diff -Nru ocaml-4.01.0/appveyor_build.sh ocaml-4.05.0/appveyor_build.sh --- ocaml-4.01.0/appveyor_build.sh 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/appveyor_build.sh 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,95 @@ +#!/bin/bash +#************************************************************************** +#* * +#* OCaml * +#* * +#* Christophe Troestler * +#* * +#* Copyright 2015 Christophe Troestler * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +function run { + NAME=$1 + shift + echo "-=-=- $NAME -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-" + $@ + CODE=$? + if [ $CODE -ne 0 ]; then + echo "-=-=- $NAME failed! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-" + exit $CODE + else + echo "-=-=- End of $NAME -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-" + fi +} + +PREFIX="C:/Program Files/OCaml" + +wmic cpu get name + +if [[ $1 = "msvc32-only" ]] ; then + cd $APPVEYOR_BUILD_FOLDER/flexdll-0.35 + make MSVC_DETECT=0 CHAINS=msvc MSVC_FLAGS="-nologo -MD -D_CRT_NO_DEPRECATE -GS- -WX" support + cp flexdll*_msvc.obj "$PREFIX/bin/flexdll" + + cd $APPVEYOR_BUILD_FOLDER/../build-msvc32 + cp config/m-nt.h config/m.h + cp config/s-nt.h config/s.h + + eval $(tools/msvs-promote-path) + + PREFIX="C:/Program Files/OCaml-msmvc32" + echo "Edit config/Makefile to set PREFIX=$PREFIX" + sed -e "s|PREFIX=.*|PREFIX=$PREFIX|" -e "/\(BYTE\|NATIVE\)CCCOMPOPTS=./s/\r\?$/ -WX\0/" config/Makefile.msvc > config/Makefile + + run "make world" make world + run "make runtimeopt" make runtimeopt + run "make -C otherlibs/systhreads libthreadsnat.lib" make -C otherlibs/systhreads libthreadsnat.lib + + exit 0 +fi + +cd $APPVEYOR_BUILD_FOLDER + +git worktree add ../build-mingw32 -b appveyor-build-mingw32 +git worktree add ../build-msvc32 -b appveyor-build-msvc32 + +cd ../build-mingw32 +git submodule update --init flexdll + +cd $APPVEYOR_BUILD_FOLDER + +tar -xzf flexdll.tar.gz +cd flexdll-0.35 +make MSVC_DETECT=0 CHAINS=msvc64 support +cp flexdll*_msvc64.obj "$PREFIX/bin/flexdll" +cd .. + +cp config/m-nt.h config/m.h +cp config/s-nt.h config/s.h + +echo "Edit config/Makefile to set PREFIX=$PREFIX" +sed -e "s|PREFIX=.*|PREFIX=$PREFIX|" -e "/\(BYTE\|NATIVE\)CCCOMPOPTS=./s/\r\?$/ -WX\0/" config/Makefile.msvc64 > config/Makefile +#run "Content of config/Makefile" cat config/Makefile + +run "make world" make world +run "make bootstrap" make bootstrap +run "make opt" make opt +run "make opt.opt" make opt.opt + +cd ../build-mingw32 + +cp config/m-nt.h config/m.h +cp config/s-nt.h config/s.h + +PREFIX="C:/Program Files/OCaml-mingw32" +echo "Edit config/Makefile to set PREFIX=$PREFIX" +sed -e "s|PREFIX=.*|PREFIX=$PREFIX|" -e "/\(BYTE\|NATIVE\)CCCOMPOPTS=./s/\r\?$/ -Werror\0/" config/Makefile.mingw > config/Makefile +#run "Content of config/Makefile" cat config/Makefile + +run "make flexdll" make flexdll +run "make world.opt" make world.opt diff -Nru ocaml-4.01.0/appveyor.yml ocaml-4.05.0/appveyor.yml --- ocaml-4.01.0/appveyor.yml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/appveyor.yml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,81 @@ +#************************************************************************** +#* * +#* OCaml * +#* * +#* Christophe Troestler * +#* * +#* Copyright 2015 Christophe Troestler * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +# Compile the 64 bits version +platform: + - x64 + +image: Visual Studio 2015 + +branches: + only: + - trunk + - 4.05 + +# Do a shallow clone of the repo to speed up the build +clone_depth: 1 + +environment: + global: + CYG_ROOT: C:/cygwin64 + CYG_MIRROR: http://mirrors.kernel.org/sourceware/cygwin/ + CYG_CACHE: C:/cygwin64/var/cache/setup + OCAMLRUNPARAM: v=0,b + OCAMLROOT: "%PROGRAMFILES%/OCaml" + OCAMLROOT2: "%PROGRAMFILES%/OCaml-mingw32" + +cache: + - C:\cygwin64\var\cache\setup + +install: + - mkdir "%OCAMLROOT%/bin/flexdll" + - appveyor DownloadFile "http://alain.frisch.fr/flexdll/flexdll-bin-0.35.zip" -FileName "flexdll.zip" + - appveyor DownloadFile "http://alain.frisch.fr/flexdll/flexdll-0.35.tar.gz" -FileName "flexdll.tar.gz" + - cinst 7zip.commandline + - mkdir flexdll-tmp + - cd flexdll-tmp + - 7za x -y ..\flexdll.zip + - for %%F in (flexdll.h flexlink.exe default_amd64.manifest) do copy %%F "%OCAMLROOT%\bin\flexdll" + - cd .. + # Make sure the Cygwin path comes before the Git one (otherwise + # cygpath behaves crazily), but after the MSVC one. + - set Path=C:\cygwin64\bin;%OCAMLROOT%\bin\flexdll;%Path% + - '%CYG_ROOT%\bin\bash -lc "cygcheck -dc cygwin"' + - '"%CYG_ROOT%\setup-x86_64.exe" -qgnNdO -R "%CYG_ROOT%" -s "%CYG_MIRROR%" -l "%CYG_CACHE%" -P diffutils -P make -P mingw64-i686-gcc-core >NUL' + - '%CYG_ROOT%\bin\bash -lc "cygcheck -dc cygwin"' + - set OCAML_PREV_PATH=%PATH% + - set OCAML_PREV_LIB=%LIB% + - set OCAML_PREV_INCLUDE=%INCLUDE% + - call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat" + +build_script: + - "%CYG_ROOT%/bin/bash -lc \"echo 'eval $($APPVEYOR_BUILD_FOLDER/tools/msvs-promote-path)' >> ~/.bash_profile\"" + - '%CYG_ROOT%/bin/bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh"' + - set PATH=%OCAML_PREV_PATH% + - set LIB=%OCAML_PREV_LIB% + - set INCLUDE=%OCAML_PREV_INCLUDE% + - call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86 + - '%CYG_ROOT%/bin/bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh msvc32-only"' + +test_script: + - set PATH=%OCAML_PREV_PATH% + - set LIB=%OCAML_PREV_LIB% + - set INCLUDE=%OCAML_PREV_INCLUDE% + - call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat" + - '%APPVEYOR_BUILD_FOLDER%\ocamlc.opt -version' + - set CAML_LD_LIBRARY_PATH=%OCAMLROOT%/lib/stublibs + - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && make tests"' + - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER/../build-mingw32 && make tests"' + - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && make install"' + - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER/../build-mingw32 && make install"' diff -Nru ocaml-4.01.0/asmcomp/afl_instrument.ml ocaml-4.05.0/asmcomp/afl_instrument.ml --- ocaml-4.01.0/asmcomp/afl_instrument.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/afl_instrument.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,94 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Stephen Dolan, University of Cambridge *) +(* *) +(* Copyright 2016 Stephen Dolan. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Insert instrumentation for afl-fuzz *) + +open Lambda +open Cmm + +let afl_area_ptr = Cconst_symbol "caml_afl_area_ptr" +let afl_prev_loc = Cconst_symbol "caml_afl_prev_loc" +let afl_map_size = 1 lsl 16 + +let rec with_afl_logging b = + if !Clflags.afl_inst_ratio < 100 && + Random.int 100 >= !Clflags.afl_inst_ratio then instrument b else + let instrumentation = + (* The instrumentation that afl-fuzz requires is: + + cur_location = ; + shared_mem[cur_location ^ prev_location]++; + prev_location = cur_location >> 1; + + See http://lcamtuf.coredump.cx/afl/technical_details.txt or + docs/technical_details.txt in afl-fuzz source for for a full + description of what's going on. *) + let cur_location = Random.int afl_map_size in + let cur_pos = Ident.create "pos" in + let afl_area = Ident.create "shared_mem" in + let op oper args = Cop (oper, args, Debuginfo.none) in + Clet(afl_area, op (Cload (Word_int, Asttypes.Mutable)) [afl_area_ptr], + Clet(cur_pos, op Cxor [op (Cload (Word_int, Asttypes.Mutable)) + [afl_prev_loc]; Cconst_int cur_location], + Csequence( + op (Cstore(Byte_unsigned, Assignment)) + [op Cadda [Cvar afl_area; Cvar cur_pos]; + op Cadda [op (Cload (Byte_unsigned, Asttypes.Mutable)) + [op Cadda [Cvar afl_area; Cvar cur_pos]]; + Cconst_int 1]], + op (Cstore(Word_int, Assignment)) + [afl_prev_loc; Cconst_int (cur_location lsr 1)]))) in + Csequence(instrumentation, instrument b) + +and instrument = function + (* these cases add logging, as they may be targets of conditional branches *) + | Cifthenelse (cond, t, f) -> + Cifthenelse (instrument cond, with_afl_logging t, with_afl_logging f) + | Cloop e -> + Cloop (with_afl_logging e) + | Ctrywith (e, ex, handler) -> + Ctrywith (instrument e, ex, with_afl_logging handler) + | Cswitch (e, cases, handlers, dbg) -> + Cswitch (instrument e, cases, Array.map with_afl_logging handlers, dbg) + + (* these cases add no logging, but instrument subexpressions *) + | Clet (v, e, body) -> Clet (v, instrument e, instrument body) + | Cassign (v, e) -> Cassign (v, instrument e) + | Ctuple es -> Ctuple (List.map instrument es) + | Cop (op, es, dbg) -> Cop (op, List.map instrument es, dbg) + | Csequence (e1, e2) -> Csequence (instrument e1, instrument e2) + | Ccatch (isrec, cases, body) -> + Ccatch (isrec, + List.map (fun (nfail, ids, e) -> nfail, ids, instrument e) cases, + instrument body) + | Cexit (ex, args) -> Cexit (ex, List.map instrument args) + + (* these are base cases and have no logging *) + | Cconst_int _ | Cconst_natint _ | Cconst_float _ + | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ + | Cblockheader _ | Cvar _ as c -> c + +let instrument_function c = + with_afl_logging c + +let instrument_initialiser c = + (* Each instrumented module calls caml_setup_afl at + initialisation, which is a no-op on the second and subsequent + calls *) + with_afl_logging + (Csequence + (Cop (Cextcall ("caml_setup_afl", typ_int, false, None), + [Cconst_int 0], + Debuginfo.none), + c)) diff -Nru ocaml-4.01.0/asmcomp/afl_instrument.mli ocaml-4.05.0/asmcomp/afl_instrument.mli --- ocaml-4.01.0/asmcomp/afl_instrument.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/afl_instrument.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,4 @@ +(* Instrumentation for afl-fuzz *) + +val instrument_function : Cmm.expression -> Cmm.expression +val instrument_initialiser : Cmm.expression -> Cmm.expression diff -Nru ocaml-4.01.0/asmcomp/amd64/arch.ml ocaml-4.05.0/asmcomp/amd64/arch.ml --- ocaml-4.01.0/asmcomp/amd64/arch.ml 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/asmcomp/amd64/arch.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,23 +1,24 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Machine-specific command-line options *) -let pic_code = ref true - let command_line_options = - [ "-fPIC", Arg.Set pic_code, + [ "-fPIC", Arg.Set Clflags.pic_code, " Generate position-independent machine code (default)"; - "-fno-PIC", Arg.Clear pic_code, + "-fno-PIC", Arg.Clear Clflags.pic_code, " Generate position-dependent machine code" ] (* Specific operations for the AMD64 processor *) @@ -33,8 +34,8 @@ type specific_operation = Ilea of addressing_mode (* "lea" gives scaled adds *) - | Istore_int of nativeint * addressing_mode (* Store an integer constant *) - | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Istore_int of nativeint * addressing_mode * bool + (* Store an integer constant *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ifloatarithmem of float_operation * addressing_mode (* Float arith operation with memory *) @@ -44,6 +45,8 @@ and float_operation = Ifloatadd | Ifloatsub | Ifloatmul | Ifloatdiv +let spacetime_node_hole_pointer_is_live_before _specific_op = false + (* Sizes, endianness *) let big_endian = false @@ -71,11 +74,11 @@ | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta) let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 - | Iindexed2 n -> 2 - | Iscaled(scale, n) -> 1 - | Iindexed2scaled(scale, n) -> 2 + Ibased _ -> 0 + | Iindexed _ -> 1 + | Iindexed2 _ -> 2 + | Iscaled _ -> 1 + | Iindexed2scaled _ -> 2 (* Printing operations and addressing modes *) @@ -101,10 +104,10 @@ let print_specific_operation printreg op ppf arg = match op with | Ilea addr -> print_addressing printreg addr ppf arg - | Istore_int(n, addr) -> - fprintf ppf "[%a] := %nd" (print_addressing printreg addr) arg n - | Istore_symbol(lbl, addr) -> - fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl + | Istore_int(n, addr, is_assign) -> + fprintf ppf "[%a] := %nd %s" + (print_addressing printreg addr) arg n + (if is_assign then "(assign)" else "(init)") | Ioffset_loc(n, addr) -> fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n | Isqrtf -> @@ -123,3 +126,8 @@ (Array.sub arg 1 (Array.length arg - 1)) | Ibswap i -> fprintf ppf "bswap_%i %a" i printreg arg.(0) + +let win64 = + match Config.system with + | "win64" | "mingw64" | "cygwin" -> true + | _ -> false diff -Nru ocaml-4.01.0/asmcomp/amd64/CSE.ml ocaml-4.05.0/asmcomp/amd64/CSE.ml --- ocaml-4.01.0/asmcomp/amd64/CSE.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/amd64/CSE.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,41 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* CSE for the AMD64 *) + +open Arch +open Mach +open CSEgen + +class cse = object + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific spec -> + begin match spec with + | Ilea _ -> Op_pure + | Istore_int(_, _, is_asg) -> Op_store is_asg + | Ioffset_loc(_, _) -> Op_store true + | Ifloatarithmem _ | Ifloatsqrtf _ -> Op_load + | Ibswap _ | Isqrtf -> super#class_of_operation op + end + | _ -> super#class_of_operation op + +end + +let fundecl f = + (new cse)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/amd64/emit.mlp ocaml-4.05.0/asmcomp/amd64/emit.mlp --- ocaml-4.01.0/asmcomp/amd64/emit.mlp 2013-06-03 18:03:59.000000000 +0000 +++ ocaml-4.05.0/asmcomp/amd64/emit.mlp 2017-07-13 08:56:44.000000000 +0000 @@ -1,17 +1,22 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +# 2 "asmcomp/amd64/emit.mlp" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) -(* Emission of x86-64 (AMD 64) assembly code *) +(* Emission of Intel x86_64 assembly code *) +open Misc open Cmm open Arch open Proc @@ -20,8 +25,43 @@ open Linearize open Emitaux -let macosx = (Config.system = "macosx") -let mingw64 = (Config.system = "mingw64") +open X86_ast +open X86_proc +open X86_dsl + +(* [Branch_relaxation] is not used in this file, but is required by + emit.mlp files for certain other targets; the reference here ensures + that when releases are being prepared the .depend files are correct + for all targets. *) +open! Branch_relaxation + +let _label s = D.label ~typ:QWORD s + +(* Override proc.ml *) + +let int_reg_name = + [| RAX; RBX; RDI; RSI; RDX; RCX; R8; R9; + R12; R13; R10; R11; RBP; |] + +let float_reg_name = Array.init 16 (fun i -> XMM i) + +let register_name r = + if r < 100 then Reg64 (int_reg_name.(r)) + else Regf (float_reg_name.(r - 100)) + +(* CFI directives *) + +let cfi_startproc () = + if Config.asm_cfi_supported then D.cfi_startproc () + +let cfi_endproc () = + if Config.asm_cfi_supported then D.cfi_endproc () + +let cfi_adjust_cfa_offset n = + if Config.asm_cfi_supported then D.cfi_adjust_cfa_offset n + +let emit_debug_info dbg = + emit_debug_info_gen dbg D.file D.loc let fp = Config.with_frame_pointers @@ -40,14 +80,14 @@ if frame_required() then begin let sz = (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8 - + (if fp then 8 else 0) ) + + (if fp then 8 else 0)) in Misc.align sz 16 end else !stack_offset + 8 let slot_offset loc cl = match loc with - Incoming n -> frame_size() + n + | Incoming n -> frame_size() + n | Local n -> if cl = 0 then !stack_offset + n * 8 @@ -56,220 +96,301 @@ (* Symbols *) -let emit_symbol s = - if macosx then emit_string "_"; - Emitaux.emit_symbol '$' s - -let emit_call s = - if !Clflags.dlcode && not macosx && not mingw64 - then `call {emit_symbol s}@PLT` - else `call {emit_symbol s}` - -let emit_jump s = - if !Clflags.dlcode && not macosx && not mingw64 - then `jmp {emit_symbol s}@PLT` - else `jmp {emit_symbol s}` - -let load_symbol_addr s = - if !Clflags.dlcode && not mingw64 - then `movq {emit_symbol s}@GOTPCREL(%rip)` - else if !pic_code - then `leaq {emit_symbol s}(%rip)` - else `movq ${emit_symbol s}` +let symbol_prefix = if system = S_macosx then "_" else "" + +let emit_symbol s = string_of_symbol symbol_prefix s + +(* Record symbols used and defined - at the end generate extern for those + used but not defined *) + +let symbols_defined = ref StringSet.empty +let symbols_used = ref StringSet.empty + +let add_def_symbol s = symbols_defined := StringSet.add s !symbols_defined +let add_used_symbol s = symbols_used := StringSet.add s !symbols_used + +let imp_table = Hashtbl.create 16 + +let reset_imp_table () = Hashtbl.clear imp_table + +let get_imp_symbol s = + match Hashtbl.find imp_table s with + | exception Not_found -> + let imps = "__caml_imp_" ^ s in + Hashtbl.add imp_table s imps; + imps + | imps -> imps + +let emit_imp_table () = + let f s imps = + _label (emit_symbol imps); + D.qword (ConstLabel (emit_symbol s)) + in + D.data(); + D.comment "relocation table start"; + D.align 8; + Hashtbl.iter f imp_table; + D.comment "relocation table end" + +let mem__imp s = + let imp_s = get_imp_symbol s in + mem64_rip QWORD (emit_symbol imp_s) + +let rel_plt s = + if windows && !Clflags.dlcode then mem__imp s + else + let use_plt = + match system with + | S_macosx | S_mingw64 | S_cygwin | S_win64 -> false + | _ -> !Clflags.dlcode + in + sym (if use_plt then emit_symbol s ^ "@PLT" else emit_symbol s) + +let emit_call s = I.call (rel_plt s) + +let emit_jump s = I.jmp (rel_plt s) + +let load_symbol_addr s arg = + if !Clflags.dlcode then + if windows then begin + (* I.mov (mem__imp s) arg (\* mov __caml_imp_foo(%rip), ... *\) *) + I.mov (sym (emit_symbol s)) arg (* movabsq $foo, ... *) + end else I.mov (mem64_rip QWORD (emit_symbol s ^ "@GOTPCREL")) arg + else if !Clflags.pic_code then + I.lea (mem64_rip NONE (emit_symbol s)) arg + else + I.mov (sym (emit_symbol s)) arg (* Output a label *) let emit_label lbl = - emit_string ".L"; emit_int lbl - -let emit_data_label lbl = - emit_string ".Ld"; emit_int lbl + match system with + | S_macosx | S_win64 -> "L" ^ string_of_int lbl + | _ -> ".L" ^ string_of_int lbl -(* Output a .align directive. *) +let label s = sym (emit_label s) -let emit_align n = - let n = if macosx then Misc.log2 n else n in - ` .align {emit_int n}\n` +let def_label s = D.label (emit_label s) let emit_Llabel fallthrough lbl = - if not fallthrough && !fastcode_flag then emit_align 4; - emit_label lbl + if not fallthrough && !fastcode_flag then D.align 4; + def_label lbl (* Output a pseudo-register *) -let emit_reg = function - { loc = Reg r } -> - emit_string (register_name r) +let reg = function + | { loc = Reg.Reg r } -> register_name r + | { loc = Stack s; typ = Float } as r -> + let ofs = slot_offset s (register_class r) in + mem64 REAL8 ofs RSP | { loc = Stack s } as r -> let ofs = slot_offset s (register_class r) in - `{emit_int ofs}(%rsp)` + mem64 QWORD ofs RSP | { loc = Unknown } -> assert false +let reg64 = function + | { loc = Reg.Reg r } -> int_reg_name.(r) + | _ -> assert false + + +let res i n = reg i.res.(n) + +let arg i n = reg i.arg.(n) + (* Output a reference to the lower 8, 16 or 32 bits of a register *) -let reg_low_8_name = - [| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b"; - "%r12b"; "%r13b"; "%r10b"; "%r11b"; "%bpl" |] -let reg_low_16_name = - [| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w"; - "%r12w"; "%r13w"; "%r10w"; "%r11w"; "%bp" |] -let reg_low_32_name = - [| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d"; - "%r12d"; "%r13d"; "%r10d"; "%r11d"; "%ebp" |] +let reg_low_8_name = Array.map (fun r -> Reg8L r) int_reg_name +let reg_low_16_name = Array.map (fun r -> Reg16 r) int_reg_name +let reg_low_32_name = Array.map (fun r -> Reg32 r) int_reg_name -let emit_subreg tbl r = +let emit_subreg tbl typ r = match r.loc with - Reg r when r < 13 -> - emit_string tbl.(r) - | Stack s -> - let ofs = slot_offset s (register_class r) in - `{emit_int ofs}(%rsp)` - | _ -> - assert false + | Reg.Reg r when r < 13 -> tbl.(r) + | Stack s -> mem64 typ (slot_offset s (register_class r)) RSP + | _ -> assert false -let emit_reg8 r = emit_subreg reg_low_8_name r -let emit_reg16 r = emit_subreg reg_low_16_name r -let emit_reg32 r = emit_subreg reg_low_32_name r +let arg8 i n = emit_subreg reg_low_8_name BYTE i.arg.(n) +let arg16 i n = emit_subreg reg_low_16_name WORD i.arg.(n) +let arg32 i n = emit_subreg reg_low_32_name DWORD i.arg.(n) +let arg64 i n = reg64 i.arg.(n) + +let res16 i n = emit_subreg reg_low_16_name WORD i.res.(n) +let res32 i n = emit_subreg reg_low_32_name DWORD i.res.(n) (* Output an addressing mode *) -let emit_addressing addr r n = +let addressing addr typ i n = match addr with - | Ibased _ when !Clflags.dlcode -> assert false - | Ibased(s, d) -> - `{emit_symbol s}`; - if d <> 0 then ` + {emit_int d}`; - `(%rip)` + | Ibased(s, ofs) -> + add_used_symbol s; + mem64_rip typ (emit_symbol s) ~ofs | Iindexed d -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)})` + mem64 typ d (arg64 i n) | Iindexed2 d -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)}, {emit_reg r.(n+1)})` + mem64 typ ~base:(arg64 i n) d (arg64 i (n+1)) | Iscaled(2, d) -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)}, {emit_reg r.(n)})` + mem64 typ ~base:(arg64 i n) d (arg64 i n) | Iscaled(scale, d) -> - if d <> 0 then emit_int d; - `(, {emit_reg r.(n)}, {emit_int scale})` + mem64 typ ~scale d (arg64 i n) | Iindexed2scaled(scale, d) -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)}, {emit_reg r.(n+1)}, {emit_int scale})` + mem64 typ ~scale ~base:(arg64 i n) d (arg64 i (n+1)) (* Record live pointers at call points -- see Emitaux *) -let record_frame_label live dbg = - let lbl = new_label() in +let record_frame_label ?label live raise_ dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function - {typ = Addr; loc = Reg r} -> + | {typ = Val; loc = Reg r} -> live_offset := ((r lsl 1) + 1) :: !live_offset - | {typ = Addr; loc = Stack s} as reg -> + | {typ = Val; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset - | _ -> ()) + | {typ = Addr} as r -> + Misc.fatal_error ("bad GC root " ^ Reg.name r) + | _ -> () + ) live; - frame_descriptors := - { fd_lbl = lbl; - fd_frame_size = frame_size(); - fd_live_offset = !live_offset; - fd_debuginfo = dbg } :: !frame_descriptors; + record_frame_descr ~label:lbl ~frame_size:(frame_size()) + ~live_offset:!live_offset ~raise_frame:raise_ dbg; lbl -let record_frame live dbg = - let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` +let record_frame ?label live raise_ dbg = + let lbl = record_frame_label ?label live raise_ dbg in + def_label lbl + +(* Spacetime instrumentation *) + +let spacetime_before_uninstrumented_call ~node_ptr ~index = + (* At the moment, [node_ptr] is pointing at the node for the current + OCaml function. Get hold of the node itself and move the pointer + forwards, saving it into the distinguished register. This is used + for instrumentation of function calls (e.g. caml_call_gc and bounds + check failures) not inserted until this stage of the compiler + pipeline. *) + I.mov node_ptr (reg Proc.loc_spacetime_node_hole); + assert (index >= 2); + I.add (int (index * 8)) (reg Proc.loc_spacetime_node_hole) (* Record calls to the GC -- we've moved them out of the way *) type gc_call = { gc_lbl: label; (* Entry label *) gc_return_lbl: label; (* Where to branch after GC *) - gc_frame: label } (* Label of frame descriptor *) + gc_frame: label; (* Label of frame descriptor *) + gc_spacetime : (X86_ast.arg * int) option; + (* Spacetime node hole pointer and index *) + } let call_gc_sites = ref ([] : gc_call list) let emit_call_gc gc = - `{emit_label gc.gc_lbl}: {emit_call "caml_call_gc"}\n`; - `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` + def_label gc.gc_lbl; + begin match gc.gc_spacetime with + | None -> assert (not Config.spacetime) + | Some (node_ptr, index) -> + assert Config.spacetime; + spacetime_before_uninstrumented_call ~node_ptr ~index + end; + emit_call "caml_call_gc"; + def_label gc.gc_frame; + I.jmp (label gc.gc_return_lbl) (* Record calls to caml_ml_array_bound_error. - In -g mode, we maintain one call to caml_ml_array_bound_error - per bound check site. Without -g, we can share a single call. *) + In -g mode, or when using Spacetime profiling, we maintain one call to + caml_ml_array_bound_error per bound check site. Without -g, we can share + a single call. *) type bound_error_call = { bd_lbl: label; (* Entry label *) - bd_frame: label } (* Label of frame descriptor *) + bd_frame: label; (* Label of frame descriptor *) + bd_spacetime : (X86_ast.arg * int) option; + (* As for [gc_call]. *) + } let bound_error_sites = ref ([] : bound_error_call list) let bound_error_call = ref 0 -let bound_error_label dbg = - if !Clflags.debug then begin +let bound_error_label ?label dbg ~spacetime = + if !Clflags.debug || Config.spacetime then begin let lbl_bound_error = new_label() in - let lbl_frame = record_frame_label Reg.Set.empty dbg in + let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in bound_error_sites := - { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; - lbl_bound_error - end else begin - if !bound_error_call = 0 then bound_error_call := new_label(); - !bound_error_call - end + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame; + bd_spacetime = spacetime; } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end let emit_call_bound_error bd = - `{emit_label bd.bd_lbl}: {emit_call "caml_ml_array_bound_error"}\n`; - `{emit_label bd.bd_frame}:\n` + def_label bd.bd_lbl; + begin match bd.bd_spacetime with + | None -> () + | Some (node_ptr, index) -> + spacetime_before_uninstrumented_call ~node_ptr ~index + end; + emit_call "caml_ml_array_bound_error"; + def_label bd.bd_frame let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; - if !bound_error_call > 0 then - `{emit_label !bound_error_call}: {emit_call "caml_ml_array_bound_error"}\n` + if !bound_error_call > 0 then begin + def_label !bound_error_call; + emit_call "caml_ml_array_bound_error" + end (* Names for instructions *) let instr_for_intop = function - Iadd -> "addq" - | Isub -> "subq" - | Imul -> "imulq" - | Iand -> "andq" - | Ior -> "orq" - | Ixor -> "xorq" - | Ilsl -> "salq" - | Ilsr -> "shrq" - | Iasr -> "sarq" + | Iadd -> I.add + | Isub -> I.sub + | Imul -> (fun arg1 arg2 -> I.imul arg1 (Some arg2)) + | Iand -> I.and_ + | Ior -> I.or_ + | Ixor -> I.xor + | Ilsl -> I.sal + | Ilsr -> I.shr + | Iasr -> I.sar | _ -> assert false let instr_for_floatop = function - Iaddf -> "addsd" - | Isubf -> "subsd" - | Imulf -> "mulsd" - | Idivf -> "divsd" + | Iaddf -> I.addsd + | Isubf -> I.subsd + | Imulf -> I.mulsd + | Idivf -> I.divsd | _ -> assert false let instr_for_floatarithmem = function - Ifloatadd -> "addsd" - | Ifloatsub -> "subsd" - | Ifloatmul -> "mulsd" - | Ifloatdiv -> "divsd" - -let name_for_cond_branch = function - Isigned Ceq -> "e" | Isigned Cne -> "ne" - | Isigned Cle -> "le" | Isigned Cgt -> "g" - | Isigned Clt -> "l" | Isigned Cge -> "ge" - | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" - | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" - | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" + | Ifloatadd -> I.addsd + | Ifloatsub -> I.subsd + | Ifloatmul -> I.mulsd + | Ifloatdiv -> I.divsd + +let cond = function + | Isigned Ceq -> E | Isigned Cne -> NE + | Isigned Cle -> LE | Isigned Cgt -> G + | Isigned Clt -> L | Isigned Cge -> GE + | Iunsigned Ceq -> E | Iunsigned Cne -> NE + | Iunsigned Cle -> BE | Iunsigned Cgt -> A + | Iunsigned Clt -> B | Iunsigned Cge -> AE (* Output an = 0 or <> 0 test. *) let output_test_zero arg = match arg.loc with - Reg r -> ` testq {emit_reg arg}, {emit_reg arg}\n` - | _ -> ` cmpq $0, {emit_reg arg}\n` + | Reg.Reg _ -> I.test (reg arg) (reg arg) + | _ -> I.cmp (int 0) (reg arg) (* Output a floating-point compare and branch *) -let emit_float_test cmp neg arg lbl = +let emit_float_test cmp neg i lbl = (* Effect of comisd on flags and conditional branches: ZF PF CF cond. branches taken unordered 1 1 1 je, jb, jbe, jp @@ -282,72 +403,73 @@ match (cmp, neg) with | (Ceq, false) | (Cne, true) -> let next = new_label() in - ` ucomisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; - ` jp {emit_label next}\n`; (* skip if unordered *) - ` je {emit_label lbl}\n`; (* branch taken if x=y *) - `{emit_label next}:\n` + I.ucomisd (arg i 1) (arg i 0); + I.jp (label next); (* skip if unordered *) + I.je lbl; (* branch taken if x=y *) + def_label next | (Cne, false) | (Ceq, true) -> - ` ucomisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; - ` jp {emit_label lbl}\n`; (* branch taken if unordered *) - ` jne {emit_label lbl}\n` (* branch taken if xy *) + I.ucomisd (arg i 1) (arg i 0); + I.jp lbl; (* branch taken if unordered *) + I.jne lbl (* branch taken if xy *) | (Clt, _) -> - ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *) - if not neg then - ` ja {emit_label lbl}\n` (* branch taken if y>x i.e. xx i.e. x - ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *) - if not neg then - ` jae {emit_label lbl}\n` (* branch taken if y>=x i.e. x<=y *) - else - ` jb {emit_label lbl}\n` (* taken if unordered or y=x i.e. x<=y *) + else I.jb lbl (* taken if unordered or y - ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; - if not neg then - ` ja {emit_label lbl}\n` (* branch taken if x>y *) - else - ` jbe {emit_label lbl}\n` (* taken if unordered or x<=y i.e. !(x>y) *) + I.comisd (arg i 1) (arg i 0); + if not neg then I.ja lbl (* branch taken if x>y *) + else I.jbe lbl (* taken if unordered or x<=y i.e. !(x>y) *) | (Cge, _) -> - ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; (* swap compare *) - if not neg then - ` jae {emit_label lbl}\n` (* branch taken if x>=y *) - else - ` jb {emit_label lbl}\n` (* taken if unordered or x=y) *) + I.comisd (arg i 1) (arg i 0);(* swap compare *) + if not neg then I.jae lbl (* branch taken if x>=y *) + else I.jb lbl (* taken if unordered or x=y) *) (* Deallocate the stack frame before a return or tail call *) let output_epilogue f = if frame_required() then begin let n = frame_size() - 8 - (if fp then 8 else 0) in - ` addq ${emit_int n}, %rsp\n`; - cfi_adjust_cfa_offset (-n); - if fp then begin - ` popq %rbp\n` + if n <> 0 + then begin + I.add (int n) rsp; + cfi_adjust_cfa_offset (-n); end; + if fp then I.pop rbp; f (); (* reset CFA back cause function body may continue *) - cfi_adjust_cfa_offset n + if n <> 0 + then cfi_adjust_cfa_offset n end else f () (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = try List.assoc cst !float_constants - with - Not_found -> - let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; - lbl - -let emit_float_constant (cst, lbl) = - `{emit_label lbl}:`; - emit_float64_directive ".quad" cst + with Not_found -> + let lbl = new_label() in + float_constants := (cst, lbl) :: !float_constants; + lbl + +let emit_float_constant f lbl = + _label (emit_label lbl); + D.qword (Const f) + +let emit_global_label s = + let lbl = Compilenv.make_symbol (Some s) in + add_def_symbol lbl; + let lbl = emit_symbol lbl in + D.global lbl; + _label lbl + (* Output the assembly code for an instruction *) @@ -358,335 +480,384 @@ (* Emit an instruction *) let emit_instr fallthrough i = - emit_debug_info i.dbg; - match i.desc with - Lend -> () - | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin - match src.typ, src.loc, dst.loc with - Float, Reg _, Reg _ -> - ` movapd {emit_reg src}, {emit_reg dst}\n` - | Float, _, _ -> - ` movsd {emit_reg src}, {emit_reg dst}\n` - | _ -> - ` movq {emit_reg src}, {emit_reg dst}\n` - end - | Lop(Iconst_int n) -> - if n = 0n then begin - match i.res.(0).loc with - Reg n -> ` xorq {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | _ -> ` movq $0, {emit_reg i.res.(0)}\n` - end else if n <= 0x7FFFFFFFn && n >= -0x80000000n then - ` movq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - else - ` movabsq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with - | 0x0000_0000_0000_0000L -> (* +0.0 *) - ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | _ -> - let lbl = add_float_constant s in - ` movsd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n` + emit_debug_info i.dbg; + match i.desc with + | Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then + begin match src.typ, src.loc, dst.loc with + | Float, Reg.Reg _, Reg.Reg _ -> I.movapd (reg src) (reg dst) + | Float, _, _ -> I.movsd (reg src) (reg dst) + | _ -> I.mov (reg src) (reg dst) end - | Lop(Iconst_symbol s) -> - ` {load_symbol_addr s}, {emit_reg i.res.(0)}\n` - | Lop(Icall_ind) -> - ` call *{emit_reg i.arg.(0)}\n`; - record_frame i.live i.dbg - | Lop(Icall_imm(s)) -> - ` {emit_call s}\n`; - record_frame i.live i.dbg - | Lop(Itailcall_ind) -> - output_epilogue begin fun () -> - ` jmp *{emit_reg i.arg.(0)}\n` + | Lop(Iconst_int n) -> + if n = 0n then begin + match i.res.(0).loc with + | Reg _ -> I.xor (res i 0) (res i 0) + | _ -> I.mov (int 0) (res i 0) + end + else + I.mov (nat n) (res i 0) + | Lop(Iconst_float f) -> + begin match f with + | 0x0000_0000_0000_0000L -> (* +0.0 *) + I.xorpd (res i 0) (res i 0) + | _ -> + let lbl = add_float_constant f in + I.movsd (mem64_rip NONE (emit_label lbl)) (res i 0) + end + | Lop(Iconst_symbol s) -> + add_used_symbol s; + load_symbol_addr s (res i 0) + | Lop(Icall_ind { label_after; }) -> + I.call (arg i 0); + record_frame i.live false i.dbg ~label:label_after + | Lop(Icall_imm { func; label_after; }) -> + add_used_symbol func; + emit_call func; + record_frame i.live false i.dbg ~label:label_after + | Lop(Itailcall_ind { label_after; }) -> + output_epilogue begin fun () -> + I.jmp (arg i 0); + if Config.spacetime then begin + record_frame Reg.Set.empty false i.dbg ~label:label_after end - | Lop(Itailcall_imm s) -> - if s = !function_name then - ` jmp {emit_label !tailrec_entry_point}\n` + end + | Lop(Itailcall_imm { func; label_after; }) -> + begin + if func = !function_name then + I.jmp (label !tailrec_entry_point) else begin output_epilogue begin fun () -> - ` {emit_jump s}\n` + add_used_symbol func; + emit_jump func end end - | Lop(Iextcall(s, alloc)) -> - if alloc then begin - ` {load_symbol_addr s}, %rax\n`; - ` {emit_call "caml_c_call"}\n`; - record_frame i.live i.dbg; - ` {load_symbol_addr "caml_young_ptr"}, %r11\n`; - ` movq (%r11), %r15\n`; - end else begin - ` {emit_call s}\n` - end - | Lop(Istackoffset n) -> - if n < 0 - then ` addq ${emit_int(-n)}, %rsp\n` - else ` subq ${emit_int(n)}, %rsp\n`; - cfi_adjust_cfa_offset n; - stack_offset := !stack_offset + n - | Lop(Iload(chunk, addr)) -> - let dest = i.res.(0) in - begin match chunk with - | Word -> - ` movq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Byte_unsigned -> - ` movzbq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Byte_signed -> - ` movsbq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Sixteen_unsigned -> - ` movzwq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Sixteen_signed -> - ` movswq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Thirtytwo_unsigned -> - ` movl {emit_addressing addr i.arg 0}, {emit_reg32 dest}\n` - | Thirtytwo_signed -> - ` movslq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Single -> - ` cvtss2sd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Double | Double_u -> - ` movsd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + end; + if Config.spacetime then begin + record_frame Reg.Set.empty false i.dbg ~label:label_after + end + | Lop(Iextcall { func; alloc; label_after; }) -> + add_used_symbol func; + if alloc then begin + load_symbol_addr func rax; + emit_call "caml_c_call"; + record_frame i.live false i.dbg ~label:label_after; + if system <> S_win64 then begin + (* TODO: investigate why such a diff. + This comes from: + http://caml.inria.fr/cgi-bin/viewvc.cgi?view=revision&revision=12664 + + If we do the same for Win64, we probably need to change + amd64nt.asm accordingly. + *) + load_symbol_addr "caml_young_ptr" r11; + I.mov (mem64 QWORD 0 R11) r15 end - | Lop(Istore(chunk, addr)) -> - begin match chunk with - | Word -> - ` movq {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Byte_unsigned | Byte_signed -> - ` movb {emit_reg8 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Sixteen_unsigned | Sixteen_signed -> - ` movw {emit_reg16 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Thirtytwo_signed | Thirtytwo_unsigned -> - ` movl {emit_reg32 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Single -> - ` cvtsd2ss {emit_reg i.arg.(0)}, %xmm15\n`; - ` movss %xmm15, {emit_addressing addr i.arg 1}\n` - | Double | Double_u -> - ` movsd {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` + end else begin + emit_call func; + if Config.spacetime then begin + record_frame Reg.Set.empty false i.dbg ~label:label_after end - | Lop(Ialloc n) -> - if !fastcode_flag then begin - let lbl_redo = new_label() in - `{emit_label lbl_redo}: subq ${emit_int n}, %r15\n`; - if !Clflags.dlcode then begin - ` {load_symbol_addr "caml_young_limit"}, %rax\n`; - ` cmpq (%rax), %r15\n`; - end else - ` cmpq {emit_symbol "caml_young_limit"}(%rip), %r15\n`; - let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live Debuginfo.none in - ` jb {emit_label lbl_call_gc}\n`; - ` leaq 8(%r15), {emit_reg i.res.(0)}\n`; - call_gc_sites := - { gc_lbl = lbl_call_gc; - gc_return_lbl = lbl_redo; - gc_frame = lbl_frame } :: !call_gc_sites - end else begin - begin match n with - 16 -> ` {emit_call "caml_alloc1"}\n` - | 24 -> ` {emit_call "caml_alloc2"}\n` - | 32 -> ` {emit_call "caml_alloc3"}\n` - | _ -> ` movq ${emit_int n}, %rax\n`; - ` {emit_call "caml_allocN"}\n` + end + | Lop(Istackoffset n) -> + if n < 0 + then I.add (int (-n)) rsp + else if n > 0 + then I.sub (int n) rsp; + if n <> 0 + then cfi_adjust_cfa_offset n; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = res i 0 in + begin match chunk with + | Word_int | Word_val -> + I.mov (addressing addr QWORD i 0) dest + | Byte_unsigned -> + I.movzx (addressing addr BYTE i 0) dest + | Byte_signed -> + I.movsx (addressing addr BYTE i 0) dest + | Sixteen_unsigned -> + I.movzx (addressing addr WORD i 0) dest + | Sixteen_signed -> + I.movsx (addressing addr WORD i 0) dest; + | Thirtytwo_unsigned -> + I.mov (addressing addr DWORD i 0) (res32 i 0) + | Thirtytwo_signed -> + I.movsxd (addressing addr DWORD i 0) dest + | Single -> + I.cvtss2sd (addressing addr REAL4 i 0) dest + | Double | Double_u -> + I.movsd (addressing addr REAL8 i 0) dest + end + | Lop(Istore(chunk, addr, _)) -> + begin match chunk with + | Word_int | Word_val -> + I.mov (arg i 0) (addressing addr QWORD i 1) + | Byte_unsigned | Byte_signed -> + I.mov (arg8 i 0) (addressing addr BYTE i 1) + | Sixteen_unsigned | Sixteen_signed -> + I.mov (arg16 i 0) (addressing addr WORD i 1) + | Thirtytwo_signed | Thirtytwo_unsigned -> + I.mov (arg32 i 0) (addressing addr DWORD i 1) + | Single -> + I.cvtsd2ss (arg i 0) xmm15; + I.movss xmm15 (addressing addr REAL4 i 1) + | Double | Double_u -> + I.movsd (arg i 0) (addressing addr REAL8 i 1) + end + | Lop(Ialloc { words = n; label_after_call_gc; spacetime_index; }) -> + if !fastcode_flag then begin + let lbl_redo = new_label() in + def_label lbl_redo; + I.sub (int n) r15; + let spacetime_node_hole_ptr_is_in_rax = + Config.spacetime && (i.arg.(0).loc = Reg 0) + in + if !Clflags.dlcode then begin + (* When using Spacetime, %rax might be the node pointer, so we + must take care not to clobber it. (Whilst we can tell the + register allocator that %rax is destroyed by Ialloc, we can't + force that the argument (the node pointer) is not in %rax.) *) + if spacetime_node_hole_ptr_is_in_rax then begin + I.push rax end; - `{record_frame i.live Debuginfo.none} leaq 8(%r15), {emit_reg i.res.(0)}\n` - end - | Lop(Iintop(Icomp cmp)) -> - ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` set{emit_string b} %al\n`; - ` movzbq %al, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Icomp cmp, n)) -> - ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` set{emit_string b} %al\n`; - ` movzbq %al, {emit_reg i.res.(0)}\n` - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in - ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label lbl}\n` - | Lop(Iintop_imm(Icheckbound, n)) -> - let lbl = bound_error_label i.dbg in - ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label lbl}\n` - | Lop(Iintop(Idiv | Imod)) -> - ` cqto\n`; - ` idivq {emit_reg i.arg.(1)}\n` - | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> - (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *) - ` {emit_string(instr_for_intop op)} %cl, {emit_reg i.res.(0)}\n` - | Lop(Iintop op) -> - (* We have i.arg.(0) = i.res.(0) *) - ` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> - ` leaq {emit_int n}({emit_reg i.arg.(0)}), {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> - ` incq {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> - ` decq {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) - let l = Misc.log2 n in - ` movq {emit_reg i.arg.(0)}, %rax\n`; - ` addq ${emit_int(n-1)}, {emit_reg i.arg.(0)}\n`; - ` testq %rax, %rax\n`; - ` cmovns %rax, {emit_reg i.arg.(0)}\n`; - ` sarq ${emit_int l}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Imod, n)) -> - (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) - ` movq {emit_reg i.arg.(0)}, %rax\n`; - ` testq %rax, %rax\n`; - ` leaq {emit_int(n-1)}(%rax), %rax\n`; - ` cmovns {emit_reg i.arg.(0)}, %rax\n`; - ` andq ${emit_int (-n)}, %rax\n`; - ` subq %rax, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(op, n)) -> - (* We have i.arg.(0) = i.res.(0) *) - ` {emit_string(instr_for_intop op)} ${emit_int n}, {emit_reg i.res.(0)}\n` - | Lop(Inegf) -> - ` xorpd {emit_symbol "caml_negf_mask"}(%rip), {emit_reg i.res.(0)}\n` - | Lop(Iabsf) -> - ` andpd {emit_symbol "caml_absf_mask"}(%rip), {emit_reg i.res.(0)}\n` - | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) -> - ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` - | Lop(Ifloatofint) -> - ` cvtsi2sdq {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintoffloat) -> - ` cvttsd2siq {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Ilea addr)) -> - ` leaq {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> - ` movq ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> - assert (not !pic_code && not !Clflags.dlcode); - ` movq ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Ioffset_loc(n, addr))) -> - ` addq ${emit_int n}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Ifloatarithmem(op, addr))) -> - ` {emit_string(instr_for_floatarithmem op)} {emit_addressing addr i.arg 1}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Ibswap size)) -> - begin match size with - | 16 -> - ` xchg %ah, %al\n`; - ` movzwq {emit_reg16 i.res.(0)}, {emit_reg i.res.(0)}\n` - | 32 -> - ` bswap {emit_reg32 i.res.(0)}\n`; - ` movslq {emit_reg32 i.res.(0)}, {emit_reg i.res.(0)}\n` - | 64 -> - ` bswap {emit_reg i.res.(0)}\n` - | _ -> assert false - end - | Lop(Ispecific Isqrtf) -> - ` sqrtsd {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Ifloatsqrtf addr)) -> - ` sqrtsd {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` - | Lreloadretaddr -> - () - | Lreturn -> - output_epilogue begin fun () -> - ` ret\n` - end - | Llabel lbl -> - `{emit_Llabel fallthrough lbl}:\n` - | Lbranch lbl -> - ` jmp {emit_label lbl}\n` - | Lcondbranch(tst, lbl) -> - begin match tst with - Itruetest -> - output_test_zero i.arg.(0); - ` jne {emit_label lbl}\n` - | Ifalsetest -> - output_test_zero i.arg.(0); - ` je {emit_label lbl}\n` - | Iinttest cmp -> - ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | - Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> - output_test_zero i.arg.(0); - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm(cmp, n) -> - ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Ifloattest(cmp, neg) -> - emit_float_test cmp neg i.arg lbl - | Ioddtest -> - ` testb $1, {emit_reg8 i.arg.(0)}\n`; - ` jne {emit_label lbl}\n` - | Ieventest -> - ` testb $1, {emit_reg8 i.arg.(0)}\n`; - ` je {emit_label lbl}\n` - end - | Lcondbranch3(lbl0, lbl1, lbl2) -> - ` cmpq $1, {emit_reg i.arg.(0)}\n`; - begin match lbl0 with - None -> () - | Some lbl -> ` jb {emit_label lbl}\n` - end; - begin match lbl1 with - None -> () - | Some lbl -> ` je {emit_label lbl}\n` - end; - begin match lbl2 with - None -> () - | Some lbl -> ` jg {emit_label lbl}\n` - end - | Lswitch jumptbl -> - let lbl = new_label() in - (* rax and rdx are clobbered by the Lswitch, - meaning that no variable that is live across the Lswitch - is assigned to rax or rdx. However, the argument to Lswitch - can still be assigned to one of these two registers, so - we must be careful not to clobber it before use. *) - let (tmp1, tmp2) = - if i.arg.(0).loc = Reg 0 (* rax *) - then (phys_reg 4 (*rdx*), phys_reg 0 (*rax*)) - else (phys_reg 0 (*rax*), phys_reg 4 (*rdx*)) in - ` leaq {emit_label lbl}(%rip), {emit_reg tmp1}\n`; - ` movslq ({emit_reg tmp1}, {emit_reg i.arg.(0)}, 4), {emit_reg tmp2}\n`; - ` addq {emit_reg tmp2}, {emit_reg tmp1}\n`; - ` jmp *{emit_reg tmp1}\n`; - if macosx then - ` .const\n` - else if mingw64 then - ` .section .rdata,\"dr\"\n` - else - ` .section .rodata\n`; - emit_align 4; - `{emit_label lbl}:`; - for i = 0 to Array.length jumptbl - 1 do - ` .long {emit_label jumptbl.(i)} - {emit_label lbl}\n` - done; - ` .text\n` - | Lsetuptrap lbl -> - ` call {emit_label lbl}\n` - | Lpushtrap -> - cfi_adjust_cfa_offset 8; - ` pushq %r14\n`; - cfi_adjust_cfa_offset 8; - ` movq %rsp, %r14\n`; - stack_offset := !stack_offset + 16 - | Lpoptrap -> - ` popq %r14\n`; - cfi_adjust_cfa_offset (-8); - ` addq $8, %rsp\n`; - cfi_adjust_cfa_offset (-8); - stack_offset := !stack_offset - 16 - | Lraise -> - if !Clflags.debug then begin - ` {emit_call "caml_raise_exn"}\n`; - record_frame Reg.Set.empty i.dbg - end else begin - ` movq %r14, %rsp\n`; - ` popq %r14\n`; - ` ret\n` - end + load_symbol_addr "caml_young_limit" rax; + I.cmp (mem64 QWORD 0 RAX) r15; + if spacetime_node_hole_ptr_is_in_rax then begin + I.pop rax (* this does not affect the flags *) + end + end else + I.cmp (mem64_rip QWORD (emit_symbol "caml_young_limit")) r15; + let lbl_call_gc = new_label() in + let dbg = + if not Config.spacetime then Debuginfo.none + else i.dbg + in + let lbl_frame = + record_frame_label ?label:label_after_call_gc i.live false dbg + in + I.jb (label lbl_call_gc); + I.lea (mem64 NONE 8 R15) (res i 0); + let gc_spacetime = + if not Config.spacetime then None + else Some (arg i 0, spacetime_index) + in + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame = lbl_frame; + gc_spacetime; } :: !call_gc_sites + end else begin + if Config.spacetime then begin + spacetime_before_uninstrumented_call ~node_ptr:(arg i 0) + ~index:spacetime_index; + end; + begin match n with + | 16 -> emit_call "caml_alloc1" + | 24 -> emit_call "caml_alloc2" + | 32 -> emit_call "caml_alloc3" + | _ -> + I.mov (int n) rax; + emit_call "caml_allocN" + end; + let label = + record_frame_label ?label:label_after_call_gc i.live false + Debuginfo.none + in + def_label label; + I.lea (mem64 NONE 8 R15) (res i 0) + end + | Lop(Iintop(Icomp cmp)) -> + I.cmp (arg i 1) (arg i 0); + I.set (cond cmp) al; + I.movzx al (res i 0) + | Lop(Iintop_imm(Icomp cmp, n)) -> + I.cmp (int n) (arg i 0); + I.set (cond cmp) al; + I.movzx al (res i 0) + | Lop(Iintop (Icheckbound { label_after_error; spacetime_index; } )) -> + let spacetime = + if not Config.spacetime then None + else Some (arg i 2, spacetime_index) + in + let lbl = bound_error_label ?label:label_after_error i.dbg ~spacetime in + I.cmp (arg i 1) (arg i 0); + I.jbe (label lbl) + | Lop(Iintop_imm(Icheckbound { label_after_error; spacetime_index; }, n)) -> + let spacetime = + if not Config.spacetime then None + else Some (arg i 1, spacetime_index) + in + let lbl = bound_error_label ?label:label_after_error i.dbg ~spacetime in + I.cmp (int n) (arg i 0); + I.jbe (label lbl) + | Lop(Iintop(Idiv | Imod)) -> + I.cqo (); + I.idiv (arg i 1) + | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> + (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *) + instr_for_intop op cl (res i 0) + | Lop(Iintop Imulh) -> + I.imul (arg i 1) None + | Lop(Iintop op) -> + (* We have i.arg.(0) = i.res.(0) *) + instr_for_intop op (arg i 1) (res i 0) + | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> + I.lea (mem64 NONE n (arg64 i 0)) (res i 0) + | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> + I.inc (res i 0) + | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> + I.dec (res i 0) + | Lop(Iintop_imm(op, n)) -> + (* We have i.arg.(0) = i.res.(0) *) + instr_for_intop op (int n) (res i 0) + | Lop(Inegf) -> + I.xorpd (mem64_rip OWORD (emit_symbol "caml_negf_mask")) (res i 0) + | Lop(Iabsf) -> + I.andpd (mem64_rip OWORD (emit_symbol "caml_absf_mask")) (res i 0) + | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) -> + instr_for_floatop floatop (arg i 1) (res i 0) + | Lop(Ifloatofint) -> + I.cvtsi2sd (arg i 0) (res i 0) + | Lop(Iintoffloat) -> + I.cvttsd2si (arg i 0) (res i 0) + | Lop(Ispecific(Ilea addr)) -> + I.lea (addressing addr NONE i 0) (res i 0) + | Lop(Ispecific(Istore_int(n, addr, _))) -> + I.mov (nat n) (addressing addr QWORD i 0) + | Lop(Ispecific(Ioffset_loc(n, addr))) -> + I.add (int n) (addressing addr QWORD i 0) + | Lop(Ispecific(Ifloatarithmem(op, addr))) -> + instr_for_floatarithmem op (addressing addr REAL8 i 1) (res i 0) + | Lop(Ispecific(Ibswap 16)) -> + I.xchg ah al; + I.movzx (res16 i 0) (res i 0) + | Lop(Ispecific(Ibswap 32)) -> + I.bswap (res32 i 0); + I.movsxd (res32 i 0) (res i 0) + | Lop(Ispecific(Ibswap 64)) -> + I.bswap (res i 0) + | Lop(Ispecific(Ibswap _)) -> + assert false + | Lop(Ispecific Isqrtf) -> + I.sqrtsd (arg i 0) (res i 0) + | Lop(Ispecific(Ifloatsqrtf addr)) -> + I.sqrtsd (addressing addr REAL8 i 0) (res i 0) + | Lreloadretaddr -> + () + | Lreturn -> + output_epilogue begin fun () -> + I.ret () + end + | Llabel lbl -> + emit_Llabel fallthrough lbl + | Lbranch lbl -> + I.jmp (label lbl) + | Lcondbranch(tst, lbl) -> + let lbl = label lbl in + begin match tst with + | Itruetest -> + output_test_zero i.arg.(0); + I.jne lbl + | Ifalsetest -> + output_test_zero i.arg.(0); + I.je lbl + | Iinttest cmp -> + I.cmp (arg i 1) (arg i 0); + I.j (cond cmp) lbl + | Iinttest_imm((Isigned Ceq | Isigned Cne | + Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> + output_test_zero i.arg.(0); + I.j (cond cmp) lbl + | Iinttest_imm(cmp, n) -> + I.cmp (int n) (arg i 0); + I.j (cond cmp) lbl + | Ifloattest(cmp, neg) -> + emit_float_test cmp neg i lbl + | Ioddtest -> + I.test (int 1) (arg8 i 0); + I.jne lbl + | Ieventest -> + I.test (int 1) (arg8 i 0); + I.je lbl + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + I.cmp (int 1) (arg i 0); + begin match lbl0 with + | None -> () + | Some lbl -> I.jb (label lbl) + end; + begin match lbl1 with + | None -> () + | Some lbl -> I.je (label lbl) + end; + begin match lbl2 with + | None -> () + | Some lbl -> I.jg (label lbl) + end + | Lswitch jumptbl -> + let lbl = emit_label (new_label()) in + (* rax and rdx are clobbered by the Lswitch, + meaning that no variable that is live across the Lswitch + is assigned to rax or rdx. However, the argument to Lswitch + can still be assigned to one of these two registers, so + we must be careful not to clobber it before use. *) + let (tmp1, tmp2) = + if i.arg.(0).loc = Reg 0 (* rax *) + then (phys_reg 4 (*rdx*), phys_reg 0 (*rax*)) + else (phys_reg 0 (*rax*), phys_reg 4 (*rdx*)) in + + I.lea (mem64_rip NONE lbl) (reg tmp1); + I.movsxd (mem64 DWORD 0 (arg64 i 0) ~scale:4 ~base:(reg64 tmp1)) + (reg tmp2); + I.add (reg tmp2) (reg tmp1); + I.jmp (reg tmp1); + + begin match system with + | S_mingw64 | S_cygwin -> D.section [".rdata"] (Some "dr") [] + | S_macosx | S_win64 -> () (* with LLVM/OS X and MASM, use the text segment *) + | _ -> D.section [".rodata"] None [] + end; + D.align 4; + _label lbl; + for i = 0 to Array.length jumptbl - 1 do + D.long (ConstSub (ConstLabel(emit_label jumptbl.(i)), + ConstLabel lbl)) + done; + D.text () + | Lsetuptrap lbl -> + I.call (label lbl) + | Lpushtrap -> + cfi_adjust_cfa_offset 8; + I.push r14; + cfi_adjust_cfa_offset 8; + I.mov rsp r14; + stack_offset := !stack_offset + 16 + | Lpoptrap -> + I.pop r14; + cfi_adjust_cfa_offset (-8); + I.add (int 8) rsp; + cfi_adjust_cfa_offset (-8); + stack_offset := !stack_offset - 16 + | Lraise k -> + (* No Spacetime instrumentation is required for [caml_raise_exn] and + [caml_reraise_exn]. The only function called that might affect the + trie is [caml_stash_backtrace], and it does not. *) + begin match k with + | Cmm.Raise_withtrace -> + emit_call "caml_raise_exn"; + record_frame Reg.Set.empty true i.dbg + | Cmm.Raise_notrace -> + I.mov r14 rsp; + I.pop r14; + I.ret () + end let rec emit_all fallthrough i = match i.desc with - | Lend -> () + | Lend -> () | _ -> emit_instr fallthrough i; emit_all (Linearize.has_fallthrough i.desc) i.next @@ -694,20 +865,21 @@ (* Emission of the profiling prelude *) let emit_profile () = - match Config.system with - | "linux" | "gnu" -> - (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly - and rbx, rbp, r12-r15 like all C functions. This includes - all the registers used for argument passing, so we don't - need to preserve other regs. We do need to initialize rbp - like mcount expects it, though. *) - ` pushq %r10\n`; - if not fp then - ` movq %rsp, %rbp\n`; - ` {emit_call "mcount"}\n`; - ` popq %r10\n` - | _ -> - () (*unsupported yet*) + if system = S_gnu || system = S_linux then begin + (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly + and rbx, rbp, r12-r15 like all C functions. This includes + all the registers used for argument passing, so we don't + need to preserve other regs. We do need to initialize rbp + like mcount expects it, though. *) + I.push r10; + if not fp then I.mov rsp rbp; + (* No Spacetime instrumentation needed: [mcount] cannot call anything + OCaml-related. *) + emit_call "mcount"; + I.pop r10 + end + +let all_functions = ref [] (* Emission of a function declaration *) @@ -719,147 +891,238 @@ call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; - ` .text\n`; - emit_align 16; - if macosx + all_functions := fundecl :: !all_functions; + D.text (); + D.align 16; + add_def_symbol fundecl.fun_name; + if system = S_macosx && not !Clflags.output_c_object && is_generic_function fundecl.fun_name then (* PR#4690 *) - ` .private_extern {emit_symbol fundecl.fun_name}\n` + D.private_extern (emit_symbol fundecl.fun_name) else - ` .globl {emit_symbol fundecl.fun_name}\n`; - `{emit_symbol fundecl.fun_name}:\n`; + D.global (emit_symbol fundecl.fun_name); + D.label (emit_symbol fundecl.fun_name); emit_debug_info fundecl.fun_dbg; cfi_startproc (); if fp then begin - ` pushq %rbp\n`; - cfi_adjust_cfa_offset 8; - ` movq %rsp, %rbp\n`; + I.push rbp; + cfi_adjust_cfa_offset 8; + I.mov rsp rbp; end; if !Clflags.gprofile then emit_profile(); if frame_required() then begin let n = frame_size() - 8 - (if fp then 8 else 0) in - ` subq ${emit_int n}, %rsp\n`; - cfi_adjust_cfa_offset n; + if n <> 0 + then begin + I.sub (int n) rsp; + cfi_adjust_cfa_offset n; + end; end; - `{emit_label !tailrec_entry_point}:\n`; + def_label !tailrec_entry_point; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); + if frame_required() then begin + let n = frame_size() - 8 - (if fp then 8 else 0) in + if n <> 0 + then begin + cfi_adjust_cfa_offset (-n); + end; + end; cfi_endproc (); - begin match Config.system with - "linux" | "gnu" -> - ` .type {emit_symbol fundecl.fun_name},@function\n`; - ` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n` - | _ -> () + begin match system with + | S_gnu | S_linux -> + D.type_ (emit_symbol fundecl.fun_name) "@function"; + D.size (emit_symbol fundecl.fun_name) + (ConstSub ( + ConstThis, + ConstLabel (emit_symbol fundecl.fun_name))) + | _ -> () end (* Emission of data *) let emit_item = function - Cglobal_symbol s -> - ` .globl {emit_symbol s}\n`; - | Cdefine_symbol s -> - `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_data_label lbl}:\n` - | Cint8 n -> - ` .byte {emit_int n}\n` - | Cint16 n -> - ` .word {emit_int n}\n` - | Cint32 n -> - ` .long {emit_nativeint n}\n` - | Cint n -> - ` .quad {emit_nativeint n}\n` - | Csingle f -> - emit_float32_directive ".long" f - | Cdouble f -> - emit_float64_directive ".quad" f - | Csymbol_address s -> - ` .quad {emit_symbol s}\n` - | Clabel_address lbl -> - ` .quad {emit_data_label lbl}\n` - | Cstring s -> - emit_string_directive " .ascii " s - | Cskip n -> - if n > 0 then ` .space {emit_int n}\n` - | Calign n -> - emit_align n + | Cglobal_symbol s -> D.global (emit_symbol s) + | Cdefine_symbol s -> add_def_symbol s; _label (emit_symbol s) + | Cint8 n -> D.byte (const n) + | Cint16 n -> D.word (const n) + | Cint32 n -> D.long (const_nat n) + | Cint n -> D.qword (const_nat n) + | Csingle f -> D.long (Const (Int64.of_int32 (Int32.bits_of_float f))) + | Cdouble f -> D.qword (Const (Int64.bits_of_float f)) + | Csymbol_address s -> add_used_symbol s; D.qword (ConstLabel (emit_symbol s)) + | Cstring s -> D.bytes s + | Cskip n -> if n > 0 then D.space n + | Calign n -> D.align n let data l = - ` .data\n`; + D.data (); List.iter emit_item l (* Beginning / end of an assembly file *) let begin_assembly() = + X86_proc.reset_asm_code (); reset_debug_info(); (* PR#5603 *) + reset_imp_table(); float_constants := []; - if !Clflags.dlcode then begin + all_functions := []; + if system = S_win64 then begin + D.extrn "caml_young_ptr" QWORD; + D.extrn "caml_young_limit" QWORD; + D.extrn "caml_exception_pointer" QWORD; + D.extrn "caml_call_gc" NEAR; + D.extrn "caml_c_call" NEAR; + D.extrn "caml_allocN" NEAR; + D.extrn "caml_alloc1" NEAR; + D.extrn "caml_alloc2" NEAR; + D.extrn "caml_alloc3" NEAR; + D.extrn "caml_ml_array_bound_error" NEAR; + D.extrn "caml_raise_exn" NEAR; + end; + + + if !Clflags.dlcode || Arch.win64 then begin (* from amd64.S; could emit these constants on demand *) - if macosx then - ` .literal16\n` - else if mingw64 then - ` .section .rdata,\"dr\"\n` - else - ` .section .rodata.cst8,\"a\",@progbits\n`; - emit_align 16; - `{emit_symbol "caml_negf_mask"}: .quad 0x8000000000000000, 0\n`; - emit_align 16; - `{emit_symbol "caml_absf_mask"}: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n` + begin match system with + | S_macosx -> D.section ["__TEXT";"__literal16"] None ["16byte_literals"] + | S_mingw64 | S_cygwin -> D.section [".rdata"] (Some "dr") [] + | S_win64 -> D.data () + | _ -> D.section [".rodata.cst8"] (Some "a") ["@progbits"] + end; + D.align 16; + _label (emit_symbol "caml_negf_mask"); + D.qword (Const 0x8000000000000000L); + D.qword (Const 0L); + D.align 16; + _label (emit_symbol "caml_absf_mask"); + D.qword (Const 0x7FFFFFFFFFFFFFFFL); + D.qword (Const 0xFFFFFFFFFFFFFFFFL); end; - let lbl_begin = Compilenv.make_symbol (Some "data_begin") in - ` .data\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - let lbl_begin = Compilenv.make_symbol (Some "code_begin") in - ` .text\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - if macosx then ` nop\n` (* PR#4690 *) + + D.data (); + emit_global_label "data_begin"; + + D.text (); + emit_global_label "code_begin"; + if system = S_macosx then I.nop (); (* PR#4690 *) + () + +let emit_spacetime_shapes () = + D.data (); + D.align 8; + emit_global_label "spacetime_shapes"; + List.iter (fun fundecl -> + (* CR-someday mshinwell: some of this should be platform independent *) + begin match fundecl.fun_spacetime_shape with + | None -> () + | Some shape -> + let funsym = emit_symbol fundecl.fun_name in + D.comment ("Shape for " ^ funsym ^ ":"); + D.qword (ConstLabel funsym); + List.iter (fun (part_of_shape, label) -> + let tag = + match part_of_shape with + | Direct_call_point _ -> 1 + | Indirect_call_point -> 2 + | Allocation_point -> 3 + in + D.qword (Const (Int64.of_int tag)); + D.qword (ConstLabel (emit_label label)); + begin match part_of_shape with + | Direct_call_point { callee; } -> + D.qword (ConstLabel (emit_symbol callee)) + | Indirect_call_point -> () + | Allocation_point -> () + end) + shape; + D.qword (Const 0L) + end) + !all_functions; + D.qword (Const 0L); + D.comment "End of Spacetime shapes." let end_assembly() = if !float_constants <> [] then begin - if macosx then - ` .literal8\n` - else if mingw64 then - ` .section .rdata,\"dr\"\n` - else - ` .section .rodata.cst8,\"a\",@progbits\n`; - List.iter emit_float_constant !float_constants + begin match system with + | S_macosx -> D.section ["__TEXT";"__literal8"] None ["8byte_literals"] + | S_mingw64 | S_cygwin -> D.section [".rdata"] (Some "dr") [] + | S_win64 -> D.data () + | _ -> D.section [".rodata.cst8"] (Some "a") ["@progbits"] + end; + List.iter (fun (cst,lbl) -> emit_float_constant cst lbl) !float_constants end; - let lbl_end = Compilenv.make_symbol (Some "code_end") in - ` .text\n`; - if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *) - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .data\n`; - let lbl_end = Compilenv.make_symbol (Some "data_end") in - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .long 0\n`; - let lbl = Compilenv.make_symbol (Some "frametable") in - ` .globl {emit_symbol lbl}\n`; - `{emit_symbol lbl}:\n`; + + D.text (); + if system = S_macosx then I.nop (); + (* suppress "ld warning: atom sorting error" *) + + emit_global_label "code_end"; + + emit_imp_table(); + + D.data (); + emit_global_label "data_end"; + D.long (const 0); + + emit_global_label "frametable"; + + let setcnt = ref 0 in emit_frames - { efa_label = (fun l -> ` .quad {emit_label l}\n`); - efa_16 = (fun n -> ` .word {emit_int n}\n`); - efa_32 = (fun n -> ` .long {emit_int32 n}\n`); - efa_word = (fun n -> ` .quad {emit_int n}\n`); - efa_align = emit_align; + { efa_code_label = (fun l -> D.qword (ConstLabel (emit_label l))); + efa_data_label = (fun l -> D.qword (ConstLabel (emit_label l))); + efa_16 = (fun n -> D.word (const n)); + efa_32 = (fun n -> D.long (const_32 n)); + efa_word = (fun n -> D.qword (const n)); + efa_align = D.align; efa_label_rel = - if macosx then begin - let setcnt = ref 0 in - fun lbl ofs -> - incr setcnt; - ` .set L$set${emit_int !setcnt}, ({emit_label lbl} - .) + {emit_int32 ofs}\n`; - ` .long L$set${emit_int !setcnt}\n` - end else begin - fun lbl ofs -> - ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n` - end; - efa_def_label = (fun l -> `{emit_label l}:\n`); - efa_string = (fun s -> emit_string_directive " .asciz " s) }; - if Config.system = "linux" then + (fun lbl ofs -> + let c = + ConstAdd ( + ConstSub(ConstLabel(emit_label lbl), ConstThis), + const_32 ofs + ) in + if system = S_macosx then begin + incr setcnt; + let s = Printf.sprintf "L$set$%d" !setcnt in + D.setvar (s, c); + D.long (ConstLabel s) + end else + D.long c + ); + efa_def_label = (fun l -> _label (emit_label l)); + efa_string = (fun s -> D.bytes (s ^ "\000")) + }; + + if Config.spacetime then begin + emit_spacetime_shapes () + end; + + if system = S_linux then (* Mark stack as non-executable, PR#4564 *) - ` .section .note.GNU-stack,\"\",%progbits\n` + D.section [".note.GNU-stack"] (Some "") [ "%progbits" ]; + + if system = S_win64 then begin + D.comment "External functions"; + StringSet.iter + (fun s -> + if not (StringSet.mem s !symbols_defined) then + D.extrn (emit_symbol s) NEAR) + !symbols_used; + symbols_used := StringSet.empty; + symbols_defined := StringSet.empty; + end; + + let asm = + if !Emitaux.create_asm_file then + Some + ( + (if X86_proc.masm then X86_masm.generate_asm + else X86_gas.generate_asm) !Emitaux.output_channel + ) + else + None + in + X86_proc.generate_code asm diff -Nru ocaml-4.01.0/asmcomp/amd64/emit_nt.mlp ocaml-4.05.0/asmcomp/amd64/emit_nt.mlp --- ocaml-4.01.0/asmcomp/amd64/emit_nt.mlp 2013-06-03 18:03:59.000000000 +0000 +++ ocaml-4.05.0/asmcomp/amd64/emit_nt.mlp 1970-01-01 00:00:00.000000000 +0000 @@ -1,814 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* Emission of x86-64 (AMD 64) assembly code, MASM syntax *) - -module StringSet = - Set.Make(struct type t = string let compare (x:t) y = compare x y end) - -open Misc -open Cmm -open Arch -open Proc -open Reg -open Mach -open Linearize -open Emitaux - -(* Tradeoff between code size and code speed *) - -let fastcode_flag = ref true - -let stack_offset = ref 0 - -(* Layout of the stack frame *) - -let frame_required () = - !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0 - -let frame_size () = (* includes return address *) - if frame_required() then begin - let sz = - (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8) - in Misc.align sz 16 - end else - !stack_offset + 8 - -let slot_offset loc cl = - match loc with - Incoming n -> frame_size() + n - | Local n -> - if cl = 0 - then !stack_offset + n * 8 - else !stack_offset + (num_stack_slots.(0) + n) * 8 - | Outgoing n -> n - -(* Output a 32 bit integer in hex *) - -let emit_int32 n = emit_printf "0%lxh" n - -(* Symbols *) - -let emit_symbol s = - Emitaux.emit_symbol '$' s - -(* Record symbols used and defined - at the end generate extern for those - used but not defined *) - -let symbols_defined = ref StringSet.empty -let symbols_used = ref StringSet.empty - -let add_def_symbol s = - symbols_defined := StringSet.add s !symbols_defined - -let add_used_symbol s = - symbols_used := StringSet.add s !symbols_used - -(* Output a label *) - -let emit_label lbl = - emit_string "L"; emit_int lbl - -let emit_data_label lbl = - emit_string "Ld"; emit_int lbl - -(* Output a .align directive. *) - -let emit_align n = - ` ALIGN {emit_int n}\n` - -let emit_Llabel fallthrough lbl = - if not fallthrough && !fastcode_flag then emit_align 4; - emit_label lbl - -(* Output a pseudo-register *) - -let emit_reg = function - { loc = Reg r } -> - emit_string (register_name r) - | { loc = Stack s; typ = Float } as r -> - let ofs = slot_offset s (register_class r) in - `REAL8 PTR {emit_int ofs}[rsp]` - | { loc = Stack s; typ = _ } as r -> - let ofs = slot_offset s (register_class r) in - `QWORD PTR {emit_int ofs}[rsp]` - | { loc = Unknown } -> - assert false - -(* Output a reference to the lower 8, 16 or 32 bits of a register *) - -let reg_low_8_name = - [| "al"; "bl"; "dil"; "sil"; "dl"; "cl"; "r8b"; "r9b"; - "r12b"; "r13b"; "r10b"; "r11b"; "bpl" |] -let reg_low_16_name = - [| "ax"; "bx"; "di"; "si"; "dx"; "cx"; "r8w"; "r9w"; - "r12w"; "r13w"; "r10w"; "r11w"; "bp" |] -let reg_low_32_name = - [| "eax"; "ebx"; "edi"; "esi"; "edx"; "ecx"; "r8d"; "r9d"; - "r12d"; "r13d"; "r10d"; "r11d"; "ebp" |] - -let emit_subreg tbl pref r = - match r.loc with - Reg r when r < 13 -> - emit_string tbl.(r) - | Stack s -> - let ofs = slot_offset s (register_class r) in - `{emit_string pref} PTR {emit_int ofs}[rsp]` - | _ -> - assert false - -let emit_reg8 r = emit_subreg reg_low_8_name "BYTE" r -let emit_reg16 r = emit_subreg reg_low_16_name "WORD" r -let emit_reg32 r = emit_subreg reg_low_32_name "DWORD" r - -(* Output an addressing mode *) - -let emit_signed_int d = - if d > 0 then emit_char '+'; - if d <> 0 then emit_int d - -let emit_addressing addr r n = - match addr with - Ibased(s, d) -> - add_used_symbol s; - `{emit_symbol s}{emit_signed_int d}` - | Iindexed d -> - `[{emit_reg r.(n)}{emit_signed_int d}]` - | Iindexed2 d -> - `[{emit_reg r.(n)}+{emit_reg r.(n+1)}{emit_signed_int d}]` - | Iscaled(2, d) -> - `[{emit_reg r.(n)}+{emit_reg r.(n)}{emit_signed_int d}]` - | Iscaled(scale, d) -> - `[{emit_reg r.(n)}*{emit_int scale}{emit_signed_int d}]` - | Iindexed2scaled(scale, d) -> - `[{emit_reg r.(n)}+{emit_reg r.(n+1)}*{emit_int scale}{emit_signed_int d}]` - -(* Record live pointers at call points *) - -let record_frame_label live dbg = - let lbl = new_label() in - let live_offset = ref [] in - Reg.Set.iter - (function - {typ = Addr; loc = Reg r} -> - live_offset := ((r lsl 1) + 1) :: !live_offset - | {typ = Addr; loc = Stack s} as reg -> - live_offset := slot_offset s (register_class reg) :: !live_offset - | _ -> ()) - live; - frame_descriptors := - { fd_lbl = lbl; - fd_frame_size = frame_size(); - fd_live_offset = !live_offset; - fd_debuginfo = dbg } :: !frame_descriptors; - lbl - -let record_frame live dbg = - let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` - -(* Record calls to the GC -- we've moved them out of the way *) - -type gc_call = - { gc_lbl: label; (* Entry label *) - gc_return_lbl: label; (* Where to branch after GC *) - gc_frame: label } (* Label of frame descriptor *) - -let call_gc_sites = ref ([] : gc_call list) - -let emit_call_gc gc = - `{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`; - `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` - -(* Record calls to caml_ml_array_bound_error. - In -g mode, we maintain one call to caml_ml_array_bound_error - per bound check site. Without -g, we can share a single call. *) - -type bound_error_call = - { bd_lbl: label; (* Entry label *) - bd_frame: label } (* Label of frame descriptor *) - -let bound_error_sites = ref ([] : bound_error_call list) -let bound_error_call = ref 0 - -let bound_error_label dbg = - if !Clflags.debug then begin - let lbl_bound_error = new_label() in - let lbl_frame = record_frame_label Reg.Set.empty dbg in - bound_error_sites := - { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; - lbl_bound_error - end else begin - if !bound_error_call = 0 then bound_error_call := new_label(); - !bound_error_call - end - -let emit_call_bound_error bd = - `{emit_label bd.bd_lbl}: call caml_ml_array_bound_error\n`; - `{emit_label bd.bd_frame}:\n` - -let emit_call_bound_errors () = - List.iter emit_call_bound_error !bound_error_sites; - if !bound_error_call > 0 then - `{emit_label !bound_error_call}: call caml_ml_array_bound_error\n` - -(* Names for instructions *) - -let instr_for_intop = function - Iadd -> "add" - | Isub -> "sub" - | Imul -> "imul" - | Iand -> "and" - | Ior -> "or" - | Ixor -> "xor" - | Ilsl -> "sal" - | Ilsr -> "shr" - | Iasr -> "sar" - | _ -> assert false - -let instr_for_floatop = function - Iaddf -> "addsd" - | Isubf -> "subsd" - | Imulf -> "mulsd" - | Idivf -> "divsd" - | _ -> assert false - -let instr_for_floatarithmem = function - Ifloatadd -> "addsd" - | Ifloatsub -> "subsd" - | Ifloatmul -> "mulsd" - | Ifloatdiv -> "divsd" - -let name_for_cond_branch = function - Isigned Ceq -> "e" | Isigned Cne -> "ne" - | Isigned Cle -> "le" | Isigned Cgt -> "g" - | Isigned Clt -> "l" | Isigned Cge -> "ge" - | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" - | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" - | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" - -(* Output an = 0 or <> 0 test. *) - -let output_test_zero arg = - match arg.loc with - Reg r -> ` test {emit_reg arg}, {emit_reg arg}\n` - | _ -> ` cmp {emit_reg arg}, 0\n` - -(* Output a floating-point compare and branch *) - -let emit_float_test cmp neg arg lbl = - (* Effect of comisd on flags and conditional branches: - ZF PF CF cond. branches taken - unordered 1 1 1 je, jb, jbe, jp - > 0 0 0 jne, jae, ja - < 0 0 1 jne, jbe, jb - = 1 0 0 je, jae, jbe. - If FP traps are on (they are off by default), - comisd traps on QNaN and SNaN but ucomisd traps on SNaN only. - *) - match (cmp, neg) with - | (Ceq, false) | (Cne, true) -> - let next = new_label() in - ` ucomisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; - ` jp {emit_label next}\n`; (* skip if unordered *) - ` je {emit_label lbl}\n`; (* branch taken if x=y *) - `{emit_label next}:\n` - | (Cne, false) | (Ceq, true) -> - ` ucomisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; - ` jp {emit_label lbl}\n`; (* branch taken if unordered *) - ` jne {emit_label lbl}\n` (* branch taken if xy *) - | (Clt, _) -> - ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; (* swap compare *) - if not neg then - ` ja {emit_label lbl}\n` (* branch taken if y>x i.e. x - ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; (* swap compare *) - if not neg then - ` jae {emit_label lbl}\n` (* branch taken if y>=x i.e. x<=y *) - else - ` jb {emit_label lbl}\n` (* taken if unordered or y - ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; - if not neg then - ` ja {emit_label lbl}\n` (* branch taken if x>y *) - else - ` jbe {emit_label lbl}\n` (* taken if unordered or x<=y i.e. !(x>y) *) - | (Cge, _) -> - ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *) - if not neg then - ` jae {emit_label lbl}\n` (* branch taken if x>=y *) - else - ` jb {emit_label lbl}\n` (* taken if unordered or x=y) *) - -(* Deallocate the stack frame before a return or tail call *) - -let output_epilogue () = - if frame_required() then begin - let n = frame_size() - 8 in - ` add rsp, {emit_int n}\n` - end - -(* Floating-point constants *) - -let float_constants = ref ([] : (string * int) list) - -let add_float_constant cst = - try - List.assoc cst !float_constants - with - Not_found -> - let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; - lbl - -let emit_float s = - (* MASM doesn't like floating-point constants such as 2e9. - Turn them into 2.0e9. *) - let pos_e = ref (-1) and pos_dot = ref (-1) in - for i = 0 to String.length s - 1 do - match s.[i] with - 'e'|'E' -> pos_e := i - | '.' -> pos_dot := i - | _ -> () - done; - if !pos_dot < 0 && !pos_e >= 0 then begin - emit_string (String.sub s 0 !pos_e); - emit_string ".0"; - emit_string (String.sub s !pos_e (String.length s - !pos_e)) - end else - emit_string s - -let emit_float_constant (cst, lbl) = - `{emit_label lbl} REAL8 {emit_float cst}\n` - -(* Output the assembly code for an instruction *) - -(* Name of current function *) -let function_name = ref "" -(* Entry point for tail recursive calls *) -let tailrec_entry_point = ref 0 - -let emit_instr fallthrough i = - match i.desc with - Lend -> () - | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin - match src.typ, src.loc, dst.loc with - Float, Reg _, Reg _ -> - ` movapd {emit_reg dst}, {emit_reg src}\n` - | Float, _, _ -> - ` movsd {emit_reg dst}, {emit_reg src}\n` - | _ -> - ` mov {emit_reg dst}, {emit_reg src}\n` - end - | Lop(Iconst_int n) -> - if n = 0n then begin - match i.res.(0).loc with - Reg n -> ` xor {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | _ -> ` mov {emit_reg i.res.(0)}, 0\n` - end else if n >= -0x80000000n && n <= 0x7FFFFFFFn then - ` mov {emit_reg i.res.(0)}, {emit_nativeint n}\n` - else if n >= 0x80000000n && n <= 0xFFFFFFFFn then - (* work around bug in ml64 *) - ` mov {emit_reg32 i.res.(0)}, {emit_nativeint n}\n` - else - (* force ml64 to use mov reg, imm64 instruction *) - ` mov {emit_reg i.res.(0)}, {emit_printf "0%nxH" n}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with - | 0x0000_0000_0000_0000L -> (* +0.0 *) - ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | _ -> - let lbl = add_float_constant s in - ` movsd {emit_reg i.res.(0)}, {emit_label lbl}\n` - end - | Lop(Iconst_symbol s) -> - add_used_symbol s; - if !pic_code then - ` lea {emit_reg i.res.(0)}, {emit_symbol s}\n` - else - ` mov {emit_reg i.res.(0)}, OFFSET {emit_symbol s}\n` - | Lop(Icall_ind) -> - ` call {emit_reg i.arg.(0)}\n`; - record_frame i.live i.dbg - | Lop(Icall_imm s) -> - add_used_symbol s; - ` call {emit_symbol s}\n`; - record_frame i.live i.dbg - | Lop(Itailcall_ind) -> - output_epilogue(); - ` jmp {emit_reg i.arg.(0)}\n` - | Lop(Itailcall_imm s) -> - if s = !function_name then - ` jmp {emit_label !tailrec_entry_point}\n` - else begin - add_used_symbol s; - output_epilogue(); - ` jmp {emit_symbol s}\n` - end - | Lop(Iextcall(s, alloc)) -> - add_used_symbol s; - if alloc then begin - ` lea rax, {emit_symbol s}\n`; - ` call {emit_symbol "caml_c_call"}\n`; - record_frame i.live i.dbg - end else begin - ` call {emit_symbol s}\n` - end - | Lop(Istackoffset n) -> - if n < 0 - then ` add rsp, {emit_int(-n)}\n` - else ` sub rsp, {emit_int(n)}\n`; - stack_offset := !stack_offset + n - | Lop(Iload(chunk, addr)) -> - let dest = i.res.(0) in - begin match chunk with - | Word -> - ` mov {emit_reg dest}, QWORD PTR {emit_addressing addr i.arg 0}\n` - | Byte_unsigned -> - ` movzx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` - | Byte_signed -> - ` movsx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` - | Sixteen_unsigned -> - ` movzx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` - | Sixteen_signed -> - ` movsx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` - | Thirtytwo_unsigned -> - (* load to low 32 bits sets high 32 bits to 0 *) - ` mov {emit_reg32 dest}, DWORD PTR {emit_addressing addr i.arg 0}\n` - | Thirtytwo_signed -> - ` movsxd {emit_reg dest}, DWORD PTR {emit_addressing addr i.arg 0}\n` - | Single -> - ` cvtss2sd {emit_reg dest}, REAL4 PTR {emit_addressing addr i.arg 0}\n` - | Double | Double_u -> - ` movsd {emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n` - end - | Lop(Istore(chunk, addr)) -> - begin match chunk with - | Word -> - ` mov QWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` - | Byte_unsigned | Byte_signed -> - ` mov BYTE PTR {emit_addressing addr i.arg 1}, {emit_reg8 i.arg.(0)}\n` - | Sixteen_unsigned | Sixteen_signed -> - ` mov WORD PTR {emit_addressing addr i.arg 1}, {emit_reg16 i.arg.(0)}\n` - | Thirtytwo_signed | Thirtytwo_unsigned -> - ` mov DWORD PTR {emit_addressing addr i.arg 1}, {emit_reg32 i.arg.(0)}\n` - | Single -> - ` cvtsd2ss xmm15, {emit_reg i.arg.(0)}\n`; - ` movss REAL4 PTR {emit_addressing addr i.arg 1}, xmm15\n` - | Double | Double_u -> - ` movsd REAL8 PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` - end - | Lop(Ialloc n) -> - if !fastcode_flag then begin - let lbl_redo = new_label() in - `{emit_label lbl_redo}: sub r15, {emit_int n}\n`; - ` cmp r15, {emit_symbol "caml_young_limit"}\n`; - let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live Debuginfo.none in - ` jb {emit_label lbl_call_gc}\n`; - ` lea {emit_reg i.res.(0)}, [r15+8]\n`; - call_gc_sites := - { gc_lbl = lbl_call_gc; - gc_return_lbl = lbl_redo; - gc_frame = lbl_frame } :: !call_gc_sites - end else begin - begin match n with - 16 -> ` call {emit_symbol "caml_alloc1"}\n` - | 24 -> ` call {emit_symbol "caml_alloc2"}\n` - | 32 -> ` call {emit_symbol "caml_alloc3"}\n` - | _ -> ` mov rax, {emit_int n}\n`; - ` call {emit_symbol "caml_allocN"}\n` - end; - `{record_frame i.live Debuginfo.none} lea {emit_reg i.res.(0)}, [r15+8]\n` - end - | Lop(Iintop(Icomp cmp)) -> - ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - let b = name_for_cond_branch cmp in - ` set{emit_string b} al\n`; - ` movzx {emit_reg i.res.(0)}, al\n` - | Lop(Iintop_imm(Icomp cmp, n)) -> - ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; - let b = name_for_cond_branch cmp in - ` set{emit_string b} al\n`; - ` movzx {emit_reg i.res.(0)}, al\n` - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in - ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - ` jbe {emit_label lbl}\n` - | Lop(Iintop_imm(Icheckbound, n)) -> - let lbl = bound_error_label i.dbg in - ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; - ` jbe {emit_label lbl}\n` - | Lop(Iintop(Idiv | Imod)) -> - ` cqo\n`; - ` idiv {emit_reg i.arg.(1)}\n` - | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> - (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *) - ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, cl\n` - | Lop(Iintop op) -> - (* We have i.arg.(0) = i.res.(0) *) - ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` - | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> - ` lea {emit_reg i.res.(0)}, {emit_int n}[{emit_reg i.arg.(0)}]\n` - | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> - ` inc {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> - ` dec {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) - let l = Misc.log2 n in - ` mov rax, {emit_reg i.arg.(0)}\n`; - ` add {emit_reg i.arg.(0)}, {emit_int(n-1)}\n`; - ` test rax, rax\n`; - ` cmovns {emit_reg i.arg.(0)}, rax\n`; - ` sar {emit_reg i.res.(0)}, {emit_int l}\n` - | Lop(Iintop_imm(Imod, n)) -> - (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) - ` mov rax, {emit_reg i.arg.(0)}\n`; - ` test rax, rax\n`; - ` lea rax, {emit_int(n-1)}[rax]\n`; - ` cmovns rax, {emit_reg i.arg.(0)}\n`; - ` and rax, {emit_int (-n)}\n`; - ` sub {emit_reg i.res.(0)}, rax\n` - | Lop(Iintop_imm(op, n)) -> - (* We have i.arg.(0) = i.res.(0) *) - ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_int n}\n` - | Lop(Inegf) -> - ` xorpd {emit_reg i.res.(0)}, {emit_symbol "caml_negf_mask"}\n` - | Lop(Iabsf) -> - ` andpd {emit_reg i.res.(0)}, {emit_symbol "caml_absf_mask"}\n` - | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) -> - ` {emit_string(instr_for_floatop floatop)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` - | Lop(Ifloatofint) -> - ` cvtsi2sd {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` - | Lop(Iintoffloat) -> - ` cvttsd2si {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` - | Lop(Ispecific(Ilea addr)) -> - ` lea {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> - ` mov QWORD PTR {emit_addressing addr i.arg 0}, {emit_nativeint n}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> - assert (not !pic_code); - add_used_symbol s; - ` mov QWORD PTR {emit_addressing addr i.arg 0}, OFFSET {emit_symbol s}\n` - | Lop(Ispecific(Ioffset_loc(n, addr))) -> - ` add QWORD PTR {emit_addressing addr i.arg 0}, {emit_int n}\n` - | Lop(Ispecific(Ifloatarithmem(op, addr))) -> - ` {emit_string(instr_for_floatarithmem op)} {emit_reg i.res.(0)}, REAL8 PTR {emit_addressing addr i.arg 1}\n` - | Lop(Ispecific(Ibswap size)) -> - begin match size with - | 16 -> - ` xchg ah, al\n`; - ` movzx {emit_reg i.res.(0)}, {emit_reg16 i.res.(0)}\n` - | 32 -> - ` bswap {emit_reg32 i.res.(0)}\n`; - ` movsxd {emit_reg i.res.(0)}, {emit_reg32 i.res.(0)}\n` - | 64 -> - ` bswap {emit_reg i.res.(0)}\n` - | _ -> assert false - end - | Lop(Ispecific Isqrtf) -> - ` sqrtsd {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` - | Lop(Ispecific(Ifloatsqrtf addr)) -> - ` sqrtsd {emit_reg i.res.(0)}, REAL8 PTR {emit_addressing addr i.arg 0}\n` - | Lreloadretaddr -> - () - | Lreturn -> - output_epilogue(); - ` ret\n` - | Llabel lbl -> - `{emit_Llabel fallthrough lbl}:\n` - | Lbranch lbl -> - ` jmp {emit_label lbl}\n` - | Lcondbranch(tst, lbl) -> - begin match tst with - Itruetest -> - output_test_zero i.arg.(0); - ` jne {emit_label lbl}\n` - | Ifalsetest -> - output_test_zero i.arg.(0); - ` je {emit_label lbl}\n` - | Iinttest cmp -> - ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | - Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> - output_test_zero i.arg.(0); - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm(cmp, n) -> - ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Ifloattest(cmp, neg) -> - emit_float_test cmp neg i.arg lbl - | Ioddtest -> - ` test {emit_reg8 i.arg.(0)}, 1\n`; - ` jne {emit_label lbl}\n` - | Ieventest -> - ` test {emit_reg8 i.arg.(0)}, 1\n`; - ` je {emit_label lbl}\n` - end - | Lcondbranch3(lbl0, lbl1, lbl2) -> - ` cmp {emit_reg i.arg.(0)}, 1\n`; - begin match lbl0 with - None -> () - | Some lbl -> ` jb {emit_label lbl}\n` - end; - begin match lbl1 with - None -> () - | Some lbl -> ` je {emit_label lbl}\n` - end; - begin match lbl2 with - None -> () - | Some lbl -> ` jg {emit_label lbl}\n` - end - | Lswitch jumptbl -> - let lbl = new_label() in - (* rax and rdx are clobbered by the Lswitch, - meaning that no variable that is live across the Lswitch - is assigned to rax or rdx. However, the argument to Lswitch - can still be assigned to one of these two registers, so - we must be careful not to clobber it before use. *) - let (tmp1, tmp2) = - if i.arg.(0).loc = Reg 0 (* rax *) - then (phys_reg 4 (*rdx*), phys_reg 0 (*rax*)) - else (phys_reg 0 (*rax*), phys_reg 4 (*rdx*)) in - ` lea {emit_reg tmp1}, {emit_label lbl}\n`; - ` movsxd {emit_reg tmp2}, DWORD PTR [{emit_reg tmp1}+{emit_reg i.arg.(0)}*4]\n`; - ` add {emit_reg tmp1}, {emit_reg tmp2}\n`; - ` jmp {emit_reg tmp1}\n`; - emit_align 4; - `{emit_label lbl} LABEL DWORD\n`; - for i = 0 to Array.length jumptbl - 1 do - ` DWORD {emit_label jumptbl.(i)} - {emit_label lbl}\n` - done - | Lsetuptrap lbl -> - ` call {emit_label lbl}\n` - | Lpushtrap -> - ` push r14\n`; - ` mov r14, rsp\n`; - stack_offset := !stack_offset + 16 - | Lpoptrap -> - ` pop r14\n`; - ` add rsp, 8\n`; - stack_offset := !stack_offset - 16 - | Lraise -> - if !Clflags.debug then begin - ` call caml_raise_exn\n`; - record_frame Reg.Set.empty i.dbg - end else begin - ` mov rsp, r14\n`; - ` pop r14\n`; - ` ret\n` - end - -let rec emit_all fallthrough i = - match i.desc with - | Lend -> () - | _ -> - emit_instr fallthrough i; - emit_all (Linearize.has_fallthrough i.desc) i.next - -(* Emission of a function declaration *) - -let fundecl fundecl = - function_name := fundecl.fun_name; - fastcode_flag := fundecl.fun_fast; - tailrec_entry_point := new_label(); - stack_offset := 0; - call_gc_sites := []; - bound_error_sites := []; - bound_error_call := 0; - ` .CODE\n`; - emit_align 16; - add_def_symbol fundecl.fun_name; - ` PUBLIC {emit_symbol fundecl.fun_name}\n`; - `{emit_symbol fundecl.fun_name}:\n`; - if frame_required() then begin - let n = frame_size() - 8 in - ` sub rsp, {emit_int n}\n` - end; - `{emit_label !tailrec_entry_point}:\n`; - emit_all true fundecl.fun_body; - List.iter emit_call_gc !call_gc_sites; - emit_call_bound_errors() - -(* Emission of data *) - -let emit_item = function - Cglobal_symbol s -> - ` PUBLIC {emit_symbol s}\n`; - | Cdefine_symbol s -> - add_def_symbol s; - `{emit_symbol s} LABEL QWORD\n` - | Cdefine_label lbl -> - `{emit_data_label lbl} LABEL QWORD\n` - | Cint8 n -> - ` BYTE {emit_int n}\n` - | Cint16 n -> - ` WORD {emit_int n}\n` - | Cint32 n -> - ` DWORD {emit_nativeint n}\n` - | Cint n -> - ` QWORD {emit_nativeint n}\n` - | Csingle f -> - ` REAL4 {emit_float f}\n` - | Cdouble f -> - ` REAL8 {emit_float f}\n` - | Csymbol_address s -> - add_used_symbol s; - ` QWORD {emit_symbol s}\n` - | Clabel_address lbl -> - ` QWORD {emit_data_label lbl}\n` - | Cstring s -> - emit_bytes_directive " BYTE " s - | Cskip n -> - if n > 0 then ` BYTE {emit_int n} DUP (?)\n` - | Calign n -> - emit_align n - -let data l = - ` .DATA\n`; - List.iter emit_item l - -(* Beginning / end of an assembly file *) - -let begin_assembly() = - float_constants := []; - ` EXTRN caml_young_ptr: QWORD\n`; - ` EXTRN caml_young_limit: QWORD\n`; - ` EXTRN caml_exception_pointer: QWORD\n`; - ` EXTRN caml_absf_mask: QWORD\n`; - ` EXTRN caml_negf_mask: QWORD\n`; - ` EXTRN caml_call_gc: NEAR\n`; - ` EXTRN caml_c_call: NEAR\n`; - ` EXTRN caml_allocN: NEAR\n`; - ` EXTRN caml_alloc1: NEAR\n`; - ` EXTRN caml_alloc2: NEAR\n`; - ` EXTRN caml_alloc3: NEAR\n`; - ` EXTRN caml_ml_array_bound_error: NEAR\n`; - ` EXTRN caml_raise_exn: NEAR\n`; - let lbl_begin = Compilenv.make_symbol (Some "data_begin") in - add_def_symbol lbl_begin; - ` .DATA\n`; - ` PUBLIC {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin} LABEL QWORD\n`; - let lbl_begin = Compilenv.make_symbol (Some "code_begin") in - add_def_symbol lbl_begin; - ` .CODE\n`; - ` PUBLIC {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin} LABEL QWORD\n` - -let end_assembly() = - if !float_constants <> [] then begin - ` .DATA\n`; - List.iter emit_float_constant !float_constants - end; - let lbl_end = Compilenv.make_symbol (Some "code_end") in - add_def_symbol lbl_end; - ` .CODE\n`; - ` PUBLIC {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end} LABEL QWORD\n`; - ` .DATA\n`; - let lbl_end = Compilenv.make_symbol (Some "data_end") in - add_def_symbol lbl_end; - ` PUBLIC {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end} LABEL QWORD\n`; - ` QWORD 0\n`; - let lbl = Compilenv.make_symbol (Some "frametable") in - add_def_symbol lbl; - ` PUBLIC {emit_symbol lbl}\n`; - `{emit_symbol lbl} LABEL QWORD\n`; - emit_frames - { efa_label = (fun l -> ` QWORD {emit_label l}\n`); - efa_16 = (fun n -> ` WORD {emit_int n}\n`); - efa_32 = (fun n -> ` DWORD {emit_int32 n}\n`); - efa_word = (fun n -> ` QWORD {emit_int n}\n`); - efa_align = emit_align; - efa_label_rel = (fun lbl ofs -> - ` DWORD {emit_label lbl} - THIS BYTE + {emit_int32 ofs}\n`); - efa_def_label = (fun l -> `{emit_label l} LABEL QWORD\n`); - efa_string = (fun s -> emit_bytes_directive " BYTE " (s ^ "\000")) }; - `\n;External functions\n\n`; - StringSet.iter - (fun s -> - if not (StringSet.mem s !symbols_defined) then - ` EXTRN {emit_symbol s}: NEAR\n`) - !symbols_used; - symbols_used := StringSet.empty; - symbols_defined := StringSet.empty; - `END\n` diff -Nru ocaml-4.01.0/asmcomp/amd64/NOTES.md ocaml-4.05.0/asmcomp/amd64/NOTES.md --- ocaml-4.01.0/asmcomp/amd64/NOTES.md 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/amd64/NOTES.md 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,21 @@ +# Supported platforms + +Intel and AMD x86 processors in 64-bit mode, a.k.a `x86_64`. + +Floating-point architecture: SSE2, supported by all x86_64 processors. + +Operating systems: Linux, BSD, MacOS X, MS Windows. + +Debian architecture name: `amd64` + +# Reference documents + +* Instruction set architecture: + any Intel or AMD manual less than 10 years old. +* ELF application binary interface: + _System V Application Binary Interface, + AMD64 Architecture Processor Supplement_ +* MacOS X application binary interface: + _OS X ABI Function Call Guide: x86-64 Function Calling Conventions_ +* Windows 64 application binary interface: + _x64 Software Conventions_ from MSDN diff -Nru ocaml-4.01.0/asmcomp/amd64/proc.ml ocaml-4.05.0/asmcomp/amd64/proc.ml --- ocaml-4.01.0/asmcomp/amd64/proc.ml 2013-06-03 18:03:59.000000000 +0000 +++ ocaml-4.05.0/asmcomp/amd64/proc.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,18 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +# 2 "asmcomp/amd64/proc.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Description of the AMD64 processor *) @@ -22,17 +26,7 @@ (* Which ABI to use *) -let win64 = - match Config.system with - | "win64" | "mingw64" -> true - | _ -> false - -(* Which asm conventions to use *) - -let masm = - match Config.ccomp_type with - | "msvc" -> true - | _ -> false +let win64 = Arch.win64 (* Registers available for register allocation *) @@ -75,6 +69,8 @@ Linux's dynamic loader also destroys r10. *) +let max_arguments_for_tailcalls = 10 + let int_reg_name = match Config.ccomp_type with | "msvc" -> @@ -99,8 +95,7 @@ let register_class r = match r.typ with - Int -> 0 - | Addr -> 0 + | Val | Int | Addr -> 0 | Float -> 1 let num_available_registers = [| 13; 16 |] @@ -117,12 +112,12 @@ (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 13 Reg.dummy in + let v = Array.make 13 Reg.dummy in for i = 0 to 12 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 16 Reg.dummy in + let v = Array.make 16 Reg.dummy in for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg (100 + i)) done; v @@ -133,8 +128,8 @@ if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) let rax = phys_reg 0 -let rcx = phys_reg 5 let rdx = phys_reg 4 +let r13 = phys_reg 9 let rbp = phys_reg 12 let rxmm15 = phys_reg 115 @@ -149,13 +144,13 @@ let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in for i = 0 to Array.length arg - 1 do match arg.(i).typ with - Int | Addr as ty -> + | Val | Int | Addr as ty -> if !int <= last_int then begin loc.(i) <- phys_reg !int; incr int @@ -176,14 +171,22 @@ let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" + +let max_int_args_in_regs () = + if Config.spacetime then 9 else 10 let loc_arguments arg = - calling_conventions 0 9 100 109 outgoing arg + calling_conventions 0 ((max_int_args_in_regs ()) - 1) 100 109 outgoing arg let loc_parameters arg = - let (loc, ofs) = calling_conventions 0 9 100 109 incoming arg in loc + let (loc, _ofs) = + calling_conventions 0 ((max_int_args_in_regs ()) - 1) 100 109 incoming arg + in + loc let loc_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc + +let loc_spacetime_node_hole = r13 (* C calling conventions under Unix: first integer args in rdi, rsi, rdx, rcx, r8, r9 @@ -199,7 +202,7 @@ Return value in rax or xmm0. *) let loc_external_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc let unix_loc_external_arguments arg = calling_conventions 2 7 100 107 outgoing arg @@ -210,12 +213,12 @@ [| 100 (*xmm0*); 101 (*xmm1*); 102 (*xmm2*); 103 (*xmm3*) |] let win64_loc_external_arguments arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let reg = ref 0 and ofs = ref 32 in for i = 0 to Array.length arg - 1 do match arg.(i).typ with - Int | Addr as ty -> + | Val | Int | Addr as ty -> if !reg < 4 then begin loc.(i) <- phys_reg win64_int_external_arguments.(!reg); incr reg @@ -234,11 +237,22 @@ done; (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) -let loc_external_arguments = - if win64 then win64_loc_external_arguments else unix_loc_external_arguments +let loc_external_arguments arg = + let arg = + Array.map (fun regs -> assert (Array.length regs = 1); regs.(0)) arg + in + let loc, alignment = + if win64 then win64_loc_external_arguments arg + else unix_loc_external_arguments arg + in + Array.map (fun reg -> [|reg|]) loc, alignment let loc_exn_bucket = rax +(* Volatile registers: none *) + +let regs_are_volatile _rs = false + (* Registers destroyed by operations *) let destroyed_at_c_call = @@ -255,12 +269,20 @@ 108;109;110;111;112;113;114;115]) let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | Iop(Iintop(Idiv | Imod)) -> [| rax; rdx |] - | Iop(Istore(Single, _)) -> [| rxmm15 |] - | Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _)) + Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) -> + all_phys_regs + | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call + | Iop(Iintop(Idiv | Imod)) | Iop(Iintop_imm((Idiv | Imod), _)) + -> [| rax; rdx |] + | Iop(Istore(Single, _, _)) -> [| rxmm15 |] + | Iop(Ialloc _) when Config.spacetime + -> [| rax; loc_spacetime_node_hole |] + | Iop(Ialloc _ | Iintop(Imulh | Icomp _) | Iintop_imm((Icomp _), _)) -> [| rax |] + | Iop (Iintop (Icheckbound _)) when Config.spacetime -> + [| loc_spacetime_node_hole |] + | Iop (Iintop_imm(Icheckbound _, _)) when Config.spacetime -> + [| loc_spacetime_node_hole |] | Iswitch(_, _) -> [| rax; rdx |] | _ -> if fp then @@ -276,23 +298,34 @@ let safe_register_pressure = function - Iextcall(_,_) -> if win64 then if fp then 7 else 8 else 0 + Iextcall _ -> if win64 then if fp then 7 else 8 else 0 | _ -> if fp then 10 else 11 let max_register_pressure = function - Iextcall(_, _) -> + Iextcall _ -> if win64 then if fp then [| 7; 10 |] else [| 8; 10 |] else if fp then [| 3; 0 |] else [| 4; 0 |] - | Iintop(Idiv | Imod) -> + | Iintop(Idiv | Imod) | Iintop_imm((Idiv | Imod), _) -> if fp then [| 10; 16 |] else [| 11; 16 |] - | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _) -> + | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Icomp _), _) -> if fp then [| 11; 16 |] else [| 12; 16 |] - | Istore(Single, _) -> + | Istore(Single, _, _) -> if fp then [| 12; 15 |] else [| 13; 15 |] | _ -> if fp then [| 12; 16 |] else [| 13; 16 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false + | Ispecific(Ilea _) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack frame *) let num_stack_slots = [| 0; 0 |] @@ -301,13 +334,7 @@ (* Calling the assembler *) let assemble_file infile outfile = - if masm then - Ccomp.command (Config.asm ^ - Filename.quote outfile ^ " " ^ Filename.quote infile ^ - (if !Clflags.verbose then "" else ">NUL")) - else - Ccomp.command (Config.asm ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) + X86_proc.assemble_file infile outfile let init () = if fp then begin diff -Nru ocaml-4.01.0/asmcomp/amd64/reload.ml ocaml-4.05.0/asmcomp/amd64/reload.ml --- ocaml-4.01.0/asmcomp/amd64/reload.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/amd64/reload.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,17 +1,19 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Cmm -open Arch open Reg open Mach @@ -32,7 +34,8 @@ Istore R R Iintop(Icomp) R R S or S S R - Iintop(Imul|Idiv|mod) R R S + Iintop(Imul|Idiv|Imod) R R S + Iintop(Imulh) R R S Iintop(shift) S S R Iintop(others) R R S or S S R @@ -62,7 +65,7 @@ method! reload_operation op arg res = match op with - | Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) -> + | Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound _) -> (* One of the two arguments can reside in the stack, but not both *) if stackp arg.(0) && stackp arg.(1) then ([|arg.(0); self#makereg arg.(1)|], res) @@ -71,10 +74,10 @@ (* This add will be turned into a lea; args and results must be in registers *) super#reload_operation op arg res - | Iintop(Idiv | Imod | Ilsl | Ilsr | Iasr) + | Iintop(Imulh | Idiv | Imod | Ilsl | Ilsr | Iasr) | Iintop_imm(_, _) -> (* The argument(s) and results can be either in register or on stack *) - (* Note: Idiv, Imod: arg(0) and res(0) already forced in regs + (* Note: Imulh, Idiv, Imod: arg(0) and res(0) already forced in regs Ilsl, Ilsr, Iasr: arg(1) already forced in regs *) (arg, res) | Iintop(Imul) | Iaddf | Isubf | Imulf | Idivf -> @@ -91,7 +94,7 @@ then (arg, res) else super#reload_operation op arg res | Iconst_symbol _ -> - if !pic_code || !Clflags.dlcode + if !Clflags.pic_code || !Clflags.dlcode || Arch.win64 then super#reload_operation op arg res else (arg, res) | _ -> (* Other operations: all args and results in registers *) @@ -99,7 +102,7 @@ method! reload_test tst arg = match tst with - Iinttest cmp -> + Iinttest _ -> (* One of the two arguments can reside on stack *) if stackp arg.(0) && stackp arg.(1) then [| self#makereg arg.(0); arg.(1) |] diff -Nru ocaml-4.01.0/asmcomp/amd64/scheduling.ml ocaml-4.05.0/asmcomp/amd64/scheduling.ml --- ocaml-4.01.0/asmcomp/amd64/scheduling.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/amd64/scheduling.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) let _ = let module M = Schedgen in () (* to create a dependency *) diff -Nru ocaml-4.01.0/asmcomp/amd64/selection.ml ocaml-4.05.0/asmcomp/amd64/selection.ml --- ocaml-4.01.0/asmcomp/amd64/selection.ml 2012-11-29 09:55:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/amd64/selection.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Instruction selection for the AMD64 *) @@ -30,28 +33,28 @@ match exp with Cconst_symbol s when not !Clflags.dlcode -> (Asymbol s, 0) - | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> + | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], _) -> let (a, n) = select_addr arg in (a, n + m) - | Cop((Csubi | Csuba), [arg; Cconst_int m]) -> + | Cop(Csubi, [arg; Cconst_int m], _) -> let (a, n) = select_addr arg in (a, n - m) - | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> + | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], _) -> let (a, n) = select_addr arg in (a, n + m) - | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) -> + | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)], _) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift) | _ -> (Alinear exp, 0) end - | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) -> + | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)], _) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) end - | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) -> + | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg], _) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) end - | Cop((Caddi | Cadda), [arg1; arg2]) -> + | Cop((Caddi | Caddv | Cadda), [arg1; arg2], _) -> begin match (select_addr arg1, select_addr arg2) with ((Alinear e1, n1), (Alinear e2, n2)) -> (Aadd(e1, e2), n1 + n2) @@ -91,6 +94,10 @@ (rax, rbx, rcx or rdx). Keep it simple, just force the argument in rax. *) | Ispecific(Ibswap 16) -> ([| rax |], [| rax |]) + (* For imulq, first arg must be in rax, rax is clobbered, and result is in + rdx. *) + | Iintop(Imulh) -> + ([| rax; arg.(1) |], [| rdx |]) | Ispecific(Ifloatarithmem(_,_)) -> let arg' = Array.copy arg in arg'.(0) <- res.(0); @@ -105,13 +112,11 @@ ([| rax; rcx |], [| rax |]) | Iintop(Imod) -> ([| rax; rcx |], [| rdx |]) - (* For div and mod with immediate operand, arg must not be in rax. - Keep it simple, force it in rdx. *) - | Iintop_imm((Idiv|Imod), _) -> - ([| rdx |], [| rdx |]) (* Other instructions are regular *) | _ -> raise Use_default +(* If you update [inline_ops], you may need to update [is_simple_expr] and/or + [effects_of], below. *) let inline_ops = [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap"; "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ] @@ -120,25 +125,35 @@ class selector = object (self) -inherit Selectgen.selector_generic as super +inherit Spacetime_profiling.instruction_selection as super -method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000 +method is_immediate n = n <= 0x7FFF_FFFF && n >= (-1-0x7FFF_FFFF) + (* -1-.... : hack so that this can be compiled on 32-bit + (cf 'make check_all_arches') *) method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n method! is_simple_expr e = match e with - | Cop(Cextcall(fn, _, _, _), args) + | Cop(Cextcall (fn, _, _, _), args, _) when List.mem fn inline_ops -> (* inlined ops are simple if their arguments are *) List.for_all self#is_simple_expr args | _ -> super#is_simple_expr e -method select_addressing chunk exp = +method! effects_of e = + match e with + | Cop(Cextcall(fn, _, _, _), args, _) + when List.mem fn inline_ops -> + Selectgen.Effect_and_coeffect.join_list_map args self#effects_of + | _ -> + super#effects_of e + +method select_addressing _chunk exp = let (a, d) = select_addr exp in (* PR#4625: displacement must be a signed 32-bit immediate *) - if d < -0x8000_0000 || d > 0x7FFF_FFFF + if not (self # is_immediate d) then (Iindexed 0, exp) else match a with | Asymbol s -> @@ -152,45 +167,31 @@ | Ascaledadd(e1, e2, scale) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) -method! select_store addr exp = +method! select_store is_assign addr exp = match exp with Cconst_int n when self#is_immediate n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) - | Cconst_natint n when self#is_immediate_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) + | (Cconst_natint n) when self#is_immediate_natint n -> + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) + | (Cblockheader(n, _dbg)) + when self#is_immediate_natint n && not Config.spacetime -> + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_pointer n when self#is_immediate n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) | Cconst_natpointer n when self#is_immediate_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) - | Cconst_symbol s when not (!pic_code || !Clflags.dlcode) -> - (Ispecific(Istore_symbol(s, addr)), Ctuple []) + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | _ -> - super#select_store addr exp + super#select_store is_assign addr exp -method! select_operation op args = +method! select_operation op args dbg = match op with (* Recognize the LEA instruction *) - Caddi | Cadda | Csubi | Csuba -> - begin match self#select_addressing Word (Cop(op, args)) with - (Iindexed d, _) -> super#select_operation op args - | (Iindexed2 0, _) -> super#select_operation op args + Caddi | Caddv | Cadda | Csubi -> + begin match self#select_addressing Word_int (Cop(op, args, dbg)) with + (Iindexed _, _) + | (Iindexed2 0, _) -> super#select_operation op args dbg | (addr, arg) -> (Ispecific(Ilea addr), [arg]) end - (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *) - | Cdivi -> - begin match args with - [arg1; Cconst_int n] when self#is_immediate n - && n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg1]) - | _ -> (Iintop Idiv, args) - end - | Cmodi -> - begin match args with - [arg1; Cconst_int n] when self#is_immediate n - && n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg1]) - | _ -> (Iintop Imod, args) - end (* Recognize float arithmetic with memory. *) | Caddf -> self#select_floatarith true Iaddf Ifloatadd args @@ -202,7 +203,7 @@ self#select_floatarith false Idivf Ifloatdiv args | Cextcall("sqrt", _, false, _) -> begin match args with - [Cop(Cload (Double|Double_u as chunk), [loc])] -> + [Cop(Cload ((Double|Double_u as chunk), _), [loc], _dbg)] -> let (addr, arg) = self#select_addressing chunk loc in (Ispecific(Ifloatsqrtf addr), [arg]) | [arg] -> @@ -211,14 +212,14 @@ assert false end (* Recognize store instructions *) - | Cstore Word -> + | Cstore ((Word_int|Word_val as chunk), _init) -> begin match args with - [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])] + [loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int n], _)] when loc = loc' && self#is_immediate n -> - let (addr, arg) = self#select_addressing Word loc in + let (addr, arg) = self#select_addressing chunk loc in (Ispecific(Ioffset_loc(n, addr)), [arg]) | _ -> - super#select_operation op args + super#select_operation op args dbg end | Cextcall("caml_bswap16_direct", _, _, _) -> (Ispecific (Ibswap 16), args) @@ -227,17 +228,21 @@ | Cextcall("caml_int64_direct_bswap", _, _, _) | Cextcall("caml_nativeint_direct_bswap", _, _, _) -> (Ispecific (Ibswap 64), args) - | _ -> super#select_operation op args + (* AMD64 does not support immediate operands for multiply high signed *) + | Cmulhi -> + (Iintop Imulh, args) + | _ -> super#select_operation op args dbg (* Recognize float arithmetic with mem *) method select_floatarith commutative regular_op mem_op args = match args with - [arg1; Cop(Cload (Double|Double_u as chunk), [loc2])] -> + [arg1; Cop(Cload ((Double|Double_u as chunk), _), [loc2], _)] -> let (addr, arg2) = self#select_addressing chunk loc2 in (Ispecific(Ifloatarithmem(mem_op, addr)), [arg1; arg2]) - | [Cop(Cload (Double|Double_u as chunk), [loc1]); arg2] when commutative -> + | [Cop(Cload ((Double|Double_u as chunk), _), [loc1], _); arg2] + when commutative -> let (addr, arg1) = self#select_addressing chunk loc1 in (Ispecific(Ifloatarithmem(mem_op, addr)), [arg2; arg1]) @@ -246,6 +251,9 @@ | _ -> assert false +method! mark_c_tailcall = + Proc.contains_calls := true + (* Deal with register constraints *) method! insert_op_debug op dbg rs rd = diff -Nru ocaml-4.01.0/asmcomp/arm/arch.ml ocaml-4.05.0/asmcomp/arm/arch.ml --- ocaml-4.01.0/asmcomp/arm/arch.ml 2013-01-06 17:07:50.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm/arch.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,18 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Benedikt Meurer, University of Siegen *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique *) -(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) -(* reserved. This file is distributed under the terms of the Q *) -(* Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2012 Benedikt Meurer. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Specific operations for the ARM processor *) @@ -21,8 +24,8 @@ let abi = match Config.system with - "linux_eabi" -> EABI - | "linux_eabihf" -> EABI_HF + "linux_eabi" | "freebsd" -> EABI + | "linux_eabihf" | "netbsd" -> EABI_HF | _ -> assert false let string_of_arch = function @@ -56,25 +59,25 @@ end in (ref def_arch, ref def_fpu, ref def_thumb) -let pic_code = ref false - let farch spec = - arch := (match spec with + arch := begin match spec with "armv4" when abi <> EABI_HF -> ARMv4 | "armv5" when abi <> EABI_HF -> ARMv5 | "armv5te" when abi <> EABI_HF -> ARMv5TE | "armv6" -> ARMv6 | "armv6t2" -> ARMv6T2 | "armv7" -> ARMv7 - | spec -> raise (Arg.Bad spec)) + | spec -> raise (Arg.Bad ("wrong '-farch' option: " ^ spec)) + end let ffpu spec = - fpu := (match spec with + fpu := begin match spec with "soft" when abi <> EABI_HF -> Soft | "vfpv2" when abi = EABI_HF -> VFPv2 | "vfpv3-d16" when abi = EABI_HF -> VFPv3_D16 | "vfpv3" when abi = EABI_HF -> VFPv3 - | spec -> raise (Arg.Bad spec)) + | spec -> raise (Arg.Bad ("wrong '-ffpu' option: " ^ spec)) + end let command_line_options = [ "-farch", Arg.String farch, @@ -83,9 +86,9 @@ "-ffpu", Arg.String ffpu, " Select the floating-point hardware" ^ " (default: " ^ (string_of_fpu !fpu) ^ ")"; - "-fPIC", Arg.Set pic_code, + "-fPIC", Arg.Set Clflags.pic_code, " Generate position-independent machine code"; - "-fno-PIC", Arg.Clear pic_code, + "-fno-PIC", Arg.Clear Clflags.pic_code, " Generate position-dependent machine code"; "-fthumb", Arg.Set thumb, " Enable Thumb/Thumb-2 code generation" @@ -107,9 +110,10 @@ (* Specific operations *) type specific_operation = - Ishiftarith of arith_operation * int - | Ishiftcheckbound of int + Ishiftarith of arith_operation * shift_operation * int + | Ishiftcheckbound of shift_operation * int | Irevsubimm of int + | Imulhadd (* multiply high and add *) | Imuladd (* multiply and add *) | Imulsub (* multiply and subtract *) | Inegmulf (* floating-point negate and multiply *) @@ -124,6 +128,16 @@ Ishiftadd | Ishiftsub | Ishiftsubrev + | Ishiftand + | Ishiftor + | Ishiftxor + +and shift_operation = + Ishiftlogicalleft + | Ishiftlogicalright + | Ishiftarithmeticright + +let spacetime_node_hole_pointer_is_live_before _specific_op = false (* Sizes, endianness *) @@ -145,7 +159,7 @@ let offset_addressing (Iindexed n) delta = Iindexed(n + delta) -let num_args_addressing (Iindexed n) = 1 +let num_args_addressing (Iindexed _) = 1 (* Printing operations and addressing modes *) @@ -155,23 +169,41 @@ printreg ppf arg.(0); if n <> 0 then fprintf ppf " + %i" n +let shiftop_name = function + | Ishiftlogicalleft -> "<<" + | Ishiftlogicalright -> ">>u" + | Ishiftarithmeticright -> ">>s" + let print_specific_operation printreg op ppf arg = match op with - | Ishiftarith(op, shift) -> - let op_name = function - | Ishiftadd -> "+" - | Ishiftsub -> "-" - | Ishiftsubrev -> "-rev" in - let shift_mark = - if shift >= 0 - then sprintf "<< %i" shift - else sprintf ">> %i" (-shift) in - fprintf ppf "%a %s %a %s" - printreg arg.(0) (op_name op) printreg arg.(1) shift_mark - | Ishiftcheckbound n -> - fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) + Ishiftarith(op, shiftop, amount) -> + let (op1_name, op2_name) = match op with + Ishiftadd -> ("", "+") + | Ishiftsub -> ("", "-") + | Ishiftsubrev -> ("-", "+") + | Ishiftand -> ("", "&") + | Ishiftor -> ("", "|") + | Ishiftxor -> ("", "^") in + fprintf ppf "%s%a %s (%a %s %i)" + op1_name + printreg arg.(0) + op2_name + printreg arg.(1) + (shiftop_name shiftop) + amount + | Ishiftcheckbound(shiftop, amount) -> + fprintf ppf "check (%a %s %i) > %a" + printreg arg.(0) + (shiftop_name shiftop) + amount + printreg arg.(1) | Irevsubimm n -> fprintf ppf "%i %s %a" n "-" printreg arg.(0) + | Imulhadd -> + fprintf ppf "%a *h %a) + %a" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) | Imuladd -> fprintf ppf "(%a * %a) + %a" printreg arg.(0) diff -Nru ocaml-4.01.0/asmcomp/arm/CSE.ml ocaml-4.05.0/asmcomp/arm/CSE.ml --- ocaml-4.01.0/asmcomp/arm/CSE.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm/CSE.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* CSE for ARM *) + +open Arch +open Mach +open CSEgen + +class cse = object + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Ishiftcheckbound _) -> Op_checkbound + | Ispecific _ -> Op_pure + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n -> n <= 255n && n >= 0n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/arm/emit.mlp ocaml-4.05.0/asmcomp/arm/emit.mlp --- ocaml-4.01.0/asmcomp/arm/emit.mlp 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm/emit.mlp 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,19 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Benedikt Meurer, University of Siegen *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique *) -(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) -(* reserved. This file is distributed under the terms of the Q *) -(* Public License version 1.0. *) -(* *) -(***********************************************************************) +#2 "asmcomp/arm/emit.mlp" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2012 Benedikt Meurer. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Emission of ARM assembly code *) @@ -31,21 +35,18 @@ let emit_label lbl = emit_string ".L"; emit_int lbl -let emit_data_label lbl = - emit_string ".Ld"; emit_int lbl - (* Symbols *) let emit_symbol s = Emitaux.emit_symbol '$' s let emit_call s = - if !Clflags.dlcode || !pic_code + if !Clflags.dlcode || !Clflags.pic_code then `bl {emit_symbol s}(PLT)` else `bl {emit_symbol s}` let emit_jump s = - if !Clflags.dlcode || !pic_code + if !Clflags.dlcode || !Clflags.pic_code then `b {emit_symbol s}(PLT)` else `b {emit_symbol s}` @@ -98,26 +99,29 @@ (* Record live pointers at call points *) -let record_frame_label live dbg = - let lbl = new_label() in +let record_frame_label ?label live raise_ dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function - {typ = Addr; loc = Reg r} -> + | {typ = Val; loc = Reg r} -> live_offset := ((r lsl 1) + 1) :: !live_offset - | {typ = Addr; loc = Stack s} as reg -> + | {typ = Val; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset + | {typ = Addr} as r -> + Misc.fatal_error ("bad GC root " ^ Reg.name r) | _ -> ()) live; - frame_descriptors := - { fd_lbl = lbl; - fd_frame_size = frame_size(); - fd_live_offset = !live_offset; - fd_debuginfo = dbg } :: !frame_descriptors; + record_frame_descr ~label:lbl ~frame_size:(frame_size()) + ~live_offset:!live_offset ~raise_frame:raise_ dbg; lbl -let record_frame live dbg = - let lbl = record_frame_label live dbg in `{emit_label lbl}:` +let record_frame ?label live raise_ dbg = + let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:` (* Record calls to the GC -- we've moved them out of the way *) @@ -142,10 +146,10 @@ let bound_error_sites = ref ([] : bound_error_call list) -let bound_error_label dbg = +let bound_error_label ?label dbg = if !Clflags.debug || !bound_error_sites = [] then begin let lbl_bound_error = new_label() in - let lbl_frame = record_frame_label Reg.Set.empty dbg in + let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in bound_error_sites := { bd_lbl = lbl_bound_error; bd_frame_lbl = lbl_frame } :: !bound_error_sites; @@ -173,19 +177,23 @@ | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi" let name_for_int_operation = function - Iadd -> "add" - | Isub -> "sub" - | Imul -> "mul" - | Iand -> "and" - | Ior -> "orr" - | Ixor -> "eor" + (* Use adds,subs,... to enable 16-bit T1 encoding *) + Iadd -> "adds" + | Isub -> "subs" + | Imul -> "mul" + | Imulh -> "smmul" + | Iand -> "ands" + | Ior -> "orrs" + | Ixor -> "eors" + | Ilsl -> "lsls" + | Ilsr -> "lsrs" + | Iasr -> "asrs" | _ -> assert false let name_for_shift_operation = function - Ilsl -> "lsl" - | Ilsr -> "lsr" - | Iasr -> "asr" - | _ -> assert false + Ishiftlogicalleft -> "lsl" + | Ishiftlogicalright -> "lsr" + | Ishiftarithmeticright -> "asr" (* General functional to decompose a non-immediate integer constant into 8-bit chunks shifted left 0 ... 30 bits. *) @@ -233,8 +241,9 @@ decompose_intconst n (fun bits -> if !first - then ` mov {emit_reg dst}, #{emit_int32 bits} @ {emit_int32 n}\n` - else ` add {emit_reg dst}, {emit_reg dst}, #{emit_int32 bits}\n`; + (* Use movs,adds here to enable 16-bit T1 encoding *) + then ` movs {emit_reg dst}, #{emit_int32 bits} @ {emit_int32 n}\n` + else ` adds {emit_reg dst}, {emit_reg dst}, #{emit_int32 bits}\n`; first := false) end @@ -268,7 +277,7 @@ (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 (* Pending floating-point literals *) -let float_literals = ref ([] : (string * label) list) +let float_literals = ref ([] : (int64 * label) list) (* Pending relative references to the global offset table *) let gotrel_literals = ref ([] : (label * label) list) (* Pending symbol literals *) @@ -309,13 +318,13 @@ ` .align 3\n`; List.iter (fun (f, lbl) -> - `{emit_label lbl}: .double {emit_string f}\n`) + `{emit_label lbl}:`; emit_float64_split_directive ".long" f) !float_literals; float_literals := [] end; if !symbol_literals <> [] then begin let offset = if !thumb then 4 else 8 in - let suffix = if !pic_code then "(GOT)" else "" in + let suffix = if !Clflags.pic_code then "(GOT)" else "" in ` .align 2\n`; List.iter (fun (l, lbl) -> @@ -333,7 +342,7 @@ (* Emit code to load the address of a symbol *) let emit_load_symbol_addr dst s = - if !pic_code then begin + if !Clflags.pic_code then begin let lbl_pic = new_label() in let lbl_got = gotrel_literal lbl_pic in let lbl_sym = symbol_literal s in @@ -385,10 +394,8 @@ | Lop(Iconst_int n) -> emit_intconst i.res.(0) (Nativeint.to_int32 n) | Lop(Iconst_float f) when !fpu = Soft -> - ` @ {emit_string f}\n`; - let bits = Int64.bits_of_float (float_of_string f) in - let high_bits = Int64.to_int32 (Int64.shift_right_logical bits 32) - and low_bits = Int64.to_int32 bits in + let high_bits = Int64.to_int32 (Int64.shift_right_logical f 32) + and low_bits = Int64.to_int32 f in if is_immediate low_bits || is_immediate high_bits then begin let ninstr_low = emit_intconst i.res.(0) low_bits and ninstr_high = emit_intconst i.res.(1) high_bits in @@ -401,7 +408,7 @@ end | Lop(Iconst_float f) when !fpu = VFPv2 -> let lbl = float_literal f in - ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n`; + ` fldd {emit_reg i.res.(0)}, {emit_label lbl}\n`; 1 | Lop(Iconst_float f) -> let encode imm = @@ -420,49 +427,49 @@ let ex = ((ex + 3) land 0x07) lxor 0x04 in Some((sg lsl 7) lor (ex lsl 4) lor mn) end in - begin match encode (Int64.bits_of_float (float_of_string f)) with + begin match encode f with None -> let lbl = float_literal f in - ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n` + ` fldd {emit_reg i.res.(0)}, {emit_label lbl}\n` | Some imm8 -> - ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8} @ {emit_string f}\n` + ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8}\n` end; 1 | Lop(Iconst_symbol s) -> emit_load_symbol_addr i.res.(0) s - | Lop(Icall_ind) -> + | Lop(Icall_ind { label_after; }) -> if !arch >= ARMv5 then begin ` blx {emit_reg i.arg.(0)}\n`; - `{record_frame i.live i.dbg}\n`; 1 + `{record_frame i.live false i.dbg ~label:label_after}\n`; 1 end else begin ` mov lr, pc\n`; ` bx {emit_reg i.arg.(0)}\n`; - `{record_frame i.live i.dbg}\n`; 2 + `{record_frame i.live false i.dbg ~label:label_after}\n`; 2 end - | Lop(Icall_imm s) -> - ` {emit_call s}\n`; - `{record_frame i.live i.dbg}\n`; 1 - | Lop(Itailcall_ind) -> + | Lop(Icall_imm { func; label_after; }) -> + ` {emit_call func}\n`; + `{record_frame i.live false i.dbg ~label:label_after}\n`; 1 + | Lop(Itailcall_ind { label_after = _; }) -> output_epilogue begin fun () -> if !contains_calls then ` ldr lr, [sp, #{emit_int (-4)}]\n`; ` bx {emit_reg i.arg.(0)}\n`; 2 end - | Lop(Itailcall_imm s) -> - if s = !function_name then begin + | Lop(Itailcall_imm { func; label_after = _; }) -> + if func = !function_name then begin ` b {emit_label !tailrec_entry_point}\n`; 1 end else begin output_epilogue begin fun () -> if !contains_calls then ` ldr lr, [sp, #{emit_int (-4)}]\n`; - ` {emit_jump s}\n`; 2 + ` {emit_jump func}\n`; 2 end end - | Lop(Iextcall(s, false)) -> - ` {emit_call s}\n`; 1 - | Lop(Iextcall(s, true)) -> - let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) s in + | Lop(Iextcall { func; alloc = false; }) -> + ` {emit_call func}\n`; 1 + | Lop(Iextcall { func; alloc = true; label_after; }) -> + let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) func in ` {emit_call "caml_c_call"}\n`; - `{record_frame i.live i.dbg}\n`; + `{record_frame i.live false i.dbg ~label:label_after}\n`; 1 + ninstr | Lop(Istackoffset n) -> assert (n mod 8 = 0); @@ -503,10 +510,10 @@ | Double_u -> "fldd" | _ (* 32-bit quantities *) -> "ldr" in ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; 1 - | Lop(Istore(Single, addr)) when !fpu >= VFPv2 -> + | Lop(Istore(Single, addr, _)) when !fpu >= VFPv2 -> ` fcvtsd s14, {emit_reg i.arg.(0)}\n`; ` fsts s14, {emit_addressing addr i.arg 1}\n`; 2 - | Lop(Istore((Double | Double_u), addr)) when !fpu = Soft -> + | Lop(Istore((Double | Double_u), addr, _)) when !fpu = Soft -> (* Use STM or STRD if possible *) begin match i.arg.(0), i.arg.(1), addr with {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0 @@ -520,7 +527,7 @@ ` str {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`; ` str {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`; 2 end - | Lop(Istore(size, addr)) -> + | Lop(Istore(size, addr, _)) -> let r = i.arg.(0) in let instr = match size with @@ -532,8 +539,10 @@ | Double_u -> "fstd" | _ (* 32-bit quantities *) -> "str" in ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1 - | Lop(Ialloc n) -> - let lbl_frame = record_frame_label i.live i.dbg in + | Lop(Ialloc { words = n; label_after_call_gc; }) -> + let lbl_frame = + record_frame_label i.live false i.dbg ?label:label_after_call_gc + in if !fastcode_flag then begin let lbl_redo = new_label() in `{emit_label lbl_redo}:`; @@ -562,9 +571,6 @@ `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; 1 + ninstr end - | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> - let shift = name_for_shift_operation op in - ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} {emit_reg i.arg.(1)}\n`; 1 | Lop(Iintop(Icomp cmp)) -> let compthen = name_for_comparison cmp in let compelse = name_for_comparison (negate_integer_comparison cmp) in @@ -579,53 +585,29 @@ ` ite {emit_string compthen}\n`; ` mov{emit_string compthen} {emit_reg i.res.(0)}, #1\n`; ` mov{emit_string compelse} {emit_reg i.res.(0)}, #0\n`; 4 - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop (Icheckbound { label_after_error; } )) -> + let lbl = bound_error_label ?label:label_after_error i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` bls {emit_label lbl}\n`; 2 - | Lop(Iintop_imm(Icheckbound, n)) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) -> + let lbl = bound_error_label ?label:label_after_error i.dbg in ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; ` bls {emit_label lbl}\n`; 2 - | Lop(Ispecific(Ishiftcheckbound shift)) -> + | Lop(Ispecific(Ishiftcheckbound(shiftop, n))) -> let lbl = bound_error_label i.dbg in - ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; + let op = name_for_shift_operation shiftop in + ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, {emit_string op} #{emit_int n}\n`; ` bcs {emit_label lbl}\n`; 2 + | Lop(Iintop Imulh) when !arch < ARMv6 -> + ` smull r12, {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 + | Lop(Ispecific Imulhadd) -> + ` smmla {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; 1 | Lop(Iintop op) -> let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 - | Lop(Iintop_imm(Idiv, n)) -> (* n is a power of 2 *) - let l = Misc.log2 n in - let r = i.res.(0) in - ` movs {emit_reg r}, {emit_reg i.arg.(0)}\n`; - if n <= 256 then begin - ` it lt\n`; - ` addlt {emit_reg r}, {emit_reg r}, #{emit_int (n-1)}\n` - end else begin - ` itt lt\n`; - ` addlt {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; - ` sublt {emit_reg r}, {emit_reg r}, #1\n` - end; - ` mov {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 5 - | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) - let l = Misc.log2 n in - let a = i.arg.(0) in - let r = i.res.(0) in - let lbl = new_label() in - ` cmp {emit_reg a}, #0\n`; - ` mov {emit_reg r}, {emit_reg a}, lsl #{emit_int (32-l)}\n`; - ` mov {emit_reg r}, {emit_reg r}, lsr #{emit_int (32-l)}\n`; - ` bpl {emit_label lbl}\n`; - ` cmp {emit_reg r}, #0\n`; - ` it ne\n`; - ` subne {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; - `{emit_label lbl}:\n`; 7 - | Lop(Iintop_imm((Ilsl | Ilsr | Iasr as op), n)) -> - let shift = name_for_shift_operation op in - ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} #{emit_int n}\n`; 1 + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 | Lop(Iintop_imm(op, n)) -> let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 | Lop(Iabsf | Inegf as op) when !fpu = Soft -> let instr = (match op with Iabsf -> "bic" @@ -664,16 +646,17 @@ | _ -> assert false) in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; 1 - | Lop(Ispecific(Ishiftarith(op, shift))) -> + | Lop(Ispecific(Ishiftarith(op, shiftop, n))) -> let instr = (match op with Ishiftadd -> "add" | Ishiftsub -> "sub" - | Ishiftsubrev -> "rsb") in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`; - if shift >= 0 - then `, lsl #{emit_int shift}\n` - else `, asr #{emit_int (-shift)}\n`; - 1 + | Ishiftsubrev -> "rsb" + | Ishiftand -> "and" + | Ishiftor -> "orr" + | Ishiftxor -> "eor") in + let op = name_for_shift_operation shiftop in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, \ + {emit_reg i.arg.(1)}, {emit_string op} #{emit_int n}\n`; 1 | Lop(Ispecific(Irevsubimm n)) -> ` rsb {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 | Lop(Ispecific(Imuladd | Imulsub as op)) -> @@ -777,7 +760,7 @@ if tramtbl.(j) <> jumptbl.(j) then `{emit_label tramtbl.(j)}: b {emit_label jumptbl.(j)}\n` done - end else if not !pic_code then begin + end else if not !Clflags.pic_code then begin ` ldr pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`; ` nop\n`; for j = 0 to Array.length jumptbl - 1 do @@ -803,11 +786,12 @@ ` pop \{trap_ptr, lr}\n`; cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset - 8; 1 - | Lraise -> - if !Clflags.debug then begin + | Lraise k -> + begin match k with + | Cmm.Raise_withtrace -> ` {emit_call "caml_raise_exn"}\n`; - `{record_frame Reg.Set.empty i.dbg}\n`; 1 - end else begin + `{record_frame Reg.Set.empty true i.dbg}\n`; 1 + | Cmm.Raise_notrace -> ` mov sp, trap_ptr\n`; ` pop \{trap_ptr, pc}\n`; 2 end @@ -840,7 +824,7 @@ let emit_profile() = match Config.system with - "linux_eabi" | "linux_eabihf" -> + "linux_eabi" | "linux_eabihf" | "netbsd" -> ` push \{lr}\n`; ` {emit_call "__gnu_mcount_nc"}\n` | _ -> () @@ -872,8 +856,10 @@ let n = frame_size() in if n > 0 then begin ignore(emit_stack_adjustment (-n)); - if !contains_calls then + if !contains_calls then begin + cfi_offset ~reg:14 (* lr *) ~offset:(-4); ` str lr, [sp, #{emit_int(n - 4)}]\n` + end end; `{emit_label !tailrec_entry_point}:\n`; emit_all 0 fundecl.fun_body; @@ -889,15 +875,13 @@ let emit_item = function Cglobal_symbol s -> ` .globl {emit_symbol s}\n`; | Cdefine_symbol s -> `{emit_symbol s}:\n` - | Cdefine_label lbl -> `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> ` .short {emit_int n}\n` | Cint32 n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` | Cint n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` - | Csingle f -> ` .single {emit_string f}\n` - | Cdouble f -> ` .double {emit_string f}\n` + | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f) + | Cdouble f -> emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` .word {emit_symbol s}\n` - | Clabel_address lbl -> ` .word {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s | Cskip n -> if n > 0 then ` .space {emit_int n}\n` | Calign n -> ` .align {emit_int(Misc.log2 n)}\n` @@ -910,6 +894,7 @@ let begin_assembly() = reset_debug_info(); + ` .file \"\"\n`; (* PR#7037 *) ` .syntax unified\n`; begin match !arch with | ARMv4 -> ` .arch armv4t\n` @@ -951,9 +936,12 @@ ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; emit_frames - { efa_label = (fun lbl -> + { efa_code_label = (fun lbl -> ` .type {emit_label lbl}, %function\n`; ` .word {emit_label lbl}\n`); + efa_data_label = (fun lbl -> + ` .type {emit_label lbl}, %object\n`; + ` .word {emit_label lbl}\n`); efa_16 = (fun n -> ` .short {emit_int n}\n`); efa_32 = (fun n -> ` .long {emit_int32 n}\n`); efa_word = (fun n -> ` .word {emit_int n}\n`); @@ -965,7 +953,7 @@ ` .type {emit_symbol lbl}, %object\n`; ` .size {emit_symbol lbl}, .-{emit_symbol lbl}\n`; begin match Config.system with - "linux_eabihf" | "linux_eabi" -> + "linux_eabihf" | "linux_eabi" | "netbsd" -> (* Mark stack as non-executable *) ` .section .note.GNU-stack,\"\",%progbits\n` | _ -> () diff -Nru ocaml-4.01.0/asmcomp/arm/NOTES.md ocaml-4.05.0/asmcomp/arm/NOTES.md --- ocaml-4.01.0/asmcomp/arm/NOTES.md 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm/NOTES.md 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,20 @@ +# Supported platforms + +A great many variants of the ARM 32-bit architecture: +* Architecture versions: v4, v5, v5te, v6, v6t2, v7. + ARMv7 is the standard nowadays. +* Instruction encoding: classic ARM or Thumb or Thumb-2. +* Floating-point: software emulation, VFPv2, VFPv3-d16, VFP-v3. +* ABI: the standard EABI (with floats passed in integer registers) + or the EABI-HF variant (with floats passed in VFP registers). + +Debian architecture names: `armel` and `armhf`. + +# Reference documents + +* Instruction set architecture: + _ARM Architecture Reference Manual, ARMv7-A and ARMv7-R edition_. + Alternatively: + _ARM Architecture Reference Manual, ARMv8_, restricted to the AArch32 subset. +* Application binary interface: + _Procedure Call Standard for the ARM Architecture_ diff -Nru ocaml-4.01.0/asmcomp/arm/proc.ml ocaml-4.05.0/asmcomp/arm/proc.ml --- ocaml-4.01.0/asmcomp/arm/proc.ml 2013-06-03 18:03:59.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm/proc.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,18 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Benedikt Meurer, University of Siegen *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique *) -(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) -(* reserved. This file is distributed under the terms of the Q *) -(* Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2012 Benedikt Meurer. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Description of the ARM processor *) @@ -63,10 +66,10 @@ let register_class r = match (r.typ, !fpu) with - (Int | Addr), _ -> 0 - | Float, VFPv2 -> 1 - | Float, VFPv3_D16 -> 1 - | Float, _ -> 2 + | (Val | Int | Addr), _ -> 0 + | Float, VFPv2 -> 1 + | Float, VFPv3_D16 -> 1 + | Float, _ -> 2 let num_available_registers = [| 9; 16; 32 |] @@ -82,14 +85,14 @@ (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 9 Reg.dummy in + let v = Array.make 9 Reg.dummy in for i = 0 to 8 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 32 Reg.dummy in + let v = Array.make 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; @@ -104,41 +107,77 @@ let stack_slot slot ty = Reg.at_location ty (Stack slot) +let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *) + (* Calling conventions *) -let calling_conventions - first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in +let calling_conventions first_int last_int first_float last_float make_stack + arg = + let loc = Array.make (Array.length arg) [| Reg.dummy |] in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int <= last_int then begin - loc.(i) <- phys_reg !int; - incr int - end else begin - loc.(i) <- stack_slot (make_stack !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - assert (abi = EABI_HF); - assert (!fpu >= VFPv2); - if !float <= last_float then begin - loc.(i) <- phys_reg !float; - incr float - end else begin - ofs := Misc.align !ofs size_float; - loc.(i) <- stack_slot (make_stack !ofs) Float; - ofs := !ofs + size_float - end + match arg.(i) with + | [| arg |] -> + begin match arg.typ with + | Val | Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- [| phys_reg !int |]; + incr int + end else begin + loc.(i) <- [| stack_slot (make_stack !ofs) ty |]; + ofs := !ofs + size_int + end + | Float -> + assert (abi = EABI_HF); + assert (!fpu >= VFPv2); + if !float <= last_float then begin + loc.(i) <- [| phys_reg !float |]; + incr float + end else begin + ofs := Misc.align !ofs size_float; + loc.(i) <- [| stack_slot (make_stack !ofs) Float |]; + ofs := !ofs + size_float + end + end + | [| arg1; arg2 |] -> + (* Passing of 64-bit quantities to external functions. *) + begin match arg1.typ, arg2.typ with + | Int, Int -> + (* 64-bit quantities split across two registers must either be in a + consecutive pair of registers where the lowest numbered is an + even-numbered register; or in a stack slot that is 8-byte + aligned. *) + int := Misc.align !int 2; + if !int <= last_int - 1 then begin + let reg_lower = phys_reg !int in + let reg_upper = phys_reg (1 + !int) in + loc.(i) <- [| reg_lower; reg_upper |]; + int := !int + 2 + end else begin + let size_int64 = size_int * 2 in + ofs := Misc.align !ofs size_int64; + let stack_lower = stack_slot (make_stack !ofs) Int in + let stack_upper = stack_slot (make_stack (size_int + !ofs)) Int in + loc.(i) <- [| stack_lower; stack_upper |]; + ofs := !ofs + size_int64 + end + | _, _ -> + let f = function Int -> "I" | Addr -> "A" | Val -> "V" | Float -> "F" in + fatal_error (Printf.sprintf "Proc.calling_conventions: bad register \ + type(s) for multi-register argument: %s, %s" + (f arg1.typ) (f arg2.typ)) + end + | _ -> + fatal_error "Proc.calling_conventions: bad number of registers for \ + multi-register argument" done; (loc, Misc.align !ofs 8) (* keep stack 8-aligned *) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" (* OCaml calling convention: first integer args in r0...r7 @@ -146,12 +185,28 @@ remaining args on stack. Return values in r0...r7 or d0...d15. *) +let max_arguments_for_tailcalls = 8 + +let single_regs arg = Array.map (fun arg -> [| arg |]) arg +let ensure_single_regs res = + Array.map (function + | [| res |] -> res + | _ -> failwith "Proc.ensure_single_regs") + res + let loc_arguments arg = - calling_conventions 0 7 100 115 outgoing arg + let (loc, alignment) = + calling_conventions 0 7 100 115 outgoing (single_regs arg) + in + ensure_single_regs loc, alignment let loc_parameters arg = - let (loc, _) = calling_conventions 0 7 100 115 incoming arg in loc + let (loc, _) = calling_conventions 0 7 100 115 incoming (single_regs arg) in + ensure_single_regs loc let loc_results res = - let (loc, _) = calling_conventions 0 7 100 115 not_supported res in loc + let (loc, _) = + calling_conventions 0 7 100 115 not_supported (single_regs res) + in + ensure_single_regs loc (* C calling convention: first integer args in r0...r3 @@ -162,17 +217,24 @@ let loc_external_arguments arg = calling_conventions 0 3 100 107 outgoing arg let loc_external_results res = - let (loc, _) = calling_conventions 0 1 100 100 not_supported res in loc + let (loc, _) = + calling_conventions 0 1 100 100 not_supported (single_regs res) + in + ensure_single_regs loc let loc_exn_bucket = phys_reg 0 +(* Volatile registers: none *) + +let regs_are_volatile _rs = false + (* Registers destroyed by operations *) let destroyed_at_alloc = (* r0-r6, d0-d15 preserved *) Array.of_list (List.map phys_reg [7;8; - 116;116;118;119;120;121;122;123; + 116;117;118;119;120;121;122;123; 124;125;126;127;128;129;130;131]) let destroyed_at_c_call = @@ -183,25 +245,27 @@ [0;1;2;3;8; 100;101;102;103;104;105;106;107; 108;109;110;111;112;113;114;115; - 116;116;118;119;120;121;122;123; + 116;117;118;119;120;121;122;123; 124;125;126;127;128;129;130;131] | EABI_HF -> (* r4-r7, d8-d15 preserved *) [0;1;2;3;8; 100;101;102;103;104;105;106;107; - 116;116;118;119;120;121;122;123; + 116;117;118;119;120;121;122;123; 124;125;126;127;128;129;130;131])) let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _) - | Iop(Iextcall(_, true)) -> + Iop(Icall_ind _ | Icall_imm _) + | Iop(Iextcall { alloc = true; _ }) -> all_phys_regs - | Iop(Iextcall(_, false)) -> + | Iop(Iextcall { alloc = false; _}) -> destroyed_at_c_call | Iop(Ialloc _) -> destroyed_at_alloc - | Iop(Iconst_symbol _) when !pic_code -> + | Iop(Iconst_symbol _) when !Clflags.pic_code -> [| phys_reg 3; phys_reg 8 |] (* r3 and r12 destroyed *) - | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) -> + | Iop(Iintop Imulh) when !arch < ARMv6 -> + [| phys_reg 8 |] (* r12 destroyed *) + | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) -> [| phys_reg 107 |] (* d7 (s14-s15) destroyed *) | _ -> [||] @@ -210,19 +274,31 @@ (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> if abi = EABI then 0 else 4 + Iextcall _ -> if abi = EABI then 0 else 4 | Ialloc _ -> if abi = EABI then 0 else 7 - | Iconst_symbol _ when !pic_code -> 7 + | Iconst_symbol _ when !Clflags.pic_code -> 7 + | Iintop Imulh when !arch < ARMv6 -> 8 | _ -> 9 let max_register_pressure = function - Iextcall(_, _) -> if abi = EABI then [| 4; 0; 0 |] else [| 4; 8; 8 |] + Iextcall _ -> if abi = EABI then [| 4; 0; 0 |] else [| 4; 8; 8 |] | Ialloc _ -> if abi = EABI then [| 7; 0; 0 |] else [| 7; 8; 8 |] - | Iconst_symbol _ when !pic_code -> [| 7; 16; 32 |] + | Iconst_symbol _ when !Clflags.pic_code -> [| 7; 16; 32 |] | Iintoffloat | Ifloatofint - | Iload(Single, _) | Istore(Single, _) -> [| 9; 15; 31 |] + | Iload(Single, _) | Istore(Single, _, _) -> [| 9; 15; 31 |] + | Iintop Imulh when !arch < ARMv6 -> [| 8; 16; 32 |] | _ -> [| 9; 16; 32 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) + | Ispecific(Ishiftcheckbound _) -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0; 0 |] diff -Nru ocaml-4.01.0/asmcomp/arm/reload.ml ocaml-4.05.0/asmcomp/arm/reload.ml --- ocaml-4.01.0/asmcomp/arm/reload.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm/reload.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Reloading for the ARM *) diff -Nru ocaml-4.01.0/asmcomp/arm/scheduling.ml ocaml-4.05.0/asmcomp/arm/scheduling.ml --- ocaml-4.01.0/asmcomp/arm/scheduling.ml 2012-10-24 06:20:45.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm/scheduling.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,22 +1,25 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Benedikt Meurer, University of Siegen *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique *) -(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) -(* reserved. This file is distributed under the terms of the Q *) -(* Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2012 Benedikt Meurer. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Arch open Mach (* Instruction scheduling for the ARM *) -class scheduler = object(self) +class scheduler = object inherit Schedgen.scheduler_generic as super @@ -31,8 +34,8 @@ | Ifloatofint (* mcr/mrc count as memory access *) | Iintoffloat -> 2 (* Multiplys have a latency of two cycles *) - | Iintop Imul - | Ispecific(Imuladd | Imulsub) -> 2 + | Iintop (Imul | Imulh) + | Ispecific(Imuladd | Imulsub | Imulhadd) -> 2 (* VFP instructions *) | Iaddf | Isubf @@ -55,13 +58,11 @@ | Iintop(Ilsl | Ilsr | Iasr) -> 2 | Iintop(Icomp _) | Iintop_imm(Icomp _, _) -> 3 - | Iintop(Icheckbound) - | Iintop_imm(Icheckbound, _) -> 2 + | Iintop(Icheckbound _) + | Iintop_imm(Icheckbound _, _) -> 2 | Ispecific(Ishiftcheckbound _) -> 3 - | Iintop_imm(Idiv, _) -> 4 - | Iintop_imm(Imod, _) -> 6 - | Iintop Imul - | Ispecific(Imuladd | Imulsub) -> 2 + | Iintop(Imul | Imulh) + | Ispecific(Imuladd | Imulsub | Imulhadd) -> 2 (* VFP instructions *) | Iaddf | Isubf -> 7 diff -Nru ocaml-4.01.0/asmcomp/arm/selection.ml ocaml-4.05.0/asmcomp/arm/selection.ml --- ocaml-4.01.0/asmcomp/arm/selection.ml 2013-05-08 13:21:32.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm/selection.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,18 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Benedikt Meurer, University of Siegen *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique *) -(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) -(* reserved. This file is distributed under the terms of the Q *) -(* Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2012 Benedikt Meurer. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Instruction selection for the ARM processor *) @@ -27,7 +30,7 @@ (* ARM load/store byte/word have -4095 to 4095 *) | Byte_unsigned | Byte_signed | Thirtytwo_unsigned | Thirtytwo_signed - | Word | Single + | Word_int | Word_val | Single when not !thumb -> n >= -4095 && n <= 4095 (* Thumb-2 load/store have -255 to 4095 *) @@ -37,15 +40,19 @@ | _ -> n >= -255 && n <= 255 -let is_intconst = function - Cconst_int _ -> true - | _ -> false +let select_shiftop = function + Clsl -> Ishiftlogicalleft + | Clsr -> Ishiftlogicalright + | Casr -> Ishiftarithmeticright + | __-> assert false (* Special constraints on operand and result registers *) exception Use_default let r1 = phys_reg 1 +let r6 = phys_reg 6 +let r7 = phys_reg 7 let pseudoregs_for_operation op arg res = match op with @@ -54,6 +61,13 @@ is also a result of the mul / mla operation. *) Iintop Imul | Ispecific Imuladd when !arch < ARMv6 -> (arg, [| res.(0); arg.(0) |]) + (* For smull rdlo,rdhi,rn,rm (pre-ARMv6) the registers rdlo, rdhi and rn + must be different. Also, rdlo (whose contents we discard) is always + forced to be r12 in proc.ml, which means that neither rdhi and rn can + be r12. To keep things simple, we force both of those two to specific + hard regs: rdhi in r6 and rn in r7. *) + | Iintop Imulh when !arch < ARMv6 -> + ([| r7; arg.(1) |], [| r6 |]) (* Soft-float Iabsf and Inegf: arg.(0) and res.(0) must be the same *) | Iabsf | Inegf when !fpu = Soft -> ([|res.(0); arg.(1)|], res) @@ -64,7 +78,7 @@ (arg', res) (* We use __aeabi_idivmod for Cmodi only, and hence we care only for the remainder in r1, so fix up the destination register. *) - | Iextcall("__aeabi_idivmod", false) -> + | Iextcall { func = "__aeabi_idivmod"; alloc = false; } -> (arg, [|r1|]) (* Other instructions are regular *) | _ -> raise Use_default @@ -77,6 +91,8 @@ method! regs_for tyv = Reg.createv (if !fpu = Soft then begin (* Expand floats into pairs of integer registers *) + (* CR mshinwell: we need to check this in conjunction with + the unboxed external functionality *) let rec expand = function [] -> [] | Float :: tyl -> Int :: Int :: expand tyl @@ -91,53 +107,70 @@ method! is_simple_expr = function (* inlined floating-point ops are simple if their arguments are *) - | Cop(Cextcall("sqrt", _, _, _), args) when !fpu >= VFPv2 -> + | Cop(Cextcall("sqrt", _, _, _), args, _) when !fpu >= VFPv2 -> List.for_all self#is_simple_expr args (* inlined byte-swap ops are simple if their arguments are *) - | Cop(Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 -> + | Cop(Cextcall("caml_bswap16_direct", _, _, _), args, _) + when !arch >= ARMv6T2 -> List.for_all self#is_simple_expr args - | Cop(Cextcall("caml_int32_direct_bswap", _,_,_), args) when !arch >= ARMv6 -> + | Cop(Cextcall("caml_int32_direct_bswap",_,_,_), args, _) + when !arch >= ARMv6 -> List.for_all self#is_simple_expr args | e -> super#is_simple_expr e +method! effects_of e = + match e with + | Cop(Cextcall("sqrt", _, _, _), args, _) when !fpu >= VFPv2 -> + Selectgen.Effect_and_coeffect.join_list_map args self#effects_of + | Cop(Cextcall("caml_bswap16_direct", _, _, _), args, _) + when !arch >= ARMv6T2 -> + Selectgen.Effect_and_coeffect.join_list_map args self#effects_of + | Cop(Cextcall("caml_int32_direct_bswap",_,_,_), args, _) + when !arch >= ARMv6 -> + Selectgen.Effect_and_coeffect.join_list_map args self#effects_of + | e -> super#effects_of e + method select_addressing chunk = function - | Cop(Cadda, [arg; Cconst_int n]) + | Cop((Cadda | Caddv), [arg; Cconst_int n], _) when is_offset chunk n -> (Iindexed n, arg) - | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) + | Cop((Cadda | Caddv as op), [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg) when is_offset chunk n -> - (Iindexed n, Cop(Cadda, [arg1; arg2])) + (Iindexed n, Cop(op, [arg1; arg2], dbg)) | arg -> (Iindexed 0, arg) -method select_shift_arith op shiftop shiftrevop args = +method select_shift_arith op dbg arithop arithrevop args = match args with - [arg1; Cop(Clsl, [arg2; Cconst_int n])] - when n > 0 && n < 32 && not(is_intconst arg2) -> - (Ispecific(Ishiftarith(shiftop, n)), [arg1; arg2]) - | [arg1; Cop(Casr, [arg2; Cconst_int n])] - when n > 0 && n < 32 && not(is_intconst arg2) -> - (Ispecific(Ishiftarith(shiftop, -n)), [arg1; arg2]) - | [Cop(Clsl, [arg1; Cconst_int n]); arg2] - when n > 0 && n < 32 && not(is_intconst arg1) -> - (Ispecific(Ishiftarith(shiftrevop, n)), [arg2; arg1]) - | [Cop(Casr, [arg1; Cconst_int n]); arg2] - when n > 0 && n < 32 && not(is_intconst arg1) -> - (Ispecific(Ishiftarith(shiftrevop, -n)), [arg2; arg1]) + [arg1; Cop(Clsl | Clsr | Casr as op, [arg2; Cconst_int n], _)] + when n > 0 && n < 32 -> + (Ispecific(Ishiftarith(arithop, select_shiftop op, n)), [arg1; arg2]) + | [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n], _); arg2] + when n > 0 && n < 32 -> + (Ispecific(Ishiftarith(arithrevop, select_shiftop op, n)), [arg2; arg1]) | args -> - begin match super#select_operation op args with + begin match super#select_operation op args dbg with + (* Recognize multiply high and add *) + (Iintop Iadd, [Cop(Cmulhi, args, _); arg3]) + | (Iintop Iadd, [arg3; Cop(Cmulhi, args, _)]) as op_args + when !arch >= ARMv6 -> + begin match self#select_operation Cmulhi args dbg with + (Iintop Imulh, [arg1; arg2]) -> + (Ispecific Imulhadd, [arg1; arg2; arg3]) + | _ -> op_args + end (* Recognize multiply and add *) - (Iintop Iadd, [Cop(Cmuli, args); arg3]) - | (Iintop Iadd, [arg3; Cop(Cmuli, args)]) as op_args -> - begin match self#select_operation Cmuli args with + | (Iintop Iadd, [Cop(Cmuli, args, _); arg3]) + | (Iintop Iadd, [arg3; Cop(Cmuli, args, _)]) as op_args -> + begin match self#select_operation Cmuli args dbg with (Iintop Imul, [arg1; arg2]) -> (Ispecific Imuladd, [arg1; arg2; arg3]) | _ -> op_args end (* Recognize multiply and subtract *) - | (Iintop Isub, [arg3; Cop(Cmuli, args)]) as op_args + | (Iintop Isub, [arg3; Cop(Cmuli, args, _)]) as op_args when !arch > ARMv6 -> - begin match self#select_operation Cmuli args with + begin match self#select_operation Cmuli args dbg with (Iintop Imul, [arg1; arg2]) -> (Ispecific Imulsub, [arg1; arg2; arg3]) | _ -> op_args @@ -145,60 +178,67 @@ | op_args -> op_args end -method! select_operation op args = +method private iextcall (func, alloc) = + Iextcall { func; alloc; label_after = Cmm.new_label (); } + +method! select_operation op args dbg = match (op, args) with (* Recognize special shift arithmetic *) - ((Cadda | Caddi), [arg; Cconst_int n]) + ((Caddv | Cadda | Caddi), [arg; Cconst_int n]) when n < 0 && self#is_immediate (-n) -> (Iintop_imm(Isub, -n), [arg]) - | ((Cadda | Caddi as op), args) -> - self#select_shift_arith op Ishiftadd Ishiftadd args - | ((Csuba | Csubi), [arg; Cconst_int n]) + | ((Caddv | Cadda | Caddi as op), args) -> + self#select_shift_arith op dbg Ishiftadd Ishiftadd args + | (Csubi, [arg; Cconst_int n]) when n < 0 && self#is_immediate (-n) -> (Iintop_imm(Iadd, -n), [arg]) - | ((Csuba | Csubi), [Cconst_int n; arg]) + | (Csubi, [Cconst_int n; arg]) when self#is_immediate n -> (Ispecific(Irevsubimm n), [arg]) - | ((Csuba | Csubi as op), args) -> - self#select_shift_arith op Ishiftsub Ishiftsubrev args - | (Ccheckbound _, [Cop(Clsr, [arg1; Cconst_int n]); arg2]) - when n > 0 && n < 32 && not(is_intconst arg2) -> - (Ispecific(Ishiftcheckbound n), [arg1; arg2]) + | (Csubi as op, args) -> + self#select_shift_arith op dbg Ishiftsub Ishiftsubrev args + | (Cand as op, args) -> + self#select_shift_arith op dbg Ishiftand Ishiftand args + | (Cor as op, args) -> + self#select_shift_arith op dbg Ishiftor Ishiftor args + | (Cxor as op, args) -> + self#select_shift_arith op dbg Ishiftxor Ishiftxor args + | (Ccheckbound, + [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n], _); arg2]) + when n > 0 && n < 32 -> + (Ispecific(Ishiftcheckbound(select_shiftop op, n)), [arg1; arg2]) (* ARM does not support immediate operands for multiplication *) | (Cmuli, args) -> (Iintop Imul, args) + | (Cmulhi, args) -> + (Iintop Imulh, args) (* Turn integer division/modulus into runtime ABI calls *) - | (Cdivi, [arg; Cconst_int n]) - when n = 1 lsl Misc.log2 n -> - (Iintop_imm(Idiv, n), [arg]) | (Cdivi, args) -> - (Iextcall("__aeabi_idiv", false), args) - | (Cmodi, [arg; Cconst_int n]) - when n > 1 && n = 1 lsl Misc.log2 n -> - (Iintop_imm(Imod, n), [arg]) + (self#iextcall("__aeabi_idiv", false), args) | (Cmodi, args) -> (* See above for fix up of return register *) - (Iextcall("__aeabi_idivmod", false), args) + (self#iextcall("__aeabi_idivmod", false), args) (* Recognize 16-bit bswap instruction (ARMv6T2 because we need movt) *) | (Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 -> (Ispecific(Ibswap 16), args) (* Recognize 32-bit bswap instructions (ARMv6 and above) *) - | (Cextcall("caml_int32_direct_bswap", _, _, _), args) when !arch >= ARMv6 -> + | (Cextcall("caml_int32_direct_bswap", _, _, _), args) + when !arch >= ARMv6 -> (Ispecific(Ibswap 32), args) (* Turn floating-point operations into runtime ABI calls for softfp *) - | (op, args) when !fpu = Soft -> self#select_operation_softfp op args + | (op, args) when !fpu = Soft -> self#select_operation_softfp op args dbg (* Select operations for VFPv{2,3} *) - | (op, args) -> self#select_operation_vfpv3 op args + | (op, args) -> self#select_operation_vfpv3 op args dbg -method private select_operation_softfp op args = +method private select_operation_softfp op args dbg = match (op, args) with (* Turn floating-point operations into runtime ABI calls *) - | (Caddf, args) -> (Iextcall("__aeabi_dadd", false), args) - | (Csubf, args) -> (Iextcall("__aeabi_dsub", false), args) - | (Cmulf, args) -> (Iextcall("__aeabi_dmul", false), args) - | (Cdivf, args) -> (Iextcall("__aeabi_ddiv", false), args) - | (Cfloatofint, args) -> (Iextcall("__aeabi_i2d", false), args) - | (Cintoffloat, args) -> (Iextcall("__aeabi_d2iz", false), args) + | (Caddf, args) -> (self#iextcall("__aeabi_dadd", false), args) + | (Csubf, args) -> (self#iextcall("__aeabi_dsub", false), args) + | (Cmulf, args) -> (self#iextcall("__aeabi_dmul", false), args) + | (Cdivf, args) -> (self#iextcall("__aeabi_ddiv", false), args) + | (Cfloatofint, args) -> (self#iextcall("__aeabi_i2d", false), args) + | (Cintoffloat, args) -> (self#iextcall("__aeabi_d2iz", false), args) | (Ccmpf comp, args) -> let func = (match comp with Cne (* there's no __aeabi_dcmpne *) @@ -211,47 +251,47 @@ Cne -> Ceq (* eq 0 => false *) | _ -> Cne (* ne 0 => true *)) in (Iintop_imm(Icomp(Iunsigned comp), 0), - [Cop(Cextcall(func, typ_int, false, Debuginfo.none), args)]) + [Cop(Cextcall(func, typ_int, false, None), args, dbg)]) (* Add coercions around loads and stores of 32-bit floats *) - | (Cload Single, args) -> - (Iextcall("__aeabi_f2d", false), [Cop(Cload Word, args)]) - | (Cstore Single, [arg1; arg2]) -> + | (Cload (Single, mut), args) -> + (self#iextcall("__aeabi_f2d", false), + [Cop(Cload (Word_int, mut), args, dbg)]) + | (Cstore (Single, init), [arg1; arg2]) -> let arg2' = - Cop(Cextcall("__aeabi_d2f", typ_int, false, Debuginfo.none), - [arg2]) in - self#select_operation (Cstore Word) [arg1; arg2'] + Cop(Cextcall("__aeabi_d2f", typ_int, false, None), [arg2], dbg) in + self#select_operation (Cstore (Word_int, init)) [arg1; arg2'] dbg (* Other operations are regular *) - | (op, args) -> super#select_operation op args + | (op, args) -> super#select_operation op args dbg -method private select_operation_vfpv3 op args = +method private select_operation_vfpv3 op args dbg = match (op, args) with (* Recognize floating-point negate and multiply *) - (Cnegf, [Cop(Cmulf, args)]) -> + (Cnegf, [Cop(Cmulf, args, _)]) -> (Ispecific Inegmulf, args) (* Recognize floating-point multiply and add *) - | (Caddf, [arg; Cop(Cmulf, args)]) - | (Caddf, [Cop(Cmulf, args); arg]) -> + | (Caddf, [arg; Cop(Cmulf, args, _)]) + | (Caddf, [Cop(Cmulf, args, _); arg]) -> (Ispecific Imuladdf, arg :: args) (* Recognize floating-point negate, multiply and subtract *) - | (Csubf, [Cop(Cnegf, [arg]); Cop(Cmulf, args)]) - | (Csubf, [Cop(Cnegf, [Cop(Cmulf, args)]); arg]) -> + | (Csubf, [Cop(Cnegf, [arg], _); Cop(Cmulf, args, _)]) + | (Csubf, [Cop(Cnegf, [Cop(Cmulf, args, _)], _); arg]) -> (Ispecific Inegmulsubf, arg :: args) (* Recognize floating-point negate, multiply and add *) - | (Csubf, [arg; Cop(Cmulf, args)]) -> + | (Csubf, [arg; Cop(Cmulf, args, _)]) -> (Ispecific Inegmuladdf, arg :: args) (* Recognize multiply and subtract *) - | (Csubf, [Cop(Cmulf, args); arg]) -> + | (Csubf, [Cop(Cmulf, args, _); arg]) -> (Ispecific Imulsubf, arg :: args) (* Recognize floating-point square root *) | (Cextcall("sqrt", _, false, _), args) -> (Ispecific Isqrtf, args) (* Other operations are regular *) - | (op, args) -> super#select_operation op args + | (op, args) -> super#select_operation op args dbg method! select_condition = function (* Turn floating-point comparisons into runtime ABI calls *) - Cop(Ccmpf _ as op, args) when !fpu = Soft -> - begin match self#select_operation_softfp op args with + Cop(Ccmpf _ as op, args, dbg) when !fpu = Soft -> + begin match self#select_operation_softfp op args dbg with (Iintop_imm(Icomp(Iunsigned Ceq), 0), [arg]) -> (Ifalsetest, arg) | (Iintop_imm(Icomp(Iunsigned Cne), 0), [arg]) -> (Itruetest, arg) | _ -> assert false diff -Nru ocaml-4.01.0/asmcomp/arm64/arch.ml ocaml-4.05.0/asmcomp/arm64/arch.ml --- ocaml-4.01.0/asmcomp/arm64/arch.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm64/arch.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,171 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2012 Benedikt Meurer. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Specific operations for the ARM processor, 64-bit mode *) + +open Format + +let command_line_options = [] + +(* Addressing modes *) + +type addressing_mode = + | Iindexed of int (* reg + displ *) + | Ibased of string * int (* global var + displ *) + +(* We do not support the reg + shifted reg addressing mode, because + what we really need is reg + shifted reg + displ, + and this is decomposed in two instructions (reg + shifted reg -> tmp, + then addressing tmp + displ). *) + +(* Specific operations *) + +type cmm_label = int + (* Do not introduce a dependency to Cmm *) + +type specific_operation = + | Ifar_alloc of { words : int; label_after_call_gc : cmm_label option; } + | Ifar_intop_checkbound of { label_after_error : cmm_label option; } + | Ifar_intop_imm_checkbound of + { bound : int; label_after_error : cmm_label option; } + | Ishiftarith of arith_operation * int + | Ishiftcheckbound of { shift : int; label_after_error : cmm_label option; } + | Ifar_shiftcheckbound of + { shift : int; label_after_error : cmm_label option; } + | Imuladd (* multiply and add *) + | Imulsub (* multiply and subtract *) + | Inegmulf (* floating-point negate and multiply *) + | Imuladdf (* floating-point multiply and add *) + | Inegmuladdf (* floating-point negate, multiply and add *) + | Imulsubf (* floating-point multiply and subtract *) + | Inegmulsubf (* floating-point negate, multiply and subtract *) + | Isqrtf (* floating-point square root *) + | Ibswap of int (* endianess conversion *) + +and arith_operation = + Ishiftadd + | Ishiftsub + +let spacetime_node_hole_pointer_is_live_before = function + | Ifar_alloc _ | Ifar_intop_checkbound _ | Ifar_intop_imm_checkbound _ + | Ishiftarith _ | Ishiftcheckbound _ | Ifar_shiftcheckbound _ -> false + | Imuladd | Imulsub | Inegmulf | Imuladdf | Inegmuladdf | Imulsubf + | Inegmulsubf | Isqrtf | Ibswap _ -> false + +(* Sizes, endianness *) + +let big_endian = false + +let size_addr = 8 +let size_int = 8 +let size_float = 8 + +let allow_unaligned_access = false + +(* Behavior of division *) + +let division_crashes_on_overflow = false + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing addr delta = + match addr with + | Iindexed n -> Iindexed(n + delta) + | Ibased(s, n) -> Ibased(s, n + delta) + +let num_args_addressing = function + | Iindexed _ -> 1 + | Ibased _ -> 0 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + match addr with + | Iindexed n -> + printreg ppf arg.(0); + if n <> 0 then fprintf ppf " + %i" n + | Ibased(s, 0) -> + fprintf ppf "\"%s\"" s + | Ibased(s, n) -> + fprintf ppf "\"%s\" + %i" s n + +let print_specific_operation printreg op ppf arg = + match op with + | Ifar_alloc { words; label_after_call_gc = _; } -> + fprintf ppf "(far) alloc %i" words + | Ifar_intop_checkbound _ -> + fprintf ppf "%a (far) check > %a" printreg arg.(0) printreg arg.(1) + | Ifar_intop_imm_checkbound { bound; _ } -> + fprintf ppf "%a (far) check > %i" printreg arg.(0) bound + | Ishiftarith(op, shift) -> + let op_name = function + | Ishiftadd -> "+" + | Ishiftsub -> "-" in + let shift_mark = + if shift >= 0 + then sprintf "<< %i" shift + else sprintf ">> %i" (-shift) in + fprintf ppf "%a %s %a %s" + printreg arg.(0) (op_name op) printreg arg.(1) shift_mark + | Ishiftcheckbound { shift; _ } -> + fprintf ppf "check %a >> %i > %a" printreg arg.(0) shift + printreg arg.(1) + | Ifar_shiftcheckbound { shift; _ } -> + fprintf ppf + "(far) check %a >> %i > %a" printreg arg.(0) shift printreg arg.(1) + | Imuladd -> + fprintf ppf "(%a * %a) + %a" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Imulsub -> + fprintf ppf "-(%a * %a) + %a" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmulf -> + fprintf ppf "-f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + | Imuladdf -> + fprintf ppf "%a +f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmuladdf -> + fprintf ppf "(-f %a) -f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Imulsubf -> + fprintf ppf "%a -f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmulsubf -> + fprintf ppf "(-f %a) +f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Isqrtf -> + fprintf ppf "sqrtf %a" + printreg arg.(0) + | Ibswap n -> + fprintf ppf "bswap%i %a" n + printreg arg.(0) diff -Nru ocaml-4.01.0/asmcomp/arm64/CSE.ml ocaml-4.05.0/asmcomp/arm64/CSE.ml --- ocaml-4.01.0/asmcomp/arm64/CSE.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm64/CSE.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* CSE for ARM64 *) + +open Arch +open Mach +open CSEgen + +class cse = object + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Ishiftcheckbound _) -> Op_checkbound + | Ispecific _ -> Op_pure + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n -> n <= 65535n && n >= 0n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/arm64/emit.mlp ocaml-4.05.0/asmcomp/arm64/emit.mlp --- ocaml-4.01.0/asmcomp/arm64/emit.mlp 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm64/emit.mlp 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,993 @@ +#2 "asmcomp/arm64/emit.mlp" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2012 Benedikt Meurer. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Emission of ARM assembly code, 64-bit mode *) + +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +(* Names for special regs *) + +let reg_trap_ptr = phys_reg 23 +let reg_alloc_ptr = phys_reg 24 +let reg_alloc_limit = phys_reg 25 +let reg_tmp1 = phys_reg 26 +let reg_x15 = phys_reg 15 + +(* Output a label *) + +let emit_label lbl = + emit_string ".L"; emit_int lbl + +(* Symbols *) + +let emit_symbol s = + Emitaux.emit_symbol '$' s + +(* Output a pseudo-register *) + +let emit_reg = function + {loc = Reg r} -> emit_string (register_name r) + | _ -> fatal_error "Emit.emit_reg" + +(* Likewise, but with the 32-bit name of the register *) + +let int_reg_name_w = + [| "w0"; "w1"; "w2"; "w3"; "w4"; "w5"; "w6"; "w7"; + "w8"; "w9"; "w10"; "w11"; "w12"; "w13"; "w14"; "w15"; + "w19"; "w20"; "w21"; "w22"; "w23"; "w24"; "w25"; + "w26"; "w27"; "w28"; "w16"; "w17" |] + +let emit_wreg = function + {loc = Reg r} -> emit_string int_reg_name_w.(r) + | _ -> fatal_error "Emit.emit_wreg" + +(* Layout of the stack frame *) + +let stack_offset = ref 0 + +let frame_size () = + let sz = + !stack_offset + + 8 * num_stack_slots.(0) + + 8 * num_stack_slots.(1) + + (if !contains_calls then 8 else 0) + in Misc.align sz 16 + +let slot_offset loc cl = + match loc with + Incoming n -> + assert (n >= 0); + frame_size() + n + | Local n -> + !stack_offset + + (if cl = 0 + then n * 8 + else num_stack_slots.(0) * 8 + n * 8) + | Outgoing n -> + assert (n >= 0); + n + +(* Output a stack reference *) + +let emit_stack r = + match r.loc with + | Stack s -> + let ofs = slot_offset s (register_class r) in `[sp, #{emit_int ofs}]` + | _ -> fatal_error "Emit.emit_stack" + +(* Output an addressing mode *) + +let emit_symbol_offset s ofs = + emit_symbol s; + if ofs > 0 then `+{emit_int ofs}` + else if ofs < 0 then `-{emit_int (-ofs)}` + else () + +let emit_addressing addr r = + match addr with + | Iindexed ofs -> + `[{emit_reg r}, #{emit_int ofs}]` + | Ibased(s, ofs) -> + `[{emit_reg r}, #:lo12:{emit_symbol_offset s ofs}]` + +(* Record live pointers at call points *) + +let record_frame_label ?label live raise_ dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in + let live_offset = ref [] in + Reg.Set.iter + (function + | {typ = Val; loc = Reg r} -> + live_offset := ((r lsl 1) + 1) :: !live_offset + | {typ = Val; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | {typ = Addr} as r -> + Misc.fatal_error ("bad GC root " ^ Reg.name r) + | _ -> ()) + live; + record_frame_descr ~label:lbl ~frame_size:(frame_size()) + ~live_offset:!live_offset ~raise_frame:raise_ dbg; + lbl + +let record_frame ?label live raise_ dbg = + let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:` + +(* Record calls to the GC -- we've moved them out of the way *) + +type gc_call = + { gc_lbl: label; (* Entry label *) + gc_return_lbl: label; (* Where to branch after GC *) + gc_frame_lbl: label } (* Label of frame descriptor *) + +let call_gc_sites = ref ([] : gc_call list) + +let emit_call_gc gc = + `{emit_label gc.gc_lbl}: bl {emit_symbol "caml_call_gc"}\n`; + `{emit_label gc.gc_frame_lbl}: b {emit_label gc.gc_return_lbl}\n` + +(* Record calls to caml_ml_array_bound_error. + In debug mode, we maintain one call to caml_ml_array_bound_error + per bound check site. Otherwise, we can share a single call. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame_lbl: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) + +let bound_error_label ?label dbg = + if !Clflags.debug || !bound_error_sites = [] then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; + bd_frame_lbl = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + let bd = List.hd !bound_error_sites in bd.bd_lbl + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: bl {emit_symbol "caml_ml_array_bound_error"}\n`; + `{emit_label bd.bd_frame_lbl}:\n` + +(* Names of various instructions *) + +let name_for_comparison = function + | Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le" + | Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt" + | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls" + | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi" + +let name_for_int_operation = function + | Iadd -> "add" + | Isub -> "sub" + | Imul -> "mul" + | Idiv -> "sdiv" + | Iand -> "and" + | Ior -> "orr" + | Ixor -> "eor" + | Ilsl -> "lsl" + | Ilsr -> "lsr" + | Iasr -> "asr" + | _ -> assert false + +(* Load an integer constant into a register *) + +let emit_intconst dst n = + let rec emit_pos first shift = + if shift < 0 then begin + if first then ` mov {emit_reg dst}, xzr\n` + end else begin + let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in + if s = 0n then emit_pos first (shift - 16) else begin + if first then + ` movz {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n` + else + ` movk {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`; + emit_pos false (shift - 16) + end + end + and emit_neg first shift = + if shift < 0 then begin + if first then ` movn {emit_reg dst}, #0\n` + end else begin + let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in + if s = 0xFFFFn then emit_neg first (shift - 16) else begin + if first then + ` movn {emit_reg dst}, #{emit_nativeint (Nativeint.logxor s 0xFFFFn)}, lsl #{emit_int shift}\n` + else + ` movk {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`; + emit_neg false (shift - 16) + end + end + in + if n < 0n then emit_neg true 48 else emit_pos true 48 + +let num_instructions_for_intconst n = + let num_instructions = ref 0 in + let rec count_pos first shift = + if shift < 0 then begin + if first then incr num_instructions + end else begin + let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in + if s = 0n then count_pos first (shift - 16) else begin + incr num_instructions; + count_pos false (shift - 16) + end + end + and count_neg first shift = + if shift < 0 then begin + if first then incr num_instructions + end else begin + let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in + if s = 0xFFFFn then count_neg first (shift - 16) else begin + incr num_instructions; + count_neg false (shift - 16) + end + end + in + if n < 0n then count_neg true 48 else count_pos true 48; + !num_instructions + +(* Recognize float constants appropriate for FMOV dst, #fpimm instruction: + "a normalized binary floating point encoding with 1 sign bit, 4 + bits of fraction and a 3-bit exponent" *) + +let is_immediate_float bits = + let exp = (Int64.(to_int (shift_right_logical bits 52)) land 0x7FF) - 1023 in + let mant = Int64.logand bits 0xF_FFFF_FFFF_FFFFL in + exp >= -3 && exp <= 4 && Int64.logand mant 0xF_0000_0000_0000L = mant + +(* Adjust sp (up or down) by the given byte amount *) + +let emit_stack_adjustment n = + let instr = if n < 0 then "sub" else "add" in + let m = abs n in + assert (m < 0x1_000_000); + let ml = m land 0xFFF and mh = m land 0xFFF_000 in + if mh <> 0 then ` {emit_string instr} sp, sp, #{emit_int mh}\n`; + if ml <> 0 then ` {emit_string instr} sp, sp, #{emit_int ml}\n`; + if n <> 0 then cfi_adjust_cfa_offset (-n) + +(* Deallocate the stack frame and reload the return address + before a return or tail call *) + +let output_epilogue f = + let n = frame_size() in + if !contains_calls then + ` ldr x30, [sp, #{emit_int (n-8)}]\n`; + if n > 0 then + emit_stack_adjustment n; + f(); + (* reset CFA back because function body may continue *) + if n > 0 then cfi_adjust_cfa_offset n + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 +(* Pending floating-point literals *) +let float_literals = ref ([] : (int64 * label) list) + +(* Label a floating-point literal *) +let float_literal f = + try + List.assoc f !float_literals + with Not_found -> + let lbl = new_label() in + float_literals := (f, lbl) :: !float_literals; + lbl + +(* Emit all pending literals *) +let emit_literals() = + if !float_literals <> [] then begin + ` .align 3\n`; + List.iter + (fun (f, lbl) -> + `{emit_label lbl}:`; emit_float64_directive ".quad" f) + !float_literals; + float_literals := [] + end + +(* Emit code to load the address of a symbol *) + +let emit_load_symbol_addr dst s = + if (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit s then begin + ` adrp {emit_reg dst}, {emit_symbol s}\n`; + ` add {emit_reg dst}, {emit_reg dst}, #:lo12:{emit_symbol s}\n` + end else begin + ` adrp {emit_reg dst}, :got:{emit_symbol s}\n`; + ` ldr {emit_reg dst}, [{emit_reg dst}, #:got_lo12:{emit_symbol s}]\n` + end + +(* The following functions are used for calculating the sizes of the + call GC and bounds check points emitted out-of-line from the function + body. See branch_relaxation.mli. *) + +let num_call_gc_and_check_bound_points instr = + let rec loop instr ((call_gc, check_bound) as totals) = + match instr.desc with + | Lend -> totals + | Lop (Ialloc _) when !fastcode_flag -> + loop instr.next (call_gc + 1, check_bound) + | Lop (Iintop Icheckbound _) + | Lop (Iintop_imm (Icheckbound _, _)) + | Lop (Ispecific (Ishiftcheckbound _)) -> + let check_bound = + (* When not in debug mode, there is at most one check-bound point. *) + if not !Clflags.debug then 1 + else check_bound + 1 + in + loop instr.next (call_gc, check_bound) + (* The following four should never be seen, since this function is run + before branch relaxation. *) + | Lop (Ispecific (Ifar_alloc _)) + | Lop (Ispecific Ifar_intop_checkbound _) + | Lop (Ispecific (Ifar_intop_imm_checkbound _)) + | Lop (Ispecific (Ifar_shiftcheckbound _)) -> assert false + | _ -> loop instr.next totals + in + loop instr (0, 0) + +let max_out_of_line_code_offset ~num_call_gc ~num_check_bound = + if num_call_gc < 1 && num_check_bound < 1 then 0 + else begin + let size_of_call_gc = 2 in + let size_of_check_bound = 1 in + let size_of_last_thing = + (* Call-GC points come before check-bound points. *) + if num_check_bound >= 1 then size_of_check_bound else size_of_call_gc + in + let total_size = + size_of_call_gc*num_call_gc + size_of_check_bound*num_check_bound + in + let max_offset = total_size - size_of_last_thing in + assert (max_offset >= 0); + max_offset + end + +module BR = Branch_relaxation.Make (struct + (* CR-someday mshinwell: B and BL have +/- 128Mb ranges; for the moment we + assume we will never exceed this. It would seem to be most likely to + occur for branches between functions; in this case, the linker should be + able to insert veneers anyway. (See section 4.6.7 of the document + "ELF for the ARM 64-bit architecture (AArch64)".) *) + + type distance = int + + module Cond_branch = struct + type t = TB | CB | Bcc + + let all = [TB; CB; Bcc] + + (* AArch64 instructions are 32 bits wide, so [distance] in this module + means units of 32-bit words. *) + let max_displacement = function + | TB -> 32 * 1024 / 4 (* +/- 32Kb *) + | CB | Bcc -> 1 * 1024 * 1024 / 4 (* +/- 1Mb *) + + let classify_instr = function + | Lop (Ialloc _) + | Lop (Iintop Icheckbound _) + | Lop (Iintop_imm (Icheckbound _, _)) + | Lop (Ispecific (Ishiftcheckbound _)) -> Some Bcc + (* The various "far" variants in [specific_operation] don't need to + return [Some] here, since their code sequences never contain any + conditional branches that might need relaxing. *) + | Lcondbranch (Itruetest, _) + | Lcondbranch (Ifalsetest, _) -> Some CB + | Lcondbranch (Iinttest _, _) + | Lcondbranch (Iinttest_imm _, _) + | Lcondbranch (Ifloattest _, _) -> Some Bcc + | Lcondbranch (Ioddtest, _) + | Lcondbranch (Ieventest, _) -> Some TB + | Lcondbranch3 _ -> Some Bcc + | _ -> None + end + + let offset_pc_at_branch = 0 + + let epilogue_size () = + if !contains_calls then 3 else 2 + + let instr_size = function + | Lend -> 0 + | Lop (Imove | Ispill | Ireload) -> 1 + | Lop (Iconst_int n) -> + num_instructions_for_intconst n + | Lop (Iconst_float _) -> 2 + | Lop (Iconst_symbol _) -> 2 + | Lop (Icall_ind _) -> 1 + | Lop (Icall_imm _) -> 1 + | Lop (Itailcall_ind _) -> epilogue_size () + | Lop (Itailcall_imm { func; _ }) -> + if func = !function_name then 1 else epilogue_size () + | Lop (Iextcall { alloc = false; }) -> 1 + | Lop (Iextcall { alloc = true; }) -> 3 + | Lop (Istackoffset _) -> 2 + | Lop (Iload (size, addr)) | Lop (Istore (size, addr, _)) -> + let based = match addr with Iindexed _ -> 0 | Ibased _ -> 1 in + based + begin match size with Single -> 2 | _ -> 1 end + | Lop (Ialloc _) when !fastcode_flag -> 4 + | Lop (Ispecific (Ifar_alloc _)) when !fastcode_flag -> 5 + | Lop (Ialloc { words = num_words; _ }) + | Lop (Ispecific (Ifar_alloc { words = num_words; _ })) -> + begin match num_words with + | 16 | 24 | 32 -> 1 + | _ -> 1 + num_instructions_for_intconst (Nativeint.of_int num_words) + end + | Lop (Iintop (Icomp _)) -> 2 + | Lop (Iintop_imm (Icomp _, _)) -> 2 + | Lop (Iintop (Icheckbound _)) -> 2 + | Lop (Ispecific (Ifar_intop_checkbound _)) -> 3 + | Lop (Iintop_imm (Icheckbound _, _)) -> 2 + | Lop (Ispecific (Ifar_intop_imm_checkbound _)) -> 3 + | Lop (Ispecific (Ishiftcheckbound _)) -> 2 + | Lop (Ispecific (Ifar_shiftcheckbound _)) -> 3 + | Lop (Iintop Imod) -> 2 + | Lop (Iintop Imulh) -> 1 + | Lop (Iintop _) -> 1 + | Lop (Iintop_imm _) -> 1 + | Lop (Ifloatofint | Iintoffloat | Iabsf | Inegf | Ispecific Isqrtf) -> 1 + | Lop (Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf) -> 1 + | Lop (Ispecific (Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf)) -> 1 + | Lop (Ispecific (Ishiftarith _)) -> 1 + | Lop (Ispecific (Imuladd | Imulsub)) -> 1 + | Lop (Ispecific (Ibswap 16)) -> 2 + | Lop (Ispecific (Ibswap _)) -> 1 + | Lreloadretaddr -> 0 + | Lreturn -> epilogue_size () + | Llabel _ -> 0 + | Lbranch _ -> 1 + | Lcondbranch (tst, _) -> + begin match tst with + | Itruetest -> 1 + | Ifalsetest -> 1 + | Iinttest _ -> 2 + | Iinttest_imm _ -> 2 + | Ifloattest _ -> 2 + | Ioddtest -> 1 + | Ieventest -> 1 + end + | Lcondbranch3 (lbl0, lbl1, lbl2) -> + 1 + begin match lbl0 with None -> 0 | Some _ -> 1 end + + begin match lbl1 with None -> 0 | Some _ -> 1 end + + begin match lbl2 with None -> 0 | Some _ -> 1 end + | Lswitch jumptbl -> 3 + Array.length jumptbl + | Lsetuptrap _ -> 2 + | Lpushtrap -> 3 + | Lpoptrap -> 1 + | Lraise k -> + begin match k with + | Cmm.Raise_withtrace -> 1 + | Cmm.Raise_notrace -> 4 + end + + let relax_allocation ~num_words ~label_after_call_gc = + Lop (Ispecific (Ifar_alloc { words = num_words; label_after_call_gc; })) + + let relax_intop_checkbound ~label_after_error = + Lop (Ispecific (Ifar_intop_checkbound { label_after_error; })) + + let relax_intop_imm_checkbound ~bound ~label_after_error = + Lop (Ispecific (Ifar_intop_imm_checkbound { bound; label_after_error; })) + + let relax_specific_op = function + | Ishiftcheckbound { shift; label_after_error; } -> + Lop (Ispecific (Ifar_shiftcheckbound { shift; label_after_error; })) + | _ -> assert false +end) + +(* Output the assembly code for allocation. *) + +let assembly_code_for_allocation ?label_after_call_gc i ~n ~far = + let lbl_frame = + record_frame_label ?label:label_after_call_gc i.live false i.dbg + in + if !fastcode_flag then begin + let lbl_redo = new_label() in + let lbl_call_gc = new_label() in + `{emit_label lbl_redo}:`; + ` sub {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, #{emit_int n}\n`; + ` cmp {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_limit}\n`; + ` add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`; + if not far then begin + ` b.lo {emit_label lbl_call_gc}\n` + end else begin + let lbl = new_label () in + ` b.cs {emit_label lbl}\n`; + ` b {emit_label lbl_call_gc}\n`; + `{emit_label lbl}:\n` + end; + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame_lbl = lbl_frame } :: !call_gc_sites + end else begin + begin match n with + | 16 -> ` bl {emit_symbol "caml_alloc1"}\n` + | 24 -> ` bl {emit_symbol "caml_alloc2"}\n` + | 32 -> ` bl {emit_symbol "caml_alloc3"}\n` + | _ -> emit_intconst reg_x15 (Nativeint.of_int n); + ` bl {emit_symbol "caml_allocN"}\n` + end; + `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n` + end + +(* Output the assembly code for an instruction *) + +let emit_instr i = + emit_debug_info i.dbg; + match i.desc with + | Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + match (src, dst) with + | {loc = Reg _; typ = Float}, {loc = Reg _} -> + ` fmov {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _}, {loc = Reg _} -> + ` mov {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _}, {loc = Stack _} -> + ` str {emit_reg src}, {emit_stack dst}\n` + | {loc = Stack _}, {loc = Reg _} -> + ` ldr {emit_reg dst}, {emit_stack src}\n` + | _ -> + assert false + end + | Lop(Iconst_int n) -> + emit_intconst i.res.(0) n + | Lop(Iconst_float f) -> + if f = 0L then + ` fmov {emit_reg i.res.(0)}, xzr\n` + else if is_immediate_float f then + ` fmov {emit_reg i.res.(0)}, #{emit_printf "0x%Lx" f}\n` + else begin + let lbl = float_literal f in + ` adrp {emit_reg reg_tmp1}, {emit_label lbl}\n`; + ` ldr {emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n` + end + | Lop(Iconst_symbol s) -> + emit_load_symbol_addr i.res.(0) s + | Lop(Icall_ind { label_after; }) -> + ` blr {emit_reg i.arg.(0)}\n`; + `{record_frame i.live false i.dbg ~label:label_after}\n` + | Lop(Icall_imm { func; label_after; }) -> + ` bl {emit_symbol func}\n`; + `{record_frame i.live false i.dbg ~label:label_after}\n` + | Lop(Itailcall_ind { label_after = _; }) -> + output_epilogue (fun () -> ` br {emit_reg i.arg.(0)}\n`) + | Lop(Itailcall_imm { func; label_after = _; }) -> + if func = !function_name then + ` b {emit_label !tailrec_entry_point}\n` + else + output_epilogue (fun () -> ` b {emit_symbol func}\n`) + | Lop(Iextcall { func; alloc = false; label_after = _; }) -> + ` bl {emit_symbol func}\n` + | Lop(Iextcall { func; alloc = true; label_after; }) -> + emit_load_symbol_addr reg_x15 func; + ` bl {emit_symbol "caml_c_call"}\n`; + `{record_frame i.live false i.dbg ~label:label_after}\n` + | Lop(Istackoffset n) -> + assert (n mod 16 = 0); + emit_stack_adjustment (-n); + stack_offset := !stack_offset + n + | Lop(Iload(size, addr)) -> + let dst = i.res.(0) in + let base = + match addr with + | Iindexed _ -> i.arg.(0) + | Ibased(s, ofs) -> + ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; + reg_tmp1 in + begin match size with + | Byte_unsigned -> + ` ldrb {emit_wreg dst}, {emit_addressing addr base}\n` + | Byte_signed -> + ` ldrsb {emit_reg dst}, {emit_addressing addr base}\n` + | Sixteen_unsigned -> + ` ldrh {emit_wreg dst}, {emit_addressing addr base}\n` + | Sixteen_signed -> + ` ldrsh {emit_reg dst}, {emit_addressing addr base}\n` + | Thirtytwo_unsigned -> + ` ldr {emit_wreg dst}, {emit_addressing addr base}\n` + | Thirtytwo_signed -> + ` ldrsw {emit_reg dst}, {emit_addressing addr base}\n` + | Single -> + ` ldr s7, {emit_addressing addr base}\n`; + ` fcvt {emit_reg dst}, s7\n` + | Word_int | Word_val | Double | Double_u -> + ` ldr {emit_reg dst}, {emit_addressing addr base}\n` + end + | Lop(Istore(size, addr, _)) -> + let src = i.arg.(0) in + let base = + match addr with + | Iindexed _ -> i.arg.(1) + | Ibased(s, ofs) -> + ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; + reg_tmp1 in + begin match size with + | Byte_unsigned | Byte_signed -> + ` strb {emit_wreg src}, {emit_addressing addr base}\n` + | Sixteen_unsigned | Sixteen_signed -> + ` strh {emit_wreg src}, {emit_addressing addr base}\n` + | Thirtytwo_unsigned | Thirtytwo_signed -> + ` str {emit_wreg src}, {emit_addressing addr base}\n` + | Single -> + ` fcvt s7, {emit_reg src}\n`; + ` str s7, {emit_addressing addr base}\n`; + | Word_int | Word_val | Double | Double_u -> + ` str {emit_reg src}, {emit_addressing addr base}\n` + end + | Lop(Ialloc { words = n; label_after_call_gc; }) -> + assembly_code_for_allocation i ~n ~far:false ?label_after_call_gc + | Lop(Ispecific (Ifar_alloc { words = n; label_after_call_gc; })) -> + assembly_code_for_allocation i ~n ~far:true ?label_after_call_gc + | Lop(Iintop(Icomp cmp)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n` + | Lop(Iintop_imm(Icomp cmp, n)) -> + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + ` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n` + | Lop(Iintop (Icheckbound { label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` b.ls {emit_label lbl}\n` + | Lop(Ispecific Ifar_intop_checkbound { label_after_error; }) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in + let lbl2 = new_label () in + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` b.hi {emit_label lbl2}\n`; + ` b {emit_label lbl}\n`; + `{emit_label lbl2}:\n`; + | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + ` b.ls {emit_label lbl}\n` + | Lop(Ispecific( + Ifar_intop_imm_checkbound { bound; label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in + let lbl2 = new_label () in + ` cmp {emit_reg i.arg.(0)}, #{emit_int bound}\n`; + ` b.hi {emit_label lbl2}\n`; + ` b {emit_label lbl}\n`; + `{emit_label lbl2}:\n`; + | Lop(Ispecific(Ishiftcheckbound { shift; label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in + ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; + ` b.cs {emit_label lbl}\n` + | Lop(Ispecific(Ifar_shiftcheckbound { shift; label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in + let lbl2 = new_label () in + ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; + ` b.lo {emit_label lbl2}\n`; + ` b {emit_label lbl}\n`; + `{emit_label lbl2}:\n`; + | Lop(Iintop Imod) -> + ` sdiv {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` msub {emit_reg i.res.(0)}, {emit_reg reg_tmp1}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` + | Lop(Iintop Imulh) -> + ` smulh {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop op) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop_imm(op, n)) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n` + | Lop(Ifloatofint | Iintoffloat | Iabsf | Inegf | Ispecific Isqrtf as op) -> + let instr = (match op with + | Ifloatofint -> "scvtf" + | Iintoffloat -> "fcvtzs" + | Iabsf -> "fabs" + | Inegf -> "fneg" + | Ispecific Isqrtf -> "fsqrt" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf as op) -> + let instr = (match op with + | Iaddf -> "fadd" + | Isubf -> "fsub" + | Imulf -> "fmul" + | Idivf -> "fdiv" + | Ispecific Inegmulf -> "fnmul" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) -> + let instr = (match op with + | Imuladdf -> "fmadd" + | Inegmuladdf -> "fnmadd" + | Imulsubf -> "fmsub" + | Inegmulsubf -> "fnmsub" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}, {emit_reg i.arg.(0)}\n` + | Lop(Ispecific(Ishiftarith(op, shift))) -> + let instr = (match op with + Ishiftadd -> "add" + | Ishiftsub -> "sub") in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`; + if shift >= 0 + then `, lsl #{emit_int shift}\n` + else `, asr #{emit_int (-shift)}\n` + | Lop(Ispecific(Imuladd | Imulsub as op)) -> + let instr = (match op with + Imuladd -> "madd" + | Imulsub -> "msub" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n` + | Lop(Ispecific(Ibswap size)) -> + begin match size with + | 16 -> + ` rev16 {emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n`; + ` ubfm {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, #0, #15\n` + | 32 -> + ` rev {emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n` + | 64 -> + ` rev {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | _ -> + assert false + end + | Lreloadretaddr -> + () + | Lreturn -> + output_epilogue (fun () -> ` ret\n`) + | Llabel lbl -> + `{emit_label lbl}:\n` + | Lbranch lbl -> + ` b {emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + | Itruetest -> + ` cbnz {emit_reg i.arg.(0)}, {emit_label lbl}\n` + | Ifalsetest -> + ` cbz {emit_reg i.arg.(0)}, {emit_label lbl}\n` + | Iinttest cmp -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + let comp = name_for_comparison cmp in + ` b.{emit_string comp} {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + let comp = name_for_comparison cmp in + ` b.{emit_string comp} {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + let comp = (match (cmp, neg) with + | (Ceq, false) | (Cne, true) -> "eq" + | (Cne, false) | (Ceq, true) -> "ne" + | (Clt, false) -> "cc" + | (Clt, true) -> "cs" + | (Cle, false) -> "ls" + | (Cle, true) -> "hi" + | (Cgt, false) -> "gt" + | (Cgt, true) -> "le" + | (Cge, false) -> "ge" + | (Cge, true) -> "lt") in + ` fcmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` b.{emit_string comp} {emit_label lbl}\n` + | Ioddtest -> + ` tbnz {emit_reg i.arg.(0)}, #0, {emit_label lbl}\n` + | Ieventest -> + ` tbz {emit_reg i.arg.(0)}, #0, {emit_label lbl}\n` + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cmp {emit_reg i.arg.(0)}, #1\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` b.lt {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` b.eq {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` b.gt {emit_label lbl}\n` + end + | Lswitch jumptbl -> + let lbltbl = new_label() in + ` adr {emit_reg reg_tmp1}, {emit_label lbltbl}\n`; + ` add {emit_reg reg_tmp1}, {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2\n`; + ` br {emit_reg reg_tmp1}\n`; + `{emit_label lbltbl}:`; + for j = 0 to Array.length jumptbl - 1 do + ` b {emit_label jumptbl.(j)}\n` + done +(* Alternative: + let lbltbl = new_label() in + ` adr {emit_reg reg_tmp1}, {emit_label lbltbl}\n`; + ` ldr {emit_wreg reg_tmp2}, [{emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2]\n`; + ` add {emit_reg reg_tmp1}, {emit_wreg reg_tmp2}, sxtb\n`; + ` br {emit_reg reg_tmp1}\n`; + `{emit_label lbltbl}:\n`; + for j = 0 to Array.length jumptbl - 1 do + ` .word {emit_label jumptbl.(j)} - {emit_label lbltbl}\n` + done +*) + | Lsetuptrap lbl -> + let lblnext = new_label() in + ` adr {emit_reg reg_tmp1}, {emit_label lblnext}\n`; + ` b {emit_label lbl}\n`; + `{emit_label lblnext}:\n` + | Lpushtrap -> + stack_offset := !stack_offset + 16; + ` str {emit_reg reg_trap_ptr}, [sp, -16]!\n`; + ` str {emit_reg reg_tmp1}, [sp, #8]\n`; + cfi_adjust_cfa_offset 16; + ` mov {emit_reg reg_trap_ptr}, sp\n` + | Lpoptrap -> + ` ldr {emit_reg reg_trap_ptr}, [sp], 16\n`; + cfi_adjust_cfa_offset (-16); + stack_offset := !stack_offset - 16 + | Lraise k -> + begin match k with + | Cmm.Raise_withtrace -> + ` bl {emit_symbol "caml_raise_exn"}\n`; + `{record_frame Reg.Set.empty true i.dbg}\n` + | Cmm.Raise_notrace -> + ` mov sp, {emit_reg reg_trap_ptr}\n`; + ` ldr {emit_reg reg_tmp1}, [sp, #8]\n`; + ` ldr {emit_reg reg_trap_ptr}, [sp], 16\n`; + ` br {emit_reg reg_tmp1}\n` + end + +(* Emission of an instruction sequence *) + +let rec emit_all i = + if i.desc = Lend then () else (emit_instr i; emit_all i.next) + +(* Emission of the profiling prelude *) + +let emit_profile() = () (* TODO *) +(* + match Config.system with + "linux_eabi" | "linux_eabihf" | "netbsd" -> + ` push \{lr}\n`; + ` {emit_call "__gnu_mcount_nc"}\n` + | _ -> () +*) + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + tailrec_entry_point := new_label(); + float_literals := []; + stack_offset := 0; + call_gc_sites := []; + bound_error_sites := []; + ` .text\n`; + ` .align 3\n`; + ` .globl {emit_symbol fundecl.fun_name}\n`; + ` .type {emit_symbol fundecl.fun_name}, %function\n`; + `{emit_symbol fundecl.fun_name}:\n`; + emit_debug_info fundecl.fun_dbg; + cfi_startproc(); + if !Clflags.gprofile then emit_profile(); + let n = frame_size() in + if n > 0 then + emit_stack_adjustment (-n); + if !contains_calls then begin + cfi_offset ~reg:30 (* return address *) ~offset:(-8); + ` str x30, [sp, #{emit_int (n-8)}]\n` + end; + `{emit_label !tailrec_entry_point}:\n`; + let num_call_gc, num_check_bound = + num_call_gc_and_check_bound_points fundecl.fun_body + in + let max_out_of_line_code_offset = + max_out_of_line_code_offset ~num_call_gc + ~num_check_bound + in + BR.relax fundecl.fun_body ~max_out_of_line_code_offset; + emit_all fundecl.fun_body; + List.iter emit_call_gc !call_gc_sites; + List.iter emit_call_bound_error !bound_error_sites; + assert (List.length !call_gc_sites = num_call_gc); + assert (List.length !bound_error_sites = num_check_bound); + cfi_endproc(); + ` .type {emit_symbol fundecl.fun_name}, %function\n`; + ` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`; + emit_literals() + +(* Emission of data *) + +let emit_item = function + | Cglobal_symbol s -> ` .globl {emit_symbol s}\n`; + | Cdefine_symbol s -> `{emit_symbol s}:\n` + | Cint8 n -> ` .byte {emit_int n}\n` + | Cint16 n -> ` .short {emit_int n}\n` + | Cint32 n -> ` .long {emit_nativeint n}\n` + | Cint n -> ` .quad {emit_nativeint n}\n` + | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f) + | Cdouble f -> emit_float64_directive ".quad" (Int64.bits_of_float f) + | Csymbol_address s -> ` .quad {emit_symbol s}\n` + | Cstring s -> emit_string_directive " .ascii " s + | Cskip n -> if n > 0 then ` .space {emit_int n}\n` + | Calign n -> ` .align {emit_int(Misc.log2 n)}\n` + +let data l = + ` .data\n`; + ` .align 3\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + reset_debug_info(); + ` .file \"\"\n`; (* PR#7037 *) + let lbl_begin = Compilenv.make_symbol (Some "data_begin") in + ` .data\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.make_symbol (Some "code_begin") in + ` .text\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n` + +let end_assembly () = + let lbl_end = Compilenv.make_symbol (Some "code_end") in + ` .text\n`; + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + let lbl_end = Compilenv.make_symbol (Some "data_end") in + ` .data\n`; + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .long 0\n`; + let lbl = Compilenv.make_symbol (Some "frametable") in + ` .globl {emit_symbol lbl}\n`; + `{emit_symbol lbl}:\n`; + emit_frames + { efa_code_label = (fun lbl -> + ` .type {emit_label lbl}, %function\n`; + ` .quad {emit_label lbl}\n`); + efa_data_label = (fun lbl -> + ` .type {emit_label lbl}, %object\n`; + ` .quad {emit_label lbl}\n`); + efa_16 = (fun n -> ` .short {emit_int n}\n`); + efa_32 = (fun n -> ` .long {emit_int32 n}\n`); + efa_word = (fun n -> ` .quad {emit_int n}\n`); + efa_align = (fun n -> ` .align {emit_int(Misc.log2 n)}\n`); + efa_label_rel = (fun lbl ofs -> + ` .long {emit_label lbl} - . + {emit_int32 ofs}\n`); + efa_def_label = (fun lbl -> `{emit_label lbl}:\n`); + efa_string = (fun s -> emit_string_directive " .asciz " s) }; + ` .type {emit_symbol lbl}, %object\n`; + ` .size {emit_symbol lbl}, .-{emit_symbol lbl}\n`; + begin match Config.system with + | "linux" -> + (* Mark stack as non-executable *) + ` .section .note.GNU-stack,\"\",%progbits\n` + | _ -> () + end diff -Nru ocaml-4.01.0/asmcomp/arm64/NOTES.md ocaml-4.05.0/asmcomp/arm64/NOTES.md --- ocaml-4.01.0/asmcomp/arm64/NOTES.md 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm64/NOTES.md 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,12 @@ +# Supported platforms + +ARMv8 in 64-bit mode (AArch64). + +Debian architecture name: `arm64`. + +# Reference documents + +* Instruction set architecture: + _ARM Architecture Reference Manual, ARMv8_, restricted to the AArch64 subset. +* Application binary interface: + _Procedure Call Standard for the ARM 64-bit Architecture (AArch64)_ diff -Nru ocaml-4.01.0/asmcomp/arm64/proc.ml ocaml-4.05.0/asmcomp/arm64/proc.ml --- ocaml-4.01.0/asmcomp/arm64/proc.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm64/proc.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,237 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2012 Benedikt Meurer. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Description of the ARM processor in 64-bit mode *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Instruction selection *) + +let word_addressed = false + +(* Registers available for register allocation *) + +(* Integer register map: + x0 - x15 general purpose (caller-save) + x16, x17 temporaries (used by call veeners) + x18 platform register (reserved) + x19 - x25 general purpose (callee-save) + x26 trap pointer + x27 alloc pointer + x28 alloc limit + x29 frame pointer + x30 return address + sp / xzr stack pointer / zero register + Floating-point register map: + d0 - d7 general purpose (caller-save) + d8 - d15 general purpose (callee-save) + d16 - d31 generat purpose (caller-save) +*) + +let int_reg_name = + [| "x0"; "x1"; "x2"; "x3"; "x4"; "x5"; "x6"; "x7"; + "x8"; "x9"; "x10"; "x11"; "x12"; "x13"; "x14"; "x15"; + "x19"; "x20"; "x21"; "x22"; "x23"; "x24"; "x25"; + "x26"; "x27"; "x28"; "x16"; "x17" |] + +let float_reg_name = + [| "d0"; "d1"; "d2"; "d3"; "d4"; "d5"; "d6"; "d7"; + "d8"; "d9"; "d10"; "d11"; "d12"; "d13"; "d14"; "d15"; + "d16"; "d17"; "d18"; "d19"; "d20"; "d21"; "d22"; "d23"; + "d24"; "d25"; "d26"; "d27"; "d28"; "d29"; "d30"; "d31" |] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + | Val | Int | Addr -> 0 + | Float -> 1 + +let num_available_registers = + [| 23; 32 |] (* first 23 int regs allocatable; all float regs allocatable *) + +let first_available_register = + [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +let rotate_registers = true + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.make 28 Reg.dummy in + for i = 0 to 27 do + v.(i) <- Reg.at_location Int (Reg i) + done; + v + +let hard_float_reg = + let v = Array.make 32 Reg.dummy in + for i = 0 to 31 do + v.(i) <- Reg.at_location Float (Reg(100 + i)) + done; + v + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let reg_x15 = phys_reg 15 +let reg_d7 = phys_reg 107 + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *) + +(* Calling conventions *) + +let calling_conventions + first_int last_int first_float last_float make_stack arg = + let loc = Array.make (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + | Val | Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" + +(* OCaml calling convention: + first integer args in r0...r15 + first float args in d0...d15 + remaining args on stack. + Return values in r0...r15 or d0...d15. *) + +let max_arguments_for_tailcalls = 16 + +let loc_arguments arg = + calling_conventions 0 15 100 115 outgoing arg +let loc_parameters arg = + let (loc, _) = calling_conventions 0 15 100 115 incoming arg in loc +let loc_results res = + let (loc, _) = calling_conventions 0 15 100 115 not_supported res in loc + +(* C calling convention: + first integer args in r0...r7 + first float args in d0...d7 + remaining args on stack. + Return values in r0...r1 or d0. *) + +let loc_external_arguments arg = + let arg = + Array.map (fun regs -> assert (Array.length regs = 1); regs.(0)) arg + in + let loc, alignment = calling_conventions 0 7 100 107 outgoing arg in + Array.map (fun reg -> [|reg|]) loc, alignment +let loc_external_results res = + let (loc, _) = calling_conventions 0 1 100 100 not_supported res in loc + +let loc_exn_bucket = phys_reg 0 + +(* Volatile registers: none *) + +let regs_are_volatile _rs = false + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = + (* x19-x28, d8-d15 preserved *) + Array.of_list (List.map phys_reg + [0;1;2;3;4;5;6;7;8;9;10;11;12;13;14;15; + 100;101;102;103;104;105;106;107; + 116;117;118;119;120;121;122;123; + 124;125;126;127;128;129;130;131]) + +let destroyed_at_oper = function + | Iop(Icall_ind _ | Icall_imm _) | Iop(Iextcall { alloc = true; }) -> + all_phys_regs + | Iop(Iextcall { alloc = false; }) -> + destroyed_at_c_call + | Iop(Ialloc _) -> + [| reg_x15 |] + | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) -> + [| reg_d7 |] (* d7 / s7 destroyed *) + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + | Iextcall _ -> 8 + | Ialloc _ -> 25 + | _ -> 26 + +let max_register_pressure = function + | Iextcall _ -> [| 10; 8 |] + | Ialloc _ -> [| 25; 32 |] + | Iintoffloat | Ifloatofint + | Iload(Single, _) | Istore(Single, _, _) -> [| 26; 31 |] + | _ -> [| 26; 32 |] + +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) + | Ispecific(Ishiftcheckbound _) -> false + | _ -> true + +(* Layout of the stack *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) + + +let init () = () diff -Nru ocaml-4.01.0/asmcomp/arm64/reload.ml ocaml-4.05.0/asmcomp/arm64/reload.ml --- ocaml-4.01.0/asmcomp/arm64/reload.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm64/reload.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Reloading for the ARM 64 bits *) + +let fundecl f = + (new Reloadgen.reload_generic)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/arm64/scheduling.ml ocaml-4.05.0/asmcomp/arm64/scheduling.ml --- ocaml-4.01.0/asmcomp/arm64/scheduling.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm64/scheduling.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +let _ = let module M = Schedgen in () (* to create a dependency *) + +(* Scheduling is turned off because the processor schedules dynamically + much better than what we could do. *) + +let fundecl f = f diff -Nru ocaml-4.01.0/asmcomp/arm64/selection.ml ocaml-4.05.0/asmcomp/arm64/selection.ml --- ocaml-4.01.0/asmcomp/arm64/selection.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/arm64/selection.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,254 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2012 Benedikt Meurer. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Instruction selection for the ARM processor *) + +open Arch +open Cmm +open Mach + +let is_offset chunk n = + (n >= -256 && n <= 255) (* 9 bits signed unscaled *) +|| (n >= 0 && + match chunk with (* 12 bits unsigned, scaled by chunk size *) + | Byte_unsigned | Byte_signed -> + n < 0x1000 + | Sixteen_unsigned | Sixteen_signed -> + n land 1 = 0 && n lsr 1 < 0x1000 + | Thirtytwo_unsigned | Thirtytwo_signed | Single -> + n land 3 = 0 && n lsr 2 < 0x1000 + | Word_int | Word_val | Double | Double_u -> + n land 7 = 0 && n lsr 3 < 0x1000) + +(* An automaton to recognize ( 0+1+0* | 1+0+1* ) + + 0 1 0 + / \ / \ / \ + \ / \ / \ / + -0--> [1] --1--> [2] --0--> [3] + / + [0] + \ + -1--> [4] --0--> [5] --1--> [6] + / \ / \ / \ + \ / \ / \ / + 1 0 1 + +The accepting states are 2, 3, 5 and 6. *) + +let auto_table = [| (* accepting?, next on 0, next on 1 *) + (* state 0 *) (false, 1, 4); + (* state 1 *) (false, 1, 2); + (* state 2 *) (true, 3, 2); + (* state 3 *) (true, 3, 7); + (* state 4 *) (false, 5, 4); + (* state 5 *) (true, 5, 6); + (* state 6 *) (true, 7, 6); + (* state 7 *) (false, 7, 7) (* error state *) +|] + +let rec run_automata nbits state input = + let (acc, next0, next1) = auto_table.(state) in + if nbits <= 0 + then acc + else run_automata (nbits - 1) + (if input land 1 = 0 then next0 else next1) + (input asr 1) + +(* We are very conservative wrt what ARM64 supports: we don't support + repetitions of a 000111000 or 1110000111 pattern, just a single + pattern of this kind. *) + +let is_logical_immediate n = + n <> 0 && n <> -1 && run_automata 64 0 n + +(* If you update [inline_ops], you may need to update [is_simple_expr] and/or + [effects_of], below. *) +let inline_ops = + [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap"; + "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ] + +let use_direct_addressing symb = + (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit symb + +(* Instruction selection *) + +class selector = object(self) + +inherit Selectgen.selector_generic as super + +method is_immediate n = + let mn = -n in + n land 0xFFF = n || n land 0xFFF_000 = n + || mn land 0xFFF = mn || mn land 0xFFF_000 = mn + +method! is_simple_expr = function + (* inlined floating-point ops are simple if their arguments are *) + | Cop(Cextcall (fn, _, _, _), args, _) when List.mem fn inline_ops -> + List.for_all self#is_simple_expr args + | e -> super#is_simple_expr e + +method! effects_of e = + match e with + | Cop(Cextcall (fn, _, _, _), args, _) when List.mem fn inline_ops -> + Selectgen.Effect_and_coeffect.join_list_map args self#effects_of + | e -> super#effects_of e + +method select_addressing chunk = function + | Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n], _) + when use_direct_addressing s -> + (Ibased(s, n), Ctuple []) + | Cop((Caddv | Cadda), [arg; Cconst_int n], _) + when is_offset chunk n -> + (Iindexed n, arg) + | Cop((Caddv | Cadda as op), [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg) + when is_offset chunk n -> + (Iindexed n, Cop(op, [arg1; arg2], dbg)) + | Cconst_symbol s + when use_direct_addressing s -> + (Ibased(s, 0), Ctuple []) + | arg -> + (Iindexed 0, arg) + +method! select_operation op args dbg = + match op with + (* Integer addition *) + | Caddi | Caddv | Cadda -> + begin match args with + (* Add immediate *) + | [arg; Cconst_int n] when self#is_immediate n -> + ((if n >= 0 then Iintop_imm(Iadd, n) else Iintop_imm(Isub, -n)), + [arg]) + | [Cconst_int n; arg] when self#is_immediate n -> + ((if n >= 0 then Iintop_imm(Iadd, n) else Iintop_imm(Isub, -n)), + [arg]) + (* Shift-add *) + | [arg1; Cop(Clsl, [arg2; Cconst_int n], _)] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftadd, n)), [arg1; arg2]) + | [arg1; Cop(Casr, [arg2; Cconst_int n], _)] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftadd, -n)), [arg1; arg2]) + | [Cop(Clsl, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftadd, n)), [arg2; arg1]) + | [Cop(Casr, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftadd, -n)), [arg2; arg1]) + (* Multiply-add *) + | [arg1; Cop(Cmuli, args2, dbg)] | [Cop(Cmuli, args2, dbg); arg1] -> + begin match self#select_operation Cmuli args2 dbg with + | (Iintop_imm(Ilsl, l), [arg3]) -> + (Ispecific(Ishiftarith(Ishiftadd, l)), [arg1; arg3]) + | (Iintop Imul, [arg3; arg4]) -> + (Ispecific Imuladd, [arg3; arg4; arg1]) + | _ -> + super#select_operation op args dbg + end + | _ -> + super#select_operation op args dbg + end + (* Integer subtraction *) + | Csubi -> + begin match args with + (* Sub immediate *) + | [arg; Cconst_int n] when self#is_immediate n -> + ((if n >= 0 then Iintop_imm(Isub, n) else Iintop_imm(Iadd, -n)), + [arg]) + (* Shift-sub *) + | [arg1; Cop(Clsl, [arg2; Cconst_int n], _)] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftsub, n)), [arg1; arg2]) + | [arg1; Cop(Casr, [arg2; Cconst_int n], _)] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftsub, -n)), [arg1; arg2]) + (* Multiply-sub *) + | [arg1; Cop(Cmuli, args2, dbg)] -> + begin match self#select_operation Cmuli args2 dbg with + | (Iintop_imm(Ilsl, l), [arg3]) -> + (Ispecific(Ishiftarith(Ishiftsub, l)), [arg1; arg3]) + | (Iintop Imul, [arg3; arg4]) -> + (Ispecific Imulsub, [arg3; arg4; arg1]) + | _ -> + super#select_operation op args dbg + end + | _ -> + super#select_operation op args dbg + end + (* Checkbounds *) + | Ccheckbound -> + begin match args with + | [Cop(Clsr, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 -> + (Ispecific(Ishiftcheckbound { shift = n; label_after_error = None; }), + [arg1; arg2]) + | _ -> + super#select_operation op args dbg + end + (* Integer multiplication *) + (* ARM does not support immediate operands for multiplication *) + | Cmuli -> + (Iintop Imul, args) + | Cmulhi -> + (Iintop Imulh, args) + (* Bitwise logical operations have a different range of immediate + operands than the other instructions *) + | Cand -> self#select_logical Iand args + | Cor -> self#select_logical Ior args + | Cxor -> self#select_logical Ixor args + (* Recognize floating-point negate and multiply *) + | Cnegf -> + begin match args with + | [Cop(Cmulf, args, _)] -> (Ispecific Inegmulf, args) + | _ -> super#select_operation op args dbg + end + (* Recognize floating-point multiply and add/sub *) + | Caddf -> + begin match args with + | [arg; Cop(Cmulf, args, _)] | [Cop(Cmulf, args, _); arg] -> + (Ispecific Imuladdf, arg :: args) + | _ -> + super#select_operation op args dbg + end + | Csubf -> + begin match args with + | [arg; Cop(Cmulf, args, _)] -> + (Ispecific Imulsubf, arg :: args) + | [Cop(Cmulf, args, _); arg] -> + (Ispecific Inegmulsubf, arg :: args) + | _ -> + super#select_operation op args dbg + end + (* Recognize floating-point square root *) + | Cextcall("sqrt", _, _, _) -> + (Ispecific Isqrtf, args) + (* Recognize bswap instructions *) + | Cextcall("caml_bswap16_direct", _, _, _) -> + (Ispecific(Ibswap 16), args) + | Cextcall("caml_int32_direct_bswap", _, _, _) -> + (Ispecific(Ibswap 32), args) + | Cextcall(("caml_int64_direct_bswap"|"caml_nativeint_direct_bswap"), + _, _, _) -> + (Ispecific (Ibswap 64), args) + (* Other operations are regular *) + | _ -> + super#select_operation op args dbg + +method select_logical op = function + | [arg; Cconst_int n] when is_logical_immediate n -> + (Iintop_imm(op, n), [arg]) + | [Cconst_int n; arg] when is_logical_immediate n -> + (Iintop_imm(op, n), [arg]) + | args -> + (Iintop op, args) + +end + +let fundecl f = (new selector)#emit_fundecl f diff -Nru ocaml-4.01.0/asmcomp/asmgen.ml ocaml-4.05.0/asmcomp/asmgen.ml --- ocaml-4.01.0/asmcomp/asmgen.ml 2013-06-03 18:03:59.000000000 +0000 +++ ocaml-4.05.0/asmcomp/asmgen.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,17 +1,22 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* From lambda to assembly code *) +[@@@ocaml.warning "+a-4-9-40-41-42"] + open Format open Config open Clflags @@ -35,8 +40,40 @@ if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase; phrase -let clambda_dump_if ppf ulambda = - if !dump_clambda then Printclambda.clambda ppf ulambda; ulambda +let flambda_raw_clambda_dump_if ppf + ({ Flambda_to_clambda. expr = ulambda; preallocated_blocks = _; + structured_constants; exported = _; } as input) = + if !dump_rawclambda then + begin + Format.fprintf ppf "@.clambda (before Un_anf):@."; + Printclambda.clambda ppf ulambda; + Symbol.Map.iter (fun sym cst -> + Format.fprintf ppf "%a:@ %a@." + Symbol.print sym + Printclambda.structured_constant cst) + structured_constants + end; + if !dump_cmm then Format.fprintf ppf "@.cmm:@."; + input + +type clambda_and_constants = + Clambda.ulambda * + Clambda.preallocated_block list * + Clambda.preallocated_constant list + +let raw_clambda_dump_if ppf + ((ulambda, _, structured_constants):clambda_and_constants) = + if !dump_rawclambda || !dump_clambda then + begin + Format.fprintf ppf "@.clambda:@."; + Printclambda.clambda ppf ulambda; + List.iter (fun {Clambda.symbol; definition} -> + Format.fprintf ppf "%s:@ %a@." + symbol + Printclambda.structured_constant definition) + structured_constants + end; + if !dump_cmm then Format.fprintf ppf "@.cmm:@." let rec regalloc ppf round fd = if round > 50 then @@ -59,25 +96,29 @@ let compile_fundecl (ppf : formatter) fd_cmm = Proc.init (); Reg.reset(); + let build = Compilenv.current_build () in fd_cmm - ++ Selection.fundecl + ++ Timings.(accumulate_time (Selection build)) Selection.fundecl ++ pass_dump_if ppf dump_selection "After instruction selection" - ++ Comballoc.fundecl + ++ Timings.(accumulate_time (Comballoc build)) Comballoc.fundecl ++ pass_dump_if ppf dump_combine "After allocation combining" - ++ liveness ppf + ++ Timings.(accumulate_time (CSE build)) CSE.fundecl + ++ pass_dump_if ppf dump_cse "After CSE" + ++ Timings.(accumulate_time (Liveness build)) (liveness ppf) + ++ Timings.(accumulate_time (Deadcode build)) Deadcode.fundecl ++ pass_dump_if ppf dump_live "Liveness analysis" - ++ Spill.fundecl - ++ liveness ppf + ++ Timings.(accumulate_time (Spill build)) Spill.fundecl + ++ Timings.(accumulate_time (Liveness build)) (liveness ppf) ++ pass_dump_if ppf dump_spill "After spilling" - ++ Split.fundecl + ++ Timings.(accumulate_time (Split build)) Split.fundecl ++ pass_dump_if ppf dump_split "After live range splitting" - ++ liveness ppf - ++ regalloc ppf 1 - ++ Linearize.fundecl + ++ Timings.(accumulate_time (Liveness build)) (liveness ppf) + ++ Timings.(accumulate_time (Regalloc build)) (regalloc ppf 1) + ++ Timings.(accumulate_time (Linearize build)) Linearize.fundecl ++ pass_dump_linear_if ppf dump_linear "Linearized code" - ++ Scheduling.fundecl + ++ Timings.(accumulate_time (Scheduling build)) Scheduling.fundecl ++ pass_dump_linear_if ppf dump_scheduling "After instruction scheduling" - ++ Emit.fundecl + ++ Timings.(accumulate_time (Emit build)) Emit.fundecl let compile_phrase ppf p = if !dump_cmm then fprintf ppf "%a@." Printcmm.phrase p; @@ -96,43 +137,123 @@ | _ -> ()) (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()]) -let compile_implementation ?toplevel prefixname ppf (size, lam) = +let compile_unit ~source_provenance _output_prefix asm_filename keep_asm + obj_filename gen = + let create_asm = keep_asm || not !Emitaux.binary_backend_available in + Emitaux.create_asm_file := create_asm; + try + if create_asm then Emitaux.output_channel := open_out asm_filename; + begin try + gen (); + if create_asm then close_out !Emitaux.output_channel; + with exn when create_asm -> + close_out !Emitaux.output_channel; + if not keep_asm then remove_file asm_filename; + raise exn + end; + let assemble_result = + Timings.(time (Assemble source_provenance)) + (Proc.assemble_file asm_filename) obj_filename + in + if assemble_result <> 0 + then raise(Error(Assembler_error asm_filename)); + if create_asm && not keep_asm then remove_file asm_filename + with exn -> + remove_file obj_filename; + raise exn + +let set_export_info (ulambda, prealloc, structured_constants, export) = + Compilenv.set_export_info export; + (ulambda, prealloc, structured_constants) + +let end_gen_implementation ?toplevel ~source_provenance ppf + (clambda:clambda_and_constants) = + Emit.begin_assembly (); + clambda + ++ Timings.(time (Cmm source_provenance)) Cmmgen.compunit + ++ Timings.(time (Compile_phrases source_provenance)) + (List.iter (compile_phrase ppf)) + ++ (fun () -> ()); + (match toplevel with None -> () | Some f -> compile_genfuns ppf f); + + (* We add explicit references to external primitive symbols. This + is to ensure that the object files that define these symbols, + when part of a C library, won't be discarded by the linker. + This is important if a module that uses such a symbol is later + dynlinked. *) + + compile_phrase ppf + (Cmmgen.reference_symbols + (List.filter (fun s -> s <> "" && s.[0] <> '%') + (List.map Primitive.native_name !Translmod.primitive_declarations)) + ); + Emit.end_assembly () + +let flambda_gen_implementation ?toplevel ~source_provenance ~backend ppf + (program:Flambda.program) = + let export = Build_export_info.build_export_info ~backend program in + let (clambda, preallocated, constants) = + Timings.time (Flambda_pass ("backend", source_provenance)) (fun () -> + (program, export) + ++ Flambda_to_clambda.convert + ++ flambda_raw_clambda_dump_if ppf + ++ (fun { Flambda_to_clambda. expr; preallocated_blocks; + structured_constants; exported; } -> + (* "init_code" following the name used in + [Cmmgen.compunit_and_constants]. *) + Un_anf.apply expr ~what:"init_code", preallocated_blocks, + structured_constants, exported) + ++ set_export_info) () + in + let constants = + List.map (fun (symbol, definition) -> + { Clambda.symbol = Linkage_name.to_string (Symbol.label symbol); + exported = true; + definition }) + (Symbol.Map.bindings constants) + in + end_gen_implementation ?toplevel ~source_provenance ppf + (clambda, preallocated, constants) + +let lambda_gen_implementation ?toplevel ~source_provenance ppf + (lambda:Lambda.program) = + let clambda = Closure.intro lambda.main_module_block_size lambda.code in + let preallocated_block = + Clambda.{ + symbol = Compilenv.make_symbol None; + exported = true; + tag = 0; + size = lambda.main_module_block_size; + } + in + let clambda_and_constants = + clambda, [preallocated_block], [] + in + raw_clambda_dump_if ppf clambda_and_constants; + end_gen_implementation ?toplevel ~source_provenance ppf clambda_and_constants + +let compile_implementation_gen ?toplevel ~source_provenance prefixname + ~required_globals ppf gen_implementation program = let asmfile = - if !keep_asm_file + if !keep_asm_file || !Emitaux.binary_backend_available then prefixname ^ ext_asm - else Filename.temp_file "camlasm" ext_asm in - let oc = open_out asmfile in - begin try - Emitaux.output_channel := oc; - Emit.begin_assembly(); - Closure.intro size lam - ++ clambda_dump_if ppf - ++ Cmmgen.compunit size - ++ List.iter (compile_phrase ppf) ++ (fun () -> ()); - (match toplevel with None -> () | Some f -> compile_genfuns ppf f); - - (* We add explicit references to external primitive symbols. This - is to ensure that the object files that define these symbols, - when part of a C library, won't be discarded by the linker. - This is important if a module that uses such a symbol is later - dynlinked. *) - - compile_phrase ppf - (Cmmgen.reference_symbols - (List.filter (fun s -> s <> "" && s.[0] <> '%') - (List.map Primitive.native_name !Translmod.primitive_declarations)) - ); - - Emit.end_assembly(); - close_out oc - with x -> - close_out oc; - if !keep_asm_file then () else remove_file asmfile; - raise x - end; - if Proc.assemble_file asmfile (prefixname ^ ext_obj) <> 0 - then raise(Error(Assembler_error asmfile)); - if !keep_asm_file then () else remove_file asmfile + else Filename.temp_file "camlasm" ext_asm + in + compile_unit ~source_provenance prefixname asmfile !keep_asm_file + (prefixname ^ ext_obj) (fun () -> + Ident.Set.iter Compilenv.require_global required_globals; + gen_implementation ?toplevel ~source_provenance ppf program) + +let compile_implementation_clambda ?toplevel ~source_provenance prefixname + ppf (program:Lambda.program) = + compile_implementation_gen ?toplevel ~source_provenance prefixname + ~required_globals:program.Lambda.required_globals + ppf lambda_gen_implementation program + +let compile_implementation_flambda ?toplevel ~source_provenance prefixname + ~required_globals ~backend ppf (program:Flambda.program) = + compile_implementation_gen ?toplevel ~source_provenance prefixname + ~required_globals ppf (flambda_gen_implementation ~backend) program (* Error report *) @@ -140,3 +261,10 @@ | Assembler_error file -> fprintf ppf "Assembler error, input left in file %a" Location.print_filename file + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff -Nru ocaml-4.01.0/asmcomp/asmgen.mli ocaml-4.05.0/asmcomp/asmgen.mli --- ocaml-4.01.0/asmcomp/asmgen.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/asmgen.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,23 +1,44 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* From lambda to assembly code *) -val compile_implementation : +val compile_implementation_flambda : ?toplevel:(string -> bool) -> - string -> Format.formatter -> int * Lambda.lambda -> unit + source_provenance:Timings.source_provenance -> + string -> + required_globals:Ident.Set.t -> + backend:(module Backend_intf.S) -> + Format.formatter -> Flambda.program -> unit + +val compile_implementation_clambda : + ?toplevel:(string -> bool) -> + source_provenance:Timings.source_provenance -> + string -> + Format.formatter -> Lambda.program -> unit + val compile_phrase : Format.formatter -> Cmm.phrase -> unit type error = Assembler_error of string exception Error of error val report_error: Format.formatter -> error -> unit + + +val compile_unit: + source_provenance:Timings.source_provenance -> + string(*prefixname*) -> + string(*asm file*) -> bool(*keep asm*) -> + string(*obj file*) -> (unit -> unit) -> unit diff -Nru ocaml-4.01.0/asmcomp/asmlibrarian.ml ocaml-4.05.0/asmcomp/asmlibrarian.ml --- ocaml-4.01.0/asmcomp/asmlibrarian.ml 2013-06-05 16:34:40.000000000 +0000 +++ ocaml-4.05.0/asmcomp/asmlibrarian.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Build libraries of .cmx files *) @@ -22,6 +25,12 @@ exception Error of error +let default_ui_export_info = + if Config.flambda then + Cmx_format.Flambda Export_info.empty + else + Cmx_format.Clambda Clambda.Value_unknown + let read_info name = let filename = try @@ -29,16 +38,16 @@ with Not_found -> raise(Error(File_not_found name)) in let (info, crc) = Compilenv.read_unit_info filename in - info.ui_force_link <- !Clflags.link_everything; + info.ui_force_link <- info.ui_force_link || !Clflags.link_everything; (* There is no need to keep the approximation in the .cmxa file, since the compiler will go looking directly for .cmx files. The linker, which is the only one that reads .cmxa files, does not need the approximation. *) - info.ui_approx <- Clambda.Value_unknown; + info.ui_export_info <- default_ui_export_info; (Filename.chop_suffix filename ".cmx" ^ ext_obj, (info, crc)) let create_archive file_list lib_name = - let archive_name = chop_extension_if_any lib_name ^ ext_lib in + let archive_name = Filename.remove_extension lib_name ^ ext_lib in let outchan = open_out_bin lib_name in try output_string outchan cmxa_magic_number; @@ -69,3 +78,10 @@ fprintf ppf "Cannot find file %s" name | Archiver_error name -> fprintf ppf "Error while creating the library %s" name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff -Nru ocaml-4.01.0/asmcomp/asmlibrarian.mli ocaml-4.05.0/asmcomp/asmlibrarian.mli --- ocaml-4.01.0/asmcomp/asmlibrarian.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/asmlibrarian.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Build libraries of .cmx files *) diff -Nru ocaml-4.01.0/asmcomp/asmlink.ml ocaml-4.05.0/asmcomp/asmlink.ml --- ocaml-4.01.0/asmcomp/asmlink.ml 2013-07-23 14:48:47.000000000 +0000 +++ ocaml-4.05.0/asmcomp/asmlink.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Link a set of .cmx/.o files and produce an executable *) @@ -33,31 +36,37 @@ (* Consistency check between interfaces and implementations *) let crc_interfaces = Consistbl.create () +let interfaces = ref ([] : string list) let crc_implementations = Consistbl.create () -let extra_implementations = ref ([] : string list) +let implementations = ref ([] : string list) let implementations_defined = ref ([] : (string * string) list) let cmx_required = ref ([] : string list) let check_consistency file_name unit crc = begin try List.iter - (fun (name, crc) -> - if name = unit.ui_name - then Consistbl.set crc_interfaces name crc file_name - else Consistbl.check crc_interfaces name crc file_name) + (fun (name, crco) -> + interfaces := name :: !interfaces; + match crco with + None -> () + | Some crc -> + if name = unit.ui_name + then Consistbl.set crc_interfaces name crc file_name + else Consistbl.check crc_interfaces name crc file_name) unit.ui_imports_cmi with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_interface(name, user, auth))) end; begin try List.iter - (fun (name, crc) -> - if crc <> cmx_not_found_crc then - Consistbl.check crc_implementations name crc file_name - else if List.mem name !cmx_required then - raise(Error(Missing_cmx(file_name, name))) - else - extra_implementations := name :: !extra_implementations) + (fun (name, crco) -> + implementations := name :: !implementations; + match crco with + None -> + if List.mem name !cmx_required then + raise(Error(Missing_cmx(file_name, name))) + | Some crc -> + Consistbl.check crc_implementations name crc file_name) unit.ui_imports_cmx with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_implementation(name, user, auth))) @@ -67,6 +76,7 @@ raise (Error(Multiple_definition(unit.ui_name, file_name, source))) with Not_found -> () end; + implementations := unit.ui_name :: !implementations; Consistbl.set crc_implementations unit.ui_name crc file_name; implementations_defined := (unit.ui_name, file_name) :: !implementations_defined; @@ -74,13 +84,9 @@ cmx_required := unit.ui_name :: !cmx_required let extract_crc_interfaces () = - Consistbl.extract crc_interfaces + Consistbl.extract !interfaces crc_interfaces let extract_crc_implementations () = - List.fold_left - (fun ncl n -> - if List.mem_assoc n ncl then ncl else (n, cmx_not_found_crc) :: ncl) - (Consistbl.extract crc_implementations) - !extra_implementations + Consistbl.extract !implementations crc_implementations (* Add C objects and options and "custom" info from a library descriptor. See bytecomp/bytelink.ml for comments on the order of C objects. *) @@ -88,10 +94,13 @@ let lib_ccobjs = ref [] let lib_ccopts = ref [] -let add_ccobjs l = +let add_ccobjs origin l = if not !Clflags.no_auto_link then begin lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; - lib_ccopts := l.lib_ccopts @ !lib_ccopts + let replace_origin = + Misc.replace_substring ~before:"$CAMLORIGIN" ~after:origin + in + lib_ccopts := List.map replace_origin l.lib_ccopts @ !lib_ccopts end let runtime_lib () = @@ -126,7 +135,7 @@ try ignore (Hashtbl.find missing_globals name); true with Not_found -> false -let add_required by (name, crc) = +let add_required by (name, _crc) = try let rq = Hashtbl.find missing_globals name in rq := by :: !rq @@ -176,7 +185,7 @@ | Library (file_name,infos) -> (* This is an archive file. Each unit contained in it will be linked in only if needed. *) - add_ccobjs infos; + add_ccobjs (Filename.dirname file_name) infos; List.fold_right (fun (info, crc) reqd -> if info.ui_force_link @@ -194,46 +203,48 @@ (* Second pass: generate the startup file and link it with everything else *) -let make_startup_file ppf filename units_list = +let make_startup_file ppf units_list = let compile_phrase p = Asmgen.compile_phrase ppf p in - let oc = open_out filename in - Emitaux.output_channel := oc; Location.input_name := "caml_startup"; (* set name of "current" input *) - Compilenv.reset "_startup"; (* set the name of the "current" compunit *) - Emit.begin_assembly(); + Compilenv.reset ~source_provenance:Timings.Startup "_startup"; + (* set the name of the "current" compunit *) + Emit.begin_assembly (); let name_list = List.flatten (List.map (fun (info,_,_) -> info.ui_defines) units_list) in compile_phrase (Cmmgen.entry_point name_list); let units = List.map (fun (info,_,_) -> info) units_list in List.iter compile_phrase (Cmmgen.generic_functions false units); - Array.iter - (fun name -> compile_phrase (Cmmgen.predef_exception name)) + Array.iteri + (fun i name -> compile_phrase (Cmmgen.predef_exception i name)) Runtimedef.builtin_exceptions; compile_phrase (Cmmgen.global_table name_list); compile_phrase (Cmmgen.globals_map (List.map (fun (unit,_,crc) -> - try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi, - crc, - unit.ui_defines) - with Not_found -> assert false) + let intf_crc = + try + match List.assoc unit.ui_name unit.ui_imports_cmi with + None -> assert false + | Some crc -> crc + with Not_found -> assert false + in + (unit.ui_name, intf_crc, crc, unit.ui_defines)) units_list)); compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list)); compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list)); - compile_phrase - (Cmmgen.frame_table("_startup" :: "_system" :: name_list)); - - Emit.end_assembly(); - close_out oc + let all_names = "_startup" :: "_system" :: name_list in + compile_phrase (Cmmgen.frame_table all_names); + if Config.spacetime then begin + compile_phrase (Cmmgen.spacetime_shapes all_names); + end; + Emit.end_assembly () -let make_shared_startup_file ppf units filename = +let make_shared_startup_file ppf units = let compile_phrase p = Asmgen.compile_phrase ppf p in - let oc = open_out filename in - Emitaux.output_channel := oc; Location.input_name := "caml_startup"; - Compilenv.reset "_shared_startup"; - Emit.begin_assembly(); + Compilenv.reset ~source_provenance:Timings.Startup "_shared_startup"; + Emit.begin_assembly (); List.iter compile_phrase (Cmmgen.generic_functions true (List.map fst units)); compile_phrase (Cmmgen.plugin_header units); @@ -242,10 +253,7 @@ (List.map (fun (ui,_) -> ui.ui_symbol) units)); (* this is to force a reference to all units, otherwise the linker might drop some of them (in case of libraries) *) - - Emit.end_assembly(); - close_out oc - + Emit.end_assembly () let call_linker_shared file_list output_name = if not (Ccomp.call_linker Ccomp.Dll output_name file_list "") @@ -262,27 +270,35 @@ (List.rev !Clflags.ccobjs) in let startup = - if !Clflags.keep_startup_file + if !Clflags.keep_startup_file || !Emitaux.binary_backend_available then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in - make_shared_startup_file ppf - (List.map (fun (ui,_,crc) -> (ui,crc)) units_tolink) startup; let startup_obj = output_name ^ ".startup" ^ ext_obj in - if Proc.assemble_file startup startup_obj <> 0 - then raise(Error(Assembler_error startup)); - if not !Clflags.keep_startup_file then remove_file startup; + Asmgen.compile_unit ~source_provenance:Timings.Startup output_name + startup !Clflags.keep_startup_file startup_obj + (fun () -> + make_shared_startup_file ppf + (List.map (fun (ui,_,crc) -> (ui,crc)) units_tolink) + ); call_linker_shared (startup_obj :: objfiles) output_name; remove_file startup_obj let call_linker file_list startup_file output_name = let main_dll = !Clflags.output_c_object && Filename.check_suffix output_name Config.ext_dll + and main_obj_runtime = !Clflags.output_complete_object in let files = startup_file :: (List.rev file_list) in + let libunwind = + if not Config.spacetime then [] + else if not Config.libunwind_available then [] + else String.split_on_char ' ' Config.libunwind_link_flags + in let files, c_lib = - if (not !Clflags.output_c_object) || main_dll then - files @ (List.rev !Clflags.ccobjs) @ runtime_lib (), - (if !Clflags.nopervasives then "" else Config.native_c_libraries) + if (not !Clflags.output_c_object) || main_dll || main_obj_runtime then + files @ (List.rev !Clflags.ccobjs) @ runtime_lib () @ libunwind, + (if !Clflags.nopervasives || main_obj_runtime + then "" else Config.native_c_libraries) else files, "" in @@ -318,19 +334,17 @@ Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; (* put user's opts first *) let startup = - if !Clflags.keep_startup_file then output_name ^ ".startup" ^ ext_asm + if !Clflags.keep_startup_file || !Emitaux.binary_backend_available + then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in - make_startup_file ppf startup units_tolink; let startup_obj = Filename.temp_file "camlstartup" ext_obj in - if Proc.assemble_file startup startup_obj <> 0 then - raise(Error(Assembler_error startup)); - try - call_linker (List.map object_file_name objfiles) startup_obj output_name; - if not !Clflags.keep_startup_file then remove_file startup; - remove_file startup_obj - with x -> - remove_file startup_obj; - raise x + Asmgen.compile_unit ~source_provenance:Timings.Startup output_name + startup !Clflags.keep_startup_file startup_obj + (fun () -> make_startup_file ppf units_tolink); + Misc.try_finally + (fun () -> + call_linker (List.map object_file_name objfiles) startup_obj output_name) + (fun () -> remove_file startup_obj) (* Error report *) @@ -390,3 +404,18 @@ Location.print_filename filename name Location.print_filename filename name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + Consistbl.clear crc_interfaces; + Consistbl.clear crc_implementations; + implementations_defined := []; + cmx_required := []; + interfaces := []; + implementations := [] diff -Nru ocaml-4.01.0/asmcomp/asmlink.mli ocaml-4.05.0/asmcomp/asmlink.mli --- ocaml-4.01.0/asmcomp/asmlink.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/asmlink.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Link a set of .cmx/.o files and produce an executable or a plugin *) @@ -20,9 +23,10 @@ val call_linker_shared: string list -> string -> unit +val reset : unit -> unit val check_consistency: string -> Cmx_format.unit_infos -> Digest.t -> unit -val extract_crc_interfaces: unit -> (string * Digest.t) list -val extract_crc_implementations: unit -> (string * Digest.t) list +val extract_crc_interfaces: unit -> (string * Digest.t option) list +val extract_crc_implementations: unit -> (string * Digest.t option) list type error = File_not_found of string diff -Nru ocaml-4.01.0/asmcomp/asmpackager.ml ocaml-4.05.0/asmcomp/asmpackager.ml --- ocaml-4.01.0/asmcomp/asmpackager.ml 2013-07-23 14:48:47.000000000 +0000 +++ ocaml-4.05.0/asmcomp/asmpackager.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* "Package" a set of .cmx/.o files into one .cmx/.o file having the original compilation units as sub-modules. *) @@ -38,9 +41,11 @@ let read_member_info pack_path file = ( let name = - String.capitalize(Filename.basename(chop_extensions file)) in + String.capitalize_ascii(Filename.basename(chop_extensions file)) in let kind = - if Filename.check_suffix file ".cmx" then begin + if Filename.check_suffix file ".cmi" then + PM_intf + else begin let (info, crc) = Compilenv.read_unit_info file in if info.ui_name <> name then raise(Error(Illegal_renaming(name, file, info.ui_name))); @@ -50,8 +55,7 @@ Asmlink.check_consistency file info crc; Compilenv.cache_unit_info info; PM_impl info - end else - PM_intf in + end in { pm_file = file; pm_name = name; pm_kind = kind } ) @@ -75,10 +79,11 @@ (* Make the .o file for the package *) -let make_package_object ppf members targetobj targetname coercion = +let make_package_object ppf members targetobj targetname coercion + ~backend = let objtemp = if !Clflags.keep_asm_file - then chop_extension_if_any targetobj ^ ".pack" ^ Config.ext_obj + then Filename.remove_extension targetobj ^ ".pack" ^ Config.ext_obj else (* Put the full name of the module in the temporary file name to avoid collisions with MSVC's link /lib in case of successive @@ -91,13 +96,34 @@ | PM_intf -> None | PM_impl _ -> Some(Ident.create_persistent m.pm_name)) members in - Asmgen.compile_implementation - (chop_extension_if_any objtemp) ppf - (Translmod.transl_store_package - components (Ident.create_persistent targetname) coercion); + let module_ident = Ident.create_persistent targetname in + let source_provenance = Timings.Pack targetname in + let prefixname = Filename.remove_extension objtemp in + if Config.flambda then begin + let size, lam = Translmod.transl_package_flambda components coercion in + let flam = + Middle_end.middle_end ppf + ~source_provenance + ~prefixname + ~backend + ~size + ~filename:targetname + ~module_ident + ~module_initializer:lam + in + Asmgen.compile_implementation_flambda ~source_provenance + prefixname ~backend ~required_globals:Ident.Set.empty ppf flam; + end else begin + let main_module_block_size, code = + Translmod.transl_store_package + components (Ident.create_persistent targetname) coercion in + Asmgen.compile_implementation_clambda ~source_provenance + prefixname ppf { Lambda.code; main_module_block_size; + module_ident; required_globals = Ident.Set.empty } + end; let objfiles = List.map - (fun m -> chop_extension_if_any m.pm_file ^ Config.ext_obj) + (fun m -> Filename.remove_extension m.pm_file ^ Config.ext_obj) (List.filter (fun m -> m.pm_kind <> PM_intf) members) in let ok = Ccomp.call_linker Ccomp.Partial targetobj (objtemp :: objfiles) "" @@ -107,11 +133,23 @@ (* Make the .cmx file for the package *) +let get_export_info ui = + assert(Config.flambda); + match ui.ui_export_info with + | Clambda _ -> assert false + | Flambda info -> info + +let get_approx ui = + assert(not Config.flambda); + match ui.ui_export_info with + | Flambda _ -> assert false + | Clambda info -> info + let build_package_cmx members cmxfile = let unit_names = List.map (fun m -> m.pm_name) members in let filter lst = - List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in + List.filter (fun (name, _crc) -> not (List.mem name unit_names)) lst in let union lst = List.fold_left (List.fold_left @@ -122,7 +160,42 @@ (fun m accu -> match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu) members [] in + let pack_units = + List.fold_left + (fun set info -> + let unit_id = Compilenv.unit_id_from_name info.ui_name in + Compilation_unit.Set.add + (Compilenv.unit_for_global unit_id) set) + Compilation_unit.Set.empty units in + let units = + if Config.flambda then + List.map (fun info -> + { info with + ui_export_info = + Flambda + (Export_info_for_pack.import_for_pack ~pack_units + ~pack:(Compilenv.current_unit ()) + (get_export_info info)) }) + units + else + units + in let ui = Compilenv.current_unit_infos() in + let ui_export_info = + if Config.flambda then + let ui_export_info = + List.fold_left (fun acc info -> + Export_info.merge acc (get_export_info info)) + (Export_info_for_pack.import_for_pack ~pack_units + ~pack:(Compilenv.current_unit ()) + (get_export_info ui)) + units + in + Flambda ui_export_info + else + Clambda (get_approx ui) + in + Export_info_for_pack.clear_import_state (); let pkg_infos = { ui_name = ui.ui_name; ui_symbol = ui.ui_symbol; @@ -130,11 +203,10 @@ List.flatten (List.map (fun info -> info.ui_defines) units) @ [ui.ui_symbol]; ui_imports_cmi = - (ui.ui_name, Env.crc_of_unit ui.ui_name) :: + (ui.ui_name, Some (Env.crc_of_unit ui.ui_name)) :: filter(Asmlink.extract_crc_interfaces()); ui_imports_cmx = filter(Asmlink.extract_crc_implementations()); - ui_approx = ui.ui_approx; ui_curry_fun = union(List.map (fun info -> info.ui_curry_fun) units); ui_apply_fun = @@ -143,25 +215,26 @@ union(List.map (fun info -> info.ui_send_fun) units); ui_force_link = List.exists (fun info -> info.ui_force_link) units; + ui_export_info; } in Compilenv.write_unit_info pkg_infos cmxfile (* Make the .cmx and the .o for the package *) let package_object_files ppf files targetcmx - targetobj targetname coercion = + targetobj targetname coercion ~backend = let pack_path = match !Clflags.for_package with | None -> targetname | Some p -> p ^ "." ^ targetname in let members = map_left_right (read_member_info pack_path) files in check_units members; - make_package_object ppf members targetobj targetname coercion; + make_package_object ppf members targetobj targetname coercion ~backend; build_package_cmx members targetcmx (* The entry point *) -let package_files ppf files targetcmx = +let package_files ppf initial_env files targetcmx ~backend = let files = List.map (fun f -> @@ -170,15 +243,18 @@ files in let prefix = chop_extensions targetcmx in let targetcmi = prefix ^ ".cmi" in - let targetobj = chop_extension_if_any targetcmx ^ Config.ext_obj in - let targetname = String.capitalize(Filename.basename prefix) in + let targetobj = Filename.remove_extension targetcmx ^ Config.ext_obj in + let targetname = String.capitalize_ascii(Filename.basename prefix) in (* Set the name of the current "input" *) Location.input_name := targetcmx; (* Set the name of the current compunit *) - Compilenv.reset ?packname:!Clflags.for_package targetname; + Compilenv.reset ~source_provenance:(Timings.Pack targetname) + ?packname:!Clflags.for_package targetname; try - let coercion = Typemod.package_units files targetcmi targetname in + let coercion = + Typemod.package_units initial_env files targetcmi targetname in package_object_files ppf files targetcmx targetobj targetname coercion + ~backend with x -> remove_file targetcmx; remove_file targetobj; raise x @@ -204,3 +280,10 @@ fprintf ppf "Error while assembling %s" file | Linking_error -> fprintf ppf "Error during partial linking" + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff -Nru ocaml-4.01.0/asmcomp/asmpackager.mli ocaml-4.05.0/asmcomp/asmpackager.mli --- ocaml-4.01.0/asmcomp/asmpackager.mli 2013-04-29 14:57:38.000000000 +0000 +++ ocaml-4.05.0/asmcomp/asmpackager.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,19 +1,28 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* "Package" a set of .cmx/.o files into one .cmx/.o file having the original compilation units as sub-modules. *) -val package_files: Format.formatter -> string list -> string -> unit +val package_files + : Format.formatter + -> Env.t + -> string list + -> string + -> backend:(module Backend_intf.S) + -> unit type error = Illegal_renaming of string * string * string diff -Nru ocaml-4.01.0/asmcomp/branch_relaxation_intf.ml ocaml-4.05.0/asmcomp/branch_relaxation_intf.ml --- ocaml-4.01.0/asmcomp/branch_relaxation_intf.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/branch_relaxation_intf.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,75 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module type S = sig + (* The distance between two instructions, in arbitrary units (typically + the natural word size of instructions). *) + type distance = int + + module Cond_branch : sig + (* The various types of conditional branches for a given target that + may require relaxation. *) + type t + + (* All values of type [t] that the emitter may produce. *) + val all : t list + + (* If [max_displacement branch] is [n] then [branch] is assumed to + reach any address in the range [pc - n, pc + n] (inclusive), after + the [pc] of the branch has been adjusted by [offset_pc_at_branch] + (see below). *) + val max_displacement : t -> distance + + (* Which variety of conditional branch may be produced by the emitter for a + given instruction description. For the moment we assume that only one + such variety per instruction description is needed. + + N.B. The only instructions supported are the following: + - Lop (Ialloc _) + - Lop (Iintop Icheckbound) + - Lop (Iintop_imm (Icheckbound, _)) + - Lop (Ispecific _) + - Lcondbranch (_, _) + - Lcondbranch3 (_, _, _) + [classify_instr] is expected to return [None] when called on any + instruction not in this list. *) + val classify_instr : Linearize.instruction_desc -> t option + end + + (* The value to be added to the program counter (in [distance] units) + when it is at a branch instruction, prior to calculating the distance + to a branch target. *) + val offset_pc_at_branch : distance + + (* The maximum size of a given instruction. *) + val instr_size : Linearize.instruction_desc -> distance + + (* Insertion of target-specific code to relax operations that cannot be + relaxed generically. It is assumed that these rewrites do not change + the size of out-of-line code (cf. branch_relaxation.mli). *) + val relax_allocation + : num_words:int + -> label_after_call_gc:Cmm.label option + -> Linearize.instruction_desc + val relax_intop_checkbound + : label_after_error:Cmm.label option + -> Linearize.instruction_desc + val relax_intop_imm_checkbound + : bound:int + -> label_after_error:Cmm.label option + -> Linearize.instruction_desc + val relax_specific_op : Arch.specific_operation -> Linearize.instruction_desc +end diff -Nru ocaml-4.01.0/asmcomp/branch_relaxation.ml ocaml-4.05.0/asmcomp/branch_relaxation.ml --- ocaml-4.01.0/asmcomp/branch_relaxation.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/branch_relaxation.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,142 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Mach +open Linearize + +module Make (T : Branch_relaxation_intf.S) = struct + let label_map code = + let map = Hashtbl.create 37 in + let rec fill_map pc instr = + match instr.desc with + | Lend -> (pc, map) + | Llabel lbl -> Hashtbl.add map lbl pc; fill_map pc instr.next + | op -> fill_map (pc + T.instr_size op) instr.next + in + fill_map 0 code + + let branch_overflows map pc_branch lbl_dest max_branch_offset = + let pc_dest = Hashtbl.find map lbl_dest in + let delta = pc_dest - (pc_branch + T.offset_pc_at_branch) in + delta <= -max_branch_offset || delta >= max_branch_offset + + let opt_branch_overflows map pc_branch opt_lbl_dest max_branch_offset = + match opt_lbl_dest with + | None -> false + | Some lbl_dest -> + branch_overflows map pc_branch lbl_dest max_branch_offset + + let instr_overflows ~code_size ~max_out_of_line_code_offset instr map pc = + match T.Cond_branch.classify_instr instr.desc with + | None -> false + | Some branch -> + let max_branch_offset = + (* Remember to cut some slack for multi-word instructions (in the + [Linearize] sense of the word) where the branch can be anywhere in + the middle. 12 words of slack is plenty. *) + T.Cond_branch.max_displacement branch - 12 + in + match instr.desc with + | Lop (Ialloc _) + | Lop (Iintop (Icheckbound _)) + | Lop (Iintop_imm (Icheckbound _, _)) + | Lop (Ispecific _) -> + (* We assume that any branches eligible for relaxation generated + by these instructions only branch forward. We further assume + that any of these may branch to an out-of-line code block. *) + code_size + max_out_of_line_code_offset - pc >= max_branch_offset + | Lcondbranch (_, lbl) -> + branch_overflows map pc lbl max_branch_offset + | Lcondbranch3 (lbl0, lbl1, lbl2) -> + opt_branch_overflows map pc lbl0 max_branch_offset + || opt_branch_overflows map pc lbl1 max_branch_offset + || opt_branch_overflows map pc lbl2 max_branch_offset + | _ -> + Misc.fatal_error "Unsupported instruction for branch relaxation" + + let fixup_branches ~code_size ~max_out_of_line_code_offset map code = + let expand_optbranch lbl n arg next = + match lbl with + | None -> next + | Some l -> + instr_cons (Lcondbranch (Iinttest_imm (Isigned Cmm.Ceq, n), l)) + arg [||] next + in + let rec fixup did_fix pc instr = + match instr.desc with + | Lend -> did_fix + | _ -> + let overflows = + instr_overflows ~code_size ~max_out_of_line_code_offset instr map pc + in + if not overflows then + fixup did_fix (pc + T.instr_size instr.desc) instr.next + else + match instr.desc with + | Lop (Ialloc { words = num_words; label_after_call_gc; }) -> + instr.desc <- T.relax_allocation ~num_words ~label_after_call_gc; + fixup true (pc + T.instr_size instr.desc) instr.next + | Lop (Iintop (Icheckbound { label_after_error; })) -> + instr.desc <- T.relax_intop_checkbound ~label_after_error; + fixup true (pc + T.instr_size instr.desc) instr.next + | Lop (Iintop_imm (Icheckbound { label_after_error; }, bound)) -> + instr.desc + <- T.relax_intop_imm_checkbound ~bound ~label_after_error; + fixup true (pc + T.instr_size instr.desc) instr.next + | Lop (Ispecific specific) -> + instr.desc <- T.relax_specific_op specific; + fixup true (pc + T.instr_size instr.desc) instr.next + | Lcondbranch (test, lbl) -> + let lbl2 = Cmm.new_label() in + let cont = + instr_cons (Lbranch lbl) [||] [||] + (instr_cons (Llabel lbl2) [||] [||] instr.next) + in + instr.desc <- Lcondbranch (invert_test test, lbl2); + instr.next <- cont; + fixup true (pc + T.instr_size instr.desc) instr.next + | Lcondbranch3 (lbl0, lbl1, lbl2) -> + let cont = + expand_optbranch lbl0 0 instr.arg + (expand_optbranch lbl1 1 instr.arg + (expand_optbranch lbl2 2 instr.arg instr.next)) + in + instr.desc <- cont.desc; + instr.next <- cont.next; + fixup true pc instr + | _ -> + (* Any other instruction has already been rejected in + [instr_overflows] above. + We can *never* get here. *) + assert false + in + fixup false 0 code + + (* Iterate branch expansion till all conditional branches are OK *) + + let rec relax code ~max_out_of_line_code_offset = + let min_of_max_branch_offsets = + List.fold_left (fun min_of_max_branch_offsets branch -> + min min_of_max_branch_offsets + (T.Cond_branch.max_displacement branch)) + max_int T.Cond_branch.all + in + let (code_size, map) = label_map code in + if code_size >= min_of_max_branch_offsets + && fixup_branches ~code_size ~max_out_of_line_code_offset map code + then relax code ~max_out_of_line_code_offset + else () +end diff -Nru ocaml-4.01.0/asmcomp/branch_relaxation.mli ocaml-4.05.0/asmcomp/branch_relaxation.mli --- ocaml-4.01.0/asmcomp/branch_relaxation.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/branch_relaxation.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Fix up conditional branches that exceed hardware-allowed ranges. *) + +module Make (T : Branch_relaxation_intf.S) : sig + val relax + : Linearize.instruction + (* [max_offset_of_out_of_line_code] specifies the furthest distance, + measured from the first address immediately after the last instruction + of the function, that may be branched to from within the function in + order to execute "out of line" code blocks such as call GC and + bounds check points. *) + -> max_out_of_line_code_offset:T.distance + -> unit +end diff -Nru ocaml-4.01.0/asmcomp/build_export_info.ml ocaml-4.05.0/asmcomp/build_export_info.ml --- ocaml-4.01.0/asmcomp/build_export_info.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/build_export_info.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,551 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +module Env : sig + type t + + val new_descr : t -> Export_info.descr -> Export_id.t + val record_descr : t -> Export_id.t -> Export_info.descr -> unit + val get_descr : t -> Export_info.approx -> Export_info.descr option + + val add_approx : t -> Variable.t -> Export_info.approx -> t + val add_approx_maps : t -> Export_info.approx Variable.Map.t list -> t + val find_approx : t -> Variable.t -> Export_info.approx + + val get_symbol_descr : t -> Symbol.t -> Export_info.descr option + + val new_unit_descr : t -> Export_id.t + + module Global : sig + (* "Global" as in "without local variable bindings". *) + type t + + val create_empty : unit -> t + + val add_symbol : t -> Symbol.t -> Export_id.t -> t + val new_symbol : t -> Symbol.t -> Export_id.t * t + + val symbol_to_export_id_map : t -> Export_id.t Symbol.Map.t + val export_id_to_descr_map : t -> Export_info.descr Export_id.Map.t + end + + (** Creates a new environment, sharing the mapping from export IDs to + export descriptions with the given global environment. *) + val empty_of_global : Global.t -> t +end = struct + let fresh_id () = Export_id.create (Compilenv.current_unit ()) + + module Global = struct + type t = + { sym : Export_id.t Symbol.Map.t; + (* Note that [ex_table]s themselves are shared (hence [ref] and not + [mutable]). *) + ex_table : Export_info.descr Export_id.Map.t ref; + } + + let create_empty () = + { sym = Symbol.Map.empty; + ex_table = ref Export_id.Map.empty; + } + + let add_symbol t sym export_id = + if Symbol.Map.mem sym t.sym then begin + Misc.fatal_errorf "Build_export_info.Env.Global.add_symbol: cannot \ + rebind symbol %a in environment" + Symbol.print sym + end; + { t with sym = Symbol.Map.add sym export_id t.sym } + + let new_symbol t sym = + let export_id = fresh_id () in + export_id, add_symbol t sym export_id + + let symbol_to_export_id_map t = t.sym + let export_id_to_descr_map t = !(t.ex_table) + end + + (* CR-someday mshinwell: The half-mutable nature of [t] with sharing of + the [ex_table] is kind of nasty. Consider making it immutable. *) + type t = + { var : Export_info.approx Variable.Map.t; + sym : Export_id.t Symbol.Map.t; + ex_table : Export_info.descr Export_id.Map.t ref; + } + + let empty_of_global (env : Global.t) = + { var = Variable.Map.empty; + sym = env.sym; + ex_table = env.ex_table; + } + + let extern_id_descr export_id = + let export = Compilenv.approx_env () in + try Some (Export_info.find_description export export_id) + with Not_found -> None + + let extern_symbol_descr sym = + if Compilenv.is_predefined_exception sym + then None + else + let export = Compilenv.approx_for_global (Symbol.compilation_unit sym) in + try + let id = Symbol.Map.find sym export.symbol_id in + let descr = Export_info.find_description export id in + Some descr + with + | Not_found -> None + + let get_id_descr t export_id = + try Some (Export_id.Map.find export_id !(t.ex_table)) + with Not_found -> extern_id_descr export_id + + let get_symbol_descr t sym = + try + let export_id = Symbol.Map.find sym t.sym in + Some (Export_id.Map.find export_id !(t.ex_table)) + with + | Not_found -> extern_symbol_descr sym + + let get_descr t (approx : Export_info.approx) = + match approx with + | Value_unknown -> None + | Value_id export_id -> get_id_descr t export_id + | Value_symbol sym -> get_symbol_descr t sym + + let record_descr t id (descr : Export_info.descr) = + if Export_id.Map.mem id !(t.ex_table) then begin + Misc.fatal_errorf "Build_export_info.Env.record_descr: cannot rebind \ + export ID %a in environment" + Export_id.print id + end; + t.ex_table := Export_id.Map.add id descr !(t.ex_table) + + let new_descr t (descr : Export_info.descr) = + let id = fresh_id () in + record_descr t id descr; + id + + let new_unit_descr t = + new_descr t (Value_constptr 0) + + let add_approx t var approx = + if Variable.Map.mem var t.var then begin + Misc.fatal_errorf "Build_export_info.Env.add_approx: cannot rebind \ + variable %a in environment" + Variable.print var + end; + { t with var = Variable.Map.add var approx t.var; } + + let add_approx_map t vars_to_approxs = + Variable.Map.fold (fun var approx t -> add_approx t var approx) + vars_to_approxs + t + + let add_approx_maps t vars_to_approxs_list = + List.fold_left add_approx_map t vars_to_approxs_list + + let find_approx t var : Export_info.approx = + try Variable.Map.find var t.var with + | Not_found -> Value_unknown +end + +let descr_of_constant (c : Flambda.const) : Export_info.descr = + match c with + (* [Const_pointer] is an immediate value of a type whose values may be + boxed (typically a variant type with both constant and non-constant + constructors). *) + | Int i -> Value_int i + | Char c -> Value_char c + | Const_pointer i -> Value_constptr i + +let descr_of_allocated_constant (c : Allocated_const.t) : Export_info.descr = + match c with + | Float f -> Value_float f + | Int32 i -> Value_boxed_int (Int32, i) + | Int64 i -> Value_boxed_int (Int64, i) + | Nativeint i -> Value_boxed_int (Nativeint, i) + | String s -> + let v_string : Export_info.value_string = + { size = String.length s; contents = Unknown_or_mutable; } + in + Value_string v_string + | Immutable_string s -> + let v_string : Export_info.value_string = + { size = String.length s; contents = Contents s; } + in + Value_string v_string + | Immutable_float_array fs -> + Value_float_array { + contents = Contents (Array.map (fun x -> Some x) (Array.of_list fs)); + size = List.length fs; + } + | Float_array fs -> + Value_float_array { + contents = Unknown_or_mutable; + size = List.length fs; + } + +let rec approx_of_expr (env : Env.t) (flam : Flambda.t) : Export_info.approx = + match flam with + | Var var -> Env.find_approx env var + | Let { var; defining_expr; body; _ } -> + let approx = descr_of_named env defining_expr in + let env = Env.add_approx env var approx in + approx_of_expr env body + | Let_mutable { body } -> + approx_of_expr env body + | Let_rec (defs, body) -> + let env = + List.fold_left (fun env (var, defining_expr) -> + let approx = descr_of_named env defining_expr in + Env.add_approx env var approx) + env defs + in + approx_of_expr env body + | Apply { func; kind; _ } -> + begin match kind with + | Indirect -> Value_unknown + | Direct closure_id' -> + match Env.get_descr env (Env.find_approx env func) with + | Some (Value_closure + { closure_id; set_of_closures = { results; _ }; }) -> + assert (Closure_id.equal closure_id closure_id'); + assert (Closure_id.Map.mem closure_id results); + Closure_id.Map.find closure_id results + | _ -> Value_unknown + end + | Assign _ -> Value_id (Env.new_unit_descr env) + | For _ -> Value_id (Env.new_unit_descr env) + | While _ -> Value_id (Env.new_unit_descr env) + | Static_raise _ | Static_catch _ | Try_with _ | If_then_else _ + | Switch _ | String_switch _ | Send _ | Proved_unreachable -> + Value_unknown + +and descr_of_named (env : Env.t) (named : Flambda.named) + : Export_info.approx = + match named with + | Expr expr -> approx_of_expr env expr + | Symbol sym -> Value_symbol sym + | Read_mutable _ -> Value_unknown + | Read_symbol_field (sym, i) -> + begin match Env.get_symbol_descr env sym with + | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i) + | _ -> Value_unknown + end + | Const const -> + Value_id (Env.new_descr env (descr_of_constant const)) + | Allocated_const const -> + Value_id (Env.new_descr env (descr_of_allocated_constant const)) + | Prim (Pmakeblock (tag, Immutable, _value_kind), args, _dbg) -> + let approxs = List.map (Env.find_approx env) args in + let descr : Export_info.descr = + Value_block (Tag.create_exn tag, Array.of_list approxs) + in + Value_id (Env.new_descr env descr) + | Prim (Pfield i, [arg], _) -> + begin match Env.get_descr env (Env.find_approx env arg) with + | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i) + | _ -> Value_unknown + end + | Prim (Pgetglobal id, _, _) -> + Value_symbol (Compilenv.symbol_for_global' id) + | Prim _ -> Value_unknown + | Set_of_closures set -> + let descr : Export_info.descr = + Value_set_of_closures (describe_set_of_closures env set) + in + Value_id (Env.new_descr env descr) + | Project_closure { set_of_closures; closure_id; } -> + begin match Env.get_descr env (Env.find_approx env set_of_closures) with + | Some (Value_set_of_closures set_of_closures) -> + if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin + Misc.fatal_errorf "Could not build export description for \ + [Project_closure]: closure ID %a not in set of closures" + Closure_id.print closure_id + end; + let descr : Export_info.descr = + Value_closure { closure_id = closure_id; set_of_closures; } + in + Value_id (Env.new_descr env descr) + | _ -> + (* It would be nice if this were [assert false], but owing to the fact + that this pass may propagate less information than for example + [Inline_and_simplify], we might end up here. *) + Value_unknown + end + | Move_within_set_of_closures { closure; start_from; move_to; } -> + begin match Env.get_descr env (Env.find_approx env closure) with + | Some (Value_closure { set_of_closures; closure_id; }) -> + assert (Closure_id.equal closure_id start_from); + let descr : Export_info.descr = + Value_closure { closure_id = move_to; set_of_closures; } + in + Value_id (Env.new_descr env descr) + | _ -> Value_unknown + end + | Project_var { closure; closure_id = closure_id'; var; } -> + begin match Env.get_descr env (Env.find_approx env closure) with + | Some (Value_closure + { set_of_closures = { bound_vars; _ }; closure_id; }) -> + assert (Closure_id.equal closure_id closure_id'); + if not (Var_within_closure.Map.mem var bound_vars) then begin + Misc.fatal_errorf "Project_var from %a (closure ID %a) of \ + variable %a that is not bound by the closure. \ + Variables bound by the closure are: %a" + Variable.print closure + Closure_id.print closure_id + Var_within_closure.print var + (Var_within_closure.Map.print (fun _ _ -> ())) bound_vars + end; + Var_within_closure.Map.find var bound_vars + | _ -> Value_unknown + end + +and describe_set_of_closures env (set : Flambda.set_of_closures) + : Export_info.value_set_of_closures = + let bound_vars_approx = + Variable.Map.map (fun (external_var : Flambda.specialised_to) -> + Env.find_approx env external_var.var) + set.free_vars + in + let specialised_args_approx = + Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + Env.find_approx env spec_to.var) + set.specialised_args + in + let closures_approx = + (* To build an approximation of the results, we need an + approximation of the functions. The first one we can build is + one where every function returns something unknown. + *) + (* CR-someday pchambart: we could improve a bit on that by building a + recursive approximation of the closures: The value_closure + description contains a [value_set_of_closures]. We could replace + this field by a [Expr_id.t] or an [approx]. + mshinwell: Deferred for now. + *) + let initial_value_set_of_closures = + { Export_info. + set_of_closures_id = set.function_decls.set_of_closures_id; + bound_vars = Var_within_closure.wrap_map bound_vars_approx; + results = + Closure_id.wrap_map + (Variable.Map.map (fun _ -> Export_info.Value_unknown) + set.function_decls.funs); + aliased_symbol = None; + } + in + Variable.Map.mapi (fun fun_var _function_decl -> + let descr : Export_info.descr = + Value_closure + { closure_id = Closure_id.wrap fun_var; + set_of_closures = initial_value_set_of_closures; + } + in + Export_info.Value_id (Env.new_descr env descr)) + set.function_decls.funs + in + let closure_env = + Env.add_approx_maps env + [closures_approx; bound_vars_approx; specialised_args_approx] + in + let results = + let result_approx _var (function_decl : Flambda.function_declaration) = + approx_of_expr closure_env function_decl.body + in + Variable.Map.mapi result_approx set.function_decls.funs + in + { set_of_closures_id = set.function_decls.set_of_closures_id; + bound_vars = Var_within_closure.wrap_map bound_vars_approx; + results = Closure_id.wrap_map results; + aliased_symbol = None; + } + +let approx_of_constant_defining_value_block_field env + (c : Flambda.constant_defining_value_block_field) : Export_info.approx = + match c with + | Symbol s -> Value_symbol s + | Const c -> Value_id (Env.new_descr env (descr_of_constant c)) + +let describe_constant_defining_value env export_id symbol + (const : Flambda.constant_defining_value) = + let env = + (* Assignments of variables to export IDs are local to each constant + defining value. *) + Env.empty_of_global env + in + match const with + | Allocated_const alloc_const -> + let descr = descr_of_allocated_constant alloc_const in + Env.record_descr env export_id descr + | Block (tag, fields) -> + let approxs = + List.map (approx_of_constant_defining_value_block_field env) fields + in + Env.record_descr env export_id (Value_block (tag, Array.of_list approxs)) + | Set_of_closures set_of_closures -> + let descr : Export_info.descr = + Value_set_of_closures + { (describe_set_of_closures env set_of_closures) with + aliased_symbol = Some symbol; + } + in + Env.record_descr env export_id descr + | Project_closure (sym, closure_id) -> + begin match Env.get_symbol_descr env sym with + | Some (Value_set_of_closures set_of_closures) -> + if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin + Misc.fatal_errorf "Could not build export description for \ + [Project_closure] constant defining value: closure ID %a not in \ + set of closures" + Closure_id.print closure_id + end; + let descr = + Export_info.Value_closure + { closure_id = closure_id; set_of_closures; } + in + Env.record_descr env export_id descr + | None -> + Misc.fatal_errorf + "Cannot project symbol %a to closure_id %a. \ + No available export description@." + Symbol.print sym + Closure_id.print closure_id + | Some (Value_closure _) -> + Misc.fatal_errorf + "Cannot project symbol %a to closure_id %a. \ + The symbol is a closure instead of a set of closures.@." + Symbol.print sym + Closure_id.print closure_id + | Some _ -> + Misc.fatal_errorf + "Cannot project symbol %a to closure_id %a. \ + The symbol is not a set of closures.@." + Symbol.print sym + Closure_id.print closure_id + end + +let describe_program (env : Env.Global.t) (program : Flambda.program) = + let rec loop env (program : Flambda.program_body) = + match program with + | Let_symbol (symbol, constant_defining_value, program) -> + let id, env = Env.Global.new_symbol env symbol in + describe_constant_defining_value env id symbol constant_defining_value; + loop env program + | Let_rec_symbol (defs, program) -> + let env, defs = + List.fold_left (fun (env, defs) (symbol, def) -> + let id, env = Env.Global.new_symbol env symbol in + env, ((id, symbol, def) :: defs)) + (env, []) defs + in + (* [Project_closure]s are separated to be handled last. They are the + only values that need a description for their argument. *) + let project_closures, other_constants = + List.partition (function + | _, _, Flambda.Project_closure _ -> true + | _ -> false) + defs + in + List.iter (fun (id, symbol, def) -> + describe_constant_defining_value env id symbol def) + other_constants; + List.iter (fun (id, symbol, def) -> + describe_constant_defining_value env id symbol def) + project_closures; + loop env program + | Initialize_symbol (symbol, tag, fields, program) -> + let id = + let env = + (* Assignments of variables to export IDs are local to each + [Initialize_symbol] construction. *) + Env.empty_of_global env + in + let field_approxs = List.map (approx_of_expr env) fields in + let descr : Export_info.descr = + Value_block (tag, Array.of_list field_approxs) + in + Env.new_descr env descr + in + let env = Env.Global.add_symbol env symbol id in + loop env program + | Effect (_expr, program) -> loop env program + | End symbol -> symbol, env + in + loop env program.program_body + +let build_export_info ~(backend : (module Backend_intf.S)) + (program : Flambda.program) : Export_info.t = + if !Clflags.opaque then + Export_info.empty + else + (* CR-soon pchambart: Should probably use that instead of the ident of + the module as global identifier. + mshinwell: Is "that" the variable "_global_symbol"? + Yes it is. We are just assuming that the symbol produced from + the identifier of the module is the right one. *) + let _global_symbol, env = + describe_program (Env.Global.create_empty ()) program + in + let sets_of_closures = + Flambda_utils.all_function_decls_indexed_by_set_of_closures_id program + in + let closures = + Flambda_utils.all_function_decls_indexed_by_closure_id program + in + let invariant_params = + Set_of_closures_id.Map.map + (fun { Flambda. function_decls; _ } -> + Invariant_params.invariant_params_in_recursion + ~backend function_decls) + (Flambda_utils.all_sets_of_closures_map program) + in + let unnested_values = + Env.Global.export_id_to_descr_map env + in + let invariant_params = + let export = Compilenv.approx_env () in + Export_id.Map.fold (fun _eid (descr:Export_info.descr) + (invariant_params) -> + match descr with + | Value_closure { set_of_closures } + | Value_set_of_closures set_of_closures -> + let { Export_info.set_of_closures_id } = set_of_closures in + begin match + Set_of_closures_id.Map.find set_of_closures_id + export.invariant_params + with + | exception Not_found -> + invariant_params + | (set:Variable.Set.t Variable.Map.t) -> + Set_of_closures_id.Map.add set_of_closures_id set invariant_params + end + | _ -> + invariant_params) + unnested_values invariant_params + in + let values = + Export_info.nest_eid_map unnested_values + in + Export_info.create ~values + ~symbol_id:(Env.Global.symbol_to_export_id_map env) + ~offset_fun:Closure_id.Map.empty + ~offset_fv:Var_within_closure.Map.empty + ~sets_of_closures ~closures + ~constant_sets_of_closures:Set_of_closures_id.Set.empty + ~invariant_params diff -Nru ocaml-4.01.0/asmcomp/build_export_info.mli ocaml-4.05.0/asmcomp/build_export_info.mli --- ocaml-4.01.0/asmcomp/build_export_info.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/build_export_info.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,25 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Construct export information, for emission into .cmx files, from an + Flambda program. *) + +val build_export_info : + backend:(module Backend_intf.S) -> + Flambda.program -> + Export_info.t diff -Nru ocaml-4.01.0/asmcomp/clambda.ml ocaml-4.05.0/asmcomp/clambda.ml --- ocaml-4.01.0/asmcomp/clambda.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/clambda.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* A variant of the "lambda" code with direct / indirect calls explicit and closures explicit too *) @@ -18,17 +21,33 @@ type function_label = string -type ulambda = +type ustructured_constant = + | Uconst_float of float + | Uconst_int32 of int32 + | Uconst_int64 of int64 + | Uconst_nativeint of nativeint + | Uconst_block of int * uconstant list + | Uconst_float_array of float list + | Uconst_string of string + | Uconst_closure of ufunction list * string * uconstant list + +and uconstant = + | Uconst_ref of string * ustructured_constant option + | Uconst_int of int + | Uconst_ptr of int + +and ulambda = Uvar of Ident.t - | Uconst of structured_constant * string option + | Uconst of uconstant | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list | Uoffset of ulambda * int - | Ulet of Ident.t * ulambda * ulambda + | Ulet of mutable_flag * value_kind * Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda @@ -38,13 +57,15 @@ | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda | Uassign of Ident.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t + | Uunreachable and ufunction = { label : function_label; arity : int; params : Ident.t list; body : ulambda; - dbg : Debuginfo.t + dbg : Debuginfo.t; + env : Ident.t option; } and ulambda_switch = @@ -59,7 +80,9 @@ { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option } + mutable fun_inline: (Ident.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } (* Approximation of values *) @@ -67,5 +90,86 @@ Value_closure of function_description * value_approximation | Value_tuple of value_approximation array | Value_unknown - | Value_integer of int - | Value_constptr of int + | Value_const of uconstant + | Value_global_field of string * int + +(* Preallocated globals *) + +type preallocated_block = { + symbol : string; + exported : bool; + tag : int; + size : int; +} + +type preallocated_constant = { + symbol : string; + exported : bool; + definition : ustructured_constant; +} + +(* Comparison functions for constants. We must not use Pervasives.compare + because it compares "0.0" and "-0.0" equal. (PR#6442) *) + +let compare_floats x1 x2 = + Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) + +let rec compare_float_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_floats h1 h2 in + if c <> 0 then c else compare_float_lists t1 t2 + +let compare_constants c1 c2 = + match c1, c2 with + | Uconst_ref(lbl1, _c1), Uconst_ref(lbl2, _c2) -> String.compare lbl1 lbl2 + (* Same labels -> same constants. + Different labels -> different constants, even if the contents + match, because of string constants that must not be + reshared. *) + | Uconst_int n1, Uconst_int n2 -> Pervasives.compare n1 n2 + | Uconst_ptr n1, Uconst_ptr n2 -> Pervasives.compare n1 n2 + | Uconst_ref _, _ -> -1 + | Uconst_int _, Uconst_ref _ -> 1 + | Uconst_int _, Uconst_ptr _ -> -1 + | Uconst_ptr _, _ -> 1 + +let rec compare_constant_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_constants h1 h2 in + if c <> 0 then c else compare_constant_lists t1 t2 + +let rank_structured_constant = function + | Uconst_float _ -> 0 + | Uconst_int32 _ -> 1 + | Uconst_int64 _ -> 2 + | Uconst_nativeint _ -> 3 + | Uconst_block _ -> 4 + | Uconst_float_array _ -> 5 + | Uconst_string _ -> 6 + | Uconst_closure _ -> 7 + +let compare_structured_constants c1 c2 = + match c1, c2 with + | Uconst_float x1, Uconst_float x2 -> compare_floats x1 x2 + | Uconst_int32 x1, Uconst_int32 x2 -> Int32.compare x1 x2 + | Uconst_int64 x1, Uconst_int64 x2 -> Int64.compare x1 x2 + | Uconst_nativeint x1, Uconst_nativeint x2 -> Nativeint.compare x1 x2 + | Uconst_block(t1, l1), Uconst_block(t2, l2) -> + let c = t1 - t2 (* no overflow possible here *) in + if c <> 0 then c else compare_constant_lists l1 l2 + | Uconst_float_array l1, Uconst_float_array l2 -> + compare_float_lists l1 l2 + | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2 + | Uconst_closure (_,lbl1,_), Uconst_closure (_,lbl2,_) -> + String.compare lbl1 lbl2 + | _, _ -> + (* no overflow possible here *) + rank_structured_constant c1 - rank_structured_constant c2 diff -Nru ocaml-4.01.0/asmcomp/clambda.mli ocaml-4.05.0/asmcomp/clambda.mli --- ocaml-4.01.0/asmcomp/clambda.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/clambda.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* A variant of the "lambda" code with direct / indirect calls explicit and closures explicit too *) @@ -18,17 +21,33 @@ type function_label = string -type ulambda = +type ustructured_constant = + | Uconst_float of float + | Uconst_int32 of int32 + | Uconst_int64 of int64 + | Uconst_nativeint of nativeint + | Uconst_block of int * uconstant list + | Uconst_float_array of float list + | Uconst_string of string + | Uconst_closure of ufunction list * string * uconstant list + +and uconstant = + | Uconst_ref of string * ustructured_constant option + | Uconst_int of int + | Uconst_ptr of int + +and ulambda = Uvar of Ident.t - | Uconst of structured_constant * string option + | Uconst of uconstant | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list | Uoffset of ulambda * int - | Ulet of Ident.t * ulambda * ulambda + | Ulet of mutable_flag * value_kind * Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda @@ -38,6 +57,7 @@ | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda | Uassign of Ident.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t + | Uunreachable and ufunction = { label : function_label; @@ -45,6 +65,7 @@ params : Ident.t list; body : ulambda; dbg : Debuginfo.t; + env : Ident.t option; } and ulambda_switch = @@ -59,7 +80,9 @@ { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option } + mutable fun_inline: (Ident.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } (* Approximation of values *) @@ -67,5 +90,25 @@ Value_closure of function_description * value_approximation | Value_tuple of value_approximation array | Value_unknown - | Value_integer of int - | Value_constptr of int + | Value_const of uconstant + | Value_global_field of string * int + +(* Comparison functions for constants *) + +val compare_structured_constants: + ustructured_constant -> ustructured_constant -> int +val compare_constants: + uconstant -> uconstant -> int + +type preallocated_block = { + symbol : string; + exported : bool; + tag : int; + size : int; +} + +type preallocated_constant = { + symbol : string; + exported : bool; + definition : ustructured_constant; +} diff -Nru ocaml-4.01.0/asmcomp/closure.ml ocaml-4.05.0/asmcomp/closure.ml --- ocaml-4.01.0/asmcomp/closure.ml 2013-06-07 11:32:13.000000000 +0000 +++ ocaml-4.05.0/asmcomp/closure.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Introduction of closures, uncurrying, recognition of direct calls *) @@ -19,6 +22,14 @@ open Switch open Clambda +module Storer = + Switch.Store + (struct + type t = lambda + type key = lambda + let make_key = Lambda.make_key + end) + (* Auxiliaries for compiling functions *) let rec split_list n l = @@ -39,38 +50,43 @@ and no longer in Cmmgen so that approximations stored in .cmx files contain the right names if the -for-pack option is active. *) -let getglobal id = +let getglobal dbg id = Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)), - [], Debuginfo.none) + [], dbg) (* Check if a variable occurs in a [clambda] term. *) let occurs_var var u = let rec occurs = function Uvar v -> v = var - | Uconst (cst,_) -> false - | Udirect_apply(lbl, args, _) -> List.exists occurs args + | Uconst _ -> false + | Udirect_apply(_lbl, args, _) -> List.exists occurs args | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args - | Uclosure(fundecls, clos) -> List.exists occurs clos - | Uoffset(u, ofs) -> occurs u - | Ulet(id, def, body) -> occurs def || occurs body + | Uclosure(_fundecls, clos) -> List.exists occurs clos + | Uoffset(u, _ofs) -> occurs u + | Ulet(_str, _kind, _id, def, body) -> occurs def || occurs body | Uletrec(decls, body) -> - List.exists (fun (id, u) -> occurs u) decls || occurs body - | Uprim(p, args, _) -> List.exists occurs args + List.exists (fun (_id, u) -> occurs u) decls || occurs body + | Uprim(_p, args, _) -> List.exists occurs args | Uswitch(arg, s) -> occurs arg || occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks + | Ustringswitch(arg,sw,d) -> + occurs arg || + List.exists (fun (_,e) -> occurs e) sw || + (match d with None -> false | Some d -> occurs d) | Ustaticfail (_, args) -> List.exists occurs args | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr - | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr + | Utrywith(body, _exn, hdlr) -> occurs body || occurs hdlr | Uifthenelse(cond, ifso, ifnot) -> occurs cond || occurs ifso || occurs ifnot | Usequence(u1, u2) -> occurs u1 || occurs u2 | Uwhile(cond, body) -> occurs cond || occurs body - | Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body + | Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body | Uassign(id, u) -> id = var || occurs u | Usend(_, met, obj, args, _) -> occurs met || occurs obj || List.exists occurs args + | Uunreachable -> false and occurs_array a = try for i = 0 to Array.length a - 1 do @@ -86,20 +102,29 @@ let prim_size prim args = match prim with - Pidentity -> 0 - | Pgetglobal id -> 1 - | Psetglobal id -> 1 - | Pmakeblock(tag, mut) -> 5 + List.length args - | Pfield f -> 1 - | Psetfield(f, isptr) -> if isptr then 4 else 1 - | Pfloatfield f -> 1 - | Psetfloatfield f -> 1 + Pidentity | Pbytes_to_string | Pbytes_of_string -> 0 + | Pgetglobal _ -> 1 + | Psetglobal _ -> 1 + | Pmakeblock _ -> 5 + List.length args + | Pfield _ -> 1 + | Psetfield(_f, isptr, init) -> + begin match init with + | Root_initialization -> 1 (* never causes a write barrier hit *) + | Assignment | Heap_initialization -> + match isptr with + | Pointer -> 4 + | Immediate -> 1 + end + | Pfloatfield _ -> 1 + | Psetfloatfield _ -> 1 | Pduprecord _ -> 10 + List.length args | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args - | Praise -> 4 + | Praise _ -> 4 | Pstringlength -> 5 - | Pstringrefs | Pstringsets -> 6 - | Pmakearray kind -> 5 + List.length args + | Pbyteslength -> 5 + | Pstringrefs -> 6 + | Pbytesrefs | Pbytessets -> 6 + | Pmakearray _ -> 5 + List.length args | Parraylength kind -> if kind = Pgenarray then 6 else 2 | Parrayrefu kind -> if kind = Pgenarray then 12 else 2 | Parraysetu kind -> if kind = Pgenarray then 16 else 4 @@ -117,26 +142,19 @@ let rec lambda_size lam = if !size > threshold then raise Exit; match lam with - Uvar v -> () - | Uconst( - (Const_base(Const_int _ | Const_char _ | Const_float _ | - Const_int32 _ | Const_int64 _ | Const_nativeint _) | - Const_pointer _), _) -> incr size -(* Structured Constants are now emitted during closure conversion. *) - | Uconst (_, Some _) -> incr size - | Uconst _ -> - raise Exit (* avoid duplication of structured constants *) - | Udirect_apply(fn, args, _) -> + Uvar _ -> () + | Uconst _ -> incr size + | Udirect_apply(_, args, _) -> size := !size + 4; lambda_list_size args | Ugeneric_apply(fn, args, _) -> size := !size + 6; lambda_size fn; lambda_list_size args - | Uclosure(defs, vars) -> + | Uclosure _ -> raise Exit (* inlining would duplicate function definitions *) - | Uoffset(lam, ofs) -> + | Uoffset(lam, _ofs) -> incr size; lambda_size lam - | Ulet(id, lam, body) -> + | Ulet(_str, _kind, _id, lam, body) -> lambda_size lam; lambda_size body - | Uletrec(bindings, body) -> + | Uletrec _ -> raise Exit (* usually too large *) | Uprim(prim, args, _) -> size := !size + prim_size prim args; @@ -147,10 +165,19 @@ lambda_size lam; lambda_array_size cases.us_actions_consts ; lambda_array_size cases.us_actions_blocks + | Ustringswitch (lam,sw,d) -> + lambda_size lam ; + (* as ifthenelse *) + List.iter + (fun (_,lam) -> + size := !size+2 ; + lambda_size lam) + sw ; + Misc.may lambda_size d | Ustaticfail (_,args) -> lambda_list_size args | Ucatch(_, _, body, handler) -> incr size; lambda_size body; lambda_size handler - | Utrywith(body, id, handler) -> + | Utrywith(body, _id, handler) -> size := !size + 8; lambda_size body; lambda_size handler | Uifthenelse(cond, ifso, ifnot) -> size := !size + 2; @@ -159,13 +186,14 @@ lambda_size lam1; lambda_size lam2 | Uwhile(cond, body) -> size := !size + 2; lambda_size cond; lambda_size body - | Ufor(id, low, high, dir, body) -> + | Ufor(_id, low, high, _dir, body) -> size := !size + 4; lambda_size low; lambda_size high; lambda_size body - | Uassign(id, lam) -> + | Uassign(_id, lam) -> incr size; lambda_size lam | Usend(_, met, obj, args, _) -> size := !size + 8; lambda_size met; lambda_size obj; lambda_list_size args + | Uunreachable -> () and lambda_list_size l = List.iter lambda_size l and lambda_array_size a = Array.iter lambda_size a in try @@ -173,24 +201,31 @@ with Exit -> false +let is_pure_prim p = + let open Semantics_of_primitives in + match Semantics_of_primitives.for_primitive p with + | (No_effects | Only_generative_effects), _ -> true + | Arbitrary_effects, _ -> false + (* Check if a clambda term is ``pure'', that is without side-effects *and* not containing function definitions *) let rec is_pure_clambda = function - Uvar v -> true + Uvar _ -> true | Uconst _ -> true - | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | - Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | - Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false - | Uprim(p, args, _) -> List.for_all is_pure_clambda args + | Uprim(p, args, _) -> is_pure_prim p && List.for_all is_pure_clambda args | _ -> false -(* Simplify primitive operations on integers *) +(* Simplify primitive operations on known arguments *) -let make_const_int n = (Uconst(Const_base(Const_int n), None), Value_integer n) -let make_const_ptr n = (Uconst(Const_pointer n, None), Value_constptr n) +let make_const c = (Uconst c, Value_const c) +let make_const_ref c = + make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, + Some c)) +let make_const_int n = make_const (Uconst_int n) +let make_const_ptr n = make_const (Uconst_ptr n) let make_const_bool b = make_const_ptr(if b then 1 else 0) -let make_comparison cmp (x: int) (y: int) = +let make_comparison cmp x y = make_const_bool (match cmp with Ceq -> x = y @@ -199,75 +234,269 @@ | Cgt -> x > y | Cle -> x <= y | Cge -> x >= y) +let make_const_float n = make_const_ref (Uconst_float n) +let make_const_natint n = make_const_ref (Uconst_nativeint n) +let make_const_int32 n = make_const_ref (Uconst_int32 n) +let make_const_int64 n = make_const_ref (Uconst_int64 n) -let simplif_prim_pure p (args, approxs) dbg = +(* The [fpc] parameter is true if constant propagation of + floating-point computations is allowed *) + +let simplif_arith_prim_pure fpc p (args, approxs) dbg = + let default = (Uprim(p, args, dbg), Value_unknown) in match approxs with - [Value_integer x] -> + (* int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] -> begin match p with - Pidentity -> make_const_int x - | Pnegint -> make_const_int (-x) - | Pbswap16 -> - make_const_int (((x land 0xff) lsl 8) lor - ((x land 0xff00) lsr 8)) - | Poffsetint y -> make_const_int (x + y) - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pnot -> make_const_bool (n1 = 0) + | Pnegint -> make_const_int (- n1) + | Poffsetint n -> make_const_int (n + n1) + | Pfloatofint when fpc -> make_const_float (float_of_int n1) + | Pbintofint Pnativeint -> make_const_natint (Nativeint.of_int n1) + | Pbintofint Pint32 -> make_const_int32 (Int32.of_int n1) + | Pbintofint Pint64 -> make_const_int64 (Int64.of_int n1) + | Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8) + lor ((n1 land 0xff00) lsr 8)) + | _ -> default end - | [Value_integer x; Value_integer y] -> + (* int (or enumerated type), int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1); + Value_const(Uconst_int n2 | Uconst_ptr n2) ] -> begin match p with - Paddint -> make_const_int(x + y) - | Psubint -> make_const_int(x - y) - | Pmulint -> make_const_int(x * y) - | Pdivint when y <> 0 -> make_const_int(x / y) - | Pmodint when y <> 0 -> make_const_int(x mod y) - | Pandint -> make_const_int(x land y) - | Porint -> make_const_int(x lor y) - | Pxorint -> make_const_int(x lxor y) - | Plslint -> make_const_int(x lsl y) - | Plsrint -> make_const_int(x lsr y) - | Pasrint -> make_const_int(x asr y) - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0) + | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0) + | Paddint -> make_const_int (n1 + n2) + | Psubint -> make_const_int (n1 - n2) + | Pmulint -> make_const_int (n1 * n2) + | Pdivint _ when n2 <> 0 -> make_const_int (n1 / n2) + | Pmodint _ when n2 <> 0 -> make_const_int (n1 mod n2) + | Pandint -> make_const_int (n1 land n2) + | Porint -> make_const_int (n1 lor n2) + | Pxorint -> make_const_int (n1 lxor n2) + | Plslint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 lsl n2) + | Plsrint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 lsr n2) + | Pasrint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 asr n2) + | Pintcomp c -> make_comparison c n1 n2 + | _ -> default end - | [Value_constptr x] -> + (* float *) + | [Value_const(Uconst_ref(_, Some (Uconst_float n1)))] when fpc -> begin match p with - Pidentity -> make_const_ptr x - | Pnot -> make_const_bool(x = 0) - | Pisint -> make_const_bool true - | Pctconst c -> - begin - match c with - | Big_endian -> make_const_bool Arch.big_endian - | Word_size -> make_const_int (8*Arch.size_int) - | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") - | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") - | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") - end - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pintoffloat -> make_const_int (int_of_float n1) + | Pnegfloat -> make_const_float (-. n1) + | Pabsfloat -> make_const_float (abs_float n1) + | _ -> default end - | [Value_constptr x; Value_constptr y] -> + (* float, float *) + | [Value_const(Uconst_ref(_, Some (Uconst_float n1))); + Value_const(Uconst_ref(_, Some (Uconst_float n2)))] when fpc -> begin match p with - Psequand -> make_const_bool(x <> 0 && y <> 0) - | Psequor -> make_const_bool(x <> 0 || y <> 0) - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Paddfloat -> make_const_float (n1 +. n2) + | Psubfloat -> make_const_float (n1 -. n2) + | Pmulfloat -> make_const_float (n1 *. n2) + | Pdivfloat -> make_const_float (n1 /. n2) + | Pfloatcomp c -> make_comparison c n1 n2 + | _ -> default end - | [Value_constptr x; Value_integer y] -> + (* nativeint *) + | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n)))] -> begin match p with - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n) + | Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n) + | Pcvtbint(Pnativeint, Pint64) -> make_const_int64 (Int64.of_nativeint n) + | Pnegbint Pnativeint -> make_const_natint (Nativeint.neg n) + | _ -> default + end + (* nativeint, nativeint *) + | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1))); + Value_const(Uconst_ref(_, Some (Uconst_nativeint n2)))] -> + begin match p with + | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2) + | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2) + | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2) + | Pdivbint {size=Pnativeint} when n2 <> 0n -> + make_const_natint (Nativeint.div n1 n2) + | Pmodbint {size=Pnativeint} when n2 <> 0n -> + make_const_natint (Nativeint.rem n1 n2) + | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2) + | Porbint Pnativeint -> make_const_natint (Nativeint.logor n1 n2) + | Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2) + | Pbintcomp(Pnativeint, c) -> make_comparison c n1 n2 + | _ -> default + end + (* nativeint, int *) + | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1))); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_left n1 n2) + | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_right_logical n1 n2) + | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_right n1 n2) + | _ -> default + end + (* int32 *) + | [Value_const(Uconst_ref(_, Some (Uconst_int32 n)))] -> + begin match p with + | Pintofbint Pint32 -> make_const_int (Int32.to_int n) + | Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n) + | Pcvtbint(Pint32, Pint64) -> make_const_int64 (Int64.of_int32 n) + | Pnegbint Pint32 -> make_const_int32 (Int32.neg n) + | _ -> default end - | [Value_integer x; Value_constptr y] -> + (* int32, int32 *) + | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1))); + Value_const(Uconst_ref(_, Some (Uconst_int32 n2)))] -> begin match p with - | Pintcomp cmp -> make_comparison cmp x y + | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2) + | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2) + | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2) + | Pdivbint {size=Pint32} when n2 <> 0l -> + make_const_int32 (Int32.div n1 n2) + | Pmodbint {size=Pint32} when n2 <> 0l -> + make_const_int32 (Int32.rem n1 n2) + | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2) + | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2) + | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2) + | Pbintcomp(Pint32, c) -> make_comparison c n1 n2 + | _ -> default + end + (* int32, int *) + | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1))); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_left n1 n2) + | Plsrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right_logical n1 n2) + | Pasrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right n1 n2) + | _ -> default + end + (* int64 *) + | [Value_const(Uconst_ref(_, Some (Uconst_int64 n)))] -> + begin match p with + | Pintofbint Pint64 -> make_const_int (Int64.to_int n) + | Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n) + | Pcvtbint(Pint64, Pnativeint) -> make_const_natint (Int64.to_nativeint n) + | Pnegbint Pint64 -> make_const_int64 (Int64.neg n) + | _ -> default + end + (* int64, int64 *) + | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1))); + Value_const(Uconst_ref(_, Some (Uconst_int64 n2)))] -> + begin match p with + | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2) + | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2) + | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2) + | Pdivbint {size=Pint64} when n2 <> 0L -> + make_const_int64 (Int64.div n1 n2) + | Pmodbint {size=Pint64} when n2 <> 0L -> + make_const_int64 (Int64.rem n1 n2) + | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2) + | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2) + | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2) + | Pbintcomp(Pint64, c) -> make_comparison c n1 n2 + | _ -> default + end + (* int64, int *) + | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1))); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_left n1 n2) + | Plsrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right_logical n1 n2) + | Pasrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right n1 n2) + | _ -> default + end + (* TODO: Pbbswap *) + (* Catch-all *) + | _ -> + default + +let field_approx n = function + | Value_tuple a when n < Array.length a -> a.(n) + | Value_const (Uconst_ref(_, Some (Uconst_block(_, l)))) + when n < List.length l -> + Value_const (List.nth l n) + | _ -> Value_unknown + +let simplif_prim_pure fpc p (args, approxs) dbg = + match p, args, approxs with + (* Block construction *) + | Pmakeblock(tag, Immutable, _kind), _, _ -> + let field = function + | Value_const c -> c + | _ -> raise Exit + in + begin try + let cst = Uconst_block (tag, List.map field approxs) in + let name = + Compilenv.new_structured_constant cst ~shared:true + in + make_const (Uconst_ref (name, Some cst)) + with Exit -> + (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs)) + end + (* Field access *) + | Pfield n, _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ] + when n < List.length l -> + make_const (List.nth l n) + | Pfield n, [ Uprim(Pmakeblock _, ul, _) ], [approx] + when n < List.length ul -> + (List.nth ul n, field_approx n approx) + (* Strings *) + | (Pstringlength | Pbyteslength), + _, + [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] -> + make_const_int (String.length s) + (* Identity *) + | (Pidentity | Pbytes_to_string | Pbytes_of_string), [arg1], [app1] -> + (arg1, app1) + (* Kind test *) + | Pisint, _, [a1] -> + begin match a1 with + | Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true + | Value_const(Uconst_ref _) -> make_const_bool false + | Value_closure _ | Value_tuple _ -> make_const_bool false | _ -> (Uprim(p, args, dbg), Value_unknown) end + (* Compile-time constants *) + | Pctconst c, _, _ -> + begin match c with + | Big_endian -> make_const_bool Arch.big_endian + | Word_size -> make_const_int (8*Arch.size_int) + | Int_size -> make_const_int (8*Arch.size_int - 1) + | Max_wosize -> make_const_int ((1 lsl ((8*Arch.size_int) - 10)) - 1 ) + | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") + | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") + | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") + | Backend_type -> + make_const_ptr 0 (* tag 0 is the same as Native here *) + end + (* Catch-all *) | _ -> - (Uprim(p, args, dbg), Value_unknown) + simplif_arith_prim_pure fpc p (args, approxs) dbg -let simplif_prim p (args, approxs as args_approxs) dbg = +let simplif_prim fpc p (args, approxs as args_approxs) dbg = if List.for_all is_pure_clambda args - then simplif_prim_pure p args_approxs dbg - else (Uprim(p, args, dbg), Value_unknown) + then simplif_prim_pure fpc p args_approxs dbg + else + (* XXX : always return the same approxs as simplif_prim_pure? *) + let approx = + match p with + | Pmakeblock(_, Immutable, _kind) -> + Value_tuple (Array.of_list approxs) + | _ -> + Value_unknown + in + (Uprim(p, args, dbg), approx) (* Substitute variables in a [ulambda] term (a body of an inlined function) and perform some more simplifications on integer primitives. @@ -279,20 +508,36 @@ over functions. *) let approx_ulam = function - Uconst(Const_base(Const_int n),_) -> Value_integer n - | Uconst(Const_base(Const_char c),_) -> Value_integer(Char.code c) - | Uconst(Const_pointer n,_) -> Value_constptr n + Uconst c -> Value_const c | _ -> Value_unknown -let rec substitute sb ulam = +let find_action idxs acts tag = + if 0 <= tag && tag < Array.length idxs then begin + let idx = idxs.(tag) in + assert(0 <= idx && idx < Array.length acts); + Some acts.(idx) + end else + (* Can this happen? *) + None + +let subst_debuginfo loc dbg = + if !Clflags.debug then + Debuginfo.inline loc dbg + else + dbg + +let rec substitute loc fpc sb ulam = match ulam with Uvar v -> begin try Tbl.find v sb with Not_found -> ulam end | Uconst _ -> ulam | Udirect_apply(lbl, args, dbg) -> - Udirect_apply(lbl, List.map (substitute sb) args, dbg) + let dbg = subst_debuginfo loc dbg in + Udirect_apply(lbl, List.map (substitute loc fpc sb) args, dbg) | Ugeneric_apply(fn, args, dbg) -> - Ugeneric_apply(substitute sb fn, List.map (substitute sb) args, dbg) + let dbg = subst_debuginfo loc dbg in + Ugeneric_apply(substitute loc fpc sb fn, + List.map (substitute loc fpc sb) args, dbg) | Uclosure(defs, env) -> (* Question: should we rename function labels as well? Otherwise, there is a risk that function labels are not globally unique. @@ -302,11 +547,12 @@ - When we substitute offsets for idents bound by let rec in [close], case [Lletrec], we discard the original let rec body and use only the substituted term. *) - Uclosure(defs, List.map (substitute sb) env) - | Uoffset(u, ofs) -> Uoffset(substitute sb u, ofs) - | Ulet(id, u1, u2) -> + Uclosure(defs, List.map (substitute loc fpc sb) env) + | Uoffset(u, ofs) -> Uoffset(substitute loc fpc sb u, ofs) + | Ulet(str, kind, id, u1, u2) -> let id' = Ident.rename id in - Ulet(id', substitute sb u1, substitute (Tbl.add id (Uvar id') sb) u2) + Ulet(str, kind, id', substitute loc fpc sb u1, + substitute loc fpc (Tbl.add id (Uvar id') sb) u2) | Uletrec(bindings, body) -> let bindings1 = List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in @@ -315,109 +561,161 @@ (fun (id, id', _) s -> Tbl.add id (Uvar id') s) bindings1 sb in Uletrec( - List.map (fun (id, id', rhs) -> (id', substitute sb' rhs)) bindings1, - substitute sb' body) + List.map + (fun (_id, id', rhs) -> (id', substitute loc fpc sb' rhs)) + bindings1, + substitute loc fpc sb' body) | Uprim(p, args, dbg) -> - let sargs = List.map (substitute sb) args in - let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) dbg in + let sargs = List.map (substitute loc fpc sb) args in + let dbg = subst_debuginfo loc dbg in + let (res, _) = + simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in res | Uswitch(arg, sw) -> - Uswitch(substitute sb arg, - { sw with - us_actions_consts = - Array.map (substitute sb) sw.us_actions_consts; - us_actions_blocks = - Array.map (substitute sb) sw.us_actions_blocks; - }) + let sarg = substitute loc fpc sb arg in + let action = + (* Unfortunately, we cannot easily deal with the + case of a constructed block (makeblock) bound to a local + identifier. This would require to keep track of + local let bindings (at least their approximations) + in this substitute function. + *) + match sarg with + | Uconst (Uconst_ref (_, Some (Uconst_block (tag, _)))) -> + find_action sw.us_index_blocks sw.us_actions_blocks tag + | Uconst (Uconst_ptr tag) -> + find_action sw.us_index_consts sw.us_actions_consts tag + | _ -> None + in + begin match action with + | Some u -> substitute loc fpc sb u + | None -> + Uswitch(sarg, + { sw with + us_actions_consts = + Array.map (substitute loc fpc sb) sw.us_actions_consts; + us_actions_blocks = + Array.map (substitute loc fpc sb) sw.us_actions_blocks; + }) + end + | Ustringswitch(arg,sw,d) -> + Ustringswitch + (substitute loc fpc sb arg, + List.map (fun (s,act) -> s,substitute loc fpc sb act) sw, + Misc.may_map (substitute loc fpc sb) d) | Ustaticfail (nfail, args) -> - Ustaticfail (nfail, List.map (substitute sb) args) + Ustaticfail (nfail, List.map (substitute loc fpc sb) args) | Ucatch(nfail, ids, u1, u2) -> - Ucatch(nfail, ids, substitute sb u1, substitute sb u2) + let ids' = List.map Ident.rename ids in + let sb' = + List.fold_right2 + (fun id id' s -> Tbl.add id (Uvar id') s) + ids ids' sb + in + Ucatch(nfail, ids', substitute loc fpc sb u1, substitute loc fpc sb' u2) | Utrywith(u1, id, u2) -> let id' = Ident.rename id in - Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2) + Utrywith(substitute loc fpc sb u1, id', + substitute loc fpc (Tbl.add id (Uvar id') sb) u2) | Uifthenelse(u1, u2, u3) -> - begin match substitute sb u1 with - Uconst(Const_pointer n, _) -> - if n <> 0 then substitute sb u2 else substitute sb u3 + begin match substitute loc fpc sb u1 with + Uconst (Uconst_ptr n) -> + if n <> 0 then substitute loc fpc sb u2 else substitute loc fpc sb u3 + | Uprim(Pmakeblock _, _, _) -> + substitute loc fpc sb u2 | su1 -> - Uifthenelse(su1, substitute sb u2, substitute sb u3) + Uifthenelse(su1, substitute loc fpc sb u2, substitute loc fpc sb u3) end - | Usequence(u1, u2) -> Usequence(substitute sb u1, substitute sb u2) - | Uwhile(u1, u2) -> Uwhile(substitute sb u1, substitute sb u2) + | Usequence(u1, u2) -> + Usequence(substitute loc fpc sb u1, substitute loc fpc sb u2) + | Uwhile(u1, u2) -> + Uwhile(substitute loc fpc sb u1, substitute loc fpc sb u2) | Ufor(id, u1, u2, dir, u3) -> let id' = Ident.rename id in - Ufor(id', substitute sb u1, substitute sb u2, dir, - substitute (Tbl.add id (Uvar id') sb) u3) + Ufor(id', substitute loc fpc sb u1, substitute loc fpc sb u2, dir, + substitute loc fpc (Tbl.add id (Uvar id') sb) u3) | Uassign(id, u) -> let id' = try match Tbl.find id sb with Uvar i -> i | _ -> assert false with Not_found -> id in - Uassign(id', substitute sb u) + Uassign(id', substitute loc fpc sb u) | Usend(k, u1, u2, ul, dbg) -> - Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, - dbg) + let dbg = subst_debuginfo loc dbg in + Usend(k, substitute loc fpc sb u1, substitute loc fpc sb u2, + List.map (substitute loc fpc sb) ul, dbg) + | Uunreachable -> + Uunreachable (* Perform an inline expansion *) let is_simple_argument = function - Uvar _ -> true - | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ | - Const_int32 _ | Const_int64 _ | Const_nativeint _),_) -> - true - | Uconst(Const_pointer _, _) -> true + | Uvar _ | Uconst _ -> true | _ -> false let no_effects = function - Uclosure _ -> true - | Uconst(Const_base(Const_string _),_) -> true - | u -> is_simple_argument u + | Uclosure _ -> true + | u -> is_pure_clambda u -let rec bind_params_rec subst params args body = +let rec bind_params_rec loc fpc subst params args body = match (params, args) with - ([], []) -> substitute subst body + ([], []) -> substitute loc fpc subst body | (p1 :: pl, a1 :: al) -> if is_simple_argument a1 then - bind_params_rec (Tbl.add p1 a1 subst) pl al body + bind_params_rec loc fpc (Tbl.add p1 a1 subst) pl al body else begin let p1' = Ident.rename p1 in + let u1, u2 = + match Ident.name p1, a1 with + | "*opt*", Uprim(Pmakeblock(0, Immutable, kind), [a], dbg) -> + a, Uprim(Pmakeblock(0, Immutable, kind), [Uvar p1'], dbg) + | _ -> + a1, Uvar p1' + in let body' = - bind_params_rec (Tbl.add p1 (Uvar p1') subst) pl al body in - if occurs_var p1 body then Ulet(p1', a1, body') + bind_params_rec loc fpc (Tbl.add p1 u2 subst) pl al body in + if occurs_var p1 body then Ulet(Immutable, Pgenval, p1', u1, body') else if no_effects a1 then body' else Usequence(a1, body') end | (_, _) -> assert false -let bind_params params args body = +let bind_params loc fpc params args body = (* Reverse parameters and arguments to preserve right-to-left evaluation order (PR#2910). *) - bind_params_rec Tbl.empty (List.rev params) (List.rev args) body + bind_params_rec loc fpc Tbl.empty (List.rev params) (List.rev args) body (* Check if a lambda term is ``pure'', that is without side-effects *and* not containing function definitions *) let rec is_pure = function - Lvar v -> true - | Lconst cst -> true - | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | - Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | - Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false - | Lprim(p, args) -> List.for_all is_pure args - | Levent(lam, ev) -> is_pure lam + Lvar _ -> true + | Lconst _ -> true + | Lprim(p, args,_) -> is_pure_prim p && List.for_all is_pure args + | Levent(lam, _ev) -> is_pure lam | _ -> false +let warning_if_forced_inline ~loc ~attribute warning = + if attribute = Always_inline then + Location.prerr_warning loc + (Warnings.Inlining_impossible warning) + (* Generate a direct application *) -let direct_apply fundesc funct ufunct uargs = +let direct_apply fundesc funct ufunct uargs ~loc ~attribute = let app_args = if fundesc.fun_closed then uargs else uargs @ [ufunct] in let app = - match fundesc.fun_inline with - None -> Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none) - | Some(params, body) -> bind_params params app_args body in + match fundesc.fun_inline, attribute with + | _, Never_inline | None, _ -> + let dbg = Debuginfo.from_location loc in + warning_if_forced_inline ~loc ~attribute + "Function information unavailable"; + Udirect_apply(fundesc.fun_label, app_args, dbg) + | Some(params, body), _ -> + bind_params loc fundesc.fun_float_const_prop params app_args body + in (* If ufunct can contain side-effects or function definitions, we must make sure that it is evaluated exactly once. If the function is not closed, we evaluate ufunct as part of the @@ -432,7 +730,8 @@ let strengthen_approx appl approx = match approx_ulam appl with - (Value_integer _ | Value_constptr _) as intapprox -> intapprox + (Value_const _) as intapprox -> + intapprox | _ -> approx (* If a term has approximation Value_integer or Value_constptr and is pure, @@ -440,8 +739,16 @@ let check_constant_result lam ulam approx = match approx with - Value_integer n when is_pure lam -> make_const_int n - | Value_constptr n when is_pure lam -> make_const_ptr n + Value_const c when is_pure lam -> make_const c + | Value_global_field (id, i) when is_pure lam -> + begin match ulam with + | Uprim(Pfield _, [Uprim(Pgetglobal _, _, _)], _) -> (ulam, approx) + | _ -> + let glb = + Uprim(Pgetglobal (Ident.create_persistent id), [], Debuginfo.none) + in + Uprim(Pfield i, [glb], Debuginfo.none), approx + end | _ -> (ulam, approx) (* Evaluate an expression with known value for its side effects only, @@ -459,32 +766,6 @@ let function_nesting_depth = ref 0 let excessive_function_nesting_depth = 5 -(* Decorate clambda term with debug information *) - -let rec add_debug_info ev u = - match ev.lev_kind with - | Lev_after _ -> - begin match u with - | Udirect_apply(lbl, args, dinfo) -> - Udirect_apply(lbl, args, Debuginfo.from_call ev) - | Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1), - args2, dinfo2) -> - Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.from_call ev), - args2, Debuginfo.from_call ev) - | Ugeneric_apply(fn, args, dinfo) -> - Ugeneric_apply(fn, args, Debuginfo.from_call ev) - | Uprim(Praise, args, dinfo) -> - Uprim(Praise, args, Debuginfo.from_call ev) - | Uprim(p, args, dinfo) -> - Uprim(p, args, Debuginfo.from_call ev) - | Usend(kind, u1, u2, args, dinfo) -> - Usend(kind, u1, u2, args, Debuginfo.from_call ev) - | Usequence(u1, u2) -> - Usequence(u1, add_debug_info ev u2) - | _ -> u - end - | _ -> u - (* Uncurry an expression and explicitate closures. Also return the approximation of the expression. The approximation environment [fenv] maps idents to approximations. @@ -492,51 +773,76 @@ The closure environment [cenv] maps idents to [ulambda] terms. It is used to substitute environment accesses for free identifiers. *) +exception NotClosed + let close_approx_var fenv cenv id = let approx = try Tbl.find id fenv with Not_found -> Value_unknown in match approx with - Value_integer n -> - make_const_int n - | Value_constptr n -> - make_const_ptr n + Value_const c -> make_const c | approx -> let subst = try Tbl.find id cenv with Not_found -> Uvar id in (subst, approx) let close_var fenv cenv id = - let (ulam, app) = close_approx_var fenv cenv id in ulam + let (ulam, _app) = close_approx_var fenv cenv id in ulam let rec close fenv cenv = function Lvar id -> close_approx_var fenv cenv id | Lconst cst -> - begin match cst with - Const_base(Const_int n) -> (Uconst (cst,None), Value_integer n) - | Const_base(Const_char c) -> (Uconst (cst,None), - Value_integer(Char.code c)) - | Const_pointer n -> (Uconst (cst, None), Value_constptr n) - | _ -> (Uconst (cst, Some (Compilenv.new_structured_constant cst true)), - Value_unknown) - end - | Lfunction(kind, params, body) as funct -> + let str ?(shared = true) cst = + let name = + Compilenv.new_structured_constant cst ~shared + in + Uconst_ref (name, Some cst) + in + let rec transl = function + | Const_base(Const_int n) -> Uconst_int n + | Const_base(Const_char c) -> Uconst_int (Char.code c) + | Const_pointer n -> Uconst_ptr n + | Const_block (tag, fields) -> + str (Uconst_block (tag, List.map transl fields)) + | Const_float_array sl -> + (* constant float arrays are really immutable *) + str (Uconst_float_array (List.map float_of_string sl)) + | Const_immstring s -> + str (Uconst_string s) + | Const_base (Const_string (s, _)) -> + (* Strings (even literal ones) must be assumed to be mutable... + except when OCaml has been configured with + -safe-string. Passing -safe-string at compilation + time is not enough, since the unit could be linked + with another one compiled without -safe-string, and + that one could modify our string literal. *) + str ~shared:Config.safe_string (Uconst_string s) + | Const_base(Const_float x) -> str (Uconst_float (float_of_string x)) + | Const_base(Const_int32 x) -> str (Uconst_int32 x) + | Const_base(Const_int64 x) -> str (Uconst_int64 x) + | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) + in + make_const (transl cst) + | Lfunction _ as funct -> close_one_function fenv cenv (Ident.create "fun") funct - (* We convert [f a] to [let a' = a in fun b c -> f a' b c] + (* We convert [f a] to [let a' = a in let f' = f in fun b c -> f' a' b c] when fun_arity > nargs *) - | Lapply(funct, args, loc) -> + | Lapply{ap_func = funct; ap_args = args; ap_loc = loc; + ap_inlined = attribute} -> let nargs = List.length args in begin match (close fenv cenv funct, close_list fenv cenv args) with ((ufunct, Value_closure(fundesc, approx_res)), - [Uprim(Pmakeblock(_, _), uargs, _)]) + [Uprim(Pmakeblock _, uargs, _)]) when List.length uargs = - fundesc.fun_arity -> - let app = direct_apply fundesc funct ufunct uargs in + let app = + direct_apply ~loc ~attribute fundesc funct ufunct uargs in (app, strengthen_approx app approx_res) | ((ufunct, Value_closure(fundesc, approx_res)), uargs) when nargs = fundesc.fun_arity -> - let app = direct_apply fundesc funct ufunct uargs in + let app = + direct_apply ~loc ~attribute fundesc funct ufunct uargs in (app, strengthen_approx app approx_res) - | ((ufunct, Value_closure(fundesc, approx_res)), uargs) + | ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs) when nargs < fundesc.fun_arity -> let first_args = List.map (fun arg -> (Ident.create "arg", arg) ) uargs in @@ -548,49 +854,81 @@ [] -> body | (arg1, arg2) :: args -> iter args - (Ulet ( arg1, arg2, body)) + (Ulet (Immutable, Pgenval, arg1, arg2, body)) in let internal_args = - (List.map (fun (arg1, arg2) -> Lvar arg1) first_args) + (List.map (fun (arg1, _arg2) -> Lvar arg1) first_args) @ (List.map (fun arg -> Lvar arg ) final_args) in + let funct_var = Ident.create "funct" in + let fenv = Tbl.add funct_var fapprox fenv in let (new_fun, approx) = close fenv cenv - (Lfunction( - Curried, final_args, Lapply(funct, internal_args, loc))) + (Lfunction{ + kind = Curried; + params = final_args; + body = Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=(Lvar funct_var); + ap_args=internal_args; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}; + loc; + attr = default_function_attribute}) in - let new_fun = iter first_args new_fun in + let new_fun = + iter first_args + (Ulet (Immutable, Pgenval, funct_var, ufunct, new_fun)) + in + warning_if_forced_inline ~loc ~attribute "Partial application"; (new_fun, approx) - | ((ufunct, Value_closure(fundesc, approx_res)), uargs) + | ((ufunct, Value_closure(fundesc, _approx_res)), uargs) when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> - let (first_args, rem_args) = split_list fundesc.fun_arity uargs in - (Ugeneric_apply(direct_apply fundesc funct ufunct first_args, - rem_args, Debuginfo.none), - Value_unknown) + let args = List.map (fun arg -> Ident.create "arg", arg) uargs in + let (first_args, rem_args) = split_list fundesc.fun_arity args in + let first_args = List.map (fun (id, _) -> Uvar id) first_args in + let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in + let dbg = Debuginfo.from_location loc in + warning_if_forced_inline ~loc ~attribute "Over-application"; + let body = + Ugeneric_apply(direct_apply ~loc ~attribute + fundesc funct ufunct first_args, + rem_args, dbg) + in + let result = + List.fold_left (fun body (id, defining_expr) -> + Ulet (Immutable, Pgenval, id, defining_expr, body)) + body + args + in + result, Value_unknown | ((ufunct, _), uargs) -> - (Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown) + let dbg = Debuginfo.from_location loc in + warning_if_forced_inline ~loc ~attribute "Unknown function"; + (Ugeneric_apply(ufunct, uargs, dbg), Value_unknown) end - | Lsend(kind, met, obj, args, _) -> + | Lsend(kind, met, obj, args, loc) -> let (umet, _) = close fenv cenv met in let (uobj, _) = close fenv cenv obj in - (Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none), + let dbg = Debuginfo.from_location loc in + (Usend(kind, umet, uobj, close_list fenv cenv args, dbg), Value_unknown) - | Llet(str, id, lam, body) -> + | Llet(str, kind, id, lam, body) -> let (ulam, alam) = close_named fenv cenv id lam in begin match (str, alam) with (Variable, _) -> let (ubody, abody) = close fenv cenv body in - (Ulet(id, ulam, ubody), abody) - | (_, (Value_integer _ | Value_constptr _)) + (Ulet(Mutable, kind, id, ulam, ubody), abody) + | (_, Value_const _) when str = Alias || is_pure lam -> close (Tbl.add id alam fenv) cenv body | (_, _) -> let (ubody, abody) = close (Tbl.add id alam fenv) cenv body in - (Ulet(id, ulam, ubody), abody) + (Ulet(Immutable, kind, id, ulam, ubody), abody) end | Lletrec(defs, body) -> if List.for_all - (function (id, Lfunction(_, _, _)) -> true | _ -> false) + (function (_id, Lfunction _) -> true | _ -> false) defs then begin (* Simple case: only function definitions *) @@ -598,15 +936,16 @@ let clos_ident = Ident.create "clos" in let fenv_body = List.fold_right - (fun (id, pos, approx) fenv -> Tbl.add id approx fenv) + (fun (id, _pos, approx) fenv -> Tbl.add id approx fenv) infos fenv in let (ubody, approx) = close fenv_body cenv body in let sb = List.fold_right - (fun (id, pos, approx) sb -> + (fun (id, pos, _approx) sb -> Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb) infos Tbl.empty in - (Ulet(clos_ident, clos, substitute sb ubody), + (Ulet(Immutable, Pgenval, clos_ident, clos, + substitute Location.none !Clflags.float_const_prop sb ubody), approx) end else begin (* General case: recursive definition of values *) @@ -614,58 +953,90 @@ [] -> ([], fenv) | (id, lam) :: rem -> let (udefs, fenv_body) = clos_defs rem in - let (ulam, approx) = close fenv cenv lam in + let (ulam, approx) = close_named fenv cenv id lam in ((id, ulam) :: udefs, Tbl.add id approx fenv_body) in let (udefs, fenv_body) = clos_defs defs in let (ubody, approx) = close fenv_body cenv body in (Uletrec(udefs, ubody), approx) end - | Lprim(Pdirapply loc,[funct;arg]) - | Lprim(Prevapply loc,[arg;funct]) -> - close fenv cenv (Lapply(funct, [arg], loc)) - | Lprim(Pgetglobal id, []) as lam -> + | Lprim(Pdirapply,[funct;arg], loc) + | Lprim(Prevapply,[arg;funct], loc) -> + close fenv cenv (Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=funct; + ap_args=[arg]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}) + | Lprim(Pgetglobal id, [], loc) as lam -> + let dbg = Debuginfo.from_location loc in check_constant_result lam - (getglobal id) + (getglobal dbg id) (Compilenv.global_approx id) - | Lprim(Pmakeblock(tag, mut) as prim, lams) -> - let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in - (Uprim(prim, ulams, Debuginfo.none), - begin match mut with - Immutable -> Value_tuple(Array.of_list approxs) - | Mutable -> Value_unknown - end) - | Lprim(Pfield n, [lam]) -> + | Lprim(Pfield n, [lam], loc) -> let (ulam, approx) = close fenv cenv lam in - let fieldapprox = - match approx with - Value_tuple a when n < Array.length a -> a.(n) - | _ -> Value_unknown in - check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) - fieldapprox - | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) -> + let dbg = Debuginfo.from_location loc in + check_constant_result lam (Uprim(Pfield n, [ulam], dbg)) + (field_approx n approx) + | Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)-> let (ulam, approx) = close fenv cenv lam in - (!global_approx).(n) <- approx; - (Uprim(Psetfield(n, false), [getglobal id; ulam], Debuginfo.none), + if approx <> Value_unknown then + (!global_approx).(n) <- approx; + let dbg = Debuginfo.from_location loc in + (Uprim(Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg), Value_unknown) - | Lprim(Praise, [Levent(arg, ev)]) -> - let (ulam, approx) = close fenv cenv arg in - (Uprim(Praise, [ulam], Debuginfo.from_raise ev), + | Lprim(Praise k, [arg], loc) -> + let (ulam, _approx) = close fenv cenv arg in + let dbg = Debuginfo.from_location loc in + (Uprim(Praise k, [ulam], dbg), Value_unknown) - | Lprim(p, args) -> - simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none + | Lprim(p, args, loc) -> + let dbg = Debuginfo.from_location loc in + simplif_prim !Clflags.float_const_prop + p (close_list_approx fenv cenv args) dbg | Lswitch(arg, sw) -> + let fn fail = + let (uarg, _) = close fenv cenv arg in + let const_index, const_actions, fconst = + close_switch fenv cenv sw.sw_consts sw.sw_numconsts fail + and block_index, block_actions, fblock = + close_switch fenv cenv sw.sw_blocks sw.sw_numblocks fail in + let ulam = + Uswitch + (uarg, + {us_index_consts = const_index; + us_actions_consts = const_actions; + us_index_blocks = block_index; + us_actions_blocks = block_actions}) in + (fconst (fblock ulam),Value_unknown) in (* NB: failaction might get copied, thus it should be some Lstaticraise *) - let (uarg, _) = close fenv cenv arg in - let const_index, const_actions = - close_switch fenv cenv sw.sw_consts sw.sw_numconsts sw.sw_failaction - and block_index, block_actions = - close_switch fenv cenv sw.sw_blocks sw.sw_numblocks sw.sw_failaction in - (Uswitch(uarg, - {us_index_consts = const_index; - us_actions_consts = const_actions; - us_index_blocks = block_index; - us_actions_blocks = block_actions}), - Value_unknown) + let fail = sw.sw_failaction in + begin match fail with + | None|Some (Lstaticraise (_,_)) -> fn fail + | Some lamfail -> + if + (sw.sw_numconsts - List.length sw.sw_consts) + + (sw.sw_numblocks - List.length sw.sw_blocks) > 1 + then + let i = next_raise_count () in + let ubody,_ = fn (Some (Lstaticraise (i,[]))) + and uhandler,_ = close fenv cenv lamfail in + Ucatch (i,[],ubody,uhandler),Value_unknown + else fn fail + end + | Lstringswitch(arg,sw,d,_) -> + let uarg,_ = close fenv cenv arg in + let usw = + List.map + (fun (s,act) -> + let uact,_ = close fenv cenv act in + s,uact) + sw in + let ud = + Misc.may_map + (fun d -> + let ud,_ = close fenv cenv d in + ud) d in + Ustringswitch (uarg,usw,ud),Value_unknown | Lstaticraise (i, args) -> (Ustaticfail (i, close_list fenv cenv args), Value_unknown) | Lstaticcatch(body, (i, vars), handler) -> @@ -678,7 +1049,7 @@ (Utrywith(ubody, id, uhandler), Value_unknown) | Lifthenelse(arg, ifso, ifnot) -> begin match close fenv cenv arg with - (uarg, Value_constptr n) -> + (uarg, Value_const (Uconst_ptr n)) -> sequence_constant_expr arg uarg (close fenv cenv (if n = 0 then ifnot else ifso)) | (uarg, _ ) -> @@ -702,9 +1073,8 @@ | Lassign(id, lam) -> let (ulam, _) = close fenv cenv lam in (Uassign(id, ulam), Value_unknown) - | Levent(lam, ev) -> - let (ulam, approx) = close fenv cenv lam in - (add_debug_info ev ulam, approx) + | Levent(lam, _) -> + close fenv cenv lam | Lifused _ -> assert false @@ -722,7 +1092,7 @@ (ulam :: ulams, approx :: approxs) and close_named fenv cenv id = function - Lfunction(kind, params, body) as funct -> + Lfunction _ as funct -> close_one_function fenv cenv id funct | lam -> close fenv cenv lam @@ -730,6 +1100,21 @@ (* Build a shared closure for a set of mutually recursive functions *) and close_functions fenv cenv fun_defs = + let fun_defs = + List.flatten + (List.map + (function + | (id, Lfunction{kind; params; body; attr; loc}) -> + Simplif.split_default_wrapper ~id ~kind ~params + ~body ~attr ~loc + | _ -> assert false + ) + fun_defs) + in + let inline_attribute = match fun_defs with + | [_, Lfunction{attr = { inline; }}] -> inline + | _ -> Default_inline (* recursive functions can't be inlined *) + in (* Update and check nesting depth *) incr function_nesting_depth; let initially_closed = @@ -743,28 +1128,30 @@ let uncurried_defs = List.map (function - (id, Lfunction(kind, params, body)) -> + (id, Lfunction{kind; params; body; loc}) -> let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in let arity = List.length params in let fundesc = {fun_label = label; fun_arity = (if kind = Tupled then -arity else arity); fun_closed = initially_closed; - fun_inline = None } in - (id, params, body, fundesc) + fun_inline = None; + fun_float_const_prop = !Clflags.float_const_prop } in + let dbg = Debuginfo.from_location loc in + (id, params, body, fundesc, dbg) | (_, _) -> fatal_error "Closure.close_functions") fun_defs in (* Build an approximate fenv for compiling the functions *) let fenv_rec = List.fold_right - (fun (id, params, body, fundesc) fenv -> + (fun (id, _params, _body, fundesc, _dbg) fenv -> Tbl.add id (Value_closure(fundesc, Value_unknown)) fenv) uncurried_defs fenv in (* Determine the offsets of each function's closure in the shared block *) let env_pos = ref (-1) in let clos_offsets = List.map - (fun (id, params, body, fundesc) -> + (fun (_id, _params, _body, fundesc, _dbg) -> let pos = !env_pos + 1 in env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2); pos) @@ -774,40 +1161,70 @@ does not use its environment parameter is invalidated. *) let useless_env = ref initially_closed in (* Translate each function definition *) - let clos_fundef (id, params, body, fundesc) env_pos = - let dbg = match body with - | Levent (_,({lev_kind=Lev_function} as ev)) -> Debuginfo.from_call ev - | _ -> Debuginfo.none in + let clos_fundef (id, params, body, fundesc, dbg) env_pos = let env_param = Ident.create "env" in let cenv_fv = build_closure_env env_param (fv_pos - env_pos) fv in let cenv_body = List.fold_right2 - (fun (id, params, arity, body) pos env -> + (fun (id, _params, _body, _fundesc, _dbg) pos env -> Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env) uncurried_defs clos_offsets cenv_fv in let (ubody, approx) = close fenv_rec cenv_body body in - if !useless_env && occurs_var env_param ubody then useless_env := false; + if !useless_env && occurs_var env_param ubody then raise NotClosed; let fun_params = if !useless_env then params else params @ [env_param] in - ({ label = fundesc.fun_label; - arity = fundesc.fun_arity; - params = fun_params; - body = ubody; - dbg }, - (id, env_pos, Value_closure(fundesc, approx))) in + let f = + { + label = fundesc.fun_label; + arity = fundesc.fun_arity; + params = fun_params; + body = ubody; + dbg; + env = Some env_param; + } + in + (* give more chance of function with default parameters (i.e. + their wrapper functions) to be inlined *) + let n = + List.fold_left + (fun n id -> n + if Ident.name id = "*opt*" then 8 else 1) + 0 + fun_params + in + let threshold = + match inline_attribute with + | Default_inline -> + let inline_threshold = + Clflags.Float_arg_helper.get ~key:0 !Clflags.inline_threshold + in + let magic_scale_constant = 8. in + int_of_float (inline_threshold *. magic_scale_constant) + n + | Always_inline -> max_int + | Never_inline -> min_int + | Unroll _ -> assert false + in + if lambda_smaller ubody threshold + then fundesc.fun_inline <- Some(fun_params, ubody); + + (f, (id, env_pos, Value_closure(fundesc, approx))) in (* Translate all function definitions. *) let clos_info_list = if initially_closed then begin - let cl = List.map2 clos_fundef uncurried_defs clos_offsets in + let snap = Compilenv.snapshot () in + try List.map2 clos_fundef uncurried_defs clos_offsets + with NotClosed -> (* If the hypothesis that the environment parameters are useless has been invalidated, then set [fun_closed] to false in all descriptions and recompile *) - if !useless_env then cl else begin + Compilenv.backtrack snap; (* PR#6337 *) List.iter - (fun (id, params, body, fundesc) -> fundesc.fun_closed <- false) + (fun (_id, _params, _body, fundesc, _dbg) -> + fundesc.fun_closed <- false; + fundesc.fun_inline <- None; + ) uncurried_defs; + useless_env := false; List.map2 clos_fundef uncurried_defs clos_offsets - end end else (* Excessive closure nesting: assume environment parameter is used *) List.map2 clos_fundef uncurried_defs clos_offsets @@ -817,31 +1234,27 @@ (* Return the Uclosure node and the list of all identifiers defined, with offsets and approximations. *) let (clos, infos) = List.split clos_info_list in + let fv = if !useless_env then [] else fv in (Uclosure(clos, List.map (close_var fenv cenv) fv), infos) (* Same, for one non-recursive function *) and close_one_function fenv cenv id funct = match close_functions fenv cenv [id, funct] with - ((Uclosure([f], _) as clos), - [_, _, (Value_closure(fundesc, _) as approx)]) -> - (* See if the function can be inlined *) - if lambda_smaller f.body - (!Clflags.inline_threshold + List.length f.params) - then fundesc.fun_inline <- Some(f.params, f.body); - (clos, approx) - | _ -> fatal_error "Closure.close_one_function" + | (clos, (i, _, approx) :: _) when id = i -> (clos, approx) + | _ -> fatal_error "Closure.close_one_function" (* Close a switch *) and close_switch fenv cenv cases num_keys default = - let index = Array.create num_keys 0 - and store = mk_store Lambda.same in + let ncases = List.length cases in + let index = Array.make num_keys 0 + and store = Storer.mk_store () in (* First default case *) begin match default with - | Some def when List.length cases < num_keys -> - ignore (store.act_store def) + | Some def when ncases < num_keys -> + assert (store.act_store def = 0) | _ -> () end ; (* Then all other cases *) @@ -849,24 +1262,115 @@ (fun (key,lam) -> index.(key) <- store.act_store lam) cases ; - (* Compile action *) + + (* Explicit sharing with catch/exit, as switcher compilation may + later unshare *) + let acts = store.act_get_shared () in + let hs = ref (fun e -> e) in + + (* Compile actions *) let actions = Array.map - (fun lam -> - let ulam,_ = close fenv cenv lam in - ulam) - (store.act_get ()) in + (function + | Single lam|Shared (Lstaticraise (_,[]) as lam) -> + let ulam,_ = close fenv cenv lam in + ulam + | Shared lam -> + let ulam,_ = close fenv cenv lam in + let i = next_raise_count () in +(* + let string_of_lambda e = + Printlambda.lambda Format.str_formatter e ; + Format.flush_str_formatter () in + Printf.eprintf "SHARE CLOSURE %i [%s]\n%s\n" i + (string_of_lambda arg) + (string_of_lambda lam) ; +*) + let ohs = !hs in + hs := (fun e -> Ucatch (i,[],ohs e,ulam)) ; + Ustaticfail (i,[])) + acts in match actions with - | [| |] -> [| |], [| |] (* May happen when default is None *) - | _ -> index, actions + | [| |] -> [| |], [| |], !hs (* May happen when default is None *) + | _ -> index, actions, !hs +(* Collect exported symbols for structured constants *) + +let collect_exported_structured_constants a = + let rec approx = function + | Value_closure (fd, a) -> + approx a; + begin match fd.fun_inline with + | Some (_, u) -> ulam u + | None -> () + end + | Value_tuple a -> Array.iter approx a + | Value_const c -> const c + | Value_unknown | Value_global_field _ -> () + and const = function + | Uconst_ref (s, (Some c)) -> + Compilenv.add_exported_constant s; + structured_constant c + | Uconst_ref (_s, None) -> assert false (* Cannot be generated *) + | Uconst_int _ | Uconst_ptr _ -> () + and structured_constant = function + | Uconst_block (_, ul) -> List.iter const ul + | Uconst_float _ | Uconst_int32 _ + | Uconst_int64 _ | Uconst_nativeint _ + | Uconst_float_array _ | Uconst_string _ -> () + | Uconst_closure _ -> assert false (* Cannot be generated *) + and ulam = function + | Uvar _ -> () + | Uconst c -> const c + | Udirect_apply (_, ul, _) -> List.iter ulam ul + | Ugeneric_apply (u, ul, _) -> ulam u; List.iter ulam ul + | Uclosure (fl, ul) -> + List.iter (fun f -> ulam f.body) fl; + List.iter ulam ul + | Uoffset(u, _) -> ulam u + | Ulet (_str, _kind, _, u1, u2) -> ulam u1; ulam u2 + | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u + | Uprim (_, ul, _) -> List.iter ulam ul + | Uswitch (u, sl) -> + ulam u; + Array.iter ulam sl.us_actions_consts; + Array.iter ulam sl.us_actions_blocks + | Ustringswitch (u,sw,d) -> + ulam u ; + List.iter (fun (_,act) -> ulam act) sw ; + Misc.may ulam d + | Ustaticfail (_, ul) -> List.iter ulam ul + | Ucatch (_, _, u1, u2) + | Utrywith (u1, _, u2) + | Usequence (u1, u2) + | Uwhile (u1, u2) -> ulam u1; ulam u2 + | Uifthenelse (u1, u2, u3) + | Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3 + | Uassign (_, u) -> ulam u + | Usend (_, u1, u2, ul, _) -> ulam u1; ulam u2; List.iter ulam ul + | Uunreachable -> () + in + approx a + +let reset () = + global_approx := [||]; + function_nesting_depth := 0 + (* The entry point *) let intro size lam = - function_nesting_depth := 0; - global_approx := Array.create size Value_unknown; + reset (); + let id = Compilenv.make_symbol None in + global_approx := Array.init size (fun i -> Value_global_field (id, i)); Compilenv.set_global_approx(Value_tuple !global_approx); - let (ulam, approx) = close Tbl.empty Tbl.empty lam in + let (ulam, _approx) = close Tbl.empty Tbl.empty lam in + let opaque = + !Clflags.opaque + || Env.is_imported_opaque (Compilenv.current_unit_name ()) + in + if opaque + then Compilenv.set_global_approx(Value_unknown) + else collect_exported_structured_constants (Value_tuple !global_approx); global_approx := [||]; ulam diff -Nru ocaml-4.01.0/asmcomp/closure.mli ocaml-4.05.0/asmcomp/closure.mli --- ocaml-4.01.0/asmcomp/closure.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/closure.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,19 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Introduction of closures, uncurrying, recognition of direct calls *) val intro: int -> Lambda.lambda -> Clambda.ulambda +val reset : unit -> unit diff -Nru ocaml-4.01.0/asmcomp/closure_offsets.ml ocaml-4.05.0/asmcomp/closure_offsets.ml --- ocaml-4.01.0/asmcomp/closure_offsets.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/closure_offsets.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,138 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +type result = { + function_offsets : int Closure_id.Map.t; + free_variable_offsets : int Var_within_closure.Map.t; +} + +let add_closure_offsets + { function_offsets; free_variable_offsets } + ({ function_decls; free_vars } : Flambda.set_of_closures) = + (* Build the table mapping the functions declared by the set of closures + to the positions of their individual "infix" closures inside the runtime + closure block. (All of the environment entries will come afterwards.) *) + let assign_function_offset id function_decl (map, env_pos) = + let pos = env_pos + 1 in + let env_pos = + let arity = Flambda_utils.function_arity function_decl in + env_pos + + 1 (* GC header; either [Closure_tag] or [Infix_tag] *) + + 1 (* full application code pointer *) + + 1 (* arity *) + + (if arity > 1 then 1 else 0) (* partial application code pointer *) + in + let closure_id = Closure_id.wrap id in + if Closure_id.Map.mem closure_id map then begin + Misc.fatal_errorf "Closure_offsets.add_closure_offsets: function \ + offset for %a would be defined multiple times" + Closure_id.print closure_id + end; + let map = Closure_id.Map.add closure_id pos map in + (map, env_pos) + in + let function_offsets, free_variable_pos = + Variable.Map.fold assign_function_offset + function_decls.funs (function_offsets, -1) + in + (* Adds the mapping of free variables to their offset. Recall that + projections of [Var_within_closure]s are only currently used when + compiling accesses to the closure of a function from outside that + function (in particular, as a result of inlining). Accesses to + a function's own closure are compiled directly via normal [Var] + accesses. *) + (* CR-someday mshinwell: As discussed with lwhite, maybe this isn't + ideal, and the self accesses should be explicitly marked too. *) + let assign_free_variable_offset var _ (map, pos) = + let var_within_closure = Var_within_closure.wrap var in + if Var_within_closure.Map.mem var_within_closure map then begin + Misc.fatal_errorf "Closure_offsets.add_closure_offsets: free variable \ + offset for %a would be defined multiple times" + Var_within_closure.print var_within_closure + end; + let map = Var_within_closure.Map.add var_within_closure pos map in + (map, pos + 1) + in + let free_variable_offsets, _ = + Variable.Map.fold assign_free_variable_offset + free_vars (free_variable_offsets, free_variable_pos) + in + { function_offsets; + free_variable_offsets; + } + +let compute (program:Flambda.program) = + let init : result = + { function_offsets = Closure_id.Map.empty; + free_variable_offsets = Var_within_closure.Map.empty; + } + in + let r = + List.fold_left add_closure_offsets + init (Flambda_utils.all_sets_of_closures program) + in + r + +let compute_reexported_offsets program + ~current_unit_offset_fun ~current_unit_offset_fv + ~imported_units_offset_fun ~imported_units_offset_fv = + let offset_fun = ref current_unit_offset_fun in + let offset_fv = ref current_unit_offset_fv in + let used_closure_id closure_id = + match Closure_id.Map.find closure_id imported_units_offset_fun with + | offset -> + assert (not (Closure_id.Map.mem closure_id current_unit_offset_fun)); + begin match Closure_id.Map.find closure_id !offset_fun with + | exception Not_found -> + offset_fun := Closure_id.Map.add closure_id offset !offset_fun + | offset' -> assert (offset = offset') + end + | exception Not_found -> + assert (Closure_id.Map.mem closure_id current_unit_offset_fun) + in + let used_var_within_closure var = + match Var_within_closure.Map.find var imported_units_offset_fv with + | offset -> + assert (not (Var_within_closure.Map.mem var current_unit_offset_fv)); + begin match Var_within_closure.Map.find var !offset_fv with + | exception Not_found -> + offset_fv := Var_within_closure.Map.add var offset !offset_fv + | offset' -> assert (offset = offset') + end + | exception Not_found -> + assert (Var_within_closure.Map.mem var current_unit_offset_fv) + in + Flambda_iterators.iter_named_of_program program + ~f:(fun (named : Flambda.named) -> + match named with + | Project_closure { closure_id; _ } -> + used_closure_id closure_id + | Move_within_set_of_closures { start_from; move_to; _ } -> + used_closure_id start_from; + used_closure_id move_to + | Project_var { closure_id; var; _ } -> + used_closure_id closure_id; + used_var_within_closure var + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ | Set_of_closures _ | Prim _ | Expr _ -> ()); + Flambda_iterators.iter_constant_defining_values_on_program program + ~f:(fun (const : Flambda.constant_defining_value) -> + match const with + | Project_closure (_, closure_id) -> used_closure_id closure_id + | Allocated_const _ | Block _ | Set_of_closures _ -> ()); + !offset_fun, !offset_fv diff -Nru ocaml-4.01.0/asmcomp/closure_offsets.mli ocaml-4.05.0/asmcomp/closure_offsets.mli --- ocaml-4.01.0/asmcomp/closure_offsets.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/closure_offsets.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,44 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Assign numerical offsets, within closure blocks, for code pointers and + environment entries. *) + +type result = private { + function_offsets : int Closure_id.Map.t; + free_variable_offsets : int Var_within_closure.Map.t; +} + +val compute : Flambda.program -> result + +(** If compilation unit [C] references [B], which contains functions inlined + from another compilation unit [A], then we may need to know the layout of + closures inside (or constructed by code inside) a.cmx in order to + compile c.cmx. Unfortunately a.cmx is permitted to be absent during such + compilation; c.cmx will be compiled using just b.cmx. As such, when + building the .cmx export information for a given compilation unit, we + also include information about the layout of any closures that it depends + on from other compilation units. This means that when situations as just + describe arise, we always have access to the necessary closure offsets. *) +val compute_reexported_offsets + : Flambda.program + -> current_unit_offset_fun:int Closure_id.Map.t + -> current_unit_offset_fv:int Var_within_closure.Map.t + -> imported_units_offset_fun:int Closure_id.Map.t + -> imported_units_offset_fv:int Var_within_closure.Map.t + -> int Closure_id.Map.t * int Var_within_closure.Map.t diff -Nru ocaml-4.01.0/asmcomp/cmmgen.ml ocaml-4.05.0/asmcomp/cmmgen.ml --- ocaml-4.01.0/asmcomp/cmmgen.ml 2013-05-22 13:59:24.000000000 +0000 +++ ocaml-4.05.0/asmcomp/cmmgen.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Translation from closed lambda to C-- *) @@ -22,47 +25,95 @@ open Cmm open Cmx_format +(* Environments used for translation to Cmm. *) + +type boxed_number = + | Boxed_float of Debuginfo.t + | Boxed_integer of boxed_integer * Debuginfo.t + +type env = { + unboxed_ids : (Ident.t * boxed_number) Ident.tbl; + environment_param : Ident.t option; +} + +let empty_env = + { + unboxed_ids =Ident.empty; + environment_param = None; + } + +let create_env ~environment_param = + { unboxed_ids = Ident.empty; + environment_param; + } + +let is_unboxed_id id env = + try Some (Ident.find_same id env.unboxed_ids) + with Not_found -> None + +let add_unboxed_id id unboxed_id bn env = + { env with + unboxed_ids = Ident.add id (unboxed_id, bn) env.unboxed_ids; + } + (* Local binding of complex expressions *) let bind name arg fn = match arg with Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ - | Cconst_pointer _ | Cconst_natpointer _ -> fn arg + | Cconst_pointer _ | Cconst_natpointer _ + | Cblockheader _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) +let bind_load name arg fn = + match arg with + | Cop(Cload _, [Cvar _], _) -> fn arg + | _ -> bind name arg fn + let bind_nonvar name arg fn = match arg with Cconst_int _ | Cconst_natint _ | Cconst_symbol _ - | Cconst_pointer _ | Cconst_natpointer _ -> fn arg + | Cconst_pointer _ | Cconst_natpointer _ + | Cblockheader _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) +let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8 + (* cf. byterun/gc.h *) + (* Block headers. Meaning of the tag field: see stdlib/obj.ml *) -let float_tag = Cconst_int Obj.double_tag let floatarray_tag = Cconst_int Obj.double_array_tag let block_header tag sz = Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10) (Nativeint.of_int tag) -let closure_header sz = block_header Obj.closure_tag sz +(* Static data corresponding to "value"s must be marked black in case we are + in no-naked-pointers mode. See [caml_darken] and the code below that emits + structured constants and static module definitions. *) +let black_block_header tag sz = Nativeint.logor (block_header tag sz) caml_black +let white_closure_header sz = block_header Obj.closure_tag sz +let black_closure_header sz = black_block_header Obj.closure_tag sz let infix_header ofs = block_header Obj.infix_tag ofs let float_header = block_header Obj.double_tag (size_float / size_addr) let floatarray_header len = - block_header Obj.double_array_tag (len * size_float / size_addr) + (* Zero-sized float arrays have tag zero for consistency with + [caml_alloc_float_array]. *) + assert (len >= 0); + if len = 0 then block_header 0 0 + else block_header Obj.double_array_tag (len * size_float / size_addr) let string_header len = block_header Obj.string_tag ((len + size_addr) / size_addr) let boxedint32_header = block_header Obj.custom_tag 2 let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr) let boxedintnat_header = block_header Obj.custom_tag 2 -let alloc_block_header tag sz = Cconst_natint(block_header tag sz) -let alloc_float_header = Cconst_natint(float_header) -let alloc_floatarray_header len = Cconst_natint(floatarray_header len) -let alloc_closure_header sz = Cconst_natint(closure_header sz) -let alloc_infix_header ofs = Cconst_natint(infix_header ofs) -let alloc_boxedint32_header = Cconst_natint(boxedint32_header) -let alloc_boxedint64_header = Cconst_natint(boxedint64_header) -let alloc_boxedintnat_header = Cconst_natint(boxedintnat_header) +let alloc_float_header dbg = Cblockheader (float_header, dbg) +let alloc_floatarray_header len dbg = Cblockheader (floatarray_header len, dbg) +let alloc_closure_header sz dbg = Cblockheader (white_closure_header sz, dbg) +let alloc_infix_header ofs dbg = Cblockheader (infix_header ofs, dbg) +let alloc_boxedint32_header dbg = Cblockheader (boxedint32_header, dbg) +let alloc_boxedint64_header dbg = Cblockheader (boxedint64_header, dbg) +let alloc_boxedintnat_header dbg = Cblockheader (boxedintnat_header, dbg) (* Integers *) @@ -75,183 +126,400 @@ else Cconst_natint (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) -let add_const c n = +let cint_const n = + Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) + +let add_no_overflow n x c dbg = + let d = n + x in + if d = 0 then c else Cop(Caddi, [c; Cconst_int d], dbg) + +let rec add_const c n dbg = if n = 0 then c else match c with | Cconst_int x when no_overflow_add x n -> Cconst_int (x + n) - | c -> Cop(Caddi, [c; Cconst_int n]) + | Cop(Caddi, [Cconst_int x; c], _) + when no_overflow_add n x -> + add_no_overflow n x c dbg + | Cop(Caddi, [c; Cconst_int x], _) + when no_overflow_add n x -> + add_no_overflow n x c dbg + | Cop(Csubi, [Cconst_int x; c], _) when no_overflow_add n x -> + Cop(Csubi, [Cconst_int (n + x); c], dbg) + | Cop(Csubi, [c; Cconst_int x], _) when no_overflow_sub n x -> + add_const c (n - x) dbg + | c -> Cop(Caddi, [c; Cconst_int n], dbg) -let incr_int = function - Cconst_int n when n < max_int -> Cconst_int(n+1) - | Cop(Caddi, [c; Cconst_int n]) when n < max_int -> add_const c (n + 1) - | c -> add_const c 1 - -let decr_int = function - Cconst_int n when n > min_int -> Cconst_int(n-1) - | Cop(Caddi, [c; Cconst_int n]) when n > min_int -> add_const c (n - 1) - | c -> add_const c (-1) +let incr_int c dbg = add_const c 1 dbg +let decr_int c dbg = add_const c (-1) dbg -let add_int c1 c2 = +let rec add_int c1 c2 dbg = match (c1, c2) with - (Cop(Caddi, [c1; Cconst_int n1]), - Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_add n1 n2 -> - add_const (Cop(Caddi, [c1; c2])) (n1 + n2) - | (Cop(Caddi, [c1; Cconst_int n1]), c2) -> - add_const (Cop(Caddi, [c1; c2])) n1 - | (c1, Cop(Caddi, [c2; Cconst_int n2])) -> - add_const (Cop(Caddi, [c1; c2])) n2 - | (Cconst_int _, _) -> - Cop(Caddi, [c2; c1]) + | (Cconst_int n, c) | (c, Cconst_int n) -> + add_const c n dbg + | (Cop(Caddi, [c1; Cconst_int n1], _), c2) -> + add_const (add_int c1 c2 dbg) n1 dbg + | (c1, Cop(Caddi, [c2; Cconst_int n2], _)) -> + add_const (add_int c1 c2 dbg) n2 dbg | (_, _) -> - Cop(Caddi, [c1; c2]) + Cop(Caddi, [c1; c2], dbg) -let sub_int c1 c2 = +let rec sub_int c1 c2 dbg = match (c1, c2) with - (Cop(Caddi, [c1; Cconst_int n1]), - Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_sub n1 n2 -> - add_const (Cop(Csubi, [c1; c2])) (n1 - n2) - | (Cop(Caddi, [c1; Cconst_int n1]), c2) -> - add_const (Cop(Csubi, [c1; c2])) n1 - | (c1, Cop(Caddi, [c2; Cconst_int n2])) when n2 <> min_int -> - add_const (Cop(Csubi, [c1; c2])) (-n2) - | (c1, Cconst_int n) when n <> min_int -> - add_const c1 (-n) + | (c1, Cconst_int n2) when n2 <> min_int -> + add_const c1 (-n2) dbg + | (c1, Cop(Caddi, [c2; Cconst_int n2], _)) when n2 <> min_int -> + add_const (sub_int c1 c2 dbg) (-n2) dbg + | (Cop(Caddi, [c1; Cconst_int n1], _), c2) -> + add_const (sub_int c1 c2 dbg) n1 dbg | (c1, c2) -> - Cop(Csubi, [c1; c2]) + Cop(Csubi, [c1; c2], dbg) -let mul_int c1 c2 = +let rec lsl_int c1 c2 dbg = match (c1, c2) with - (Cconst_int 0, _) -> c1 - | (Cconst_int 1, _) -> c2 - | (_, Cconst_int 0) -> c2 - | (_, Cconst_int 1) -> c1 - | (_, _) -> Cop(Cmuli, [c1; c2]) - -let tag_int = function - Cconst_int n -> int_const n - | c -> Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) - -let force_tag_int = function - Cconst_int n -> int_const n - | c -> Cop(Cor, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) + | (Cop(Clsl, [c; Cconst_int n1], _), Cconst_int n2) + when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 -> + Cop(Clsl, [c; Cconst_int (n1 + n2)], dbg) + | (Cop(Caddi, [c1; Cconst_int n1], _), Cconst_int n2) + when no_overflow_lsl n1 n2 -> + add_const (lsl_int c1 c2 dbg) (n1 lsl n2) dbg + | (_, _) -> + Cop(Clsl, [c1; c2], dbg) -let untag_int = function - Cconst_int n -> Cconst_int(n asr 1) - | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c - | Cop(Cor, [Cop(Casr, [c; Cconst_int n]); Cconst_int 1]) - when n > 0 && n < size_int * 8 -> - Cop(Casr, [c; Cconst_int (n+1)]) - | Cop(Cor, [Cop(Clsr, [c; Cconst_int n]); Cconst_int 1]) - when n > 0 && n < size_int * 8 -> - Cop(Clsr, [c; Cconst_int (n+1)]) - | Cop(Cor, [c; Cconst_int 1]) -> Cop(Casr, [c; Cconst_int 1]) - | c -> Cop(Casr, [c; Cconst_int 1]) +let is_power2 n = n = 1 lsl Misc.log2 n -let lsl_int c1 c2 = +and mult_power2 c n dbg = lsl_int c (Cconst_int (Misc.log2 n)) dbg + +let rec mul_int c1 c2 dbg = match (c1, c2) with - (Cop(Clsl, [c; Cconst_int n1]), Cconst_int n2) - when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 -> - Cop(Clsl, [c; Cconst_int (n1 + n2)]) - | (_, _) -> - Cop(Clsl, [c1; c2]) + | (c, Cconst_int 0) | (Cconst_int 0, c) -> Csequence (c, Cconst_int 0) + | (c, Cconst_int 1) | (Cconst_int 1, c) -> + c + | (c, Cconst_int(-1)) | (Cconst_int(-1), c) -> + sub_int (Cconst_int 0) c dbg + | (c, Cconst_int n) when is_power2 n -> mult_power2 c n dbg + | (Cconst_int n, c) when is_power2 n -> mult_power2 c n dbg + | (Cop(Caddi, [c; Cconst_int n], _), Cconst_int k) | + (Cconst_int k, Cop(Caddi, [c; Cconst_int n], _)) + when no_overflow_mul n k -> + add_const (mul_int c (Cconst_int k) dbg) (n * k) dbg + | (c1, c2) -> + Cop(Cmuli, [c1; c2], dbg) + let ignore_low_bit_int = function - Cop(Caddi, [(Cop(Clsl, [_; Cconst_int n]) as c); Cconst_int 1]) when n > 0 + Cop(Caddi, [(Cop(Clsl, [_; Cconst_int n], _) as c); Cconst_int 1], _) + when n > 0 -> c - | Cop(Cor, [c; Cconst_int 1]) -> c + | Cop(Cor, [c; Cconst_int 1], _) -> c | c -> c -let lsr_int c1 c2 = +let lsr_int c1 c2 dbg = match c2 with - (Cconst_int n) when n > 0 -> - Cop(Clsr, [ignore_low_bit_int c1; c2]) + Cconst_int 0 -> + c1 + | Cconst_int n when n > 0 -> + Cop(Clsr, [ignore_low_bit_int c1; c2], dbg) | _ -> - Cop(Clsr, [c1; c2]) + Cop(Clsr, [c1; c2], dbg) -let asr_int c1 c2 = +let asr_int c1 c2 dbg = match c2 with - (Cconst_int n) when n > 0 -> - Cop(Casr, [ignore_low_bit_int c1; c2]) + Cconst_int 0 -> + c1 + | Cconst_int n when n > 0 -> + Cop(Casr, [ignore_low_bit_int c1; c2], dbg) + | _ -> + Cop(Casr, [c1; c2], dbg) + +let tag_int i dbg = + match i with + Cconst_int n -> + int_const n + | Cop(Casr, [c; Cconst_int n], _) when n > 0 -> + Cop(Cor, [asr_int c (Cconst_int (n - 1)) dbg; Cconst_int 1], dbg) + | c -> + incr_int (lsl_int c (Cconst_int 1) dbg) dbg + +let force_tag_int i dbg = + match i with + Cconst_int n -> + int_const n + | Cop(Casr, [c; Cconst_int n], dbg) when n > 0 -> + Cop(Cor, [asr_int c (Cconst_int (n - 1)) dbg; Cconst_int 1], dbg) + | c -> + Cop(Cor, [lsl_int c (Cconst_int 1) dbg; Cconst_int 1], dbg) + +let untag_int i dbg = + match i with + Cconst_int n -> Cconst_int(n asr 1) + | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], _) -> c + | Cop(Cor, [Cop(Casr, [c; Cconst_int n], _); Cconst_int 1], _) + when n > 0 && n < size_int * 8 -> + Cop(Casr, [c; Cconst_int (n+1)], dbg) + | Cop(Cor, [Cop(Clsr, [c; Cconst_int n], _); Cconst_int 1], _) + when n > 0 && n < size_int * 8 -> + Cop(Clsr, [c; Cconst_int (n+1)], dbg) + | Cop(Cor, [c; Cconst_int 1], _) -> Cop(Casr, [c; Cconst_int 1], dbg) + | c -> Cop(Casr, [c; Cconst_int 1], dbg) + +let if_then_else (cond, ifso, ifnot) = + match cond with + | Cconst_int 0 -> ifnot + | Cconst_int 1 -> ifso | _ -> - Cop(Casr, [c1; c2]) + Cifthenelse(cond, ifso, ifnot) -(* Division or modulo on tagged integers. The overflow case min_int / -1 - cannot occur, but we must guard against division by zero. *) +(* Turning integer divisions into multiply-high then shift. + The [division_parameters] function is used in module Emit for + those target platforms that support this optimization. *) -let is_different_from x = function - Cconst_int n -> n <> x - | Cconst_natint n -> n <> Nativeint.of_int x - | _ -> false +(* Unsigned comparison between native integers. *) -let safe_divmod op c1 c2 dbg = - if !Clflags.fast || is_different_from 0 c2 then - Cop(op, [c1; c2]) - else - bind "divisor" c2 (fun c2 -> - Cifthenelse(c2, - Cop(op, [c1; c2]), - Cop(Craise dbg, - [Cconst_symbol "caml_bucket_Division_by_zero"]))) +let ucompare x y = Nativeint.(compare (add x min_int) (add y min_int)) + +(* Unsigned division and modulus at type nativeint. + Algorithm: Hacker's Delight section 9.3 *) + +let udivmod n d = Nativeint.( + if d < 0n then + if ucompare n d < 0 then (0n, n) else (1n, sub n d) + else begin + let q = shift_left (div (shift_right_logical n 1) d) 1 in + let r = sub n (mul q d) in + if ucompare r d >= 0 then (succ q, sub r d) else (q, r) + end) + +(* Compute division parameters. + Algorithm: Hacker's Delight chapter 10, fig 10-1. *) + +let divimm_parameters d = Nativeint.( + assert (d > 0n); + let twopsm1 = min_int in (* 2^31 for 32-bit archs, 2^63 for 64-bit archs *) + let nc = sub (pred twopsm1) (snd (udivmod twopsm1 d)) in + let rec loop p (q1, r1) (q2, r2) = + let p = p + 1 in + let q1 = shift_left q1 1 and r1 = shift_left r1 1 in + let (q1, r1) = + if ucompare r1 nc >= 0 then (succ q1, sub r1 nc) else (q1, r1) in + let q2 = shift_left q2 1 and r2 = shift_left r2 1 in + let (q2, r2) = + if ucompare r2 d >= 0 then (succ q2, sub r2 d) else (q2, r2) in + let delta = sub d r2 in + if ucompare q1 delta < 0 || (q1 = delta && r1 = 0n) + then loop p (q1, r1) (q2, r2) + else (succ q2, p - size) + in loop (size - 1) (udivmod twopsm1 nc) (udivmod twopsm1 d)) + +(* The result [(m, p)] of [divimm_parameters d] satisfies the following + inequality: + + 2^(wordsize + p) < m * d <= 2^(wordsize + p) + 2^(p + 1) (i) + + from which it follows that + + floor(n / d) = floor(n * m / 2^(wordsize+p)) + if 0 <= n < 2^(wordsize-1) + ceil(n / d) = floor(n * m / 2^(wordsize+p)) + 1 + if -2^(wordsize-1) <= n < 0 + + The correctness condition (i) above can be checked by the code below. + It was exhaustively tested for values of d from 2 to 10^9 in the + wordsize = 64 case. + +let add2 (xh, xl) (yh, yl) = + let zl = add xl yl and zh = add xh yh in + ((if ucompare zl xl < 0 then succ zh else zh), zl) + +let shl2 (xh, xl) n = + assert (0 < n && n < size + size); + if n < size + then (logor (shift_left xh n) (shift_right_logical xl (size - n)), + shift_left xl n) + else (shift_left xl (n - size), 0n) + +let mul2 x y = + let halfsize = size / 2 in + let halfmask = pred (shift_left 1n halfsize) in + let xl = logand x halfmask and xh = shift_right_logical x halfsize in + let yl = logand y halfmask and yh = shift_right_logical y halfsize in + add2 (mul xh yh, 0n) + (add2 (shl2 (0n, mul xl yh) halfsize) + (add2 (shl2 (0n, mul xh yl) halfsize) + (0n, mul xl yl))) + +let ucompare2 (xh, xl) (yh, yl) = + let c = ucompare xh yh in if c = 0 then ucompare xl yl else c + +let validate d m p = + let md = mul2 m d in + let one2 = (0n, 1n) in + let twoszp = shl2 one2 (size + p) in + let twop1 = shl2 one2 (p + 1) in + ucompare2 twoszp md < 0 && ucompare2 md (add2 twoszp twop1) <= 0 +*) + +let raise_regular dbg exc = + Csequence( + Cop(Cstore (Thirtytwo_signed, Assignment), + [(Cconst_symbol "caml_backtrace_pos"); Cconst_int 0], dbg), + Cop(Craise Raise_withtrace,[exc], dbg)) + +let raise_symbol dbg symb = + raise_regular dbg (Cconst_symbol symb) + +let rec div_int c1 c2 is_safe dbg = + match (c1, c2) with + (c1, Cconst_int 0) -> + Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero") + | (c1, Cconst_int 1) -> + c1 + | (Cconst_int n1, Cconst_int n2) -> + Cconst_int (n1 / n2) + | (c1, Cconst_int n) when n <> min_int -> + let l = Misc.log2 n in + if n = 1 lsl l then + (* Algorithm: + t = shift-right-signed(c1, l - 1) + t = shift-right(t, W - l) + t = c1 + t + res = shift-right-signed(c1 + t, l) + *) + Cop(Casr, [bind "dividend" c1 (fun c1 -> + let t = asr_int c1 (Cconst_int (l - 1)) dbg in + let t = lsr_int t (Cconst_int (Nativeint.size - l)) dbg in + add_int c1 t dbg); + Cconst_int l], dbg) + else if n < 0 then + sub_int (Cconst_int 0) (div_int c1 (Cconst_int (-n)) is_safe dbg) dbg + else begin + let (m, p) = divimm_parameters (Nativeint.of_int n) in + (* Algorithm: + t = multiply-high-signed(c1, m) + if m < 0, t = t + c1 + if p > 0, t = shift-right-signed(t, p) + res = t + sign-bit(c1) + *) + bind "dividend" c1 (fun c1 -> + let t = Cop(Cmulhi, [c1; Cconst_natint m], dbg) in + let t = if m < 0n then Cop(Caddi, [t; c1], dbg) else t in + let t = if p > 0 then Cop(Casr, [t; Cconst_int p], dbg) else t in + add_int t (lsr_int c1 (Cconst_int (Nativeint.size - 1)) dbg) dbg) + end + | (c1, c2) when !Clflags.fast || is_safe = Lambda.Unsafe -> + Cop(Cdivi, [c1; c2], dbg) + | (c1, c2) -> + bind "divisor" c2 (fun c2 -> + bind "dividend" c1 (fun c1 -> + Cifthenelse(c2, + Cop(Cdivi, [c1; c2], dbg), + raise_symbol dbg "caml_exn_Division_by_zero"))) + +let mod_int c1 c2 is_safe dbg = + match (c1, c2) with + (c1, Cconst_int 0) -> + Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero") + | (c1, Cconst_int (1 | (-1))) -> + Csequence(c1, Cconst_int 0) + | (Cconst_int n1, Cconst_int n2) -> + Cconst_int (n1 mod n2) + | (c1, (Cconst_int n as c2)) when n <> min_int -> + let l = Misc.log2 n in + if n = 1 lsl l then + (* Algorithm: + t = shift-right-signed(c1, l - 1) + t = shift-right(t, W - l) + t = c1 + t + t = bit-and(t, -n) + res = c1 - t + *) + bind "dividend" c1 (fun c1 -> + let t = asr_int c1 (Cconst_int (l - 1)) dbg in + let t = lsr_int t (Cconst_int (Nativeint.size - l)) dbg in + let t = add_int c1 t dbg in + let t = Cop(Cand, [t; Cconst_int (-n)], dbg) in + sub_int c1 t dbg) + else + bind "dividend" c1 (fun c1 -> + sub_int c1 (mul_int (div_int c1 c2 is_safe dbg) c2 dbg) dbg) + | (c1, c2) when !Clflags.fast || is_safe = Lambda.Unsafe -> + (* Flambda already generates that test *) + Cop(Cmodi, [c1; c2], dbg) + | (c1, c2) -> + bind "divisor" c2 (fun c2 -> + bind "dividend" c1 (fun c1 -> + Cifthenelse(c2, + Cop(Cmodi, [c1; c2], dbg), + raise_symbol dbg "caml_exn_Division_by_zero"))) (* Division or modulo on boxed integers. The overflow case min_int / -1 can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *) -let safe_divmod_bi mkop mkm1 c1 c2 bi dbg = +let is_different_from x = function + Cconst_int n -> n <> x + | Cconst_natint n -> n <> Nativeint.of_int x + | _ -> false + +let safe_divmod_bi mkop is_safe mkm1 c1 c2 bi dbg = bind "dividend" c1 (fun c1 -> bind "divisor" c2 (fun c2 -> - let c3 = - if Arch.division_crashes_on_overflow - && (size_int = 4 || bi <> Pint32) - && not (is_different_from (-1) c2) - then - Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)]), mkop c1 c2, mkm1 c1) - else - mkop c1 c2 in - if !Clflags.fast || is_different_from 0 c2 then - c3 - else - Cifthenelse(c2, c3, - Cop(Craise dbg, - [Cconst_symbol "caml_bucket_Division_by_zero"])))) - -let safe_div_bi = - safe_divmod_bi (fun c1 c2 -> Cop(Cdivi, [c1;c2])) - (fun c1 -> Cop(Csubi, [Cconst_int 0; c1])) - -let safe_mod_bi = - safe_divmod_bi (fun c1 c2 -> Cop(Cmodi, [c1;c2])) - (fun c1 -> Cconst_int 0) + let c = mkop c1 c2 is_safe dbg in + if Arch.division_crashes_on_overflow + && (size_int = 4 || bi <> Pint32) + && not (is_different_from (-1) c2) + then Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)], dbg), c, mkm1 c1 dbg) + else c)) + +let safe_div_bi is_safe = + safe_divmod_bi div_int is_safe + (fun c1 dbg -> Cop(Csubi, [Cconst_int 0; c1], dbg)) + +let safe_mod_bi is_safe = + safe_divmod_bi mod_int is_safe (fun _ _ -> Cconst_int 0) (* Bool *) -let test_bool = function - Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c - | Cop(Clsl, [c; Cconst_int 1]) -> c - | c -> Cop(Ccmpi Cne, [c; Cconst_int 1]) +let test_bool dbg cmm = + match cmm with + | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], _) -> c + | Cconst_int n -> + if n = 1 then + Cconst_int 0 + else + Cconst_int 1 + | c -> Cop(Ccmpi Cne, [c; Cconst_int 1], dbg) (* Float *) -let box_float c = Cop(Calloc, [alloc_float_header; c]) +let box_float dbg c = Cop(Calloc, [alloc_float_header dbg; c], dbg) -let rec unbox_float = function - Cop(Calloc, [header; c]) -> c - | Clet(id, exp, body) -> Clet(id, exp, unbox_float body) +let map_ccatch f rec_flag handlers body = + let handlers = List.map + (fun (n, ids, handler) -> (n, ids, f handler)) + handlers in + Ccatch(rec_flag, handlers, f body) + +let rec unbox_float dbg cmm = + match cmm with + | Cop(Calloc, [_header; c], _) -> c + | Clet(id, exp, body) -> Clet(id, exp, unbox_float dbg body) | Cifthenelse(cond, e1, e2) -> - Cifthenelse(cond, unbox_float e1, unbox_float e2) - | Csequence(e1, e2) -> Csequence(e1, unbox_float e2) - | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map unbox_float el) - | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_float e1, unbox_float e2) - | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float e1, id, unbox_float e2) - | c -> Cop(Cload Double_u, [c]) + Cifthenelse(cond, unbox_float dbg e1, unbox_float dbg e2) + | Csequence(e1, e2) -> Csequence(e1, unbox_float dbg e2) + | Cswitch(e, tbl, el, dbg) -> + Cswitch(e, tbl, Array.map (unbox_float dbg) el, dbg) + | Ccatch(rec_flag, handlers, body) -> + map_ccatch (unbox_float dbg) rec_flag handlers body + | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float dbg e1, id, unbox_float dbg e2) + | c -> Cop(Cload (Double_u, Immutable), [c], dbg) (* Complex *) -let box_complex c_re c_im = - Cop(Calloc, [alloc_floatarray_header 2; c_re; c_im]) +let box_complex dbg c_re c_im = + Cop(Calloc, [alloc_floatarray_header 2 dbg; c_re; c_im], dbg) -let complex_re c = Cop(Cload Double_u, [c]) -let complex_im c = Cop(Cload Double_u, - [Cop(Cadda, [c; Cconst_int size_float])]) +let complex_re c dbg = Cop(Cload (Double_u, Immutable), [c], dbg) +let complex_im c dbg = Cop(Cload (Double_u, Immutable), + [Cop(Cadda, [c; Cconst_int size_float], dbg)], dbg) (* Unit *) @@ -264,50 +532,72 @@ Csequence(c1, remove_unit c2) | Cifthenelse(cond, ifso, ifnot) -> Cifthenelse(cond, remove_unit ifso, remove_unit ifnot) - | Cswitch(sel, index, cases) -> - Cswitch(sel, index, Array.map remove_unit cases) - | Ccatch(io, ids, body, handler) -> - Ccatch(io, ids, remove_unit body, remove_unit handler) + | Cswitch(sel, index, cases, dbg) -> + Cswitch(sel, index, Array.map remove_unit cases, dbg) + | Ccatch(rec_flag, handlers, body) -> + map_ccatch remove_unit rec_flag handlers body | Ctrywith(body, exn, handler) -> Ctrywith(remove_unit body, exn, remove_unit handler) | Clet(id, c1, c2) -> Clet(id, c1, remove_unit c2) - | Cop(Capply (mty, dbg), args) -> - Cop(Capply (typ_void, dbg), args) - | Cop(Cextcall(proc, mty, alloc, dbg), args) -> - Cop(Cextcall(proc, typ_void, alloc, dbg), args) + | Cop(Capply _mty, args, dbg) -> + Cop(Capply typ_void, args, dbg) + | Cop(Cextcall(proc, _mty, alloc, label_after), args, dbg) -> + Cop(Cextcall(proc, typ_void, alloc, label_after), args, dbg) | Cexit (_,_) as c -> c | Ctuple [] as c -> c | c -> Csequence(c, Ctuple []) (* Access to block fields *) -let field_address ptr n = +let field_address ptr n dbg = if n = 0 then ptr - else Cop(Cadda, [ptr; Cconst_int(n * size_addr)]) + else Cop(Cadda, [ptr; Cconst_int(n * size_addr)], dbg) -let get_field ptr n = - Cop(Cload Word, [field_address ptr n]) +let get_field env ptr n dbg = + let mut = + match env.environment_param with + | None -> Mutable + | Some environment_param -> + match ptr with + | Cvar ptr -> + (* Loads from the current function's closure are immutable. *) + if Ident.same environment_param ptr then Immutable + else Mutable + | _ -> Mutable + in + Cop(Cload (Word_val, mut), [field_address ptr n dbg], dbg) + +let set_field ptr n newval init dbg = + Cop(Cstore (Word_val, init), [field_address ptr n dbg; newval], dbg) -let set_field ptr n newval = - Cop(Cstore Word, [field_address ptr n; newval]) +let non_profinfo_mask = (1 lsl (64 - Config.profinfo_width)) - 1 -let header ptr = - Cop(Cload Word, [Cop(Cadda, [ptr; Cconst_int(-size_int)])]) +let get_header ptr dbg = + (* We cannot deem this as [Immutable] due to the presence of [Obj.truncate] + and [Obj.set_tag]. *) + Cop(Cload (Word_int, Mutable), + [Cop(Cadda, [ptr; Cconst_int(-size_int)], dbg)], dbg) + +let get_header_without_profinfo ptr dbg = + if Config.profinfo then + Cop(Cand, [get_header ptr dbg; Cconst_int non_profinfo_mask], dbg) + else + get_header ptr dbg let tag_offset = if big_endian then -1 else -size_int -let get_tag ptr = +let get_tag ptr dbg = if Proc.word_addressed then (* If byte loads are slow *) - Cop(Cand, [header ptr; Cconst_int 255]) + Cop(Cand, [get_header ptr dbg; Cconst_int 255], dbg) else (* If byte loads are efficient *) - Cop(Cload Byte_unsigned, - [Cop(Cadda, [ptr; Cconst_int(tag_offset)])]) + Cop(Cload (Byte_unsigned, Mutable), (* Same comment as [get_header] above *) + [Cop(Cadda, [ptr; Cconst_int(tag_offset)], dbg)], dbg) -let get_size ptr = - Cop(Clsr, [header ptr; Cconst_int 10]) +let get_size ptr dbg = + Cop(Clsr, [get_header_without_profinfo ptr dbg; Cconst_int 10], dbg) (* Array indexing *) @@ -317,120 +607,173 @@ let wordsize_shift = 9 let numfloat_shift = 9 + log2_size_float - log2_size_addr -let is_addr_array_hdr hdr = - Cop(Ccmpi Cne, [Cop(Cand, [hdr; Cconst_int 255]); floatarray_tag]) +let is_addr_array_hdr hdr dbg = + Cop(Ccmpi Cne, [Cop(Cand, [hdr; Cconst_int 255], dbg); floatarray_tag], dbg) -let is_addr_array_ptr ptr = - Cop(Ccmpi Cne, [get_tag ptr; floatarray_tag]) +let is_addr_array_ptr ptr dbg = + Cop(Ccmpi Cne, [get_tag ptr dbg; floatarray_tag], dbg) -let addr_array_length hdr = Cop(Clsr, [hdr; Cconst_int wordsize_shift]) -let float_array_length hdr = Cop(Clsr, [hdr; Cconst_int numfloat_shift]) +let addr_array_length hdr dbg = + Cop(Clsr, [hdr; Cconst_int wordsize_shift], dbg) +let float_array_length hdr dbg = + Cop(Clsr, [hdr; Cconst_int numfloat_shift], dbg) -let lsl_const c n = - Cop(Clsl, [c; Cconst_int n]) +let lsl_const c n dbg = + if n = 0 then c + else Cop(Clsl, [c; Cconst_int n], dbg) -let array_indexing log2size ptr ofs = +(* Produces a pointer to the element of the array [ptr] on the position [ofs] + with the given element [log2size] log2 element size. [ofs] is given as a + tagged int expression. + The optional ?typ argument is the C-- type of the result. + By default, it is Addr, meaning we are constructing a derived pointer + into the heap. If we know the pointer is outside the heap + (this is the case for bigarray indexing), we give type Int instead. *) + +let array_indexing ?typ log2size ptr ofs dbg = + let add = + match typ with + | None | Some Addr -> Cadda + | Some Int -> Caddi + | _ -> assert false in match ofs with - Cconst_int n -> + | Cconst_int n -> let i = n asr 1 in - if i = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(i lsl log2size)]) - | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> - Cop(Cadda, [ptr; lsl_const c log2size]) - | Cop(Caddi, [c; Cconst_int n]) -> - Cop(Cadda, [Cop(Cadda, [ptr; lsl_const c (log2size - 1)]); - Cconst_int((n-1) lsl (log2size - 1))]) + if i = 0 then ptr else Cop(add, [ptr; Cconst_int(i lsl log2size)], dbg) + | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], _) -> + Cop(add, [ptr; lsl_const c log2size dbg], dbg) + | Cop(Caddi, [c; Cconst_int n], _) when log2size = 0 -> + Cop(add, [Cop(add, [ptr; untag_int c dbg], dbg); Cconst_int (n asr 1)], + dbg) + | Cop(Caddi, [c; Cconst_int n], _) -> + Cop(add, [Cop(add, [ptr; lsl_const c (log2size - 1) dbg], dbg); + Cconst_int((n-1) lsl (log2size - 1))], dbg) + | _ when log2size = 0 -> + Cop(add, [ptr; untag_int ofs dbg], dbg) | _ -> - Cop(Cadda, [Cop(Cadda, [ptr; lsl_const ofs (log2size - 1)]); - Cconst_int((-1) lsl (log2size - 1))]) + Cop(add, [Cop(add, [ptr; lsl_const ofs (log2size - 1) dbg], dbg); + Cconst_int((-1) lsl (log2size - 1))], dbg) -let addr_array_ref arr ofs = - Cop(Cload Word, [array_indexing log2_size_addr arr ofs]) -let unboxed_float_array_ref arr ofs = - Cop(Cload Double_u, [array_indexing log2_size_float arr ofs]) -let float_array_ref arr ofs = - box_float(unboxed_float_array_ref arr ofs) - -let addr_array_set arr ofs newval = - Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none), - [array_indexing log2_size_addr arr ofs; newval]) -let int_array_set arr ofs newval = - Cop(Cstore Word, [array_indexing log2_size_addr arr ofs; newval]) -let float_array_set arr ofs newval = - Cop(Cstore Double_u, [array_indexing log2_size_float arr ofs; newval]) +let addr_array_ref arr ofs dbg = + Cop(Cload (Word_val, Mutable), + [array_indexing log2_size_addr arr ofs dbg], dbg) +let int_array_ref arr ofs dbg = + Cop(Cload (Word_int, Mutable), + [array_indexing log2_size_addr arr ofs dbg], dbg) +let unboxed_float_array_ref arr ofs dbg = + Cop(Cload (Double_u, Mutable), + [array_indexing log2_size_float arr ofs dbg], dbg) +let float_array_ref dbg arr ofs = + box_float dbg (unboxed_float_array_ref arr ofs dbg) + +let addr_array_set arr ofs newval dbg = + Cop(Cextcall("caml_modify", typ_void, false, None), + [array_indexing log2_size_addr arr ofs dbg; newval], dbg) +let addr_array_initialize arr ofs newval dbg = + Cop(Cextcall("caml_initialize", typ_void, false, None), + [array_indexing log2_size_addr arr ofs dbg; newval], dbg) +let int_array_set arr ofs newval dbg = + Cop(Cstore (Word_int, Assignment), + [array_indexing log2_size_addr arr ofs dbg; newval], dbg) +let float_array_set arr ofs newval dbg = + Cop(Cstore (Double_u, Assignment), + [array_indexing log2_size_float arr ofs dbg; newval], dbg) (* String length *) -let string_length exp = +(* Length of string block *) + +let string_length exp dbg = bind "str" exp (fun str -> let tmp_var = Ident.create "tmp" in Clet(tmp_var, Cop(Csubi, [Cop(Clsl, - [Cop(Clsr, [header str; Cconst_int 10]); - Cconst_int log2_size_addr]); - Cconst_int 1]), + [get_size str dbg; + Cconst_int log2_size_addr], + dbg); + Cconst_int 1], + dbg), Cop(Csubi, [Cvar tmp_var; - Cop(Cload Byte_unsigned, - [Cop(Cadda, [str; Cvar tmp_var])])]))) + Cop(Cload (Byte_unsigned, Mutable), + [Cop(Cadda, [str; Cvar tmp_var], dbg)], dbg)], dbg))) (* Message sending *) -let lookup_tag obj tag = +let lookup_tag obj tag dbg = bind "tag" tag (fun tag -> - Cop(Cextcall("caml_get_public_method", typ_addr, false, Debuginfo.none), - [obj; tag])) + Cop(Cextcall("caml_get_public_method", typ_val, false, None), + [obj; tag], + dbg)) -let lookup_label obj lab = +let lookup_label obj lab dbg = bind "lab" lab (fun lab -> - let table = Cop (Cload Word, [obj]) in - addr_array_ref table lab) + let table = Cop (Cload (Word_val, Mutable), [obj], dbg) in + addr_array_ref table lab dbg) let call_cached_method obj tag cache pos args dbg = let arity = List.length args in - let cache = array_indexing log2_size_addr cache pos in + let cache = array_indexing log2_size_addr cache pos dbg in Compilenv.need_send_fun arity; - Cop(Capply (typ_addr, dbg), + Cop(Capply typ_val, Cconst_symbol("caml_send" ^ string_of_int arity) :: - obj :: tag :: cache :: args) + obj :: tag :: cache :: args, + dbg) (* Allocation *) -let make_alloc_generic set_fn tag wordsize args = +let make_alloc_generic set_fn dbg tag wordsize args = if wordsize <= Config.max_young_wosize then - Cop(Calloc, Cconst_natint(block_header tag wordsize) :: args) + Cop(Calloc, Cblockheader(block_header tag wordsize, dbg) :: args, dbg) else begin let id = Ident.create "alloc" in let rec fill_fields idx = function [] -> Cvar id - | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1, + | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1 dbg, fill_fields (idx + 2) el) in Clet(id, - Cop(Cextcall("caml_alloc", typ_addr, true, Debuginfo.none), - [Cconst_int wordsize; Cconst_int tag]), + Cop(Cextcall("caml_alloc", typ_val, true, None), + [Cconst_int wordsize; Cconst_int tag], dbg), fill_fields 1 args) end -let make_alloc tag args = - make_alloc_generic addr_array_set tag (List.length args) args -let make_float_alloc tag args = - make_alloc_generic float_array_set tag +let make_alloc dbg tag args = + let addr_array_init arr ofs newval dbg = + Cop(Cextcall("caml_initialize", typ_void, false, None), + [array_indexing log2_size_addr arr ofs dbg; newval], dbg) + in + make_alloc_generic addr_array_init dbg tag (List.length args) args + +let make_float_alloc dbg tag args = + make_alloc_generic float_array_set dbg tag (List.length args * size_float / size_addr) args (* Bounds checking *) let make_checkbound dbg = function - | [Cop(Clsr, [a1; Cconst_int n]); Cconst_int m] when (m lsl n) > n -> - Cop(Ccheckbound dbg, [a1; Cconst_int(m lsl n + 1 lsl n - 1)]) + | [Cop(Clsr, [a1; Cconst_int n], _); Cconst_int m] when (m lsl n) > n -> + Cop(Ccheckbound, [a1; Cconst_int(m lsl n + 1 lsl n - 1)], dbg) | args -> - Cop(Ccheckbound dbg, args) + Cop(Ccheckbound, args, dbg) (* To compile "let rec" over values *) let fundecls_size fundecls = let sz = ref (-1) in List.iter - (fun f -> sz := !sz + 1 + (if f.arity = 1 then 2 else 3)) + (fun f -> + let indirect_call_code_pointer_size = + match f.arity with + | 0 | 1 -> 0 + (* arity 1 does not need an indirect call handler. + arity 0 cannot be indirect called *) + | _ -> 1 + (* For other arities there is an indirect call handler. + if arity >= 2 it is caml_curry... + if arity < 0 it is caml_tuplify... *) + in + sz := !sz + 1 + 2 + indirect_call_code_pointer_size) fundecls; !sz @@ -444,21 +787,29 @@ begin try Ident.find_same id env with Not_found -> RHS_nonrec end | Uclosure(fundecls, clos_vars) -> RHS_block (fundecls_size fundecls + List.length clos_vars) - | Ulet(id, exp, body) -> + | Ulet(_str, _kind, id, exp, body) -> expr_size (Ident.add id (expr_size env exp) env) body - | Uletrec(bindings, body) -> + | Uletrec(_bindings, body) -> expr_size env body - | Uprim(Pmakeblock(tag, mut), args, _) -> + | Uprim(Pmakeblock _, args, _) -> RHS_block (List.length args) - | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) -> + | Uprim(Pmakearray((Paddrarray | Pintarray), _), args, _) -> RHS_block (List.length args) - | Uprim(Pmakearray(Pfloatarray), args, _) -> + | Uprim(Pmakearray(Pfloatarray, _), args, _) -> RHS_floatblock (List.length args) - | Uprim (Pduprecord (Record_regular, sz), _, _) -> + | Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) -> RHS_block sz + | Uprim (Pduprecord (Record_unboxed _, _), _, _) -> + assert false + | Uprim (Pduprecord (Record_extension, sz), _, _) -> + RHS_block (sz + 1) | Uprim (Pduprecord (Record_float, sz), _, _) -> RHS_floatblock sz - | Usequence(exp, exp') -> + | Uprim (Pccall { prim_name; _ }, closure::_, _) + when prim_name = "caml_check_value_is_closure" -> + (* Used for "-clambda-checks". *) + expr_size env closure + | Usequence(_exp, exp') -> expr_size env exp' | _ -> RHS_nonrec @@ -484,45 +835,44 @@ (* Translate structured constants *) -(* Fabrice: moved to compilenv.ml ---- -let const_label = ref 0 - -let new_const_label () = - incr const_label; - !const_label - -let new_const_symbol () = - incr const_label; - Compilenv.make_symbol (Some (string_of_int !const_label)) - -let structured_constants = ref ([] : (string * structured_constant) list) -*) - let transl_constant = function - Const_base(Const_int n) -> + | Uconst_int n -> int_const n - | Const_base(Const_char c) -> - Cconst_int(((Char.code c) lsl 1) + 1) - | Const_pointer n -> + | Uconst_ptr n -> if n <= max_repr_int && n >= min_repr_int then Cconst_pointer((n lsl 1) + 1) else Cconst_natpointer (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) - | cst -> - Cconst_symbol (Compilenv.new_structured_constant cst false) + | Uconst_ref (label, _) -> + Cconst_symbol label + +let transl_structured_constant cst = + let label = Compilenv.new_structured_constant cst ~shared:true in + Cconst_symbol label (* Translate constant closures *) -let constant_closures = - ref ([] : (string * ufunction list) list) +type is_global = Global | Not_global + +type symbol_defn = string * is_global + +type cmm_constant = + | Const_closure of symbol_defn * ufunction list * uconstant list + | Const_table of symbol_defn * data_item list + +let cmm_constants = + ref ([] : cmm_constant list) + +let add_cmm_constant c = + cmm_constants := c :: !cmm_constants (* Boxed integers *) let box_int_constant bi n = match bi with - Pnativeint -> Const_base(Const_nativeint n) - | Pint32 -> Const_base(Const_int32 (Nativeint.to_int32 n)) - | Pint64 -> Const_base(Const_int64 (Int64.of_nativeint n)) + Pnativeint -> Uconst_nativeint n + | Pint32 -> Uconst_int32 (Nativeint.to_int32 n) + | Pint64 -> Uconst_int64 (Int64.of_nativeint n) let operations_boxed_int bi = match bi with @@ -536,49 +886,85 @@ | Pint32 -> alloc_boxedint32_header | Pint64 -> alloc_boxedint64_header -let box_int bi arg = +let box_int dbg bi arg = match arg with Cconst_int n -> - transl_constant (box_int_constant bi (Nativeint.of_int n)) + transl_structured_constant (box_int_constant bi (Nativeint.of_int n)) | Cconst_natint n -> - transl_constant (box_int_constant bi n) + transl_structured_constant (box_int_constant bi n) | _ -> let arg' = if bi = Pint32 && size_int = 8 && big_endian - then Cop(Clsl, [arg; Cconst_int 32]) + then Cop(Clsl, [arg; Cconst_int 32], dbg) else arg in - Cop(Calloc, [alloc_header_boxed_int bi; + Cop(Calloc, [alloc_header_boxed_int bi dbg; Cconst_symbol(operations_boxed_int bi); - arg']) + arg'], dbg) + +let split_int64_for_32bit_target arg dbg = + bind "split_int64" arg (fun arg -> + let first = Cop (Cadda, [Cconst_int size_int; arg], dbg) in + let second = Cop (Cadda, [Cconst_int (2 * size_int); arg], dbg) in + Ctuple [Cop (Cload (Thirtytwo_unsigned, Mutable), [first], dbg); + Cop (Cload (Thirtytwo_unsigned, Mutable), [second], dbg)]) -let rec unbox_int bi arg = +let rec unbox_int bi arg dbg = match arg with - Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])]) + Cop(Calloc, [_hdr; _ops; Cop(Clsl, [contents; Cconst_int 32], dbg')], dbg) when bi = Pint32 && size_int = 8 && big_endian -> (* Force sign-extension of low 32 bits *) - Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32]) - | Cop(Calloc, [hdr; ops; contents]) + Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32], dbg'); Cconst_int 32], + dbg) + | Cop(Calloc, [_hdr; _ops; contents], dbg) when bi = Pint32 && size_int = 8 && not big_endian -> (* Force sign-extension of low 32 bits *) - Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32]) - | Cop(Calloc, [hdr; ops; contents]) -> + Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32], dbg); Cconst_int 32], dbg) + | Cop(Calloc, [_hdr; _ops; contents], _dbg) -> contents - | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body) + | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body dbg) | Cifthenelse(cond, e1, e2) -> - Cifthenelse(cond, unbox_int bi e1, unbox_int bi e2) - | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2) - | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map (unbox_int bi) el) - | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_int bi e1, unbox_int bi e2) - | Ctrywith(e1, id, e2) -> Ctrywith(unbox_int bi e1, id, unbox_int bi e2) + Cifthenelse(cond, unbox_int bi e1 dbg, unbox_int bi e2 dbg) + | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2 dbg) + | Cswitch(e, tbl, el, dbg) -> + Cswitch(e, tbl, Array.map (fun e -> unbox_int bi e dbg) el, dbg) + | Ccatch(rec_flag, handlers, body) -> + map_ccatch (fun e -> unbox_int bi e dbg) rec_flag handlers body + | Ctrywith(e1, id, e2) -> + Ctrywith(unbox_int bi e1 dbg, id, unbox_int bi e2 dbg) | _ -> - Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word), - [Cop(Cadda, [arg; Cconst_int size_addr])]) + if size_int = 4 && bi = Pint64 then + split_int64_for_32bit_target arg dbg + else + Cop( + Cload((if bi = Pint32 then Thirtytwo_signed else Word_int), Mutable), + [Cop(Cadda, [arg; Cconst_int size_addr], dbg)], dbg) -let make_unsigned_int bi arg = +let make_unsigned_int bi arg dbg = if bi = Pint32 && size_int = 8 - then Cop(Cand, [arg; Cconst_natint 0xFFFFFFFFn]) + then Cop(Cand, [arg; Cconst_natint 0xFFFFFFFFn], dbg) else arg +(* Boxed numbers *) + +let equal_unboxed_integer ui1 ui2 = + match ui1, ui2 with + | Pnativeint, Pnativeint -> true + | Pint32, Pint32 -> true + | Pint64, Pint64 -> true + | _, _ -> false + +let equal_boxed_number bn1 bn2 = + match bn1, bn2 with + | Boxed_float _, Boxed_float _ -> true + | Boxed_integer(ui1, _), Boxed_integer(ui2, _) -> + equal_unboxed_integer ui1 ui2 + | _, _ -> false + +let box_number bn arg = + match bn with + | Boxed_float dbg -> box_float dbg arg + | Boxed_integer (bi, dbg) -> box_int dbg bi arg + (* Big arrays *) let bigarray_elt_size = function @@ -596,22 +982,46 @@ | Pbigarray_complex32 -> 8 | Pbigarray_complex64 -> 16 +(* Produces a pointer to the element of the bigarray [b] on the position + [args]. [args] is given as a list of tagged int expressions, one per array + dimension. *) let bigarray_indexing unsafe elt_kind layout b args dbg = - let check_bound a1 a2 k = - if unsafe then k else Csequence(make_checkbound dbg [a1;a2], k) in + let check_ba_bound bound idx v = + Csequence(make_checkbound dbg [bound;idx], v) in + (* Validates the given multidimensional offset against the array bounds and + transforms it into a one dimensional offset. The offsets are expressions + evaluating to tagged int. *) let rec ba_indexing dim_ofs delta_ofs = function [] -> assert false | [arg] -> - bind "idx" (untag_int arg) - (fun idx -> - check_bound (Cop(Cload Word,[field_address b dim_ofs])) idx idx) + if unsafe then arg + else + bind "idx" arg (fun idx -> + (* Load the untagged int bound for the given dimension *) + let bound = + Cop(Cload (Word_int, Mutable),[field_address b dim_ofs dbg], dbg) + in + let idxn = untag_int idx dbg in + check_ba_bound bound idxn idx) | arg1 :: argl -> + (* The remainder of the list is transformed into a one dimensional offset + *) let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in - bind "idx" (untag_int arg1) - (fun idx -> - bind "bound" (Cop(Cload Word, [field_address b dim_ofs])) - (fun bound -> - check_bound bound idx (add_int (mul_int rem bound) idx))) in + (* Load the untagged int bound for the given dimension *) + let bound = + Cop(Cload (Word_int, Mutable), [field_address b dim_ofs dbg], dbg) + in + if unsafe then add_int (mul_int (decr_int rem dbg) bound dbg) arg1 dbg + else + bind "idx" arg1 (fun idx -> + bind "bound" bound (fun bound -> + let idxn = untag_int idx dbg in + (* [offset = rem * (tag_int bound) + idx] *) + let offset = + add_int (mul_int (decr_int rem dbg) bound dbg) idx dbg + in + check_ba_bound bound idxn offset)) in + (* The offset as an expression evaluating to int *) let offset = match layout with Pbigarray_unknown_layout -> @@ -619,14 +1029,14 @@ | Pbigarray_c_layout -> ba_indexing (4 + List.length args) (-1) (List.rev args) | Pbigarray_fortran_layout -> - ba_indexing 5 1 (List.map (fun idx -> sub_int idx (Cconst_int 2)) args) + ba_indexing 5 1 + (List.map (fun idx -> sub_int idx (Cconst_int 2) dbg) args) and elt_size = bigarray_elt_size elt_kind in - let byte_offset = - if elt_size = 1 - then offset - else Cop(Clsl, [offset; Cconst_int(log2 elt_size)]) in - Cop(Cadda, [Cop(Cload Word, [field_address b 1]); byte_offset]) + (* [array_indexing] can simplify the given expressions *) + array_indexing ~typ:Int (log2 elt_size) + (Cop(Cload (Word_int, Mutable), + [field_address b 1 dbg], dbg)) offset dbg let bigarray_word_kind = function Pbigarray_unknown -> assert false @@ -637,9 +1047,9 @@ | Pbigarray_sint16 -> Sixteen_signed | Pbigarray_uint16 -> Sixteen_unsigned | Pbigarray_int32 -> Thirtytwo_signed - | Pbigarray_int64 -> Word - | Pbigarray_caml_int -> Word - | Pbigarray_native_int -> Word + | Pbigarray_int64 -> Word_int + | Pbigarray_caml_int -> Word_int + | Pbigarray_native_int -> Word_int | Pbigarray_complex32 -> Single | Pbigarray_complex64 -> Double @@ -651,12 +1061,14 @@ let sz = bigarray_elt_size elt_kind / 2 in bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> - box_complex - (Cop(Cload kind, [addr])) - (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])]))) + box_complex dbg + (Cop(Cload (kind, Mutable), [addr], dbg)) + (Cop(Cload (kind, Mutable), + [Cop(Cadda, [addr; Cconst_int sz], dbg)], dbg))) | _ -> - Cop(Cload (bigarray_word_kind elt_kind), - [bigarray_indexing unsafe elt_kind layout b args dbg])) + Cop(Cload (bigarray_word_kind elt_kind, Mutable), + [bigarray_indexing unsafe elt_kind layout b args dbg], + dbg)) let bigarray_set unsafe elt_kind layout b args newval dbg = bind "ba" b (fun b -> @@ -668,135 +1080,166 @@ bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> Csequence( - Cop(Cstore kind, [addr; complex_re newv]), - Cop(Cstore kind, - [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv])))) + Cop(Cstore (kind, Assignment), [addr; complex_re newv dbg], dbg), + Cop(Cstore (kind, Assignment), + [Cop(Cadda, [addr; Cconst_int sz], dbg); complex_im newv dbg], + dbg)))) | _ -> - Cop(Cstore (bigarray_word_kind elt_kind), - [bigarray_indexing unsafe elt_kind layout b args dbg; newval])) + Cop(Cstore (bigarray_word_kind elt_kind, Assignment), + [bigarray_indexing unsafe elt_kind layout b args dbg; newval], + dbg)) -let unaligned_load_16 ptr idx = +let unaligned_load_16 ptr idx dbg = if Arch.allow_unaligned_access - then Cop(Cload Sixteen_unsigned, [add_int ptr idx]) + then Cop(Cload (Sixteen_unsigned, Mutable), [add_int ptr idx dbg], dbg) else - let v1 = Cop(Cload Byte_unsigned, [add_int ptr idx]) in - let v2 = Cop(Cload Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 1)]) in + let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in + let v2 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg], dbg) in let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in - Cop(Cor, [lsl_int b1 (Cconst_int 8); b2]) + Cop(Cor, [lsl_int b1 (Cconst_int 8) dbg; b2], dbg) -let unaligned_set_16 ptr idx newval = +let unaligned_set_16 ptr idx newval dbg = if Arch.allow_unaligned_access - then Cop(Cstore Sixteen_unsigned, [add_int ptr idx; newval]) + then + Cop(Cstore (Sixteen_unsigned, Assignment), + [add_int ptr idx dbg; newval], dbg) else - let v1 = Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8]); Cconst_int 0xFF]) in - let v2 = Cop(Cand, [newval; Cconst_int 0xFF]) in + let v1 = + Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8], dbg); Cconst_int 0xFF], dbg) + in + let v2 = Cop(Cand, [newval; Cconst_int 0xFF], dbg) in let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in Csequence( - Cop(Cstore Byte_unsigned, [add_int ptr idx; b1]), - Cop(Cstore Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 1); b2])) + Cop(Cstore (Byte_unsigned, Assignment), [add_int ptr idx dbg; b1], dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg; b2], dbg)) -let unaligned_load_32 ptr idx = +let unaligned_load_32 ptr idx dbg = if Arch.allow_unaligned_access - then Cop(Cload Thirtytwo_unsigned, [add_int ptr idx]) + then Cop(Cload (Thirtytwo_unsigned, Mutable), [add_int ptr idx dbg], dbg) else - let v1 = Cop(Cload Byte_unsigned, [add_int ptr idx]) in - let v2 = Cop(Cload Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 1)]) in - let v3 = Cop(Cload Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 2)]) in - let v4 = Cop(Cload Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 3)]) in + let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in + let v2 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg], dbg) in + let v3 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg], dbg) in + let v4 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg], dbg) in let b1, b2, b3, b4 = if Arch.big_endian then v1, v2, v3, v4 else v4, v3, v2, v1 in Cop(Cor, - [Cop(Cor, [lsl_int b1 (Cconst_int 24); lsl_int b2 (Cconst_int 16)]); - Cop(Cor, [lsl_int b3 (Cconst_int 8); b4])]) + [Cop(Cor, [lsl_int b1 (Cconst_int 24) dbg; + lsl_int b2 (Cconst_int 16) dbg], dbg); + Cop(Cor, [lsl_int b3 (Cconst_int 8) dbg; b4], dbg)], + dbg) -let unaligned_set_32 ptr idx newval = +let unaligned_set_32 ptr idx newval dbg = if Arch.allow_unaligned_access - then Cop(Cstore Thirtytwo_unsigned, [add_int ptr idx; newval]) + then + Cop(Cstore (Thirtytwo_unsigned, Assignment), [add_int ptr idx dbg; newval], + dbg) else let v1 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int 24]); Cconst_int 0xFF]) in + Cop(Cand, [Cop(Clsr, [newval; Cconst_int 24], dbg); Cconst_int 0xFF], dbg) + in let v2 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int 16]); Cconst_int 0xFF]) in + Cop(Cand, [Cop(Clsr, [newval; Cconst_int 16], dbg); Cconst_int 0xFF], dbg) + in let v3 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8]); Cconst_int 0xFF]) in - let v4 = Cop(Cand, [newval; Cconst_int 0xFF]) in + Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8], dbg); Cconst_int 0xFF], dbg) + in + let v4 = Cop(Cand, [newval; Cconst_int 0xFF], dbg) in let b1, b2, b3, b4 = if Arch.big_endian then v1, v2, v3, v4 else v4, v3, v2, v1 in Csequence( Csequence( - Cop(Cstore Byte_unsigned, [add_int ptr idx; b1]), - Cop(Cstore Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 1); b2])), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int ptr idx dbg; b1], dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg; b2], dbg)), Csequence( - Cop(Cstore Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 2); b3]), - Cop(Cstore Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 3); b4]))) + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg; b3], dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg; b4], dbg))) -let unaligned_load_64 ptr idx = +let unaligned_load_64 ptr idx dbg = assert(size_int = 8); if Arch.allow_unaligned_access - then Cop(Cload Word, [add_int ptr idx]) + then Cop(Cload (Word_int, Mutable), [add_int ptr idx dbg], dbg) else - let v1 = Cop(Cload Byte_unsigned, [add_int ptr idx]) in - let v2 = Cop(Cload Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 1)]) in - let v3 = Cop(Cload Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 2)]) in - let v4 = Cop(Cload Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 3)]) in - let v5 = Cop(Cload Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 4)]) in - let v6 = Cop(Cload Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 5)]) in - let v7 = Cop(Cload Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 6)]) in - let v8 = Cop(Cload Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 7)]) in + let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in + let v2 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg], dbg) in + let v3 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg], dbg) in + let v4 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg], dbg) in + let v5 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (Cconst_int 4) dbg], dbg) in + let v6 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (Cconst_int 5) dbg], dbg) in + let v7 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (Cconst_int 6) dbg], dbg) in + let v8 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (Cconst_int 7) dbg], dbg) in let b1, b2, b3, b4, b5, b6, b7, b8 = if Arch.big_endian then v1, v2, v3, v4, v5, v6, v7, v8 else v8, v7, v6, v5, v4, v3, v2, v1 in Cop(Cor, [Cop(Cor, - [Cop(Cor, [lsl_int b1 (Cconst_int (8*7)); - lsl_int b2 (Cconst_int (8*6))]); - Cop(Cor, [lsl_int b3 (Cconst_int (8*5)); - lsl_int b4 (Cconst_int (8*4))])]); + [Cop(Cor, [lsl_int b1 (Cconst_int (8*7)) dbg; + lsl_int b2 (Cconst_int (8*6)) dbg], dbg); + Cop(Cor, [lsl_int b3 (Cconst_int (8*5)) dbg; + lsl_int b4 (Cconst_int (8*4)) dbg], dbg)], + dbg); Cop(Cor, - [Cop(Cor, [lsl_int b5 (Cconst_int (8*3)); - lsl_int b6 (Cconst_int (8*2))]); - Cop(Cor, [lsl_int b7 (Cconst_int 8); - b8])])]) + [Cop(Cor, [lsl_int b5 (Cconst_int (8*3)) dbg; + lsl_int b6 (Cconst_int (8*2)) dbg], dbg); + Cop(Cor, [lsl_int b7 (Cconst_int 8) dbg; + b8], dbg)], + dbg)], dbg) -let unaligned_set_64 ptr idx newval = +let unaligned_set_64 ptr idx newval dbg = assert(size_int = 8); if Arch.allow_unaligned_access - then Cop(Cstore Word, [add_int ptr idx; newval]) + then Cop(Cstore (Word_int, Assignment), [add_int ptr idx dbg; newval], dbg) else let v1 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*7)]); Cconst_int 0xFF]) in + Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*7)], dbg); Cconst_int 0xFF], + dbg) + in let v2 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*6)]); Cconst_int 0xFF]) in + Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*6)], dbg); Cconst_int 0xFF], + dbg) + in let v3 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*5)]); Cconst_int 0xFF]) in + Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*5)], dbg); Cconst_int 0xFF], + dbg) + in let v4 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*4)]); Cconst_int 0xFF]) in + Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*4)], dbg); Cconst_int 0xFF], + dbg) + in let v5 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*3)]); Cconst_int 0xFF]) in + Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*3)], dbg); Cconst_int 0xFF], + dbg) + in let v6 = - Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*2)]); Cconst_int 0xFF]) in - let v7 = Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8]); Cconst_int 0xFF]) in - let v8 = Cop(Cand, [newval; Cconst_int 0xFF]) in + Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*2)], dbg); Cconst_int 0xFF], + dbg) + in + let v7 = + Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8], dbg); Cconst_int 0xFF], + dbg) + in + let v8 = Cop(Cand, [newval; Cconst_int 0xFF], dbg) in let b1, b2, b3, b4, b5, b6, b7, b8 = if Arch.big_endian then v1, v2, v3, v4, v5, v6, v7, v8 @@ -804,34 +1247,56 @@ Csequence( Csequence( Csequence( - Cop(Cstore Byte_unsigned, [add_int ptr idx; b1]), - Cop(Cstore Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 1); b2])), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int ptr idx dbg; b1], + dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg; b2], + dbg)), Csequence( - Cop(Cstore Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 2); b3]), - Cop(Cstore Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 3); b4]))), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg; b3], + dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg; b4], + dbg))), Csequence( Csequence( - Cop(Cstore Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 4); b5]), - Cop(Cstore Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 5); b6])), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (Cconst_int 4) dbg; b5], + dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (Cconst_int 5) dbg; b6], + dbg)), Csequence( - Cop(Cstore Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 6); b7]), - Cop(Cstore Byte_unsigned, - [add_int (add_int ptr idx) (Cconst_int 7); b8])))) + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (Cconst_int 6) dbg; b7], + dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (Cconst_int 7) dbg; b8], + dbg)))) + +let max_or_zero a dbg = + bind "size" a (fun a -> + (* equivalent to + Cifthenelse(Cop(Ccmpi Cle, [a; Cconst_int 0]), Cconst_int 0, a) + + if a is positive, sign is 0 hence sign_negation is full of 1 + so sign_negation&a = a + if a is negative, sign is full of 1 hence sign_negation is 0 + so sign_negation&a = 0 *) + let sign = Cop(Casr, [a; Cconst_int (size_int * 8 - 1)], dbg) in + let sign_negation = Cop(Cxor, [sign; Cconst_int (-1)], dbg) in + Cop(Cand, [sign_negation; a], dbg)) let check_bound unsafe dbg a1 a2 k = - if unsafe then k else Csequence(make_checkbound dbg [a1;a2], k) + if unsafe then k + else Csequence(make_checkbound dbg [max_or_zero a1 dbg; a2], k) (* Simplification of some primitives into C calls *) let default_prim name = - { prim_name = name; prim_arity = 0 (*ignored*); - prim_alloc = true; prim_native_name = ""; prim_native_float = false } + Primitive.simple ~name ~arity:0(*ignored*) ~alloc:true let simplif_primitive_32bits = function Pbintofint Pint64 -> Pccall (default_prim "caml_int64_of_int") @@ -846,8 +1311,8 @@ | Paddbint Pint64 -> Pccall (default_prim "caml_int64_add") | Psubbint Pint64 -> Pccall (default_prim "caml_int64_sub") | Pmulbint Pint64 -> Pccall (default_prim "caml_int64_mul") - | Pdivbint Pint64 -> Pccall (default_prim "caml_int64_div") - | Pmodbint Pint64 -> Pccall (default_prim "caml_int64_mod") + | Pdivbint {size=Pint64} -> Pccall (default_prim "caml_int64_div") + | Pmodbint {size=Pint64} -> Pccall (default_prim "caml_int64_mod") | Pandbint Pint64 -> Pccall (default_prim "caml_int64_and") | Porbint Pint64 -> Pccall (default_prim "caml_int64_or") | Pxorbint Pint64 -> Pccall (default_prim "caml_int64_xor") @@ -860,9 +1325,9 @@ | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan") | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal") | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal") - | Pbigarrayref(unsafe, n, Pbigarray_int64, layout) -> + | Pbigarrayref(_unsafe, n, Pbigarray_int64, _layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(unsafe, n, Pbigarray_int64, layout) -> + | Pbigarrayset(_unsafe, n, Pbigarray_int64, _layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | Pstring_load_64(_) -> Pccall (default_prim "caml_string_get64") | Pstring_set_64(_) -> Pccall (default_prim "caml_string_set64") @@ -875,41 +1340,49 @@ match p with | Pduprecord _ -> Pccall (default_prim "caml_obj_dup") - | Pbigarrayref(unsafe, n, Pbigarray_unknown, layout) -> + | Pbigarrayref(_unsafe, n, Pbigarray_unknown, _layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(unsafe, n, Pbigarray_unknown, layout) -> + | Pbigarrayset(_unsafe, n, Pbigarray_unknown, _layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) - | Pbigarrayref(unsafe, n, kind, Pbigarray_unknown_layout) -> + | Pbigarrayref(_unsafe, n, _kind, Pbigarray_unknown_layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(unsafe, n, kind, Pbigarray_unknown_layout) -> + | Pbigarrayset(_unsafe, n, _kind, Pbigarray_unknown_layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | p -> if size_int = 8 then p else simplif_primitive_32bits p (* Build switchers both for constants and blocks *) -(* constants first *) - -let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg])) +let transl_isout h arg dbg = tag_int (Cop(Ccmpa Clt, [h ; arg], dbg)) dbg -let make_switch_gen arg cases acts = - let lcases = Array.length cases in - let new_cases = Array.create lcases 0 in - let store = Switch.mk_store (=) in - - for i = 0 to Array.length cases-1 do - let act = cases.(i) in - let new_act = store.Switch.act_store act in - new_cases.(i) <- new_act - done ; - Cswitch - (arg, new_cases, - Array.map - (fun n -> acts.(n)) - (store.Switch.act_get ())) +(* Build an actual switch (ie jump table) *) - -(* Then for blocks *) +let make_switch arg cases actions dbg = + let is_const = function + (* Constant integers loaded from a table should end in 1, + so that Cload never produces untagged integers *) + | Cconst_int n + | Cconst_pointer n -> (n land 1) = 1 + | Cconst_natint n + | Cconst_natpointer n -> (Nativeint.(to_int (logand n one) = 1)) + | Cconst_symbol _ -> true + | _ -> false in + if Array.for_all is_const actions then + let to_data_item = function + | Cconst_int n + | Cconst_pointer n -> Cint (Nativeint.of_int n) + | Cconst_natint n + | Cconst_natpointer n -> Cint n + | Cconst_symbol s -> Csymbol_address s + | _ -> assert false in + let const_actions = Array.map to_data_item actions in + let table = Compilenv.new_const_symbol () in + add_cmm_constant (Const_table ((table, Not_global), + Array.to_list (Array.map (fun act -> + const_actions.(act)) cases))); + addr_array_ref (Cconst_symbol table) (tag_int arg dbg) dbg + else + Cswitch (arg,cases,actions,dbg) module SArgBlocks = struct @@ -924,117 +1397,247 @@ type act = expression - let default = Cexit (0,[]) - let make_prim p args = Cop (p,args) - let make_offset arg n = add_const arg n - let make_isout h arg = Cop (Ccmpa Clt, [h ; arg]) - let make_isin h arg = Cop (Ccmpa Cge, [h ; arg]) + let make_const i = Cconst_int i + (* CR mshinwell: fix debuginfo *) + let make_prim p args = Cop (p,args, Debuginfo.none) + let make_offset arg n = add_const arg n Debuginfo.none + let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none) + let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none) let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot) let make_switch arg cases actions = - make_switch_gen arg cases actions + make_switch arg cases actions Debuginfo.none let bind arg body = bind "switcher" arg body + let make_catch handler = match handler with + | Cexit (i,[]) -> i,fun e -> e + | _ -> + let i = next_raise_count () in +(* + Printf.eprintf "SHARE CMM: %i\n" i ; + Printcmm.expression Format.str_formatter handler ; + Printf.eprintf "%s\n" (Format.flush_str_formatter ()) ; +*) + i, + (fun body -> match body with + | Cexit (j,_) -> + if i=j then handler + else body + | _ -> ccatch (i,[],body,handler)) + + let make_exit i = Cexit (i,[]) + end +(* cmm store, as sharing as normally been detected in previous + phases, we only share exits *) +module StoreExp = + Switch.Store + (struct + type t = expression + type key = int + let make_key = function + | Cexit (i,[]) -> Some i + | _ -> None + end) + module SwitcherBlocks = Switch.Make(SArgBlocks) +(* Int switcher, arg in [low..high], + cases is list of individual cases, and is sorted by first component *) + +let transl_int_switch arg low high cases default = match cases with +| [] -> assert false +| _::_ -> + let store = StoreExp.mk_store () in + assert (store.Switch.act_store default = 0) ; + let cases = + List.map + (fun (i,act) -> i,store.Switch.act_store act) + cases in + let rec inters plow phigh pact = function + | [] -> + if phigh = high then [plow,phigh,pact] + else [(plow,phigh,pact); (phigh+1,high,0) ] + | (i,act)::rem -> + if i = phigh+1 then + if pact = act then + inters plow i pact rem + else + (plow,phigh,pact)::inters i i act rem + else (* insert default *) + if pact = 0 then + if act = 0 then + inters plow i 0 rem + else + (plow,i-1,pact):: + inters i i act rem + else (* pact <> 0 *) + (plow,phigh,pact):: + begin + if act = 0 then inters (phigh+1) i 0 rem + else (phigh+1,i-1,0)::inters i i act rem + end in + let inters = match cases with + | [] -> assert false + | (k0,act0)::rem -> + if k0 = low then inters k0 k0 act0 rem + else inters low (k0-1) 0 cases in + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + (low,high) + a + (Array.of_list inters) store) + + (* Auxiliary functions for optimizing "let" of boxed numbers (floats and boxed integers *) type unboxed_number_kind = No_unboxing - | Boxed_float - | Boxed_integer of boxed_integer + | Boxed of boxed_number * bool (* true: boxed form available at no cost *) + | No_result (* expression never returns a result *) -let is_unboxed_number = function - Uconst(Const_base(Const_float f), _) -> - Boxed_float - | Uprim(p, _, _) -> +let unboxed_number_kind_of_unbox dbg = function + | Same_as_ocaml_repr -> No_unboxing + | Unboxed_float -> Boxed (Boxed_float dbg, false) + | Unboxed_integer bi -> Boxed (Boxed_integer (bi, dbg), false) + | Untagged_int -> No_unboxing + +let rec is_unboxed_number ~strict env e = + (* Given unboxed_number_kind from two branches of the code, returns the + resulting unboxed_number_kind. + + If [strict=false], one knows that the type of the expression + is an unboxable number, and we decide to return an unboxed value + if this indeed eliminates at least one allocation. + + If [strict=true], we need to ensure that all possible branches + return an unboxable number (of the same kind). This could not + be the case in presence of GADTs. + *) + let join k1 e = + match k1, is_unboxed_number ~strict env e with + | Boxed (b1, c1), Boxed (b2, c2) when equal_boxed_number b1 b2 -> + Boxed (b1, c1 && c2) + | No_result, k | k, No_result -> + k (* if a branch never returns, it is safe to unbox it *) + | No_unboxing, k | k, No_unboxing when not strict -> + k + | _, _ -> No_unboxing + in + match e with + | Uvar id -> + begin match is_unboxed_id id env with + | None -> No_unboxing + | Some (_, bn) -> Boxed (bn, false) + end + + | Uconst(Uconst_ref(_, Some (Uconst_float _))) -> + Boxed (Boxed_float Debuginfo.none, true) + | Uconst(Uconst_ref(_, Some (Uconst_int32 _))) -> + Boxed (Boxed_integer (Pint32, Debuginfo.none), true) + | Uconst(Uconst_ref(_, Some (Uconst_int64 _))) -> + Boxed (Boxed_integer (Pint64, Debuginfo.none), true) + | Uconst(Uconst_ref(_, Some (Uconst_nativeint _))) -> + Boxed (Boxed_integer (Pnativeint, Debuginfo.none), true) + | Uprim(p, _, dbg) -> begin match simplif_primitive p with - Pccall p -> if p.prim_native_float then Boxed_float else No_unboxing - | Pfloatfield _ -> Boxed_float - | Pfloatofint -> Boxed_float - | Pnegfloat -> Boxed_float - | Pabsfloat -> Boxed_float - | Paddfloat -> Boxed_float - | Psubfloat -> Boxed_float - | Pmulfloat -> Boxed_float - | Pdivfloat -> Boxed_float - | Parrayrefu Pfloatarray -> Boxed_float - | Parrayrefs Pfloatarray -> Boxed_float - | Pbintofint bi -> Boxed_integer bi - | Pcvtbint(src, dst) -> Boxed_integer dst - | Pnegbint bi -> Boxed_integer bi - | Paddbint bi -> Boxed_integer bi - | Psubbint bi -> Boxed_integer bi - | Pmulbint bi -> Boxed_integer bi - | Pdivbint bi -> Boxed_integer bi - | Pmodbint bi -> Boxed_integer bi - | Pandbint bi -> Boxed_integer bi - | Porbint bi -> Boxed_integer bi - | Pxorbint bi -> Boxed_integer bi - | Plslbint bi -> Boxed_integer bi - | Plsrbint bi -> Boxed_integer bi - | Pasrbint bi -> Boxed_integer bi + | Pccall p -> unboxed_number_kind_of_unbox dbg p.prim_native_repr_res + | Pfloatfield _ + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat + | Parrayrefu Pfloatarray + | Parrayrefs Pfloatarray -> Boxed (Boxed_float dbg, false) + | Pbintofint bi + | Pcvtbint(_, bi) + | Pnegbint bi + | Paddbint bi + | Psubbint bi + | Pmulbint bi + | Pdivbint {size=bi} + | Pmodbint {size=bi} + | Pandbint bi + | Porbint bi + | Pxorbint bi + | Plslbint bi + | Plsrbint bi + | Pasrbint bi + | Pbbswap bi -> Boxed (Boxed_integer (bi, dbg), false) | Pbigarrayref(_, _, (Pbigarray_float32 | Pbigarray_float64), _) -> - Boxed_float - | Pbigarrayref(_, _, Pbigarray_int32, _) -> Boxed_integer Pint32 - | Pbigarrayref(_, _, Pbigarray_int64, _) -> Boxed_integer Pint64 - | Pbigarrayref(_, _, Pbigarray_native_int,_) -> Boxed_integer Pnativeint - | Pstring_load_32(_) -> Boxed_integer Pint32 - | Pstring_load_64(_) -> Boxed_integer Pint64 - | Pbigstring_load_32(_) -> Boxed_integer Pint32 - | Pbigstring_load_64(_) -> Boxed_integer Pint64 - | Pbbswap bi -> Boxed_integer bi + Boxed (Boxed_float dbg, false) + | Pbigarrayref(_, _, Pbigarray_int32, _) -> + Boxed (Boxed_integer (Pint32, dbg), false) + | Pbigarrayref(_, _, Pbigarray_int64, _) -> + Boxed (Boxed_integer (Pint64, dbg), false) + | Pbigarrayref(_, _, Pbigarray_native_int,_) -> + Boxed (Boxed_integer (Pnativeint, dbg), false) + | Pstring_load_32(_) -> Boxed (Boxed_integer (Pint32, dbg), false) + | Pstring_load_64(_) -> Boxed (Boxed_integer (Pint64, dbg), false) + | Pbigstring_load_32(_) -> Boxed (Boxed_integer (Pint32, dbg), false) + | Pbigstring_load_64(_) -> Boxed (Boxed_integer (Pint64, dbg), false) + | Praise _ -> No_result | _ -> No_unboxing end + | Ulet (_, _, _, _, e) | Uletrec (_, e) | Usequence (_, e) -> + is_unboxed_number ~strict env e + | Uswitch (_, switch) -> + let k = Array.fold_left join No_result switch.us_actions_consts in + Array.fold_left join k switch.us_actions_blocks + | Ustringswitch (_, actions, default_opt) -> + let k = List.fold_left (fun k (_, e) -> join k e) No_result actions in + begin match default_opt with + None -> k + | Some default -> join k default + end + | Ustaticfail _ -> No_result + | Uifthenelse (_, e1, e2) | Ucatch (_, _, e1, e2) | Utrywith (e1, _, e2) -> + join (is_unboxed_number ~strict env e1) e2 | _ -> No_unboxing -let subst_boxed_number unbox_fn boxed_id unboxed_id exp = - let need_boxed = ref false in - let assigned = ref false in - let rec subst = function - Cvar id as e -> - if Ident.same id boxed_id then need_boxed := true; e - | Clet(id, arg, body) -> Clet(id, subst arg, subst body) - | Cassign(id, arg) -> - if Ident.same id boxed_id then begin - assigned := true; - Cassign(unboxed_id, subst(unbox_fn arg)) - end else - Cassign(id, subst arg) - | Ctuple argv -> Ctuple(List.map subst argv) - | Cop(Cload _, [Cvar id]) as e -> - if Ident.same id boxed_id then Cvar unboxed_id else e - | Cop(Cload _, [Cop(Cadda, [Cvar id; _])]) as e -> - if Ident.same id boxed_id then Cvar unboxed_id else e - | Cop(op, argv) -> Cop(op, List.map subst argv) - | Csequence(e1, e2) -> Csequence(subst e1, subst e2) - | Cifthenelse(e1, e2, e3) -> Cifthenelse(subst e1, subst e2, subst e3) - | Cswitch(arg, index, cases) -> - Cswitch(subst arg, index, Array.map subst cases) - | Cloop e -> Cloop(subst e) - | Ccatch(nfail, ids, e1, e2) -> Ccatch(nfail, ids, subst e1, subst e2) - | Cexit (nfail, el) -> Cexit (nfail, List.map subst el) - | Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2) - | e -> e in - let res = subst exp in - (res, !need_boxed, !assigned) +(* Helper for compilation of initialization and assignment operations *) + +type assignment_kind = Caml_modify | Caml_initialize | Simple + +let assignment_kind ptr init = + match init, ptr with + | Assignment, Pointer -> Caml_modify + | Heap_initialization, Pointer -> Caml_initialize + | Assignment, Immediate + | Heap_initialization, Immediate + | Root_initialization, (Immediate | Pointer) -> Simple (* Translate an expression *) let functions = (Queue.create() : ufunction Queue.t) -let rec transl = function +let strmatch_compile = + let module S = + Strmatch.Make + (struct + let string_block_length ptr = get_size ptr Debuginfo.none + let transl_switch = transl_int_switch + end) in + S.compile + +let rec transl env e = + match e with Uvar id -> - Cvar id - | Uconst (sc, Some const_label) -> - Cconst_symbol const_label - | Uconst (sc, None) -> + begin match is_unboxed_id id env with + | None -> Cvar id + | Some (unboxed_id, bn) -> box_number bn (Cvar unboxed_id) + end + | Uconst sc -> transl_constant sc | Uclosure(fundecls, []) -> let lbl = Compilenv.new_const_symbol() in - constant_closures := (lbl, fundecls) :: !constant_closures; + add_cmm_constant ( + Const_closure ((lbl, Not_global), fundecls, [])); List.iter (fun f -> Queue.add f functions) fundecls; Cconst_symbol lbl | Uclosure(fundecls, clos_vars) -> @@ -1042,17 +1645,17 @@ fundecls_size fundecls + List.length clos_vars in let rec transl_fundecls pos = function [] -> - List.map transl clos_vars + List.map (transl env) clos_vars | f :: rem -> Queue.add f functions; let header = if pos = 0 - then alloc_closure_header block_size - else alloc_infix_header pos in - if f.arity = 1 then + then alloc_closure_header block_size f.dbg + else alloc_infix_header pos f.dbg in + if f.arity = 1 || f.arity = 0 then header :: Cconst_symbol f.label :: - int_const 1 :: + int_const f.arity :: transl_fundecls (pos + 3) rem else header :: @@ -1060,717 +1663,966 @@ int_const f.arity :: Cconst_symbol f.label :: transl_fundecls (pos + 4) rem in - Cop(Calloc, transl_fundecls 0 fundecls) + Cop(Calloc, transl_fundecls 0 fundecls, Debuginfo.none) | Uoffset(arg, offset) -> - field_address (transl arg) offset + (* produces a valid Caml value, pointing just after an infix header *) + let ptr = transl env arg in + if offset = 0 + then ptr + else Cop(Caddv, [ptr; Cconst_int(offset * size_addr)], Debuginfo.none) | Udirect_apply(lbl, args, dbg) -> - Cop(Capply(typ_addr, dbg), Cconst_symbol lbl :: List.map transl args) + Cop(Capply typ_val, Cconst_symbol lbl :: List.map (transl env) args, dbg) | Ugeneric_apply(clos, [arg], dbg) -> - bind "fun" (transl clos) (fun clos -> - Cop(Capply(typ_addr, dbg), [get_field clos 0; transl arg; clos])) + bind "fun" (transl env clos) (fun clos -> + Cop(Capply typ_val, [get_field env clos 0 dbg; transl env arg; clos], + dbg)) | Ugeneric_apply(clos, args, dbg) -> let arity = List.length args in let cargs = Cconst_symbol(apply_function arity) :: - List.map transl (args @ [clos]) in - Cop(Capply(typ_addr, dbg), cargs) + List.map (transl env) (args @ [clos]) in + Cop(Capply typ_val, cargs, dbg) | Usend(kind, met, obj, args, dbg) -> let call_met obj args clos = if args = [] then - Cop(Capply(typ_addr, dbg), [get_field clos 0;obj;clos]) + Cop(Capply typ_val, [get_field env clos 0 dbg; obj; clos], dbg) else let arity = List.length args + 1 in let cargs = Cconst_symbol(apply_function arity) :: obj :: - (List.map transl args) @ [clos] in - Cop(Capply(typ_addr, dbg), cargs) + (List.map (transl env) args) @ [clos] in + Cop(Capply typ_val, cargs, dbg) in - bind "obj" (transl obj) (fun obj -> + bind "obj" (transl env obj) (fun obj -> match kind, args with Self, _ -> - bind "met" (lookup_label obj (transl met)) (call_met obj args) + bind "met" (lookup_label obj (transl env met) dbg) + (call_met obj args) | Cached, cache :: pos :: args -> - call_cached_method obj (transl met) (transl cache) (transl pos) - (List.map transl args) dbg + call_cached_method obj + (transl env met) (transl env cache) (transl env pos) + (List.map (transl env) args) dbg | _ -> - bind "met" (lookup_tag obj (transl met)) (call_met obj args)) - | Ulet(id, exp, body) -> - begin match is_unboxed_number exp with - No_unboxing -> - Clet(id, transl exp, transl body) - | Boxed_float -> - transl_unbox_let box_float unbox_float transl_unbox_float - id exp body - | Boxed_integer bi -> - transl_unbox_let (box_int bi) (unbox_int bi) (transl_unbox_int bi) - id exp body - end + bind "met" (lookup_tag obj (transl env met) dbg) + (call_met obj args)) + | Ulet(str, kind, id, exp, body) -> + transl_let env str kind id exp body | Uletrec(bindings, body) -> - transl_letrec bindings (transl body) + transl_letrec env bindings (transl env body) (* Primitives *) | Uprim(prim, args, dbg) -> begin match (simplif_primitive prim, args) with (Pgetglobal id, []) -> Cconst_symbol (Ident.name id) - | (Pmakeblock(tag, mut), []) -> - transl_constant(Const_block(tag, [])) - | (Pmakeblock(tag, mut), args) -> - make_alloc tag (List.map transl args) + | (Pmakeblock _, []) -> + assert false + | (Pmakeblock(tag, _mut, _kind), args) -> + make_alloc dbg tag (List.map (transl env) args) | (Pccall prim, args) -> - if prim.prim_native_float then - box_float - (Cop(Cextcall(prim.prim_native_name, typ_float, false, dbg), - List.map transl_unbox_float args)) - else - Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc, - dbg), - List.map transl args) - | (Pmakearray kind, []) -> - transl_constant(Const_block(0, [])) - | (Pmakearray kind, args) -> - begin match kind with - Pgenarray -> - Cop(Cextcall("caml_make_array", typ_addr, true, Debuginfo.none), - [make_alloc 0 (List.map transl args)]) - | Paddrarray | Pintarray -> - make_alloc 0 (List.map transl args) - | Pfloatarray -> - make_float_alloc Obj.double_array_tag - (List.map transl_unbox_float args) - end - | (Pbigarrayref(unsafe, num_dims, elt_kind, layout), arg1 :: argl) -> + transl_ccall env prim args dbg + | (Pduparray (kind, _), [Uprim (Pmakearray (kind', _), args, _dbg)]) -> + (* We arrive here in two cases: + 1. When using Closure, all the time. + 2. When using Flambda, if a float array longer than + [Translcore.use_dup_for_constant_arrays_bigger_than] turns out + to be non-constant. + If for some reason Flambda fails to lift a constant array we + could in theory also end up here. + Note that [kind] above is unconstrained, but with the current + state of [Translcore], we will in fact only get here with + [Pfloatarray]s. *) + assert (kind = kind'); + transl_make_array dbg env kind args + | (Pduparray _, [arg]) -> + let prim_obj_dup = + Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true + in + transl_ccall env prim_obj_dup [arg] dbg + | (Pmakearray _, []) -> + transl_structured_constant (Uconst_block(0, [])) + | (Pmakearray (kind, _), args) -> transl_make_array dbg env kind args + | (Pbigarrayref(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) -> let elt = bigarray_get unsafe elt_kind layout - (transl arg1) (List.map transl argl) dbg in + (transl env arg1) (List.map (transl env) argl) dbg in begin match elt_kind with - Pbigarray_float32 | Pbigarray_float64 -> box_float elt + Pbigarray_float32 | Pbigarray_float64 -> box_float dbg elt | Pbigarray_complex32 | Pbigarray_complex64 -> elt - | Pbigarray_int32 -> box_int Pint32 elt - | Pbigarray_int64 -> box_int Pint64 elt - | Pbigarray_native_int -> box_int Pnativeint elt - | Pbigarray_caml_int -> force_tag_int elt - | _ -> tag_int elt + | Pbigarray_int32 -> box_int dbg Pint32 elt + | Pbigarray_int64 -> box_int dbg Pint64 elt + | Pbigarray_native_int -> box_int dbg Pnativeint elt + | Pbigarray_caml_int -> force_tag_int elt dbg + | _ -> tag_int elt dbg end - | (Pbigarrayset(unsafe, num_dims, elt_kind, layout), arg1 :: argl) -> + | (Pbigarrayset(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) -> let (argidx, argnewval) = split_last argl in return_unit(bigarray_set unsafe elt_kind layout - (transl arg1) - (List.map transl argidx) + (transl env arg1) + (List.map (transl env) argidx) (match elt_kind with Pbigarray_float32 | Pbigarray_float64 -> - transl_unbox_float argnewval - | Pbigarray_complex32 | Pbigarray_complex64 -> transl argnewval - | Pbigarray_int32 -> transl_unbox_int Pint32 argnewval - | Pbigarray_int64 -> transl_unbox_int Pint64 argnewval - | Pbigarray_native_int -> transl_unbox_int Pnativeint argnewval - | _ -> untag_int (transl argnewval)) + transl_unbox_float dbg env argnewval + | Pbigarray_complex32 | Pbigarray_complex64 -> transl env argnewval + | Pbigarray_int32 -> transl_unbox_int dbg env Pint32 argnewval + | Pbigarray_int64 -> transl_unbox_int dbg env Pint64 argnewval + | Pbigarray_native_int -> + transl_unbox_int dbg env Pnativeint argnewval + | _ -> untag_int (transl env argnewval) dbg) dbg) | (Pbigarraydim(n), [b]) -> let dim_ofs = 4 + n in - tag_int (Cop(Cload Word, [field_address (transl b) dim_ofs])) + tag_int (Cop(Cload (Word_int, Mutable), + [field_address (transl env b) dim_ofs dbg], + dbg)) dbg | (p, [arg]) -> - transl_prim_1 p arg dbg + transl_prim_1 env p arg dbg | (p, [arg1; arg2]) -> - transl_prim_2 p arg1 arg2 dbg + transl_prim_2 env p arg1 arg2 dbg | (p, [arg1; arg2; arg3]) -> - transl_prim_3 p arg1 arg2 arg3 dbg + transl_prim_3 env p arg1 arg2 arg3 dbg | (_, _) -> fatal_error "Cmmgen.transl:prim" end (* Control structures *) | Uswitch(arg, s) -> + let dbg = Debuginfo.none in (* As in the bytecode interpreter, only matching against constants can be checked *) if Array.length s.us_index_blocks = 0 then - Cswitch - (untag_int (transl arg), - s.us_index_consts, - Array.map transl s.us_actions_consts) + make_switch + (untag_int (transl env arg) dbg) + s.us_index_consts + (Array.map (transl env) s.us_actions_consts) + dbg else if Array.length s.us_index_consts = 0 then - transl_switch (get_tag (transl arg)) + transl_switch dbg env (get_tag (transl env arg) dbg) s.us_index_blocks s.us_actions_blocks else - bind "switch" (transl arg) (fun arg -> + bind "switch" (transl env arg) (fun arg -> Cifthenelse( - Cop(Cand, [arg; Cconst_int 1]), - transl_switch - (untag_int arg) s.us_index_consts s.us_actions_consts, - transl_switch - (get_tag arg) s.us_index_blocks s.us_actions_blocks)) + Cop(Cand, [arg; Cconst_int 1], dbg), + transl_switch dbg env + (untag_int arg dbg) s.us_index_consts s.us_actions_consts, + transl_switch dbg env + (get_tag arg dbg) s.us_index_blocks s.us_actions_blocks)) + | Ustringswitch(arg,sw,d) -> + let dbg = Debuginfo.none in + bind "switch" (transl env arg) + (fun arg -> + strmatch_compile dbg arg (Misc.may_map (transl env) d) + (List.map (fun (s,act) -> s,transl env act) sw)) | Ustaticfail (nfail, args) -> - Cexit (nfail, List.map transl args) + Cexit (nfail, List.map (transl env) args) | Ucatch(nfail, [], body, handler) -> - make_catch nfail (transl body) (transl handler) + make_catch nfail (transl env body) (transl env handler) | Ucatch(nfail, ids, body, handler) -> - Ccatch(nfail, ids, transl body, transl handler) + ccatch(nfail, ids, transl env body, transl env handler) | Utrywith(body, exn, handler) -> - Ctrywith(transl body, exn, transl handler) + Ctrywith(transl env body, exn, transl env handler) | Uifthenelse(Uprim(Pnot, [arg], _), ifso, ifnot) -> - transl (Uifthenelse(arg, ifnot, ifso)) + transl env (Uifthenelse(arg, ifnot, ifso)) | Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) -> - exit_if_false cond (transl ifso) nfail + let dbg = Debuginfo.none in + exit_if_false dbg env cond (transl env ifso) nfail | Uifthenelse(cond, Ustaticfail (nfail, []), ifnot) -> - exit_if_true cond nfail (transl ifnot) - | Uifthenelse(Uprim(Psequand, _, _) as cond, ifso, ifnot) -> + let dbg = Debuginfo.none in + exit_if_true dbg env cond nfail (transl env ifnot) + | Uifthenelse(Uprim(Psequand, _, dbg) as cond, ifso, ifnot) -> let raise_num = next_raise_count () in make_catch raise_num - (exit_if_false cond (transl ifso) raise_num) - (transl ifnot) - | Uifthenelse(Uprim(Psequor, _, _) as cond, ifso, ifnot) -> + (exit_if_false dbg env cond (transl env ifso) raise_num) + (transl env ifnot) + | Uifthenelse(Uprim(Psequor, _, dbg) as cond, ifso, ifnot) -> let raise_num = next_raise_count () in make_catch raise_num - (exit_if_true cond raise_num (transl ifnot)) - (transl ifso) + (exit_if_true dbg env cond raise_num (transl env ifnot)) + (transl env ifso) | Uifthenelse (Uifthenelse (cond, condso, condnot), ifso, ifnot) -> + let dbg = Debuginfo.none in let num_true = next_raise_count () in make_catch num_true (make_catch2 (fun shared_false -> - Cifthenelse - (test_bool (transl cond), - exit_if_true condso num_true shared_false, - exit_if_true condnot num_true shared_false)) - (transl ifnot)) - (transl ifso) + if_then_else + (test_bool dbg (transl env cond), + exit_if_true dbg env condso num_true shared_false, + exit_if_true dbg env condnot num_true shared_false)) + (transl env ifnot)) + (transl env ifso) | Uifthenelse(cond, ifso, ifnot) -> - Cifthenelse(test_bool(transl cond), transl ifso, transl ifnot) + let dbg = Debuginfo.none in + if_then_else(test_bool dbg (transl env cond), transl env ifso, + transl env ifnot) | Usequence(exp1, exp2) -> - Csequence(remove_unit(transl exp1), transl exp2) + Csequence(remove_unit(transl env exp1), transl env exp2) | Uwhile(cond, body) -> + let dbg = Debuginfo.none in let raise_num = next_raise_count () in return_unit - (Ccatch + (ccatch (raise_num, [], - Cloop(exit_if_false cond (remove_unit(transl body)) raise_num), + Cloop(exit_if_false dbg env cond + (remove_unit(transl env body)) raise_num), Ctuple [])) | Ufor(id, low, high, dir, body) -> + let dbg = Debuginfo.none in let tst = match dir with Upto -> Cgt | Downto -> Clt in let inc = match dir with Upto -> Caddi | Downto -> Csubi in let raise_num = next_raise_count () in let id_prev = Ident.rename id in return_unit (Clet - (id, transl low, - bind_nonvar "bound" (transl high) (fun high -> - Ccatch + (id, transl env low, + bind_nonvar "bound" (transl env high) (fun high -> + ccatch (raise_num, [], Cifthenelse - (Cop(Ccmpi tst, [Cvar id; high]), Cexit (raise_num, []), + (Cop(Ccmpi tst, [Cvar id; high], dbg), + Cexit (raise_num, []), Cloop (Csequence - (remove_unit(transl body), + (remove_unit(transl env body), Clet(id_prev, Cvar id, Csequence (Cassign(id, - Cop(inc, [Cvar id; Cconst_int 2])), + Cop(inc, [Cvar id; Cconst_int 2], + dbg)), Cifthenelse - (Cop(Ccmpi Ceq, [Cvar id_prev; high]), + (Cop(Ccmpi Ceq, [Cvar id_prev; high], + dbg), Cexit (raise_num,[]), Ctuple [])))))), Ctuple [])))) | Uassign(id, exp) -> - return_unit(Cassign(id, transl exp)) + let dbg = Debuginfo.none in + begin match is_unboxed_id id env with + | None -> + return_unit (Cassign(id, transl env exp)) + | Some (unboxed_id, bn) -> + return_unit(Cassign(unboxed_id, + transl_unbox_number dbg env bn exp)) + end + | Uunreachable -> + let dbg = Debuginfo.none in + Cop(Cload (Word_int, Mutable), [Cconst_int 0], dbg) + +and transl_make_array dbg env kind args = + match kind with + | Pgenarray -> + Cop(Cextcall("caml_make_array", typ_val, true, None), + [make_alloc dbg 0 (List.map (transl env) args)], dbg) + | Paddrarray | Pintarray -> + make_alloc dbg 0 (List.map (transl env) args) + | Pfloatarray -> + make_float_alloc dbg Obj.double_array_tag + (List.map (transl_unbox_float dbg env) args) + +and transl_ccall env prim args dbg = + let transl_arg native_repr arg = + match native_repr with + | Same_as_ocaml_repr -> transl env arg + | Unboxed_float -> transl_unbox_float dbg env arg + | Unboxed_integer bi -> transl_unbox_int dbg env bi arg + | Untagged_int -> untag_int (transl env arg) dbg + in + let rec transl_args native_repr_args args = + match native_repr_args, args with + | [], args -> + (* We don't require the two lists to be of the same length as + [default_prim] always sets the arity to [0]. *) + List.map (transl env) args + | _, [] -> assert false + | native_repr :: native_repr_args, arg :: args -> + transl_arg native_repr arg :: transl_args native_repr_args args + in + let typ_res, wrap_result = + match prim.prim_native_repr_res with + | Same_as_ocaml_repr -> (typ_val, fun x -> x) + | Unboxed_float -> (typ_float, box_float dbg) + | Unboxed_integer Pint64 when size_int = 4 -> + ([|Int; Int|], box_int dbg Pint64) + | Unboxed_integer bi -> (typ_int, box_int dbg bi) + | Untagged_int -> (typ_int, (fun i -> tag_int i dbg)) + in + let args = transl_args prim.prim_native_repr_args args in + wrap_result + (Cop(Cextcall(Primitive.native_name prim, + typ_res, prim.prim_alloc, None), args, dbg)) -and transl_prim_1 p arg dbg = +and transl_prim_1 env p arg dbg = match p with (* Generic operations *) - Pidentity -> - transl arg + Pidentity | Pbytes_to_string | Pbytes_of_string | Popaque -> + transl env arg | Pignore -> - return_unit(remove_unit (transl arg)) + return_unit(remove_unit (transl env arg)) (* Heap operations *) | Pfield n -> - get_field (transl arg) n + get_field env (transl env arg) n dbg | Pfloatfield n -> - let ptr = transl arg in - box_float( - Cop(Cload Double_u, + let ptr = transl env arg in + box_float dbg ( + Cop(Cload (Double_u, Mutable), [if n = 0 then ptr - else Cop(Cadda, [ptr; Cconst_int(n * size_float)])])) + else Cop(Cadda, [ptr; Cconst_int(n * size_float)], dbg)], + dbg)) + | Pint_as_pointer -> + Cop(Caddi, [transl env arg; Cconst_int (-1)], dbg) + (* always a pointer outside the heap *) (* Exceptions *) - | Praise -> - Cop(Craise dbg, [transl arg]) + | Praise _ when not (!Clflags.debug) -> + Cop(Craise Cmm.Raise_notrace, [transl env arg], dbg) + | Praise Lambda.Raise_notrace -> + Cop(Craise Cmm.Raise_notrace, [transl env arg], dbg) + | Praise Lambda.Raise_reraise -> + Cop(Craise Cmm.Raise_withtrace, [transl env arg], dbg) + | Praise Lambda.Raise_regular -> + raise_regular dbg (transl env arg) (* Integer operations *) | Pnegint -> - Cop(Csubi, [Cconst_int 2; transl arg]) + Cop(Csubi, [Cconst_int 2; transl env arg], dbg) | Pctconst c -> - let const_of_bool b = tag_int (Cconst_int (if b then 1 else 0)) in + let const_of_bool b = tag_int (Cconst_int (if b then 1 else 0)) dbg in begin match c with | Big_endian -> const_of_bool Arch.big_endian - | Word_size -> tag_int (Cconst_int (8*Arch.size_int)) + | Word_size -> tag_int (Cconst_int (8*Arch.size_int)) dbg + | Int_size -> tag_int (Cconst_int ((8*Arch.size_int) - 1)) dbg + | Max_wosize -> + tag_int (Cconst_int ((1 lsl ((8*Arch.size_int) - 10)) - 1 )) dbg | Ostype_unix -> const_of_bool (Sys.os_type = "Unix") | Ostype_win32 -> const_of_bool (Sys.os_type = "Win32") | Ostype_cygwin -> const_of_bool (Sys.os_type = "Cygwin") + | Backend_type -> + tag_int (Cconst_int 0) dbg (* tag 0 is the same as Native here *) end | Poffsetint n -> - if no_overflow_lsl n then - add_const (transl arg) (n lsl 1) + if no_overflow_lsl n 1 then + add_const (transl env arg) (n lsl 1) dbg else - transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n), None)) + transl_prim_2 env Paddint arg (Uconst (Uconst_int n)) Debuginfo.none | Poffsetref n -> return_unit - (bind "ref" (transl arg) (fun arg -> - Cop(Cstore Word, - [arg; add_const (Cop(Cload Word, [arg])) (n lsl 1)]))) + (bind "ref" (transl env arg) (fun arg -> + Cop(Cstore (Word_int, Assignment), + [arg; + add_const (Cop(Cload (Word_int, Mutable), [arg], dbg)) + (n lsl 1) dbg], + dbg))) (* Floating-point operations *) | Pfloatofint -> - box_float(Cop(Cfloatofint, [untag_int(transl arg)])) + box_float dbg (Cop(Cfloatofint, [untag_int(transl env arg) dbg], dbg)) | Pintoffloat -> - tag_int(Cop(Cintoffloat, [transl_unbox_float arg])) + tag_int(Cop(Cintoffloat, [transl_unbox_float dbg env arg], dbg)) dbg | Pnegfloat -> - box_float(Cop(Cnegf, [transl_unbox_float arg])) + box_float dbg (Cop(Cnegf, [transl_unbox_float dbg env arg], dbg)) | Pabsfloat -> - box_float(Cop(Cabsf, [transl_unbox_float arg])) + box_float dbg (Cop(Cabsf, [transl_unbox_float dbg env arg], dbg)) (* String operations *) - | Pstringlength -> - tag_int(string_length (transl arg)) + | Pstringlength | Pbyteslength -> + tag_int(string_length (transl env arg) dbg) dbg (* Array operations *) | Parraylength kind -> + let hdr = get_header_without_profinfo (transl env arg) dbg in begin match kind with Pgenarray -> let len = if wordsize_shift = numfloat_shift then - Cop(Clsr, [header(transl arg); Cconst_int wordsize_shift]) + Cop(Clsr, [hdr; Cconst_int wordsize_shift], dbg) else - bind "header" (header(transl arg)) (fun hdr -> - Cifthenelse(is_addr_array_hdr hdr, - Cop(Clsr, [hdr; Cconst_int wordsize_shift]), - Cop(Clsr, [hdr; Cconst_int numfloat_shift]))) in - Cop(Cor, [len; Cconst_int 1]) + bind "header" hdr (fun hdr -> + Cifthenelse(is_addr_array_hdr hdr dbg, + Cop(Clsr, [hdr; Cconst_int wordsize_shift], dbg), + Cop(Clsr, [hdr; Cconst_int numfloat_shift], dbg))) in + Cop(Cor, [len; Cconst_int 1], dbg) | Paddrarray | Pintarray -> - Cop(Cor, [addr_array_length(header(transl arg)); Cconst_int 1]) + Cop(Cor, [addr_array_length hdr dbg; Cconst_int 1], dbg) | Pfloatarray -> - Cop(Cor, [float_array_length(header(transl arg)); Cconst_int 1]) + Cop(Cor, [float_array_length hdr dbg; Cconst_int 1], dbg) end (* Boolean operations *) | Pnot -> - Cop(Csubi, [Cconst_int 4; transl arg]) (* 1 -> 3, 3 -> 1 *) + Cop(Csubi, [Cconst_int 4; transl env arg], dbg) (* 1 -> 3, 3 -> 1 *) (* Test integer/block *) | Pisint -> - tag_int(Cop(Cand, [transl arg; Cconst_int 1])) + tag_int(Cop(Cand, [transl env arg; Cconst_int 1], dbg)) dbg (* Boxed integers *) | Pbintofint bi -> - box_int bi (untag_int (transl arg)) + box_int dbg bi (untag_int (transl env arg) dbg) | Pintofbint bi -> - force_tag_int (transl_unbox_int bi arg) + force_tag_int (transl_unbox_int dbg env bi arg) dbg | Pcvtbint(bi1, bi2) -> - box_int bi2 (transl_unbox_int bi1 arg) + box_int dbg bi2 (transl_unbox_int dbg env bi1 arg) | Pnegbint bi -> - box_int bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int bi arg])) + box_int dbg bi + (Cop(Csubi, [Cconst_int 0; transl_unbox_int dbg env bi arg], dbg)) | Pbbswap bi -> let prim = match bi with | Pnativeint -> "nativeint" | Pint32 -> "int32" | Pint64 -> "int64" in - box_int bi (Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim, - typ_int, false, Debuginfo.none), - [transl_unbox_int bi arg])) + box_int dbg bi (Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim, + typ_int, false, None), + [transl_unbox_int dbg env bi arg], + dbg)) | Pbswap16 -> - tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false, - Debuginfo.none), - [untag_int (transl arg)])) - | _ -> - fatal_error "Cmmgen.transl_prim_1" + tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false, None), + [untag_int (transl env arg) dbg], + dbg)) + dbg + | prim -> + fatal_errorf "Cmmgen.transl_prim_1: %a" Printlambda.primitive prim -and transl_prim_2 p arg1 arg2 dbg = +and transl_prim_2 env p arg1 arg2 dbg = match p with (* Heap operations *) - Psetfield(n, ptr) -> - if ptr then - return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none), - [field_address (transl arg1) n; transl arg2])) - else - return_unit(set_field (transl arg1) n (transl arg2)) - | Psetfloatfield n -> - let ptr = transl arg1 in + | Pfield_computed -> + addr_array_ref (transl env arg1) (transl env arg2) dbg + | Psetfield(n, ptr, init) -> + begin match assignment_kind ptr init with + | Caml_modify -> + return_unit(Cop(Cextcall("caml_modify", typ_void, false, None), + [field_address (transl env arg1) n dbg; + transl env arg2], + dbg)) + | Caml_initialize -> + return_unit(Cop(Cextcall("caml_initialize", typ_void, false, None), + [field_address (transl env arg1) n dbg; + transl env arg2], + dbg)) + | Simple -> + return_unit(set_field (transl env arg1) n (transl env arg2) init dbg) + end + | Psetfloatfield (n, init) -> + let ptr = transl env arg1 in return_unit( - Cop(Cstore Double_u, + Cop(Cstore (Double_u, init), [if n = 0 then ptr - else Cop(Cadda, [ptr; Cconst_int(n * size_float)]); - transl_unbox_float arg2])) + else Cop(Cadda, [ptr; Cconst_int(n * size_float)], dbg); + transl_unbox_float dbg env arg2], dbg)) (* Boolean operations *) | Psequand -> - Cifthenelse(test_bool(transl arg1), transl arg2, Cconst_int 1) + if_then_else(test_bool dbg (transl env arg1), + transl env arg2, Cconst_int 1) (* let id = Ident.create "res1" in - Clet(id, transl arg1, - Cifthenelse(test_bool(Cvar id), transl arg2, Cvar id)) *) + Clet(id, transl env arg1, + Cifthenelse(test_bool dbg (Cvar id), transl env arg2, Cvar id)) *) | Psequor -> - Cifthenelse(test_bool(transl arg1), Cconst_int 3, transl arg2) + if_then_else(test_bool dbg (transl env arg1), + Cconst_int 3, transl env arg2) (* Integer operations *) | Paddint -> - decr_int(add_int (transl arg1) (transl arg2)) + decr_int(add_int (transl env arg1) (transl env arg2) dbg) dbg | Psubint -> - incr_int(sub_int (transl arg1) (transl arg2)) + incr_int(sub_int (transl env arg1) (transl env arg2) dbg) dbg | Pmulint -> - incr_int(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)])) - | Pdivint -> - tag_int(safe_divmod Cdivi (untag_int(transl arg1)) - (untag_int(transl arg2)) dbg) - | Pmodint -> - tag_int(safe_divmod Cmodi (untag_int(transl arg1)) - (untag_int(transl arg2)) dbg) + begin + (* decrementing the non-constant part helps when the multiplication is + followed by an addition; + for example, using this trick compiles (100 * a + 7) into + (+ ( * a 100) -85) + rather than + (+ ( * 200 (>>s a 1)) 15) + *) + match transl env arg1, transl env arg2 with + | Cconst_int _ as c1, c2 -> + incr_int (mul_int (untag_int c1 dbg) (decr_int c2 dbg) dbg) dbg + | c1, c2 -> + incr_int (mul_int (decr_int c1 dbg) (untag_int c2 dbg) dbg) dbg + end + | Pdivint is_safe -> + tag_int(div_int (untag_int(transl env arg1) dbg) + (untag_int(transl env arg2) dbg) is_safe dbg) dbg + | Pmodint is_safe -> + tag_int(mod_int (untag_int(transl env arg1) dbg) + (untag_int(transl env arg2) dbg) is_safe dbg) dbg | Pandint -> - Cop(Cand, [transl arg1; transl arg2]) + Cop(Cand, [transl env arg1; transl env arg2], dbg) | Porint -> - Cop(Cor, [transl arg1; transl arg2]) + Cop(Cor, [transl env arg1; transl env arg2], dbg) | Pxorint -> - Cop(Cor, [Cop(Cxor, [ignore_low_bit_int(transl arg1); - ignore_low_bit_int(transl arg2)]); - Cconst_int 1]) + Cop(Cor, [Cop(Cxor, [ignore_low_bit_int(transl env arg1); + ignore_low_bit_int(transl env arg2)], dbg); + Cconst_int 1], dbg) | Plslint -> - incr_int(lsl_int (decr_int(transl arg1)) (untag_int(transl arg2))) + incr_int(lsl_int (decr_int(transl env arg1) dbg) + (untag_int(transl env arg2) dbg) dbg) dbg | Plsrint -> - Cop(Cor, [lsr_int (transl arg1) (untag_int(transl arg2)); - Cconst_int 1]) + Cop(Cor, [lsr_int (transl env arg1) (untag_int(transl env arg2) dbg) dbg; + Cconst_int 1], dbg) | Pasrint -> - Cop(Cor, [asr_int (transl arg1) (untag_int(transl arg2)); - Cconst_int 1]) + Cop(Cor, [asr_int (transl env arg1) (untag_int(transl env arg2) dbg) dbg; + Cconst_int 1], dbg) | Pintcomp cmp -> - tag_int(Cop(Ccmpi(transl_comparison cmp), [transl arg1; transl arg2])) + tag_int(Cop(Ccmpi(transl_comparison cmp), + [transl env arg1; transl env arg2], dbg)) dbg | Pisout -> - transl_isout (transl arg1) (transl arg2) + transl_isout (transl env arg1) (transl env arg2) dbg (* Float operations *) | Paddfloat -> - box_float(Cop(Caddf, - [transl_unbox_float arg1; transl_unbox_float arg2])) + box_float dbg (Cop(Caddf, + [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2], + dbg)) | Psubfloat -> - box_float(Cop(Csubf, - [transl_unbox_float arg1; transl_unbox_float arg2])) + box_float dbg (Cop(Csubf, + [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2], + dbg)) | Pmulfloat -> - box_float(Cop(Cmulf, - [transl_unbox_float arg1; transl_unbox_float arg2])) + box_float dbg (Cop(Cmulf, + [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2], + dbg)) | Pdivfloat -> - box_float(Cop(Cdivf, - [transl_unbox_float arg1; transl_unbox_float arg2])) + box_float dbg (Cop(Cdivf, + [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2], + dbg)) | Pfloatcomp cmp -> tag_int(Cop(Ccmpf(transl_comparison cmp), - [transl_unbox_float arg1; transl_unbox_float arg2])) + [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2], + dbg)) dbg (* String operations *) - | Pstringrefu -> - tag_int(Cop(Cload Byte_unsigned, - [add_int (transl arg1) (untag_int(transl arg2))])) - | Pstringrefs -> + | Pstringrefu | Pbytesrefu -> + tag_int(Cop(Cload (Byte_unsigned, Mutable), + [add_int (transl env arg1) (untag_int(transl env arg2) dbg) + dbg], + dbg)) dbg + | Pstringrefs | Pbytesrefs -> tag_int - (bind "str" (transl arg1) (fun str -> - bind "index" (untag_int (transl arg2)) (fun idx -> + (bind "str" (transl env arg1) (fun str -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> Csequence( - make_checkbound dbg [string_length str; idx], - Cop(Cload Byte_unsigned, [add_int str idx]))))) + make_checkbound dbg [string_length str dbg; idx], + Cop(Cload (Byte_unsigned, Mutable), + [add_int str idx dbg], dbg))))) dbg | Pstring_load_16(unsafe) -> tag_int - (bind "str" (transl arg1) (fun str -> - bind "index" (untag_int (transl arg2)) (fun idx -> - check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 1)) - idx (unaligned_load_16 str idx)))) + (bind "str" (transl env arg1) (fun str -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> + check_bound unsafe dbg + (sub_int (string_length str dbg) (Cconst_int 1) dbg) + idx (unaligned_load_16 str idx dbg)))) dbg | Pbigstring_load_16(unsafe) -> tag_int - (bind "ba" (transl arg1) (fun ba -> - bind "index" (untag_int (transl arg2)) (fun idx -> - bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data -> - check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5])) - (Cconst_int 1)) idx - (unaligned_load_16 ba_data idx))))) + (bind "ba" (transl env arg1) (fun ba -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> + bind "ba_data" + (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) + (fun ba_data -> + check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable), + [field_address ba 5 dbg], dbg)) + (Cconst_int 1) dbg) idx + (unaligned_load_16 ba_data idx dbg))))) dbg | Pstring_load_32(unsafe) -> - box_int Pint32 - (bind "str" (transl arg1) (fun str -> - bind "index" (untag_int (transl arg2)) (fun idx -> - check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 3)) - idx (unaligned_load_32 str idx)))) + box_int dbg Pint32 + (bind "str" (transl env arg1) (fun str -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> + check_bound unsafe dbg + (sub_int (string_length str dbg) (Cconst_int 3) dbg) + idx (unaligned_load_32 str idx dbg)))) | Pbigstring_load_32(unsafe) -> - box_int Pint32 - (bind "ba" (transl arg1) (fun ba -> - bind "index" (untag_int (transl arg2)) (fun idx -> - bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data -> - check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5])) - (Cconst_int 3)) idx - (unaligned_load_32 ba_data idx))))) + box_int dbg Pint32 + (bind "ba" (transl env arg1) (fun ba -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> + bind "ba_data" + (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) + (fun ba_data -> + check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable), + [field_address ba 5 dbg], dbg)) + (Cconst_int 3) dbg) idx + (unaligned_load_32 ba_data idx dbg))))) | Pstring_load_64(unsafe) -> - box_int Pint64 - (bind "str" (transl arg1) (fun str -> - bind "index" (untag_int (transl arg2)) (fun idx -> - check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 7)) - idx (unaligned_load_64 str idx)))) + box_int dbg Pint64 + (bind "str" (transl env arg1) (fun str -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> + check_bound unsafe dbg + (sub_int (string_length str dbg) (Cconst_int 7) dbg) + idx (unaligned_load_64 str idx dbg)))) | Pbigstring_load_64(unsafe) -> - box_int Pint64 - (bind "ba" (transl arg1) (fun ba -> - bind "index" (untag_int (transl arg2)) (fun idx -> - bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data -> - check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5])) - (Cconst_int 7)) idx - (unaligned_load_64 ba_data idx))))) + box_int dbg Pint64 + (bind "ba" (transl env arg1) (fun ba -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> + bind "ba_data" + (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) + (fun ba_data -> + check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable), + [field_address ba 5 dbg], dbg)) + (Cconst_int 7) dbg) idx + (unaligned_load_64 ba_data idx dbg))))) (* Array operations *) | Parrayrefu kind -> begin match kind with Pgenarray -> - bind "arr" (transl arg1) (fun arr -> - bind "index" (transl arg2) (fun idx -> - Cifthenelse(is_addr_array_ptr arr, - addr_array_ref arr idx, - float_array_ref arr idx))) - | Paddrarray | Pintarray -> - addr_array_ref (transl arg1) (transl arg2) + bind "arr" (transl env arg1) (fun arr -> + bind "index" (transl env arg2) (fun idx -> + Cifthenelse(is_addr_array_ptr arr dbg, + addr_array_ref arr idx dbg, + float_array_ref dbg arr idx))) + | Paddrarray -> + addr_array_ref (transl env arg1) (transl env arg2) dbg + | Pintarray -> + (* CR mshinwell: for int/addr_array_ref move "dbg" to first arg *) + int_array_ref (transl env arg1) (transl env arg2) dbg | Pfloatarray -> - float_array_ref (transl arg1) (transl arg2) + float_array_ref dbg (transl env arg1) (transl env arg2) end | Parrayrefs kind -> begin match kind with | Pgenarray -> - bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> - bind "header" (header arr) (fun hdr -> + bind "index" (transl env arg2) (fun idx -> + bind "arr" (transl env arg1) (fun arr -> + bind "header" (get_header_without_profinfo arr dbg) (fun hdr -> if wordsize_shift = numfloat_shift then - Csequence(make_checkbound dbg [addr_array_length hdr; idx], - Cifthenelse(is_addr_array_hdr hdr, - addr_array_ref arr idx, - float_array_ref arr idx)) + Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx], + Cifthenelse(is_addr_array_hdr hdr dbg, + addr_array_ref arr idx dbg, + float_array_ref dbg arr idx)) else - Cifthenelse(is_addr_array_hdr hdr, - Csequence(make_checkbound dbg [addr_array_length hdr; idx], - addr_array_ref arr idx), - Csequence(make_checkbound dbg [float_array_length hdr; idx], - float_array_ref arr idx))))) - | Paddrarray | Pintarray -> - bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> - Csequence(make_checkbound dbg [addr_array_length(header arr); idx], - addr_array_ref arr idx))) + Cifthenelse(is_addr_array_hdr hdr dbg, + Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx], + addr_array_ref arr idx dbg), + Csequence(make_checkbound dbg [float_array_length hdr dbg; idx], + float_array_ref dbg arr idx))))) + | Paddrarray -> + bind "index" (transl env arg2) (fun idx -> + bind "arr" (transl env arg1) (fun arr -> + Csequence(make_checkbound dbg [ + addr_array_length(get_header_without_profinfo arr dbg) dbg; idx], + addr_array_ref arr idx dbg))) + | Pintarray -> + bind "index" (transl env arg2) (fun idx -> + bind "arr" (transl env arg1) (fun arr -> + Csequence(make_checkbound dbg [ + addr_array_length(get_header_without_profinfo arr dbg) dbg; idx], + int_array_ref arr idx dbg))) | Pfloatarray -> - box_float( - bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> + box_float dbg ( + bind "index" (transl env arg2) (fun idx -> + bind "arr" (transl env arg1) (fun arr -> Csequence(make_checkbound dbg - [float_array_length(header arr); idx], - unboxed_float_array_ref arr idx)))) + [float_array_length(get_header_without_profinfo arr dbg) dbg; + idx], + unboxed_float_array_ref arr idx dbg)))) end (* Operations on bitvects *) | Pbittest -> - bind "index" (untag_int(transl arg2)) (fun idx -> + bind "index" (untag_int(transl env arg2) dbg) (fun idx -> tag_int( - Cop(Cand, [Cop(Clsr, [Cop(Cload Byte_unsigned, - [add_int (transl arg1) - (Cop(Clsr, [idx; Cconst_int 3]))]); - Cop(Cand, [idx; Cconst_int 7])]); - Cconst_int 1]))) + Cop(Cand, [Cop(Clsr, [Cop(Cload (Byte_unsigned, Mutable), + [add_int (transl env arg1) + (Cop(Clsr, [idx; Cconst_int 3], dbg)) + dbg], + dbg); + Cop(Cand, [idx; Cconst_int 7], dbg)], dbg); + Cconst_int 1], dbg)) dbg) (* Boxed integers *) | Paddbint bi -> - box_int bi (Cop(Caddi, - [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + box_int dbg bi (Cop(Caddi, + [transl_unbox_int dbg env bi arg1; + transl_unbox_int dbg env bi arg2], dbg)) | Psubbint bi -> - box_int bi (Cop(Csubi, - [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + box_int dbg bi (Cop(Csubi, + [transl_unbox_int dbg env bi arg1; + transl_unbox_int dbg env bi arg2], dbg)) | Pmulbint bi -> - box_int bi (Cop(Cmuli, - [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) - | Pdivbint bi -> - box_int bi (safe_div_bi - (transl_unbox_int bi arg1) (transl_unbox_int bi arg2) + box_int dbg bi (Cop(Cmuli, + [transl_unbox_int dbg env bi arg1; + transl_unbox_int dbg env bi arg2], dbg)) + | Pdivbint { size = bi; is_safe } -> + box_int dbg bi (safe_div_bi is_safe + (transl_unbox_int dbg env bi arg1) + (transl_unbox_int dbg env bi arg2) bi dbg) - | Pmodbint bi -> - box_int bi (safe_mod_bi - (transl_unbox_int bi arg1) (transl_unbox_int bi arg2) + | Pmodbint { size = bi; is_safe } -> + box_int dbg bi (safe_mod_bi is_safe + (transl_unbox_int dbg env bi arg1) + (transl_unbox_int dbg env bi arg2) bi dbg) | Pandbint bi -> - box_int bi (Cop(Cand, - [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + box_int dbg bi (Cop(Cand, + [transl_unbox_int dbg env bi arg1; + transl_unbox_int dbg env bi arg2], dbg)) | Porbint bi -> - box_int bi (Cop(Cor, - [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + box_int dbg bi (Cop(Cor, + [transl_unbox_int dbg env bi arg1; + transl_unbox_int dbg env bi arg2], dbg)) | Pxorbint bi -> - box_int bi (Cop(Cxor, - [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) + box_int dbg bi (Cop(Cxor, + [transl_unbox_int dbg env bi arg1; + transl_unbox_int dbg env bi arg2], dbg)) | Plslbint bi -> - box_int bi (Cop(Clsl, - [transl_unbox_int bi arg1; untag_int(transl arg2)])) + box_int dbg bi (Cop(Clsl, + [transl_unbox_int dbg env bi arg1; + untag_int(transl env arg2) dbg], dbg)) | Plsrbint bi -> - box_int bi (Cop(Clsr, - [make_unsigned_int bi (transl_unbox_int bi arg1); - untag_int(transl arg2)])) + box_int dbg bi (Cop(Clsr, + [make_unsigned_int bi (transl_unbox_int dbg env bi arg1) dbg; + untag_int(transl env arg2) dbg], dbg)) | Pasrbint bi -> - box_int bi (Cop(Casr, - [transl_unbox_int bi arg1; untag_int(transl arg2)])) + box_int dbg bi (Cop(Casr, + [transl_unbox_int dbg env bi arg1; + untag_int(transl env arg2) dbg], dbg)) | Pbintcomp(bi, cmp) -> tag_int (Cop(Ccmpi(transl_comparison cmp), - [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) - | _ -> - fatal_error "Cmmgen.transl_prim_2" + [transl_unbox_int dbg env bi arg1; + transl_unbox_int dbg env bi arg2], dbg)) dbg + | prim -> + fatal_errorf "Cmmgen.transl_prim_2: %a" Printlambda.primitive prim -and transl_prim_3 p arg1 arg2 arg3 dbg = +and transl_prim_3 env p arg1 arg2 arg3 dbg = match p with + (* Heap operations *) + | Psetfield_computed(ptr, init) -> + begin match assignment_kind ptr init with + | Caml_modify -> + return_unit ( + addr_array_set (transl env arg1) (transl env arg2) (transl env arg3) + dbg) + | Caml_initialize -> + return_unit ( + addr_array_initialize (transl env arg1) (transl env arg2) + (transl env arg3) dbg) + | Simple -> + return_unit ( + int_array_set (transl env arg1) (transl env arg2) (transl env arg3) + dbg) + end (* String operations *) - Pstringsetu -> - return_unit(Cop(Cstore Byte_unsigned, - [add_int (transl arg1) (untag_int(transl arg2)); - untag_int(transl arg3)])) - | Pstringsets -> + | Pbytessetu -> + return_unit(Cop(Cstore (Byte_unsigned, Assignment), + [add_int (transl env arg1) + (untag_int(transl env arg2) dbg) + dbg; + untag_int(transl env arg3) dbg], dbg)) + | Pbytessets -> return_unit - (bind "str" (transl arg1) (fun str -> - bind "index" (untag_int (transl arg2)) (fun idx -> + (bind "str" (transl env arg1) (fun str -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> Csequence( - make_checkbound dbg [string_length str; idx], - Cop(Cstore Byte_unsigned, - [add_int str idx; untag_int(transl arg3)]))))) + make_checkbound dbg [string_length str dbg; idx], + Cop(Cstore (Byte_unsigned, Assignment), + [add_int str idx dbg; untag_int(transl env arg3) dbg], + dbg))))) (* Array operations *) | Parraysetu kind -> return_unit(begin match kind with Pgenarray -> - bind "newval" (transl arg3) (fun newval -> - bind "index" (transl arg2) (fun index -> - bind "arr" (transl arg1) (fun arr -> - Cifthenelse(is_addr_array_ptr arr, - addr_array_set arr index newval, - float_array_set arr index (unbox_float newval))))) + bind "newval" (transl env arg3) (fun newval -> + bind "index" (transl env arg2) (fun index -> + bind "arr" (transl env arg1) (fun arr -> + Cifthenelse(is_addr_array_ptr arr dbg, + addr_array_set arr index newval dbg, + float_array_set arr index (unbox_float dbg newval) + dbg)))) | Paddrarray -> - addr_array_set (transl arg1) (transl arg2) (transl arg3) + addr_array_set (transl env arg1) (transl env arg2) (transl env arg3) + dbg | Pintarray -> - int_array_set (transl arg1) (transl arg2) (transl arg3) + int_array_set (transl env arg1) (transl env arg2) (transl env arg3) + dbg | Pfloatarray -> - float_array_set (transl arg1) (transl arg2) (transl_unbox_float arg3) + float_array_set (transl env arg1) (transl env arg2) + (transl_unbox_float dbg env arg3) + dbg end) | Parraysets kind -> return_unit(begin match kind with | Pgenarray -> - bind "newval" (transl arg3) (fun newval -> - bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> - bind "header" (header arr) (fun hdr -> + bind "newval" (transl env arg3) (fun newval -> + bind "index" (transl env arg2) (fun idx -> + bind "arr" (transl env arg1) (fun arr -> + bind "header" (get_header_without_profinfo arr dbg) (fun hdr -> if wordsize_shift = numfloat_shift then - Csequence(make_checkbound dbg [addr_array_length hdr; idx], - Cifthenelse(is_addr_array_hdr hdr, - addr_array_set arr idx newval, + Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx], + Cifthenelse(is_addr_array_hdr hdr dbg, + addr_array_set arr idx newval dbg, float_array_set arr idx - (unbox_float newval))) + (unbox_float dbg newval) + dbg)) else - Cifthenelse(is_addr_array_hdr hdr, - Csequence(make_checkbound dbg [addr_array_length hdr; idx], - addr_array_set arr idx newval), - Csequence(make_checkbound dbg [float_array_length hdr; idx], + Cifthenelse(is_addr_array_hdr hdr dbg, + Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx], + addr_array_set arr idx newval dbg), + Csequence(make_checkbound dbg [float_array_length hdr dbg; idx], float_array_set arr idx - (unbox_float newval))))))) + (unbox_float dbg newval) dbg)))))) | Paddrarray -> - bind "newval" (transl arg3) (fun newval -> - bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> - Csequence(make_checkbound dbg [addr_array_length(header arr); idx], - addr_array_set arr idx newval)))) + bind "newval" (transl env arg3) (fun newval -> + bind "index" (transl env arg2) (fun idx -> + bind "arr" (transl env arg1) (fun arr -> + Csequence(make_checkbound dbg [ + addr_array_length(get_header_without_profinfo arr dbg) dbg; idx], + addr_array_set arr idx newval dbg)))) | Pintarray -> - bind "newval" (transl arg3) (fun newval -> - bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> - Csequence(make_checkbound dbg [addr_array_length(header arr); idx], - int_array_set arr idx newval)))) + bind "newval" (transl env arg3) (fun newval -> + bind "index" (transl env arg2) (fun idx -> + bind "arr" (transl env arg1) (fun arr -> + Csequence(make_checkbound dbg [ + addr_array_length(get_header_without_profinfo arr dbg) dbg; idx], + int_array_set arr idx newval dbg)))) | Pfloatarray -> - bind "newval" (transl_unbox_float arg3) (fun newval -> - bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> - Csequence(make_checkbound dbg [float_array_length(header arr);idx], - float_array_set arr idx newval)))) + bind_load "newval" (transl_unbox_float dbg env arg3) (fun newval -> + bind "index" (transl env arg2) (fun idx -> + bind "arr" (transl env arg1) (fun arr -> + Csequence(make_checkbound dbg [ + float_array_length (get_header_without_profinfo arr dbg) dbg;idx], + float_array_set arr idx newval dbg)))) end) | Pstring_set_16(unsafe) -> return_unit - (bind "str" (transl arg1) (fun str -> - bind "index" (untag_int (transl arg2)) (fun idx -> - bind "newval" (untag_int (transl arg3)) (fun newval -> - check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 1)) - idx (unaligned_set_16 str idx newval))))) + (bind "str" (transl env arg1) (fun str -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> + bind "newval" (untag_int (transl env arg3) dbg) (fun newval -> + check_bound unsafe dbg + (sub_int (string_length str dbg) (Cconst_int 1) dbg) + idx (unaligned_set_16 str idx newval dbg))))) | Pbigstring_set_16(unsafe) -> return_unit - (bind "ba" (transl arg1) (fun ba -> - bind "index" (untag_int (transl arg2)) (fun idx -> - bind "newval" (untag_int (transl arg3)) (fun newval -> - bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data -> - check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5])) - (Cconst_int 1)) - idx (unaligned_set_16 ba_data idx newval)))))) + (bind "ba" (transl env arg1) (fun ba -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> + bind "newval" (untag_int (transl env arg3) dbg) (fun newval -> + bind "ba_data" + (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) + (fun ba_data -> + check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable), + [field_address ba 5 dbg], dbg)) + (Cconst_int 1) + dbg) + idx (unaligned_set_16 ba_data idx newval dbg)))))) | Pstring_set_32(unsafe) -> return_unit - (bind "str" (transl arg1) (fun str -> - bind "index" (untag_int (transl arg2)) (fun idx -> - bind "newval" (transl_unbox_int Pint32 arg3) (fun newval -> - check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 3)) - idx (unaligned_set_32 str idx newval))))) + (bind "str" (transl env arg1) (fun str -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> + bind "newval" (transl_unbox_int dbg env Pint32 arg3) (fun newval -> + check_bound unsafe dbg + (sub_int (string_length str dbg) (Cconst_int 3) dbg) + idx (unaligned_set_32 str idx newval dbg))))) | Pbigstring_set_32(unsafe) -> return_unit - (bind "ba" (transl arg1) (fun ba -> - bind "index" (untag_int (transl arg2)) (fun idx -> - bind "newval" (transl_unbox_int Pint32 arg3) (fun newval -> - bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data -> - check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5])) - (Cconst_int 3)) - idx (unaligned_set_32 ba_data idx newval)))))) + (bind "ba" (transl env arg1) (fun ba -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> + bind "newval" (transl_unbox_int dbg env Pint32 arg3) (fun newval -> + bind "ba_data" + (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) + (fun ba_data -> + check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable), + [field_address ba 5 dbg], dbg)) + (Cconst_int 3) + dbg) + idx (unaligned_set_32 ba_data idx newval dbg)))))) | Pstring_set_64(unsafe) -> return_unit - (bind "str" (transl arg1) (fun str -> - bind "index" (untag_int (transl arg2)) (fun idx -> - bind "newval" (transl_unbox_int Pint64 arg3) (fun newval -> - check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 7)) - idx (unaligned_set_64 str idx newval))))) + (bind "str" (transl env arg1) (fun str -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> + bind "newval" (transl_unbox_int dbg env Pint64 arg3) (fun newval -> + check_bound unsafe dbg + (sub_int (string_length str dbg) (Cconst_int 7) dbg) + idx (unaligned_set_64 str idx newval dbg))))) | Pbigstring_set_64(unsafe) -> return_unit - (bind "ba" (transl arg1) (fun ba -> - bind "index" (untag_int (transl arg2)) (fun idx -> - bind "newval" (transl_unbox_int Pint64 arg3) (fun newval -> - bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data -> - check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5])) - (Cconst_int 7)) idx - (unaligned_set_64 ba_data idx newval)))))) - - | _ -> - fatal_error "Cmmgen.transl_prim_3" + (bind "ba" (transl env arg1) (fun ba -> + bind "index" (untag_int (transl env arg2) dbg) (fun idx -> + bind "newval" (transl_unbox_int dbg env Pint64 arg3) (fun newval -> + bind "ba_data" + (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) + (fun ba_data -> + check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable), + [field_address ba 5 dbg], dbg)) + (Cconst_int 7) + dbg) idx + (unaligned_set_64 ba_data idx newval dbg)))))) + + | prim -> + fatal_errorf "Cmmgen.transl_prim_3: %a" Printlambda.primitive prim + +and transl_unbox_float dbg env = function + Uconst(Uconst_ref(_, Some (Uconst_float f))) -> Cconst_float f + | exp -> unbox_float dbg (transl env exp) -and transl_unbox_float = function - Uconst(Const_base(Const_float f), _) -> Cconst_float f - | exp -> unbox_float(transl exp) - -and transl_unbox_int bi = function - Uconst(Const_base(Const_int32 n), _) -> +and transl_unbox_int dbg env bi = function + Uconst(Uconst_ref(_, Some (Uconst_int32 n))) -> Cconst_natint (Nativeint.of_int32 n) - | Uconst(Const_base(Const_nativeint n), _) -> + | Uconst(Uconst_ref(_, Some (Uconst_nativeint n))) -> Cconst_natint n - | Uconst(Const_base(Const_int64 n), _) -> - assert (size_int = 8); Cconst_natint (Int64.to_nativeint n) - | Uprim(Pbintofint bi',[Uconst(Const_base(Const_int i),_)],_) when bi = bi' -> + | Uconst(Uconst_ref(_, Some (Uconst_int64 n))) -> + if size_int = 8 then + Cconst_natint (Int64.to_nativeint n) + else begin + let low = Int64.to_nativeint n in + let high = Int64.to_nativeint (Int64.shift_right_logical n 32) in + if big_endian then Ctuple [Cconst_natint high; Cconst_natint low] + else Ctuple [Cconst_natint low; Cconst_natint high] + end + | Uprim(Pbintofint bi',[Uconst(Uconst_int i)],_) when bi = bi' -> Cconst_int i - | exp -> unbox_int bi (transl exp) + | exp -> unbox_int bi (transl env exp) dbg -and transl_unbox_let box_fn unbox_fn transl_unbox_fn id exp body = - let unboxed_id = Ident.create (Ident.name id) in - let trbody1 = transl body in - let (trbody2, need_boxed, is_assigned) = - subst_boxed_number unbox_fn id unboxed_id trbody1 in - if need_boxed && is_assigned then - Clet(id, transl exp, trbody1) - else - Clet(unboxed_id, transl_unbox_fn exp, - if need_boxed - then Clet(id, box_fn(Cvar unboxed_id), trbody2) - else trbody2) +and transl_unbox_number dbg env bn arg = + match bn with + | Boxed_float _ -> transl_unbox_float dbg env arg + | Boxed_integer (bi, _) -> transl_unbox_int dbg env bi arg + +and transl_let env str kind id exp body = + let dbg = Debuginfo.none in + let unboxing = + (* If [id] is a mutable variable (introduced to eliminate a local + reference) and it contains a type of unboxable numbers, then + force unboxing. Indeed, if not boxed, each assignment to the variable + might require some boxing, but such local references are often + used in loops and we really want to avoid repeated boxing. *) + match str, kind with + | Mutable, Pfloatval -> + Boxed (Boxed_float dbg, false) + | Mutable, Pboxedintval bi -> + Boxed (Boxed_integer (bi, dbg), false) + | _, (Pfloatval | Pboxedintval _) -> + (* It would be safe to always unbox in this case, but + we do it only if this indeed allows us to get rid of + some allocations in the bound expression. *) + is_unboxed_number ~strict:false env exp + | _, Pgenval -> + (* Here we don't know statically that the bound expression + evaluates to an unboxable number type. We need to be stricter + and ensure that all possible branches in the expression + return a boxed value (of the same kind). Indeed, with GADTs, + different branches could return different types. *) + is_unboxed_number ~strict:true env exp + | _, Pintval -> + No_unboxing + in + match unboxing with + | No_unboxing | Boxed (_, true) | No_result -> + (* N.B. [body] must still be traversed even if [exp] will never return: + there may be constant closures inside that need lifting out. *) + Clet(id, transl env exp, transl env body) + | Boxed (boxed_number, _false) -> + let unboxed_id = Ident.create (Ident.name id) in + Clet(unboxed_id, transl_unbox_number dbg env boxed_number exp, + transl (add_unboxed_id id unboxed_id boxed_number env) body) and make_catch ncatch body handler = match body with | Cexit (nexit,[]) when nexit=ncatch -> handler -| _ -> Ccatch (ncatch, [], body, handler) +| _ -> ccatch (ncatch, [], body, handler) and make_catch2 mk_body handler = match handler with | Cexit (_,[])|Ctuple []|Cconst_int _|Cconst_pointer _ -> @@ -1782,73 +2634,85 @@ (mk_body (Cexit (nfail,[]))) handler -and exit_if_true cond nfail otherwise = +and exit_if_true dbg env cond nfail otherwise = match cond with - | Uconst (Const_pointer 0, _) -> otherwise - | Uconst (Const_pointer 1, _) -> Cexit (nfail,[]) + | Uconst (Uconst_ptr 0) -> otherwise + | Uconst (Uconst_ptr 1) -> Cexit (nfail,[]) + | Uifthenelse (arg1, Uconst (Uconst_ptr 1), arg2) | Uprim(Psequor, [arg1; arg2], _) -> - exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise) + exit_if_true dbg env arg1 nfail + (exit_if_true dbg env arg2 nfail otherwise) + | Uifthenelse (_, _, Uconst (Uconst_ptr 0)) | Uprim(Psequand, _, _) -> begin match otherwise with | Cexit (raise_num,[]) -> - exit_if_false cond (Cexit (nfail,[])) raise_num + exit_if_false dbg env cond (Cexit (nfail,[])) raise_num | _ -> let raise_num = next_raise_count () in make_catch raise_num - (exit_if_false cond (Cexit (nfail,[])) raise_num) + (exit_if_false dbg env cond (Cexit (nfail,[])) raise_num) otherwise end | Uprim(Pnot, [arg], _) -> - exit_if_false arg otherwise nfail + exit_if_false dbg env arg otherwise nfail | Uifthenelse (cond, ifso, ifnot) -> make_catch2 (fun shared -> - Cifthenelse - (test_bool (transl cond), - exit_if_true ifso nfail shared, - exit_if_true ifnot nfail shared)) + if_then_else + (test_bool dbg (transl env cond), + exit_if_true dbg env ifso nfail shared, + exit_if_true dbg env ifnot nfail shared)) otherwise | _ -> - Cifthenelse(test_bool(transl cond), Cexit (nfail, []), otherwise) + if_then_else(test_bool dbg (transl env cond), + Cexit (nfail, []), otherwise) -and exit_if_false cond otherwise nfail = +and exit_if_false dbg env cond otherwise nfail = match cond with - | Uconst (Const_pointer 0, _) -> Cexit (nfail,[]) - | Uconst (Const_pointer 1, _) -> otherwise + | Uconst (Uconst_ptr 0) -> Cexit (nfail,[]) + | Uconst (Uconst_ptr 1) -> otherwise + | Uifthenelse (arg1, arg2, Uconst (Uconst_ptr 0)) | Uprim(Psequand, [arg1; arg2], _) -> - exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail + exit_if_false dbg env arg1 + (exit_if_false dbg env arg2 otherwise nfail) nfail + | Uifthenelse (_, Uconst (Uconst_ptr 1), _) | Uprim(Psequor, _, _) -> begin match otherwise with | Cexit (raise_num,[]) -> - exit_if_true cond raise_num (Cexit (nfail,[])) + exit_if_true dbg env cond raise_num (Cexit (nfail,[])) | _ -> let raise_num = next_raise_count () in make_catch raise_num - (exit_if_true cond raise_num (Cexit (nfail,[]))) + (exit_if_true dbg env cond raise_num (Cexit (nfail,[]))) otherwise end | Uprim(Pnot, [arg], _) -> - exit_if_true arg nfail otherwise + exit_if_true dbg env arg nfail otherwise | Uifthenelse (cond, ifso, ifnot) -> make_catch2 (fun shared -> - Cifthenelse - (test_bool (transl cond), - exit_if_false ifso shared nfail, - exit_if_false ifnot shared nfail)) + if_then_else + (test_bool dbg (transl env cond), + exit_if_false dbg env ifso shared nfail, + exit_if_false dbg env ifnot shared nfail)) otherwise | _ -> - Cifthenelse(test_bool(transl cond), otherwise, Cexit (nfail, [])) + if_then_else (test_bool dbg (transl env cond), otherwise, + Cexit (nfail, [])) -and transl_switch arg index cases = match Array.length cases with +and transl_switch _dbg env arg index cases = match Array.length cases with | 0 -> fatal_error "Cmmgen.transl_switch" -| 1 -> transl cases.(0) +| 1 -> transl env cases.(0) | _ -> + let cases = Array.map (transl env) cases in + let store = StoreExp.mk_store () in + let index = + Array.map + (fun j -> store.Switch.act_store cases.(j)) + index in let n_index = Array.length index in - let actions = Array.map transl cases in - let inters = ref [] and this_high = ref (n_index-1) and this_low = ref (n_index-1) @@ -1865,52 +2729,71 @@ end done ; inters := (0, !this_high, !this_act) :: !inters ; - bind "switcher" arg - (fun a -> - SwitcherBlocks.zyva - (0,n_index-1) - (fun i -> Cconst_int i) - a - (Array.of_list !inters) actions) + match !inters with + | [_] -> cases.(0) + | inters -> + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + (0,n_index-1) + a + (Array.of_list inters) store) -and transl_letrec bindings cont = +and transl_letrec env bindings cont = + let dbg = Debuginfo.none in let bsz = - List.map (fun (id, exp) -> (id, exp, expr_size Ident.empty exp)) bindings in + List.map (fun (id, exp) -> (id, exp, expr_size Ident.empty exp)) + bindings + in let op_alloc prim sz = - Cop(Cextcall(prim, typ_addr, true, Debuginfo.none), [int_const sz]) in + Cop(Cextcall(prim, typ_val, true, None), [int_const sz], dbg) in let rec init_blocks = function | [] -> fill_nonrec bsz - | (id, exp, RHS_block sz) :: rem -> - Clet(id, op_alloc "caml_alloc_dummy" sz, init_blocks rem) - | (id, exp, RHS_floatblock sz) :: rem -> - Clet(id, op_alloc "caml_alloc_dummy_float" sz, init_blocks rem) - | (id, exp, RHS_nonrec) :: rem -> + | (id, _exp, RHS_block sz) :: rem -> + Clet(id, op_alloc "caml_alloc_dummy" sz, + init_blocks rem) + | (id, _exp, RHS_floatblock sz) :: rem -> + Clet(id, op_alloc "caml_alloc_dummy_float" sz, + init_blocks rem) + | (id, _exp, RHS_nonrec) :: rem -> Clet (id, Cconst_int 0, init_blocks rem) and fill_nonrec = function | [] -> fill_blocks bsz - | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + | (_id, _exp, (RHS_block _ | RHS_floatblock _)) :: rem -> fill_nonrec rem | (id, exp, RHS_nonrec) :: rem -> - Clet (id, transl exp, fill_nonrec rem) + Clet(id, transl env exp, fill_nonrec rem) and fill_blocks = function | [] -> cont | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> let op = - Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none), - [Cvar id; transl exp]) in + Cop(Cextcall("caml_update_dummy", typ_void, false, None), + [Cvar id; transl env exp], dbg) in Csequence(op, fill_blocks rem) - | (id, exp, RHS_nonrec) :: rem -> + | (_id, _exp, RHS_nonrec) :: rem -> fill_blocks rem in init_blocks bsz (* Translate a function definition *) let transl_function f = + let body = + if Config.flambda then + Un_anf.apply f.body ~what:f.label + else + f.body + in + let cmm_body = + let env = create_env ~environment_param:f.env in + if !Clflags.afl_instrument then + Afl_instrument.instrument_function (transl env body) + else + transl env body in Cfunction {fun_name = f.label; - fun_args = List.map (fun id -> (id, typ_addr)) f.params; - fun_body = transl f.body; + fun_args = List.map (fun id -> (id, typ_val)) f.params; + fun_body = cmm_body; fun_fast = !Clflags.optimize_for_speed; - fun_dbg = f.dbg; } + fun_dbg = f.dbg} (* Translate all function definitions *) @@ -1928,106 +2811,59 @@ else begin transl_all_functions (StringSet.add f.label already_translated) - (transl_function f :: cont) + ((f.dbg, transl_function f) :: cont) end with Queue.Empty -> - cont + cont, already_translated + +let cdefine_symbol (symb, global) = + match global with + | Global -> [Cglobal_symbol symb; Cdefine_symbol symb] + | Not_global -> [Cdefine_symbol symb] (* Emit structured constants *) -let immstrings = Hashtbl.create 17 +let rec emit_structured_constant symb cst cont = + let emit_block white_header symb cont = + (* Headers for structured constants must be marked black in case we + are in no-naked-pointers mode. See [caml_darken]. *) + let black_header = Nativeint.logor white_header caml_black in + Cint black_header :: cdefine_symbol symb @ cont + in + match cst with + | Uconst_float s-> + emit_block float_header symb (Cdouble s :: cont) + | Uconst_string s -> + emit_block (string_header (String.length s)) symb + (emit_string_constant s cont) + | Uconst_int32 n -> + emit_block boxedint32_header symb + (emit_boxed_int32_constant n cont) + | Uconst_int64 n -> + emit_block boxedint64_header symb + (emit_boxed_int64_constant n cont) + | Uconst_nativeint n -> + emit_block boxedintnat_header symb + (emit_boxed_nativeint_constant n cont) + | Uconst_block (tag, csts) -> + let cont = List.fold_right emit_constant csts cont in + emit_block (block_header tag (List.length csts)) symb cont + | Uconst_float_array fields -> + emit_block (floatarray_header (List.length fields)) symb + (Misc.map_end (fun f -> Cdouble f) fields cont) + | Uconst_closure(fundecls, lbl, fv) -> + assert(lbl = fst symb); + add_cmm_constant (Const_closure (symb, fundecls, fv)); + List.iter (fun f -> Queue.add f functions) fundecls; + cont -let rec emit_constant symb cst cont = +and emit_constant cst cont = match cst with - Const_base(Const_float s) -> - Cint(float_header) :: Cdefine_symbol symb :: Cdouble s :: cont - | Const_base(Const_string s) | Const_immstring s -> - Cint(string_header (String.length s)) :: - Cdefine_symbol symb :: - emit_string_constant s cont - | Const_base(Const_int32 n) -> - Cint(boxedint32_header) :: Cdefine_symbol symb :: - emit_boxed_int32_constant n cont - | Const_base(Const_int64 n) -> - Cint(boxedint64_header) :: Cdefine_symbol symb :: - emit_boxed_int64_constant n cont - | Const_base(Const_nativeint n) -> - Cint(boxedintnat_header) :: Cdefine_symbol symb :: - emit_boxed_nativeint_constant n cont - | Const_block(tag, fields) -> - let (emit_fields, cont1) = emit_constant_fields fields cont in - Cint(block_header tag (List.length fields)) :: - Cdefine_symbol symb :: - emit_fields @ cont1 - | Const_float_array(fields) -> - Cint(floatarray_header (List.length fields)) :: - Cdefine_symbol symb :: - Misc.map_end (fun f -> Cdouble f) fields cont - | _ -> fatal_error "gencmm.emit_constant" - -and emit_constant_fields fields cont = - match fields with - [] -> ([], cont) - | f1 :: fl -> - let (data1, cont1) = emit_constant_field f1 cont in - let (datal, contl) = emit_constant_fields fl cont1 in - (data1 :: datal, contl) - -and emit_constant_field field cont = - match field with - Const_base(Const_int n) -> - (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n), - cont) - | Const_base(Const_char c) -> - (Cint(Nativeint.of_int(((Char.code c) lsl 1) + 1)), cont) - | Const_base(Const_float s) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(float_header) :: Cdefine_label lbl :: Cdouble s :: cont) - | Const_base(Const_string s) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(string_header (String.length s)) :: Cdefine_label lbl :: - emit_string_constant s cont) - | Const_immstring s -> - begin try - (Clabel_address (Hashtbl.find immstrings s), cont) - with Not_found -> - let lbl = Compilenv.new_const_label() in - Hashtbl.add immstrings s lbl; - (Clabel_address lbl, - Cint(string_header (String.length s)) :: Cdefine_label lbl :: - emit_string_constant s cont) - end - | Const_base(Const_int32 n) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(boxedint32_header) :: Cdefine_label lbl :: - emit_boxed_int32_constant n cont) - | Const_base(Const_int64 n) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(boxedint64_header) :: Cdefine_label lbl :: - emit_boxed_int64_constant n cont) - | Const_base(Const_nativeint n) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(boxedintnat_header) :: Cdefine_label lbl :: - emit_boxed_nativeint_constant n cont) - | Const_pointer n -> - (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n), - cont) - | Const_block(tag, fields) -> - let lbl = Compilenv.new_const_label() in - let (emit_fields, cont1) = emit_constant_fields fields cont in - (Clabel_address lbl, - Cint(block_header tag (List.length fields)) :: Cdefine_label lbl :: - emit_fields @ cont1) - | Const_float_array(fields) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(floatarray_header (List.length fields)) :: Cdefine_label lbl :: - Misc.map_end (fun f -> Cdouble f) fields cont) + | Uconst_int n | Uconst_ptr n -> + cint_const n + :: cont + | Uconst_ref (label, _) -> + Csymbol_address label :: cont and emit_string_constant s cont = let n = size_int - 1 - (String.length s) mod size_int in @@ -2057,72 +2893,163 @@ (* Emit constant closures *) -let emit_constant_closure symb fundecls cont = +let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont = + let closure_symbol f = + if Config.flambda then + cdefine_symbol (f.label ^ "_closure", global_symb) + else + [] + in match fundecls with - [] -> assert false + [] -> + (* This should probably not happen: dead code has normally been + eliminated and a closure cannot be accessed without going through + a [Project_closure], which depends on the function. *) + assert (clos_vars = []); + cdefine_symbol symb @ + List.fold_right emit_constant clos_vars cont | f1 :: remainder -> let rec emit_others pos = function - [] -> cont + [] -> + List.fold_right emit_constant clos_vars cont | f2 :: rem -> - if f2.arity = 1 then + if f2.arity = 1 || f2.arity = 0 then Cint(infix_header pos) :: + (closure_symbol f2) @ Csymbol_address f2.label :: - Cint 3n :: + cint_const f2.arity :: emit_others (pos + 3) rem else Cint(infix_header pos) :: + (closure_symbol f2) @ Csymbol_address(curry_function f2.arity) :: - Cint(Nativeint.of_int (f2.arity lsl 1 + 1)) :: + cint_const f2.arity :: Csymbol_address f2.label :: emit_others (pos + 4) rem in - Cint(closure_header (fundecls_size fundecls)) :: - Cdefine_symbol symb :: - if f1.arity = 1 then + Cint(black_closure_header (fundecls_size fundecls + + List.length clos_vars)) :: + cdefine_symbol symb @ + (closure_symbol f1) @ + if f1.arity = 1 || f1.arity = 0 then Csymbol_address f1.label :: - Cint 3n :: + cint_const f1.arity :: emit_others 3 remainder else Csymbol_address(curry_function f1.arity) :: - Cint(Nativeint.of_int (f1.arity lsl 1 + 1)) :: + cint_const f1.arity :: Csymbol_address f1.label :: emit_others 4 remainder +(* Emit constant blocks *) + +let emit_constant_table symb elems = + cdefine_symbol symb @ + elems + (* Emit all structured constants *) -let emit_all_constants cont = +let emit_constants cont (constants:Clambda.preallocated_constant list) = let c = ref cont in List.iter - (fun (lbl, global, cst) -> - let cst = emit_constant lbl cst [] in - let cst = if global then - Cglobal_symbol lbl :: cst - else cst in + (fun { symbol = lbl; exported; definition = cst } -> + let global = if exported then Global else Not_global in + let cst = emit_structured_constant (lbl, global) cst [] in c:= Cdata(cst):: !c) - (Compilenv.structured_constants()); -(* structured_constants := []; done in Compilenv.reset() *) - Hashtbl.clear immstrings; (* PR#3979 *) + constants; List.iter - (fun (symb, fundecls) -> - c := Cdata(emit_constant_closure symb fundecls []) :: !c) - !constant_closures; - constant_closures := []; + (function + | Const_closure (symb, fundecls, clos_vars) -> + c := Cdata(emit_constant_closure symb fundecls clos_vars []) :: !c + | Const_table (symb, elems) -> + c := Cdata(emit_constant_table symb elems) :: !c) + !cmm_constants; + cmm_constants := []; !c +let emit_all_constants cont = + let constants = Compilenv.structured_constants () in + Compilenv.clear_structured_constants (); + emit_constants cont constants + +let transl_all_functions_and_emit_all_constants cont = + let rec aux already_translated cont translated_functions = + if Compilenv.structured_constants () = [] && + Queue.is_empty functions + then cont, translated_functions + else + let translated_functions, already_translated = + transl_all_functions already_translated translated_functions + in + let cont = emit_all_constants cont in + aux already_translated cont translated_functions + in + let cont, translated_functions = + aux StringSet.empty cont [] + in + let translated_functions = + (* Sort functions according to source position *) + List.map snd + (List.sort (fun (dbg1, _) (dbg2, _) -> + Debuginfo.compare dbg1 dbg2) translated_functions) + in + translated_functions @ cont + +(* Build the NULL terminated array of gc roots *) + +let emit_gc_roots_table ~symbols cont = + let table_symbol = Compilenv.make_symbol (Some "gc_roots") in + Cdata(Cglobal_symbol table_symbol :: + Cdefine_symbol table_symbol :: + List.map (fun s -> Csymbol_address s) symbols @ + [Cint 0n]) + :: cont + +(* Build preallocated blocks (used for Flambda [Initialize_symbol] + constructs, and Clambda global module) *) + +let preallocate_block cont { Clambda.symbol; exported; tag; size } = + let space = + (* These words will be registered as roots and as such must contain + valid values, in case we are in no-naked-pointers mode. Likewise + the block header must be black, below (see [caml_darken]), since + the overall record may be referenced. *) + Array.to_list + (Array.init size (fun _index -> + Cint (Nativeint.of_int 1 (* Val_unit *)))) + in + let data = + Cint(black_block_header tag size) :: + if exported then + Cglobal_symbol symbol :: + Cdefine_symbol symbol :: space + else + Cdefine_symbol symbol :: space + in + Cdata data :: cont + +let emit_preallocated_blocks preallocated_blocks cont = + let symbols = + List.map (fun ({ Clambda.symbol }:Clambda.preallocated_block) -> symbol) + preallocated_blocks + in + let c1 = emit_gc_roots_table ~symbols cont in + List.fold_left preallocate_block c1 preallocated_blocks + (* Translate a compilation unit *) -let compunit size ulam = - let glob = Compilenv.make_symbol None in - let init_code = transl ulam in +let compunit (ulam, preallocated_blocks, constants) = + let init_code = + if !Clflags.afl_instrument then + Afl_instrument.instrument_initialiser (transl empty_env ulam) + else + transl empty_env ulam in let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry"); fun_args = []; fun_body = init_code; fun_fast = false; fun_dbg = Debuginfo.none }] in - let c2 = transl_all_functions StringSet.empty c1 in - let c3 = emit_all_constants c2 in - Cdata [Cint(block_header 0 size); - Cglobal_symbol glob; - Cdefine_symbol glob; - Cskip(size * size_addr)] :: c3 + let c2 = emit_constants c1 constants in + let c3 = transl_all_functions_and_emit_all_constants c2 in + emit_preallocated_blocks preallocated_blocks c3 (* CAMLprim value caml_cache_public_method (value meths, value tag, value *cache) @@ -2138,41 +3065,46 @@ } *) -let cache_public_method meths tag cache = +let cache_public_method meths tag cache dbg = let raise_num = next_raise_count () in let li = Ident.create "li" and hi = Ident.create "hi" and mi = Ident.create "mi" and tagged = Ident.create "tagged" in Clet ( li, Cconst_int 3, Clet ( - hi, Cop(Cload Word, [meths]), + hi, Cop(Cload (Word_int, Mutable), [meths], dbg), Csequence( - Ccatch + ccatch (raise_num, [], Cloop (Clet( mi, Cop(Cor, - [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi]); Cconst_int 1]); - Cconst_int 1]), + [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi], dbg); Cconst_int 1], + dbg); + Cconst_int 1], + dbg), Csequence( Cifthenelse (Cop (Ccmpi Clt, [tag; - Cop(Cload Word, + Cop(Cload (Word_int, Mutable), [Cop(Cadda, - [meths; lsl_const (Cvar mi) log2_size_addr])])]), - Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2])), + [meths; lsl_const (Cvar mi) log2_size_addr dbg], + dbg)], + dbg)], dbg), + Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2], dbg)), Cassign(li, Cvar mi)), Cifthenelse - (Cop(Ccmpi Cge, [Cvar li; Cvar hi]), Cexit (raise_num, []), + (Cop(Ccmpi Cge, [Cvar li; Cvar hi], dbg), Cexit (raise_num, []), Ctuple [])))), Ctuple []), Clet ( - tagged, Cop(Cadda, [lsl_const (Cvar li) log2_size_addr; - Cconst_int(1 - 3 * size_addr)]), - Csequence(Cop (Cstore Word, [cache; Cvar tagged]), - Cvar tagged))))) + tagged, + Cop(Cadda, [lsl_const (Cvar li) log2_size_addr dbg; + Cconst_int(1 - 3 * size_addr)], dbg), + Csequence(Cop (Cstore (Word_int, Assignment), [cache; Cvar tagged], dbg), + Cvar tagged))))) (* Generate an application function: (defun caml_applyN (a1 ... aN clos) @@ -2186,18 +3118,20 @@ *) let apply_function_body arity = - let arg = Array.create arity (Ident.create "arg") in + let dbg = Debuginfo.none in + let arg = Array.make arity (Ident.create "arg") in for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done; let clos = Ident.create "clos" in + let env = empty_env in let rec app_fun clos n = if n = arity-1 then - Cop(Capply(typ_addr, Debuginfo.none), - [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]) + Cop(Capply typ_val, + [get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg) else begin let newclos = Ident.create "clos" in Clet(newclos, - Cop(Capply(typ_addr, Debuginfo.none), - [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]), + Cop(Capply typ_val, + [get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg), app_fun newclos (n+1)) end in let args = Array.to_list arg in @@ -2205,44 +3139,51 @@ (args, clos, if arity = 1 then app_fun clos 0 else Cifthenelse( - Cop(Ccmpi Ceq, [get_field (Cvar clos) 1; int_const arity]), - Cop(Capply(typ_addr, Debuginfo.none), - get_field (Cvar clos) 2 :: List.map (fun s -> Cvar s) all_args), + Cop(Ccmpi Ceq, [get_field env (Cvar clos) 1 dbg; int_const arity], dbg), + Cop(Capply typ_val, + get_field env (Cvar clos) 2 dbg :: List.map (fun s -> Cvar s) all_args, + dbg), app_fun clos 0)) let send_function arity = + let dbg = Debuginfo.none in let (args, clos', body) = apply_function_body (1+arity) in let cache = Ident.create "cache" and obj = List.hd args and tag = Ident.create "tag" in + let env = empty_env in let clos = let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in let meths = Ident.create "meths" and cached = Ident.create "cached" in let real = Ident.create "real" in - let mask = get_field (Cvar meths) 1 in + let mask = get_field env (Cvar meths) 1 dbg in let cached_pos = Cvar cached in - let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths]); - Cconst_int(3*size_addr-1)]) in - let tag' = Cop(Cload Word, [tag_pos]) in + let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths], dbg); + Cconst_int(3*size_addr-1)], dbg) in + let tag' = Cop(Cload (Word_int, Mutable), [tag_pos], dbg) in Clet ( - meths, Cop(Cload Word, [obj]), + meths, Cop(Cload (Word_val, Mutable), [obj], dbg), Clet ( - cached, Cop(Cand, [Cop(Cload Word, [cache]); mask]), + cached, + Cop(Cand, [Cop(Cload (Word_int, Mutable), [cache], dbg); mask], dbg), Clet ( real, - Cifthenelse(Cop(Ccmpa Cne, [tag'; tag]), - cache_public_method (Cvar meths) tag cache, + Cifthenelse(Cop(Ccmpa Cne, [tag'; tag], dbg), + cache_public_method (Cvar meths) tag cache dbg, cached_pos), - Cop(Cload Word, [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths]); - Cconst_int(2*size_addr-1)])])))) + Cop(Cload (Word_val, Mutable), + [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths], dbg); + Cconst_int(2*size_addr-1)], dbg)], dbg)))) in let body = Clet(clos', clos, body) in + let cache = cache in let fun_args = - [obj, typ_addr; tag, typ_int; cache, typ_addr] - @ List.map (fun id -> (id, typ_addr)) (List.tl args) in + [obj, typ_val; tag, typ_int; cache, typ_val] + @ List.map (fun id -> (id, typ_val)) (List.tl args) in + let fun_name = "caml_send" ^ string_of_int arity in Cfunction - {fun_name = "caml_send" ^ string_of_int arity; + {fun_name; fun_args = fun_args; fun_body = body; fun_fast = true; @@ -2251,32 +3192,39 @@ let apply_function arity = let (args, clos, body) = apply_function_body arity in let all_args = args @ [clos] in + let fun_name = "caml_apply" ^ string_of_int arity in Cfunction - {fun_name = "caml_apply" ^ string_of_int arity; - fun_args = List.map (fun id -> (id, typ_addr)) all_args; + {fun_name; + fun_args = List.map (fun id -> (id, typ_val)) all_args; fun_body = body; fun_fast = true; - fun_dbg = Debuginfo.none } + fun_dbg = Debuginfo.none; + } (* Generate tuplifying functions: (defun caml_tuplifyN (arg clos) (app clos.direct #0(arg) ... #N-1(arg) clos)) *) let tuplify_function arity = + let dbg = Debuginfo.none in let arg = Ident.create "arg" in let clos = Ident.create "clos" in + let env = empty_env in let rec access_components i = if i >= arity then [] - else get_field (Cvar arg) i :: access_components(i+1) in + else get_field env (Cvar arg) i dbg :: access_components(i+1) in + let fun_name = "caml_tuplify" ^ string_of_int arity in Cfunction - {fun_name = "caml_tuplify" ^ string_of_int arity; - fun_args = [arg, typ_addr; clos, typ_addr]; + {fun_name; + fun_args = [arg, typ_val; clos, typ_val]; fun_body = - Cop(Capply(typ_addr, Debuginfo.none), - get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]); + Cop(Capply typ_val, + get_field env (Cvar clos) 2 dbg :: access_components 0 @ [Cvar clos], + dbg); fun_fast = true; - fun_dbg = Debuginfo.none } + fun_dbg = Debuginfo.none; + } (* Generate currying functions: (defun caml_curryN (arg clos) @@ -2308,36 +3256,41 @@ let max_arity_optimized = 15 let final_curry_function arity = + let dbg = Debuginfo.none in let last_arg = Ident.create "arg" in let last_clos = Ident.create "clos" in + let env = empty_env in let rec curry_fun args clos n = if n = 0 then - Cop(Capply(typ_addr, Debuginfo.none), - get_field (Cvar clos) 2 :: - args @ [Cvar last_arg; Cvar clos]) + Cop(Capply typ_val, + get_field env (Cvar clos) 2 dbg :: + args @ [Cvar last_arg; Cvar clos], + dbg) else if n = arity - 1 || arity > max_arity_optimized then begin let newclos = Ident.create "clos" in Clet(newclos, - get_field (Cvar clos) 3, - curry_fun (get_field (Cvar clos) 2 :: args) newclos (n-1)) + get_field env (Cvar clos) 3 dbg, + curry_fun (get_field env (Cvar clos) 2 dbg :: args) newclos (n-1)) end else begin let newclos = Ident.create "clos" in Clet(newclos, - get_field (Cvar clos) 4, - curry_fun (get_field (Cvar clos) 3 :: args) newclos (n-1)) + get_field env (Cvar clos) 4 dbg, + curry_fun (get_field env (Cvar clos) 3 dbg :: args) newclos (n-1)) end in Cfunction {fun_name = "caml_curry" ^ string_of_int arity ^ "_" ^ string_of_int (arity-1); - fun_args = [last_arg, typ_addr; last_clos, typ_addr]; + fun_args = [last_arg, typ_val; last_clos, typ_val]; fun_body = curry_fun [] last_clos (arity-1); fun_fast = true; fun_dbg = Debuginfo.none } let rec intermediate_curry_functions arity num = + let dbg = Debuginfo.none in + let env = empty_env in if num = arity - 1 then [final_curry_function arity] else begin @@ -2346,20 +3299,22 @@ let arg = Ident.create "arg" and clos = Ident.create "clos" in Cfunction {fun_name = name2; - fun_args = [arg, typ_addr; clos, typ_addr]; + fun_args = [arg, typ_val; clos, typ_val]; fun_body = if arity - num > 2 && arity <= max_arity_optimized then Cop(Calloc, - [alloc_closure_header 5; + [alloc_closure_header 5 Debuginfo.none; Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); int_const (arity - num - 1); Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1) ^ "_app"); - Cvar arg; Cvar clos]) + Cvar arg; Cvar clos], + dbg) else Cop(Calloc, - [alloc_closure_header 4; - Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); - int_const 1; Cvar arg; Cvar clos]); + [alloc_closure_header 4 Debuginfo.none; + Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); + int_const 1; Cvar arg; Cvar clos], + dbg); fun_fast = true; fun_dbg = Debuginfo.none } :: @@ -2367,24 +3322,25 @@ let rec iter i = if i <= arity then let arg = Ident.create (Printf.sprintf "arg%d" i) in - (arg, typ_addr) :: iter (i+1) + (arg, typ_val) :: iter (i+1) else [] in let direct_args = iter (num+2) in let rec iter i args clos = if i = 0 then - Cop(Capply(typ_addr, Debuginfo.none), - (get_field (Cvar clos) 2) :: args @ [Cvar clos]) + Cop(Capply typ_val, + (get_field env (Cvar clos) 2 dbg) :: args @ [Cvar clos], + dbg) else let newclos = Ident.create "clos" in Clet(newclos, - get_field (Cvar clos) 4, - iter (i-1) (get_field (Cvar clos) 3 :: args) newclos) + get_field env (Cvar clos) 4 dbg, + iter (i-1) (get_field env (Cvar clos) 3 dbg :: args) newclos) in let cf = Cfunction {fun_name = name1 ^ "_" ^ string_of_int (num+1) ^ "_app"; - fun_args = direct_args @ [clos, typ_addr]; + fun_args = direct_args @ [clos, typ_val]; fun_body = iter (num+1) (List.map (fun (arg,_) -> Cvar arg) direct_args) clos; fun_fast = true; @@ -2396,7 +3352,9 @@ end let curry_function arity = - if arity >= 0 + assert(arity <> 0); + (* Functions with arity = 0 does not have a curry_function *) + if arity > 0 then intermediate_curry_functions arity 0 else [tuplify_function (-arity)] @@ -2428,17 +3386,21 @@ (* Generate the entry point *) let entry_point namelist = + (* CR mshinwell: review all of these "None"s. We should be able to at + least have filenames for these. *) + let dbg = Debuginfo.none in let incr_global_inited = - Cop(Cstore Word, + Cop(Cstore (Word_int, Assignment), [Cconst_symbol "caml_globals_inited"; - Cop(Caddi, [Cop(Cload Word, [Cconst_symbol "caml_globals_inited"]); - Cconst_int 1])]) in + Cop(Caddi, [Cop(Cload (Word_int, Mutable), + [Cconst_symbol "caml_globals_inited"], dbg); + Cconst_int 1], dbg)], dbg) in let body = List.fold_right (fun name next -> let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in - Csequence(Cop(Capply(typ_void, Debuginfo.none), - [Cconst_symbol entry_sym]), + Csequence(Cop(Capply typ_void, + [Cconst_symbol entry_sym], dbg), Csequence(incr_global_inited, next))) namelist (Cconst_int 1) in Cfunction {fun_name = "caml_program"; @@ -2453,7 +3415,7 @@ let global_table namelist = let mksym name = - Csymbol_address (Compilenv.make_symbol ~unitname:name None) + Csymbol_address (Compilenv.make_symbol ~unitname:name (Some "gc_roots")) in Cdata(Cglobal_symbol "caml_globals" :: Cdefine_symbol "caml_globals" :: @@ -2465,9 +3427,8 @@ Cdata(List.map mksym namelist) let global_data name v = - Cdata(Cglobal_symbol name :: - emit_constant name - (Const_base (Const_string (Marshal.to_string v []))) []) + Cdata(emit_structured_constant (name, Global) + (Uconst_string (Marshal.to_string v [])) []) let globals_map v = global_data "caml_globals_map" v @@ -2482,6 +3443,18 @@ List.map mksym namelist @ [cint_zero]) +(* Generate the master table of Spacetime shapes *) + +let spacetime_shapes namelist = + let mksym name = + Csymbol_address ( + Compilenv.make_symbol ~unitname:name (Some "spacetime_shapes")) + in + Cdata(Cglobal_symbol "caml_spacetime_shapes" :: + Cdefine_symbol "caml_spacetime_shapes" :: + List.map mksym namelist + @ [cint_zero]) + (* Generate the table of module data and code segments *) let segment_table namelist symbol begname endname = @@ -2502,20 +3475,20 @@ (* Initialize a predefined exception *) -let predef_exception name = - let bucketname = "caml_bucket_" ^ name in +let predef_exception i name = let symname = "caml_exn_" ^ name in - Cdata(Cglobal_symbol symname :: - emit_constant symname (Const_block(0,[Const_base(Const_string name)])) - [ Cglobal_symbol bucketname; - Cint(block_header 0 1); - Cdefine_symbol bucketname; - Csymbol_address symname ]) + let cst = Uconst_string name in + let label = Compilenv.new_const_symbol () in + let cont = emit_structured_constant (label, Not_global) cst [] in + Cdata(emit_structured_constant (symname, Global) + (Uconst_block(Obj.object_tag, + [ + Uconst_ref(label, Some cst); + Uconst_int (-i-1); + ])) cont) (* Header for a plugin *) -let mapflat f l = List.flatten (List.map f l) - let plugin_header units = let mk (ui,crc) = { dynu_name = ui.ui_name; diff -Nru ocaml-4.01.0/asmcomp/cmmgen.mli ocaml-4.05.0/asmcomp/cmmgen.mli --- ocaml-4.01.0/asmcomp/cmmgen.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/cmmgen.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,18 +1,25 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Translation from closed lambda to C-- *) -val compunit: int -> Clambda.ulambda -> Cmm.phrase list +val compunit: + Clambda.ulambda + * Clambda.preallocated_block list + * Clambda.preallocated_constant list + -> Cmm.phrase list val apply_function: int -> Cmm.phrase val send_function: int -> Cmm.phrase @@ -24,7 +31,9 @@ val globals_map: (string * Digest.t * Digest.t * string list) list -> Cmm.phrase val frame_table: string list -> Cmm.phrase +val spacetime_shapes: string list -> Cmm.phrase val data_segment_table: string list -> Cmm.phrase val code_segment_table: string list -> Cmm.phrase -val predef_exception: string -> Cmm.phrase +val predef_exception: int -> string -> Cmm.phrase val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase +val black_block_header: (*tag:*)int -> (*size:*)int -> nativeint diff -Nru ocaml-4.01.0/asmcomp/cmm.ml ocaml-4.05.0/asmcomp/cmm.ml --- ocaml-4.01.0/asmcomp/cmm.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/cmm.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,32 +1,87 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) type machtype_component = - Addr + | Val + | Addr | Int | Float type machtype = machtype_component array let typ_void = ([||] : machtype_component array) +let typ_val = [|Val|] let typ_addr = [|Addr|] let typ_int = [|Int|] let typ_float = [|Float|] let size_component = function - Addr -> Arch.size_addr + | Val | Addr -> Arch.size_addr | Int -> Arch.size_int | Float -> Arch.size_float +(** [machtype_component]s are partially ordered as follows: + + Addr Float + ^ + | + Val + ^ + | + Int + + In particular, [Addr] must be above [Val], to ensure that if there is + a join point between a code path yielding [Addr] and one yielding [Val] + then the result is treated as a derived pointer into the heap (i.e. [Addr]). + (Such a result may not be live across any call site or a fatal compiler + error will result.) +*) + +let lub_component comp1 comp2 = + match comp1, comp2 with + | Int, Int -> Int + | Int, Val -> Val + | Int, Addr -> Addr + | Val, Int -> Val + | Val, Val -> Val + | Val, Addr -> Addr + | Addr, Int -> Addr + | Addr, Addr -> Addr + | Addr, Val -> Addr + | Float, Float -> Float + | (Int | Addr | Val), Float + | Float, (Int | Addr | Val) -> + (* Float unboxing code must be sure to avoid this case. *) + assert false + +let ge_component comp1 comp2 = + match comp1, comp2 with + | Int, Int -> true + | Int, Addr -> false + | Int, Val -> false + | Val, Int -> true + | Val, Val -> true + | Val, Addr -> false + | Addr, Int -> true + | Addr, Addr -> true + | Addr, Val -> true + | Float, Float -> true + | (Int | Addr | Val), Float + | Float, (Int | Addr | Val) -> + assert false + let size_machtype mty = let size = ref 0 in for i = 0 to Array.length mty - 1 do @@ -52,6 +107,18 @@ | Clt -> Cgt | Cle -> Cge | Cgt -> Clt | Cge -> Cle +type label = int + +let label_counter = ref 99 + +let new_label() = incr label_counter; !label_counter + +type raise_kind = + | Raise_withtrace + | Raise_notrace + +type rec_flag = Nonrecursive | Recursive + type memory_chunk = Byte_unsigned | Byte_signed @@ -59,46 +126,50 @@ | Sixteen_signed | Thirtytwo_unsigned | Thirtytwo_signed - | Word + | Word_int + | Word_val | Single | Double | Double_u -type operation = - Capply of machtype * Debuginfo.t - | Cextcall of string * machtype * bool * Debuginfo.t - | Cload of memory_chunk +and operation = + Capply of machtype + | Cextcall of string * machtype * bool * label option + (** If specified, the given label will be placed immediately after the + call (at the same place as any frame descriptor would reference). *) + | Cload of memory_chunk * Asttypes.mutable_flag | Calloc - | Cstore of memory_chunk - | Caddi | Csubi | Cmuli | Cdivi | Cmodi + | Cstore of memory_chunk * Lambda.initialization_or_assignment + | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi of comparison - | Cadda | Csuba + | Caddv | Cadda | Ccmpa of comparison | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison - | Craise of Debuginfo.t - | Ccheckbound of Debuginfo.t + | Craise of raise_kind + | Ccheckbound type expression = Cconst_int of int | Cconst_natint of nativeint - | Cconst_float of string + | Cconst_float of float | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint + | Cblockheader of nativeint * Debuginfo.t | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression | Ctuple of expression list - | Cop of operation * expression list + | Cop of operation * expression list * Debuginfo.t | Csequence of expression * expression | Cifthenelse of expression * expression * expression - | Cswitch of expression * int array * expression array + | Cswitch of expression * int array * expression array * Debuginfo.t | Cloop of expression - | Ccatch of int * Ident.t list * expression * expression + | Ccatch of rec_flag * (int * Ident.t list * expression) list * expression | Cexit of int * expression list | Ctrywith of expression * Ident.t * expression @@ -107,20 +178,19 @@ fun_args: (Ident.t * machtype) list; fun_body: expression; fun_fast: bool; - fun_dbg : Debuginfo.t; } + fun_dbg : Debuginfo.t; + } type data_item = Cdefine_symbol of string - | Cdefine_label of int | Cglobal_symbol of string | Cint8 of int | Cint16 of int | Cint32 of nativeint | Cint of nativeint - | Csingle of string - | Cdouble of string + | Csingle of float + | Cdouble of float | Csymbol_address of string - | Clabel_address of int | Cstring of string | Cskip of int | Calign of int @@ -128,3 +198,9 @@ type phrase = Cfunction of fundecl | Cdata of data_item list + +let ccatch (i, ids, e1, e2)= + Ccatch(Nonrecursive, [i, ids, e2], e1) + +let reset () = + label_counter := 99 diff -Nru ocaml-4.01.0/asmcomp/cmm.mli ocaml-4.05.0/asmcomp/cmm.mli --- ocaml-4.01.0/asmcomp/cmm.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/cmm.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,30 +1,75 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Second intermediate language (machine independent) *) type machtype_component = - Addr + | Val + | Addr | Int | Float +(* - [Val] denotes a valid OCaml value: either a pointer to the beginning + of a heap block, an infix pointer if it is preceded by the correct + infix header, or a 2n+1 encoded integer. + - [Int] is for integers (not necessarily 2n+1 encoded) and for + pointers outside the heap. + - [Addr] denotes pointers that are neither [Val] nor [Int], i.e. + pointers into the heap that point in the middle of a heap block. + Such derived pointers are produced by e.g. array indexing. + - [Float] is for unboxed floating-point numbers. + +The purpose of these types is twofold. First, they guide register +allocation: type [Float] goes in FP registers, the other types go +into integer registers. Second, they determine how local variables are +tracked by the GC: + - Variables of type [Val] are GC roots. If they are pointers, the + GC will not deallocate the addressed heap block, and will update + the local variable if the heap block moves. + - Variables of type [Int] and [Float] are ignored by the GC. + The GC does not change their values. + - Variables of type [Addr] must never be live across an allocation + point or function call. They cannot be given as roots to the GC + because they don't point after a well-formed block header of the + kind that the GC needs. However, the GC may move the block pointed + into, invalidating the value of the [Addr] variable. +*) + type machtype = machtype_component array val typ_void: machtype +val typ_val: machtype val typ_addr: machtype val typ_int: machtype val typ_float: machtype val size_component: machtype_component -> int + +(** Least upper bound of two [machtype_component]s. *) +val lub_component + : machtype_component + -> machtype_component + -> machtype_component + +(** Returns [true] iff the first supplied [machtype_component] is greater than + or equal to the second under the relation used by [lub_component]. *) +val ge_component + : machtype_component + -> machtype_component + -> bool + val size_machtype: machtype -> int type comparison = @@ -38,6 +83,15 @@ val negate_comparison: comparison -> comparison val swap_comparison: comparison -> comparison +type label = int +val new_label: unit -> label + +type raise_kind = + | Raise_withtrace + | Raise_notrace + +type rec_flag = Nonrecursive | Recursive + type memory_chunk = Byte_unsigned | Byte_signed @@ -45,46 +99,53 @@ | Sixteen_signed | Thirtytwo_unsigned | Thirtytwo_signed - | Word + | Word_int (* integer or pointer outside heap *) + | Word_val (* pointer inside heap or encoded int *) | Single - | Double (* 64-bit-aligned 64-bit float *) - | Double_u (* word-aligned 64-bit float *) + | Double (* 64-bit-aligned 64-bit float *) + | Double_u (* word-aligned 64-bit float *) -type operation = - Capply of machtype * Debuginfo.t - | Cextcall of string * machtype * bool * Debuginfo.t - | Cload of memory_chunk +and operation = + Capply of machtype + | Cextcall of string * machtype * bool * label option + | Cload of memory_chunk * Asttypes.mutable_flag | Calloc - | Cstore of memory_chunk - | Caddi | Csubi | Cmuli | Cdivi | Cmodi + | Cstore of memory_chunk * Lambda.initialization_or_assignment + | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi of comparison - | Cadda | Csuba + | Caddv (* pointer addition that produces a [Val] (well-formed Caml value) *) + | Cadda (* pointer addition that produces a [Addr] (derived heap pointer) *) | Ccmpa of comparison | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison - | Craise of Debuginfo.t - | Ccheckbound of Debuginfo.t + | Craise of raise_kind + | Ccheckbound -type expression = +(** Not all cmm expressions currently have [Debuginfo.t] values attached to + them. The ones that do are those that are likely to generate code that + can fairly robustly be mapped back to a source location. In the future + it might be the case that more [Debuginfo.t] annotations are desirable. *) +and expression = Cconst_int of int | Cconst_natint of nativeint - | Cconst_float of string + | Cconst_float of float | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint + | Cblockheader of nativeint * Debuginfo.t | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression | Ctuple of expression list - | Cop of operation * expression list + | Cop of operation * expression list * Debuginfo.t | Csequence of expression * expression | Cifthenelse of expression * expression * expression - | Cswitch of expression * int array * expression array + | Cswitch of expression * int array * expression array * Debuginfo.t | Cloop of expression - | Ccatch of int * Ident.t list * expression * expression + | Ccatch of rec_flag * (int * Ident.t list * expression) list * expression | Cexit of int * expression list | Ctrywith of expression * Ident.t * expression @@ -93,20 +154,19 @@ fun_args: (Ident.t * machtype) list; fun_body: expression; fun_fast: bool; - fun_dbg : Debuginfo.t; } + fun_dbg : Debuginfo.t; + } type data_item = Cdefine_symbol of string - | Cdefine_label of int | Cglobal_symbol of string | Cint8 of int | Cint16 of int | Cint32 of nativeint | Cint of nativeint - | Csingle of string - | Cdouble of string + | Csingle of float + | Cdouble of float | Csymbol_address of string - | Clabel_address of int | Cstring of string | Cskip of int | Calign of int @@ -114,3 +174,7 @@ type phrase = Cfunction of fundecl | Cdata of data_item list + +val ccatch : int * Ident.t list * expression * expression -> expression + +val reset : unit -> unit diff -Nru ocaml-4.01.0/asmcomp/cmx_format.mli ocaml-4.05.0/asmcomp/cmx_format.mli --- ocaml-4.01.0/asmcomp/cmx_format.mli 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/asmcomp/cmx_format.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,21 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -(* *) -(* Copyright 2010 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2010 Institut National de Recherche en Informatique et *) +(* en Automatique *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Format of .cmx, .cmxa and .cmxs files *) @@ -22,16 +29,21 @@ The .cmx file contains these infos (as an externed record) plus a MD5 of these infos *) +type export_info = + | Clambda of Clambda.value_approximation + | Flambda of Export_info.t + type unit_infos = { mutable ui_name: string; (* Name of unit implemented *) mutable ui_symbol: string; (* Prefix for symbols *) mutable ui_defines: string list; (* Unit and sub-units implemented *) - mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *) - mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *) - mutable ui_approx: Clambda.value_approximation; (* Approx of the structure*) + mutable ui_imports_cmi: + (string * Digest.t option) list; (* Interfaces imported *) + mutable ui_imports_cmx:(string * Digest.t option) list; (* Infos imported *) mutable ui_curry_fun: int list; (* Currying functions needed *) mutable ui_apply_fun: int list; (* Apply functions needed *) mutable ui_send_fun: int list; (* Send functions needed *) + mutable ui_export_info: export_info; mutable ui_force_link: bool } (* Always linked *) (* Each .a library has a matching .cmxa file that provides the following @@ -49,8 +61,8 @@ type dynunit = { dynu_name: string; dynu_crc: Digest.t; - dynu_imports_cmi: (string * Digest.t) list; - dynu_imports_cmx: (string * Digest.t) list; + dynu_imports_cmi: (string * Digest.t option) list; + dynu_imports_cmx: (string * Digest.t option) list; dynu_defines: string list; } diff -Nru ocaml-4.01.0/asmcomp/codegen.ml ocaml-4.05.0/asmcomp/codegen.ml --- ocaml-4.01.0/asmcomp/codegen.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/codegen.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,95 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* From C-- to assembly code *) - -open Format -open Cmm - -let dump_cmm = ref false -let dump_selection = ref false -let dump_live = ref false -let dump_spill = ref false -let dump_split = ref false -let dump_interf = ref false -let dump_prefer = ref false -let dump_regalloc = ref false -let dump_reload = ref false -let dump_linear = ref false - -let rec regalloc fd = - if !dump_live then Printmach.phase "Liveness analysis" fd; - Interf.build_graph fd; - if !dump_interf then Printmach.interferences(); - if !dump_prefer then Printmach.preferences(); - Coloring.allocate_registers(); - if !dump_regalloc then - Printmach.phase "After register allocation" fd; - let (newfd, redo_regalloc) = Reload.fundecl fd in - if !dump_reload then - Printmach.phase "After insertion of reloading code" newfd; - if redo_regalloc - then begin Reg.reinit(); Liveness.fundecl newfd; regalloc newfd end - else newfd - -let fundecl ppf fd_cmm = - if !dump_cmm then begin - fprintf ppf "*** C-- code@."; - fprintf ppf "%a@." Printcmm.fundecl fd_cmm - end; - Reg.reset(); - let fd_sel = Sequence.fundecl fd_cmm in - if !dump_selection then - Printmach.phase "After instruction selection" fd_sel; - Liveness.fundecl fd_sel; - if !dump_live then Printmach.phase "Liveness analysis" fd_sel; - let fd_spill = Spill.fundecl fd_sel in - Liveness.fundecl fd_spill; - if !dump_spill then - Printmach.phase "After spilling" fd_spill; - let fd_split = Split.fundecl fd_spill in - Liveness.fundecl fd_split; - if !dump_split then - Printmach.phase "After live range splitting" fd_split; - let fd_reload = regalloc fd_split in - let fd_linear = Linearize.fundecl fd_reload in - if !dump_linear then begin - printf "*** Linearized code@."; - Printlinear.fundecl fd_linear; print_newline() - end; - Emit.fundecl fd_linear - -let phrase = function - Cfunction fd -> fundecl fd - | Cdata dl -> Emit.data dl - -let file filename = - let ic = open_in filename in - let lb = Lexing.from_channel ic in - try - while true do - phrase(Parsecmm.phrase Lexcmm.token lb) - done - with - End_of_file -> - close_in ic - | Lexcmm.Error msg -> - close_in ic; Lexcmm.report_error lb msg - | Parsing.Parse_error -> - close_in ic; - prerr_string "Syntax error near character "; - prerr_int (Lexing.lexeme_start lb); - prerr_newline() - | Parsecmmaux.Error msg -> - close_in ic; Parsecmmaux.report_error msg - | x -> - close_in ic; raise x diff -Nru ocaml-4.01.0/asmcomp/codegen.mli ocaml-4.05.0/asmcomp/codegen.mli --- ocaml-4.01.0/asmcomp/codegen.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/codegen.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* From C-- to assembly code *) - -val phrase: Cmm.phrase -> unit -val file: string -> unit - -val dump_cmm: bool ref -val dump_selection: bool ref -val dump_live: bool ref -val dump_spill: bool ref -val dump_split: bool ref -val dump_interf: bool ref -val dump_prefer: bool ref -val dump_regalloc: bool ref -val dump_reload: bool ref -val dump_linear: bool ref diff -Nru ocaml-4.01.0/asmcomp/coloring.ml ocaml-4.05.0/asmcomp/coloring.ml --- ocaml-4.01.0/asmcomp/coloring.ml 2013-01-13 16:57:36.000000000 +0000 +++ ocaml-4.05.0/asmcomp/coloring.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Register allocation by coloring of the interference graph *) @@ -47,7 +50,7 @@ if reg.spill then begin (* Preallocate the registers in the stack *) let nslots = Proc.num_stack_slots.(cl) in - let conflict = Array.create nslots false in + let conflict = Array.make nslots false in List.iter (fun r -> match r.loc with @@ -84,14 +87,14 @@ (* Where to start the search for a suitable register. Used to introduce some "randomness" in the choice between registers with equal scores. This offers more opportunities for scheduling. *) - let start_register = Array.create Proc.num_register_classes 0 in + let start_register = Array.make Proc.num_register_classes 0 in (* Assign a location to a register, the best we can. *) let assign_location reg = let cl = Proc.register_class reg in let first_reg = Proc.first_available_register.(cl) in let num_regs = Proc.num_available_registers.(cl) in - let score = Array.create num_regs 0 in + let score = Array.make num_regs 0 in let best_score = ref (-1000000) and best_reg = ref (-1) in let start = start_register.(cl) in if num_regs <> 0 then begin @@ -161,7 +164,7 @@ end else begin (* Sorry, we must put the pseudoreg in a stack location *) let nslots = Proc.num_stack_slots.(cl) in - let score = Array.create nslots 0 in + let score = Array.make nslots 0 in (* Compute the scores as for registers *) List.iter (fun (r, w) -> diff -Nru ocaml-4.01.0/asmcomp/coloring.mli ocaml-4.05.0/asmcomp/coloring.mli --- ocaml-4.01.0/asmcomp/coloring.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/coloring.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Register allocation by coloring of the interference graph *) diff -Nru ocaml-4.01.0/asmcomp/comballoc.ml ocaml-4.05.0/asmcomp/comballoc.ml --- ocaml-4.01.0/asmcomp/comballoc.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/comballoc.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Combine heap allocations occurring in the same basic block *) @@ -23,18 +26,20 @@ let allocated_size = function No_alloc -> 0 - | Pending_alloc(reg, ofs) -> ofs + | Pending_alloc(_, ofs) -> ofs let rec combine i allocstate = match i.desc with - Iend | Ireturn | Iexit _ | Iraise -> + Iend | Ireturn | Iexit _ | Iraise _ -> (i, allocated_size allocstate) - | Iop(Ialloc sz) -> + | Iop(Ialloc { words = sz; _ }) -> begin match allocstate with No_alloc -> let (newnext, newsz) = combine i.next (Pending_alloc(i.res.(0), sz)) in - (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, 0) + (instr_cons_debug (Iop(Ialloc {words = newsz; spacetime_index = 0; + label_after_call_gc = None; })) + i.arg i.res i.dbg newnext, 0) | Pending_alloc(reg, ofs) -> if ofs + sz < Config.max_young_wosize * Arch.size_addr then begin let (newnext, newsz) = @@ -44,15 +49,17 @@ end else begin let (newnext, newsz) = combine i.next (Pending_alloc(i.res.(0), sz)) in - (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, ofs) + (instr_cons_debug (Iop(Ialloc { words = newsz; spacetime_index = 0; + label_after_call_gc = None; })) + i.arg i.res i.dbg newnext, ofs) end end - | Iop(Icall_ind | Icall_imm _ | Iextcall _ | - Itailcall_ind | Itailcall_imm _) -> + | Iop(Icall_ind _ | Icall_imm _ | Iextcall _ | + Itailcall_ind _ | Itailcall_imm _) -> let newnext = combine_restart i.next in (instr_cons_debug i.desc i.arg i.res i.dbg newnext, allocated_size allocstate) - | Iop op -> + | Iop _ -> let (newnext, sz) = combine i.next allocstate in (instr_cons_debug i.desc i.arg i.res i.dbg newnext, sz) | Iifthenelse(test, ifso, ifnot) -> @@ -70,11 +77,13 @@ let newbody = combine_restart body in (instr_cons (Iloop(newbody)) i.arg i.res i.next, allocated_size allocstate) - | Icatch(io, body, handler) -> + | Icatch(rec_flag, handlers, body) -> let (newbody, sz) = combine body allocstate in - let newhandler = combine_restart handler in + let newhandlers = + List.map (fun (io, handler) -> io, combine_restart handler) handlers in let newnext = combine_restart i.next in - (instr_cons (Icatch(io, newbody, newhandler)) i.arg i.res newnext, sz) + (instr_cons (Icatch(rec_flag, newhandlers, newbody)) + i.arg i.res newnext, sz) | Itrywith(body, handler) -> let (newbody, sz) = combine body allocstate in let newhandler = combine_restart handler in @@ -85,4 +94,5 @@ let (newi, _) = combine i No_alloc in newi let fundecl f = - {f with fun_body = combine_restart f.fun_body} + if Config.spacetime then f + else {f with fun_body = combine_restart f.fun_body} diff -Nru ocaml-4.01.0/asmcomp/comballoc.mli ocaml-4.05.0/asmcomp/comballoc.mli --- ocaml-4.01.0/asmcomp/comballoc.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/comballoc.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Combine heap allocations occurring in the same basic block *) diff -Nru ocaml-4.01.0/asmcomp/compilenv.ml ocaml-4.05.0/asmcomp/compilenv.ml --- ocaml-4.01.0/asmcomp/compilenv.ml 2013-07-23 14:48:47.000000000 +0000 +++ ocaml-4.05.0/asmcomp/compilenv.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,20 +1,28 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2010 Institut National de Recherche en Informatique et *) +(* en Automatique *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Compilation environments for compilation units *) +[@@@ocaml.warning "+a-4-9-40-41-42"] + open Config open Misc -open Clambda open Cmx_format type error = @@ -26,9 +34,47 @@ let global_infos_table = (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t) +let export_infos_table = + (Hashtbl.create 10 : (string, Export_info.t) Hashtbl.t) -let structured_constants = - ref ([] : (string * bool * Lambda.structured_constant) list) +let imported_sets_of_closures_table = + (Set_of_closures_id.Tbl.create 10 + : Flambda.function_declarations option Set_of_closures_id.Tbl.t) + +let sourcefile = ref None + +module CstMap = + Map.Make(struct + type t = Clambda.ustructured_constant + let compare = Clambda.compare_structured_constants + (* PR#6442: it is incorrect to use Pervasives.compare on values of type t + because it compares "0.0" and "-0.0" equal. *) + end) + +type structured_constants = + { + strcst_shared: string CstMap.t; + strcst_all: (string * Clambda.ustructured_constant) list; + } + +let structured_constants_empty = + { + strcst_shared = CstMap.empty; + strcst_all = []; + } + +let structured_constants = ref structured_constants_empty + + +let exported_constants = Hashtbl.create 17 + +let merged_environment = ref Export_info.empty + +let default_ui_export_info = + if Config.flambda then + Cmx_format.Flambda Export_info.empty + else + Cmx_format.Clambda Value_unknown let current_unit = { ui_name = ""; @@ -36,11 +82,11 @@ ui_defines = []; ui_imports_cmi = []; ui_imports_cmx = []; - ui_approx = Value_unknown; ui_curry_fun = []; ui_apply_fun = []; ui_send_fun = []; - ui_force_link = false } + ui_force_link = false; + ui_export_info = default_ui_export_info } let symbolname_for_pack pack name = match pack with @@ -56,10 +102,25 @@ Buffer.add_string b name; Buffer.contents b +let unit_id_from_name name = Ident.create_persistent name + +let concat_symbol unitname id = + unitname ^ "__" ^ id + +let make_symbol ?(unitname = current_unit.ui_symbol) idopt = + let prefix = "caml" ^ unitname in + match idopt with + | None -> prefix + | Some id -> concat_symbol prefix id -let reset ?packname name = +let current_unit_linkage_name () = + Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None) + +let reset ?packname ~source_provenance:file name = Hashtbl.clear global_infos_table; + Set_of_closures_id.Tbl.clear imported_sets_of_closures_table; let symbol = symbolname_for_pack packname name in + sourcefile := Some file; current_unit.ui_name <- name; current_unit.ui_symbol <- symbol; current_unit.ui_defines <- [symbol]; @@ -68,8 +129,18 @@ current_unit.ui_curry_fun <- []; current_unit.ui_apply_fun <- []; current_unit.ui_send_fun <- []; - current_unit.ui_force_link <- false; - structured_constants := [] + current_unit.ui_force_link <- !Clflags.link_everything; + Hashtbl.clear exported_constants; + structured_constants := structured_constants_empty; + current_unit.ui_export_info <- default_ui_export_info; + merged_environment := Export_info.empty; + Hashtbl.clear export_infos_table; + let compilation_unit = + Compilation_unit.create + (Ident.create_persistent name) + (current_unit_linkage_name ()) + in + Compilation_unit.set_current compilation_unit let current_unit_infos () = current_unit @@ -77,16 +148,30 @@ let current_unit_name () = current_unit.ui_name +let current_build () = + match !sourcefile with + | None -> assert false + | Some v -> v + let make_symbol ?(unitname = current_unit.ui_symbol) idopt = let prefix = "caml" ^ unitname in match idopt with | None -> prefix | Some id -> prefix ^ "__" ^ id +let symbol_in_current_unit name = + let prefix = "caml" ^ current_unit.ui_symbol in + name = prefix || + (let lp = String.length prefix in + String.length name >= 2 + lp + && String.sub name 0 lp = prefix + && name.[lp] = '_' + && name.[lp + 1] = '_') + let read_unit_info filename = let ic = open_in_bin filename in try - let buffer = input_bytes ic (String.length cmx_magic_number) in + let buffer = really_input_string ic (String.length cmx_magic_number) in if buffer <> cmx_magic_number then begin close_in ic; raise(Error(Not_a_unit_info filename)) @@ -101,7 +186,7 @@ let read_library_info filename = let ic = open_in_bin filename in - let buffer = input_bytes ic (String.length cmxa_magic_number) in + let buffer = really_input_string ic (String.length cmxa_magic_number) in if buffer <> cmxa_magic_number then raise(Error(Not_a_unit_info filename)); let infos = (input_value ic : library_infos) in @@ -111,9 +196,6 @@ (* Read and cache info on global identifiers *) -let cmx_not_found_crc = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" - let get_global_info global_ident = ( let modname = Ident.name global_ident in if modname = current_unit.ui_name then @@ -123,15 +205,21 @@ Hashtbl.find global_infos_table modname with Not_found -> let (infos, crc) = - try - let filename = - find_in_path_uncap !load_path (modname ^ ".cmx") in - let (ui, crc) = read_unit_info filename in - if ui.ui_name <> modname then - raise(Error(Illegal_renaming(modname, ui.ui_name, filename))); - (Some ui, crc) - with Not_found -> - (None, cmx_not_found_crc) in + if Env.is_imported_opaque modname then (None, None) + else begin + try + let filename = + find_in_path_uncap !load_path (modname ^ ".cmx") in + let (ui, crc) = read_unit_info filename in + if ui.ui_name <> modname then + raise(Error(Illegal_renaming(modname, ui.ui_name, filename))); + (Some ui, Some crc) + with Not_found -> + let warn = Warnings.No_cmx_file modname in + Location.prerr_warning Location.none warn; + (None, None) + end + in current_unit.ui_imports_cmx <- (modname, crc) :: current_unit.ui_imports_cmx; Hashtbl.add global_infos_table modname infos; @@ -144,18 +232,26 @@ (* Return the approximation of a global identifier *) -let toplevel_approx = Hashtbl.create 16 - -let record_global_approx_toplevel id = - Hashtbl.add toplevel_approx current_unit.ui_name current_unit.ui_approx +let get_clambda_approx ui = + assert(not Config.flambda); + match ui.ui_export_info with + | Flambda _ -> assert false + | Clambda approx -> approx + +let toplevel_approx : + (string, Clambda.value_approximation) Hashtbl.t = Hashtbl.create 16 + +let record_global_approx_toplevel () = + Hashtbl.add toplevel_approx current_unit.ui_name + (get_clambda_approx current_unit) let global_approx id = - if Ident.is_predef_exn id then Value_unknown + if Ident.is_predef_exn id then Clambda.Value_unknown else try Hashtbl.find toplevel_approx (Ident.name id) with Not_found -> match get_global_info id with - | None -> Value_unknown - | Some ui -> ui.ui_approx + | None -> Clambda.Value_unknown + | Some ui -> get_clambda_approx ui (* Return the symbol used to refer to a global identifier *) @@ -163,15 +259,72 @@ if Ident.is_predef_exn id then "caml_exn_" ^ Ident.name id else begin - match get_global_info id with + let unitname = Ident.name id in + match + try ignore (Hashtbl.find toplevel_approx unitname); None + with Not_found -> get_global_info id + with | None -> make_symbol ~unitname:(Ident.name id) None | Some ui -> make_symbol ~unitname:ui.ui_symbol None end (* Register the approximation of the module being compiled *) +let unit_for_global id = + let sym_label = Linkage_name.create (symbol_for_global id) in + Compilation_unit.create id sym_label + +let predefined_exception_compilation_unit = + Compilation_unit.create (Ident.create_persistent "__dummy__") + (Linkage_name.create "__dummy__") + +let is_predefined_exception sym = + Compilation_unit.equal + predefined_exception_compilation_unit + (Symbol.compilation_unit sym) + +let symbol_for_global' id = + let sym_label = Linkage_name.create (symbol_for_global id) in + if Ident.is_predef_exn id then + Symbol.unsafe_create predefined_exception_compilation_unit sym_label + else + Symbol.unsafe_create (unit_for_global id) sym_label + let set_global_approx approx = - current_unit.ui_approx <- approx + assert(not Config.flambda); + current_unit.ui_export_info <- Clambda approx + +(* Exporting and importing cross module information *) + +let get_flambda_export_info ui = + assert(Config.flambda); + match ui.ui_export_info with + | Clambda _ -> assert false + | Flambda ei -> ei + +let set_export_info export_info = + assert(Config.flambda); + current_unit.ui_export_info <- Flambda export_info + +let approx_for_global comp_unit = + let id = Compilation_unit.get_persistent_ident comp_unit in + if (Compilation_unit.equal + predefined_exception_compilation_unit + comp_unit) + || Ident.is_predef_exn id + || not (Ident.global id) + then invalid_arg (Format.asprintf "approx_for_global %a" Ident.print id); + let modname = Ident.name id in + try Hashtbl.find export_infos_table modname with + | Not_found -> + let exported = match get_global_info id with + | None -> Export_info.empty + | Some ui -> get_flambda_export_info ui in + Hashtbl.add export_infos_table modname exported; + merged_environment := Export_info.merge !merged_environment exported; + exported + +let approx_env () = !merged_environment (* Record that a currying function or application function is needed *) @@ -180,6 +333,7 @@ current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun let need_apply_fun n = + assert(n > 0); if not (List.mem n current_unit.ui_apply_fun) then current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun @@ -199,27 +353,88 @@ close_out oc let save_unit_info filename = - current_unit.ui_imports_cmi <- Env.imported_units(); + current_unit.ui_imports_cmi <- Env.imports(); write_unit_info current_unit filename +let current_unit_linkage_name () = + Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None) +let current_unit () = + match Compilation_unit.get_current () with + | Some current_unit -> current_unit + | None -> Misc.fatal_error "Compilenv.current_unit" -let const_label = ref 0 +let current_unit_symbol () = + Symbol.unsafe_create (current_unit ()) (current_unit_linkage_name ()) -let new_const_label () = - incr const_label; - !const_label +let const_label = ref 0 let new_const_symbol () = incr const_label; make_symbol (Some (string_of_int !const_label)) -let new_structured_constant cst global = - let lbl = new_const_symbol() in - structured_constants := (lbl, global, cst) :: !structured_constants; - lbl +let snapshot () = !structured_constants +let backtrack s = structured_constants := s -let structured_constants () = !structured_constants +let new_structured_constant cst ~shared = + let {strcst_shared; strcst_all} = !structured_constants in + if shared then + try + CstMap.find cst strcst_shared + with Not_found -> + let lbl = new_const_symbol() in + structured_constants := + { + strcst_shared = CstMap.add cst lbl strcst_shared; + strcst_all = (lbl, cst) :: strcst_all; + }; + lbl + else + let lbl = new_const_symbol() in + structured_constants := + { + strcst_shared; + strcst_all = (lbl, cst) :: strcst_all; + }; + lbl + +let add_exported_constant s = + Hashtbl.replace exported_constants s () + +let clear_structured_constants () = + structured_constants := structured_constants_empty + +let structured_constants () = + List.map + (fun (symbol, definition) -> + { + Clambda.symbol; + exported = Hashtbl.mem exported_constants symbol; + definition; + }) + (!structured_constants).strcst_all + +let closure_symbol fv = + let compilation_unit = Closure_id.get_compilation_unit fv in + let unitname = + Linkage_name.to_string (Compilation_unit.get_linkage_name compilation_unit) + in + let linkage_name = + concat_symbol unitname ((Closure_id.unique_name fv) ^ "_closure") + in + Symbol.unsafe_create compilation_unit (Linkage_name.create linkage_name) + +let function_label fv = + let compilation_unit = Closure_id.get_compilation_unit fv in + let unitname = + Linkage_name.to_string + (Compilation_unit.get_linkage_name compilation_unit) + in + (concat_symbol unitname (Closure_id.unique_name fv)) + +let require_global global_ident = + if not (Ident.is_predef_exn global_ident) then + ignore (get_global_info global_ident : Cmx_format.unit_infos option) (* Error report *) @@ -236,3 +451,10 @@ fprintf ppf "%a@ contains the description for unit\ @ %s when %s was expected" Location.print_filename filename name modname + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff -Nru ocaml-4.01.0/asmcomp/compilenv.mli ocaml-4.05.0/asmcomp/compilenv.mli --- ocaml-4.01.0/asmcomp/compilenv.mli 2013-04-29 14:57:38.000000000 +0000 +++ ocaml-4.05.0/asmcomp/compilenv.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,28 +1,62 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2010 Institut National de Recherche en Informatique et *) +(* en Automatique *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Compilation environments for compilation units *) open Cmx_format -val reset: ?packname:string -> string -> unit +(* CR-soon mshinwell: this is a bit ugly + mshinwell: deferred CR, this has been addressed in the export info + improvement feature. +*) +val imported_sets_of_closures_table + : Flambda.function_declarations option Set_of_closures_id.Tbl.t + (* flambda-only *) + +val reset: ?packname:string -> source_provenance:Timings.source_provenance -> + string -> unit (* Reset the environment and record the name of the unit being compiled (arg). Optional argument is [-for-pack] prefix. *) +val unit_id_from_name: string -> Ident.t + (* flambda-only *) + val current_unit_infos: unit -> unit_infos (* Return the infos for the unit being compiled *) val current_unit_name: unit -> string - (* Return the name of the unit being compiled *) + (* Return the name of the unit being compiled + clambda-only *) + +val current_unit_linkage_name: unit -> Linkage_name.t + (* Return the linkage_name of the unit being compiled. + flambda-only *) + +val current_build: unit -> Timings.source_provenance + (* Return the kind of build source being compiled. If it is a + file compilation it also provides the filename. *) + +val current_unit: unit -> Compilation_unit.t + (* flambda-only *) + +val current_unit_symbol: unit -> Symbol.t + (* flambda-only *) val make_symbol: ?unitname:string -> string option -> string (* [make_symbol ~unitname:u None] returns the asm symbol that @@ -31,16 +65,40 @@ corresponds to symbol [id] in the compilation unit [u] (or the current unit). *) -val symbol_for_global: Ident.t -> string - (* Return the asm symbol that refers to the given global identifier *) +val symbol_in_current_unit: string -> bool + (* Return true if the given asm symbol belongs to the + current compilation unit, false otherwise. *) + +val is_predefined_exception: Symbol.t -> bool + (* flambda-only *) +val unit_for_global: Ident.t -> Compilation_unit.t + (* flambda-only *) + +val symbol_for_global: Ident.t -> string + (* Return the asm symbol that refers to the given global identifier + flambda-only *) +val symbol_for_global': Ident.t -> Symbol.t + (* flambda-only *) val global_approx: Ident.t -> Clambda.value_approximation - (* Return the approximation for the given global identifier *) + (* Return the approximation for the given global identifier + clambda-only *) val set_global_approx: Clambda.value_approximation -> unit - (* Record the approximation of the unit being compiled *) + (* Record the approximation of the unit being compiled + clambda-only *) val record_global_approx_toplevel: unit -> unit - (* Record the current approximation for the current toplevel phrase *) + (* Record the current approximation for the current toplevel phrase + clambda-only *) +val set_export_info: Export_info.t -> unit + (* Record the informations of the unit being compiled + flambda-only *) +val approx_env: unit -> Export_info.t + (* Returns all the information loaded from extenal compilation units + flambda-only *) +val approx_for_global: Compilation_unit.t -> Export_info.t + (* Loads the exported information declaring the compilation_unit + flambda-only *) val need_curry_fun: int -> unit val need_apply_fun: int -> unit @@ -49,10 +107,29 @@ message sending) function with the given arity *) val new_const_symbol : unit -> string -val new_const_label : unit -> int -val new_structured_constant : Lambda.structured_constant -> bool -> string -val structured_constants : - unit -> (string * bool * Lambda.structured_constant) list +val closure_symbol : Closure_id.t -> Symbol.t + (* Symbol of a function if the function is + closed (statically allocated) + flambda-only *) +val function_label : Closure_id.t -> string + (* linkage name of the code of a function + flambda-only *) + +val new_structured_constant: + Clambda.ustructured_constant -> + shared:bool -> (* can be shared with another structually equal constant *) + string +val structured_constants: + unit -> Clambda.preallocated_constant list +val clear_structured_constants: unit -> unit +val add_exported_constant: string -> unit + (* clambda-only *) +type structured_constants + (* clambda-only *) +val snapshot: unit -> structured_constants + (* clambda-only *) +val backtrack: structured_constants -> unit + (* clambda-only *) val read_unit_info: string -> unit_infos * Digest.t (* Read infos and MD5 from a [.cmx] file. *) @@ -65,9 +142,9 @@ honored by [symbol_for_global] and [global_approx] without looking at the corresponding .cmx file. *) -val cmx_not_found_crc: Digest.t - (* Special digest used in the [ui_imports_cmx] list to signal - that no [.cmx] file was found and used for the imported unit *) +val require_global: Ident.t -> unit + (* Enforce a link dependency of the current compilation + unit to the required module *) val read_library_info: string -> library_infos diff -Nru ocaml-4.01.0/asmcomp/CSEgen.ml ocaml-4.05.0/asmcomp/CSEgen.ml --- ocaml-4.01.0/asmcomp/CSEgen.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/CSEgen.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,366 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Common subexpression elimination by value numbering over extended + basic blocks. *) + +open Mach + +type valnum = int + +(* Classification of operations *) + +type op_class = + | Op_pure (* pure arithmetic, produce one or several result *) + | Op_checkbound (* checkbound-style: no result, can raise an exn *) + | Op_load (* memory load *) + | Op_store of bool (* memory store, false = init, true = assign *) + | Op_other (* anything else that does not allocate nor store in memory *) + +(* We maintain sets of equations of the form + valnums = operation(valnums) + plus a mapping from registers to valnums (value numbers). *) + +type rhs = operation * valnum array + +module Equations = struct + module Rhs_map = + Map.Make(struct type t = rhs let compare = Pervasives.compare end) + + type 'a t = + { load_equations : 'a Rhs_map.t; + other_equations : 'a Rhs_map.t } + + let empty = + { load_equations = Rhs_map.empty; + other_equations = Rhs_map.empty } + + let add op_class op v m = + match op_class with + | Op_load -> + { m with load_equations = Rhs_map.add op v m.load_equations } + | _ -> + { m with other_equations = Rhs_map.add op v m.other_equations } + + let find op_class op m = + match op_class with + | Op_load -> + Rhs_map.find op m.load_equations + | _ -> + Rhs_map.find op m.other_equations + + let remove_loads m = + { load_equations = Rhs_map.empty; + other_equations = m.other_equations } +end + +type numbering = + { num_next: int; (* next fresh value number *) + num_eqs: valnum array Equations.t; (* mapping rhs -> valnums *) + num_reg: valnum Reg.Map.t } (* mapping register -> valnum *) + +let empty_numbering = + { num_next = 0; num_eqs = Equations.empty; num_reg = Reg.Map.empty } + +(** Generate a fresh value number [v] and associate it to register [r]. + Returns a pair [(n',v)] with the updated value numbering [n']. *) + +let fresh_valnum_reg n r = + let v = n.num_next in + ({n with num_next = v + 1; num_reg = Reg.Map.add r v n.num_reg}, v) + +(* Same, for a set of registers [rs]. *) + +let array_fold_transf (f: numbering -> 'a -> numbering * 'b) n (a: 'a array) + : numbering * 'b array = + match Array.length a with + | 0 -> (n, [||]) + | 1 -> let (n', b) = f n a.(0) in (n', [|b|]) + | l -> let b = Array.make l 0 and n = ref n in + for i = 0 to l - 1 do + let (n', x) = f !n a.(i) in + b.(i) <- x; n := n' + done; + (!n, b) + +let fresh_valnum_regs n rs = + array_fold_transf fresh_valnum_reg n rs + +(** [valnum_reg n r] returns the value number for the contents of + register [r]. If none exists, a fresh value number is returned + and associated with register [r]. The possibly updated numbering + is also returned. [valnum_regs] is similar, but for an array of + registers. *) + +let valnum_reg n r = + try + (n, Reg.Map.find r n.num_reg) + with Not_found -> + fresh_valnum_reg n r + +let valnum_regs n rs = + array_fold_transf valnum_reg n rs + +(* Look up the set of equations for an equation with the given rhs. + Return [Some res] if there is one, where [res] is the lhs. *) + +let find_equation op_class n rhs = + try + Some(Equations.find op_class rhs n.num_eqs) + with Not_found -> + None + +(* Find a register containing the given value number. *) + +let find_reg_containing n v = + Reg.Map.fold (fun r v' res -> if v' = v then Some r else res) + n.num_reg None + +(* Find a set of registers containing the given value numbers. *) + +let find_regs_containing n vs = + match Array.length vs with + | 0 -> Some [||] + | 1 -> begin match find_reg_containing n vs.(0) with + | None -> None + | Some r -> Some [|r|] + end + | l -> let rs = Array.make l Reg.dummy in + begin try + for i = 0 to l - 1 do + match find_reg_containing n vs.(i) with + | None -> raise Exit + | Some r -> rs.(i) <- r + done; + Some rs + with Exit -> + None + end + +(* Associate the given value number to the given result register, + without adding new equations. *) + +let set_known_reg n r v = + { n with num_reg = Reg.Map.add r v n.num_reg } + +(* Associate the given value numbers to the given result registers, + without adding new equations. *) + +let array_fold2 f n a1 a2 = + let l = Array.length a1 in + assert (l = Array.length a2); + let n = ref n in + for i = 0 to l - 1 do n := f !n a1.(i) a2.(i) done; + !n + +let set_known_regs n rs vs = + array_fold2 set_known_reg n rs vs + +(* Record the effect of a move: no new equations, but the result reg + maps to the same value number as the argument reg. *) + +let set_move n src dst = + let (n1, v) = valnum_reg n src in + { n1 with num_reg = Reg.Map.add dst v n1.num_reg } + +(* Record the equation [fresh valnums = rhs] and associate the given + result registers [rs] to [fresh valnums]. *) + +let set_fresh_regs n rs rhs op_class = + let (n1, vs) = fresh_valnum_regs n rs in + { n1 with num_eqs = Equations.add op_class rhs vs n.num_eqs } + +(* Forget everything we know about the given result registers, + which are receiving unpredictable values at run-time. *) + +let set_unknown_regs n rs = + { n with num_reg = Array.fold_right Reg.Map.remove rs n.num_reg } + +(* Keep only the equations satisfying the given predicate. *) + +let remove_load_numbering n = + { n with num_eqs = Equations.remove_loads n.num_eqs } + +(* Forget everything we know about registers of type [Addr]. *) + +let kill_addr_regs n = + { n with num_reg = + Reg.Map.filter (fun r _n -> r.Reg.typ <> Cmm.Addr) n.num_reg } + +(* Prepend a set of moves before [i] to assign [srcs] to [dsts]. *) + +let insert_single_move i src dst = instr_cons (Iop Imove) [|src|] [|dst|] i + +let insert_move srcs dsts i = + match Array.length srcs with + | 0 -> i + | 1 -> instr_cons (Iop Imove) srcs dsts i + | _ -> (* Parallel move: first copy srcs into tmps one by one, + then copy tmps into dsts one by one *) + let tmps = Reg.createv_like srcs in + let i1 = array_fold2 insert_single_move i tmps dsts in + array_fold2 insert_single_move i1 srcs tmps + +class cse_generic = object (self) + +(* Default classification of operations. Can be overriden in + processor-specific files to classify specific operations better. *) + +method class_of_operation op = + match op with + | Imove | Ispill | Ireload -> assert false (* treated specially *) + | Iconst_int _ | Iconst_float _ | Iconst_symbol _ -> Op_pure + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ + | Iextcall _ -> assert false (* treated specially *) + | Istackoffset _ -> Op_other + | Iload(_,_) -> Op_load + | Istore(_,_,asg) -> Op_store asg + | Ialloc _ -> assert false (* treated specially *) + | Iintop(Icheckbound _) -> Op_checkbound + | Iintop _ -> Op_pure + | Iintop_imm(Icheckbound _, _) -> Op_checkbound + | Iintop_imm(_, _) -> Op_pure + | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Ifloatofint | Iintoffloat -> Op_pure + | Ispecific _ -> Op_other + +(* Operations that are so cheap that it isn't worth factoring them. *) + +method is_cheap_operation op = + match op with + | Iconst_int _ -> true + | _ -> false + +(* Forget all equations involving memory loads. Performed after a + non-initializing store *) + +method private kill_loads n = + remove_load_numbering n + +(* Perform CSE on the given instruction [i] and its successors. + [n] is the value numbering current at the beginning of [i]. *) + +method private cse n i = + match i.desc with + | Iend | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) + | Iexit _ | Iraise _ -> + i + | Iop (Imove | Ispill | Ireload) -> + (* For moves, we associate the same value number to the result reg + as to the argument reg. *) + let n1 = set_move n i.arg.(0) i.res.(0) in + {i with next = self#cse n1 i.next} + | Iop (Icall_ind _ | Icall_imm _ | Iextcall _) -> + (* For function calls, we should at least forget: + - equations involving memory loads, since the callee can + perform arbitrary memory stores; + - equations involving arithmetic operations that can + produce [Addr]-typed derived pointers into the heap + (see below for Ialloc); + - mappings from hardware registers to value numbers, + since the callee does not preserve these registers. + That doesn't leave much usable information: checkbounds + could be kept, but won't be usable for CSE as one of their + arguments is always a memory load. For simplicity, we + just forget everything. *) + {i with next = self#cse empty_numbering i.next} + | Iop (Ialloc _) -> + (* For allocations, we must avoid extending the live range of a + pseudoregister across the allocation if this pseudoreg + is a derived heap pointer (a pointer into the heap that does + not point to the beginning of a Caml block). PR#6484 is an + example of this situation. Such pseudoregs have type [Addr]. + Pseudoregs with types other than [Addr] can be kept. + Moreover, allocation can trigger the asynchronous execution + of arbitrary Caml code (finalizer, signal handler, context + switch), which can contain non-initializing stores. + Hence, all equations over loads must be removed. *) + let n1 = kill_addr_regs (self#kill_loads n) in + let n2 = set_unknown_regs n1 i.res in + {i with next = self#cse n2 i.next} + | Iop op -> + begin match self#class_of_operation op with + | (Op_pure | Op_checkbound | Op_load) as op_class -> + let (n1, varg) = valnum_regs n i.arg in + let n2 = set_unknown_regs n1 (Proc.destroyed_at_oper i.desc) in + begin match find_equation op_class n1 (op, varg) with + | Some vres -> + (* This operation was computed earlier. *) + (* Are there registers that hold the results computed earlier? *) + begin match find_regs_containing n1 vres with + | Some res when (not (self#is_cheap_operation op)) + && (not (Proc.regs_are_volatile res)) -> + (* We can replace res <- op args with r <- move res, + provided res are stable (non-volatile) registers. + If the operation is very cheap to compute, e.g. + an integer constant, don't bother. *) + let n3 = set_known_regs n1 i.res vres in + (* This is n1 above and not n2 because the move + does not destroy any regs *) + insert_move res i.res (self#cse n3 i.next) + | _ -> + (* We already computed the operation but lost its + results. Associate the result registers to + the result valnums of the previous operation. *) + let n3 = set_known_regs n2 i.res vres in + {i with next = self#cse n3 i.next} + end + | None -> + (* This operation produces a result we haven't seen earlier. *) + let n3 = set_fresh_regs n2 i.res (op, varg) op_class in + {i with next = self#cse n3 i.next} + end + | Op_store false | Op_other -> + (* An initializing store or an "other" operation do not invalidate + any equations, but we do not know anything about the results. *) + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + let n2 = set_unknown_regs n1 i.res in + {i with next = self#cse n2 i.next} + | Op_store true -> + (* A non-initializing store can invalidate + anything we know about prior loads. *) + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + let n2 = set_unknown_regs n1 i.res in + let n3 = self#kill_loads n2 in + {i with next = self#cse n3 i.next} + end + (* For control structures, we set the numbering to empty at every + join point, but propagate the current numbering across fork points. *) + | Iifthenelse(test, ifso, ifnot) -> + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + {i with desc = Iifthenelse(test, self#cse n1 ifso, self#cse n1 ifnot); + next = self#cse empty_numbering i.next} + | Iswitch(index, cases) -> + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + {i with desc = Iswitch(index, Array.map (self#cse n1) cases); + next = self#cse empty_numbering i.next} + | Iloop(body) -> + {i with desc = Iloop(self#cse empty_numbering body); + next = self#cse empty_numbering i.next} + | Icatch(rec_flag, handlers, body) -> + let aux (nfail, handler) = + nfail, self#cse empty_numbering handler + in + {i with desc = Icatch(rec_flag, List.map aux handlers, self#cse n body); + next = self#cse empty_numbering i.next} + | Itrywith(body, handler) -> + {i with desc = Itrywith(self#cse n body, + self#cse empty_numbering handler); + next = self#cse empty_numbering i.next} + +method fundecl f = + {f with fun_body = self#cse empty_numbering f.fun_body} + +end diff -Nru ocaml-4.01.0/asmcomp/CSEgen.mli ocaml-4.05.0/asmcomp/CSEgen.mli --- ocaml-4.01.0/asmcomp/CSEgen.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/CSEgen.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Common subexpression elimination by value numbering over extended + basic blocks. *) + +type op_class = + | Op_pure (* pure, produce one result *) + | Op_checkbound (* checkbound-style: no result, can raise an exn *) + | Op_load (* memory load *) + | Op_store of bool (* memory store, false = init, true = assign *) + | Op_other (* anything else that does not allocate nor store in memory *) + +class cse_generic : object + (* The following methods can be overriden to handle processor-specific + operations. *) + + method class_of_operation: Mach.operation -> op_class + + method is_cheap_operation: Mach.operation -> bool + (* Operations that are so cheap that it isn't worth factoring them. *) + + (* The following method is the entry point and should not be overridden *) + method fundecl: Mach.fundecl -> Mach.fundecl + +end diff -Nru ocaml-4.01.0/asmcomp/deadcode.ml ocaml-4.05.0/asmcomp/deadcode.ml --- ocaml-4.01.0/asmcomp/deadcode.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/deadcode.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,81 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Dead code elimination: remove pure instructions whose results are + not used. *) + +open Mach + +(* [deadcode i] returns a pair of an optimized instruction [i'] + and a set of registers live "before" instruction [i]. *) + +let rec deadcode i = + let arg = + if Config.spacetime + && Mach.spacetime_node_hole_pointer_is_live_before i + then Array.append i.arg [| Proc.loc_spacetime_node_hole |] + else i.arg + in + match i.desc with + | Iend | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) | Iraise _ -> + (i, Reg.add_set_array i.live arg) + | Iop op -> + let (s, before) = deadcode i.next in + if Proc.op_is_pure op (* no side effects *) + && Reg.disjoint_set_array before i.res (* results are not used after *) + && not (Proc.regs_are_volatile arg) (* no stack-like hard reg *) + && not (Proc.regs_are_volatile i.res) (* is involved *) + then begin + assert (Array.length i.res > 0); (* sanity check *) + (s, before) + end else begin + ({i with next = s}, Reg.add_set_array i.live arg) + end + | Iifthenelse(test, ifso, ifnot) -> + let (ifso', _) = deadcode ifso in + let (ifnot', _) = deadcode ifnot in + let (s, _) = deadcode i.next in + ({i with desc = Iifthenelse(test, ifso', ifnot'); next = s}, + Reg.add_set_array i.live arg) + | Iswitch(index, cases) -> + let cases' = Array.map (fun c -> fst (deadcode c)) cases in + let (s, _) = deadcode i.next in + ({i with desc = Iswitch(index, cases'); next = s}, + Reg.add_set_array i.live arg) + | Iloop(body) -> + let (body', _) = deadcode body in + let (s, _) = deadcode i.next in + ({i with desc = Iloop body'; next = s}, i.live) + | Icatch(rec_flag, handlers, body) -> + let (body', _) = deadcode body in + let handlers' = + List.map (fun (nfail, handler) -> + let (handler', _) = deadcode handler in + nfail, handler') + handlers + in + let (s, _) = deadcode i.next in + ({i with desc = Icatch(rec_flag, handlers', body'); next = s}, i.live) + | Iexit _nfail -> + (i, i.live) + | Itrywith(body, handler) -> + let (body', _) = deadcode body in + let (handler', _) = deadcode handler in + let (s, _) = deadcode i.next in + ({i with desc = Itrywith(body', handler'); next = s}, i.live) + +let fundecl f = + let (new_body, _) = deadcode f.fun_body in + {f with fun_body = new_body} diff -Nru ocaml-4.01.0/asmcomp/deadcode.mli ocaml-4.05.0/asmcomp/deadcode.mli --- ocaml-4.01.0/asmcomp/deadcode.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/deadcode.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Dead code elimination: remove pure instructions whose results are + not used. *) + +val fundecl: Mach.fundecl -> Mach.fundecl diff -Nru ocaml-4.01.0/asmcomp/debuginfo.ml ocaml-4.05.0/asmcomp/debuginfo.ml --- ocaml-4.01.0/asmcomp/debuginfo.ml 2012-07-30 18:04:46.000000000 +0000 +++ ocaml-4.05.0/asmcomp/debuginfo.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -open Lexing -open Location - -type kind = Dinfo_call | Dinfo_raise - -type t = { - dinfo_kind: kind; - dinfo_file: string; - dinfo_line: int; - dinfo_char_start: int; - dinfo_char_end: int -} - -let none = { - dinfo_kind = Dinfo_call; - dinfo_file = ""; - dinfo_line = 0; - dinfo_char_start = 0; - dinfo_char_end = 0 -} - -(* PR#5643: cannot use (==) because Debuginfo values are marshalled *) -let is_none t = - t = none - -let to_string d = - if d = none - then "" - else Printf.sprintf "{%s:%d,%d-%d}" - d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end - -let from_location kind loc = - if loc == Location.none then none else - { dinfo_kind = kind; - dinfo_file = loc.loc_start.pos_fname; - dinfo_line = loc.loc_start.pos_lnum; - dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol; - dinfo_char_end = - if loc.loc_end.pos_fname = loc.loc_start.pos_fname - then loc.loc_end.pos_cnum - loc.loc_start.pos_bol - else loc.loc_start.pos_cnum - loc.loc_start.pos_bol } - -let from_call ev = from_location Dinfo_call ev.Lambda.lev_loc -let from_raise ev = from_location Dinfo_raise ev.Lambda.lev_loc diff -Nru ocaml-4.01.0/asmcomp/debuginfo.mli ocaml-4.05.0/asmcomp/debuginfo.mli --- ocaml-4.01.0/asmcomp/debuginfo.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/asmcomp/debuginfo.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -type kind = Dinfo_call | Dinfo_raise - -type t = private { - dinfo_kind: kind; - dinfo_file: string; - dinfo_line: int; - dinfo_char_start: int; - dinfo_char_end: int -} - -val none: t - -val is_none: t -> bool - -val to_string: t -> string - -val from_location: kind -> Location.t -> t - -val from_call: Lambda.lambda_event -> t -val from_raise: Lambda.lambda_event -> t diff -Nru ocaml-4.01.0/asmcomp/emitaux.ml ocaml-4.05.0/asmcomp/emitaux.ml --- ocaml-4.01.0/asmcomp/emitaux.ml 2013-06-03 18:03:59.000000000 +0000 +++ ocaml-4.05.0/asmcomp/emitaux.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,19 +1,20 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Common functions for emitting assembly code *) -open Debuginfo - let output_channel = ref stdout let emit_string s = output_string !output_channel s @@ -88,16 +89,10 @@ done; if !pos > 0 then emit_char '\n' -(* PR#4813: assemblers do strange things with float literals indeed, - so we convert to IEEE representation ourselves and emit float - literals as 32- or 64-bit integers. *) - -let emit_float64_directive directive f = - let x = Int64.bits_of_float (float_of_string f) in +let emit_float64_directive directive x = emit_printf "\t%s\t0x%Lx\n" directive x -let emit_float64_split_directive directive f = - let x = Int64.bits_of_float (float_of_string f) in +let emit_float64_split_directive directive x = let lo = Int64.logand x 0xFFFF_FFFFL and hi = Int64.shift_right_logical x 32 in emit_printf "\t%s\t0x%Lx, 0x%Lx\n" @@ -105,8 +100,7 @@ (if Arch.big_endian then hi else lo) (if Arch.big_endian then lo else hi) -let emit_float32_directive directive f = - let x = Int32.bits_of_float (float_of_string f) in +let emit_float32_directive directive x = emit_printf "\t%s\t0x%lx\n" directive x (* Record live pointers at call points *) @@ -115,12 +109,22 @@ { fd_lbl: int; (* Return address *) fd_frame_size: int; (* Size of stack frame *) fd_live_offset: int list; (* Offsets/regs of live addresses *) + fd_raise: bool; (* Is frame for a raise? *) fd_debuginfo: Debuginfo.t } (* Location, if any *) let frame_descriptors = ref([] : frame_descr list) +let record_frame_descr ~label ~frame_size ~live_offset ~raise_frame debuginfo = + frame_descriptors := + { fd_lbl = label; + fd_frame_size = frame_size; + fd_live_offset = List.sort_uniq (-) live_offset; + fd_raise = raise_frame; + fd_debuginfo = debuginfo } :: !frame_descriptors + type emit_frame_actions = - { efa_label: int -> unit; + { efa_code_label: int -> unit; + efa_data_label: int -> unit; efa_16: int -> unit; efa_32: int32 -> unit; efa_word: int -> unit; @@ -135,39 +139,83 @@ try Hashtbl.find filenames name with Not_found -> - let lbl = Linearize.new_label () in + let lbl = Cmm.new_label () in Hashtbl.add filenames name lbl; - lbl in + lbl + in + let module Label_table = + Hashtbl.Make (struct + type t = bool * Debuginfo.t + + let equal ((rs1 : bool), dbg1) (rs2, dbg2) = + rs1 = rs2 && Debuginfo.compare dbg1 dbg2 = 0 + + let hash (rs, dbg) = + Hashtbl.hash (rs, Debuginfo.hash dbg) + end) + in + let debuginfos = Label_table.create 7 in + let rec label_debuginfos rs rdbg = + let key = (rs, rdbg) in + try fst (Label_table.find debuginfos key) + with Not_found -> + let lbl = Cmm.new_label () in + let next = + match rdbg with + | [] -> assert false + | _ :: [] -> None + | _ :: ((_ :: _) as rdbg') -> Some (label_debuginfos false rdbg') + in + Label_table.add debuginfos key (lbl, next); + lbl + in + let emit_debuginfo_label rs rdbg = + a.efa_data_label (label_debuginfos rs rdbg) + in let emit_frame fd = - a.efa_label fd.fd_lbl; + a.efa_code_label fd.fd_lbl; a.efa_16 (if Debuginfo.is_none fd.fd_debuginfo then fd.fd_frame_size else fd.fd_frame_size + 1); a.efa_16 (List.length fd.fd_live_offset); List.iter a.efa_16 fd.fd_live_offset; a.efa_align Arch.size_addr; - if not (Debuginfo.is_none fd.fd_debuginfo) then begin - let d = fd.fd_debuginfo in - let line = min 0xFFFFF d.dinfo_line - and char_start = min 0xFF d.dinfo_char_start - and char_end = min 0x3FF d.dinfo_char_end - and kind = match d.dinfo_kind with Dinfo_call -> 0 | Dinfo_raise -> 1 in - let info = - Int64.add (Int64.shift_left (Int64.of_int line) 44) ( - Int64.add (Int64.shift_left (Int64.of_int char_start) 36) ( - Int64.add (Int64.shift_left (Int64.of_int char_end) 26) - (Int64.of_int kind))) in - a.efa_label_rel - (label_filename d.dinfo_file) - (Int64.to_int32 info); - a.efa_32 (Int64.to_int32 (Int64.shift_right info 32)) - end in + match List.rev fd.fd_debuginfo with + | [] -> () + | _ :: _ as rdbg -> emit_debuginfo_label fd.fd_raise rdbg + in let emit_filename name lbl = a.efa_def_label lbl; a.efa_string name; - a.efa_align Arch.size_addr in + a.efa_align Arch.size_addr + in + let pack_info fd_raise d = + let line = min 0xFFFFF d.Debuginfo.dinfo_line + and char_start = min 0xFF d.Debuginfo.dinfo_char_start + and char_end = min 0x3FF d.Debuginfo.dinfo_char_end + and kind = if fd_raise then 1 else 0 in + Int64.(add (shift_left (of_int line) 44) + (add (shift_left (of_int char_start) 36) + (add (shift_left (of_int char_end) 26) + (of_int kind)))) + in + let emit_debuginfo (rs, rdbg) (lbl,next) = + let d = List.hd rdbg in + a.efa_align Arch.size_addr; + a.efa_def_label lbl; + let info = pack_info rs d in + a.efa_label_rel + (label_filename d.Debuginfo.dinfo_file) + (Int64.to_int32 info); + a.efa_32 (Int64.to_int32 (Int64.shift_right info 32)); + begin match next with + | Some next -> a.efa_data_label next + | None -> a.efa_word 0 + end + in a.efa_word (List.length !frame_descriptors); List.iter emit_frame !frame_descriptors; + Label_table.iter emit_debuginfo debuginfos; Hashtbl.iter emit_filename filenames; frame_descriptors := [] @@ -202,6 +250,15 @@ emit_string "\t.cfi_adjust_cfa_offset\t"; emit_int n; emit_string "\n"; end +let cfi_offset ~reg ~offset = + if is_cfi_enabled () then begin + emit_string "\t.cfi_offset "; + emit_int reg; + emit_string ", "; + emit_int offset; + emit_string "\n" + end + (* Emit debug information *) (* This assoc list is expected to be very short *) @@ -218,24 +275,41 @@ (* We only diplay .file if the file has not been seen before. We display .loc for every instruction. *) -let emit_debug_info dbg = +let emit_debug_info_gen dbg file_emitter loc_emitter = if is_cfi_enabled () && - (!Clflags.debug || Config.with_frame_pointers) - && not (Debuginfo.is_none dbg) then begin - let line = dbg.Debuginfo.dinfo_line in - assert (line <> 0); (* clang errors out on zero line numbers *) - let file_name = dbg.Debuginfo.dinfo_file in - let file_num = - try List.assoc file_name !file_pos_nums - with Not_found -> - let file_num = !file_pos_num_cnt in - incr file_pos_num_cnt; - emit_string "\t.file\t"; - emit_int file_num; emit_char '\t'; - emit_string_literal file_name; emit_char '\n'; - file_pos_nums := (file_name,file_num) :: !file_pos_nums; - file_num in - emit_string "\t.loc\t"; - emit_int file_num; emit_char '\t'; - emit_int line; emit_char '\n' + (!Clflags.debug || Config.with_frame_pointers) then begin + match List.rev dbg with + | [] -> () + | { Debuginfo.dinfo_line = line; + dinfo_char_start = col; + dinfo_file = file_name; } :: _ -> + if line > 0 then begin (* PR#6243 *) + let file_num = + try List.assoc file_name !file_pos_nums + with Not_found -> + let file_num = !file_pos_num_cnt in + incr file_pos_num_cnt; + file_emitter ~file_num ~file_name; + file_pos_nums := (file_name,file_num) :: !file_pos_nums; + file_num in + loc_emitter ~file_num ~line ~col; + end end + +let emit_debug_info dbg = + emit_debug_info_gen dbg (fun ~file_num ~file_name -> + emit_string "\t.file\t"; + emit_int file_num; emit_char '\t'; + emit_string_literal file_name; emit_char '\n'; + ) + (fun ~file_num ~line ~col:_ -> + emit_string "\t.loc\t"; + emit_int file_num; emit_char '\t'; + emit_int line; emit_char '\n') + +let reset () = + reset_debug_info (); + frame_descriptors := [] + +let binary_backend_available = ref false +let create_asm_file = ref true diff -Nru ocaml-4.01.0/asmcomp/emitaux.mli ocaml-4.05.0/asmcomp/emitaux.mli --- ocaml-4.01.0/asmcomp/emitaux.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/emitaux.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Common functions for emitting assembly code *) @@ -23,23 +26,29 @@ val emit_string_literal: string -> unit val emit_string_directive: string -> string -> unit val emit_bytes_directive: string -> string -> unit -val emit_float64_directive: string -> string -> unit -val emit_float64_split_directive: string -> string -> unit -val emit_float32_directive: string -> string -> unit +val emit_float64_directive: string -> int64 -> unit +val emit_float64_split_directive: string -> int64 -> unit +val emit_float32_directive: string -> int32 -> unit +val reset : unit -> unit val reset_debug_info: unit -> unit val emit_debug_info: Debuginfo.t -> unit - -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list; (* Offsets/regs of live addresses *) - fd_debuginfo: Debuginfo.t } (* Location, if any *) - -val frame_descriptors : frame_descr list ref +val emit_debug_info_gen : + Debuginfo.t -> + (file_num:int -> file_name:string -> unit) -> + (file_num:int -> line:int -> col:int -> unit) -> unit + +val record_frame_descr : + label:int -> (* Return address *) + frame_size:int -> (* Size of stack frame *) + live_offset:int list -> (* Offsets/regs of live addresses *) + raise_frame:bool -> (* Is frame for a raise? *) + Debuginfo.t -> (* Location, if any *) + unit type emit_frame_actions = - { efa_label: int -> unit; + { efa_code_label: int -> unit; + efa_data_label: int -> unit; efa_16: int -> unit; efa_32: int32 -> unit; efa_word: int -> unit; @@ -55,3 +64,13 @@ val cfi_startproc : unit -> unit val cfi_endproc : unit -> unit val cfi_adjust_cfa_offset : int -> unit +val cfi_offset : reg:int -> offset:int -> unit + + +val binary_backend_available: bool ref + (** Is a binary backend available. If yes, we don't need + to generate the textual assembly file (unless the user + request it with -S). *) + +val create_asm_file: bool ref + (** Are we actually generating the textual assembly file? *) diff -Nru ocaml-4.01.0/asmcomp/emit.mli ocaml-4.05.0/asmcomp/emit.mli --- ocaml-4.01.0/asmcomp/emit.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/emit.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Generation of assembly code *) diff -Nru ocaml-4.01.0/asmcomp/export_info_for_pack.ml ocaml-4.05.0/asmcomp/export_info_for_pack.ml --- ocaml-4.01.0/asmcomp/export_info_for_pack.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/export_info_for_pack.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,211 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +let rename_id_state = Export_id.Tbl.create 100 +let rename_set_of_closures_id_state = Set_of_closures_id.Tbl.create 10 +let imported_function_declarations_table = + (Set_of_closures_id.Tbl.create 10 + : Flambda.function_declarations Set_of_closures_id.Tbl.t) + +(* Rename export identifiers' compilation units to denote that they now + live within a pack. *) +let import_eid_for_pack units pack id = + try Export_id.Tbl.find rename_id_state id + with Not_found -> + let unit_id = Export_id.get_compilation_unit id in + let id' = + if Compilation_unit.Set.mem unit_id units + then Export_id.create ?name:(Export_id.name id) pack + else id + in + Export_id.Tbl.add rename_id_state id id'; + id' + +(* Similar to [import_eid_for_pack], but for symbols. *) +let import_symbol_for_pack units pack symbol = + let compilation_unit = Symbol.compilation_unit symbol in + if Compilation_unit.Set.mem compilation_unit units + then Symbol.import_for_pack ~pack symbol + else symbol + +let import_approx_for_pack units pack (approx : Export_info.approx) + : Export_info.approx = + match approx with + | Value_symbol sym -> Value_symbol (import_symbol_for_pack units pack sym) + | Value_id eid -> Value_id (import_eid_for_pack units pack eid) + | Value_unknown -> Value_unknown + +let import_set_of_closures_id_for_pack units pack + (set_of_closures_id : Set_of_closures_id.t) + : Set_of_closures_id.t = + let compilation_unit = + Set_of_closures_id.get_compilation_unit set_of_closures_id + in + if Compilation_unit.Set.mem compilation_unit units then + Set_of_closures_id.Tbl.memoize + rename_set_of_closures_id_state + (fun _ -> + Set_of_closures_id.create + ?name:(Set_of_closures_id.name set_of_closures_id) + pack) + set_of_closures_id + else set_of_closures_id + +let import_set_of_closures_origin_for_pack units pack + (set_of_closures_origin : Set_of_closures_origin.t) + : Set_of_closures_origin.t = + Set_of_closures_origin.rename + (import_set_of_closures_id_for_pack units pack) + set_of_closures_origin + +let import_set_of_closures units pack + (set_of_closures : Export_info.value_set_of_closures) + : Export_info.value_set_of_closures = + { set_of_closures_id = + import_set_of_closures_id_for_pack units pack + set_of_closures.set_of_closures_id; + bound_vars = + Var_within_closure.Map.map (import_approx_for_pack units pack) + set_of_closures.bound_vars; + results = + Closure_id.Map.map (import_approx_for_pack units pack) + set_of_closures.results; + aliased_symbol = + Misc.may_map + (import_symbol_for_pack units pack) + set_of_closures.aliased_symbol; + } + +let import_descr_for_pack units pack (descr : Export_info.descr) + : Export_info.descr = + match descr with + | Value_int _ + | Value_char _ + | Value_constptr _ + | Value_string _ + | Value_float _ + | Value_float_array _ + | Export_info.Value_boxed_int _ + | Value_mutable_block _ as desc -> desc + | Value_block (tag, fields) -> + Value_block (tag, Array.map (import_approx_for_pack units pack) fields) + | Value_closure { closure_id; set_of_closures } -> + Value_closure { + closure_id; + set_of_closures = import_set_of_closures units pack set_of_closures; + } + | Value_set_of_closures set_of_closures -> + Value_set_of_closures (import_set_of_closures units pack set_of_closures) + +let rec import_code_for_pack units pack expr = + Flambda_iterators.map_named (function + | Symbol sym -> Symbol (import_symbol_for_pack units pack sym) + | Read_symbol_field (sym, field) -> + Read_symbol_field (import_symbol_for_pack units pack sym, field) + | Set_of_closures set_of_closures -> + let set_of_closures = + Flambda.create_set_of_closures + ~free_vars:set_of_closures.free_vars + ~specialised_args:set_of_closures.specialised_args + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + ~function_decls: + (import_function_declarations_for_pack units pack + set_of_closures.function_decls) + in + Set_of_closures set_of_closures + | e -> e) + expr + +and import_function_declarations_for_pack_aux units pack + (function_decls : Flambda.function_declarations) = + let funs = + Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> + Flambda.create_function_declaration ~params:function_decl.params + ~body:(import_code_for_pack units pack function_decl.body) + ~stub:function_decl.stub ~dbg:function_decl.dbg + ~inline:function_decl.inline + ~specialise:function_decl.specialise + ~is_a_functor:function_decl.is_a_functor) + function_decls.funs + in + Flambda.import_function_declarations_for_pack + (Flambda.update_function_declarations function_decls ~funs) + (import_set_of_closures_id_for_pack units pack) + (import_set_of_closures_origin_for_pack units pack) + +and import_function_declarations_for_pack units pack + (function_decls:Flambda.function_declarations) = + let original_set_of_closures_id = function_decls.set_of_closures_id in + try + Set_of_closures_id.Tbl.find imported_function_declarations_table + original_set_of_closures_id + with Not_found -> + let function_decls = + import_function_declarations_for_pack_aux units pack function_decls + in + Set_of_closures_id.Tbl.add + imported_function_declarations_table + original_set_of_closures_id + function_decls; + function_decls + +let import_eidmap_for_pack units pack f map = + Export_info.nest_eid_map + (Compilation_unit.Map.fold + (fun _ map acc -> Export_id.Map.disjoint_union map acc) + (Compilation_unit.Map.map (fun map -> + Export_id.Map.map_keys (import_eid_for_pack units pack) + (Export_id.Map.map f map)) + map) + Export_id.Map.empty) + +let import_for_pack ~pack_units ~pack (exp : Export_info.t) = + let import_sym = import_symbol_for_pack pack_units pack in + let import_descr = import_descr_for_pack pack_units pack in + let import_eid = import_eid_for_pack pack_units pack in + let import_eidmap f map = import_eidmap_for_pack pack_units pack f map in + let import_set_of_closures_id = + import_set_of_closures_id_for_pack pack_units pack + in + let import_function_declarations = + import_function_declarations_for_pack pack_units pack + in + let sets_of_closures = + Set_of_closures_id.Map.map_keys import_set_of_closures_id + (Set_of_closures_id.Map.map + import_function_declarations + exp.sets_of_closures) + in + Export_info.create ~sets_of_closures + ~closures:(Flambda_utils.make_closure_map' sets_of_closures) + ~offset_fun:exp.offset_fun + ~offset_fv:exp.offset_fv + ~values:(import_eidmap import_descr exp.values) + ~symbol_id:(Symbol.Map.map_keys import_sym + (Symbol.Map.map import_eid exp.symbol_id)) + ~constant_sets_of_closures: + (Set_of_closures_id.Set.map import_set_of_closures_id + exp.constant_sets_of_closures) + ~invariant_params: + (Set_of_closures_id.Map.map_keys import_set_of_closures_id + exp.invariant_params) + +let clear_import_state () = + Set_of_closures_id.Tbl.clear imported_function_declarations_table; + Set_of_closures_id.Tbl.clear rename_set_of_closures_id_state; + Export_id.Tbl.clear rename_id_state diff -Nru ocaml-4.01.0/asmcomp/export_info_for_pack.mli ocaml-4.05.0/asmcomp/export_info_for_pack.mli --- ocaml-4.01.0/asmcomp/export_info_for_pack.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/export_info_for_pack.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Transformations on export information that are only used for the + building of packs. *) + +(** Transform the information from [exported] to be + suitable to be reexported as the information for a pack named [pack] + containing units [pack_units]. + It mainly changes symbols of units [pack_units] to refer to + [pack] instead. *) +val import_for_pack + : pack_units:Compilation_unit.Set.t + -> pack:Compilation_unit.t + -> Export_info.t + -> Export_info.t + +(** Drops the state after importing several units in the same pack. *) +val clear_import_state : unit -> unit diff -Nru ocaml-4.01.0/asmcomp/export_info.ml ocaml-4.05.0/asmcomp/export_info.ml --- ocaml-4.01.0/asmcomp/export_info.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/export_info.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,360 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +type value_string_contents = + | Contents of string + | Unknown_or_mutable + +type value_string = { + contents : value_string_contents; + size : int; +} + +type value_float_array_contents = + | Contents of float option array + | Unknown_or_mutable + +type value_float_array = { + contents : value_float_array_contents; + size : int; +} + +type descr = + | Value_block of Tag.t * approx array + | Value_mutable_block of Tag.t * int + | Value_int of int + | Value_char of char + | Value_constptr of int + | Value_float of float + | Value_float_array of value_float_array + | Value_boxed_int : 'a Simple_value_approx.boxed_int * 'a -> descr + | Value_string of value_string + | Value_closure of value_closure + | Value_set_of_closures of value_set_of_closures + +and value_closure = { + closure_id : Closure_id.t; + set_of_closures : value_set_of_closures; +} + +and value_set_of_closures = { + set_of_closures_id : Set_of_closures_id.t; + bound_vars : approx Var_within_closure.Map.t; + results : approx Closure_id.Map.t; + aliased_symbol : Symbol.t option; +} + +and approx = + | Value_unknown + | Value_id of Export_id.t + | Value_symbol of Symbol.t + +let equal_approx (a1:approx) (a2:approx) = + match a1, a2 with + | Value_unknown, Value_unknown -> + true + | Value_id id1, Value_id id2 -> + Export_id.equal id1 id2 + | Value_symbol s1, Value_symbol s2 -> + Symbol.equal s1 s2 + | (Value_unknown | Value_symbol _ | Value_id _), + (Value_unknown | Value_symbol _ | Value_id _) -> + false + +let equal_array eq a1 a2 = + Array.length a1 = Array.length a2 && + try + Array.iteri (fun i v1 -> if not (eq a2.(i) v1) then raise Exit) a1; + true + with Exit -> false + +let equal_option eq o1 o2 = + match o1, o2 with + | None, None -> true + | Some v1, Some v2 -> eq v1 v2 + | Some _, None | None, Some _ -> false + +let equal_set_of_closures (s1:value_set_of_closures) + (s2:value_set_of_closures) = + Set_of_closures_id.equal s1.set_of_closures_id s2.set_of_closures_id && + Var_within_closure.Map.equal equal_approx s1.bound_vars s2.bound_vars && + Closure_id.Map.equal equal_approx s1.results s2.results && + equal_option Symbol.equal s1.aliased_symbol s2.aliased_symbol + +let equal_descr (d1:descr) (d2:descr) : bool = + match d1, d2 with + | Value_block (t1, f1), Value_block (t2, f2) -> + Tag.equal t1 t2 && equal_array equal_approx f1 f2 + | Value_mutable_block (t1, s1), Value_mutable_block (t2, s2) -> + Tag.equal t1 t2 && + s1 = s2 + | Value_int i1, Value_int i2 -> + i1 = i2 + | Value_char c1, Value_char c2 -> + c1 = c2 + | Value_constptr i1, Value_constptr i2 -> + i1 = i2 + | Value_float f1, Value_float f2 -> + f1 = f2 + | Value_float_array s1, Value_float_array s2 -> + s1 = s2 + | Value_boxed_int (t1, v1), Value_boxed_int (t2, v2) -> + Simple_value_approx.equal_boxed_int t1 v1 t2 v2 + | Value_string s1, Value_string s2 -> + s1 = s2 + | Value_closure c1, Value_closure c2 -> + Closure_id.equal c1.closure_id c2.closure_id && + equal_set_of_closures c1.set_of_closures c2.set_of_closures + | Value_set_of_closures s1, Value_set_of_closures s2 -> + equal_set_of_closures s1 s2 + | ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _ + | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _ + | Value_boxed_int _ | Value_string _ | Value_closure _ + | Value_set_of_closures _ ), + ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _ + | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _ + | Value_boxed_int _ | Value_string _ | Value_closure _ + | Value_set_of_closures _ ) -> + false + +type t = { + sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t; + closures : Flambda.function_declarations Closure_id.Map.t; + values : descr Export_id.Map.t Compilation_unit.Map.t; + symbol_id : Export_id.t Symbol.Map.t; + offset_fun : int Closure_id.Map.t; + offset_fv : int Var_within_closure.Map.t; + constant_sets_of_closures : Set_of_closures_id.Set.t; + invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; +} + +let empty : t = { + sets_of_closures = Set_of_closures_id.Map.empty; + closures = Closure_id.Map.empty; + values = Compilation_unit.Map.empty; + symbol_id = Symbol.Map.empty; + offset_fun = Closure_id.Map.empty; + offset_fv = Var_within_closure.Map.empty; + constant_sets_of_closures = Set_of_closures_id.Set.empty; + invariant_params = Set_of_closures_id.Map.empty; +} + +let create ~sets_of_closures ~closures ~values ~symbol_id + ~offset_fun ~offset_fv ~constant_sets_of_closures + ~invariant_params = + { sets_of_closures; + closures; + values; + symbol_id; + offset_fun; + offset_fv; + constant_sets_of_closures; + invariant_params; + } + +let add_clambda_info t ~offset_fun ~offset_fv ~constant_sets_of_closures = + assert (Closure_id.Map.cardinal t.offset_fun = 0); + assert (Var_within_closure.Map.cardinal t.offset_fv = 0); + assert (Set_of_closures_id.Set.cardinal t.constant_sets_of_closures = 0); + { t with offset_fun; offset_fv; constant_sets_of_closures; } + +let merge (t1 : t) (t2 : t) : t = + let eidmap_disjoint_union ?eq map1 map2 = + Compilation_unit.Map.merge (fun _id map1 map2 -> + match map1, map2 with + | None, None -> None + | None, Some map + | Some map, None -> Some map + | Some map1, Some map2 -> + Some (Export_id.Map.disjoint_union ?eq map1 map2)) + map1 map2 + in + let int_eq (i : int) j = i = j in + { values = eidmap_disjoint_union ~eq:equal_descr t1.values t2.values; + sets_of_closures = + Set_of_closures_id.Map.disjoint_union t1.sets_of_closures + t2.sets_of_closures; + closures = Closure_id.Map.disjoint_union t1.closures t2.closures; + symbol_id = Symbol.Map.disjoint_union ~print:Export_id.print t1.symbol_id t2.symbol_id; + offset_fun = Closure_id.Map.disjoint_union + ~eq:int_eq t1.offset_fun t2.offset_fun; + offset_fv = Var_within_closure.Map.disjoint_union + ~eq:int_eq t1.offset_fv t2.offset_fv; + constant_sets_of_closures = + Set_of_closures_id.Set.union t1.constant_sets_of_closures + t2.constant_sets_of_closures; + invariant_params = + Set_of_closures_id.Map.disjoint_union + ~print:(Variable.Map.print Variable.Set.print) + ~eq:(Variable.Map.equal Variable.Set.equal) + t1.invariant_params t2.invariant_params; + } + +let find_value eid map = + let unit_map = + Compilation_unit.Map.find (Export_id.get_compilation_unit eid) map + in + Export_id.Map.find eid unit_map + +let find_description (t : t) eid = + find_value eid t.values + +let nest_eid_map map = + let add_map eid v map = + let unit = Export_id.get_compilation_unit eid in + let m = + try Compilation_unit.Map.find unit map + with Not_found -> Export_id.Map.empty + in + Compilation_unit.Map.add unit (Export_id.Map.add eid v m) map + in + Export_id.Map.fold add_map map Compilation_unit.Map.empty + +let print_approx ppf ((t,root_symbols) : t * Symbol.t list) = + let values = t.values in + let fprintf = Format.fprintf in + let printed = ref Export_id.Set.empty in + let recorded_symbol = ref Symbol.Set.empty in + let symbols_to_print = Queue.create () in + let printed_set_of_closures = ref Set_of_closures_id.Set.empty in + let rec print_approx ppf (approx : approx) = + match approx with + | Value_unknown -> fprintf ppf "?" + | Value_id id -> + if Export_id.Set.mem id !printed then + fprintf ppf "(%a: _)" Export_id.print id + else begin + try + let descr = find_value id values in + printed := Export_id.Set.add id !printed; + fprintf ppf "@[(%a:@ %a)@]" + Export_id.print id print_descr descr + with Not_found -> + fprintf ppf "(%a: Not available)" Export_id.print id + end + | Value_symbol sym -> + if not (Symbol.Set.mem sym !recorded_symbol) then begin + recorded_symbol := Symbol.Set.add sym !recorded_symbol; + Queue.push sym symbols_to_print; + end; + Symbol.print ppf sym + and print_descr ppf (descr : descr) = + match descr with + | Value_int i -> Format.pp_print_int ppf i + | Value_char c -> fprintf ppf "%c" c + | Value_constptr i -> fprintf ppf "%ip" i + | Value_block (tag, fields) -> + fprintf ppf "[%a:%a]" Tag.print tag print_fields fields + | Value_mutable_block (tag, size) -> + fprintf ppf "[mutable %a:%i]" Tag.print tag size + | Value_closure {closure_id; set_of_closures} -> + fprintf ppf "(closure %a, %a)" Closure_id.print closure_id + print_set_of_closures set_of_closures + | Value_set_of_closures set_of_closures -> + fprintf ppf "(set_of_closures %a)" print_set_of_closures set_of_closures + | Value_string { contents; size } -> + begin match contents with + | Unknown_or_mutable -> Format.fprintf ppf "string %i" size + | Contents s -> + let s = + if size > 10 + then String.sub s 0 8 ^ "..." + else s + in + Format.fprintf ppf "string %i %S" size s + end + | Value_float f -> Format.pp_print_float ppf f + | Value_float_array float_array -> + Format.fprintf ppf "float_array%s %i" + (match float_array.contents with + | Unknown_or_mutable -> "" + | Contents _ -> "_imm") + float_array.size + | Value_boxed_int (t, i) -> + let module A = Simple_value_approx in + match t with + | A.Int32 -> Format.fprintf ppf "%li" i + | A.Int64 -> Format.fprintf ppf "%Li" i + | A.Nativeint -> Format.fprintf ppf "%ni" i + and print_fields ppf fields = + Array.iter (fun approx -> fprintf ppf "%a@ " print_approx approx) fields + and print_set_of_closures ppf + { set_of_closures_id; bound_vars; aliased_symbol; results } = + if Set_of_closures_id.Set.mem set_of_closures_id !printed_set_of_closures + then fprintf ppf "%a" Set_of_closures_id.print set_of_closures_id + else begin + printed_set_of_closures := + Set_of_closures_id.Set.add set_of_closures_id !printed_set_of_closures; + let print_alias ppf = function + | None -> () + | Some symbol -> + Format.fprintf ppf "@ (alias: %a)" Symbol.print symbol + in + fprintf ppf "{%a: %a%a => %a}" + Set_of_closures_id.print set_of_closures_id + print_binding bound_vars + print_alias aliased_symbol + (Closure_id.Map.print print_approx) results + end + and print_binding ppf bound_vars = + Var_within_closure.Map.iter (fun clos_id approx -> + fprintf ppf "%a -> %a,@ " + Var_within_closure.print clos_id + print_approx approx) + bound_vars + in + let rec print_recorded_symbols () = + if not (Queue.is_empty symbols_to_print) then begin + let sym = Queue.pop symbols_to_print in + begin match Symbol.Map.find sym t.symbol_id with + | exception Not_found -> () + | id -> + fprintf ppf "@[%a:@ %a@];@ " + Symbol.print sym + print_approx (Value_id id) + end; + print_recorded_symbols (); + end + in + List.iter (fun s -> Queue.push s symbols_to_print) root_symbols; + fprintf ppf "@[Globals:@ "; + fprintf ppf "@]@ @[Symbols:@ "; + print_recorded_symbols (); + fprintf ppf "@]" + +let print_offsets ppf (t : t) = + Format.fprintf ppf "@[offset_fun:@ "; + Closure_id.Map.iter (fun cid off -> + Format.fprintf ppf "%a -> %i@ " + Closure_id.print cid off) t.offset_fun; + Format.fprintf ppf "@]@ @[offset_fv:@ "; + Var_within_closure.Map.iter (fun vid off -> + Format.fprintf ppf "%a -> %i@ " + Var_within_closure.print vid off) t.offset_fv; + Format.fprintf ppf "@]@ " + +let print_functions ppf (t : t) = + Set_of_closures_id.Map.print Flambda.print_function_declarations ppf + t.sets_of_closures + +let print_all ppf ((t, root_symbols) : t * Symbol.t list) = + let fprintf = Format.fprintf in + fprintf ppf "approxs@ %a@.@." + print_approx (t, root_symbols); + fprintf ppf "functions@ %a@.@." + print_functions t diff -Nru ocaml-4.01.0/asmcomp/export_info.mli ocaml-4.05.0/asmcomp/export_info.mli --- ocaml-4.01.0/asmcomp/export_info.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/export_info.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,149 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Exported information (that is to say, information written into a .cmx + file) about a compilation unit. *) + +type value_string_contents = + | Contents of string + | Unknown_or_mutable + +type value_string = { + contents : value_string_contents; + size : int; +} + +type value_float_array_contents = + | Contents of float option array + | Unknown_or_mutable + +type value_float_array = { + contents : value_float_array_contents; + size : int; +} + +type descr = + | Value_block of Tag.t * approx array + | Value_mutable_block of Tag.t * int + | Value_int of int + | Value_char of char + | Value_constptr of int + | Value_float of float + | Value_float_array of value_float_array + | Value_boxed_int : 'a Simple_value_approx.boxed_int * 'a -> descr + | Value_string of value_string + | Value_closure of value_closure + | Value_set_of_closures of value_set_of_closures + +and value_closure = { + closure_id : Closure_id.t; + set_of_closures : value_set_of_closures; +} + +and value_set_of_closures = { + set_of_closures_id : Set_of_closures_id.t; + bound_vars : approx Var_within_closure.Map.t; + results : approx Closure_id.Map.t; + aliased_symbol : Symbol.t option; +} + +(* CR-soon mshinwell: Fix the export information so we can correctly + propagate "unresolved due to..." in the manner of [Simple_value_approx]. + Unfortunately this seems to be complicated by the fact that, during + [Import_approx], resolution can fail not only due to missing symbols but + also due to missing export IDs. The argument type of + [Simple_value_approx.t] may need updating to reflect this (make the + symbol optional? It's only for debugging anyway.) *) +and approx = + | Value_unknown + | Value_id of Export_id.t + | Value_symbol of Symbol.t + +(** A structure that describes what a single compilation unit exports. *) +type t = private { + sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t; + (** Code of exported functions indexed by set of closures IDs. *) + closures : Flambda.function_declarations Closure_id.Map.t; + (** Code of exported functions indexed by closure IDs. *) + values : descr Export_id.Map.t Compilation_unit.Map.t; + (** Structure of exported values. *) + symbol_id : Export_id.t Symbol.Map.t; + (** Associates symbols and values. *) + offset_fun : int Closure_id.Map.t; + (** Positions of function pointers in their closures. *) + offset_fv : int Var_within_closure.Map.t; + (** Positions of value pointers in their closures. *) + constant_sets_of_closures : Set_of_closures_id.Set.t; + (* CR-soon mshinwell for pchambart: Add comment *) + invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; + (* Function parameters known to be invariant (see [Invariant_params]) + indexed by set of closures ID. *) +} + +(** Export information for a compilation unit that exports nothing. *) +val empty : t + +(** Create a new export information structure. *) +val create + : sets_of_closures:Flambda.function_declarations Set_of_closures_id.Map.t + -> closures:Flambda.function_declarations Closure_id.Map.t + -> values:descr Export_id.Map.t Compilation_unit.Map.t + -> symbol_id:Export_id.t Symbol.Map.t + -> offset_fun:int Closure_id.Map.t + -> offset_fv:int Var_within_closure.Map.t + -> constant_sets_of_closures:Set_of_closures_id.Set.t + -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t + -> t + +(* CR-someday pchambart: Should we separate [t] in 2 types: one created by the + current [create] function, returned by [Build_export_info]. And + another built using t and offset_informations returned by + [flambda_to_clambda] ? + mshinwell: I think we should, but after we've done the first release. +*) +(** Record information about the layout of closures and which sets of + closures are constant. These are all worked out during the + [Flambda_to_clambda] pass. *) +val add_clambda_info + : t + -> offset_fun:int Closure_id.Map.t + -> offset_fv:int Var_within_closure.Map.t + -> constant_sets_of_closures:Set_of_closures_id.Set.t + -> t + +(** Union of export information. Verifies that there are no identifier + clashes. *) +val merge : t -> t -> t + +(** Look up the description of an exported value given its export ID. *) +val find_description + : t + -> Export_id.t + -> descr + +(** Partition a mapping from export IDs by compilation unit. *) +val nest_eid_map + : 'a Export_id.Map.t + -> 'a Export_id.Map.t Compilation_unit.Map.t + +(**/**) +(* Debug printing functions. *) +val print_approx : Format.formatter -> t * Symbol.t list -> unit +val print_functions : Format.formatter -> t -> unit +val print_offsets : Format.formatter -> t -> unit +val print_all : Format.formatter -> t * Symbol.t list -> unit diff -Nru ocaml-4.01.0/asmcomp/flambda_to_clambda.ml ocaml-4.05.0/asmcomp/flambda_to_clambda.ml --- ocaml-4.01.0/asmcomp/flambda_to_clambda.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/flambda_to_clambda.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,694 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +type for_one_or_more_units = { + fun_offset_table : int Closure_id.Map.t; + fv_offset_table : int Var_within_closure.Map.t; + closures : Flambda.function_declarations Closure_id.Map.t; + constant_sets_of_closures : Set_of_closures_id.Set.t; +} + +type t = { + current_unit : for_one_or_more_units; + imported_units : for_one_or_more_units; +} + +type ('a, 'b) declaration_position = + | Current_unit of 'a + | Imported_unit of 'b + | Not_declared + +let get_fun_offset t closure_id = + let fun_offset_table = + if Closure_id.in_compilation_unit closure_id (Compilenv.current_unit ()) + then t.current_unit.fun_offset_table + else t.imported_units.fun_offset_table + in + try Closure_id.Map.find closure_id fun_offset_table + with Not_found -> + Misc.fatal_errorf "Flambda_to_clambda: missing offset for closure %a" + Closure_id.print closure_id + +let get_fv_offset t var_within_closure = + let fv_offset_table = + if Var_within_closure.in_compilation_unit var_within_closure + (Compilenv.current_unit ()) + then t.current_unit.fv_offset_table + else t.imported_units.fv_offset_table + in + try Var_within_closure.Map.find var_within_closure fv_offset_table + with Not_found -> + Misc.fatal_errorf "Flambda_to_clambda: missing offset for variable %a" + Var_within_closure.print var_within_closure + +let function_declaration_position t closure_id = + try + Current_unit (Closure_id.Map.find closure_id t.current_unit.closures) + with Not_found -> + try + Imported_unit (Closure_id.Map.find closure_id t.imported_units.closures) + with Not_found -> Not_declared + +let is_function_constant t closure_id = + match function_declaration_position t closure_id with + | Current_unit { set_of_closures_id } -> + Set_of_closures_id.Set.mem set_of_closures_id + t.current_unit.constant_sets_of_closures + | Imported_unit { set_of_closures_id } -> + Set_of_closures_id.Set.mem set_of_closures_id + t.imported_units.constant_sets_of_closures + | Not_declared -> + Misc.fatal_errorf "Flambda_to_clambda: missing closure %a" + Closure_id.print closure_id + +(* Instrumentation of closure and field accesses to try to catch compiler + bugs. *) + +let check_closure ulam named : Clambda.ulambda = + if not !Clflags.clambda_checks then ulam + else + let desc = + Primitive.simple ~name:"caml_check_value_is_closure" + ~arity:2 ~alloc:false + in + let str = Format.asprintf "%a" Flambda.print_named named in + let str_const = + Compilenv.new_structured_constant (Uconst_string str) ~shared:true + in + Uprim (Pccall desc, + [ulam; Clambda.Uconst (Uconst_ref (str_const, None))], + Debuginfo.none) + +let check_field ulam pos named_opt : Clambda.ulambda = + if not !Clflags.clambda_checks then ulam + else + let desc = + Primitive.simple ~name:"caml_check_field_access" + ~arity:3 ~alloc:false + in + let str = + match named_opt with + | None -> "" + | Some named -> Format.asprintf "%a" Flambda.print_named named + in + let str_const = + Compilenv.new_structured_constant (Uconst_string str) ~shared:true + in + Uprim (Pccall desc, [ulam; Clambda.Uconst (Uconst_int pos); + Clambda.Uconst (Uconst_ref (str_const, None))], + Debuginfo.none) + +module Env : sig + type t + + val empty : t + + val add_subst : t -> Variable.t -> Clambda.ulambda -> t + val find_subst_exn : t -> Variable.t -> Clambda.ulambda + + val add_fresh_ident : t -> Variable.t -> Ident.t * t + val ident_for_var_exn : t -> Variable.t -> Ident.t + + val add_fresh_mutable_ident : t -> Mutable_variable.t -> Ident.t * t + val ident_for_mutable_var_exn : t -> Mutable_variable.t -> Ident.t + + val add_allocated_const : t -> Symbol.t -> Allocated_const.t -> t + val allocated_const_for_symbol : t -> Symbol.t -> Allocated_const.t option + + val keep_only_symbols : t -> t +end = struct + type t = + { subst : Clambda.ulambda Variable.Map.t; + var : Ident.t Variable.Map.t; + mutable_var : Ident.t Mutable_variable.Map.t; + toplevel : bool; + allocated_constant_for_symbol : Allocated_const.t Symbol.Map.t; + } + + let empty = + { subst = Variable.Map.empty; + var = Variable.Map.empty; + mutable_var = Mutable_variable.Map.empty; + toplevel = false; + allocated_constant_for_symbol = Symbol.Map.empty; + } + + let add_subst t id subst = + { t with subst = Variable.Map.add id subst t.subst } + + let find_subst_exn t id = Variable.Map.find id t.subst + + let ident_for_var_exn t id = Variable.Map.find id t.var + + let add_fresh_ident t var = + let id = Ident.create (Variable.unique_name var) in + id, { t with var = Variable.Map.add var id t.var } + + let ident_for_mutable_var_exn t mut_var = + Mutable_variable.Map.find mut_var t.mutable_var + + let add_fresh_mutable_ident t mut_var = + let id = Mutable_variable.unique_ident mut_var in + let mutable_var = Mutable_variable.Map.add mut_var id t.mutable_var in + id, { t with mutable_var; } + + let add_allocated_const t sym cons = + { t with + allocated_constant_for_symbol = + Symbol.Map.add sym cons t.allocated_constant_for_symbol; + } + + let allocated_const_for_symbol t sym = + try + Some (Symbol.Map.find sym t.allocated_constant_for_symbol) + with Not_found -> None + + let keep_only_symbols t = + { empty with + allocated_constant_for_symbol = t.allocated_constant_for_symbol; + } +end + +let subst_var env var : Clambda.ulambda = + try Env.find_subst_exn env var + with Not_found -> + try Uvar (Env.ident_for_var_exn env var) + with Not_found -> + Misc.fatal_errorf "Flambda_to_clambda: unbound variable %a@." + Variable.print var + +let subst_vars env vars = List.map (subst_var env) vars + +let build_uoffset ulam offset : Clambda.ulambda = + if offset = 0 then ulam + else Uoffset (ulam, offset) + +let to_clambda_allocated_constant (const : Allocated_const.t) + : Clambda.ustructured_constant = + match const with + | Float f -> Uconst_float f + | Int32 i -> Uconst_int32 i + | Int64 i -> Uconst_int64 i + | Nativeint i -> Uconst_nativeint i + | Immutable_string s | String s -> Uconst_string s + | Immutable_float_array a | Float_array a -> Uconst_float_array a + +let to_uconst_symbol env symbol : Clambda.ustructured_constant option = + match Env.allocated_const_for_symbol env symbol with + | Some ((Float _ | Int32 _ | Int64 _ | Nativeint _) as const) -> + Some (to_clambda_allocated_constant const) + | None (* CR-soon mshinwell: Try to make this an error. *) + | Some _ -> None + +let to_clambda_symbol' env sym : Clambda.uconstant = + let lbl = Linkage_name.to_string (Symbol.label sym) in + Uconst_ref (lbl, to_uconst_symbol env sym) + +let to_clambda_symbol env sym : Clambda.ulambda = + Uconst (to_clambda_symbol' env sym) + +let to_clambda_const env (const : Flambda.constant_defining_value_block_field) + : Clambda.uconstant = + match const with + | Symbol symbol -> to_clambda_symbol' env symbol + | Const (Int i) -> Uconst_int i + | Const (Char c) -> Uconst_int (Char.code c) + | Const (Const_pointer i) -> Uconst_ptr i + +let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = + match flam with + | Var var -> subst_var env var + | Let { var; defining_expr; body; _ } -> + (* TODO: synthesize proper value_kind *) + let id, env_body = Env.add_fresh_ident env var in + Ulet (Immutable, Pgenval, id, to_clambda_named t env var defining_expr, + to_clambda t env_body body) + | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> + let id, env_body = Env.add_fresh_mutable_ident env mut_var in + let def = subst_var env var in + Ulet (Mutable, contents_kind, id, def, to_clambda t env_body body) + | Let_rec (defs, body) -> + let env, defs = + List.fold_right (fun (var, def) (env, defs) -> + let id, env = Env.add_fresh_ident env var in + env, (id, var, def) :: defs) + defs (env, []) + in + let defs = + List.map (fun (id, var, def) -> id, to_clambda_named t env var def) defs + in + Uletrec (defs, to_clambda t env body) + | Apply { func; args; kind = Direct direct_func; dbg = dbg } -> + (* The closure _parameter_ of the function is added by cmmgen. + At the call site, for a direct call, the closure argument must be + explicitly added (by [to_clambda_direct_apply]); there is no special + handling of such in the direct call primitive. + For an indirect call, we do not need to do anything here; Cmmgen will + do the equivalent of the previous paragraph when it generates a direct + call to [caml_apply]. *) + to_clambda_direct_apply t func args direct_func dbg env + | Apply { func; args; kind = Indirect; dbg = dbg } -> + let callee = subst_var env func in + Ugeneric_apply (check_closure callee (Flambda.Expr (Var func)), + subst_vars env args, dbg) + | Switch (arg, sw) -> + let aux () : Clambda.ulambda = + let const_index, const_actions = + to_clambda_switch t env sw.consts sw.numconsts sw.failaction + in + let block_index, block_actions = + to_clambda_switch t env sw.blocks sw.numblocks sw.failaction + in + Uswitch (subst_var env arg, + { us_index_consts = const_index; + us_actions_consts = const_actions; + us_index_blocks = block_index; + us_actions_blocks = block_actions; + }) + in + (* Check that the [failaction] may be duplicated. If this is not the + case, share it through a static raise / static catch. *) + (* CR-someday pchambart for pchambart: This is overly simplified. + We should verify that this does not generates too bad code. + If it the case, handle some let cases. + *) + begin match sw.failaction with + | None -> aux () + | Some (Static_raise _) -> aux () + | Some failaction -> + let exn = Static_exception.create () in + let sw = + { sw with + failaction = Some (Flambda.Static_raise (exn, [])); + } + in + let expr : Flambda.t = + Static_catch (exn, [], Switch (arg, sw), failaction) + in + to_clambda t env expr + end + | String_switch (arg, sw, def) -> + let arg = subst_var env arg in + let sw = List.map (fun (s, e) -> s, to_clambda t env e) sw in + let def = Misc.may_map (to_clambda t env) def in + Ustringswitch (arg, sw, def) + | Static_raise (static_exn, args) -> + Ustaticfail (Static_exception.to_int static_exn, + List.map (subst_var env) args) + | Static_catch (static_exn, vars, body, handler) -> + let env_handler, ids = + List.fold_right (fun var (env, ids) -> + let id, env = Env.add_fresh_ident env var in + env, id :: ids) + vars (env, []) + in + Ucatch (Static_exception.to_int static_exn, ids, + to_clambda t env body, to_clambda t env_handler handler) + | Try_with (body, var, handler) -> + let id, env_handler = Env.add_fresh_ident env var in + Utrywith (to_clambda t env body, id, to_clambda t env_handler handler) + | If_then_else (arg, ifso, ifnot) -> + Uifthenelse (subst_var env arg, to_clambda t env ifso, + to_clambda t env ifnot) + | While (cond, body) -> + Uwhile (to_clambda t env cond, to_clambda t env body) + | For { bound_var; from_value; to_value; direction; body } -> + let id, env_body = Env.add_fresh_ident env bound_var in + Ufor (id, subst_var env from_value, subst_var env to_value, + direction, to_clambda t env_body body) + | Assign { being_assigned; new_value } -> + let id = + try Env.ident_for_mutable_var_exn env being_assigned + with Not_found -> + Misc.fatal_errorf "Unbound mutable variable %a in [Assign]: %a" + Mutable_variable.print being_assigned + Flambda.print flam + in + Uassign (id, subst_var env new_value) + | Send { kind; meth; obj; args; dbg } -> + Usend (kind, subst_var env meth, subst_var env obj, + subst_vars env args, dbg) + | Proved_unreachable -> Uunreachable + +and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda = + match named with + | Symbol sym -> to_clambda_symbol env sym + | Const (Const_pointer n) -> Uconst (Uconst_ptr n) + | Const (Int n) -> Uconst (Uconst_int n) + | Const (Char c) -> Uconst (Uconst_int (Char.code c)) + | Allocated_const _ -> + Misc.fatal_errorf "[Allocated_const] should have been lifted to a \ + [Let_symbol] construction before [Flambda_to_clambda]: %a = %a" + Variable.print var + Flambda.print_named named + | Read_mutable mut_var -> + begin try Uvar (Env.ident_for_mutable_var_exn env mut_var) + with Not_found -> + Misc.fatal_errorf "Unbound mutable variable %a in [Read_mutable]: %a" + Mutable_variable.print mut_var + Flambda.print_named named + end + | Read_symbol_field (symbol, field) -> + Uprim (Pfield field, [to_clambda_symbol env symbol], Debuginfo.none) + | Set_of_closures set_of_closures -> + to_clambda_set_of_closures t env set_of_closures + | Project_closure { set_of_closures; closure_id } -> + (* Note that we must use [build_uoffset] to ensure that we do not generate + a [Uoffset] construction in the event that the offset is zero, otherwise + we might break pattern matches in Cmmgen (in particular for the + compilation of "let rec"). *) + check_closure ( + build_uoffset + (check_closure (subst_var env set_of_closures) + (Flambda.Expr (Var set_of_closures))) + (get_fun_offset t closure_id)) + named + | Move_within_set_of_closures { closure; start_from; move_to } -> + check_closure (build_uoffset + (check_closure (subst_var env closure) + (Flambda.Expr (Var closure))) + ((get_fun_offset t move_to) - (get_fun_offset t start_from))) + named + | Project_var { closure; var; closure_id } -> + let ulam = subst_var env closure in + let fun_offset = get_fun_offset t closure_id in + let var_offset = get_fv_offset t var in + let pos = var_offset - fun_offset in + Uprim (Pfield pos, + [check_field (check_closure ulam (Expr (Var closure))) pos (Some named)], + Debuginfo.none) + | Prim (Pfield index, [block], dbg) -> + Uprim (Pfield index, [check_field (subst_var env block) index None], dbg) + | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) -> + Uprim (Psetfield (index, maybe_ptr, init), [ + check_field (subst_var env block) index None; + subst_var env new_value; + ], dbg) + | Prim (Popaque, args, dbg) -> + Uprim (Pidentity, subst_vars env args, dbg) + | Prim (p, args, dbg) -> + Uprim (p, subst_vars env args, dbg) + | Expr expr -> to_clambda t env expr + +and to_clambda_switch t env cases num_keys default = + let num_keys = + if Numbers.Int.Set.cardinal num_keys = 0 then 0 + else Numbers.Int.Set.max_elt num_keys + 1 + in + let index = Array.make num_keys 0 in + let store = Flambda_utils.Switch_storer.mk_store () in + begin match default with + | Some def when List.length cases < num_keys -> ignore (store.act_store def) + | _ -> () + end; + List.iter (fun (key, lam) -> index.(key) <- store.act_store lam) cases; + let actions = Array.map (to_clambda t env) (store.act_get ()) in + match actions with + | [| |] -> [| |], [| |] (* May happen when [default] is [None]. *) + | _ -> index, actions + +and to_clambda_direct_apply t func args direct_func dbg env : Clambda.ulambda = + let closed = is_function_constant t direct_func in + let label = Compilenv.function_label direct_func in + let uargs = + let uargs = subst_vars env args in + (* Remove the closure argument if the closure is closed. (Note that the + closure argument is always a variable, so we can be sure we are not + dropping any side effects.) *) + if closed then uargs else uargs @ [subst_var env func] + in + Udirect_apply (label, uargs, dbg) + +(* Describe how to build a runtime closure block that corresponds to the + given Flambda set of closures. + + For instance the closure for the following set of closures: + + let rec fun_a x = + if x <= 0 then 0 else fun_b (x-1) v1 + and fun_b x y = + if x <= 0 then 0 else v1 + v2 + y + fun_a (x-1) + + will be represented in memory as: + + [ closure header; fun_a; + 1; infix header; fun caml_curry_2; + 2; fun_b; v1; v2 ] + + fun_a and fun_b will take an additional parameter 'env' to + access their closure. It will be arranged such that in the body + of each function the env parameter points to its own code + pointer. For example, in fun_b it will be shifted by 3 words. + + Hence accessing v1 in the body of fun_a is accessing the + 6th field of 'env' and in the body of fun_b the 1st field. +*) +and to_clambda_set_of_closures t env + (({ function_decls; free_vars } : Flambda.set_of_closures) + as set_of_closures) : Clambda.ulambda = + let all_functions = Variable.Map.bindings function_decls.funs in + let env_var = Ident.create "env" in + let to_clambda_function + (closure_id, (function_decl : Flambda.function_declaration)) + : Clambda.ufunction = + let closure_id = Closure_id.wrap closure_id in + let fun_offset = + Closure_id.Map.find closure_id t.current_unit.fun_offset_table + in + let env = + (* Inside the body of the function, we cannot access variables + declared outside, so start with a suitably clean environment. + Note that we must not forget the information about which allocated + constants contain which unboxed values. *) + let env = Env.keep_only_symbols env in + (* Add the Clambda expressions for the free variables of the function + to the environment. *) + let add_env_free_variable id _ env = + let var_offset = + try + Var_within_closure.Map.find + (Var_within_closure.wrap id) t.current_unit.fv_offset_table + with Not_found -> + Misc.fatal_errorf "Clambda.to_clambda_set_of_closures: offset for \ + free variable %a is unknown. Set of closures: %a" + Variable.print id + Flambda.print_set_of_closures set_of_closures + in + let pos = var_offset - fun_offset in + Env.add_subst env id + (Uprim (Pfield pos, [Clambda.Uvar env_var], Debuginfo.none)) + in + let env = Variable.Map.fold add_env_free_variable free_vars env in + (* Add the Clambda expressions for all functions defined in the current + set of closures to the environment. The various functions may be + retrieved by moving within the runtime closure, starting from the + current function's closure. *) + let add_env_function pos env (id, _) = + let offset = + Closure_id.Map.find (Closure_id.wrap id) + t.current_unit.fun_offset_table + in + let exp : Clambda.ulambda = Uoffset (Uvar env_var, offset - pos) in + Env.add_subst env id exp + in + List.fold_left (add_env_function fun_offset) env all_functions + in + let env_body, params = + List.fold_right (fun var (env, params) -> + let id, env = Env.add_fresh_ident env var in + env, id :: params) + function_decl.params (env, []) + in + { label = Compilenv.function_label closure_id; + arity = Flambda_utils.function_arity function_decl; + params = params @ [env_var]; + body = to_clambda t env_body function_decl.body; + dbg = function_decl.dbg; + env = Some env_var; + } + in + let funs = List.map to_clambda_function all_functions in + let free_vars = + Variable.Map.bindings (Variable.Map.map ( + fun (free_var : Flambda.specialised_to) -> + subst_var env free_var.var) free_vars) + in + Uclosure (funs, List.map snd free_vars) + +and to_clambda_closed_set_of_closures t env symbol + ({ function_decls; } : Flambda.set_of_closures) + : Clambda.ustructured_constant = + let functions = Variable.Map.bindings function_decls.funs in + let to_clambda_function (id, (function_decl : Flambda.function_declaration)) + : Clambda.ufunction = + (* All that we need in the environment, for translating one closure from + a closed set of closures, is the substitutions for variables bound to + the various closures in the set. Such closures will always be + referenced via symbols. *) + let env = + List.fold_left (fun env (var, _) -> + let closure_id = Closure_id.wrap var in + let symbol = Compilenv.closure_symbol closure_id in + Env.add_subst env var (to_clambda_symbol env symbol)) + (Env.keep_only_symbols env) + functions + in + let env_body, params = + List.fold_right (fun var (env, params) -> + let id, env = Env.add_fresh_ident env var in + env, id :: params) + function_decl.params (env, []) + in + { label = Compilenv.function_label (Closure_id.wrap id); + arity = Flambda_utils.function_arity function_decl; + params; + body = to_clambda t env_body function_decl.body; + dbg = function_decl.dbg; + env = None; + } + in + let ufunct = List.map to_clambda_function functions in + let closure_lbl = Linkage_name.to_string (Symbol.label symbol) in + Uconst_closure (ufunct, closure_lbl, []) + +let to_clambda_initialize_symbol t env symbol fields : Clambda.ulambda = + let fields = + List.mapi (fun index expr -> index, to_clambda t env expr) fields + in + let build_setfield (index, field) : Clambda.ulambda = + (* Note that this will never cause a write barrier hit, owing to + the [Initialization]. *) + Uprim (Psetfield (index, Pointer, Root_initialization), + [to_clambda_symbol env symbol; field], + Debuginfo.none) + in + match fields with + | [] -> Uconst (Uconst_ptr 0) + | h :: t -> + List.fold_left (fun acc (p, field) -> + Clambda.Usequence (build_setfield (p, field), acc)) + (build_setfield h) t + +let accumulate_structured_constants t env symbol + (c : Flambda.constant_defining_value) acc = + match c with + | Allocated_const c -> + Symbol.Map.add symbol (to_clambda_allocated_constant c) acc + | Block (tag, fields) -> + let fields = List.map (to_clambda_const env) fields in + Symbol.Map.add symbol (Clambda.Uconst_block (Tag.to_int tag, fields)) acc + | Set_of_closures set_of_closures -> + let to_clambda_set_of_closures = + to_clambda_closed_set_of_closures t env symbol set_of_closures + in + Symbol.Map.add symbol to_clambda_set_of_closures acc + | Project_closure _ -> acc + +let to_clambda_program t env constants (program : Flambda.program) = + let rec loop env constants (program : Flambda.program_body) + : Clambda.ulambda * Clambda.ustructured_constant Symbol.Map.t = + match program with + | Let_symbol (symbol, alloc, program) -> + (* Useful only for unboxing. Since floats and boxed integers will + never be part of a Let_rec_symbol, handling only the Let_symbol + is sufficient. *) + let env = + match alloc with + | Allocated_const const -> Env.add_allocated_const env symbol const + | _ -> env + in + let constants = + accumulate_structured_constants t env symbol alloc constants + in + loop env constants program + | Let_rec_symbol (defs, program) -> + let constants = + List.fold_left (fun constants (symbol, alloc) -> + accumulate_structured_constants t env symbol alloc constants) + constants defs + in + loop env constants program + | Initialize_symbol (symbol, _tag, fields, program) -> + (* The tag is ignored here: It is used separately to generate the + preallocated block. Only the initialisation code is generated + here. *) + let e1 = to_clambda_initialize_symbol t env symbol fields in + let e2, constants = loop env constants program in + Usequence (e1, e2), constants + | Effect (expr, program) -> + let e1 = to_clambda t env expr in + let e2, constants = loop env constants program in + Usequence (e1, e2), constants + | End _ -> + Uconst (Uconst_ptr 0), constants + in + loop env constants program.program_body + +type result = { + expr : Clambda.ulambda; + preallocated_blocks : Clambda.preallocated_block list; + structured_constants : Clambda.ustructured_constant Symbol.Map.t; + exported : Export_info.t; +} + +let convert (program, exported) : result = + let current_unit = + let offsets = Closure_offsets.compute program in + { fun_offset_table = offsets.function_offsets; + fv_offset_table = offsets.free_variable_offsets; + closures = Flambda_utils.make_closure_map program; + constant_sets_of_closures = + Flambda_utils.all_lifted_constant_sets_of_closures program; + } + in + let imported_units = + let imported = Compilenv.approx_env () in + { fun_offset_table = imported.offset_fun; + fv_offset_table = imported.offset_fv; + closures = imported.closures; + constant_sets_of_closures = imported.constant_sets_of_closures; + } + in + let t = { current_unit; imported_units; } in + let preallocated_blocks = + List.map (fun (symbol, tag, fields) -> + { Clambda. + symbol = Linkage_name.to_string (Symbol.label symbol); + exported = true; + tag = Tag.to_int tag; + size = List.length fields; + }) + (Flambda_utils.initialize_symbols program) + in + let expr, structured_constants = + to_clambda_program t Env.empty Symbol.Map.empty program + in + let offset_fun, offset_fv = + Closure_offsets.compute_reexported_offsets program + ~current_unit_offset_fun:current_unit.fun_offset_table + ~current_unit_offset_fv:current_unit.fv_offset_table + ~imported_units_offset_fun:imported_units.fun_offset_table + ~imported_units_offset_fv:imported_units.fv_offset_table + in + let exported = + Export_info.add_clambda_info exported + ~offset_fun + ~offset_fv + ~constant_sets_of_closures:current_unit.constant_sets_of_closures + in + { expr; preallocated_blocks; structured_constants; exported; } diff -Nru ocaml-4.01.0/asmcomp/flambda_to_clambda.mli ocaml-4.05.0/asmcomp/flambda_to_clambda.mli --- ocaml-4.01.0/asmcomp/flambda_to_clambda.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/flambda_to_clambda.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +type result = { + expr : Clambda.ulambda; + preallocated_blocks : Clambda.preallocated_block list; + structured_constants : Clambda.ustructured_constant Symbol.Map.t; + exported : Export_info.t; +} + +(** Convert an Flambda program, with associated proto-export information, + to Clambda. + This yields a Clambda expression together with augmented export + information and details about required statically-allocated values + (preallocated blocks, for [Initialize_symbol], and structured + constants). + + It is during this process that accesses to variables within + closures are transformed to field accesses within closure values. + For direct calls, the hidden closure parameter is added. Switch + tables are also built. +*) +val convert : Flambda.program * Export_info.t -> result diff -Nru ocaml-4.01.0/asmcomp/i386/arch.ml ocaml-4.05.0/asmcomp/i386/arch.ml --- ocaml-4.01.0/asmcomp/i386/arch.ml 2012-11-09 16:15:29.000000000 +0000 +++ ocaml-4.05.0/asmcomp/i386/arch.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Machine-specific command-line options *) @@ -31,11 +34,12 @@ type specific_operation = Ilea of addressing_mode (* Lea gives scaled adds *) - | Istore_int of nativeint * addressing_mode (* Store an integer constant *) - | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Istore_int of nativeint * addressing_mode * bool + (* Store an integer constant *) + | Istore_symbol of string * addressing_mode * bool (* Store a symbol *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ipush (* Push regs on stack *) - | Ipush_int of nativeint (* Push an integer constant *) + | Ipush_int of nativeint (* Push an integer constant *) | Ipush_symbol of string (* Push a symbol *) | Ipush_load of addressing_mode (* Load a scalar and push *) | Ipush_load_float of addressing_mode (* Load a float and push *) @@ -48,6 +52,8 @@ and float_operation = Ifloatadd | Ifloatsub | Ifloatsubrev | Ifloatmul | Ifloatdiv | Ifloatdivrev +let spacetime_node_hole_pointer_is_live_before _specific_op = false + (* Sizes, endianness *) let big_endian = false @@ -75,11 +81,11 @@ | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta) let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 - | Iindexed2 n -> 2 - | Iscaled(scale, n) -> 1 - | Iindexed2scaled(scale, n) -> 2 + Ibased _ -> 0 + | Iindexed _ -> 1 + | Iindexed2 _ -> 2 + | Iscaled _ -> 1 + | Iindexed2scaled _ -> 2 (* Printing operations and addressing modes *) @@ -105,11 +111,14 @@ let print_specific_operation printreg op ppf arg = match op with | Ilea addr -> print_addressing printreg addr ppf arg - | Istore_int(n, addr) -> - fprintf ppf "[%a] := %s" (print_addressing printreg addr) arg - (Nativeint.to_string n) - | Istore_symbol(lbl, addr) -> - fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl + | Istore_int(n, addr, is_assign) -> + fprintf ppf "[%a] := %nd %s" + (print_addressing printreg addr) arg n + (if is_assign then "(assign)" else "(init)") + | Istore_symbol(lbl, addr, is_assign) -> + fprintf ppf "[%a] := \"%s\" %s" + (print_addressing printreg addr) arg lbl + (if is_assign then "(assign)" else "(init)") | Ioffset_loc(n, addr) -> fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n | Ipush -> @@ -152,5 +161,7 @@ let stack_alignment = match Config.system with - | "macosx" -> 16 - | _ -> 4 + | "win32" -> 4 (* MSVC *) + | _ -> 16 +(* PR#6038: GCC and Clang seem to require 16-byte alignment nowadays, + even if only MacOS X's ABI formally requires it *) diff -Nru ocaml-4.01.0/asmcomp/i386/CSE.ml ocaml-4.05.0/asmcomp/i386/CSE.ml --- ocaml-4.01.0/asmcomp/i386/CSE.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/i386/CSE.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* CSE for the i386 *) + +open Cmm +open Arch +open Mach +open CSEgen + +class cse = object + +inherit cse_generic as super + +method! class_of_operation op = + match op with + (* Operations that affect the floating-point stack cannot be factored *) + | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Iintoffloat | Ifloatofint + | Iload((Single | Double | Double_u), _) -> Op_other + (* Specific ops *) + | Ispecific(Ilea _) -> Op_pure + | Ispecific(Istore_int(_, _, is_asg)) -> Op_store is_asg + | Ispecific(Istore_symbol(_, _, is_asg)) -> Op_store is_asg + | Ispecific(Ioffset_loc(_, _)) -> Op_store true + | Ispecific _ -> Op_other + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int _ -> true + | Iconst_symbol _ -> true + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/i386/emit.mlp ocaml-4.05.0/asmcomp/i386/emit.mlp --- ocaml-4.01.0/asmcomp/i386/emit.mlp 2013-03-19 07:22:12.000000000 +0000 +++ ocaml-4.05.0/asmcomp/i386/emit.mlp 2017-07-13 08:56:44.000000000 +0000 @@ -1,20 +1,21 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +#2 "asmcomp/i386/emit.mlp" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Emission of Intel 386 assembly code *) -module StringSet = - Set.Make(struct type t = string let compare (x:t) y = compare x y end) - open Misc open Cmm open Arch @@ -24,6 +25,29 @@ open Linearize open Emitaux +open X86_ast +open X86_proc +open X86_dsl + +let _label s = D.label ~typ:DWORD s + +let mem_sym typ ?(ofs = 0) sym = + mem32 typ ~scale:0 ?base:None ~sym ofs RAX (*ignored since scale=0*) + +(* CFI directives *) + +let cfi_startproc () = + if Config.asm_cfi_supported then D.cfi_startproc () + +let cfi_endproc () = + if Config.asm_cfi_supported then D.cfi_endproc () + +let cfi_adjust_cfa_offset n = + if Config.asm_cfi_supported then D.cfi_adjust_cfa_offset n + +let emit_debug_info dbg = + emit_debug_info_gen dbg D.file D.loc + (* Tradeoff between code size and code speed *) let fastcode_flag = ref true @@ -39,7 +63,7 @@ let slot_offset loc cl = match loc with - Incoming n -> + | Incoming n -> assert (n >= 0); frame_size() + n | Local n -> @@ -50,152 +74,146 @@ assert (n >= 0); n +(* Record symbols used and defined - at the end generate extern for those + used but not defined *) + +let symbols_defined = ref StringSet.empty +let symbols_used = ref StringSet.empty + +let add_def_symbol s = symbols_defined := StringSet.add s !symbols_defined +let add_used_symbol s = symbols_used := StringSet.add s !symbols_used + let trap_frame_size = Misc.align 8 stack_alignment (* Prefixing of symbols with "_" *) let symbol_prefix = - match Config.system with - "linux_elf" -> "" - | "bsd_elf" -> "" - | "solaris" -> "" - | "beos" -> "" - | "gnu" -> "" - | _ -> "_" + match system with + | S_linux_elf -> "" + | S_bsd_elf -> "" + | S_solaris -> "" + | S_beos -> "" + | S_gnu -> "" + | _ -> "_" (* win32 & others *) + +let emit_symbol s = string_of_symbol symbol_prefix s + +let immsym s = sym (emit_symbol s) -let emit_symbol s = - emit_string symbol_prefix; Emitaux.emit_symbol '$' s +let emit_call s = I.call (immsym s) (* Output a label *) let label_prefix = - match Config.system with - "linux_elf" -> ".L" - | "bsd_elf" -> ".L" - | "solaris" -> ".L" - | "beos" -> ".L" - | "gnu" -> ".L" + match system with + | S_linux_elf -> ".L" + | S_bsd_elf -> ".L" + | S_solaris -> ".L" + | S_beos -> ".L" + | S_gnu -> ".L" | _ -> "L" let emit_label lbl = - emit_string label_prefix; emit_int lbl + Printf.sprintf "%s%d" label_prefix lbl -let emit_data_label lbl = - emit_string label_prefix; emit_string "d"; emit_int lbl +let label s = sym (emit_label s) - -(* Some data directives have different names under Solaris *) - -let word_dir = - match Config.system with - "solaris" -> ".value" - | _ -> ".word" -let skip_dir = - match Config.system with - "solaris" -> ".zero" - | _ -> ".space" -let use_ascii_dir = - match Config.system with - "solaris" -> false - | _ -> true - -(* MacOSX has its own way to reference symbols potentially defined in - shared objects *) - -let macosx = - match Config.system with - | "macosx" -> true - | _ -> false - -(* Output a .align directive. - The numerical argument to .align is log2 of alignment size, except - under ELF, where it is the alignment size... *) - -let emit_align = - match Config.system with - "linux_elf" | "bsd_elf" | "solaris" | "beos" | "cygwin" | "mingw" | "gnu" -> - (fun n -> ` .align {emit_int n}\n`) - | _ -> - (fun n -> ` .align {emit_int(Misc.log2 n)}\n`) +let def_label s = D.label (emit_label s) let emit_Llabel fallthrough lbl = - if not fallthrough && !fastcode_flag then - emit_align 16 ; - emit_label lbl + if not fallthrough && !fastcode_flag then D.align 16 ; + def_label lbl (* Output a pseudo-register *) -let emit_reg = function - { loc = Reg r } -> - emit_string (register_name r) +let int_reg_name = [| RAX; RBX; RCX; RDX; RSI; RDI; RBP |] + +let float_reg_name = [| TOS |] + +let register_name r = + if r < 100 then Reg32 (int_reg_name.(r)) + else Regf (float_reg_name.(r - 100)) + +let sym32 ?ofs s = mem_sym ?ofs DWORD (emit_symbol s) + +let reg = function + | { loc = Reg r } -> register_name r | { loc = Stack(Incoming n | Outgoing n) } when n < 0 -> - `{emit_symbol "caml_extra_params"} + {emit_int (n + 64)}` + sym32 "caml_extra_params" ~ofs:(n + 64) + | { loc = Stack s; typ = Float } as r -> + let ofs = slot_offset s (register_class r) in + mem32 REAL8 ofs RSP | { loc = Stack s } as r -> let ofs = slot_offset s (register_class r) in - `{emit_int ofs}(%esp)` + mem32 DWORD ofs RSP | { loc = Unknown } -> - fatal_error "Emit_i386.emit_reg" + fatal_error "Emit_i386.reg" (* Output a reference to the lower 8 bits or lower 16 bits of a register *) -let reg_low_byte_name = [| "%al"; "%bl"; "%cl"; "%dl" |] -let reg_low_half_name = [| "%ax"; "%bx"; "%cx"; "%dx"; "%si"; "%di"; "%bp" |] +let reg_low_8_name = Array.map (fun r -> Reg8L r) int_reg_name +let reg_low_16_name = Array.map (fun r -> Reg16 r) int_reg_name -let emit_reg8 r = +let reg8 r = match r.loc with - Reg r when r < 4 -> emit_string (reg_low_byte_name.(r)) - | _ -> fatal_error "Emit_i386.emit_reg8" + | Reg r when r < 4 -> reg_low_8_name.(r) + | _ -> fatal_error "Emit_i386.reg8" -let emit_reg16 r = +let reg16 r = match r.loc with - Reg r when r < 7 -> emit_string (reg_low_half_name.(r)) - | _ -> fatal_error "Emit_i386.emit_reg16" + | Reg r when r < 7 -> reg_low_16_name.(r) + | _ -> fatal_error "Emit_i386.reg16" + +let reg32 = function + | { loc = Reg.Reg r } -> int_reg_name.(r) + | _ -> assert false + +let arg32 i n = reg32 i.arg.(n) (* Output an addressing mode *) -let emit_addressing addr r n = +let addressing addr typ i n = match addr with - Ibased(s, d) -> - `{emit_symbol s}`; - if d <> 0 then ` + {emit_int d}` + | Ibased(s, ofs) -> + add_used_symbol s; + mem_sym typ (emit_symbol s) ~ofs | Iindexed d -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)})` + mem32 typ d (arg32 i n) | Iindexed2 d -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)}, {emit_reg r.(n+1)})` + mem32 typ ~base:(arg32 i n) d (arg32 i (n+1)) | Iscaled(2, d) -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)}, {emit_reg r.(n)})` + mem32 typ ~base:(arg32 i n) d (arg32 i n) | Iscaled(scale, d) -> - if d <> 0 then emit_int d; - `(, {emit_reg r.(n)}, {emit_int scale})` + mem32 typ ~scale d (arg32 i n) | Iindexed2scaled(scale, d) -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)}, {emit_reg r.(n+1)}, {emit_int scale})` + mem32 typ ~scale ~base:(arg32 i n) d (arg32 i (n+1)) (* Record live pointers at call points *) -let record_frame_label live dbg = - let lbl = new_label() in +let record_frame_label ?label live raise_ dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function - {typ = Addr; loc = Reg r} -> + | {typ = Val; loc = Reg r} -> live_offset := ((r lsl 1) + 1) :: !live_offset - | {typ = Addr; loc = Stack s} as reg -> + | {typ = Val; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset + | {typ = Addr} as r -> + Misc.fatal_error ("bad GC root " ^ Reg.name r) | _ -> ()) live; - frame_descriptors := - { fd_lbl = lbl; - fd_frame_size = frame_size(); - fd_live_offset = !live_offset; - fd_debuginfo = dbg } :: !frame_descriptors; + record_frame_descr ~label:lbl ~frame_size:(frame_size()) + ~live_offset:!live_offset ~raise_frame:raise_ dbg; lbl -let record_frame live dbg = - let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` +let record_frame ?label live raise_ dbg = + let lbl = record_frame_label ?label live raise_ dbg in + def_label lbl (* Record calls to the GC -- we've moved them out of the way *) @@ -207,8 +225,10 @@ let call_gc_sites = ref ([] : gc_call list) let emit_call_gc gc = - `{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`; - `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` + def_label gc.gc_lbl; + emit_call "caml_call_gc"; + def_label gc.gc_frame; + I.jmp (label gc.gc_return_lbl) (* Record calls to caml_ml_array_bound_error. In -g mode, we maintain one call to caml_ml_array_bound_error @@ -221,105 +241,112 @@ let bound_error_sites = ref ([] : bound_error_call list) let bound_error_call = ref 0 -let bound_error_label dbg = +let bound_error_label ?label dbg = if !Clflags.debug then begin let lbl_bound_error = new_label() in - let lbl_frame = record_frame_label Reg.Set.empty dbg in + let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in bound_error_sites := - { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; - lbl_bound_error - end else begin - if !bound_error_call = 0 then bound_error_call := new_label(); - !bound_error_call - end + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end let emit_call_bound_error bd = - `{emit_label bd.bd_lbl}: call {emit_symbol "caml_ml_array_bound_error"}\n`; - `{emit_label bd.bd_frame}:\n` + def_label bd.bd_lbl; + emit_call "caml_ml_array_bound_error"; + def_label bd.bd_frame let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; - if !bound_error_call > 0 then - `{emit_label !bound_error_call}: call {emit_symbol "caml_ml_array_bound_error"}\n` + if !bound_error_call > 0 then begin + def_label !bound_error_call; + emit_call "caml_ml_array_bound_error" + end (* Names for instructions *) let instr_for_intop = function - Iadd -> "addl" - | Isub -> "subl" - | Imul -> "imull" - | Iand -> "andl" - | Ior -> "orl" - | Ixor -> "xorl" - | Ilsl -> "sall" - | Ilsr -> "shrl" - | Iasr -> "sarl" + | Iadd -> I.add + | Isub -> I.sub + | Imul -> (fun arg1 arg2 -> I.imul arg1 (Some arg2)) + | Iand -> I.and_ + | Ior -> I.or_ + | Ixor -> I.xor + | Ilsl -> I.sal + | Ilsr -> I.shr + | Iasr -> I.sar | _ -> fatal_error "Emit_i386: instr_for_intop" +let unary_instr_for_floatop = function + | Inegf -> I.fchs () + | Iabsf -> I.fabs () + | _ -> fatal_error "Emit_i386: unary_instr_for_floatop" + let instr_for_floatop = function - Inegf -> "fchs" - | Iabsf -> "fabs" - | Iaddf -> "faddl" - | Isubf -> "fsubl" - | Imulf -> "fmull" - | Idivf -> "fdivl" - | Ispecific Isubfrev -> "fsubrl" - | Ispecific Idivfrev -> "fdivrl" + | Iaddf -> I.fadd + | Isubf -> I.fsub + | Imulf -> I.fmul + | Idivf -> I.fdiv + | Ispecific Isubfrev -> I.fsubr + | Ispecific Idivfrev -> I.fdivr | _ -> fatal_error "Emit_i386: instr_for_floatop" let instr_for_floatop_reversed = function - Iaddf -> "faddl" - | Isubf -> "fsubrl" - | Imulf -> "fmull" - | Idivf -> "fdivrl" - | Ispecific Isubfrev -> "fsubl" - | Ispecific Idivfrev -> "fdivl" + | Iaddf -> I.fadd + | Isubf -> I.fsubr + | Imulf -> I.fmul + | Idivf -> I.fdivr + | Ispecific Isubfrev -> I.fsub + | Ispecific Idivfrev -> I.fdiv | _ -> fatal_error "Emit_i386: instr_for_floatop_reversed" -let instr_for_floatop_pop = function - Iaddf -> "faddp" - | Isubf -> "fsubp" - | Imulf -> "fmulp" - | Idivf -> "fdivp" - | Ispecific Isubfrev -> "fsubrp" - | Ispecific Idivfrev -> "fdivrp" - | _ -> fatal_error "Emit_i386: instr_for_floatop_pop" - -let instr_for_floatarithmem double = function - Ifloatadd -> if double then "faddl" else "fadds" - | Ifloatsub -> if double then "fsubl" else "fsubs" - | Ifloatsubrev -> if double then "fsubrl" else "fsubrs" - | Ifloatmul -> if double then "fmull" else "fmuls" - | Ifloatdiv -> if double then "fdivl" else "fdivs" - | Ifloatdivrev -> if double then "fdivrl" else "fdivrs" - -let name_for_cond_branch = function - Isigned Ceq -> "e" | Isigned Cne -> "ne" - | Isigned Cle -> "le" | Isigned Cgt -> "g" - | Isigned Clt -> "l" | Isigned Cge -> "ge" - | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" - | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" - | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" + +let instr_for_floatop_reversed_pop = function + | Iaddf -> I.faddp + | Isubf -> I.fsubrp + | Imulf -> I.fmulp + | Idivf -> I.fdivrp + | Ispecific Isubfrev -> I.fsubp + | Ispecific Idivfrev -> I.fdivp + | _ -> fatal_error "Emit_i386: instr_for_floatop_reversed_pop" + +let instr_for_floatarithmem = function + | Ifloatadd -> I.fadd + | Ifloatsub -> I.fsub + | Ifloatsubrev -> I.fsubr + | Ifloatmul -> I.fmul + | Ifloatdiv -> I.fdiv + | Ifloatdivrev -> I.fdivr + +let cond = function + | Isigned Ceq -> E | Isigned Cne -> NE + | Isigned Cle -> LE | Isigned Cgt -> G + | Isigned Clt -> L | Isigned Cge -> GE + | Iunsigned Ceq -> E | Iunsigned Cne -> NE + | Iunsigned Cle -> BE | Iunsigned Cgt -> A + | Iunsigned Clt -> B | Iunsigned Cge -> AE (* Output an = 0 or <> 0 test. *) let output_test_zero arg = match arg.loc with - Reg r -> ` testl {emit_reg arg}, {emit_reg arg}\n` - | _ -> ` cmpl $0, {emit_reg arg}\n` + | Reg.Reg _ -> I.test (reg arg) (reg arg) + | _ -> I.cmp (int 0) (reg arg) (* Deallocate the stack frame before a return or tail call *) let output_epilogue f = let n = frame_size() - 4 in if n > 0 then - begin - ` addl ${emit_int n}, %esp\n`; - cfi_adjust_cfa_offset (-n); - f (); - (* reset CFA back cause function body may continue *) - cfi_adjust_cfa_offset n - end + begin + I.add (int n) esp; + cfi_adjust_cfa_offset (-n); + f (); + (* reset CFA back cause function body may continue *) + cfi_adjust_cfa_offset n + end else f () @@ -332,87 +359,85 @@ let emit_float_test cmp neg arg lbl = let actual_cmp = match (is_tos arg.(0), is_tos arg.(1)) with - (true, true) -> - (* both args on top of FP stack *) - ` fcompp\n`; - cmp + | (true, true) -> + (* both args on top of FP stack *) + I.fcompp (); + cmp | (true, false) -> - (* first arg on top of FP stack *) - ` fcompl {emit_reg arg.(1)}\n`; - cmp + (* first arg on top of FP stack *) + I.fcomp (reg arg.(1)); + cmp | (false, true) -> - (* second arg on top of FP stack *) - ` fcompl {emit_reg arg.(0)}\n`; - Cmm.swap_comparison cmp + (* second arg on top of FP stack *) + I.fcomp (reg arg.(0)); + Cmm.swap_comparison cmp | (false, false) -> - ` fldl {emit_reg arg.(0)}\n`; - ` fcompl {emit_reg arg.(1)}\n`; - cmp - in - ` fnstsw %ax\n`; - begin match actual_cmp with - Ceq -> + I.fld (reg arg.(0)); + I.fcomp (reg arg.(1)); + cmp + in + I.fnstsw ax; + match actual_cmp with + | Ceq -> if neg then begin - ` andb $68, %ah\n`; - ` xorb $64, %ah\n`; - ` jne ` + I.and_ (int 68) ah; + I.xor (int 64) ah; + I.jne lbl end else begin - ` andb $69, %ah\n`; - ` cmpb $64, %ah\n`; - ` je ` + I.and_ (int 69) ah; + I.cmp (int 64) ah; + I.je lbl end | Cne -> if neg then begin - ` andb $69, %ah\n`; - ` cmpb $64, %ah\n`; - ` je ` + I.and_ (int 69) ah; + I.cmp (int 64) ah; + I.je lbl end else begin - ` andb $68, %ah\n`; - ` xorb $64, %ah\n`; - ` jne ` + I.and_ (int 68) ah; + I.xor (int 64) ah; + I.jne lbl end | Cle -> - ` andb $69, %ah\n`; - ` decb %ah\n`; - ` cmpb $64, %ah\n`; + I.and_ (int 69) ah; + I.dec ah; + I.cmp (int 64) ah; if neg - then ` jae ` - else ` jb ` + then I.jae lbl + else I.jb lbl | Cge -> - ` andb $5, %ah\n`; + I.and_ (int 5) ah; if neg - then ` jne ` - else ` je ` + then I.jne lbl + else I.je lbl | Clt -> - ` andb $69, %ah\n`; - ` cmpb $1, %ah\n`; + I.and_ (int 69) ah; + I.cmp (int 1) ah; if neg - then ` jne ` - else ` je ` + then I.jne lbl + else I.je lbl | Cgt -> - ` andb $69, %ah\n`; + I.and_ (int 69) ah; if neg - then ` jne ` - else ` je ` - end; - `{emit_label lbl}\n` + then I.jne lbl + else I.je lbl (* Emit a Ifloatspecial instruction *) let emit_floatspecial = function - "atan" -> ` fld1; fpatan\n` - | "atan2" -> ` fpatan\n` - | "cos" -> ` fcos\n` - | "log" -> ` fldln2; fxch; fyl2x\n` - | "log10" -> ` fldlg2; fxch; fyl2x\n` - | "sin" -> ` fsin\n` - | "sqrt" -> ` fsqrt\n` - | "tan" -> ` fptan; fstp %st(0)\n` + | "atan" -> I.fld1 (); I.fpatan () + | "atan2" -> I.fpatan () + | "cos" -> I.fcos () + | "log" -> I.fldln2 (); I.fxch st1; I.fyl2x () + | "log10" -> I.fldlg2 (); I.fxch st1; I.fyl2x () + | "sin" -> I.fsin () + | "sqrt" -> I.fsqrt () + | "tan" -> I.fptan (); I.fstp st0 | _ -> assert false (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = try @@ -423,9 +448,22 @@ float_constants := (cst, lbl) :: !float_constants; lbl -let emit_float_constant (cst, lbl) = - `{emit_label lbl}:`; - emit_float64_split_directive ".long" cst +let emit_float64_split_directive x = + let lo = Int64.logand x 0xFFFF_FFFFL + and hi = Int64.shift_right_logical x 32 in + D.long (Const (if Arch.big_endian then hi else lo)); + D.long (Const (if Arch.big_endian then lo else hi)) + +let emit_float_constant cst lbl = + _label (emit_label lbl); + emit_float64_split_directive cst + +let emit_global_label s = + let lbl = Compilenv.make_symbol (Some s) in + add_def_symbol lbl; + let lbl = emit_symbol lbl in + D.global lbl; + _label lbl (* Output the assembly code for an instruction *) @@ -433,414 +471,417 @@ let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 -(* Label of trap for out-of-range accesses *) -let range_check_trap = ref 0 (* Record references to external C functions (for MacOSX) *) let external_symbols_direct = ref StringSet.empty let external_symbols_indirect = ref StringSet.empty let emit_instr fallthrough i = - emit_debug_info i.dbg; - match i.desc with - Lend -> () - | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin - if src.typ = Float then - if is_tos src then - ` fstpl {emit_reg dst}\n` - else if is_tos dst then - ` fldl {emit_reg src}\n` - else begin - ` fldl {emit_reg src}\n`; - ` fstpl {emit_reg dst}\n` - end - else - ` movl {emit_reg src}, {emit_reg dst}\n` - end - | Lop(Iconst_int n) -> - if n = 0n then begin - match i.res.(0).loc with - Reg n -> ` xorl {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | _ -> ` movl $0, {emit_reg i.res.(0)}\n` - end else - ` movl ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with - | 0x0000_0000_0000_0000L -> (* +0.0 *) - ` fldz\n` - | 0x8000_0000_0000_0000L -> (* -0.0 *) - ` fldz\n fchs\n` - | 0x3FF0_0000_0000_0000L -> (* 1.0 *) - ` fld1\n` - | 0xBFF0_0000_0000_0000L -> (* -1.0 *) - ` fld1\n fchs\n` - | _ -> - let lbl = add_float_constant s in - ` fldl {emit_label lbl}\n` - end - | Lop(Iconst_symbol s) -> - ` movl ${emit_symbol s}, {emit_reg i.res.(0)}\n` - | Lop(Icall_ind) -> - ` call *{emit_reg i.arg.(0)}\n`; - record_frame i.live i.dbg - | Lop(Icall_imm s) -> - ` call {emit_symbol s}\n`; - record_frame i.live i.dbg - | Lop(Itailcall_ind) -> + emit_debug_info i.dbg; + match i.desc with + | Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + if src.typ = Float then + if is_tos src then + I.fstp (reg dst) + else if is_tos dst then + I.fld (reg src) + else begin + I.fld (reg src); + I.fstp (reg dst) + end + else + I.mov (reg src) (reg dst) + end + | Lop(Iconst_int n) -> + if n = 0n then begin + match i.res.(0).loc with + | Reg _ -> I.xor (reg i.res.(0)) (reg i.res.(0)) + | _ -> I.mov (int 0) (reg i.res.(0)) + end else + I.mov (nat n) (reg i.res.(0)) + | Lop(Iconst_float f) -> + begin match f with + | 0x0000_0000_0000_0000L -> (* +0.0 *) + I.fldz () + | 0x8000_0000_0000_0000L -> (* -0.0 *) + I.fldz (); I.fchs () + | 0x3FF0_0000_0000_0000L -> (* 1.0 *) + I.fld1 () + | 0xBFF0_0000_0000_0000L -> (* -1.0 *) + I.fld1 (); I.fchs () + | _ -> + let lbl = add_float_constant f in + I.fld (mem_sym REAL8 (emit_label lbl)) + end + | Lop(Iconst_symbol s) -> + add_used_symbol s; + I.mov (immsym s) (reg i.res.(0)) + | Lop(Icall_ind { label_after; }) -> + I.call (reg i.arg.(0)); + record_frame i.live false i.dbg ~label:label_after + | Lop(Icall_imm { func; label_after; }) -> + add_used_symbol func; + emit_call func; + record_frame i.live false i.dbg ~label:label_after + | Lop(Itailcall_ind { label_after = _; }) -> + output_epilogue begin fun () -> + I.jmp (reg i.arg.(0)) + end + | Lop(Itailcall_imm { func; label_after = _; }) -> + if func = !function_name then + I.jmp (label !tailrec_entry_point) + else begin output_epilogue begin fun () -> - ` jmp *{emit_reg i.arg.(0)}\n` + add_used_symbol func; + I.jmp (immsym func) end - | Lop(Itailcall_imm s) -> - if s = !function_name then - ` jmp {emit_label !tailrec_entry_point}\n` + end + | Lop(Iextcall { func; alloc; label_after; }) -> + add_used_symbol func; + if alloc then begin + if system <> S_macosx then + I.mov (immsym func) eax else begin - output_epilogue begin fun () -> - ` jmp {emit_symbol s}\n` - end + external_symbols_indirect := + StringSet.add func !external_symbols_indirect; + I.mov (mem_sym DWORD (Printf.sprintf "L%s$non_lazy_ptr" + (emit_symbol func))) eax + end; + emit_call "caml_c_call"; + record_frame i.live false i.dbg ~label:label_after + end else begin + if system <> S_macosx then + emit_call func + else begin + external_symbols_direct := + StringSet.add func !external_symbols_direct; + I.call (sym (Printf.sprintf "L%s$stub" (emit_symbol func))) end - | Lop(Iextcall(s, alloc)) -> - if alloc then begin - if not macosx then - ` movl ${emit_symbol s}, %eax\n` + end + | Lop(Istackoffset n) -> + if n < 0 + then I.add (int (-n)) esp + else I.sub (int n) esp; + cfi_adjust_cfa_offset n; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = i.res.(0) in + begin match chunk with + | Word_int | Word_val | Thirtytwo_signed | Thirtytwo_unsigned -> + I.mov (addressing addr DWORD i 0) (reg dest) + | Byte_unsigned -> + I.movzx (addressing addr BYTE i 0) (reg dest) + | Byte_signed -> + I.movsx (addressing addr BYTE i 0) (reg dest) + | Sixteen_unsigned -> + I.movzx (addressing addr WORD i 0) (reg dest) + | Sixteen_signed -> + I.movsx (addressing addr WORD i 0) (reg dest) + | Single -> + I.fld (addressing addr REAL4 i 0) + | Double | Double_u -> + I.fld (addressing addr REAL8 i 0) + end + | Lop(Istore(chunk, addr, _)) -> + begin match chunk with + | Word_int | Word_val | Thirtytwo_signed | Thirtytwo_unsigned -> + I.mov (reg i.arg.(0)) (addressing addr DWORD i 1) + | Byte_unsigned | Byte_signed -> + I.mov (reg8 i.arg.(0)) (addressing addr BYTE i 1) + | Sixteen_unsigned | Sixteen_signed -> + I.mov (reg16 i.arg.(0)) (addressing addr WORD i 1) + | Single -> + if is_tos i.arg.(0) then + I.fstp (addressing addr REAL4 i 1) else begin - external_symbols_indirect := - StringSet.add s !external_symbols_indirect; - ` movl L{emit_symbol s}$non_lazy_ptr, %eax\n` - end; - ` call {emit_symbol "caml_c_call"}\n`; - record_frame i.live i.dbg - end else begin - if not macosx then - ` call {emit_symbol s}\n` + I.fld (reg i.arg.(0)); + I.fstp (addressing addr REAL4 i 1) + end + | Double | Double_u -> + if is_tos i.arg.(0) then + I.fstp (addressing addr REAL8 i 1) else begin - external_symbols_direct := - StringSet.add s !external_symbols_direct; - ` call L{emit_symbol s}$stub\n` + I.fld (reg i.arg.(0)); + I.fstp (addressing addr REAL8 i 1) end - end - | Lop(Istackoffset n) -> - if n < 0 - then ` addl ${emit_int(-n)}, %esp\n` - else ` subl ${emit_int(n)}, %esp\n`; - cfi_adjust_cfa_offset n; - stack_offset := !stack_offset + n - | Lop(Iload(chunk, addr)) -> - let dest = i.res.(0) in - begin match chunk with - | Word | Thirtytwo_signed | Thirtytwo_unsigned -> - ` movl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Byte_unsigned -> - ` movzbl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Byte_signed -> - ` movsbl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Sixteen_unsigned -> - ` movzwl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Sixteen_signed -> - ` movswl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Single -> - ` flds {emit_addressing addr i.arg 0}\n` - | Double | Double_u -> - ` fldl {emit_addressing addr i.arg 0}\n` - end - | Lop(Istore(chunk, addr)) -> - begin match chunk with - | Word | Thirtytwo_signed | Thirtytwo_unsigned -> - ` movl {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Byte_unsigned | Byte_signed -> - ` movb {emit_reg8 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Sixteen_unsigned | Sixteen_signed -> - ` movw {emit_reg16 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Single -> - if is_tos i.arg.(0) then - ` fstps {emit_addressing addr i.arg 1}\n` - else begin - ` fldl {emit_reg i.arg.(0)}\n`; - ` fstps {emit_addressing addr i.arg 1}\n` - end - | Double | Double_u -> - if is_tos i.arg.(0) then - ` fstpl {emit_addressing addr i.arg 1}\n` - else begin - ` fldl {emit_reg i.arg.(0)}\n`; - ` fstpl {emit_addressing addr i.arg 1}\n` - end - end - | Lop(Ialloc n) -> - if !fastcode_flag then begin - let lbl_redo = new_label() in - `{emit_label lbl_redo}: movl {emit_symbol "caml_young_ptr"}, %eax\n`; - ` subl ${emit_int n}, %eax\n`; - ` movl %eax, {emit_symbol "caml_young_ptr"}\n`; - ` cmpl {emit_symbol "caml_young_limit"}, %eax\n`; - let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live Debuginfo.none in - ` jb {emit_label lbl_call_gc}\n`; - ` leal 4(%eax), {emit_reg i.res.(0)}\n`; - call_gc_sites := - { gc_lbl = lbl_call_gc; - gc_return_lbl = lbl_redo; - gc_frame = lbl_frame } :: !call_gc_sites - end else begin - begin match n with - 8 -> ` call {emit_symbol "caml_alloc1"}\n` - | 12 -> ` call {emit_symbol "caml_alloc2"}\n` - | 16 -> ` call {emit_symbol "caml_alloc3"}\n` - | _ -> ` movl ${emit_int n}, %eax\n`; - ` call {emit_symbol "caml_allocN"}\n` - end; - `{record_frame i.live Debuginfo.none} leal 4(%eax), {emit_reg i.res.(0)}\n` - end - | Lop(Iintop(Icomp cmp)) -> - ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` set{emit_string b} %al\n`; - ` movzbl %al, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Icomp cmp, n)) -> - ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` set{emit_string b} %al\n`; - ` movzbl %al, {emit_reg i.res.(0)}\n` - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in - ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label lbl}\n` - | Lop(Iintop_imm(Icheckbound, n)) -> - let lbl = bound_error_label i.dbg in - ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label lbl}\n` - | Lop(Iintop(Idiv | Imod)) -> - ` cltd\n`; - ` idivl {emit_reg i.arg.(1)}\n` - | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> - (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) - ` {emit_string(instr_for_intop op)} %cl, {emit_reg i.res.(0)}\n` - | Lop(Iintop op) -> - (* We have i.arg.(0) = i.res.(0) *) - ` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> - ` leal {emit_int n}({emit_reg i.arg.(0)}), {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> - ` incl {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> - ` decl {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - let l = Misc.log2 n in - let lbl = new_label() in - output_test_zero i.arg.(0); - ` jge {emit_label lbl}\n`; - ` addl ${emit_int(n-1)}, {emit_reg i.arg.(0)}\n`; - `{emit_label lbl}: sarl ${emit_int l}, {emit_reg i.arg.(0)}\n` - | Lop(Iintop_imm(Imod, n)) -> - let lbl = new_label() in - ` movl {emit_reg i.arg.(0)}, %eax\n`; - ` testl %eax, %eax\n`; - ` jge {emit_label lbl}\n`; - ` addl ${emit_int(n-1)}, %eax\n`; - `{emit_label lbl}: andl ${emit_int(-n)}, %eax\n`; - ` subl %eax, {emit_reg i.arg.(0)}\n` - | Lop(Iintop_imm(op, n)) -> - (* We have i.arg.(0) = i.res.(0) *) - ` {emit_string(instr_for_intop op)} ${emit_int n}, {emit_reg i.res.(0)}\n` - | Lop(Inegf | Iabsf as floatop) -> - if not (is_tos i.arg.(0)) then - ` fldl {emit_reg i.arg.(0)}\n`; - ` {emit_string(instr_for_floatop floatop)}\n` - | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific(Isubfrev | Idivfrev) - as floatop) -> - begin match (is_tos i.arg.(0), is_tos i.arg.(1)) with - (true, true) -> + end + | Lop(Ialloc { words = n; label_after_call_gc; }) -> + if !fastcode_flag then begin + let lbl_redo = new_label() in + def_label lbl_redo; + I.mov (sym32 "caml_young_ptr") eax; + I.sub (int n) eax; + I.mov eax (sym32 "caml_young_ptr"); + I.cmp (sym32 "caml_young_limit") eax; + let lbl_call_gc = new_label() in + let lbl_frame = record_frame_label i.live false Debuginfo.none in + I.jb (label lbl_call_gc); + I.lea (mem32 NONE 4 RAX) (reg i.res.(0)); + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame = lbl_frame } :: !call_gc_sites + end else begin + begin match n with + 8 -> emit_call "caml_alloc1" + | 12 -> emit_call "caml_alloc2" + | 16 -> emit_call "caml_alloc3" + | _ -> + I.mov (int n) eax; + emit_call "caml_allocN" + end; + let label = + record_frame_label ?label:label_after_call_gc i.live false + Debuginfo.none + in + def_label label; + I.lea (mem32 NONE 4 RAX) (reg i.res.(0)) + end + | Lop(Iintop(Icomp cmp)) -> + I.cmp (reg i.arg.(1)) (reg i.arg.(0)); + I.set (cond cmp) al; + I.movzx al (reg i.res.(0)); + | Lop(Iintop_imm(Icomp cmp, n)) -> + I.cmp (int n) (reg i.arg.(0)); + I.set (cond cmp) al; + I.movzx al (reg i.res.(0)) + | Lop(Iintop (Icheckbound { label_after_error; } )) -> + let lbl = bound_error_label ?label:label_after_error i.dbg in + I.cmp (reg i.arg.(1)) (reg i.arg.(0)); + I.jbe (label lbl) + | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) -> + let lbl = bound_error_label ?label:label_after_error i.dbg in + I.cmp (int n) (reg i.arg.(0)); + I.jbe (label lbl) + | Lop(Iintop(Idiv | Imod)) -> + I.cdq (); + I.idiv (reg i.arg.(1)) + | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> + (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) + instr_for_intop op cl (reg i.res.(0)) + | Lop(Iintop Imulh) -> + I.imul (reg i.arg.(1)) None + | Lop(Iintop op) -> + (* We have i.arg.(0) = i.res.(0) *) + instr_for_intop op (reg i.arg.(1)) (reg i.res.(0)) + | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> + I.lea (mem32 NONE n (reg32 i.arg.(0))) (reg i.res.(0)) + | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> + I.inc (reg i.res.(0)) + | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> + I.dec (reg i.res.(0)) + | Lop(Iintop_imm(op, n)) -> + (* We have i.arg.(0) = i.res.(0) *) + instr_for_intop op (int n) (reg i.res.(0)) + | Lop(Inegf | Iabsf as floatop) -> + if not (is_tos i.arg.(0)) then + I.fld (reg i.arg.(0)); + unary_instr_for_floatop floatop + | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific(Isubfrev | Idivfrev) + as floatop) -> + begin match (is_tos i.arg.(0), is_tos i.arg.(1)) with + (true, true) -> (* both operands on top of FP stack *) - ` {emit_string(instr_for_floatop_pop floatop)} %st, %st(1)\n` - | (true, false) -> + instr_for_floatop_reversed_pop floatop st0 st1 + | (true, false) -> (* first operand on stack *) - ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` - | (false, true) -> + instr_for_floatop floatop (reg i.arg.(1)) + | (false, true) -> (* second operand on stack *) - ` {emit_string(instr_for_floatop_reversed floatop)} {emit_reg i.arg.(0)}\n` - | (false, false) -> + instr_for_floatop_reversed floatop (reg i.arg.(0)) + | (false, false) -> (* both operands in memory *) - ` fldl {emit_reg i.arg.(0)}\n`; - ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` - end - | Lop(Ifloatofint) -> - begin match i.arg.(0).loc with - Stack s -> - ` fildl {emit_reg i.arg.(0)}\n` - | _ -> - ` pushl {emit_reg i.arg.(0)}\n`; - ` fildl (%esp)\n`; - ` addl $4, %esp\n` - end - | Lop(Iintoffloat) -> - if not (is_tos i.arg.(0)) then - ` fldl {emit_reg i.arg.(0)}\n`; - stack_offset := !stack_offset - 8; - ` subl $8, %esp\n`; - cfi_adjust_cfa_offset 8; - ` fnstcw 4(%esp)\n`; - ` movw 4(%esp), %ax\n`; - ` movb $12, %ah\n`; - ` movw %ax, 0(%esp)\n`; - ` fldcw 0(%esp)\n`; - begin match i.res.(0).loc with - Stack s -> - ` fistpl {emit_reg i.res.(0)}\n` + I.fld (reg i.arg.(0)); + instr_for_floatop floatop (reg i.arg.(1)) + end + | Lop(Ifloatofint) -> + begin match i.arg.(0).loc with + | Stack _ -> + I.fild (reg i.arg.(0)) + | _ -> + I.push (reg i.arg.(0)); + I.fild (mem32 DWORD 0 RSP); + I.add (int 4) esp + end + | Lop(Iintoffloat) -> + if not (is_tos i.arg.(0)) then + I.fld (reg i.arg.(0)); + stack_offset := !stack_offset - 8; + I.sub (int 8) esp; + cfi_adjust_cfa_offset 8; + I.fnstcw (mem32 NONE 4 RSP); + I.mov (mem32 WORD 4 RSP) ax; + I.mov (int 12) ah; + I.mov ax (mem32 WORD 0 RSP); + I.fldcw (mem32 NONE 0 RSP); + begin match i.res.(0).loc with + | Stack _ -> + I.fistp (reg i.res.(0)) + | _ -> + I.fistp (mem32 DWORD 0 RSP); + I.mov (mem32 DWORD 0 RSP) (reg i.res.(0)) + end; + I.fldcw (mem32 NONE 4 RSP); + I.add (int 8) esp; + cfi_adjust_cfa_offset (-8); + stack_offset := !stack_offset + 8 + | Lop(Ispecific(Ilea addr)) -> + I.lea (addressing addr DWORD i 0) (reg i.res.(0)) + | Lop(Ispecific(Istore_int(n, addr, _))) -> + I.mov (nat n) (addressing addr DWORD i 0) + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> + add_used_symbol s; + I.mov (immsym s) (addressing addr DWORD i 0) + | Lop(Ispecific(Ioffset_loc(n, addr))) -> + I.add (int n) (addressing addr DWORD i 0) + | Lop(Ispecific(Ipush)) -> + (* Push arguments in reverse order *) + for n = Array.length i.arg - 1 downto 0 do + let r = i.arg.(n) in + match r with + {loc = Reg _; typ = Float} -> + I.sub (int 8) esp; + cfi_adjust_cfa_offset 8; + I.fstp (mem32 REAL8 0 RSP); + stack_offset := !stack_offset + 8 + | {loc = Stack sl; typ = Float} -> + let ofs = slot_offset sl 1 in + (* Use x87 stack to move from stack to stack, + instead of two 32-bit push instructions, + which could kill performance on modern CPUs (see #6979). + *) + I.fld (mem32 REAL8 ofs RSP); + I.sub (int 8) esp; + cfi_adjust_cfa_offset 8; + I.fstp (mem32 REAL8 0 RSP); + stack_offset := !stack_offset + 8 | _ -> - ` fistpl (%esp)\n`; - ` movl (%esp), {emit_reg i.res.(0)}\n` - end; - ` fldcw 4(%esp)\n`; - ` addl $8, %esp\n`; - cfi_adjust_cfa_offset (-8); - stack_offset := !stack_offset + 8 - | Lop(Ispecific(Ilea addr)) -> - ` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> - ` movl ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> - ` movl ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Ioffset_loc(n, addr))) -> - ` addl ${emit_int n}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Ipush)) -> - (* Push arguments in reverse order *) - for n = Array.length i.arg - 1 downto 0 do - let r = i.arg.(n) in - match r with - {loc = Reg _; typ = Float} -> - ` subl $8, %esp\n`; - cfi_adjust_cfa_offset 8; - ` fstpl 0(%esp)\n`; - stack_offset := !stack_offset + 8 - | {loc = Stack sl; typ = Float} -> - let ofs = slot_offset sl 1 in - ` pushl {emit_int(ofs + 4)}(%esp)\n`; - ` pushl {emit_int(ofs + 4)}(%esp)\n`; - cfi_adjust_cfa_offset 8; - stack_offset := !stack_offset + 8 - | _ -> - ` pushl {emit_reg r}\n`; - cfi_adjust_cfa_offset 4; - stack_offset := !stack_offset + 4 - done - | Lop(Ispecific(Ipush_int n)) -> - ` pushl ${emit_nativeint n}\n`; - cfi_adjust_cfa_offset 4; - stack_offset := !stack_offset + 4 - | Lop(Ispecific(Ipush_symbol s)) -> - ` pushl ${emit_symbol s}\n`; - cfi_adjust_cfa_offset 4; - stack_offset := !stack_offset + 4 - | Lop(Ispecific(Ipush_load addr)) -> - ` pushl {emit_addressing addr i.arg 0}\n`; - cfi_adjust_cfa_offset 4; - stack_offset := !stack_offset + 4 - | Lop(Ispecific(Ipush_load_float addr)) -> - ` pushl {emit_addressing (offset_addressing addr 4) i.arg 0}\n`; - ` pushl {emit_addressing addr i.arg 0}\n`; - cfi_adjust_cfa_offset 8; - stack_offset := !stack_offset + 8 - | Lop(Ispecific(Ifloatarithmem(double, op, addr))) -> - if not (is_tos i.arg.(0)) then - ` fldl {emit_reg i.arg.(0)}\n`; - ` {emit_string(instr_for_floatarithmem double op)} {emit_addressing addr i.arg 1}\n` - | Lop(Ispecific(Ifloatspecial s)) -> - (* Push args on float stack if necessary *) - for k = 0 to Array.length i.arg - 1 do - if not (is_tos i.arg.(k)) then ` fldl {emit_reg i.arg.(k)}\n` - done; - (* Fix-up for binary instrs whose args were swapped *) - if Array.length i.arg = 2 && is_tos i.arg.(1) then - ` fxch %st(1)\n`; - emit_floatspecial s - | Lreloadretaddr -> - () - | Lreturn -> - output_epilogue begin fun () -> - ` ret\n` - end - | Llabel lbl -> - `{emit_Llabel fallthrough lbl}:\n` - | Lbranch lbl -> - ` jmp {emit_label lbl}\n` - | Lcondbranch(tst, lbl) -> - begin match tst with - Itruetest -> - output_test_zero i.arg.(0); - ` jne {emit_label lbl}\n` - | Ifalsetest -> - output_test_zero i.arg.(0); - ` je {emit_label lbl}\n` - | Iinttest cmp -> - ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | - Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> - output_test_zero i.arg.(0); - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm(cmp, n) -> - ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Ifloattest(cmp, neg) -> - emit_float_test cmp neg i.arg lbl - | Ioddtest -> - ` testl $1, {emit_reg i.arg.(0)}\n`; - ` jne {emit_label lbl}\n` - | Ieventest -> - ` testl $1, {emit_reg i.arg.(0)}\n`; - ` je {emit_label lbl}\n` - end - | Lcondbranch3(lbl0, lbl1, lbl2) -> - ` cmpl $1, {emit_reg i.arg.(0)}\n`; - begin match lbl0 with - None -> () - | Some lbl -> ` jb {emit_label lbl}\n` - end; - begin match lbl1 with - None -> () - | Some lbl -> ` je {emit_label lbl}\n` - end; - begin match lbl2 with - None -> () - | Some lbl -> ` jg {emit_label lbl}\n` - end - | Lswitch jumptbl -> - let lbl = new_label() in - ` jmp *{emit_label lbl}(, {emit_reg i.arg.(0)}, 4)\n`; - ` .data\n`; - `{emit_label lbl}:`; - for i = 0 to Array.length jumptbl - 1 do - ` .long {emit_label jumptbl.(i)}\n` - done; - ` .text\n` - | Lsetuptrap lbl -> - ` call {emit_label lbl}\n` - | Lpushtrap -> - if trap_frame_size > 8 then - ` subl ${emit_int (trap_frame_size - 8)}, %esp\n`; - ` pushl {emit_symbol "caml_exception_pointer"}\n`; - cfi_adjust_cfa_offset trap_frame_size; - ` movl %esp, {emit_symbol "caml_exception_pointer"}\n`; - stack_offset := !stack_offset + trap_frame_size - | Lpoptrap -> - ` popl {emit_symbol "caml_exception_pointer"}\n`; - ` addl ${emit_int (trap_frame_size - 4)}, %esp\n`; - cfi_adjust_cfa_offset (-trap_frame_size); - stack_offset := !stack_offset - trap_frame_size - | Lraise -> - if !Clflags.debug then begin - ` call {emit_symbol "caml_raise_exn"}\n`; - record_frame Reg.Set.empty i.dbg - end else begin - ` movl {emit_symbol "caml_exception_pointer"}, %esp\n`; - ` popl {emit_symbol "caml_exception_pointer"}\n`; + I.push (reg r); + cfi_adjust_cfa_offset 4; + stack_offset := !stack_offset + 4 + done + | Lop(Ispecific(Ipush_int n)) -> + I.push (nat n); + cfi_adjust_cfa_offset 4; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_symbol s)) -> + add_used_symbol s; + I.push (immsym s); + cfi_adjust_cfa_offset 4; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_load addr)) -> + I.push (addressing addr DWORD i 0); + cfi_adjust_cfa_offset 4; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_load_float addr)) -> + I.push (addressing (offset_addressing addr 4) DWORD i 0); + I.push (addressing addr DWORD i 0); + cfi_adjust_cfa_offset 8; + stack_offset := !stack_offset + 8 + | Lop(Ispecific(Ifloatarithmem(double, op, addr))) -> + if not (is_tos i.arg.(0)) then + I.fld (reg i.arg.(0)); + instr_for_floatarithmem op + (addressing addr + (if double then REAL8 else REAL4) i 1) + | Lop(Ispecific(Ifloatspecial s)) -> + (* Push args on float stack if necessary *) + for k = 0 to Array.length i.arg - 1 do + if not (is_tos i.arg.(k)) then I.fld (reg i.arg.(k)) + done; + (* Fix-up for binary instrs whose args were swapped *) + if Array.length i.arg = 2 && is_tos i.arg.(1) then + I.fxch st1; + emit_floatspecial s + | Lreloadretaddr -> + () + | Lreturn -> + output_epilogue begin fun () -> + I.ret () + end + | Llabel lbl -> + emit_Llabel fallthrough lbl + | Lbranch lbl -> + I.jmp (label lbl) + | Lcondbranch(tst, lbl) -> + let lbl = label lbl in + begin match tst with + | Itruetest -> + output_test_zero i.arg.(0); + I.jne lbl; + | Ifalsetest -> + output_test_zero i.arg.(0); + I.je lbl + | Iinttest cmp -> + I.cmp (reg i.arg.(1)) (reg i.arg.(0)); + I.j (cond cmp) lbl + | Iinttest_imm((Isigned Ceq | Isigned Cne | + Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> + output_test_zero i.arg.(0); + I.j (cond cmp) lbl + | Iinttest_imm(cmp, n) -> + I.cmp (int n) (reg i.arg.(0)); + I.j (cond cmp) lbl + | Ifloattest(cmp, neg) -> + emit_float_test cmp neg i.arg lbl + | Ioddtest -> + I.test (int 1) (reg i.arg.(0)); + I.jne lbl + | Ieventest -> + I.test (int 1) (reg i.arg.(0)); + I.je lbl + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + I.cmp (int 1) (reg i.arg.(0)); + begin match lbl0 with + None -> () + | Some lbl -> I.jb (label lbl) + end; + begin match lbl1 with + None -> () + | Some lbl -> I.je (label lbl) + end; + begin match lbl2 with + None -> () + | Some lbl -> I.jg (label lbl) + end + | Lswitch jumptbl -> + let lbl = new_label() in + I.jmp (mem32 NONE 0 (reg32 i.arg.(0)) ~scale:4 ~sym:(emit_label lbl)); + D.data (); + _label (emit_label lbl); + for i = 0 to Array.length jumptbl - 1 do + D.long (ConstLabel (emit_label jumptbl.(i))) + done; + D.text () + | Lsetuptrap lbl -> + I.call (label lbl) + | Lpushtrap -> + if trap_frame_size > 8 then + I.sub (int (trap_frame_size - 8)) esp; + I.push (sym32 "caml_exception_pointer"); + cfi_adjust_cfa_offset trap_frame_size; + I.mov esp (sym32 "caml_exception_pointer"); + stack_offset := !stack_offset + trap_frame_size + | Lpoptrap -> + I.pop (sym32 "caml_exception_pointer"); + I.add (int (trap_frame_size - 4)) esp; + cfi_adjust_cfa_offset (-trap_frame_size); + stack_offset := !stack_offset - trap_frame_size + | Lraise k -> + begin match k with + | Cmm.Raise_withtrace -> + emit_call "caml_raise_exn"; + record_frame Reg.Set.empty true i.dbg + | Cmm.Raise_notrace -> + I.mov (sym32 "caml_exception_pointer") esp; + I.pop (sym32 "caml_exception_pointer"); if trap_frame_size > 8 then - ` addl ${emit_int (trap_frame_size - 8)}, %esp\n`; - ` ret\n` - end + I.add (int (trap_frame_size - 8)) esp; + I.ret () + end let rec emit_all fallthrough i = match i.desc with @@ -848,65 +889,52 @@ | _ -> emit_instr fallthrough i; emit_all - (Linearize.has_fallthrough i.desc) + (system = S_win32 || Linearize.has_fallthrough i.desc) i.next (* Emission of external symbol references (for MacOSX) *) let emit_external_symbol_direct s = - `L{emit_symbol s}$stub:\n`; - ` .indirect_symbol {emit_symbol s}\n`; - ` hlt ; hlt ; hlt ; hlt ; hlt\n` + _label (Printf.sprintf "L%s$stub" (emit_symbol s)); + D.indirect_symbol (emit_symbol s); + I.hlt (); I.hlt (); I.hlt (); I.hlt () ; I.hlt () let emit_external_symbol_indirect s = - `L{emit_symbol s}$non_lazy_ptr:\n`; - ` .indirect_symbol {emit_symbol s}\n`; - ` .long 0\n` + _label (Printf.sprintf "L%s$non_lazy_ptr" (emit_symbol s)); + D.indirect_symbol (emit_symbol s); + D.long (const 0) let emit_external_symbols () = - ` .section __IMPORT,__pointers,non_lazy_symbol_pointers\n`; + D.section [ "__IMPORT"; "__pointers"] None ["non_lazy_symbol_pointers" ]; StringSet.iter emit_external_symbol_indirect !external_symbols_indirect; external_symbols_indirect := StringSet.empty; - ` .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5\n`; + D.section [ "__IMPORT"; "__jump_table"] None + [ "symbol_stubs"; "self_modifying_code+pure_instructions"; "5" ]; StringSet.iter emit_external_symbol_direct !external_symbols_direct; external_symbols_direct := StringSet.empty; if !Clflags.gprofile then begin - `Lmcount$stub:\n`; - ` .indirect_symbol mcount\n`; - ` hlt ; hlt ; hlt ; hlt ; hlt\n` + _label "Lmcount$stub"; + D.indirect_symbol "mcount"; + I.hlt (); I.hlt (); I.hlt () ; I.hlt () ; I.hlt () end (* Emission of the profiling prelude *) +let call_mcount mcount = + I.push eax; + I.mov esp ebp; + I.push ecx; + I.push edx; + I.call (sym mcount); + I.pop edx; + I.pop ecx; + I.pop eax + let emit_profile () = - match Config.system with - "linux_elf" | "gnu" -> - ` pushl %eax\n`; - ` movl %esp, %ebp\n`; - ` pushl %ecx\n`; - ` pushl %edx\n`; - ` call {emit_symbol "mcount"}\n`; - ` popl %edx\n`; - ` popl %ecx\n`; - ` popl %eax\n` - | "bsd_elf" -> - ` pushl %eax\n`; - ` movl %esp, %ebp\n`; - ` pushl %ecx\n`; - ` pushl %edx\n`; - ` call .mcount\n`; - ` popl %edx\n`; - ` popl %ecx\n`; - ` popl %eax\n` - | "macosx" -> - ` pushl %eax\n`; - ` movl %esp, %ebp\n`; - ` pushl %ecx\n`; - ` pushl %edx\n`; - ` call Lmcount$stub\n`; - ` popl %edx\n`; - ` popl %ecx\n`; - ` popl %eax\n` + match system with + | S_linux_elf | S_gnu -> call_mcount "mcount" + | S_bsd_elf -> call_mcount ".mcount" + | S_macosx -> call_mcount "Lmcount$stub" | _ -> () (*unsupported yet*) (* Emission of a function declaration *) @@ -919,123 +947,150 @@ call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; - ` .text\n`; - emit_align 16; - if macosx + D.text (); + add_def_symbol fundecl.fun_name; + D.align (if system = S_win32 then 4 else 16); + if system = S_macosx && not !Clflags.output_c_object && is_generic_function fundecl.fun_name then (* PR#4690 *) - ` .private_extern {emit_symbol fundecl.fun_name}\n` + D.private_extern (emit_symbol fundecl.fun_name) else - ` .globl {emit_symbol fundecl.fun_name}\n`; - `{emit_symbol fundecl.fun_name}:\n`; + D.global (emit_symbol fundecl.fun_name); + D.label (emit_symbol fundecl.fun_name); emit_debug_info fundecl.fun_dbg; cfi_startproc (); if !Clflags.gprofile then emit_profile(); let n = frame_size() - 4 in - if n > 0 then - begin - ` subl ${emit_int n}, %esp\n`; + if n > 0 then begin + I.sub (int n) esp; cfi_adjust_cfa_offset n; end; - `{emit_label !tailrec_entry_point}:\n`; + def_label !tailrec_entry_point; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); cfi_endproc (); - begin match Config.system with - "linux_elf" | "bsd_elf" | "gnu" -> - ` .type {emit_symbol fundecl.fun_name},@function\n`; - ` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n` - | _ -> () end + begin match system with + | S_linux_elf | S_bsd_elf | S_gnu -> + D.type_ (emit_symbol fundecl.fun_name) "@function"; + D.size (emit_symbol fundecl.fun_name) + (ConstSub ( + ConstThis, + ConstLabel (emit_symbol fundecl.fun_name))) + | _ -> () + end (* Emission of data *) let emit_item = function - Cglobal_symbol s -> - ` .globl {emit_symbol s}\n`; - | Cdefine_symbol s -> - `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_data_label lbl}:\n` - | Cint8 n -> - ` .byte {emit_int n}\n` - | Cint16 n -> - ` {emit_string word_dir} {emit_int n}\n` - | Cint32 n -> - ` .long {emit_nativeint n}\n` - | Cint n -> - ` .long {emit_nativeint n}\n` - | Csingle f -> - emit_float32_directive ".long" f - | Cdouble f -> - emit_float64_split_directive ".long" f - | Csymbol_address s -> - ` .long {emit_symbol s}\n` - | Clabel_address lbl -> - ` .long {emit_data_label lbl}\n` - | Cstring s -> - if use_ascii_dir - then emit_string_directive " .ascii " s - else emit_bytes_directive " .byte " s - | Cskip n -> - if n > 0 then ` {emit_string skip_dir} {emit_int n}\n` - | Calign n -> - emit_align n + | Cglobal_symbol s -> D.global (emit_symbol s) + | Cdefine_symbol s -> add_def_symbol s; _label (emit_symbol s) + | Cint8 n -> D.byte (const n) + | Cint16 n -> D.word (const n) + | Cint32 n -> D.long (const_nat n) + | Cint n -> D.long (const_nat n) + | Csingle f -> D.long (Const (Int64.of_int32 (Int32.bits_of_float f))) + | Cdouble f -> emit_float64_split_directive (Int64.bits_of_float f) + | Csymbol_address s -> add_used_symbol s; D.long (ConstLabel (emit_symbol s)) + | Cstring s -> D.bytes s + | Cskip n -> if n > 0 then D.space n + | Calign n -> D.align n let data l = - ` .data\n`; + D.data (); List.iter emit_item l (* Beginning / end of an assembly file *) let begin_assembly() = + X86_proc.reset_asm_code (); reset_debug_info(); (* PR#5603 *) float_constants := []; - let lbl_begin = Compilenv.make_symbol (Some "data_begin") in - ` .data\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - let lbl_begin = Compilenv.make_symbol (Some "code_begin") in - ` .text\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - if macosx then ` nop\n` (* PR#4690 *) + if system = S_win32 then begin + D.mode386 (); + D.model "FLAT"; + D.extrn "_caml_young_ptr" DWORD; + D.extrn "_caml_young_limit" DWORD; + D.extrn "_caml_exception_pointer" DWORD; + D.extrn "_caml_extra_params" DWORD; + D.extrn "_caml_call_gc" PROC; + D.extrn "_caml_c_call" PROC; + D.extrn "_caml_allocN" PROC; + D.extrn "_caml_alloc1" PROC; + D.extrn "_caml_alloc2" PROC; + D.extrn "_caml_alloc3" PROC; + D.extrn "_caml_ml_array_bound_error" PROC; + D.extrn "_caml_raise_exn" PROC; + end; + + D.data (); + emit_global_label "data_begin"; + + D.text (); + emit_global_label "code_begin"; + if system = S_macosx then I.nop (); (* PR#4690 *) + () let end_assembly() = if !float_constants <> [] then begin - ` .data\n`; - List.iter emit_float_constant !float_constants + D.data (); + List.iter (fun (cst,lbl) -> emit_float_constant cst lbl) !float_constants end; - let lbl_end = Compilenv.make_symbol (Some "code_end") in - ` .text\n`; - if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *) - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .data\n`; - let lbl_end = Compilenv.make_symbol (Some "data_end") in - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .long 0\n`; - let lbl = Compilenv.make_symbol (Some "frametable") in - ` .globl {emit_symbol lbl}\n`; - `{emit_symbol lbl}:\n`; + + D.text (); + if system = S_macosx then I.nop (); + (* suppress "ld warning: atom sorting error" *) + + emit_global_label "code_end"; + + D.data (); + emit_global_label "data_end"; + D.long (const 0); + + emit_global_label "frametable"; + emit_frames - { efa_label = (fun l -> ` .long {emit_label l}\n`); - efa_16 = (fun n -> ` {emit_string word_dir} {emit_int n}\n`); - efa_32 = (fun n -> ` .long {emit_int32 n}\n`); - efa_word = (fun n -> ` .long {emit_int n}\n`); - efa_align = emit_align; + { efa_code_label = (fun l -> D.long (ConstLabel (emit_label l))); + efa_data_label = (fun l -> D.long (ConstLabel (emit_label l))); + efa_16 = (fun n -> D.word (const n)); + efa_32 = (fun n -> D.long (const_32 n)); + efa_word = (fun n -> D.long (const n)); + efa_align = D.align; efa_label_rel = (fun lbl ofs -> - ` .long {emit_label lbl} - . + {emit_int32 ofs}\n`); - efa_def_label = (fun l -> `{emit_label l}:\n`); - efa_string = (fun s -> - let s = s ^ "\000" in - if use_ascii_dir - then emit_string_directive " .ascii " s - else emit_bytes_directive " .byte " s) }; - if macosx then emit_external_symbols (); - if Config.system = "linux_elf" then + D.long (ConstAdd ( + ConstSub(ConstLabel(emit_label lbl), + ConstThis), + const_32 ofs))); + efa_def_label = (fun l -> _label (emit_label l)); + efa_string = (fun s -> D.bytes (s ^ "\000")) + }; + + if system = S_macosx then emit_external_symbols (); + if system = S_linux_elf then (* Mark stack as non-executable, PR#4564 *) - `\n .section .note.GNU-stack,\"\",%progbits\n` + D.section [".note.GNU-stack"] (Some "") ["%progbits"]; + + if system = S_win32 then begin + D.comment "External functions"; + StringSet.iter + (fun s -> + if not (StringSet.mem s !symbols_defined) then + D.extrn (emit_symbol s) PROC) + !symbols_used; + symbols_used := StringSet.empty; + symbols_defined := StringSet.empty; + end; + + let asm = + if !Emitaux.create_asm_file then + Some + ( + (if X86_proc.masm then X86_masm.generate_asm + else X86_gas.generate_asm) !Emitaux.output_channel + ) + else + None + in + X86_proc.generate_code asm diff -Nru ocaml-4.01.0/asmcomp/i386/emit_nt.mlp ocaml-4.05.0/asmcomp/i386/emit_nt.mlp --- ocaml-4.01.0/asmcomp/i386/emit_nt.mlp 2013-03-19 07:22:12.000000000 +0000 +++ ocaml-4.05.0/asmcomp/i386/emit_nt.mlp 1970-01-01 00:00:00.000000000 +0000 @@ -1,913 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* Emission of Intel 386 assembly code, MASM syntax. *) - -module StringSet = - Set.Make(struct type t = string let compare (x:t) y = compare x y end) - -open Misc -open Cmm -open Arch -open Proc -open Reg -open Mach -open Linearize -open Emitaux - -(* Tradeoff between code size and code speed *) - -let fastcode_flag = ref true - -(* Layout of the stack frame *) - -let stack_offset = ref 0 - -let frame_size () = (* includes return address *) - !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4 - -let slot_offset loc cl = - match loc with - Incoming n -> - assert (n >= 0); - frame_size() + n - | Local n -> - if cl = 0 - then !stack_offset + n * 4 - else !stack_offset + num_stack_slots.(0) * 4 + n * 8 - | Outgoing n -> - assert (n >= 0); - n -(* Record symbols used and defined - at the end generate extern for those - used but not defined *) - -let symbols_defined = ref StringSet.empty -let symbols_used = ref StringSet.empty - -let add_def_symbol s = - symbols_defined := StringSet.add s !symbols_defined - -let add_used_symbol s = - symbols_used := StringSet.add s !symbols_used - -let emit_symbol s = - emit_string "_"; Emitaux.emit_symbol '$' s - -let emit_int32 n = emit_printf "0%lxh" n - -(* Output a label *) - -let emit_label lbl = - emit_string "L"; emit_int lbl - -let emit_data_label lbl = - emit_string "Ld"; emit_int lbl - -(* Output an align directive. *) - -let emit_align n = ` ALIGN {emit_int n}\n` - -(* Output a pseudo-register *) - -let emit_reg = function - { loc = Reg r } -> - emit_string (register_name r) - | { loc = Stack(Incoming n | Outgoing n) } when n < 0 -> - `{emit_symbol "caml_extra_params"} + {emit_int (n + 64)}` - | { loc = Stack s; typ = Float } as r -> - let ofs = slot_offset s (register_class r) in - `REAL8 PTR {emit_int ofs}[esp]` - | { loc = Stack s } as r -> - let ofs = slot_offset s (register_class r) in - `DWORD PTR {emit_int ofs}[esp]` - | { loc = Unknown } -> - fatal_error "Emit.emit_reg" - -(* Output a reference to the lower 8 bits or lower 16 bits of a register *) - -let reg_low_byte_name = [| "al"; "bl"; "cl"; "dl" |] -let reg_low_half_name = [| "ax"; "bx"; "cx"; "dx"; "si"; "di"; "bp" |] - -let emit_reg8 r = - match r.loc with - Reg r when r < 4 -> emit_string (reg_low_byte_name.(r)) - | _ -> fatal_error "Emit.emit_reg8" - -let emit_reg16 r = - match r.loc with - Reg r when r < 7 -> emit_string (reg_low_half_name.(r)) - | _ -> fatal_error "Emit.emit_reg16" - -(* Check if the given register overlaps (same location) with the given - array of registers *) - -let register_overlap reg arr = - try - for i = 0 to Array.length arr - 1 do - if reg.loc = arr.(i).loc then raise Exit - done; - false - with Exit -> - true - -(* Output an addressing mode *) - -let emit_signed_int d = - if d > 0 then emit_char '+'; - if d <> 0 then emit_int d - -let emit_addressing addr r n = - match addr with - Ibased(s, d) -> - add_used_symbol s; - `{emit_symbol s}{emit_signed_int d}` - | Iindexed d -> - `[{emit_reg r.(n)}{emit_signed_int d}]` - | Iindexed2 d -> - `[{emit_reg r.(n)}+{emit_reg r.(n+1)}{emit_signed_int d}]` - | Iscaled(2, d) -> - `[{emit_reg r.(n)}+{emit_reg r.(n)}{emit_signed_int d}]` - | Iscaled(scale, d) -> - `[{emit_reg r.(n)}*{emit_int scale}{emit_signed_int d}]` - | Iindexed2scaled(scale, d) -> - `[{emit_reg r.(n)}+{emit_reg r.(n+1)}*{emit_int scale}{emit_signed_int d}]` - -(* Record live pointers at call points *) - -let record_frame_label live dbg = - let lbl = new_label() in - let live_offset = ref [] in - Reg.Set.iter - (function - {typ = Addr; loc = Reg r} -> - live_offset := ((r lsl 1) + 1) :: !live_offset - | {typ = Addr; loc = Stack s} as reg -> - live_offset := slot_offset s (register_class reg) :: !live_offset - | _ -> ()) - live; - frame_descriptors := - { fd_lbl = lbl; - fd_frame_size = frame_size(); - fd_live_offset = !live_offset; - fd_debuginfo = dbg } :: !frame_descriptors; - lbl - -let record_frame live dbg = - let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` - -(* Record calls to the GC -- we've moved them out of the way *) - -type gc_call = - { gc_lbl: label; (* Entry label *) - gc_return_lbl: label; (* Where to branch after GC *) - gc_frame: label } (* Label of frame descriptor *) - -let call_gc_sites = ref ([] : gc_call list) - -let emit_call_gc gc = - `{emit_label gc.gc_lbl}: call _caml_call_gc\n`; - `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` - -(* Record calls to caml_ml_array_bound_error. - In -g mode, we maintain one call to caml_ml_array_bound_error - per bound check site. Without -g, we can share a single call. *) - -type bound_error_call = - { bd_lbl: label; (* Entry label *) - bd_frame: label } (* Label of frame descriptor *) - -let bound_error_sites = ref ([] : bound_error_call list) -let bound_error_call = ref 0 - -let bound_error_label dbg = - if !Clflags.debug then begin - let lbl_bound_error = new_label() in - let lbl_frame = record_frame_label Reg.Set.empty dbg in - bound_error_sites := - { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; - lbl_bound_error - end else begin - if !bound_error_call = 0 then bound_error_call := new_label(); - !bound_error_call - end - -let emit_call_bound_error bd = - `{emit_label bd.bd_lbl}: call _caml_ml_array_bound_error\n`; - `{emit_label bd.bd_frame}:\n` - -let emit_call_bound_errors () = - List.iter emit_call_bound_error !bound_error_sites; - if !bound_error_call > 0 then - `{emit_label !bound_error_call}: call _caml_ml_array_bound_error\n` - -(* Names for instructions *) - -let instr_for_intop = function - Iadd -> "add" - | Isub -> "sub" - | Imul -> "imul" - | Iand -> "and" - | Ior -> "or" - | Ixor -> "xor" - | Ilsl -> "sal" - | Ilsr -> "shr" - | Iasr -> "sar" - | _ -> fatal_error "Emit: instr_for_intop" - -let instr_for_floatop = function - Inegf -> "fchs" - | Iabsf -> "fabs" - | Iaddf -> "fadd" - | Isubf -> "fsub" - | Imulf -> "fmul" - | Idivf -> "fdiv" - | Ispecific Isubfrev -> "fsubr" - | Ispecific Idivfrev -> "fdivr" - | _ -> fatal_error "Emit: instr_for_floatop" - -let instr_for_floatop_reversed = function - Iaddf -> "fadd" - | Isubf -> "fsubr" - | Imulf -> "fmul" - | Idivf -> "fdivr" - | Ispecific Isubfrev -> "fsub" - | Ispecific Idivfrev -> "fdiv" - | _ -> fatal_error "Emit: instr_for_floatop_reversed" - -let instr_for_floatarithmem = function - Ifloatadd -> "fadd" - | Ifloatsub -> "fsub" - | Ifloatsubrev -> "fsubr" - | Ifloatmul -> "fmul" - | Ifloatdiv -> "fdiv" - | Ifloatdivrev -> "fdivr" - -let name_for_cond_branch = function - Isigned Ceq -> "e" | Isigned Cne -> "ne" - | Isigned Cle -> "le" | Isigned Cgt -> "g" - | Isigned Clt -> "l" | Isigned Cge -> "ge" - | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" - | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" - | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" - -(* Output an = 0 or <> 0 test. *) - -let output_test_zero arg = - match arg.loc with - Reg r -> ` test {emit_reg arg}, {emit_reg arg}\n` - | _ -> ` cmp {emit_reg arg}, 0\n` - -(* Deallocate the stack frame before a return or tail call *) - -let output_epilogue () = - let n = frame_size() - 4 in - if n > 0 then ` add esp, {emit_int n}\n` - -(* Determine if the given register is the top of the floating-point stack *) - -let is_tos = function { loc = Reg _; typ = Float } -> true | _ -> false - -(* Emit the code for a floating-point comparison *) - -let emit_float_test cmp neg arg lbl = - let actual_cmp = - match (is_tos arg.(0), is_tos arg.(1)) with - (true, true) -> - (* both args on top of FP stack *) - ` fcompp\n`; - cmp - | (true, false) -> - (* first arg on top of FP stack *) - ` fcomp {emit_reg arg.(1)}\n`; - cmp - | (false, true) -> - (* second arg on top of FP stack *) - ` fcomp {emit_reg arg.(0)}\n`; - Cmm.swap_comparison cmp - | (false, false) -> - ` fld {emit_reg arg.(0)}\n`; - ` fcomp {emit_reg arg.(1)}\n`; - cmp - in - ` fnstsw ax\n`; - begin match actual_cmp with - Ceq -> - if neg then begin - ` and ah, 68\n`; - ` xor ah, 64\n`; - ` jne ` - end else begin - ` and ah, 69\n`; - ` cmp ah, 64\n`; - ` je ` - end - | Cne -> - if neg then begin - ` and ah, 69\n`; - ` cmp ah, 64\n`; - ` je ` - end else begin - ` and ah, 68\n`; - ` xor ah, 64\n`; - ` jne ` - end - | Cle -> - ` and ah, 69\n`; - ` dec ah\n`; - ` cmp ah, 64\n`; - if neg - then ` jae ` - else ` jb ` - | Cge -> - ` and ah, 5\n`; - if neg - then ` jne ` - else ` je ` - | Clt -> - ` and ah, 69\n`; - ` cmp ah, 1\n`; - if neg - then ` jne ` - else ` je ` - | Cgt -> - ` and ah, 69\n`; - if neg - then ` jne ` - else ` je ` - end; - `{emit_label lbl}\n` - -(* Emit a Ifloatspecial instruction *) - -let emit_floatspecial = function - "atan" -> ` fld1\n\tfpatan\n` - | "atan2" -> ` fpatan\n` - | "cos" -> ` fcos\n` - | "log" -> ` fldln2\n\tfxch\n\tfyl2x\n` - | "log10" -> ` fldlg2\n\tfxch\n\tfyl2x\n` - | "sin" -> ` fsin\n` - | "sqrt" -> ` fsqrt\n` - | "tan" -> ` fptan\n\tfstp st(0)\n` - | _ -> assert false - -(* Floating-point constants *) - -let float_constants = ref ([] : (string * int) list) - -let add_float_constant cst = - try - List.assoc cst !float_constants - with - Not_found -> - let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; - lbl - -let emit_float s = - (* MASM doesn't like floating-point constants such as 2e9. - Turn them into 2.0e9. *) - let pos_e = ref (-1) and pos_dot = ref (-1) in - for i = 0 to String.length s - 1 do - match s.[i] with - 'e'|'E' -> pos_e := i - | '.' -> pos_dot := i - | _ -> () - done; - if !pos_dot < 0 && !pos_e >= 0 then begin - emit_string (String.sub s 0 !pos_e); - emit_string ".0"; - emit_string (String.sub s !pos_e (String.length s - !pos_e)) - end else - emit_string s - -let emit_float_constant (cst, lbl) = - `{emit_label lbl} REAL8 {emit_float cst}\n` - -(* Output the assembly code for an instruction *) - -(* Name of current function *) -let function_name = ref "" -(* Entry point for tail recursive calls *) -let tailrec_entry_point = ref 0 -(* Label of trap for out-of-range accesses *) -let range_check_trap = ref 0 - -let emit_instr i = - match i.desc with - Lend -> () - | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin - if src.typ = Float then - if is_tos src then - ` fstp {emit_reg dst}\n` - else if is_tos dst then - ` fld {emit_reg src}\n` - else begin - ` fld {emit_reg src}\n`; - ` fstp {emit_reg dst}\n` - end - else - ` mov {emit_reg dst}, {emit_reg src}\n` - end - | Lop(Iconst_int n) -> - if n = 0n then begin - match i.res.(0).loc with - Reg n -> ` xor {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | _ -> ` mov {emit_reg i.res.(0)}, 0\n` - end else - ` mov {emit_reg i.res.(0)}, {emit_nativeint n}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with - | 0x0000_0000_0000_0000L -> (* +0.0 *) - ` fldz\n` - | 0x8000_0000_0000_0000L -> (* -0.0 *) - ` fldz\n fchs\n` - | 0x3FF0_0000_0000_0000L -> (* 1.0 *) - ` fld1\n` - | 0xBFF0_0000_0000_0000L -> (* -1.0 *) - ` fld1\n fchs\n` - | _ -> - let lbl = add_float_constant s in - ` fld {emit_label lbl}\n` - end - | Lop(Iconst_symbol s) -> - add_used_symbol s; - ` mov {emit_reg i.res.(0)}, OFFSET {emit_symbol s}\n` - | Lop(Icall_ind) -> - ` call {emit_reg i.arg.(0)}\n`; - record_frame i.live i.dbg - | Lop(Icall_imm s) -> - add_used_symbol s; - ` call {emit_symbol s}\n`; - record_frame i.live i.dbg - | Lop(Itailcall_ind) -> - output_epilogue(); - ` jmp {emit_reg i.arg.(0)}\n` - | Lop(Itailcall_imm s) -> - if s = !function_name then - ` jmp {emit_label !tailrec_entry_point}\n` - else begin - output_epilogue(); - add_used_symbol s; - ` jmp {emit_symbol s}\n` - end - | Lop(Iextcall(s, alloc)) -> - add_used_symbol s ; - if alloc then begin - ` mov eax, OFFSET {emit_symbol s}\n`; - ` call _caml_c_call\n`; - record_frame i.live i.dbg - end else begin - ` call {emit_symbol s}\n` - end - | Lop(Istackoffset n) -> - if n >= 0 - then ` sub esp, {emit_int n}\n` - else ` add esp, {emit_int(-n)}\n`; - stack_offset := !stack_offset + n - | Lop(Iload(chunk, addr)) -> - let dest = i.res.(0) in - begin match chunk with - | Word | Thirtytwo_signed | Thirtytwo_unsigned -> - ` mov {emit_reg dest}, DWORD PTR {emit_addressing addr i.arg 0}\n` - | Byte_unsigned -> - ` movzx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` - | Byte_signed -> - ` movsx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` - | Sixteen_unsigned -> - ` movzx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` - | Sixteen_signed -> - ` movsx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` - | Single -> - ` fld REAL4 PTR {emit_addressing addr i.arg 0}\n` - | Double | Double_u -> - ` fld REAL8 PTR {emit_addressing addr i.arg 0}\n` - end - | Lop(Istore(chunk, addr)) -> - begin match chunk with - | Word | Thirtytwo_signed | Thirtytwo_unsigned -> - ` mov DWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` - | Byte_unsigned | Byte_signed -> - ` mov BYTE PTR {emit_addressing addr i.arg 1}, {emit_reg8 i.arg.(0)}\n` - | Sixteen_unsigned | Sixteen_signed -> - ` mov WORD PTR {emit_addressing addr i.arg 1}, {emit_reg16 i.arg.(0)}\n` - | Single -> - if is_tos i.arg.(0) then - ` fstp REAL4 PTR {emit_addressing addr i.arg 1}\n` - else begin - ` fld {emit_reg i.arg.(0)}\n`; - ` fstp REAL4 PTR {emit_addressing addr i.arg 1}\n` - end - | Double | Double_u -> - if is_tos i.arg.(0) then - ` fstp REAL8 PTR {emit_addressing addr i.arg 1}\n` - else begin - ` fld {emit_reg i.arg.(0)}\n`; - ` fstp REAL8 PTR {emit_addressing addr i.arg 1}\n` - end - end - | Lop(Ialloc n) -> - if !fastcode_flag then begin - let lbl_redo = new_label() in - `{emit_label lbl_redo}: mov eax, _caml_young_ptr\n`; - ` sub eax, {emit_int n}\n`; - ` mov _caml_young_ptr, eax\n`; - ` cmp eax, _caml_young_limit\n`; - let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live Debuginfo.none in - ` jb {emit_label lbl_call_gc}\n`; - ` lea {emit_reg i.res.(0)}, [eax+4]\n`; - call_gc_sites := - { gc_lbl = lbl_call_gc; - gc_return_lbl = lbl_redo; - gc_frame = lbl_frame } :: !call_gc_sites - end else begin - begin match n with - 8 -> ` call _caml_alloc1\n` - | 12 -> ` call _caml_alloc2\n` - | 16 -> ` call _caml_alloc3\n` - | _ -> ` mov eax, {emit_int n}\n`; - ` call _caml_allocN\n` - end; - `{record_frame i.live Debuginfo.none} lea {emit_reg i.res.(0)}, [eax+4]\n` - end - | Lop(Iintop(Icomp cmp)) -> - ` cmp {emit_reg i.arg.(0)},{emit_reg i.arg.(1)}\n`; - let b = name_for_cond_branch cmp in - ` set{emit_string b} al\n`; - ` movzx {emit_reg i.res.(0)}, al\n` - | Lop(Iintop_imm(Icomp cmp, n)) -> - ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; - let b = name_for_cond_branch cmp in - ` set{emit_string b} al\n`; - ` movzx {emit_reg i.res.(0)}, al\n` - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in - ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - ` jbe {emit_label lbl}\n` - | Lop(Iintop_imm(Icheckbound, n)) -> - let lbl = bound_error_label i.dbg in - ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; - ` jbe {emit_label lbl}\n` - | Lop(Iintop(Idiv | Imod)) -> - ` cdq\n`; - ` idiv {emit_reg i.arg.(1)}\n` - | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> - (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) - ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, cl\n` - | Lop(Iintop op) -> - (* We have i.arg.(0) = i.res.(0) *) - ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` - | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> - ` lea {emit_reg i.res.(0)}, [{emit_reg i.arg.(0)}+{emit_int n}]\n` - | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> - ` inc {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> - ` dec {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - let l = Misc.log2 n in - let lbl = new_label() in - output_test_zero i.arg.(0); - ` jge {emit_label lbl}\n`; - ` add {emit_reg i.arg.(0)}, {emit_int(n-1)}\n`; - `{emit_label lbl}: sar {emit_reg i.arg.(0)}, {emit_int l}\n` - | Lop(Iintop_imm(Imod, n)) -> - let lbl = new_label() in - ` mov eax, {emit_reg i.arg.(0)}\n`; - ` test eax, eax\n`; - ` jge {emit_label lbl}\n`; - ` add eax, {emit_int(n-1)}\n`; - `{emit_label lbl}: and eax, {emit_int(-n)}\n`; - ` sub {emit_reg i.arg.(0)}, eax\n` - | Lop(Iintop_imm(op, n)) -> - (* We have i.arg.(0) = i.res.(0) *) - ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_int n}\n` - | Lop(Inegf | Iabsf as floatop) -> - if not (is_tos i.arg.(0)) then - ` fld {emit_reg i.arg.(0)}\n`; - ` {emit_string(instr_for_floatop floatop)}\n` - | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific(Isubfrev | Idivfrev) - as floatop) -> - begin match (is_tos i.arg.(0), is_tos i.arg.(1)) with - (true, true) -> - (* both operands on top of FP stack *) - ` {emit_string(instr_for_floatop_reversed floatop)}\n` - | (true, false) -> - (* first operand on stack *) - ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` - | (false, true) -> - (* second operand on stack *) - ` {emit_string(instr_for_floatop_reversed floatop)} {emit_reg i.arg.(0)}\n` - | (false, false) -> - (* both operands in memory *) - ` fld {emit_reg i.arg.(0)}\n`; - ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` - end - | Lop(Ifloatofint) -> - begin match i.arg.(0).loc with - Stack s -> - ` fild {emit_reg i.arg.(0)}\n` - | _ -> - ` push {emit_reg i.arg.(0)}\n`; - ` fild DWORD PTR [esp]\n`; - ` add esp, 4\n` - end - | Lop(Iintoffloat) -> - if not (is_tos i.arg.(0)) then - ` fld {emit_reg i.arg.(0)}\n`; - stack_offset := !stack_offset - 8; - ` sub esp, 8\n`; - ` fnstcw [esp+4]\n`; - ` mov ax, [esp+4]\n`; - ` mov ah, 12\n`; - ` mov [esp], ax\n`; - ` fldcw [esp]\n`; - begin match i.res.(0).loc with - Stack s -> - ` fistp {emit_reg i.res.(0)}\n` - | _ -> - ` fistp DWORD PTR [esp]\n`; - ` mov {emit_reg i.res.(0)}, [esp]\n` - end; - ` fldcw [esp+4]\n`; - ` add esp, 8\n`; - stack_offset := !stack_offset + 8 - | Lop(Ispecific(Ilea addr)) -> - ` lea {emit_reg i.res.(0)}, DWORD PTR {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> - ` mov DWORD PTR {emit_addressing addr i.arg 0},{emit_nativeint n}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> - add_used_symbol s ; - ` mov DWORD PTR {emit_addressing addr i.arg 0},OFFSET {emit_symbol s}\n` - | Lop(Ispecific(Ioffset_loc(n, addr))) -> - ` add DWORD PTR {emit_addressing addr i.arg 0},{emit_int n}\n` - | Lop(Ispecific(Ipush)) -> - (* Push arguments in reverse order *) - for n = Array.length i.arg - 1 downto 0 do - let r = i.arg.(n) in - match r with - {loc = Reg rn; typ = Float} -> - ` sub esp, 8\n`; - ` fstp REAL8 PTR 0[esp]\n`; - stack_offset := !stack_offset + 8 - | {loc = Stack sl; typ = Float} -> - let ofs = slot_offset sl 1 in - ` push DWORD PTR {emit_int (ofs + 4)}[esp]\n`; - ` push DWORD PTR {emit_int (ofs + 4)}[esp]\n`; - stack_offset := !stack_offset + 8 - | _ -> - ` push {emit_reg r}\n`; - stack_offset := !stack_offset + 4 - done - | Lop(Ispecific(Ipush_int n)) -> - ` push {emit_nativeint n}\n`; - stack_offset := !stack_offset + 4 - | Lop(Ispecific(Ipush_symbol s)) -> - add_used_symbol s; - ` push OFFSET {emit_symbol s}\n`; - stack_offset := !stack_offset + 4 - | Lop(Ispecific(Ipush_load addr)) -> - ` push DWORD PTR {emit_addressing addr i.arg 0}\n`; - stack_offset := !stack_offset + 4 - | Lop(Ispecific(Ipush_load_float addr)) -> - ` push DWORD PTR {emit_addressing (offset_addressing addr 4) i.arg 0}\n`; - ` push DWORD PTR {emit_addressing addr i.arg 0}\n`; - stack_offset := !stack_offset + 8 - | Lop(Ispecific(Ifloatarithmem(double, op, addr))) -> - if not (is_tos i.arg.(0)) then - ` fld {emit_reg i.arg.(0)}\n`; - let size = if double then "REAL8" else "REAL4" in - ` {emit_string(instr_for_floatarithmem op)} {emit_string size} PTR {emit_addressing addr i.arg 1}\n` - | Lop(Ispecific(Ifloatspecial s)) -> - (* Push args on float stack if necessary *) - for k = 0 to Array.length i.arg - 1 do - if not (is_tos i.arg.(k)) then ` fld {emit_reg i.arg.(k)}\n` - done; - (* Fix-up for binary instrs whose args were swapped *) - if Array.length i.arg = 2 && is_tos i.arg.(1) then - ` fxch st(1)\n`; - emit_floatspecial s - | Lreloadretaddr -> - () - | Lreturn -> - output_epilogue(); - ` ret\n` - | Llabel lbl -> - `{emit_label lbl}:\n` - | Lbranch lbl -> - ` jmp {emit_label lbl}\n` - | Lcondbranch(tst, lbl) -> - begin match tst with - Itruetest -> - output_test_zero i.arg.(0); - ` jne {emit_label lbl}\n` - | Ifalsetest -> - output_test_zero i.arg.(0); - ` je {emit_label lbl}\n` - | Iinttest cmp -> - ` cmp {emit_reg i.arg.(0)},{emit_reg i.arg.(1)}\n`; - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | - Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> - output_test_zero i.arg.(0); - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm(cmp, n) -> - ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Ifloattest(cmp, neg) -> - emit_float_test cmp neg i.arg lbl - | Ioddtest -> - ` test {emit_reg i.arg.(0)}, 1\n`; - ` jne {emit_label lbl}\n` - | Ieventest -> - ` test {emit_reg i.arg.(0)}, 1\n`; - ` je {emit_label lbl}\n` - end - | Lcondbranch3(lbl0, lbl1, lbl2) -> - ` cmp {emit_reg i.arg.(0)}, 1\n`; - begin match lbl0 with - None -> () - | Some lbl -> ` jb {emit_label lbl}\n` - end; - begin match lbl1 with - None -> () - | Some lbl -> ` je {emit_label lbl}\n` - end; - begin match lbl2 with - None -> () - | Some lbl -> ` jg {emit_label lbl}\n` - end - | Lswitch jumptbl -> - let lbl = new_label() in - ` jmp [{emit_reg i.arg.(0)} * 4 + {emit_label lbl}]\n`; - ` .DATA\n`; - `{emit_label lbl}`; - for i = 0 to Array.length jumptbl - 1 do - ` DWORD {emit_label jumptbl.(i)}\n` - done; - ` .CODE\n` - | Lsetuptrap lbl -> - ` call {emit_label lbl}\n` - | Lpushtrap -> - ` push _caml_exception_pointer\n`; - ` mov _caml_exception_pointer, esp\n`; - stack_offset := !stack_offset + 8 - | Lpoptrap -> - ` pop _caml_exception_pointer\n`; - ` add esp, 4\n`; - stack_offset := !stack_offset - 8 - | Lraise -> - if !Clflags.debug then begin - ` call _caml_raise_exn\n`; - record_frame Reg.Set.empty i.dbg - end else begin - ` mov esp, _caml_exception_pointer\n`; - ` pop _caml_exception_pointer\n`; - ` ret\n` - end - -let rec emit_all i = - match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next - -(* Emission of a function declaration *) - -let fundecl fundecl = - function_name := fundecl.fun_name; - fastcode_flag := fundecl.fun_fast; - tailrec_entry_point := new_label(); - stack_offset := 0; - call_gc_sites := []; - bound_error_sites := []; - bound_error_call := 0; - ` .CODE\n`; - add_def_symbol fundecl.fun_name; - emit_align 4; - ` PUBLIC {emit_symbol fundecl.fun_name}\n`; - `{emit_symbol fundecl.fun_name}:\n`; - let n = frame_size() - 4 in - if n > 0 then - ` sub esp, {emit_int n}\n`; - `{emit_label !tailrec_entry_point}:\n`; - emit_all fundecl.fun_body; - List.iter emit_call_gc !call_gc_sites; - emit_call_bound_errors () - -(* Emission of data *) - -let emit_item = function - Cglobal_symbol s -> - ` PUBLIC {emit_symbol s}\n`; - | Cdefine_symbol s -> - add_def_symbol s ; - `{emit_symbol s} LABEL DWORD\n` - | Cdefine_label lbl -> - `{emit_data_label lbl} LABEL DWORD\n` - | Cint8 n -> - ` BYTE {emit_int n}\n` - | Cint16 n -> - ` WORD {emit_int n}\n` - | Cint n -> - ` DWORD {emit_nativeint n}\n` - | Cint32 n -> - ` DWORD {emit_nativeint n}\n` - | Csingle f -> - ` REAL4 {emit_float f}\n` - | Cdouble f -> - ` REAL8 {emit_float f}\n` - | Csymbol_address s -> - add_used_symbol s ; - ` DWORD {emit_symbol s}\n` - | Clabel_address lbl -> - ` DWORD {emit_data_label lbl}\n` - | Cstring s -> - emit_bytes_directive " BYTE " s - | Cskip n -> - if n > 0 then ` BYTE {emit_int n} DUP (?)\n` - | Calign n -> - emit_align n - -let data l = - ` .DATA\n`; - List.iter emit_item l - -(* Beginning / end of an assembly file *) - -let begin_assembly() = - float_constants := []; - `.386\n`; - ` .MODEL FLAT\n\n`; - ` EXTERN _caml_young_ptr: DWORD\n`; - ` EXTERN _caml_young_limit: DWORD\n`; - ` EXTERN _caml_exception_pointer: DWORD\n`; - ` EXTERN _caml_extra_params: DWORD\n`; - ` EXTERN _caml_call_gc: PROC\n`; - ` EXTERN _caml_c_call: PROC\n`; - ` EXTERN _caml_allocN: PROC\n`; - ` EXTERN _caml_alloc1: PROC\n`; - ` EXTERN _caml_alloc2: PROC\n`; - ` EXTERN _caml_alloc3: PROC\n`; - ` EXTERN _caml_ml_array_bound_error: PROC\n`; - ` EXTERN _caml_raise_exn: PROC\n`; - ` .DATA\n`; - let lbl_begin = Compilenv.make_symbol (Some "data_begin") in - add_def_symbol lbl_begin; - ` PUBLIC {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin} LABEL DWORD\n`; - ` .CODE\n`; - let lbl_begin = Compilenv.make_symbol (Some "code_begin") in - add_def_symbol lbl_begin; - ` PUBLIC {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin} LABEL DWORD\n` - -let end_assembly() = - if !float_constants <> [] then begin - ` .DATA\n`; - List.iter emit_float_constant !float_constants; - end; - ` .CODE\n`; - let lbl_end = Compilenv.make_symbol (Some "code_end") in - add_def_symbol lbl_end; - ` PUBLIC {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end} LABEL DWORD\n`; - ` .DATA\n`; - let lbl_end = Compilenv.make_symbol (Some "data_end") in - add_def_symbol lbl_end; - ` PUBLIC {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end} LABEL DWORD\n`; - ` DWORD 0\n`; - let lbl = Compilenv.make_symbol (Some "frametable") in - add_def_symbol lbl; - ` PUBLIC {emit_symbol lbl}\n`; - `{emit_symbol lbl}`; - emit_frames - { efa_label = (fun l -> ` DWORD {emit_label l}\n`); - efa_16 = (fun n -> ` WORD {emit_int n}\n`); - efa_32 = (fun n -> ` DWORD {emit_int32 n}\n`); - efa_word = (fun n -> ` DWORD {emit_int n}\n`); - efa_align = emit_align; - efa_label_rel = (fun lbl ofs -> - ` DWORD {emit_label lbl} - THIS BYTE + {emit_int32 ofs}\n`); - efa_def_label = (fun l -> `{emit_label l} LABEL DWORD\n`); - efa_string = (fun s -> emit_bytes_directive " BYTE " (s ^ "\000")) }; - `\n;External functions\n\n`; - StringSet.iter - (fun s -> - if not (StringSet.mem s !symbols_defined) then - ` EXTERN {emit_symbol s}: PROC\n`) - !symbols_used; - symbols_used := StringSet.empty; - symbols_defined := StringSet.empty; - `END\n` diff -Nru ocaml-4.01.0/asmcomp/i386/NOTES.md ocaml-4.05.0/asmcomp/i386/NOTES.md --- ocaml-4.01.0/asmcomp/i386/NOTES.md 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/i386/NOTES.md 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,22 @@ +# Supported platforms + +Intel and AMD x86 processors in 32-bit mode. +The baseline is the 80486, also known as `i486`. +(Debian's baseline is now the Pentium 1.) + +Floating-point architecture: x87. +(SSE2 not available in Debian's baseline.) + +Operating systems: Linux, BSD, MacOS X, MS Windows. + +Debian architecture name: `i386` + +# Reference documents + +* Instruction set architecture: + any Intel or AMD manual of the last 20 years. +* ELF application binary interface: + _System V Application Binary Interface, + Intel386 Architecture Processor Supplement_ +* MacOS X application binary interface: + _OS X ABI Function Call Guide: IA-32 Function Calling Conventions_ diff -Nru ocaml-4.01.0/asmcomp/i386/proc.ml ocaml-4.05.0/asmcomp/i386/proc.ml --- ocaml-4.01.0/asmcomp/i386/proc.ml 2013-07-23 14:48:47.000000000 +0000 +++ ocaml-4.05.0/asmcomp/i386/proc.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,18 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +# 2 "asmcomp/i386/proc.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Description of the Intel 386 processor *) @@ -53,8 +57,7 @@ let register_class r = match r.typ with - Int -> 0 - | Addr -> 0 + | Val | Int | Addr -> 0 | Float -> 1 let num_available_registers = [| 7; 0 |] @@ -72,7 +75,7 @@ (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 7 Reg.dummy in + let v = Array.make 7 Reg.dummy in for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done; v @@ -87,11 +90,12 @@ let eax = phys_reg 0 let ecx = phys_reg 2 let edx = phys_reg 3 -let tos = phys_reg 100 let stack_slot slot ty = Reg.at_location ty (Stack slot) +let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *) + (* Instruction selection *) let word_addressed = false @@ -111,13 +115,13 @@ let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref (-64) in for i = 0 to Array.length arg - 1 do match arg.(i).typ with - Int | Addr as ty -> + Val | Int | Addr as ty -> if !int <= last_int then begin loc.(i) <- phys_reg !int; incr int @@ -138,33 +142,53 @@ let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" + +(* Six arguments in integer registers plus eight in global memory. *) +let max_arguments_for_tailcalls = 14 let loc_arguments arg = calling_conventions 0 5 100 99 outgoing arg let loc_parameters arg = - let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc + let (loc, _ofs) = calling_conventions 0 5 100 99 incoming arg in loc let loc_results res = - let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc -let extcall_use_push = true -let loc_external_arguments arg = + let (loc, _ofs) = calling_conventions 0 5 100 100 not_supported res in loc +let loc_external_arguments _arg = fatal_error "Proc.loc_external_arguments" let loc_external_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + match res with + | [|{typ=Int};{typ=Int}|] -> [|eax; edx|] + | _ -> + let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc let loc_exn_bucket = eax +(* Volatile registers: the x87 top of FP stack is *) + +let reg_is_volatile = function + | { typ = Float; loc = Reg _ } -> true + | _ -> false + +let regs_are_volatile rs = + try + for i = 0 to Array.length rs - 1 do + if reg_is_volatile rs.(i) then raise Exit + done; + false + with Exit -> + true + (* Registers destroyed by operations *) let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *) [|eax; ecx; edx|] let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call + Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _}) -> + all_phys_regs + | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call | Iop(Iintop(Idiv | Imod)) -> [| eax; edx |] - | Iop(Iintop_imm(Imod, _)) -> [| eax |] - | Iop(Ialloc _) -> [| eax |] + | Iop(Ialloc _ | Iintop Imulh) -> [| eax |] | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |] | Iop(Iintoffloat) -> [| eax |] | Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |] @@ -174,15 +198,26 @@ (* Maximal register pressure *) -let safe_register_pressure op = 4 +let safe_register_pressure _op = 4 let max_register_pressure = function - Iextcall(_, _) -> [| 4; max_int |] + Iextcall _ -> [| 4; max_int |] | Iintop(Idiv | Imod) -> [| 5; max_int |] | Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) | Iintoffloat -> [| 6; max_int |] | _ -> [|7; max_int |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false + | Ispecific(Ilea _) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack frame *) let num_stack_slots = [| 0; 0 |] @@ -191,12 +226,6 @@ (* Calling the assembler *) let assemble_file infile outfile = - if masm then - Ccomp.command (Config.asm ^ - Filename.quote outfile ^ " " ^ Filename.quote infile ^ - (if !Clflags.verbose then "" else ">NUL")) - else - Ccomp.command (Config.asm ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) + X86_proc.assemble_file infile outfile let init () = () diff -Nru ocaml-4.01.0/asmcomp/i386/reload.ml ocaml-4.05.0/asmcomp/i386/reload.ml --- ocaml-4.01.0/asmcomp/i386/reload.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/i386/reload.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Cmm open Arch @@ -37,7 +40,7 @@ method! reload_operation op arg res = match op with - Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) -> + Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound _) -> (* One of the two arguments can reside in the stack *) if stackp arg.(0) && stackp arg.(1) then ([|arg.(0); self#makereg arg.(1)|], res) @@ -57,16 +60,18 @@ if stackp arg.(0) then let r = self#makereg arg.(0) in ([|r|], [|r|]) else (arg, res) - | Iintop(Ilsl|Ilsr|Iasr) | Iintop_imm(_, _) | Ifloatofint | Iintoffloat | - Ispecific(Ipush) -> + | Iintop(Imulh | Ilsl | Ilsr | Iasr) | Iintop_imm(_, _) + | Ifloatofint | Iintoffloat | Ispecific(Ipush) -> (* The argument(s) can be either in register or on stack *) + (* Note: Imulh: arg(0 and res(0) already forced in regs + Ilsl, Ilsr, Iasr: arg(1) already forced in regs *) (arg, res) | _ -> (* Other operations: all args and results in registers *) super#reload_operation op arg res method! reload_test tst arg = match tst with - Iinttest cmp -> + Iinttest _ -> (* One of the two arguments can reside on stack *) if stackp arg.(0) && stackp arg.(1) then [| self#makereg arg.(0); arg.(1) |] diff -Nru ocaml-4.01.0/asmcomp/i386/scheduling.ml ocaml-4.05.0/asmcomp/i386/scheduling.ml --- ocaml-4.01.0/asmcomp/i386/scheduling.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/i386/scheduling.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) let () = let module M = Schedgen in () (* to create a dependency *) diff -Nru ocaml-4.01.0/asmcomp/i386/selection.ml ocaml-4.05.0/asmcomp/i386/selection.ml --- ocaml-4.01.0/asmcomp/i386/selection.ml 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/asmcomp/i386/selection.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Instruction selection for the Intel x86 *) @@ -31,28 +34,28 @@ match exp with Cconst_symbol s -> (Asymbol s, 0) - | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> + | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], _) -> let (a, n) = select_addr arg in (a, n + m) - | Cop((Csubi | Csuba), [arg; Cconst_int m]) -> + | Cop(Csubi, [arg; Cconst_int m], _) -> let (a, n) = select_addr arg in (a, n - m) - | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> + | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], _) -> let (a, n) = select_addr arg in (a, n + m) - | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) -> + | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)], _) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift) | _ -> (Alinear exp, 0) end - | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) -> + | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)], _) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) end - | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) -> + | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg], _) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) end - | Cop((Caddi | Cadda), [arg1; arg2]) -> + | Cop((Caddi | Cadda | Caddv), [arg1; arg2], _) -> begin match (select_addr arg1, select_addr arg2) with ((Alinear e1, n1), (Alinear e2, n2)) -> (Aadd(e1, e2), n1 + n2) @@ -70,8 +73,9 @@ | arg -> (Alinear arg, 0) -(* C functions to be turned into Ifloatspecial instructions if -ffast-math *) - +(* C functions to be turned into Ifloatspecial instructions if -ffast-math. + If you update this list, you may need to update [is_simple_expr] and/or + [effects_of], below. *) let inline_float_ops = ["atan"; "atan2"; "cos"; "log"; "log10"; "sin"; "sqrt"; "tan"] @@ -79,13 +83,13 @@ (Ershov's algorithm) *) let rec float_needs = function - Cop((Cnegf | Cabsf), [arg]) -> + Cop((Cnegf | Cabsf), [arg], _) -> float_needs arg - | Cop((Caddf | Csubf | Cmulf | Cdivf), [arg1; arg2]) -> + | Cop((Caddf | Csubf | Cmulf | Cdivf), [arg1; arg2], _) -> let n1 = float_needs arg1 in let n2 = float_needs arg2 in if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2 - | Cop(Cextcall(fn, ty_res, alloc, dbg), args) + | Cop(Cextcall(fn, _ty_res, _alloc, _label), args, _dbg) when !fast_math && List.mem fn inline_float_ops -> begin match args with [arg] -> float_needs arg @@ -110,8 +114,12 @@ Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) -> ([|res.(0); arg.(1)|], res, false) (* Two-address unary operations *) - | Iintop_imm((Iadd|Isub|Imul|Idiv|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) -> + | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) -> (res, res, false) + (* For imull, first arg must be in eax, eax is clobbered, and result is in + edx. *) + | Iintop(Imulh) -> + ([| eax; arg.(1) |], [| edx |], true) (* For shifts with variable shift count, second arg must be in ecx *) | Iintop(Ilsl|Ilsr|Iasr) -> ([|res.(0); ecx|], res, false) @@ -122,10 +130,6 @@ ([| eax; ecx |], [| eax |], true) | Iintop(Imod) -> ([| eax; ecx |], [| edx |], true) - (* For mod with immediate operand, arg must not be in eax. - Keep it simple, force it in edx. *) - | Iintop_imm(Imod, _) -> - ([| edx |], [| edx |], true) (* For floating-point operations and floating-point loads, the result is always left at the top of the floating-point stack *) | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf @@ -135,7 +139,7 @@ (* For storing a byte, the argument must be in eax...edx. (But for a short, any reg will do!) Keep it simple, just force the argument to be in edx. *) - | Istore((Byte_unsigned | Byte_signed), addr) -> + | Istore((Byte_unsigned | Byte_signed), _, _) -> let newarg = Array.copy arg in newarg.(0) <- edx; (newarg, res, false) @@ -154,18 +158,26 @@ inherit Selectgen.selector_generic as super -method is_immediate (n : int) = true +method is_immediate (_n : int) = true method! is_simple_expr e = match e with - | Cop(Cextcall(fn, _, alloc, _), args) + | Cop(Cextcall(fn, _, _alloc, _), args, _) when !fast_math && List.mem fn inline_float_ops -> (* inlined float ops are simple if their arguments are *) List.for_all self#is_simple_expr args | _ -> super#is_simple_expr e -method select_addressing chunk exp = +method! effects_of e = + match e with + | Cop(Cextcall(fn, _, _, _), args, _) + when !fast_math && List.mem fn inline_float_ops -> + Selectgen.Effect_and_coeffect.join_list_map args self#effects_of + | _ -> + super#effects_of e + +method select_addressing _chunk exp = match select_addr exp with (Asymbol s, d) -> (Ibased(s, d), Ctuple []) @@ -178,43 +190,30 @@ | (Ascaledadd(e1, e2, scale), d) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) -method! select_store addr exp = +method! select_store is_assign addr exp = match exp with Cconst_int n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) - | Cconst_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) + | (Cconst_natint n | Cblockheader (n, _)) -> + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_pointer n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) | Cconst_natpointer n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_symbol s -> - (Ispecific(Istore_symbol(s, addr)), Ctuple []) + (Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple []) | _ -> - super#select_store addr exp + super#select_store is_assign addr exp -method! select_operation op args = +method! select_operation op args dbg = match op with (* Recognize the LEA instruction *) - Caddi | Cadda | Csubi | Csuba -> - begin match self#select_addressing Word (Cop(op, args)) with - (Iindexed d, _) -> super#select_operation op args - | (Iindexed2 0, _) -> super#select_operation op args + Caddi | Caddv | Cadda | Csubi -> + begin match self#select_addressing Word_int (Cop(op, args, dbg)) with + (Iindexed _, _) + | (Iindexed2 0, _) -> super#select_operation op args dbg | (addr, arg) -> (Ispecific(Ilea addr), [arg]) end - (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *) - | Cdivi -> - begin match args with - [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg1]) - | _ -> (Iintop Idiv, args) - end - | Cmodi -> - begin match args with - [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg1]) - | _ -> (Iintop Imod, args) - end (* Recognize float arithmetic with memory. In passing, apply Ershov's algorithm to reduce stack usage *) | Caddf -> @@ -228,31 +227,34 @@ self#select_floatarith Idivf (Ispecific Idivfrev) Ifloatdiv Ifloatdivrev args (* Recognize store instructions *) - | Cstore Word -> + | Cstore ((Word_int | Word_val) as chunk, _) -> begin match args with - [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])] + [loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int n], _)] when loc = loc' -> - let (addr, arg) = self#select_addressing Word loc in + let (addr, arg) = self#select_addressing chunk loc in (Ispecific(Ioffset_loc(n, addr)), [arg]) | _ -> - super#select_operation op args + super#select_operation op args dbg end (* Recognize inlined floating point operations *) - | Cextcall(fn, ty_res, false, dbg) + | Cextcall(fn, _ty_res, false, _label) when !fast_math && List.mem fn inline_float_ops -> (Ispecific(Ifloatspecial fn), args) + (* i386 does not support immediate operands for multiply high signed *) + | Cmulhi -> + (Iintop Imulh, args) (* Default *) - | _ -> super#select_operation op args + | _ -> super#select_operation op args dbg (* Recognize float arithmetic with mem *) method select_floatarith regular_op reversed_op mem_op mem_rev_op args = match args with - [arg1; Cop(Cload chunk, [loc2])] -> + [arg1; Cop(Cload (chunk, _), [loc2], _)] -> let (addr, arg2) = self#select_addressing chunk loc2 in (Ispecific(Ifloatarithmem(chunk_double chunk, mem_op, addr)), [arg1; arg2]) - | [Cop(Cload chunk, [loc1]); arg2] -> + | [Cop(Cload (chunk, _), [loc1], _); arg2] -> let (addr, arg1) = self#select_addressing chunk loc1 in (Ispecific(Ifloatarithmem(chunk_double chunk, mem_rev_op, addr)), [arg2; arg1]) @@ -290,14 +292,17 @@ | Cconst_pointer n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple []) | Cconst_natpointer n -> (Ispecific(Ipush_int n), Ctuple []) | Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple []) - | Cop(Cload Word, [loc]) -> - let (addr, arg) = self#select_addressing Word loc in + | Cop(Cload ((Word_int | Word_val as chunk), _), [loc], _) -> + let (addr, arg) = self#select_addressing chunk loc in (Ispecific(Ipush_load addr), arg) - | Cop(Cload Double_u, [loc]) -> + | Cop(Cload (Double_u, _), [loc], _) -> let (addr, arg) = self#select_addressing Double_u loc in (Ispecific(Ipush_load_float addr), arg) | _ -> (Ispecific(Ipush), exp) +method! mark_c_tailcall = + Proc.contains_calls := true + method! emit_extcall_args env args = let rec size_pushes = function | [] -> 0 diff -Nru ocaml-4.01.0/asmcomp/.ignore ocaml-4.05.0/asmcomp/.ignore --- ocaml-4.01.0/asmcomp/.ignore 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/asmcomp/.ignore 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -emit.ml -arch.ml -proc.ml -selection.ml -reload.ml -scheduling.ml diff -Nru ocaml-4.01.0/asmcomp/import_approx.ml ocaml-4.05.0/asmcomp/import_approx.ml --- ocaml-4.01.0/asmcomp/import_approx.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/import_approx.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,192 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +module A = Simple_value_approx + +let import_set_of_closures = + let import_function_declarations (clos : Flambda.function_declarations) + : Flambda.function_declarations = + (* CR-soon mshinwell for pchambart: Do we still need to do this + rewriting? I'm wondering if maybe we don't have to any more. *) + let sym_to_fun_var_map (clos : Flambda.function_declarations) = + Variable.Map.fold (fun fun_var _ acc -> + let closure_id = Closure_id.wrap fun_var in + let sym = Compilenv.closure_symbol closure_id in + Symbol.Map.add sym fun_var acc) + clos.funs Symbol.Map.empty + in + let sym_map = sym_to_fun_var_map clos in + let f_named (named : Flambda.named) = + match named with + | Symbol sym -> + begin try Flambda.Expr (Var (Symbol.Map.find sym sym_map)) with + | Not_found -> named + end + | named -> named + in + let funs = + Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> + let body = + Flambda_iterators.map_toplevel_named f_named function_decl.body + in + Flambda.create_function_declaration ~params:function_decl.params + ~body ~stub:function_decl.stub ~dbg:function_decl.dbg + ~inline:function_decl.inline + ~specialise:function_decl.specialise + ~is_a_functor:function_decl.is_a_functor) + clos.funs + in + Flambda.update_function_declarations clos ~funs + in + let aux set_of_closures_id = + ignore (Compilenv.approx_for_global + (Set_of_closures_id.get_compilation_unit set_of_closures_id)); + let ex_info = Compilenv.approx_env () in + let function_declarations = + try + Some (Set_of_closures_id.Map.find set_of_closures_id + ex_info.sets_of_closures) + with Not_found -> + None + in + match function_declarations with + | None -> None + | Some function_declarations -> + Some (import_function_declarations function_declarations) + in + Set_of_closures_id.Tbl.memoize Compilenv.imported_sets_of_closures_table aux + +let rec import_ex ex = + ignore (Compilenv.approx_for_global (Export_id.get_compilation_unit ex)); + let ex_info = Compilenv.approx_env () in + let import_value_set_of_closures ~set_of_closures_id ~bound_vars + ~(ex_info : Export_info.t) ~what : A.value_set_of_closures option = + let bound_vars = Var_within_closure.Map.map import_approx bound_vars in + match + Set_of_closures_id.Map.find set_of_closures_id ex_info.invariant_params + with + | exception Not_found -> + Misc.fatal_errorf "Set of closures ID %a not found in invariant_params \ + (when importing [%a: %s])" + Set_of_closures_id.print set_of_closures_id + Export_id.print ex + what + | invariant_params -> + match import_set_of_closures set_of_closures_id with + | None -> None + | Some function_decls -> + Some (A.create_value_set_of_closures + ~function_decls + ~bound_vars + ~invariant_params:(lazy invariant_params) + ~specialised_args:Variable.Map.empty + ~freshening:Freshening.Project_var.empty + ~direct_call_surrogates:Closure_id.Map.empty) + in + match Export_info.find_description ex_info ex with + | exception Not_found -> A.value_unknown Other + | Value_int i -> A.value_int i + | Value_char c -> A.value_char c + | Value_constptr i -> A.value_constptr i + | Value_float f -> A.value_float f + | Value_float_array float_array -> + begin match float_array.contents with + | Unknown_or_mutable -> + A.value_mutable_float_array ~size:float_array.size + | Contents contents -> + A.value_immutable_float_array + (Array.map (function + | None -> A.value_any_float + | Some f -> A.value_float f) + contents) + end + | Export_info.Value_boxed_int (t, i) -> A.value_boxed_int t i + | Value_string { size; contents } -> + let contents = + match contents with + | Unknown_or_mutable -> None + | Contents contents -> Some contents + in + A.value_string size contents + | Value_mutable_block _ -> A.value_unknown Other + | Value_block (tag, fields) -> + A.value_block tag (Array.map import_approx fields) + | Value_closure { closure_id; + set_of_closures = + { set_of_closures_id; bound_vars; aliased_symbol } } -> + let value_set_of_closures = + import_value_set_of_closures ~set_of_closures_id ~bound_vars ~ex_info + ~what:(Format.asprintf "Value_closure %a" Closure_id.print closure_id) + in + begin match value_set_of_closures with + | None -> A.value_unresolved (Set_of_closures_id set_of_closures_id) + | Some value_set_of_closures -> + A.value_closure ?set_of_closures_symbol:aliased_symbol + value_set_of_closures closure_id + end + | Value_set_of_closures { set_of_closures_id; bound_vars; aliased_symbol } -> + let value_set_of_closures = + import_value_set_of_closures ~set_of_closures_id ~bound_vars ~ex_info + ~what:"Value_set_of_closures" + in + match value_set_of_closures with + | None -> + A.value_unresolved (Set_of_closures_id set_of_closures_id) + | Some value_set_of_closures -> + let approx = A.value_set_of_closures value_set_of_closures in + match aliased_symbol with + | None -> approx + | Some symbol -> A.augment_with_symbol approx symbol + +and import_approx (ap : Export_info.approx) = + match ap with + | Value_unknown -> A.value_unknown Other + | Value_id ex -> A.value_extern ex + | Value_symbol sym -> A.value_symbol sym + +let import_symbol sym = + if Compilenv.is_predefined_exception sym then + A.value_unknown Other + else + let symbol_id_map = + let global = Symbol.compilation_unit sym in + (Compilenv.approx_for_global global).symbol_id + in + match Symbol.Map.find sym symbol_id_map with + | approx -> A.augment_with_symbol (import_ex approx) sym + | exception Not_found -> + A.value_unresolved (Symbol sym) + +(* Note for code reviewers: Observe that [really_import] iterates until + the approximation description is fully resolved (or a necessary .cmx + file is missing). *) + +let rec really_import (approx : A.descr) = + match approx with + | Value_extern ex -> really_import_ex ex + | Value_symbol sym -> really_import_symbol sym + | r -> r + +and really_import_ex ex = + really_import (import_ex ex).descr + +and really_import_symbol sym = + really_import (import_symbol sym).descr + +let really_import_approx (approx : Simple_value_approx.t) = + A.replace_description approx (really_import approx.descr) diff -Nru ocaml-4.01.0/asmcomp/import_approx.mli ocaml-4.05.0/asmcomp/import_approx.mli --- ocaml-4.01.0/asmcomp/import_approx.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/import_approx.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Create simple value approximations from the export information in + .cmx files. *) + +(** Given an approximation description, load .cmx files (possibly more + than one) until the description is fully resolved. If a necessary .cmx + file cannot be found, "unresolved" will be returned. *) +val really_import : Simple_value_approx.descr -> Simple_value_approx.descr + +(** Maps the description of the given approximation through [really_import]. *) +val really_import_approx : Simple_value_approx.t -> Simple_value_approx.t + +(** Read and convert the approximation of a given symbol from the + relevant .cmx file. Unlike the "really_" functions, this does not + continue to load .cmx files until the approximation is fully + resolved. *) +val import_symbol : Symbol.t -> Simple_value_approx.t diff -Nru ocaml-4.01.0/asmcomp/interf.ml ocaml-4.05.0/asmcomp/interf.ml --- ocaml-4.01.0/asmcomp/interf.ml 2013-03-19 07:22:12.000000000 +0000 +++ ocaml-4.05.0/asmcomp/interf.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Construction of the interference graph. Annotate pseudoregs with interference lists and preference lists. *) @@ -87,41 +90,47 @@ | Iop(Imove | Ispill | Ireload) -> add_interf_move i.arg.(0) i.res.(0) i.live; interf i.next - | Iop(Itailcall_ind) -> () - | Iop(Itailcall_imm lbl) -> () - | Iop op -> + | Iop(Itailcall_ind _) -> () + | Iop(Itailcall_imm _) -> () + | Iop _ -> add_interf_set i.res i.live; add_interf_self i.res; interf i.next - | Iifthenelse(tst, ifso, ifnot) -> + | Iifthenelse(_tst, ifso, ifnot) -> interf ifso; interf ifnot; interf i.next - | Iswitch(index, cases) -> + | Iswitch(_index, cases) -> for i = 0 to Array.length cases - 1 do interf cases.(i) done; interf i.next | Iloop body -> interf body; interf i.next - | Icatch(_, body, handler) -> - interf body; interf handler; interf i.next + | Icatch(_rec_flag, handlers, body) -> + interf body; + List.iter (fun (_, handler) -> interf handler) handlers; + interf i.next | Iexit _ -> () | Itrywith(body, handler) -> add_interf_set Proc.destroyed_at_raise handler.live; interf body; interf handler; interf i.next - | Iraise -> () in + | Iraise _ -> () in (* Add a preference from one reg to another. Do not add anything if the two registers conflict, - or if the source register already has a location. *) + or if the source register already has a location, + or if the two registers belong to different classes. + (The last case can occur e.g. on Sparc when passing + float arguments in integer registers, PR#6227.) *) let add_pref weight r1 r2 = if weight > 0 then begin let i = r1.stamp and j = r2.stamp in if i <> j && r1.loc = Unknown + && Proc.register_class r1 = Proc.register_class r2 && (let p = if i < j then (i, j) else (j, i) in not (IntPairSet.mem p !mat)) then r1.prefer <- (r2, weight) :: r1.prefer @@ -155,15 +164,15 @@ | Iop(Ireload) -> add_pref (weight / 4) i.res.(0) i.arg.(0); prefer weight i.next - | Iop(Itailcall_ind) -> () - | Iop(Itailcall_imm lbl) -> () - | Iop op -> + | Iop(Itailcall_ind _) -> () + | Iop(Itailcall_imm _) -> () + | Iop _ -> prefer weight i.next - | Iifthenelse(tst, ifso, ifnot) -> + | Iifthenelse(_tst, ifso, ifnot) -> prefer (weight / 2) ifso; prefer (weight / 2) ifnot; prefer weight i.next - | Iswitch(index, cases) -> + | Iswitch(_index, cases) -> for i = 0 to Array.length cases - 1 do prefer (weight / 2) cases.(i) done; @@ -172,13 +181,23 @@ (* Avoid overflow of weight and spill_cost *) prefer (if weight < 1000 then 8 * weight else weight) body; prefer weight i.next - | Icatch(_, body, handler) -> - prefer weight body; prefer weight handler; prefer weight i.next + | Icatch(rec_flag, handlers, body) -> + prefer weight body; + List.iter (fun (_nfail, handler) -> + let weight = + match rec_flag with + | Cmm.Recursive -> + (* Avoid overflow of weight and spill_cost *) + if weight < 1000 then 8 * weight else weight + | Cmm.Nonrecursive -> + weight in + prefer weight handler) handlers; + prefer weight i.next | Iexit _ -> () | Itrywith(body, handler) -> prefer weight body; prefer weight handler; prefer weight i.next - | Iraise -> () + | Iraise _ -> () in interf fundecl.fun_body; prefer 8 fundecl.fun_body diff -Nru ocaml-4.01.0/asmcomp/interf.mli ocaml-4.05.0/asmcomp/interf.mli --- ocaml-4.01.0/asmcomp/interf.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/interf.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Construction of the interference graph. Annotate pseudoregs with interference lists and preference lists. *) diff -Nru ocaml-4.01.0/asmcomp/linearize.ml ocaml-4.05.0/asmcomp/linearize.ml --- ocaml-4.01.0/asmcomp/linearize.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/linearize.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,25 +1,24 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Transformation of Mach code into a list of pseudo-instructions. *) open Reg open Mach -type label = int - -let label_counter = ref 99 - -let new_label() = incr label_counter; !label_counter +type label = Cmm.label type instruction = { mutable desc: instruction_desc; @@ -42,18 +41,20 @@ | Lsetuptrap of label | Lpushtrap | Lpoptrap - | Lraise + | Lraise of Cmm.raise_kind let has_fallthrough = function - | Lreturn | Lbranch _ | Lswitch _ | Lraise - | Lop Itailcall_ind | Lop (Itailcall_imm _) -> false + | Lreturn | Lbranch _ | Lswitch _ | Lraise _ + | Lop Itailcall_ind _ | Lop (Itailcall_imm _) -> false | _ -> true type fundecl = { fun_name: string; fun_body: instruction; fun_fast: bool; - fun_dbg : Debuginfo.t } + fun_dbg : Debuginfo.t; + fun_spacetime_shape : Mach.spacetime_shape option; + } (* Invert a test *) @@ -110,7 +111,7 @@ Lbranch lbl -> (lbl, n) | Llabel lbl -> (lbl, n) | Lend -> (-1, n) - | _ -> let lbl = new_label() in (lbl, cons_instr (Llabel lbl) n) + | _ -> let lbl = Cmm.new_label() in (lbl, cons_instr (Llabel lbl) n) (* Check the fallthrough label *) let check_label n = match n.desc with @@ -126,9 +127,9 @@ match n.desc with Lend -> n | Llabel _ -> n -(* Do not discard Lpoptrap or Istackoffset instructions, +(* Do not discard Lpoptrap/Lpushtrap or Istackoffset instructions, as this may cause a stack imbalance later during assembler generation. *) - | Lpoptrap -> n + | Lpoptrap | Lpushtrap -> n | Lop(Istackoffset _) -> n | _ -> discard_dead_code n.next @@ -148,27 +149,40 @@ else discard_dead_code n -(* Current labels for exit handler *) +let try_depth = ref 0 + +(* Association list: exit handler -> (handler label, try-nesting factor) *) let exit_label = ref [] -let find_exit_label k = +let find_exit_label_try_depth k = try List.assoc k !exit_label with | Not_found -> Misc.fatal_error "Linearize.find_exit_label" +let find_exit_label k = + let (label, t) = find_exit_label_try_depth k in + assert(t = !try_depth); + label + let is_next_catch n = match !exit_label with -| (n0,_)::_ when n0=n -> true +| (n0,(_,t))::_ when n0=n && t = !try_depth -> true | _ -> false +let local_exit k = + snd (find_exit_label_try_depth k) = !try_depth + (* Linearize an instruction [i]: add it in front of the continuation [n] *) let rec linear i n = match i.Mach.desc with Iend -> n - | Iop(Itailcall_ind | Itailcall_imm _ as op) -> - copy_instr (Lop op) i (discard_dead_code n) + | Iop(Itailcall_ind _ | Itailcall_imm _ as op) -> + if not Config.spacetime then + copy_instr (Lop op) i (discard_dead_code n) + else + copy_instr (Lop op) i (linear i.Mach.next n) | Iop(Imove | Ireload | Ispill) when i.Mach.arg.(0).loc = i.Mach.res.(0).loc -> linear i.Mach.next n @@ -187,15 +201,15 @@ | _, Iend, Lbranch lbl -> copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1) | Iexit nfail1, Iexit nfail2, _ - when is_next_catch nfail1 -> + when is_next_catch nfail1 && local_exit nfail2 -> let lbl2 = find_exit_label nfail2 in copy_instr (Lcondbranch (invert_test test, lbl2)) i (linear ifso n1) - | Iexit nfail, _, _ -> + | Iexit nfail, _, _ when local_exit nfail -> let n2 = linear ifnot n1 and lbl = find_exit_label nfail in copy_instr (Lcondbranch(test, lbl)) i n2 - | _, Iexit nfail, _ -> + | _, Iexit nfail, _ when local_exit nfail -> let n2 = linear ifso n1 in let lbl = find_exit_label nfail in copy_instr (Lcondbranch(invert_test test, lbl)) i n2 @@ -214,7 +228,7 @@ (linear ifso (add_branch lbl_end nelse)) end | Iswitch(index, cases) -> - let lbl_cases = Array.create (Array.length cases) 0 in + let lbl_cases = Array.make (Array.length cases) 0 in let (lbl_end, n1) = get_label(linear i.Mach.next n) in let n2 = ref (discard_dead_code n1) in for i = Array.length cases - 1 downto 0 do @@ -235,33 +249,69 @@ end else copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index)) i !n2 | Iloop body -> - let lbl_head = new_label() in + let lbl_head = Cmm.new_label() in let n1 = linear i.Mach.next n in let n2 = linear body (cons_instr (Lbranch lbl_head) n1) in cons_instr (Llabel lbl_head) n2 - | Icatch(io, body, handler) -> + | Icatch(_rec_flag, handlers, body) -> let (lbl_end, n1) = get_label(linear i.Mach.next n) in - let (lbl_handler, n2) = get_label(linear handler n1) in - exit_label := (io, lbl_handler) :: !exit_label ; + (* CR mshinwell for pchambart: + 1. rename "io" + 2. Make sure the test cases cover the "Iend" cases too *) + let labels_at_entry_to_handlers = List.map (fun (_nfail, handler) -> + match handler.Mach.desc with + | Iend -> lbl_end + | _ -> Cmm.new_label ()) + handlers in + let exit_label_add = List.map2 + (fun (nfail, _) lbl -> (nfail, (lbl, !try_depth))) + handlers labels_at_entry_to_handlers in + let previous_exit_label = !exit_label in + exit_label := exit_label_add @ !exit_label; + let n2 = List.fold_left2 (fun n (_nfail, handler) lbl_handler -> + match handler.Mach.desc with + | Iend -> n + | _ -> cons_instr (Llabel lbl_handler) (linear handler n)) + n1 handlers labels_at_entry_to_handlers + in let n3 = linear body (add_branch lbl_end n2) in - exit_label := List.tl !exit_label; + exit_label := previous_exit_label; n3 | Iexit nfail -> - let n1 = linear i.Mach.next n in - let lbl = find_exit_label nfail in - add_branch lbl n1 + let lbl, t = find_exit_label_try_depth nfail in + (* We need to re-insert dummy pushtrap (which won't be executed), + so as to preserve stack offset during assembler generation. + It would make sense to have a special pseudo-instruction + only to inform the later pass about this stack offset + (corresponding to N traps). + *) + let rec loop i tt = + if t = tt then i + else loop (cons_instr Lpushtrap i) (tt - 1) + in + let n1 = loop (linear i.Mach.next n) !try_depth in + let rec loop i tt = + if t = tt then i + else loop (cons_instr Lpoptrap i) (tt - 1) + in + loop (add_branch lbl n1) !try_depth | Itrywith(body, handler) -> let (lbl_join, n1) = get_label (linear i.Mach.next n) in + incr try_depth; + assert (i.Mach.arg = [| |] || Config.spacetime); let (lbl_body, n2) = - get_label (cons_instr Lpushtrap + get_label (instr_cons Lpushtrap i.Mach.arg [| |] (linear body (cons_instr Lpoptrap n1))) in - cons_instr (Lsetuptrap lbl_body) + decr try_depth; + instr_cons (Lsetuptrap lbl_body) i.Mach.arg [| |] (linear handler (add_branch lbl_join n2)) - | Iraise -> - copy_instr Lraise i (discard_dead_code n) + | Iraise k -> + copy_instr (Lraise k) i (discard_dead_code n) let fundecl f = { fun_name = f.Mach.fun_name; fun_body = linear f.Mach.fun_body end_instr; fun_fast = f.Mach.fun_fast; - fun_dbg = f.Mach.fun_dbg } + fun_dbg = f.Mach.fun_dbg; + fun_spacetime_shape = f.Mach.fun_spacetime_shape; + } diff -Nru ocaml-4.01.0/asmcomp/linearize.mli ocaml-4.05.0/asmcomp/linearize.mli --- ocaml-4.01.0/asmcomp/linearize.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/linearize.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,19 +1,21 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Transformation of Mach code into a list of pseudo-instructions. *) -type label = int -val new_label: unit -> label +type label = Cmm.label type instruction = { mutable desc: instruction_desc; @@ -36,7 +38,7 @@ | Lsetuptrap of label | Lpushtrap | Lpoptrap - | Lraise + | Lraise of Cmm.raise_kind val has_fallthrough : instruction_desc -> bool val end_instr: instruction @@ -48,6 +50,8 @@ { fun_name: string; fun_body: instruction; fun_fast: bool; - fun_dbg : Debuginfo.t } + fun_dbg : Debuginfo.t; + fun_spacetime_shape : Mach.spacetime_shape option; + } val fundecl: Mach.fundecl -> fundecl diff -Nru ocaml-4.01.0/asmcomp/liveness.ml ocaml-4.05.0/asmcomp/liveness.ml --- ocaml-4.01.0/asmcomp/liveness.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/liveness.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Liveness analysis. Annotate mach code with the set of regs live at each point. *) @@ -16,13 +19,13 @@ open Mach let live_at_exit = ref [] + let find_live_at_exit k = try List.assoc k !live_at_exit with - | Not_found -> Misc.fatal_error "Spill.find_live_at_exit" + | Not_found -> Misc.fatal_error "Liveness.find_live_at_exit" -let live_at_break = ref Reg.Set.empty let live_at_raise = ref Reg.Set.empty let rec live i finally = @@ -32,26 +35,58 @@ before the instruction sequence. The instruction i is annotated by the set of registers live across the instruction. *) + let arg = + if Config.spacetime + && Mach.spacetime_node_hole_pointer_is_live_before i + then Array.append i.arg [| Proc.loc_spacetime_node_hole |] + else i.arg + in match i.desc with Iend -> i.live <- finally; finally - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> - (* i.live remains empty since no regs are live across *) - Reg.set_of_array i.arg - | Iifthenelse(test, ifso, ifnot) -> + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> + i.live <- Reg.Set.empty; (* no regs are live across *) + Reg.set_of_array arg + | Iop op -> + let after = live i.next finally in + if Proc.op_is_pure op (* no side effects *) + && Reg.disjoint_set_array after i.res (* results are not used after *) + && not (Proc.regs_are_volatile arg) (* no stack-like hard reg *) + && not (Proc.regs_are_volatile i.res) (* is involved *) + then begin + (* This operation is dead code. Ignore its arguments. *) + i.live <- after; + after + end else begin + let across_after = Reg.diff_set_array after i.res in + let across = + match op with + | Icall_ind _ | Icall_imm _ | Iextcall _ + | Iintop (Icheckbound _) | Iintop_imm(Icheckbound _, _) -> + (* The function call may raise an exception, branching to the + nearest enclosing try ... with. Similarly for bounds checks. + Hence, everything that must be live at the beginning of + the exception handler must also be live across this instr. *) + Reg.Set.union across_after !live_at_raise + | _ -> + across_after in + i.live <- across; + Reg.add_set_array across arg + end + | Iifthenelse(_test, ifso, ifnot) -> let at_join = live i.next finally in let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in i.live <- at_fork; - Reg.add_set_array at_fork i.arg - | Iswitch(index, cases) -> + Reg.add_set_array at_fork arg + | Iswitch(_index, cases) -> let at_join = live i.next finally in let at_fork = ref Reg.Set.empty in for i = 0 to Array.length cases - 1 do at_fork := Reg.Set.union !at_fork (live cases.(i) at_join) done; i.live <- !at_fork; - Reg.add_set_array !at_fork i.arg + Reg.add_set_array !at_fork arg | Iloop(body) -> let at_top = ref Reg.Set.empty in (* Yes, there are better algorithms, but we'll just iterate till @@ -66,14 +101,46 @@ end; i.live <- !at_top; !at_top - | Icatch(nfail, body, handler) -> + | Icatch(rec_flag, handlers, body) -> let at_join = live i.next finally in - let before_handler = live handler at_join in - let before_body = - live_at_exit := (nfail,before_handler) :: !live_at_exit ; - let before_body = live body at_join in - live_at_exit := List.tl !live_at_exit ; - before_body in + let aux (nfail,handler) (nfail', before_handler) = + assert(nfail = nfail'); + let before_handler' = live handler at_join in + nfail, Reg.Set.union before_handler before_handler' + in + let aux_equal (nfail, before_handler) (nfail', before_handler') = + assert(nfail = nfail'); + Reg.Set.equal before_handler before_handler' + in + let live_at_exit_before = !live_at_exit in + let live_at_exit_add before_handlers = + List.map (fun (nfail, before_handler) -> + (nfail, before_handler)) + before_handlers + in + let rec fixpoint before_handlers = + let live_at_exit_add = live_at_exit_add before_handlers in + live_at_exit := live_at_exit_add @ !live_at_exit; + let before_handlers' = List.map2 aux handlers before_handlers in + live_at_exit := live_at_exit_before; + match rec_flag with + | Cmm.Nonrecursive -> + before_handlers' + | Cmm.Recursive -> + if List.for_all2 aux_equal before_handlers before_handlers' + then before_handlers' + else fixpoint before_handlers' + in + let init_state = + List.map (fun (nfail, _handler) -> nfail, Reg.Set.empty) handlers + in + let before_handler = fixpoint init_state in + (* We could use handler.live instead of Reg.Set.empty as the initial + value but we would need to clean the live field before doing the + analysis (to remove remnants of previous passes). *) + live_at_exit := (live_at_exit_add before_handler) @ !live_at_exit; + let before_body = live body at_join in + live_at_exit := live_at_exit_before; i.live <- before_body; before_body | Iexit nfail -> @@ -89,29 +156,23 @@ live_at_raise := saved_live_at_raise; i.live <- before_body; before_body - | Iraise -> - (* i.live remains empty since no regs are live across *) - Reg.add_set_array !live_at_raise i.arg - | _ -> - let across_after = Reg.diff_set_array (live i.next finally) i.res in - let across = - match i.desc with - Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) - | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> - (* The function call may raise an exception, branching to the - nearest enclosing try ... with. Similarly for bounds checks. - Hence, everything that must be live at the beginning of - the exception handler must also be live across this instr. *) - Reg.Set.union across_after !live_at_raise - | _ -> - across_after in - i.live <- across; - Reg.add_set_array across i.arg + | Iraise _ -> + i.live <- !live_at_raise; + Reg.add_set_array !live_at_raise arg + +let reset () = + live_at_raise := Reg.Set.empty; + live_at_exit := [] let fundecl ppf f = let initially_live = live f.fun_body Reg.Set.empty in - (* Sanity check: only function parameters can be live at entrypoint *) + (* Sanity check: only function parameters (and the Spacetime node hole + register, if profiling) can be live at entrypoint *) let wrong_live = Reg.Set.diff initially_live (Reg.set_of_array f.fun_args) in + let wrong_live = + if not Config.spacetime then wrong_live + else Reg.Set.remove Proc.loc_spacetime_node_hole wrong_live + in if not (Reg.Set.is_empty wrong_live) then begin Format.fprintf ppf "%a@." Printmach.regset wrong_live; Misc.fatal_error "Liveness.fundecl" diff -Nru ocaml-4.01.0/asmcomp/liveness.mli ocaml-4.05.0/asmcomp/liveness.mli --- ocaml-4.01.0/asmcomp/liveness.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/liveness.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,18 +1,22 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Liveness analysis. Annotate mach code with the set of regs live at each point. *) open Format +val reset : unit -> unit val fundecl: formatter -> Mach.fundecl -> unit diff -Nru ocaml-4.01.0/asmcomp/mach.ml ocaml-4.05.0/asmcomp/mach.ml --- ocaml-4.01.0/asmcomp/mach.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/mach.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,26 +1,32 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Representation of machine code by sequences of pseudoinstructions *) +type label = Cmm.label + type integer_comparison = Isigned of Cmm.comparison | Iunsigned of Cmm.comparison type integer_operation = - Iadd | Isub | Imul | Idiv | Imod + Iadd | Isub | Imul | Imulh | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison - | Icheckbound + | Icheckbound of { label_after_error : label option; + spacetime_index : int; } type test = Itruetest @@ -36,17 +42,18 @@ | Ispill | Ireload | Iconst_int of nativeint - | Iconst_float of string + | Iconst_float of int64 | Iconst_symbol of string - | Icall_ind - | Icall_imm of string - | Itailcall_ind - | Itailcall_imm of string - | Iextcall of string * bool + | Icall_ind of { label_after : label; } + | Icall_imm of { func : string; label_after : label; } + | Itailcall_ind of { label_after : label; } + | Itailcall_imm of { func : string; label_after : label; } + | Iextcall of { func : string; alloc : bool; label_after : label; } | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode - | Istore of Cmm.memory_chunk * Arch.addressing_mode - | Ialloc of int + | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool + | Ialloc of { words : int; label_after_call_gc : label option; + spacetime_index : int; } | Iintop of integer_operation | Iintop_imm of integer_operation * int | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf @@ -68,17 +75,26 @@ | Iifthenelse of test * instruction * instruction | Iswitch of int array * instruction array | Iloop of instruction - | Icatch of int * instruction * instruction + | Icatch of Cmm.rec_flag * (int * instruction) list * instruction | Iexit of int | Itrywith of instruction * instruction - | Iraise + | Iraise of Cmm.raise_kind + +type spacetime_part_of_shape = + | Direct_call_point of { callee : string; } + | Indirect_call_point + | Allocation_point + +type spacetime_shape = (spacetime_part_of_shape * Cmm.label) list type fundecl = { fun_name: string; fun_args: Reg.t array; fun_body: instruction; fun_fast: bool; - fun_dbg : Debuginfo.t } + fun_dbg : Debuginfo.t; + fun_spacetime_shape : spacetime_shape option; + } let rec dummy_instr = { desc = Iend; @@ -110,21 +126,56 @@ f i; match i.desc with Iend -> () - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> () - | Iifthenelse(tst, ifso, ifnot) -> + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> () + | Iifthenelse(_tst, ifso, ifnot) -> instr_iter f ifso; instr_iter f ifnot; instr_iter f i.next - | Iswitch(index, cases) -> + | Iswitch(_index, cases) -> for i = 0 to Array.length cases - 1 do instr_iter f cases.(i) done; instr_iter f i.next | Iloop(body) -> instr_iter f body; instr_iter f i.next - | Icatch(_, body, handler) -> - instr_iter f body; instr_iter f handler; instr_iter f i.next + | Icatch(_, handlers, body) -> + instr_iter f body; + List.iter (fun (_n, handler) -> instr_iter f handler) handlers; + instr_iter f i.next | Iexit _ -> () | Itrywith(body, handler) -> instr_iter f body; instr_iter f handler; instr_iter f i.next - | Iraise -> () + | Iraise _ -> () | _ -> instr_iter f i.next + +let spacetime_node_hole_pointer_is_live_before insn = + match insn.desc with + | Iop op -> + begin match op with + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ -> true + | Iextcall { alloc; } -> alloc + | Ialloc _ -> + (* Allocations are special: the call to [caml_call_gc] requires some + instrumentation code immediately prior, but this is not inserted until + the emitter (since the call is not visible prior to that in any IR). + As such, none of the Mach / Linearize analyses will ever see that + we use the node hole pointer for these, and we do not need to say + that it is live at such points. *) + false + | Iintop op | Iintop_imm (op, _) -> + begin match op with + | Icheckbound _ + (* [Icheckbound] doesn't need to return [true] for the same reason as + [Ialloc]. *) + | Iadd | Isub | Imul | Imulh | Idiv | Imod + | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr + | Icomp _ -> false + end + | Ispecific specific_op -> + Arch.spacetime_node_hole_pointer_is_live_before specific_op + | Imove | Ispill | Ireload | Iconst_int _ | Iconst_float _ + | Iconst_symbol _ | Istackoffset _ | Iload _ | Istore _ + | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Ifloatofint | Iintoffloat -> false + end + | Iend | Ireturn | Iifthenelse _ | Iswitch _ | Iloop _ | Icatch _ + | Iexit _ | Itrywith _ | Iraise _ -> false diff -Nru ocaml-4.01.0/asmcomp/mach.mli ocaml-4.05.0/asmcomp/mach.mli --- ocaml-4.01.0/asmcomp/mach.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/mach.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,26 +1,39 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Representation of machine code by sequences of pseudoinstructions *) +(** N.B. Backends vary in their treatment of call gc and checkbound + points. If the positioning of any labels associated with these is + important for some new feature in the compiler, the relevant backends' + behaviour should be checked. *) +type label = Cmm.label + type integer_comparison = Isigned of Cmm.comparison | Iunsigned of Cmm.comparison type integer_operation = - Iadd | Isub | Imul | Idiv | Imod + Iadd | Isub | Imul | Imulh | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison - | Icheckbound + | Icheckbound of { label_after_error : label option; + spacetime_index : int; } + (** For Spacetime only, [Icheckbound] operations take two arguments, the + second being the pointer to the trie node for the current function + (and the first being as per non-Spacetime mode). *) type test = Itruetest @@ -36,17 +49,21 @@ | Ispill | Ireload | Iconst_int of nativeint - | Iconst_float of string + | Iconst_float of int64 | Iconst_symbol of string - | Icall_ind - | Icall_imm of string - | Itailcall_ind - | Itailcall_imm of string - | Iextcall of string * bool + | Icall_ind of { label_after : label; } + | Icall_imm of { func : string; label_after : label; } + | Itailcall_ind of { label_after : label; } + | Itailcall_imm of { func : string; label_after : label; } + | Iextcall of { func : string; alloc : bool; label_after : label; } | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode - | Istore of Cmm.memory_chunk * Arch.addressing_mode - | Ialloc of int + | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool + (* false = initialization, true = assignment *) + | Ialloc of { words : int; label_after_call_gc : label option; + spacetime_index : int; } + (** For Spacetime only, Ialloc instructions take one argument, being the + pointer to the trie node for the current function. *) | Iintop of integer_operation | Iintop_imm of integer_operation * int | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf @@ -68,17 +85,32 @@ | Iifthenelse of test * instruction * instruction | Iswitch of int array * instruction array | Iloop of instruction - | Icatch of int * instruction * instruction + | Icatch of Cmm.rec_flag * (int * instruction) list * instruction | Iexit of int | Itrywith of instruction * instruction - | Iraise + | Iraise of Cmm.raise_kind + +type spacetime_part_of_shape = + | Direct_call_point of { callee : string; (* the symbol *) } + | Indirect_call_point + | Allocation_point + +(** A description of the layout of a Spacetime profiling node associated with + a given function. Each call and allocation point instrumented within + the function is marked with a label in the code and assigned a place + within the node. This information is stored within the executable and + extracted when the user saves a profile. The aim is to minimise runtime + memory usage within the nodes and increase performance. *) +type spacetime_shape = (spacetime_part_of_shape * Cmm.label) list type fundecl = { fun_name: string; fun_args: Reg.t array; fun_body: instruction; fun_fast: bool; - fun_dbg : Debuginfo.t } + fun_dbg : Debuginfo.t; + fun_spacetime_shape : spacetime_shape option; + } val dummy_instr: instruction val end_instr: unit -> instruction @@ -89,3 +121,5 @@ instruction_desc -> Reg.t array -> Reg.t array -> Debuginfo.t -> instruction -> instruction val instr_iter: (instruction -> unit) -> instruction -> unit + +val spacetime_node_hole_pointer_is_live_before : instruction -> bool diff -Nru ocaml-4.01.0/asmcomp/power/arch.ml ocaml-4.05.0/asmcomp/power/arch.ml --- ocaml-4.01.0/asmcomp/power/arch.ml 2013-06-21 15:00:10.000000000 +0000 +++ ocaml-4.05.0/asmcomp/power/arch.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,29 +1,60 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Specific operations for the PowerPC processor *) open Format +let ppc64 = + match Config.model with + | "ppc" -> false + | "ppc64" | "ppc64le" -> true + | _ -> assert false + +type abi = ELF32 | ELF64v1 | ELF64v2 + +let abi = + match Config.model with + | "ppc" -> ELF32 + | "ppc64" -> ELF64v1 + | "ppc64le" -> ELF64v2 + | _ -> assert false + (* Machine-specific command-line options *) -let command_line_options = [] +let big_toc = ref false + +let command_line_options = [ + "-flarge-toc", Arg.Set big_toc, + " Support TOC (table of contents) greater than 64 kbytes" +] (* Specific operations *) type specific_operation = Imultaddf (* multiply and add *) | Imultsubf (* multiply and subtract *) - | Ialloc_far of int (* allocation in large functions *) + | Ialloc_far of (* allocation in large functions *) + { words : int; label_after_call_gc : int (*Cmm.label*) option; } + +(* note: we avoid introducing a dependency to Cmm since this dep + is not detected when "make depend" is run under amd64 *) + +let spacetime_node_hole_pointer_is_live_before = function + | Imultaddf | Imultsubf -> false + | Ialloc_far _ -> true (* Addressing modes *) @@ -34,16 +65,18 @@ (* Sizes, endianness *) -let big_endian = true - -let ppc64 = - match Config.model with "ppc64" -> true | _ -> false +let big_endian = + match Config.model with + | "ppc" -> true + | "ppc64" -> true + | "ppc64le" -> false + | _ -> assert false let size_addr = if ppc64 then 8 else 4 let size_int = size_addr let size_float = 8 -let allow_unaligned_access = false +let allow_unaligned_access = true (* Behavior of division *) @@ -60,8 +93,8 @@ | Iindexed2 -> assert false let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 + Ibased _ -> 0 + | Iindexed _ -> 1 | Iindexed2 -> 2 (* Printing operations and addressing modes *) @@ -85,5 +118,5 @@ | Imultsubf -> fprintf ppf "%a *f %a -f %a" printreg arg.(0) printreg arg.(1) printreg arg.(2) - | Ialloc_far n -> - fprintf ppf "alloc_far %d" n + | Ialloc_far { words; _ } -> + fprintf ppf "alloc_far %d" words diff -Nru ocaml-4.01.0/asmcomp/power/CSE.ml ocaml-4.05.0/asmcomp/power/CSE.ml --- ocaml-4.01.0/asmcomp/power/CSE.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/power/CSE.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* CSE for the PowerPC *) + +open Arch +open Mach +open CSEgen + +class cse = object + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Imultaddf | Imultsubf) -> Op_pure + | Ispecific(Ialloc_far _) -> Op_other + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n -> n <= 32767n && n >= -32768n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/power/emit.mlp ocaml-4.05.0/asmcomp/power/emit.mlp --- ocaml-4.01.0/asmcomp/power/emit.mlp 2013-06-24 08:16:27.000000000 +0000 +++ ocaml-4.05.0/asmcomp/power/emit.mlp 2017-07-13 08:56:44.000000000 +0000 @@ -1,20 +1,21 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +#2 "asmcomp/power/emit.mlp" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Emission of PowerPC assembly code *) -module StringSet = - Set.Make(struct type t = string let compare (x:t) y = compare x y end) - open Misc open Cmm open Arch @@ -24,75 +25,83 @@ open Linearize open Emitaux +(* Reserved space at bottom of stack *) + +let reserved_stack_space = + match abi with + | ELF32 -> 0 + | ELF64v1 -> 48 + | ELF64v2 -> 32 + (* Layout of the stack. The stack is kept 16-aligned. *) let stack_offset = ref 0 let frame_size () = let size = + reserved_stack_space + !stack_offset + (* Trap frame, outgoing parameters *) size_int * num_stack_slots.(0) + (* Local int variables *) size_float * num_stack_slots.(1) + (* Local float variables *) - (if !contains_calls then size_int else 0) in (* The return address *) + (if !contains_calls && abi = ELF32 then size_int else 0) in + (* The return address *) Misc.align size 16 let slot_offset loc cls = match loc with Local n -> - if cls = 0 - then !stack_offset + num_stack_slots.(1) * size_float + n * size_int - else !stack_offset + n * size_float - | Incoming n -> frame_size() + n - | Outgoing n -> n - -(* Whether stack backtraces are supported *) - -let supports_backtraces = - match Config.system with - | "rhapsody" -> true - | _ -> false + reserved_stack_space + !stack_offset + + (if cls = 0 then num_stack_slots.(1) * size_float + n * size_int + else n * size_float) + | Incoming n -> frame_size() + reserved_stack_space + n + | Outgoing n -> reserved_stack_space + n + +let retaddr_offset () = + match abi with + | ELF32 -> frame_size() - size_addr + | ELF64v1 | ELF64v2 -> frame_size() + 16 + +let toc_save_offset () = + match abi with + | ELF32 -> assert false + | ELF64v1 | ELF64v2 -> frame_size() + 8 + +let (trap_size, trap_handler_offset, trap_previous_offset) = + match abi with + | ELF32 -> (16, 0, 4) + | ELF64v1 -> (32, 56, 64) + | ELF64v2 -> (32, 40, 48) (* Output a symbol *) -let emit_symbol = - match Config.system with - | "elf" | "bsd" | "bsd_elf" -> (fun s -> Emitaux.emit_symbol '.' s) - | "rhapsody" -> (fun s -> emit_char '_'; Emitaux.emit_symbol '$' s) - | _ -> assert false +let emit_symbol s = Emitaux.emit_symbol '.' s (* Output a label *) -let label_prefix = - match Config.system with - | "elf" | "bsd" | "bsd_elf" -> ".L" - | "rhapsody" -> "L" - | _ -> assert false +let label_prefix = ".L" let emit_label lbl = emit_string label_prefix; emit_int lbl -let emit_data_label lbl = - emit_string label_prefix; emit_string "d"; emit_int lbl - (* Section switching *) -let data_space = - match Config.system with - | "elf" | "bsd" | "bsd_elf" -> " .section \".data\"\n" - | "rhapsody" -> " .data\n" - | _ -> assert false - let code_space = - match Config.system with - | "elf" | "bsd" | "bsd_elf" -> " .section \".text\"\n" - | "rhapsody" -> " .text\n" - | _ -> assert false + " .section \".text\"\n" + +let function_descr_space = + match abi with + | ELF32 -> code_space + | ELF64v1 -> " .section \".opd\",\"aw\"\n" + | ELF64v2 -> code_space + +let data_space = + " .section \".data\"\n" let rodata_space = - match Config.system with - | "elf" | "bsd" | "bsd_elf" -> " .section \".rodata\"\n" - | "rhapsody" -> " .const\n" - | _ -> assert false + " .section \".rodata\"\n" + +let toc_space = + " .section \".toc\",\"aw\"\n" (* Names of instructions that differ in 32 and 64-bit modes *) @@ -102,51 +111,56 @@ let cmpg = if ppc64 then "cmpd" else "cmpw" let cmplg = if ppc64 then "cmpld" else "cmplw" let datag = if ppc64 then ".quad" else ".long" -let aligng = if ppc64 then 3 else 2 let mullg = if ppc64 then "mulld" else "mullw" let divg = if ppc64 then "divd" else "divw" let tglle = if ppc64 then "tdlle" else "twlle" -let sragi = if ppc64 then "sradi" else "srawi" -let slgi = if ppc64 then "sldi" else "slwi" -let fctigz = if ppc64 then "fctidz" else "fctiwz" + +(* Output a processor register *) + +let emit_gpr = emit_int (* Output a pseudo-register *) let emit_reg r = match r.loc with - Reg r -> emit_string (register_name r) + | Reg r -> emit_string (register_name r) | _ -> fatal_error "Emit.emit_reg" -let use_full_regnames = - Config.system = "rhapsody" - -let emit_gpr r = - if use_full_regnames then emit_char 'r'; - emit_int r - -let emit_fpr r = - if use_full_regnames then emit_char 'f'; - emit_int r - -let emit_ccr r = - if use_full_regnames then emit_string "cr"; - emit_int r - (* Output a stack reference *) let emit_stack r = match r.loc with - Stack s -> - let ofs = slot_offset s (register_class r) in `{emit_int ofs}({emit_gpr 1})` + | Stack s -> + let ofs = slot_offset s (register_class r) in `{emit_int ofs}(1)` | _ -> fatal_error "Emit.emit_stack" +(* Output the name of a symbol plus an optional offset *) + +let emit_symbol_offset (s, d) = + emit_symbol s; + if d > 0 then `+`; + if d <> 0 then emit_int d + (* Split a 32-bit integer constants in two 16-bit halves *) -let low n = n land 0xFFFF -let high n = n asr 16 +let low_high_u n = (n land 0xFFFF, n asr 16) + (* unsigned low half, for use with "ori" *) -let nativelow n = Nativeint.to_int n land 0xFFFF -let nativehigh n = Nativeint.to_int (Nativeint.shift_right n 16) +let native_low_high_u n = + (Nativeint.(to_int (logand n 0xFFFFn)), + Nativeint.(to_int (shift_right n 16))) + (* unsigned low half, for use with "ori" *) + +let low_high_s n = + let lo = ((n + 0x8000) land 0xFFFF) - 0x8000 in + (lo, (n - lo) asr 16) + (* signed low half, for use with "addi" *) + +let native_low_high_s n = + let lo = Nativeint.(sub (logand (add n 0x8000n) 0xFFFFn) 0x8000n) in + (Nativeint.to_int lo, + Nativeint.(to_int (shift_right (sub n lo) 16))) + (* signed low half, for use with "addi" *) let is_immediate n = n <= 32767 && n >= -32768 @@ -154,47 +168,83 @@ let is_native_immediate n = n <= 32767n && n >= -32768n +(* Record TOC entries *) + +type tocentry = + | TocSym of string + | TocLabel of int + | TocInt of nativeint + | TocFloat of int64 + +let tocref_entries : (tocentry, label) Hashtbl.t = Hashtbl.create 64 + +let emit_tocentry = function + | TocSym s -> emit_symbol s + | TocInt i -> emit_nativeint i + | TocFloat f -> emit_printf "0x%Lx # %.12g" f (Int64.float_of_bits f) + | TocLabel lbl -> emit_label lbl + +let label_for_tocref entry = + try + Hashtbl.find tocref_entries entry + with Not_found -> + let lbl = new_label() in + Hashtbl.add tocref_entries entry lbl; + lbl + +let emit_toctable () = + Hashtbl.iter + (fun entry lbl -> + `{emit_label lbl}: .quad {emit_tocentry entry}\n`) + tocref_entries + +(* Emit a load from a TOC entry *) + +let emit_tocload emit_dest dest entry = + let lbl = label_for_tocref entry in + if !big_toc || !Clflags.for_package <> None then begin + ` addis {emit_dest dest}, 2, {emit_label lbl}@toc@ha\n`; + ` ld {emit_dest dest}, {emit_label lbl}@toc@l({emit_dest dest}) # {emit_tocentry entry}\n` + end else begin + ` ld {emit_dest dest}, {emit_label lbl}@toc(2) # {emit_tocentry entry}\n` + end + (* Output a "upper 16 bits" or "lower 16 bits" operator. *) let emit_upper emit_fun arg = - match Config.system with - | "elf" | "bsd" | "bsd_elf" -> - emit_fun arg; emit_string "@ha" - | "rhapsody" -> - emit_string "ha16("; emit_fun arg; emit_string ")" - | _ -> assert false + emit_fun arg; emit_string "@ha" let emit_lower emit_fun arg = - match Config.system with - | "elf" | "bsd" | "bsd_elf" -> - emit_fun arg; emit_string "@l" - | "rhapsody" -> - emit_string "lo16("; emit_fun arg; emit_string ")" - | _ -> assert false + emit_fun arg; emit_string "@l" (* Output a load or store operation *) -let emit_symbol_offset (s, d) = - emit_symbol s; - if d > 0 then `+`; - if d <> 0 then emit_int d - let valid_offset instr ofs = - ofs land 3 = 0 || (instr <> "ld" && instr <> "std") + ofs land 3 = 0 || (instr <> "ld" && instr <> "std" && instr <> "lwa") let emit_load_store instr addressing_mode addr n arg = match addressing_mode with - Ibased(s, d) -> - ` addis {emit_gpr 11}, 0, {emit_upper emit_symbol_offset (s,d)}\n`; - ` {emit_string instr} {emit_reg arg}, {emit_lower emit_symbol_offset (s,d)}({emit_gpr 11})\n` + | Ibased(s, d) -> + begin match abi with + | ELF32 -> + ` addis 11, 0, {emit_upper emit_symbol_offset (s,d)}\n`; + ` {emit_string instr} {emit_reg arg}, {emit_lower emit_symbol_offset (s,d)}(11)\n` + | ELF64v1 | ELF64v2 -> + emit_tocload emit_gpr 11 (TocSym s); + let (lo, hi) = low_high_s d in + if hi <> 0 then + ` addis 11, 11, {emit_int hi}\n`; + ` {emit_string instr} {emit_reg arg}, {emit_int lo}(11)\n` + end | Iindexed ofs -> if is_immediate ofs && valid_offset instr ofs then ` {emit_string instr} {emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n` else begin - ` lis {emit_gpr 0}, {emit_int(high ofs)}\n`; - if low ofs <> 0 then - ` ori {emit_gpr 0}, {emit_gpr 0}, {emit_int(low ofs)}\n`; - ` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, {emit_gpr 0}\n` + let (lo, hi) = low_high_u ofs in + ` addis 0, 0, {emit_int hi}\n`; + if lo <> 0 then + ` ori 0, 0, {emit_int lo}\n`; + ` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, 0\n` end | Iindexed2 -> ` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, {emit_reg addr.(n+1)}\n` @@ -202,55 +252,85 @@ (* After a comparison, extract the result as 0 or 1 *) let emit_set_comp cmp res = - ` mfcr {emit_gpr 0}\n`; + ` mfcr 0\n`; let bitnum = match cmp with Ceq | Cne -> 2 | Cgt | Cle -> 1 | Clt | Cge -> 0 in -` rlwinm {emit_reg res}, {emit_gpr 0}, {emit_int(bitnum+1)}, 31, 31\n`; +` rlwinm {emit_reg res}, 0, {emit_int(bitnum+1)}, 31, 31\n`; begin match cmp with Cne | Cle | Cge -> ` xori {emit_reg res}, {emit_reg res}, 1\n` | _ -> () end +(* Free the stack frame *) + +let emit_free_frame () = + let n = frame_size() in + if n > 0 then + ` addi 1, 1, {emit_int n}\n` + +(* Emit a "bl" instruction to a given symbol *) + +let emit_call s = + match abi with + | ELF32 when !Clflags.dlcode || !Clflags.pic_code -> + ` bl {emit_symbol s}@plt\n` + | _ -> + ` bl {emit_symbol s}\n` + +(* Add a nop after a "bl" call for ELF64 *) + +let emit_call_nop () = + match abi with + | ELF32 -> () + | ELF64v1 | ELF64v2 -> ` nop \n` + +(* Reload the TOC register r2 from the value saved on the stack *) + +let emit_reload_toc () = + ` ld 2, {emit_int (toc_save_offset())}(1)\n` + +(* Adjust stack_offset and emit corresponding CFI directive *) + +let adjust_stack_offset delta = + stack_offset := !stack_offset + delta; + cfi_adjust_cfa_offset delta + (* Record live pointers at call points *) -let record_frame live dbg = - let lbl = new_label() in +let record_frame ?label live raise_ dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function - {typ = Addr; loc = Reg r} -> - live_offset := (r lsl 1) + 1 :: !live_offset - | {typ = Addr; loc = Stack s} as reg -> + | {typ = Val; loc = Reg r} -> + live_offset := ((r lsl 1) + 1) :: !live_offset + | {typ = Val; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset + | {typ = Addr} as r -> + Misc.fatal_error ("bad GC root " ^ Reg.name r) | _ -> ()) live; - frame_descriptors := - { fd_lbl = lbl; - fd_frame_size = frame_size(); - fd_live_offset = !live_offset; - fd_debuginfo = dbg } :: !frame_descriptors; + record_frame_descr ~label:lbl ~frame_size:(frame_size()) + ~live_offset:!live_offset ~raise_frame:raise_ dbg; `{emit_label lbl}:\n` -(* Record floating-point and large integer literals *) - -let float_literals = ref ([] : (string * int) list) -let int_literals = ref ([] : (nativeint * int) list) - -(* Record external C functions to be called in a position-independent way - (for MacOSX) *) +(* Record floating-point literals (for PPC32) *) -let pic_externals = (Config.system = "rhapsody") +let float_literals = ref ([] : (int64 * int) list) -let external_functions = ref StringSet.empty +(* Record jump tables (for PPC64). In order to reduce the size of the TOC, + we concatenate all jumptables and emit them at the end of the compilation + unit. *) -let emit_external s = - ` .non_lazy_symbol_pointer\n`; - `L{emit_symbol s}$non_lazy_ptr:\n`; - ` .indirect_symbol {emit_symbol s}\n`; - ` {emit_string datag} 0\n` +let jumptables = ref ([] : label list) (* in reverse order *) +let jumptables_lbl = ref (-1) (* Names for conditional branches after comparisons *) @@ -266,15 +346,16 @@ (* Names for various instructions *) let name_for_intop = function - Iadd -> "add" - | Imul -> if ppc64 then "mulld" else "mullw" - | Idiv -> if ppc64 then "divd" else "divw" - | Iand -> "and" - | Ior -> "or" - | Ixor -> "xor" - | Ilsl -> if ppc64 then "sld" else "slw" - | Ilsr -> if ppc64 then "srd" else "srw" - | Iasr -> if ppc64 then "srad" else "sraw" + Iadd -> "add" + | Imul -> if ppc64 then "mulld" else "mullw" + | Imulh -> if ppc64 then "mulhd" else "mulhw" + | Idiv -> if ppc64 then "divd" else "divw" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | Ilsl -> if ppc64 then "sld" else "slw" + | Ilsr -> if ppc64 then "srd" else "srw" + | Iasr -> if ppc64 then "srad" else "sraw" | _ -> Misc.fatal_error "Emit.Intop" let name_for_intop_imm = function @@ -309,153 +390,137 @@ let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 -(* Names of functions defined in the current file *) -let defined_functions = ref StringSet.empty (* Label of glue code for calling the GC *) let call_gc_label = ref 0 -(* Fixup conditional branches that exceed hardware allowed range *) +(* Relaxation of branches that exceed the span of a relative branch. *) -let load_store_size = function - Ibased(s, d) -> 2 - | Iindexed ofs -> if is_immediate ofs then 1 else 3 - | Iindexed2 -> 1 - -let instr_size = function - Lend -> 0 - | Lop(Imove | Ispill | Ireload) -> 1 - | Lop(Iconst_int n) -> if is_native_immediate n then 1 else 2 - | Lop(Iconst_float s) -> 2 - | Lop(Iconst_symbol s) -> 2 - | Lop(Icall_ind) -> 2 - | Lop(Icall_imm s) -> 1 - | Lop(Itailcall_ind) -> 5 - | Lop(Itailcall_imm s) -> if s = !function_name then 1 else 4 - | Lop(Iextcall(s, true)) -> 3 - | Lop(Iextcall(s, false)) -> if pic_externals then 4 else 1 - | Lop(Istackoffset n) -> 1 - | Lop(Iload(chunk, addr)) -> +module BR = Branch_relaxation.Make (struct + type distance = int + + module Cond_branch = struct + type t = Branch + + let all = [Branch] + + let max_displacement = function + (* 14-bit signed offset in words. *) + | Branch -> 8192 + + let classify_instr = function + | Lop (Ialloc _) + (* [Ialloc_far] does not need to be here, since its code sequence + never involves any conditional branches that might need relaxing. *) + | Lcondbranch _ + | Lcondbranch3 _ -> Some Branch + | _ -> None + end + + let offset_pc_at_branch = 1 + + let size = + match abi with + | ELF32 -> (fun a _ _ -> a) + | ELF64v1 -> (fun _ b _ -> b) + | ELF64v2 -> (fun _ _ c -> c) + + let tocload_size() = + if !big_toc || !Clflags.for_package <> None then 2 else 1 + + let load_store_size = function + | Ibased(_s, d) -> + if abi = ELF32 then 2 else begin + let (_lo, hi) = low_high_s d in + tocload_size() + (if hi = 0 then 1 else 2) + end + | Iindexed ofs -> if is_immediate ofs then 1 else 3 + | Iindexed2 -> 1 + + let instr_size = function + | Lend -> 0 + | Lop(Imove | Ispill | Ireload) -> 1 + | Lop(Iconst_int n) -> + if is_native_immediate n then 1 + else if (let (_lo, hi) = native_low_high_s n in + hi >= -0x8000 && hi <= 0x7FFF) then 2 + else if (let (_lo, hi) = native_low_high_u n in + hi >= -0x8000 && hi <= 0x7FFF) then 2 + else tocload_size() + | Lop(Iconst_float _) -> if abi = ELF32 then 2 else tocload_size() + | Lop(Iconst_symbol _) -> if abi = ELF32 then 2 else tocload_size() + | Lop(Icall_ind _) -> size 2 5 4 + | Lop(Icall_imm _) -> size 1 3 3 + | Lop(Itailcall_ind _) -> size 5 7 6 + | Lop(Itailcall_imm { func; _ }) -> + if func = !function_name + then 1 + else size 4 (7 + tocload_size()) (6 + tocload_size()) + | Lop(Iextcall { alloc = true; _ }) -> + size 3 (2 + tocload_size()) (2 + tocload_size()) + | Lop(Iextcall { alloc = false; _}) -> size 1 2 2 + | Lop(Istackoffset _) -> 1 + | Lop(Iload(chunk, addr)) -> if chunk = Byte_signed then load_store_size addr + 1 else load_store_size addr - | Lop(Istore(chunk, addr)) -> load_store_size addr - | Lop(Ialloc n) -> 4 - | Lop(Ispecific(Ialloc_far n)) -> 5 - | Lop(Iintop Imod) -> 3 - | Lop(Iintop(Icomp cmp)) -> 4 - | Lop(Iintop op) -> 1 - | Lop(Iintop_imm(Idiv, n)) -> 2 - | Lop(Iintop_imm(Imod, n)) -> 4 - | Lop(Iintop_imm(Icomp cmp, n)) -> 4 - | Lop(Iintop_imm(op, n)) -> 1 - | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1 - | Lop(Ifloatofint) -> 9 - | Lop(Iintoffloat) -> 4 - | Lop(Ispecific sop) -> 1 - | Lreloadretaddr -> 2 - | Lreturn -> 2 - | Llabel lbl -> 0 - | Lbranch lbl -> 1 - | Lcondbranch(tst, lbl) -> 2 - | Lcondbranch3(lbl0, lbl1, lbl2) -> + | Lop(Istore(_chunk, addr, _)) -> load_store_size addr + | Lop(Ialloc _) -> 4 + | Lop(Ispecific(Ialloc_far _)) -> 5 + | Lop(Iintop Imod) -> 3 + | Lop(Iintop(Icomp _)) -> 4 + | Lop(Iintop _) -> 1 + | Lop(Iintop_imm(Icomp _, _)) -> 4 + | Lop(Iintop_imm _) -> 1 + | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1 + | Lop(Ifloatofint) -> 9 + | Lop(Iintoffloat) -> 4 + | Lop(Ispecific _) -> 1 + | Lreloadretaddr -> 2 + | Lreturn -> 2 + | Llabel _ -> 0 + | Lbranch _ -> 1 + | Lcondbranch _ -> 2 + | Lcondbranch3(lbl0, lbl1, lbl2) -> 1 + (if lbl0 = None then 0 else 1) + (if lbl1 = None then 0 else 1) + (if lbl2 = None then 0 else 1) - | Lswitch jumptbl -> 8 - | Lsetuptrap lbl -> 1 - | Lpushtrap -> 4 - | Lpoptrap -> 2 - | Lraise -> 6 - -let label_map code = - let map = Hashtbl.create 37 in - let rec fill_map pc instr = - match instr.desc with - Lend -> (pc, map) - | Llabel lbl -> Hashtbl.add map lbl pc; fill_map pc instr.next - | op -> fill_map (pc + instr_size op) instr.next - in fill_map 0 code - -let max_branch_offset = 8180 -(* 14-bit signed offset in words. Remember to cut some slack - for multi-word instructions where the branch can be anywhere in - the middle. 12 words of slack is plenty. *) - -let branch_overflows map pc_branch lbl_dest = - let pc_dest = Hashtbl.find map lbl_dest in - let delta = pc_dest - (pc_branch + 1) in - delta <= -max_branch_offset || delta >= max_branch_offset - -let opt_branch_overflows map pc_branch opt_lbl_dest = - match opt_lbl_dest with - None -> false - | Some lbl_dest -> branch_overflows map pc_branch lbl_dest - -let fixup_branches codesize map code = - let expand_optbranch lbl n arg next = - match lbl with - None -> next - | Some l -> - instr_cons (Lcondbranch(Iinttest_imm(Isigned Ceq, n), l)) - arg [||] next in - let rec fixup did_fix pc instr = - match instr.desc with - Lend -> did_fix - | Lcondbranch(test, lbl) when branch_overflows map pc lbl -> - let lbl2 = new_label() in - let cont = - instr_cons (Lbranch lbl) [||] [||] - (instr_cons (Llabel lbl2) [||] [||] instr.next) in - instr.desc <- Lcondbranch(invert_test test, lbl2); - instr.next <- cont; - fixup true (pc + 2) instr.next - | Lcondbranch3(lbl0, lbl1, lbl2) - when opt_branch_overflows map pc lbl0 - || opt_branch_overflows map pc lbl1 - || opt_branch_overflows map pc lbl2 -> - let cont = - expand_optbranch lbl0 0 instr.arg - (expand_optbranch lbl1 1 instr.arg - (expand_optbranch lbl2 2 instr.arg instr.next)) in - instr.desc <- cont.desc; - instr.next <- cont.next; - fixup true pc instr - | Lop(Ialloc n) when codesize - pc >= max_branch_offset -> - instr.desc <- Lop(Ispecific(Ialloc_far n)); - fixup true (pc + 4) instr.next - | op -> - fixup did_fix (pc + instr_size op) instr.next - in fixup false 0 code - -(* Iterate branch expansion till all conditional branches are OK *) - -let rec branch_normalization code = - let (codesize, map) = label_map code in - if codesize >= max_branch_offset && fixup_branches codesize map code - then branch_normalization code - else () - + | Lswitch _ -> size 7 (5 + tocload_size()) (5 + tocload_size()) + | Lsetuptrap _ -> size 1 2 2 + | Lpushtrap -> size 4 5 5 + | Lpoptrap -> 2 + | Lraise _ -> 6 + + let relax_allocation ~num_words:words ~label_after_call_gc = + Lop (Ispecific (Ialloc_far { words; label_after_call_gc; })) + + (* [classify_addr], above, never identifies these instructions as needing + relaxing. As such, these functions should never be called. *) + let relax_specific_op _ = assert false + let relax_intop_checkbound ~label_after_error:_ = assert false + let relax_intop_imm_checkbound ~bound:_ ~label_after_error:_ = assert false +end) (* Output the assembly code for an instruction *) -let rec emit_instr i dslot = +let emit_instr i = + emit_debug_info i.dbg; match i.desc with - Lend -> () + | Lend -> () | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin match (src, dst) with - {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} -> + | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} -> ` mr {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} -> ` fmr {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} -> + | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} -> ` {emit_string stg} {emit_reg src}, {emit_stack dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + | {loc = Reg _; typ = Float}, {loc = Stack _} -> ` stfd {emit_reg src}, {emit_stack dst}\n` - | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} -> + | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} -> ` {emit_string lg} {emit_reg dst}, {emit_stack src}\n` - | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + | {loc = Stack _; typ = Float}, {loc = Reg _} -> ` lfd {emit_reg dst}, {emit_stack src}\n` | (_, _) -> fatal_error "Emit: Imove" @@ -463,130 +528,223 @@ | Lop(Iconst_int n) -> if is_native_immediate n then ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` - else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin - ` lis {emit_reg i.res.(0)}, {emit_int(nativehigh n)}\n`; - if nativelow n <> 0 then - ` ori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int(nativelow n)}\n` + else begin + (* Try a signed decomposition first, because the sequence + addis/addi is eligible for instruction fusion. *) + let (lo, hi) = native_low_high_s n in + if hi >= -0x8000 && hi <= 0x7FFF then begin + ` addis {emit_reg i.res.(0)}, 0, {emit_int hi}\n`; + if lo <> 0 then + ` addi {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int lo}\n` end else begin + (* Now try an unsigned decomposition *) + let (lo, hi) = native_low_high_u n in + if hi >= -0x8000 && hi <= 0x7FFF then begin + ` addis {emit_reg i.res.(0)}, 0, {emit_int hi}\n`; + if lo <> 0 then + ` ori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int lo}\n` + end else begin + match abi with + | ELF32 -> assert false + | ELF64v1 | ELF64v2 -> + emit_tocload emit_reg i.res.(0) (TocInt n) + end end end + | Lop(Iconst_float f) -> + begin match abi with + | ELF32 -> let lbl = new_label() in - int_literals := (n, lbl) :: !int_literals; - ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; - ` {emit_string lg} {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` + float_literals := (f, lbl) :: !float_literals; + ` addis 11, 0, {emit_upper emit_label lbl}\n`; + ` lfd {emit_reg i.res.(0)}, {emit_lower emit_label lbl}(11)\n` + | ELF64v1 | ELF64v2 -> + let entry = TocFloat f in + let lbl = label_for_tocref entry in + if !big_toc || !Clflags.for_package <> None then begin + ` addis 11, 2, {emit_label lbl}@toc@ha\n`; + ` lfd {emit_reg i.res.(0)}, {emit_label lbl}@toc@l(11) # {emit_tocentry entry}\n` + end else begin + ` lfd {emit_reg i.res.(0)}, {emit_label lbl}@toc(2) # {emit_tocentry entry}\n` + end end - | Lop(Iconst_float s) -> - let lbl = new_label() in - float_literals := (s, lbl) :: !float_literals; - ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; - ` lfd {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` | Lop(Iconst_symbol s) -> - ` addis {emit_reg i.res.(0)}, 0, {emit_upper emit_symbol s}\n`; - ` addi {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_lower emit_symbol s}\n` - | Lop(Icall_ind) -> - ` mtctr {emit_reg i.arg.(0)}\n`; - ` bctrl\n`; - record_frame i.live i.dbg - | Lop(Icall_imm s) -> - ` bl {emit_symbol s}\n`; - record_frame i.live i.dbg - | Lop(Itailcall_ind) -> - let n = frame_size() in - ` mtctr {emit_reg i.arg.(0)}\n`; + begin match abi with + | ELF32 -> + ` addis {emit_reg i.res.(0)}, 0, {emit_upper emit_symbol s}\n`; + ` addi {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_lower emit_symbol s}\n` + | ELF64v1 | ELF64v2 -> + emit_tocload emit_reg i.res.(0) (TocSym s) + end + | Lop(Icall_ind { label_after; }) -> + begin match abi with + | ELF32 -> + ` mtctr {emit_reg i.arg.(0)}\n`; + ` bctrl\n`; + record_frame i.live false i.dbg ~label:label_after + | ELF64v1 -> + ` ld 0, 0({emit_reg i.arg.(0)})\n`; (* code pointer *) + ` mtctr 0\n`; + ` ld 2, 8({emit_reg i.arg.(0)})\n`; (* TOC for callee *) + ` bctrl\n`; + record_frame i.live false i.dbg ~label:label_after; + emit_reload_toc() + | ELF64v2 -> + ` mtctr {emit_reg i.arg.(0)}\n`; + ` mr 12, {emit_reg i.arg.(0)}\n`; (* addr of fn in r12 *) + ` bctrl\n`; + record_frame i.live false i.dbg ~label:label_after; + emit_reload_toc() + end + | Lop(Icall_imm { func; label_after; }) -> + begin match abi with + | ELF32 -> + emit_call func; + record_frame i.live false i.dbg ~label:label_after + | ELF64v1 | ELF64v2 -> + (* For PPC64, we cannot just emit a "bl s; nop" sequence, because + of the following scenario: + - current function f1 calls f2 that has the same TOC + - f2 tailcalls f3 that has a different TOC + Because f1 and f2 have the same TOC, the linker inserted no + code in f1 to save and restore r2 around the call to f2. + Because f2 tailcalls f3, r2 will not be restored to f2's TOC + when f3 returns. So, we're back into f1, with the wrong TOC in r2. + We have two options: + 1- Turn the call into an indirect call, like we do for + Itailcall_imm. Cost: 6 instructions. + 2- Follow the "bl" with an instruction to restore r2 + explicitly. If the called function has a different TOC, + this instruction is redundant with those inserted + by the linker, but this is harmless. + Cost: 3 instructions if same TOC, 7 if different TOC. + Let's try option 2. *) + emit_call func; + record_frame i.live false i.dbg ~label:label_after; + ` nop\n`; + emit_reload_toc() + end + | Lop(Itailcall_ind { label_after = _; }) -> + begin match abi with + | ELF32 -> + ` mtctr {emit_reg i.arg.(0)}\n` + | ELF64v1 -> + ` ld 0, 0({emit_reg i.arg.(0)})\n`; (* code pointer *) + ` mtctr 0\n`; + ` ld 2, 8({emit_reg i.arg.(0)})\n` (* TOC for callee *) + | ELF64v2 -> + ` mtctr {emit_reg i.arg.(0)}\n`; + ` mr 12, {emit_reg i.arg.(0)}\n` (* addr of fn in r12 *) + end; if !contains_calls then begin - ` {emit_string lg} {emit_gpr 11}, {emit_int(n - size_addr)}({emit_gpr 1})\n`; - ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`; - ` mtlr {emit_gpr 11}\n` - end else begin - if n > 0 then - ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n` + ` {emit_string lg} 11, {emit_int(retaddr_offset())}(1)\n`; + ` mtlr 11\n` end; + emit_free_frame(); ` bctr\n` - | Lop(Itailcall_imm s) -> - if s = !function_name then + | Lop(Itailcall_imm { func; label_after = _; }) -> + if func = !function_name then ` b {emit_label !tailrec_entry_point}\n` else begin - let n = frame_size() in + begin match abi with + | ELF32 -> + () + | ELF64v1 -> + emit_tocload emit_gpr 11 (TocSym func); + ` ld 0, 0(11)\n`; (* code pointer *) + ` mtctr 0\n`; + ` ld 2, 8(11)\n` (* TOC for callee *) + | ELF64v2 -> + emit_tocload emit_gpr 12 (TocSym func); (* addr of fn must be in r12 *) + ` mtctr 12\n` + end; if !contains_calls then begin - ` {emit_string lg} {emit_gpr 11}, {emit_int(n - size_addr)}({emit_gpr 1})\n`; - ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`; - ` mtlr {emit_gpr 11}\n` - end else begin - if n > 0 then - ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n` + ` {emit_string lg} 11, {emit_int(retaddr_offset())}(1)\n`; + ` mtlr 11\n` end; - ` b {emit_symbol s}\n` + emit_free_frame(); + begin match abi with + | ELF32 -> + ` b {emit_symbol func}\n` + | ELF64v1 | ELF64v2 -> + ` bctr\n` + end end - | Lop(Iextcall(s, alloc)) -> - if alloc then begin - if pic_externals then begin - external_functions := StringSet.add s !external_functions; - ` addis {emit_gpr 11}, 0, ha16(L{emit_symbol s}$non_lazy_ptr)\n`; - ` {emit_string lg} {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n` - end else begin - ` addis {emit_gpr 11}, 0, {emit_upper emit_symbol s}\n`; - ` addi {emit_gpr 11}, {emit_gpr 11}, {emit_lower emit_symbol s}\n` - end; - ` bl {emit_symbol "caml_c_call"}\n`; - record_frame i.live i.dbg + | Lop(Iextcall { func; alloc; }) -> + if not alloc then begin + emit_call func; + emit_call_nop() end else begin - if pic_externals then begin - external_functions := StringSet.add s !external_functions; - ` addis {emit_gpr 11}, 0, ha16(L{emit_symbol s}$non_lazy_ptr)\n`; - ` {emit_string lg} {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n`; - ` mtctr {emit_gpr 11}\n`; - ` bctrl\n` - end else - ` bl {emit_symbol s}\n` + match abi with + | ELF32 -> + ` addis 28, 0, {emit_upper emit_symbol func}\n`; + ` addi 28, 28, {emit_lower emit_symbol func}\n`; + emit_call "caml_c_call"; + record_frame i.live false i.dbg + | ELF64v1 | ELF64v2 -> + emit_tocload emit_gpr 28 (TocSym func); + emit_call "caml_c_call"; + record_frame i.live false i.dbg; + ` nop\n` end | Lop(Istackoffset n) -> - ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int (-n)}\n`; - stack_offset := !stack_offset + n + ` addi 1, 1, {emit_int (-n)}\n`; + adjust_stack_offset n | Lop(Iload(chunk, addr)) -> let loadinstr = match chunk with - Byte_unsigned -> "lbz" + | Byte_unsigned -> "lbz" | Byte_signed -> "lbz" | Sixteen_unsigned -> "lhz" | Sixteen_signed -> "lha" | Thirtytwo_unsigned -> "lwz" | Thirtytwo_signed -> if ppc64 then "lwa" else "lwz" - | Word -> lg + | Word_int | Word_val -> lg | Single -> "lfs" | Double | Double_u -> "lfd" in emit_load_store loadinstr addr i.arg 0 i.res.(0); if chunk = Byte_signed then ` extsb {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> let storeinstr = match chunk with - Byte_unsigned | Byte_signed -> "stb" + | Byte_unsigned | Byte_signed -> "stb" | Sixteen_unsigned | Sixteen_signed -> "sth" | Thirtytwo_unsigned | Thirtytwo_signed -> "stw" - | Word -> stg + | Word_int | Word_val -> stg | Single -> "stfs" | Double | Double_u -> "stfd" in emit_load_store storeinstr addr i.arg 1 i.arg.(0) - | Lop(Ialloc n) -> - if !call_gc_label = 0 then call_gc_label := new_label(); - ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; - ` {emit_string cmplg} {emit_gpr 31}, {emit_gpr 30}\n`; - ` addi {emit_reg i.res.(0)}, {emit_gpr 31}, {emit_int size_addr}\n`; + | Lop(Ialloc { words = n; label_after_call_gc; }) -> + if !call_gc_label = 0 then begin + match label_after_call_gc with + | None -> call_gc_label := new_label () + | Some label -> call_gc_label := label + end; + ` addi 31, 31, {emit_int(-n)}\n`; + ` {emit_string cmplg} 31, 30\n`; + ` addi {emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`; ` bltl {emit_label !call_gc_label}\n`; - record_frame i.live Debuginfo.none - | Lop(Ispecific(Ialloc_far n)) -> - if !call_gc_label = 0 then call_gc_label := new_label(); + (* Exactly 4 instructions after the beginning of the alloc sequence *) + record_frame i.live false Debuginfo.none + | Lop(Ispecific(Ialloc_far { words = n; label_after_call_gc; })) -> + if !call_gc_label = 0 then begin + match label_after_call_gc with + | None -> call_gc_label := new_label () + | Some label -> call_gc_label := label + end; let lbl = new_label() in - ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; - ` {emit_string cmplg} {emit_gpr 31}, {emit_gpr 30}\n`; + ` addi 31, 31, {emit_int(-n)}\n`; + ` {emit_string cmplg} 31, 30\n`; ` bge {emit_label lbl}\n`; ` bl {emit_label !call_gc_label}\n`; - record_frame i.live Debuginfo.none; - `{emit_label lbl}: addi {emit_reg i.res.(0)}, {emit_gpr 31}, {emit_int size_addr}\n` + (* Exactly 4 instructions after the beginning of the alloc sequence *) + record_frame i.live false Debuginfo.none; + `{emit_label lbl}: addi {emit_reg i.res.(0)}, 31, {emit_int size_addr}\n` | Lop(Iintop Isub) -> (* subfc has swapped arguments *) ` subfc {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` | Lop(Iintop Imod) -> - ` {emit_string divg} {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - ` {emit_string mullg} {emit_gpr 0}, {emit_gpr 0}, {emit_reg i.arg.(1)}\n`; - ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` + ` {emit_string divg} 0, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` {emit_string mullg} 0, 0, {emit_reg i.arg.(1)}\n`; + ` subfc {emit_reg i.res.(0)}, 0, {emit_reg i.arg.(0)}\n` | Lop(Iintop(Icomp cmp)) -> begin match cmp with Isigned c -> @@ -596,25 +754,15 @@ ` {emit_string cmplg} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; emit_set_comp c i.res.(0) end - | Lop(Iintop Icheckbound) -> - if !Clflags.debug && supports_backtraces then - record_frame Reg.Set.empty i.dbg; + | Lop(Iintop (Icheckbound { label_after_error; })) -> + if !Clflags.debug then + record_frame Reg.Set.empty false i.dbg ?label:label_after_error; ` {emit_string tglle} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> let instr = name_for_intop op in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop_imm(Isub, n)) -> ` addi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n` - | Lop(Iintop_imm(Idiv, n)) -> (* n is guaranteed to be a power of 2 *) - let l = Misc.log2 n in - ` {emit_string sragi} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int l}\n`; - ` addze {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Imod, n)) -> (* n is guaranteed to be a power of 2 *) - let l = Misc.log2 n in - ` {emit_string sragi} {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`; - ` addze {emit_gpr 0}, {emit_gpr 0}\n`; - ` {emit_string slgi} {emit_gpr 0}, {emit_gpr 0}, {emit_int l}\n`; - ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` | Lop(Iintop_imm(Icomp cmp, n)) -> begin match cmp with Isigned c -> @@ -624,9 +772,9 @@ ` {emit_string cmplg}i {emit_reg i.arg.(0)}, {emit_int n}\n`; emit_set_comp c i.res.(0) end - | Lop(Iintop_imm(Icheckbound, n)) -> - if !Clflags.debug && supports_backtraces then - record_frame Reg.Set.empty i.dbg; + | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) -> + if !Clflags.debug then + record_frame Reg.Set.empty false i.dbg ?label:label_after_error; ` {emit_string tglle}i {emit_reg i.arg.(0)}, {emit_int n}\n` | Lop(Iintop_imm(op, n)) -> let instr = name_for_intop_imm op in @@ -639,41 +787,43 @@ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Ifloatofint) -> if ppc64 then begin - ` stdu {emit_reg i.arg.(0)}, -16({emit_gpr 1})\n`; - ` lfd {emit_reg i.res.(0)}, 0({emit_gpr 1})\n`; - ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; + (* Can use protected zone (288 bytes below r1 *) + ` std {emit_reg i.arg.(0)}, -16(1)\n`; + ` lfd {emit_reg i.res.(0)}, -16(1)\n`; ` fcfid {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` end else begin let lbl = new_label() in - float_literals := ("4.503601774854144e15", lbl) :: !float_literals; - (* That float above represents 0x4330000080000000 *) - ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; - ` lfd {emit_fpr 0}, {emit_lower emit_label lbl}({emit_gpr 11})\n`; - ` lis {emit_gpr 0}, 0x4330\n`; - ` stwu {emit_gpr 0}, -16({emit_gpr 1})\n`; - ` xoris {emit_gpr 0}, {emit_reg i.arg.(0)}, 0x8000\n`; - ` stw {emit_gpr 0}, 4({emit_gpr 1})\n`; - ` lfd {emit_reg i.res.(0)}, 0({emit_gpr 1})\n`; - ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; - ` fsub {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_fpr 0}\n` + float_literals := (0x4330000080000000L, lbl) :: !float_literals; + ` addis 11, 0, {emit_upper emit_label lbl}\n`; + ` lfd 0, {emit_lower emit_label lbl}(11)\n`; + ` lis 0, 0x4330\n`; + ` stwu 0, -16(1)\n`; + ` xoris 0, {emit_reg i.arg.(0)}, 0x8000\n`; + ` stw 0, 4(1)\n`; + ` lfd {emit_reg i.res.(0)}, 0(1)\n`; + ` addi 1, 1, 16\n`; + ` fsub {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 0\n` end | Lop(Iintoffloat) -> - let ofs = if ppc64 then 0 else 4 in - ` {emit_string fctigz} {emit_fpr 0}, {emit_reg i.arg.(0)}\n`; - ` stfdu {emit_fpr 0}, -16({emit_gpr 1})\n`; - ` {emit_string lg} {emit_reg i.res.(0)}, {emit_int ofs}({emit_gpr 1})\n`; - ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n` + if ppc64 then begin + (* Can use protected zone (288 bytes below r1 *) + ` fctidz 0, {emit_reg i.arg.(0)}\n`; + ` stfd 0, -16(1)\n`; + ` ld {emit_reg i.res.(0)}, -16(1)\n` + end else begin + ` fctiwz 0, {emit_reg i.arg.(0)}\n`; + ` stfdu 0, -16(1)\n`; + ` lwz {emit_reg i.res.(0)}, 4(1)\n`; + ` addi 1, 1, 16\n` + end | Lop(Ispecific sop) -> let instr = name_for_specific sop in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n` | Lreloadretaddr -> - let n = frame_size() in - ` {emit_string lg} {emit_gpr 11}, {emit_int(n - size_addr)}({emit_gpr 1})\n`; - ` mtlr {emit_gpr 11}\n` + ` {emit_string lg} 11, {emit_int(retaddr_offset())}(1)\n`; + ` mtlr 11\n` | Lreturn -> - let n = frame_size() in - if n > 0 then - ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`; + emit_free_frame(); ` blr\n` | Llabel lbl -> `{emit_label lbl}:\n` @@ -683,24 +833,20 @@ begin match tst with Itruetest -> ` {emit_string cmpg}i {emit_reg i.arg.(0)}, 0\n`; - emit_delay dslot; ` bne {emit_label lbl}\n` | Ifalsetest -> ` {emit_string cmpg}i {emit_reg i.arg.(0)}, 0\n`; - emit_delay dslot; ` beq {emit_label lbl}\n` | Iinttest cmp -> let (comp, branch) = name_for_int_comparison cmp in ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - emit_delay dslot; ` {emit_string branch} {emit_label lbl}\n` | Iinttest_imm(cmp, n) -> let (comp, branch) = name_for_int_comparison cmp in ` {emit_string comp}i {emit_reg i.arg.(0)}, {emit_int n}\n`; - emit_delay dslot; ` {emit_string branch} {emit_label lbl}\n` | Ifloattest(cmp, neg) -> - ` fcmpu {emit_ccr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` fcmpu 0, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; (* bit 0 = lt, bit 1 = gt, bit 2 = eq *) let (bitnum, negtst) = match cmp with @@ -712,22 +858,18 @@ | Cge -> ` cror 3, 1, 2\n`; (* gt or eq *) (3, neg) | Clt -> (0, neg) in - emit_delay dslot; if negtst then ` bf {emit_int bitnum}, {emit_label lbl}\n` else ` bt {emit_int bitnum}, {emit_label lbl}\n` | Ioddtest -> - ` andi. {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`; - emit_delay dslot; + ` andi. 0, {emit_reg i.arg.(0)}, 1\n`; ` bne {emit_label lbl}\n` | Ieventest -> - ` andi. {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`; - emit_delay dslot; + ` andi. 0, {emit_reg i.arg.(0)}, 1\n`; ` beq {emit_label lbl}\n` end | Lcondbranch3(lbl0, lbl1, lbl2) -> ` {emit_string cmpg}i {emit_reg i.arg.(0)}, 1\n`; - emit_delay dslot; begin match lbl0 with None -> () | Some lbl -> ` blt {emit_label lbl}\n` @@ -742,166 +884,224 @@ end | Lswitch jumptbl -> let lbl = new_label() in - ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; - ` addi {emit_gpr 11}, {emit_gpr 11}, {emit_lower emit_label lbl}\n`; - ` {emit_string slgi} {emit_gpr 0}, {emit_reg i.arg.(0)}, 2\n`; - ` {emit_string lwa}x {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`; - ` add {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`; - ` mtctr {emit_gpr 0}\n`; + if ppc64 then begin + if !jumptables_lbl < 0 then jumptables_lbl := lbl; + let start = List.length !jumptables in + let (start_lo, start_hi) = low_high_s start in + emit_tocload emit_gpr 11 (TocLabel !jumptables_lbl); + ` addi 12, {emit_reg i.arg.(0)}, {emit_int start_lo}\n`; + if start_hi <> 0 then + ` addis 12, 12, {emit_int start_hi}\n`; + ` sldi 12, 12, 2\n` + end else begin + ` addis 11, 0, {emit_upper emit_label lbl}\n`; + ` addi 11, 11, {emit_lower emit_label lbl}\n`; + ` slwi 12, {emit_reg i.arg.(0)}, 2\n` + end; + ` {emit_string lwa}x 0, 11, 12\n`; + ` add 0, 11, 0\n`; + ` mtctr 0\n`; ` bctr\n`; - emit_string rodata_space; - `{emit_label lbl}:`; - for i = 0 to Array.length jumptbl - 1 do - ` .long {emit_label jumptbl.(i)} - {emit_label lbl}\n` - done; - emit_string code_space + if ppc64 then begin + jumptables := List.rev_append (Array.to_list jumptbl) !jumptables + end else begin + emit_string rodata_space; + `{emit_label lbl}:`; + for i = 0 to Array.length jumptbl - 1 do + ` .long {emit_label jumptbl.(i)} - {emit_label lbl}\n` + done; + emit_string code_space + end | Lsetuptrap lbl -> - ` bl {emit_label lbl}\n` + ` bl {emit_label lbl}\n`; + begin match abi with + | ELF32 -> () + | ELF64v1 | ELF64v2 -> emit_reload_toc() + end | Lpushtrap -> - stack_offset := !stack_offset + 16; - ` mflr {emit_gpr 0}\n`; - ` {emit_string stg}u {emit_gpr 0}, -16({emit_gpr 1})\n`; - ` {emit_string stg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; - ` mr {emit_gpr 29}, {emit_gpr 1}\n` + begin match abi with + | ELF32 -> + ` mflr 0\n`; + ` stwu 0, -16(1)\n`; + adjust_stack_offset 16; + ` stw 29, 4(1)\n`; + ` mr 29, 1\n` + | ELF64v1 | ELF64v2 -> + ` mflr 0\n`; + ` addi 1, 1, -32\n`; + adjust_stack_offset 32; + ` std 0, {emit_int trap_handler_offset}(1)\n`; + ` std 29, {emit_int trap_previous_offset}(1)\n`; + ` mr 29, 1\n` + end | Lpoptrap -> - ` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; - ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; - stack_offset := !stack_offset - 16 - | Lraise -> - if !Clflags.debug && supports_backtraces then begin - ` bl {emit_symbol "caml_raise_exn"}\n`; - record_frame Reg.Set.empty i.dbg - end else begin - ` {emit_string lg} {emit_gpr 0}, 0({emit_gpr 29})\n`; - ` mr {emit_gpr 1}, {emit_gpr 29}\n`; - ` mtlr {emit_gpr 0}\n`; - ` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; - ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; - ` blr\n` - end - -and emit_delay = function - None -> () - | Some i -> emit_instr i None + ` {emit_string lg} 29, {emit_int trap_previous_offset}(1)\n`; + ` addi 1, 1, {emit_int trap_size}\n`; + adjust_stack_offset (-trap_size) + | Lraise k -> + begin match k with + | Cmm.Raise_withtrace -> + emit_call "caml_raise_exn"; + record_frame Reg.Set.empty true i.dbg; + emit_call_nop() + | Cmm.Raise_notrace -> + ` {emit_string lg} 0, {emit_int trap_handler_offset}(29)\n`; + ` mr 1, 29\n`; + ` mtctr 0\n`; + ` {emit_string lg} 29, {emit_int trap_previous_offset}(1)\n`; + ` addi 1, 1, {emit_int trap_size}\n`; + ` bctr\n` + end -(* Checks if a pseudo-instruction expands to instructions - that do not branch and do not affect CR0 nor R12. *) +(* Emit a sequence of instructions *) -let is_simple_instr i = +let rec emit_all i = match i.desc with - Lop op -> - begin match op with - Icall_imm _ | Icall_ind | Itailcall_imm _ | Itailcall_ind | - Iextcall(_, _) -> false - | Ialloc(_) -> false - | Iintop(Icomp _) -> false - | Iintop_imm(Iand, _) -> false - | Iintop_imm(Icomp _, _) -> false - | _ -> true - end - | Lreloadretaddr -> true - | _ -> false + | Lend -> () + | _ -> emit_instr i; emit_all i.next -let no_interference res arg = - try - for i = 0 to Array.length arg - 1 do - for j = 0 to Array.length res - 1 do - if arg.(i).loc = res.(j).loc then raise Exit - done - done; - true - with Exit -> - false - -(* Emit a sequence of instructions, trying to fill delay slots for branches *) +(* Emission of the profiling prelude *) -let rec emit_all i = - match i with - {desc = Lend} -> () - | {next = {desc = (Lcondbranch(_, _) | Lcondbranch3(_, _, _))}} - when is_simple_instr i && no_interference i.res i.next.arg -> - emit_instr i.next (Some i); - emit_all i.next.next - | _ -> - emit_instr i None; - emit_all i.next +let emit_profile () = + match abi with + | ELF32 -> + ` mflr 0\n`; + ` addi 1, 1, -16\n`; + ` stw 0, 4(1)\n`; + (* _mcount preserves the registers used for parameter passing *) + (* when it returns, lr contains the original return address *) + ` bl {emit_symbol "_mcount"}\n`; + ` addi 1, 1, 16\n` + | ELF64v1 | ELF64v2 -> + ` mflr 0\n`; + (* save the registers used for parameter passing *) + ` bl {emit_symbol "caml_before_mcount"}\n`; + ` bl {emit_symbol "_mcount"}\n`; + ` nop\n`; + (* restore the registers used for parameter passing *) + ` bl {emit_symbol "caml_after_mcount"}\n`; + ` mtlr 0\n` (* Emission of a function declaration *) let fundecl fundecl = function_name := fundecl.fun_name; - defined_functions := StringSet.add fundecl.fun_name !defined_functions; tailrec_entry_point := new_label(); stack_offset := 0; call_gc_label := 0; float_literals := []; - int_literals := []; - if Config.system = "rhapsody" - && not !Clflags.output_c_object - && is_generic_function fundecl.fun_name - then (* PR#4690 *) - ` .private_extern {emit_symbol fundecl.fun_name}\n` - else - ` .globl {emit_symbol fundecl.fun_name}\n`; - begin match Config.system with - | "elf" | "bsd" | "bsd_elf" -> - ` .type {emit_symbol fundecl.fun_name}, @function\n` - | _ -> () + jumptables := []; jumptables_lbl := -1; + begin match abi with + | ELF32 -> + emit_string code_space; + ` .globl {emit_symbol fundecl.fun_name}\n`; + ` .type {emit_symbol fundecl.fun_name}, @function\n`; + ` .align 2\n`; + `{emit_symbol fundecl.fun_name}:\n` + | ELF64v1 -> + emit_string function_descr_space; + ` .align 3\n`; + ` .globl {emit_symbol fundecl.fun_name}\n`; + ` .type {emit_symbol fundecl.fun_name}, @function\n`; + `{emit_symbol fundecl.fun_name}:\n`; + ` .quad .L.{emit_symbol fundecl.fun_name}, .TOC.@tocbase\n`; + emit_string code_space; + ` .align 2\n`; + `.L.{emit_symbol fundecl.fun_name}:\n` + | ELF64v2 -> + emit_string code_space; + ` .globl {emit_symbol fundecl.fun_name}\n`; + ` .type {emit_symbol fundecl.fun_name}, @function\n`; + ` .align 2\n`; + `{emit_symbol fundecl.fun_name}:\n`; + `0: addis 2, 12, (.TOC. - 0b)@ha\n`; + ` addi 2, 2, (.TOC. - 0b)@l\n`; + ` .localentry {emit_symbol fundecl.fun_name}, . - 0b\n` end; - emit_string code_space; - ` .align 2\n`; - `{emit_symbol fundecl.fun_name}:\n`; + emit_debug_info fundecl.fun_dbg; + cfi_startproc(); + if !Clflags.gprofile then emit_profile(); let n = frame_size() in + if n > 0 then begin + ` addi 1, 1, {emit_int(-n)}\n`; + cfi_adjust_cfa_offset n + end; if !contains_calls then begin - ` mflr {emit_gpr 0}\n`; - ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n`; - ` {emit_string stg} {emit_gpr 0}, {emit_int(n - size_addr)}({emit_gpr 1})\n` - end else begin - if n > 0 then - ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n` + let ra = retaddr_offset() in + ` mflr 0\n`; + ` {emit_string stg} 0, {emit_int ra}(1)\n`; + cfi_offset ~reg: 65 (* LR *) ~offset: (ra - n); + match abi with + | ELF32 -> () + | ELF64v1 | ELF64v2 -> + ` std 2, {emit_int(toc_save_offset())}(1)\n` end; `{emit_label !tailrec_entry_point}:\n`; - branch_normalization fundecl.fun_body; + (* On this target, there is at most one "out of line" code block per + function: a single "call GC" point. It comes immediately after the + function's body. *) + BR.relax fundecl.fun_body ~max_out_of_line_code_offset:0; emit_all fundecl.fun_body; (* Emit the glue code to call the GC *) if !call_gc_label > 0 then begin `{emit_label !call_gc_label}:\n`; - ` b {emit_symbol "caml_call_gc"}\n` + match abi with + | ELF32 -> + ` b {emit_symbol "caml_call_gc"}\n` + | ELF64v1 -> + ` std 2, 40(1)\n`; + (* save our TOC, will be restored by caml_call_gc *) + emit_tocload emit_gpr 11 (TocSym "caml_call_gc"); + ` ld 0, 0(11)\n`; + ` mtctr 0\n`; + ` ld 2, 8(11)\n`; + ` bctr\n` + | ELF64v2 -> + ` std 2, 24(1)\n`; + (* save our TOC, will be restored by caml_call_gc *) + emit_tocload emit_gpr 12 (TocSym "caml_call_gc"); + ` mtctr 12\n`; + ` bctr\n` + end; + cfi_endproc(); + begin match abi with + | ELF32 | ELF64v2 -> + ` .size {emit_symbol fundecl.fun_name}, . - {emit_symbol fundecl.fun_name}\n` + | ELF64v1 -> + ` .size {emit_symbol fundecl.fun_name}, . - .L.{emit_symbol fundecl.fun_name}\n` end; (* Emit the numeric literals *) - if !float_literals <> [] || !int_literals <> [] then begin + if !float_literals <> [] then begin emit_string rodata_space; ` .align 3\n`; List.iter (fun (f, lbl) -> `{emit_label lbl}:`; - if ppc64 - then emit_float64_directive ".quad" f - else emit_float64_split_directive ".long" f) - !float_literals; + emit_float64_split_directive ".long" f) + !float_literals + end; + (* Emit the jump tables *) + if !jumptables <> [] then begin + emit_string rodata_space; + ` .align 2\n`; + `{emit_label !jumptables_lbl}:`; List.iter - (fun (n, lbl) -> - `{emit_label lbl}: {emit_string datag} {emit_nativeint n}\n`) - !int_literals + (fun lbl -> + ` .long {emit_label lbl} - {emit_label !jumptables_lbl}\n`) + (List.rev !jumptables) end (* Emission of data *) let declare_global_data s = ` .globl {emit_symbol s}\n`; - match Config.system with - | "elf" | "bsd" | "bsd_elf" -> - ` .type {emit_symbol s}, @object\n` - | "rhapsody" -> () - | _ -> assert false + ` .type {emit_symbol s}, @object\n` let emit_item = function Cglobal_symbol s -> declare_global_data s | Cdefine_symbol s -> `{emit_symbol s}:\n`; - | Cdefine_label lbl -> - `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> @@ -911,15 +1111,13 @@ | Cint n -> ` {emit_string datag} {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".long" f + emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> if ppc64 - then emit_float64_directive ".quad" f - else emit_float64_split_directive ".long" f + then emit_float64_directive ".quad" (Int64.bits_of_float f) + else emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` {emit_string datag} {emit_symbol s}\n` - | Clabel_address lbl -> - ` {emit_string datag} {emit_data_label lbl}\n` | Cstring s -> emit_bytes_directive " .byte " s | Cskip n -> @@ -929,33 +1127,69 @@ let data l = emit_string data_space; + ` .align {emit_int (if ppc64 then 3 else 2)}\n`; List.iter emit_item l (* Beginning / end of an assembly file *) let begin_assembly() = - defined_functions := StringSet.empty; - external_functions := StringSet.empty; + reset_debug_info(); + ` .file \"\"\n`; (* PR#7037 *) + begin match abi with + | ELF64v2 -> ` .abiversion 2\n` + | _ -> () + end; + Hashtbl.clear tocref_entries; (* Emit the beginning of the segments *) let lbl_begin = Compilenv.make_symbol (Some "data_begin") in emit_string data_space; declare_global_data lbl_begin; `{emit_symbol lbl_begin}:\n`; let lbl_begin = Compilenv.make_symbol (Some "code_begin") in - emit_string code_space; + emit_string function_descr_space; + (* For the ELF64v1 ABI, we must make sure that the .opd and .data + sections are in different pages. .opd comes after .data, + so aligning .opd is enough. To save space, we do it only + for the startup file, not for every OCaml compilation unit. *) + let c = Compilenv.current_unit_name() in + if abi = ELF64v1 && (c = "_startup" || c = "_shared_startup") then begin + ` .p2align 12\n` + end; declare_global_data lbl_begin; `{emit_symbol lbl_begin}:\n` let end_assembly() = - if pic_externals then - (* Emit the pointers to external functions *) - StringSet.iter emit_external !external_functions; + (* In profiling mode, for ELF64, emit the helper functions + for register saving and restoring. We put one copy of these + functions in every generated file, instead of defining + them once in asmrun/power.S, so that we can call them + without risking to save r2 in the wrong place. *) + if ppc64 && !Clflags.gprofile then begin + let save_area = reserved_stack_space + (if abi = ELF64v1 then 8*8 else 0) in + let stacksize = save_area + 8*8 in + emit_string code_space; + ` .align 2\n`; + `{emit_symbol "caml_before_mcount"}:\n`; + ` stdu 1, {emit_int (-stacksize)}(1)\n`; + ` std 0, {emit_int (16 + stacksize)}(1)\n`; + for i = 3 to 10 do + ` std {emit_gpr i}, {emit_int (save_area + (i - 3) * 8)}(1)\n` + done; + ` blr\n`; + `{emit_symbol "caml_after_mcount"}:\n`; + ` ld 0, {emit_int (16 + stacksize)}(1)\n`; + for i = 3 to 10 do + ` ld {emit_gpr i}, {emit_int (save_area + (i - 3) * 8)}(1)\n` + done; + ` addi 1, 1, {emit_int stacksize}\n`; + ` blr\n` + end; (* Emit the end of the segments *) - emit_string code_space; + emit_string function_descr_space; let lbl_end = Compilenv.make_symbol (Some "code_end") in declare_global_data lbl_end; `{emit_symbol lbl_end}:\n`; - ` .long 0\n`; + if abi <> ELF64v1 then ` .long 0\n`; emit_string data_space; let lbl_end = Compilenv.make_symbol (Some "data_end") in declare_global_data lbl_end; @@ -967,13 +1201,25 @@ declare_global_data lbl; `{emit_symbol lbl}:\n`; emit_frames - { efa_label = (fun l -> ` {emit_string datag} {emit_label l}\n`); + { efa_code_label = + (fun l -> ` {emit_string datag} {emit_label l}\n`); + efa_data_label = + (fun l -> ` {emit_string datag} {emit_label l}\n`); efa_16 = (fun n -> ` .short {emit_int n}\n`); efa_32 = (fun n -> ` .long {emit_int32 n}\n`); efa_word = (fun n -> ` {emit_string datag} {emit_int n}\n`); - efa_align = (fun n -> ` .align {emit_int (Misc.log2 n)}\n`); + efa_align = (fun n -> ` .balign {emit_int n}\n`); efa_label_rel = (fun lbl ofs -> ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`); efa_def_label = (fun l -> `{emit_label l}:\n`); efa_string = (fun s -> emit_bytes_directive " .byte " (s ^ "\000")) - } + }; + (* Emit the TOC entries *) + begin match abi with + | ELF32 -> () + | ELF64v1 | ELF64v2 -> + emit_string toc_space; + emit_toctable(); + Hashtbl.clear tocref_entries + end; + ` .section .note.GNU-stack,\"\",%progbits\n` diff -Nru ocaml-4.01.0/asmcomp/power/NOTES.md ocaml-4.05.0/asmcomp/power/NOTES.md --- ocaml-4.01.0/asmcomp/power/NOTES.md 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/power/NOTES.md 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,26 @@ +# Supported platforms + +IBM POWER and Freescale (nee Motorola) PowerPC processors, in three flavors: +* 32 bits, ELF ABI: Debian's `powerpc` +* 64 bits big-endian, ELF ABI v1: Debian's `powerpc` +* 64 bits little-endian, ELF ABI v2: Debian's `ppc64el` + +No longer supported: AIX and MacOS X. + +# Reference documents + +* Instruction set architecture: + _PowerPC User Instruction Set Architecture_, + book 1 of _PowerPC Architecture Book_ + (http://www.ibm.com/developerworks/systems/library/es-archguide-v2.html). +* ELF ABI 32 bits: + _System V Application Binary Interface, PowerPC Processor Supplement_ +* ELF ABI 64 bits version 1: + _64-bit PowerPC ELF Application Binary Interface Supplement_ + (http://refspecs.linuxfoundation.org/ELF/ppc64/PPC-elf64abi.html) +* ELF ABI 64 bits version 2: + _Power Architecture 64-bit ELF V2 ABI Specification, + OpenPOWER ABI for Linux Supplement_ + (http://openpowerfoundation.org/technical/technical-resources/technical-specifications/) +* _The PowerPC Compiler Writer's Guide_, Warthman Associates, 1996. + (PDF available from various sources on the Web.) diff -Nru ocaml-4.01.0/asmcomp/power/proc.ml ocaml-4.05.0/asmcomp/power/proc.ml --- ocaml-4.01.0/asmcomp/power/proc.ml 2013-06-24 08:16:27.000000000 +0000 +++ ocaml-4.05.0/asmcomp/power/proc.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Description of the Power PC *) @@ -42,33 +45,21 @@ *) let int_reg_name = - if Config.system = "rhapsody" then - [| "r3"; "r4"; "r5"; "r6"; "r7"; "r8"; "r9"; "r10"; - "r14"; "r15"; "r16"; "r17"; "r18"; "r19"; "r20"; "r21"; - "r22"; "r23"; "r24"; "r25"; "r26"; "r27"; "r28" |] - else - [| "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10"; - "14"; "15"; "16"; "17"; "18"; "19"; "20"; "21"; - "22"; "23"; "24"; "25"; "26"; "27"; "28" |] + [| "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10"; + "14"; "15"; "16"; "17"; "18"; "19"; "20"; "21"; + "22"; "23"; "24"; "25"; "26"; "27"; "28" |] let float_reg_name = - if Config.system = "rhapsody" then - [| "f1"; "f2"; "f3"; "f4"; "f5"; "f6"; "f7"; "f8"; - "f9"; "f10"; "f11"; "f12"; "f13"; "f14"; "f15"; "f16"; - "f17"; "f18"; "f19"; "f20"; "f21"; "f22"; "f23"; "f24"; - "f25"; "f26"; "f27"; "f28"; "f29"; "f30"; "f31" |] - else - [| "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; - "9"; "10"; "11"; "12"; "13"; "14"; "15"; "16"; - "17"; "18"; "19"; "20"; "21"; "22"; "23"; "24"; - "25"; "26"; "27"; "28"; "29"; "30"; "31" |] + [| "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; + "9"; "10"; "11"; "12"; "13"; "14"; "15"; "16"; + "17"; "18"; "19"; "20"; "21"; "22"; "23"; "24"; + "25"; "26"; "27"; "28"; "29"; "30"; "31" |] let num_register_classes = 2 let register_class r = match r.typ with - Int -> 0 - | Addr -> 0 + | Val | Int | Addr -> 0 | Float -> 1 let num_available_registers = [| 23; 31 |] @@ -83,11 +74,11 @@ (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 23 Reg.dummy in + let v = Array.make 23 Reg.dummy in for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 31 Reg.dummy in + let v = Array.make 31 Reg.dummy in for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v let all_phys_regs = @@ -99,107 +90,177 @@ let stack_slot slot ty = Reg.at_location ty (Stack slot) +let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *) + (* Calling conventions *) let calling_conventions - first_int last_int first_float last_float make_stack stack_ofs arg = - let loc = Array.create (Array.length arg) Reg.dummy in + first_int last_int first_float last_float + make_stack stack_ofs reg_use_stack arg = + let loc = Array.make (Array.length arg) [| Reg.dummy |] in let int = ref first_int in let float = ref first_float in let ofs = ref stack_ofs in for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int <= last_int then begin - loc.(i) <- phys_reg !int; - incr int - end else begin - loc.(i) <- stack_slot (make_stack !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; - incr float - end else begin - loc.(i) <- stack_slot (make_stack !ofs) Float; - ofs := !ofs + size_float - end + match arg.(i) with + | [| arg |] -> + begin match arg.typ with + | Val | Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- [| phys_reg !int |]; + incr int; + if reg_use_stack then ofs := !ofs + size_int + end else begin + loc.(i) <- [| stack_slot (make_stack !ofs) ty |]; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- [| phys_reg !float |]; + incr float; + (* On 64-bit platforms, passing a float in a float register + reserves a normal register as well *) + if size_int = 8 then incr int; + if reg_use_stack then ofs := !ofs + size_float + end else begin + ofs := Misc.align !ofs size_float; + loc.(i) <- [| stack_slot (make_stack !ofs) Float |]; + ofs := !ofs + size_float + end + end + | [| arg1; arg2 |] -> + (* Passing of 64-bit quantities to external functions + on 32-bit platform. *) + assert (size_int = 4); + begin match arg1.typ, arg2.typ with + | Int, Int -> + (* 64-bit quantities split across two registers must either be in a + consecutive pair of registers where the lowest numbered is an + even-numbered register; or in a stack slot that is 8-byte + aligned. *) + int := Misc.align !int 2; + if !int <= last_int - 1 then begin + let reg_lower = phys_reg !int in + let reg_upper = phys_reg (!int + 1) in + loc.(i) <- [| reg_lower; reg_upper |]; + int := !int + 2 + end else begin + let size_int64 = 8 in + ofs := Misc.align !ofs size_int64; + let ofs_lower = !ofs in + let ofs_upper = !ofs + size_int in + let stack_lower = stack_slot (make_stack ofs_lower) Int in + let stack_upper = stack_slot (make_stack ofs_upper) Int in + loc.(i) <- [| stack_lower; stack_upper |]; + ofs := !ofs + size_int64 + end + | _, _ -> + let f = function Int -> "I" | Addr -> "A" | Val -> "V" | Float -> "F" in + fatal_error (Printf.sprintf "Proc.calling_conventions: bad register \ + type(s) for multi-register argument: %s, %s" + (f arg1.typ) (f arg2.typ)) + end + | _ -> + fatal_error "Proc.calling_conventions: bad number of registers for \ + multi-register argument" done; (loc, Misc.align !ofs 16) (* Keep stack 16-aligned. *) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" + +let single_regs arg = Array.map (fun arg -> [| arg |]) arg +let ensure_single_regs res = + Array.map (function + | [| res |] -> res + | _ -> failwith "Proc.ensure_single_regs") + res + +let max_arguments_for_tailcalls = 8 let loc_arguments arg = - calling_conventions 0 7 100 112 outgoing 0 arg + let (loc, ofs) = + calling_conventions 0 7 100 112 outgoing 0 false (single_regs arg) + in + (ensure_single_regs loc, ofs) let loc_parameters arg = - let (loc, ofs) = calling_conventions 0 7 100 112 incoming 0 arg in loc + let (loc, _ofs) = + calling_conventions 0 7 100 112 incoming 0 false (single_regs arg) + in + ensure_single_regs loc let loc_results res = - let (loc, ofs) = calling_conventions 0 7 100 112 not_supported 0 res in loc - -(* C calling conventions under PowerOpen: - use GPR 3-10 and FPR 1-13 just like ML calling - conventions, but always reserve stack space for all arguments. - Also, using a float register automatically reserves two int registers - (in 32-bit mode) or one int register (in 64-bit mode). - (If we were to call a non-prototyped C function, each float argument - would have to go both in a float reg and in the matching pair - of integer regs.) + let (loc, _ofs) = + calling_conventions 0 7 100 112 not_supported 0 false (single_regs res) + in + ensure_single_regs loc - C calling conventions under SVR4: +(* C calling conventions for ELF32: use GPR 3-10 and FPR 1-8 just like ML calling conventions. Using a float register does not affect the int registers. Always reserve 8 bytes at bottom of stack, plus whatever is needed - to hold the overflow arguments. *) - -let poweropen_external_conventions first_int last_int - first_float last_float arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref first_int in - let float = ref first_float in - let ofs = ref (14 * size_addr) in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int <= last_int then begin - loc.(i) <- phys_reg !int; - incr int - end else begin - loc.(i) <- stack_slot (Outgoing !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; - incr float - end else begin - loc.(i) <- stack_slot (Outgoing !ofs) Float; - ofs := !ofs + size_float - end; - int := !int + (if ppc64 then 1 else 2) - done; - (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) + to hold the overflow arguments. + C calling conventions for ELF64v1: + Use GPR 3-10 for the first integer arguments. + Use FPR 1-13 for the first float arguments. + Always reserve stack space for all arguments, even when passed in + registers. + Always reserve at least 8 words (64 bytes) for the arguments. + Always reserve 48 bytes at bottom of stack, plus whatever is needed + to hold the arguments. + The reserved 48 bytes are automatically added in emit.mlp + and need not appear here. + C calling conventions for ELF64v2: + Use GPR 3-10 for the first integer arguments. + Use FPR 1-13 for the first float arguments. + If all arguments fit in registers, don't reserve stack space. + Otherwise, reserve stack space for all arguments. + Always reserve 32 bytes at bottom of stack, plus whatever is needed + to hold the arguments. + The reserved 32 bytes are automatically added in emit.mlp + and need not appear here. +*) let loc_external_arguments = - match Config.system with - | "rhapsody" -> poweropen_external_conventions 0 7 100 112 - | "elf" | "bsd" | "bsd_elf" -> calling_conventions 0 7 100 107 outgoing 8 - | _ -> assert false - -let extcall_use_push = false + match abi with + | ELF32 -> + calling_conventions 0 7 100 107 outgoing 8 false + | ELF64v1 -> + fun args -> + let (loc, ofs) = + calling_conventions 0 7 100 112 outgoing 0 true args in + (loc, max ofs 64) + | ELF64v2 -> + fun args -> + let (loc, ofs) = + calling_conventions 0 7 100 112 outgoing 0 true args in + if Array.fold_left + (fun stk r -> + assert (Array.length r = 1); + match r.(0).loc with + | Stack _ -> true + | _ -> stk) + false loc + then (loc, ofs) + else (loc, 0) (* Results are in GPR 3 and FPR 1 *) let loc_external_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc + let (loc, _ofs) = + calling_conventions 0 1 100 100 not_supported 0 false (single_regs res) + in + ensure_single_regs loc (* Exceptions are in GPR 3 *) let loc_exn_bucket = phys_reg 0 +(* Volatile registers: none *) + +let regs_are_volatile _rs = false + (* Registers destroyed by operations *) let destroyed_at_c_call = @@ -208,8 +269,9 @@ 100; 101; 102; 103; 104; 105; 106; 107; 108; 109; 110; 111; 112]) let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call + Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _ }) -> + all_phys_regs + | Iop(Iextcall { alloc = false; _ }) -> destroyed_at_c_call | _ -> [||] let destroyed_at_raise = all_phys_regs @@ -217,13 +279,24 @@ (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> 15 + Iextcall _ -> 15 | _ -> 23 let max_register_pressure = function - Iextcall(_, _) -> [| 15; 18 |] + Iextcall _ -> [| 15; 18 |] | _ -> [| 23; 30 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false + | Ispecific(Imultaddf | Imultsubf) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] diff -Nru ocaml-4.01.0/asmcomp/power/reload.ml ocaml-4.05.0/asmcomp/power/reload.ml --- ocaml-4.01.0/asmcomp/power/reload.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/power/reload.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Reloading for the PowerPC *) diff -Nru ocaml-4.01.0/asmcomp/power/scheduling.ml ocaml-4.05.0/asmcomp/power/scheduling.ml --- ocaml-4.01.0/asmcomp/power/scheduling.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/power/scheduling.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Instruction scheduling for the Power PC *) @@ -26,7 +29,7 @@ | Iload(_, _) -> 2 | Iconst_float _ -> 2 (* turned into a load *) | Iconst_symbol _ -> 1 - | Iintop Imul -> 9 + | Iintop(Imul | Imulh) -> 9 | Iintop_imm(Imul, _) -> 5 | Iintop(Idiv | Imod) -> 36 | Iaddf | Isubf -> 4 @@ -35,7 +38,7 @@ | Ispecific(Imultaddf | Imultsubf) -> 5 | _ -> 1 -method reload_retaddr_latency = 12 +method! reload_retaddr_latency = 12 (* If we can have that many cycles between the reloadretaddr and the return, we can expect that the blr branch will be completely folded. *) @@ -44,18 +47,16 @@ method oper_issue_cycles = function Iconst_float _ | Iconst_symbol _ -> 2 | Iload(_, Ibased(_, _)) -> 2 - | Istore(_, Ibased(_, _)) -> 2 + | Istore(_, Ibased(_, _), _) -> 2 | Ialloc _ -> 4 | Iintop(Imod) -> 40 (* assuming full stall *) | Iintop(Icomp _) -> 4 - | Iintop_imm(Idiv, _) -> 2 - | Iintop_imm(Imod, _) -> 4 | Iintop_imm(Icomp _, _) -> 4 | Ifloatofint -> 9 | Iintoffloat -> 4 | _ -> 1 -method reload_retaddr_issue_cycles = 3 +method! reload_retaddr_issue_cycles = 3 (* load then stalling mtlr *) end diff -Nru ocaml-4.01.0/asmcomp/power/selection.ml ocaml-4.05.0/asmcomp/power/selection.ml --- ocaml-4.01.0/asmcomp/power/selection.ml 2013-06-21 15:00:10.000000000 +0000 +++ ocaml-4.05.0/asmcomp/power/selection.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Instruction selection for the Power PC processor *) @@ -25,20 +28,20 @@ let rec select_addr = function Cconst_symbol s -> - (Asymbol s, 0) - | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> - let (a, n) = select_addr arg in (a, n + m) - | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> - let (a, n) = select_addr arg in (a, n + m) - | Cop((Caddi | Cadda), [arg1; arg2]) -> + (Asymbol s, 0, Debuginfo.none) + | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], dbg) -> + let (a, n, _) = select_addr arg in (a, n + m, dbg) + | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], dbg) -> + let (a, n, _) = select_addr arg in (a, n + m, dbg) + | Cop((Caddi | Caddv | Cadda), [arg1; arg2], dbg) -> begin match (select_addr arg1, select_addr arg2) with - ((Alinear e1, n1), (Alinear e2, n2)) -> - (Aadd(e1, e2), n1 + n2) + ((Alinear e1, n1, _), (Alinear e2, n2, _)) -> + (Aadd(e1, e2), n1 + n2, dbg) | _ -> - (Aadd(arg1, arg2), 0) + (Aadd(arg1, arg2), 0, dbg) end | exp -> - (Alinear exp, 0) + (Alinear exp, 0, Debuginfo.none) (* Instruction selection *) @@ -48,43 +51,35 @@ method is_immediate n = (n <= 32767) && (n >= -32768) -method select_addressing chunk exp = +method select_addressing _chunk exp = match select_addr exp with - (Asymbol s, d) -> + (Asymbol s, d, _dbg) -> (Ibased(s, d), Ctuple []) - | (Alinear e, d) -> + | (Alinear e, d, _dbg) -> (Iindexed d, e) - | (Aadd(e1, e2), d) -> + | (Aadd(e1, e2), d, dbg) -> if d = 0 then (Iindexed2, Ctuple[e1; e2]) - else (Iindexed d, Cop(Cadda, [e1; e2])) + else (Iindexed d, Cop(Cadda, [e1; e2], dbg)) -method! select_operation op args = +method! select_operation op args dbg = match (op, args) with - (* Prevent the recognition of (x / cst) and (x % cst) when cst is not - a power of 2, which do not correspond to an instruction. *) - (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg]) - | (Cdivi, _) -> - (Iintop Idiv, args) - | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg]) - | (Cmodi, _) -> - (Iintop Imod, args) + (* PowerPC does not support immediate operands for multiply high *) + (Cmulhi, _) -> (Iintop Imulh, args) (* The and, or and xor instructions have a different range of immediate operands than the other instructions *) | (Cand, _) -> self#select_logical Iand args | (Cor, _) -> self#select_logical Ior args | (Cxor, _) -> self#select_logical Ixor args (* Recognize mult-add and mult-sub instructions *) - | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> + | (Caddf, [Cop(Cmulf, [arg1; arg2], _); arg3]) -> (Ispecific Imultaddf, [arg1; arg2; arg3]) - | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> + | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2], _)]) -> (Ispecific Imultaddf, [arg1; arg2; arg3]) - | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> + | (Csubf, [Cop(Cmulf, [arg1; arg2], _); arg3]) -> (Ispecific Imultsubf, [arg1; arg2; arg3]) | _ -> - super#select_operation op args + super#select_operation op args dbg method select_logical op = function [arg; Cconst_int n] when n >= 0 && n <= 0xFFFF -> diff -Nru ocaml-4.01.0/asmcomp/printclambda.ml ocaml-4.05.0/asmcomp/printclambda.ml --- ocaml-4.01.0/asmcomp/printclambda.ml 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/asmcomp/printclambda.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,29 +1,77 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Format open Asttypes open Clambda -let rec pr_idents ppf = function - | [] -> () - | h::t -> fprintf ppf "%a %a" Ident.print h pr_idents t +let mutable_flag = function + | Mutable-> "[mut]" + | Immutable -> "" + +let value_kind = + let open Lambda in + function + | Pgenval -> "" + | Pintval -> ":int" + | Pfloatval -> ":float" + | Pboxedintval Pnativeint -> ":nativeint" + | Pboxedintval Pint32 -> ":int32" + | Pboxedintval Pint64 -> ":int64" + +let rec structured_constant ppf = function + | Uconst_float x -> fprintf ppf "%F" x + | Uconst_int32 x -> fprintf ppf "%ldl" x + | Uconst_int64 x -> fprintf ppf "%LdL" x + | Uconst_nativeint x -> fprintf ppf "%ndn" x + | Uconst_block (tag, l) -> + fprintf ppf "block(%i" tag; + List.iter (fun u -> fprintf ppf ",%a" uconstant u) l; + fprintf ppf ")" + | Uconst_float_array [] -> + fprintf ppf "floatarray()" + | Uconst_float_array (f1 :: fl) -> + fprintf ppf "floatarray(%F" f1; + List.iter (fun f -> fprintf ppf ",%F" f) fl; + fprintf ppf ")" + | Uconst_string s -> fprintf ppf "%S" s + | Uconst_closure(clos, sym, fv) -> + let idents ppf = + List.iter (fprintf ppf "@ %a" Ident.print)in + let one_fun ppf f = + fprintf ppf "(fun@ %s@ %d@ @[<2>%a@]@ @[<2>%a@])" + f.label f.arity idents f.params lam f.body in + let funs ppf = + List.iter (fprintf ppf "@ %a" one_fun) in + let sconsts ppf scl = + List.iter (fun sc -> fprintf ppf "@ %a" uconstant sc) scl in + fprintf ppf "@[<2>(const_closure%a %s@ %a)@]" funs clos sym sconsts fv -let rec lam ppf = function + +and uconstant ppf = function + | Uconst_ref (s, Some c) -> + fprintf ppf "%S=%a" s structured_constant c + | Uconst_ref (s, None) -> fprintf ppf "%S"s + | Uconst_int i -> fprintf ppf "%i" i + | Uconst_ptr i -> fprintf ppf "%ia" i + +and lam ppf = function | Uvar id -> Ident.print ppf id - | Uconst (cst,_) -> - Printlambda.structured_constant ppf cst + | Uconst c -> uconstant ppf c | Udirect_apply(f, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in @@ -36,7 +84,7 @@ let idents ppf = List.iter (fprintf ppf "@ %a" Ident.print)in let one_fun ppf f = - fprintf ppf "(fun@ %s@ %d @[<2>%a@] @[<2>%a@])" + fprintf ppf "@[<2>(fun@ %s@ %d @[<2>%a@]@ @[<2>%a@]@])" f.label f.arity idents f.params lam f.body in let funs ppf = List.iter (fprintf ppf "@ %a" one_fun) in @@ -44,13 +92,15 @@ List.iter (fprintf ppf "@ %a" lam) in fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i - | Ulet(id, arg, body) -> + | Ulet(mut, kind, id, arg, body) -> let rec letbody ul = match ul with - | Ulet(id, arg, body) -> - fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg; + | Ulet(mut, kind, id, arg, body) -> + fprintf ppf "@ @[<2>%a%s%s@ %a@]" + Ident.print id (mutable_flag mut) (value_kind kind) lam arg; letbody body | _ -> ul in - fprintf ppf "@[<2>(let@ @[(@[<2>%a@ %a@]" Ident.print id lam arg; + fprintf ppf "@[<2>(let@ @[(@[<2>%a%s%s@ %a@]" + Ident.print id (mutable_flag mut) (value_kind kind) lam arg; let expr = letbody body in fprintf ppf ")@]@ %a)@]" lam expr | Uletrec(id_arg_list, body) -> @@ -68,23 +118,38 @@ List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs | Uswitch(larg, sw) -> - let switch ppf sw = - let spc = ref false in - for i = 0 to Array.length sw.us_index_consts - 1 do - let n = sw.us_index_consts.(i) in - let l = sw.us_actions_consts.(n) in - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i:@ %a@]" i lam l; - done; - for i = 0 to Array.length sw.us_index_blocks - 1 do - let n = sw.us_index_blocks.(i) in - let l = sw.us_actions_blocks.(n) in - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i:@ %a@]" i lam l; + let print_case tag index i ppf = + for j = 0 to Array.length index - 1 do + if index.(j) = i then fprintf ppf "case %s %i:" tag j + done in + let print_cases tag index cases ppf = + for i = 0 to Array.length cases - 1 do + fprintf ppf "@ @[<2>%t@ %a@]" + (print_case tag index i) sequence cases.(i) done in + let switch ppf sw = + print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ; + print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf in fprintf ppf - "@[<1>(switch %a@ @[%a@])@]" + "@[@[<2>(switch@ %a@ @]%a)@]" lam larg switch sw + | Ustringswitch(larg,sw,d) -> + let switch ppf sw = + let spc = ref false in + List.iter + (fun (s,l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" + (String.escaped s) lam l) + sw ; + begin match d with + | Some d -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam d + | None -> () + end in + fprintf ppf + "@[<1>(switch %a@ @[%a@])@]" lam larg switch sw | Ustaticfail (i, ls) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in @@ -124,6 +189,8 @@ else if k = Lambda.Cached then "cache" else "" in fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs + | Uunreachable -> + fprintf ppf "unreachable" and sequence ppf ulam = match ulam with | Usequence(l1, l2) -> @@ -132,3 +199,29 @@ let clambda ppf ulam = fprintf ppf "%a@." lam ulam + + +let rec approx ppf = function + Value_closure(fundesc, a) -> + Format.fprintf ppf "@[<2>function %s@ arity %i" + fundesc.fun_label fundesc.fun_arity; + if fundesc.fun_closed then begin + Format.fprintf ppf "@ (closed)" + end; + if fundesc.fun_inline <> None then begin + Format.fprintf ppf "@ (inline)" + end; + Format.fprintf ppf "@ -> @ %a@]" approx a + | Value_tuple a -> + let tuple ppf a = + for i = 0 to Array.length a - 1 do + if i > 0 then Format.fprintf ppf ";@ "; + Format.fprintf ppf "%i: %a" i approx a.(i) + done in + Format.fprintf ppf "@[(%a)@]" tuple a + | Value_unknown -> + Format.fprintf ppf "_" + | Value_const c -> + fprintf ppf "@[const(%a)@]" uconstant c + | Value_global_field (s, i) -> + fprintf ppf "@[global(%s,%i)@]" s i diff -Nru ocaml-4.01.0/asmcomp/printclambda.mli ocaml-4.05.0/asmcomp/printclambda.mli --- ocaml-4.01.0/asmcomp/printclambda.mli 2012-02-22 08:43:39.000000000 +0000 +++ ocaml-4.05.0/asmcomp/printclambda.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,16 +1,21 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Clambda open Format val clambda: formatter -> ulambda -> unit +val approx: formatter -> value_approximation -> unit +val structured_constant: formatter -> ustructured_constant -> unit diff -Nru ocaml-4.01.0/asmcomp/printcmm.ml ocaml-4.05.0/asmcomp/printcmm.ml --- ocaml-4.01.0/asmcomp/printcmm.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/printcmm.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,21 +1,29 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Pretty-printing of C-- code *) open Format open Cmm +let rec_flag ppf = function + | Nonrecursive -> () + | Recursive -> fprintf ppf " rec" + let machtype_component ppf = function + | Val -> fprintf ppf "val" | Addr -> fprintf ppf "addr" | Int -> fprintf ppf "int" | Float -> fprintf ppf "float" @@ -43,23 +51,35 @@ | Sixteen_signed -> "signed int16" | Thirtytwo_unsigned -> "unsigned int32" | Thirtytwo_signed -> "signed int32" - | Word -> "" + | Word_int -> "int" + | Word_val -> "val" | Single -> "float32" | Double -> "float64" | Double_u -> "float64u" -let operation = function - | Capply(ty, d) -> "app" ^ Debuginfo.to_string d - | Cextcall(lbl, ty, alloc, d) -> +let raise_kind fmt = function + | Raise_withtrace -> Format.fprintf fmt "raise_withtrace" + | Raise_notrace -> Format.fprintf fmt "raise_notrace" + +let operation d = function + | Capply _ty -> "app" ^ Debuginfo.to_string d + | Cextcall(lbl, _ty, _alloc, _) -> Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.to_string d) - | Cload Word -> "load" - | Cload c -> Printf.sprintf "load %s" (chunk c) - | Calloc -> "alloc" - | Cstore Word -> "store" - | Cstore c -> Printf.sprintf "store %s" (chunk c) + | Cload (c, Asttypes.Immutable) -> Printf.sprintf "load %s" (chunk c) + | Cload (c, Asttypes.Mutable) -> Printf.sprintf "load_mut %s" (chunk c) + | Calloc -> "alloc" ^ Debuginfo.to_string d + | Cstore (c, init) -> + let init = + match init with + | Lambda.Heap_initialization -> "(heap-init)" + | Lambda.Root_initialization -> "(root-init)" + | Lambda.Assignment -> "" + in + Printf.sprintf "store %s%s" (chunk c) init | Caddi -> "+" | Csubi -> "-" | Cmuli -> "*" + | Cmulhi -> "*h" | Cdivi -> "/" | Cmodi -> "mod" | Cand -> "and" @@ -69,8 +89,8 @@ | Clsr -> ">>u" | Casr -> ">>s" | Ccmpi c -> comparison c + | Caddv -> "+v" | Cadda -> "+a" - | Csuba -> "-a" | Ccmpa c -> Printf.sprintf "%sa" (comparison c) | Cnegf -> "~f" | Cabsf -> "absf" @@ -81,13 +101,17 @@ | Cfloatofint -> "floatofint" | Cintoffloat -> "intoffloat" | Ccmpf c -> Printf.sprintf "%sf" (comparison c) - | Craise d -> "raise" ^ Debuginfo.to_string d - | Ccheckbound d -> "checkbound" ^ Debuginfo.to_string d + | Craise k -> Format.asprintf "%a%s" raise_kind k (Debuginfo.to_string d) + | Ccheckbound -> "checkbound" ^ Debuginfo.to_string d let rec expr ppf = function | Cconst_int n -> fprintf ppf "%i" n - | Cconst_natint n -> fprintf ppf "%s" (Nativeint.to_string n) - | Cconst_float s -> fprintf ppf "%s" s + | Cconst_natint n -> + fprintf ppf "%s" (Nativeint.to_string n) + | Cblockheader(n, d) -> + fprintf ppf "block-hdr(%s)%s" + (Nativeint.to_string n) (Debuginfo.to_string d) + | Cconst_float n -> fprintf ppf "%F" n | Cconst_symbol s -> fprintf ppf "\"%s\"" s | Cconst_pointer n -> fprintf ppf "%ia" n | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n) @@ -118,11 +142,11 @@ expr ppf e) el in fprintf ppf "@[<1>[%a]@]" tuple el - | Cop(op, el) -> - fprintf ppf "@[<2>(%s" (operation op); + | Cop(op, el, dbg) -> + fprintf ppf "@[<2>(%s" (operation dbg op); List.iter (fun e -> fprintf ppf "@ %a" expr e) el; begin match op with - | Capply (mty, _) -> fprintf ppf "@ %a" machtype mty + | Capply mty -> fprintf ppf "@ %a" machtype mty | Cextcall(_, mty, _, _) -> fprintf ppf "@ %a" machtype mty | _ -> () end; @@ -131,7 +155,7 @@ fprintf ppf "@[<2>(seq@ %a@ %a)@]" sequence e1 sequence e2 | Cifthenelse(e1, e2, e3) -> fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" expr e1 expr e2 expr e3 - | Cswitch(e1, index, cases) -> + | Cswitch(e1, index, cases, _dbg) -> let print_case i ppf = for j = 0 to Array.length index - 1 do if index.(j) = i then fprintf ppf "case %i:" j @@ -143,17 +167,26 @@ fprintf ppf "@[@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases | Cloop e -> fprintf ppf "@[<2>(loop@ %a)@]" sequence e - | Ccatch(i, ids, e1, e2) -> + | Ccatch(flag, handlers, e1) -> + let print_handler ppf (i, ids, e2) = + fprintf ppf "(%d%a)@ %a" + i + (fun ppf ids -> + List.iter + (fun id -> fprintf ppf " %a" Ident.print id) + ids) ids + sequence e2 + in + let print_handlers ppf l = + List.iter (print_handler ppf) l + in fprintf ppf - "@[<2>(catch@ %a@;<1 -2>with(%d%a)@ %a)@]" - sequence e1 i - (fun ppf ids -> - List.iter - (fun id -> fprintf ppf " %a" Ident.print id) - ids) ids - sequence e2 + "@[<2>(catch%a@ %a@;<1 -2>with%a)@]" + rec_flag flag + sequence e1 + print_handlers handlers | Cexit (i, el) -> - fprintf ppf "@[<2>(exit %d" i ; + fprintf ppf "@[<2>(exit %d" i; List.iter (fun e -> fprintf ppf "@ %a" expr e) el; fprintf ppf ")@]" | Ctrywith(e1, id, e2) -> @@ -180,16 +213,14 @@ let data_item ppf = function | Cdefine_symbol s -> fprintf ppf "\"%s\":" s - | Cdefine_label l -> fprintf ppf "L%i:" l | Cglobal_symbol s -> fprintf ppf "global \"%s\"" s | Cint8 n -> fprintf ppf "byte %i" n | Cint16 n -> fprintf ppf "int16 %i" n | Cint32 n -> fprintf ppf "int32 %s" (Nativeint.to_string n) | Cint n -> fprintf ppf "int %s" (Nativeint.to_string n) - | Csingle f -> fprintf ppf "single %s" f - | Cdouble f -> fprintf ppf "double %s" f + | Csingle f -> fprintf ppf "single %F" f + | Cdouble f -> fprintf ppf "double %F" f | Csymbol_address s -> fprintf ppf "addr \"%s\"" s - | Clabel_address l -> fprintf ppf "addr L%i" l | Cstring s -> fprintf ppf "string \"%s\"" s | Cskip n -> fprintf ppf "skip %i" n | Calign n -> fprintf ppf "align %i" n diff -Nru ocaml-4.01.0/asmcomp/printcmm.mli ocaml-4.05.0/asmcomp/printcmm.mli --- ocaml-4.01.0/asmcomp/printcmm.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/printcmm.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,25 +1,30 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Pretty-printing of C-- code *) open Format +val rec_flag : formatter -> Cmm.rec_flag -> unit val machtype_component : formatter -> Cmm.machtype_component -> unit val machtype : formatter -> Cmm.machtype_component array -> unit val comparison : Cmm.comparison -> string val chunk : Cmm.memory_chunk -> string -val operation : Cmm.operation -> string +val operation : Debuginfo.t -> Cmm.operation -> string val expression : formatter -> Cmm.expression -> unit val fundecl : formatter -> Cmm.fundecl -> unit val data : formatter -> Cmm.data_item list -> unit val phrase : formatter -> Cmm.phrase -> unit +val raise_kind: formatter -> Cmm.raise_kind -> unit diff -Nru ocaml-4.01.0/asmcomp/printlinear.ml ocaml-4.05.0/asmcomp/printlinear.ml --- ocaml-4.01.0/asmcomp/printlinear.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/printlinear.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Pretty-printing of linearized machine code *) @@ -25,7 +28,7 @@ | Lend -> () | Lop op -> begin match op with - | Ialloc _ | Icall_ind | Icall_imm _ | Iextcall(_, _) -> + | Ialloc _ | Icall_ind _ | Icall_imm _ | Iextcall _ -> fprintf ppf "@[<1>{%a}@]@," regsetaddr i.live | _ -> () end; @@ -60,8 +63,8 @@ fprintf ppf "push trap" | Lpoptrap -> fprintf ppf "pop trap" - | Lraise -> - fprintf ppf "raise %a" reg i.arg.(0) + | Lraise k -> + fprintf ppf "%a %a" Printcmm.raise_kind k reg i.arg.(0) end; if not (Debuginfo.is_none i.dbg) then fprintf ppf " %s" (Debuginfo.to_string i.dbg) diff -Nru ocaml-4.01.0/asmcomp/printlinear.mli ocaml-4.05.0/asmcomp/printlinear.mli --- ocaml-4.01.0/asmcomp/printlinear.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/printlinear.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Pretty-printing of linearized machine code *) diff -Nru ocaml-4.01.0/asmcomp/printmach.ml ocaml-4.05.0/asmcomp/printmach.ml --- ocaml-4.01.0/asmcomp/printmach.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/printmach.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Pretty-printing of pseudo machine code *) @@ -18,10 +21,11 @@ open Mach let reg ppf r = - if String.length r.name > 0 then - fprintf ppf "%s" r.name + if not (Reg.anonymous r) then + fprintf ppf "%s" (Reg.name r) else - fprintf ppf "%s" (match r.typ with Addr -> "A" | Int -> "I" | Float -> "F"); + fprintf ppf "%s" + (match r.typ with Val -> "V" | Addr -> "A" | Int -> "I" | Float -> "F"); fprintf ppf "/%i" r.stamp; begin match r.loc with | Unknown -> () @@ -56,7 +60,10 @@ (fun r -> if !first then begin first := false; fprintf ppf "%a" reg r end else fprintf ppf "@ %a" reg r; - match r.typ with Addr -> fprintf ppf "*" | _ -> ()) + match r.typ with + | Val -> fprintf ppf "*" + | Addr -> fprintf ppf "!" + | _ -> ()) s let intcomp = function @@ -70,6 +77,7 @@ | Iadd -> " + " | Isub -> " - " | Imul -> " * " + | Imulh -> " *h " | Idiv -> " div " | Imod -> " mod " | Iand -> " & " @@ -79,7 +87,16 @@ | Ilsr -> " >>u " | Iasr -> " >>s " | Icomp cmp -> intcomp cmp - | Icheckbound -> " check > " + | Icheckbound { label_after_error; spacetime_index; } -> + if not Config.spacetime then " check > " + else + Printf.sprintf "check[lbl=%s,index=%d] > " + begin + match label_after_error with + | None -> "" + | Some lbl -> string_of_int lbl + end + spacetime_index let test tst ppf arg = match tst with @@ -103,27 +120,32 @@ | Ispill -> fprintf ppf "%a (spill)" regs arg | Ireload -> fprintf ppf "%a (reload)" regs arg | Iconst_int n -> fprintf ppf "%s" (Nativeint.to_string n) - | Iconst_float s -> fprintf ppf "%s" s + | Iconst_float f -> fprintf ppf "%F" (Int64.float_of_bits f) | Iconst_symbol s -> fprintf ppf "\"%s\"" s - | Icall_ind -> fprintf ppf "call %a" regs arg - | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg - | Itailcall_ind -> fprintf ppf "tailcall %a" regs arg - | Itailcall_imm lbl -> fprintf ppf "tailcall \"%s\" %a" lbl regs arg - | Iextcall(lbl, alloc) -> - fprintf ppf "extcall \"%s\" %a%s" lbl regs arg - (if not alloc then "" else " (noalloc)") + | Icall_ind _ -> fprintf ppf "call %a" regs arg + | Icall_imm { func; _ } -> fprintf ppf "call \"%s\" %a" func regs arg + | Itailcall_ind _ -> fprintf ppf "tailcall %a" regs arg + | Itailcall_imm { func; } -> fprintf ppf "tailcall \"%s\" %a" func regs arg + | Iextcall { func; alloc; _ } -> + fprintf ppf "extcall \"%s\" %a%s" func regs arg + (if alloc then "" else " (noalloc)") | Istackoffset n -> fprintf ppf "offset stack %i" n | Iload(chunk, addr) -> fprintf ppf "%s[%a]" (Printcmm.chunk chunk) (Arch.print_addressing reg addr) arg - | Istore(chunk, addr) -> - fprintf ppf "%s[%a] := %a" + | Istore(chunk, addr, is_assign) -> + fprintf ppf "%s[%a] := %a %s" (Printcmm.chunk chunk) (Arch.print_addressing reg addr) (Array.sub arg 1 (Array.length arg - 1)) reg arg.(0) - | Ialloc n -> fprintf ppf "alloc %i" n + (if is_assign then "(assign)" else "(init)") + | Ialloc { words = n; _ } -> + fprintf ppf "alloc %i" n; + if Config.spacetime then begin + fprintf ppf "(spacetime node = %a)" reg arg.(0) + end | Iintop(op) -> fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1) | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n | Inegf -> fprintf ppf "-f %a" reg arg.(0) @@ -168,17 +190,27 @@ fprintf ppf "@,endswitch" | Iloop(body) -> fprintf ppf "@[loop@,%a@;<0 -2>endloop@]" instr body - | Icatch(i, body, handler) -> - fprintf - ppf "@[catch@,%a@;<0 -2>with(%d)@,%a@;<0 -2>endcatch@]" - instr body i instr handler + | Icatch(flag, handlers, body) -> + fprintf ppf "@[catch%a@,%a@;<0 -2>with" + Printcmm.rec_flag flag instr body; + let h (nfail, handler) = + fprintf ppf "(%d)@,%a@;" nfail instr handler in + let rec aux = function + | [] -> () + | [v] -> h v + | v :: t -> + h v; + fprintf ppf "@ and"; + aux t + in + aux handlers | Iexit i -> fprintf ppf "exit(%d)" i | Itrywith(body, handler) -> fprintf ppf "@[try@,%a@;<0 -2>with@,%a@;<0 -2>endtry@]" instr body instr handler - | Iraise -> - fprintf ppf "raise %a" reg i.arg.(0) + | Iraise k -> + fprintf ppf "%a %a" Printcmm.raise_kind k reg i.arg.(0) end; if not (Debuginfo.is_none i.dbg) then fprintf ppf "%s" (Debuginfo.to_string i.dbg); diff -Nru ocaml-4.01.0/asmcomp/printmach.mli ocaml-4.05.0/asmcomp/printmach.mli --- ocaml-4.01.0/asmcomp/printmach.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/printmach.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Pretty-printing of pseudo machine code *) diff -Nru ocaml-4.01.0/asmcomp/proc.mli ocaml-4.05.0/asmcomp/proc.mli --- ocaml-4.01.0/asmcomp/proc.mli 2013-06-03 18:03:59.000000000 +0000 +++ ocaml-4.05.0/asmcomp/proc.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Processor descriptions *) @@ -28,9 +31,23 @@ val loc_arguments: Reg.t array -> Reg.t array * int val loc_results: Reg.t array -> Reg.t array val loc_parameters: Reg.t array -> Reg.t array -val loc_external_arguments: Reg.t array -> Reg.t array * int +(* For argument number [n] split across multiple registers, the target-specific + implementation of [loc_external_arguments] must return [regs] such that + [regs.(n).(0)] is to hold the part of the value at the lowest address. + (All that matters for the input to [loc_external_arguments] is the pattern + of lengths and register types of the various supplied arrays.) *) +val loc_external_arguments: Reg.t array array -> Reg.t array array * int val loc_external_results: Reg.t array -> Reg.t array val loc_exn_bucket: Reg.t +val loc_spacetime_node_hole: Reg.t + +(* The maximum number of arguments of an OCaml to OCaml function call for + which it is guaranteed there will be no arguments passed on the stack. + (Above this limit, tail call optimization may be disabled.) + N.B. The values for this parameter in the backends currently assume + that no unboxed floats are passed using the OCaml calling conventions. +*) +val max_arguments_for_tailcalls : int (* Maximal register pressures for pre-spilling *) val safe_register_pressure: Mach.operation -> int @@ -40,6 +57,12 @@ val destroyed_at_oper: Mach.instruction_desc -> Reg.t array val destroyed_at_raise: Reg.t array +(* Volatile registers: those that change value when read *) +val regs_are_volatile: Reg.t array -> bool + +(* Pure operations *) +val op_is_pure: Mach.operation -> bool + (* Info for laying out the stack frame *) val num_stack_slots: int array val contains_calls: bool ref diff -Nru ocaml-4.01.0/asmcomp/reg.ml ocaml-4.05.0/asmcomp/reg.ml --- ocaml-4.01.0/asmcomp/reg.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/reg.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,23 +1,44 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Cmm +module Raw_name = struct + type t = + | Anon + | R + | Ident of Ident.t + + let create_from_ident ident = Ident ident + + let to_string t = + match t with + | Anon -> None + | R -> Some "R" + | Ident ident -> + let name = Ident.name ident in + if String.length name <= 0 then None else Some name +end + type t = - { mutable name: string; + { mutable raw_name: Raw_name.t; stamp: int; - typ: Cmm.machtype_component; + mutable typ: Cmm.machtype_component; mutable loc: location; mutable spill: bool; + mutable part: int option; mutable interf: t list; mutable prefer: (t * int) list; mutable degree: int; @@ -37,44 +58,65 @@ type reg = t let dummy = - { name = ""; stamp = 0; typ = Int; loc = Unknown; spill = false; - interf = []; prefer = []; degree = 0; spill_cost = 0; visited = false } + { raw_name = Raw_name.Anon; stamp = 0; typ = Int; loc = Unknown; + spill = false; interf = []; prefer = []; degree = 0; spill_cost = 0; + visited = false; part = None; + } let currstamp = ref 0 let reg_list = ref([] : t list) let create ty = - let r = { name = ""; stamp = !currstamp; typ = ty; loc = Unknown; - spill = false; interf = []; prefer = []; degree = 0; - spill_cost = 0; visited = false } in + let r = { raw_name = Raw_name.Anon; stamp = !currstamp; typ = ty; + loc = Unknown; spill = false; interf = []; prefer = []; degree = 0; + spill_cost = 0; visited = false; part = None; } in reg_list := r :: !reg_list; incr currstamp; r let createv tyv = let n = Array.length tyv in - let rv = Array.create n dummy in + let rv = Array.make n dummy in for i = 0 to n-1 do rv.(i) <- create tyv.(i) done; rv let createv_like rv = let n = Array.length rv in - let rv' = Array.create n dummy in + let rv' = Array.make n dummy in for i = 0 to n-1 do rv'.(i) <- create rv.(i).typ done; rv' let clone r = let nr = create r.typ in - nr.name <- r.name; + nr.raw_name <- r.raw_name; nr let at_location ty loc = - let r = { name = "R"; stamp = !currstamp; typ = ty; loc = loc; spill = false; - interf = []; prefer = []; degree = 0; spill_cost = 0; - visited = false } in + let r = { raw_name = Raw_name.R; stamp = !currstamp; typ = ty; loc; + spill = false; interf = []; prefer = []; degree = 0; + spill_cost = 0; visited = false; part = None; } in incr currstamp; r +let anonymous t = + match Raw_name.to_string t.raw_name with + | None -> true + | Some _raw_name -> false + +let name t = + match Raw_name.to_string t.raw_name with + | None -> "" + | Some raw_name -> + let with_spilled = + if t.spill then + "spilled-" ^ raw_name + else + raw_name + in + match t.part with + | None -> with_spilled + | Some part -> with_spilled ^ "#" ^ string_of_int part + let first_virtual_reg_stamp = ref (-1) let reset() = @@ -139,6 +181,16 @@ else inter_all(i+1) in inter_all 0 +let disjoint_set_array s v = + match Array.length v with + 0 -> true + | 1 -> not (Set.mem v.(0) s) + | n -> let rec disjoint_all i = + if i >= n then true + else if Set.mem v.(i) s then false + else disjoint_all (i+1) + in disjoint_all 0 + let set_of_array v = match Array.length v with 0 -> Set.empty diff -Nru ocaml-4.01.0/asmcomp/reg.mli ocaml-4.05.0/asmcomp/reg.mli --- ocaml-4.01.0/asmcomp/reg.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/reg.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,23 +1,32 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Pseudo-registers *) +module Raw_name : sig + type t + val create_from_ident : Ident.t -> t +end + type t = - { mutable name: string; (* Name (for printing) *) + { mutable raw_name: Raw_name.t; (* Name *) stamp: int; (* Unique stamp *) - typ: Cmm.machtype_component; (* Type of contents *) + mutable typ: Cmm.machtype_component;(* Type of contents *) mutable loc: location; (* Actual location *) mutable spill: bool; (* "true" to force stack allocation *) + mutable part: int option; (* Zero-based index of part of value *) mutable interf: t list; (* Other regs live simultaneously *) mutable prefer: (t * int) list; (* Preferences for other regs *) mutable degree: int; (* Number of other regs live sim. *) @@ -41,12 +50,18 @@ val clone: t -> t val at_location: Cmm.machtype_component -> location -> t +val anonymous : t -> bool + +(* Name for printing *) +val name : t -> string + module Set: Set.S with type elt = t module Map: Map.S with type key = t val add_set_array: Set.t -> t array -> Set.t val diff_set_array: Set.t -> t array -> Set.t val inter_set_array: Set.t -> t array -> Set.t +val disjoint_set_array: Set.t -> t array -> bool val set_of_array: t array -> Set.t val reset: unit -> unit diff -Nru ocaml-4.01.0/asmcomp/reloadgen.ml ocaml-4.05.0/asmcomp/reloadgen.ml --- ocaml-4.01.0/asmcomp/reloadgen.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/reloadgen.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Insert load/stores for pseudoregs that got assigned to stack locations. *) @@ -16,15 +19,6 @@ open Reg open Mach -let access_stack r = - try - for i = 0 to Array.length r - 1 do - match r.(i).loc with Stack _ -> raise Exit | _ -> () - done; - false - with Exit -> - true - let insert_move src dst next = if src.loc = dst.loc then next @@ -54,7 +48,7 @@ method private makeregs rv = let n = Array.length rv in - let newv = Array.create n Reg.dummy in + let newv = Array.make n Reg.dummy in for i = 0 to n-1 do newv.(i) <- self#makereg rv.(i) done; newv @@ -79,7 +73,7 @@ | _ -> (self#makeregs arg, self#makeregs res) -method reload_test tst args = +method reload_test _tst args = self#makeregs args method private reload i = @@ -88,14 +82,14 @@ already at the correct position (e.g. on stack for some arguments). However, something needs to be done for the function pointer in indirect calls. *) - Iend | Ireturn | Iop(Itailcall_imm _) | Iraise -> i - | Iop(Itailcall_ind) -> + Iend | Ireturn | Iop(Itailcall_imm _) | Iraise _ -> i + | Iop(Itailcall_ind _) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg {i with arg = newarg} | Iop(Icall_imm _ | Iextcall _) -> {i with next = self#reload i.next} - | Iop(Icall_ind) -> + | Iop(Icall_ind _) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg {i with arg = newarg; next = self#reload i.next} @@ -118,9 +112,12 @@ (self#reload i.next)) | Iloop body -> instr_cons (Iloop(self#reload body)) [||] [||] (self#reload i.next) - | Icatch(nfail, body, handler) -> + | Icatch(rec_flag, handlers, body) -> + let new_handlers = List.map + (fun (nfail, handler) -> nfail, self#reload handler) + handlers in instr_cons - (Icatch(nfail, self#reload body, self#reload handler)) [||] [||] + (Icatch(rec_flag, new_handlers, self#reload body)) [||] [||] (self#reload i.next) | Iexit i -> instr_cons (Iexit i) [||] [||] dummy_instr @@ -133,7 +130,6 @@ let new_body = self#reload f.fun_body in ({fun_name = f.fun_name; fun_args = f.fun_args; fun_body = new_body; fun_fast = f.fun_fast; - fun_dbg = f.fun_dbg}, + fun_dbg = f.fun_dbg; fun_spacetime_shape = f.fun_spacetime_shape}, redo_regalloc) - end diff -Nru ocaml-4.01.0/asmcomp/reloadgen.mli ocaml-4.05.0/asmcomp/reloadgen.mli --- ocaml-4.01.0/asmcomp/reloadgen.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/reloadgen.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) class reload_generic : object method reload_operation : diff -Nru ocaml-4.01.0/asmcomp/reload.mli ocaml-4.05.0/asmcomp/reload.mli --- ocaml-4.01.0/asmcomp/reload.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/reload.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Insert load/stores for pseudoregs that got assigned to stack locations. *) diff -Nru ocaml-4.01.0/asmcomp/s390x/arch.ml ocaml-4.05.0/asmcomp/s390x/arch.ml --- ocaml-4.01.0/asmcomp/s390x/arch.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/s390x/arch.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,91 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Bill O'Farrell, IBM *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2015 IBM (Bill O'Farrell with help from Tristan Amini). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Specific operations for the Z processor *) + +open Format + +(* Machine-specific command-line options *) + +let pic_code = ref true + +let command_line_options = + [ "-fPIC", Arg.Set pic_code, + " Generate position-independent machine code (default)"; + "-fno-PIC", Arg.Clear pic_code, + " Generate position-dependent machine code" ] + +(* Specific operations *) + +type specific_operation = + Imultaddf (* multiply and add *) + | Imultsubf (* multiply and subtract *) + +let spacetime_node_hole_pointer_is_live_before _specific_op = false + +(* Addressing modes *) + +type addressing_mode = + | Iindexed of int (* reg + displ *) + | Iindexed2 of int (* reg + reg + displ *) + +(* Sizes, endianness *) + +let big_endian = true + +let size_addr = 8 +let size_int = size_addr +let size_float = 8 + +let allow_unaligned_access = false + +(* Behavior of division *) + +let division_crashes_on_overflow = true + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing addr delta = + match addr with + | Iindexed n -> Iindexed(n + delta) + | Iindexed2 n -> Iindexed2(n + delta) + +let num_args_addressing = function + | Iindexed _ -> 1 + | Iindexed2 _ -> 2 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + match addr with + | Iindexed n -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a%s" printreg arg.(0) idx + | Iindexed2 n -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a + %a%s" printreg arg.(0) printreg arg.(1) idx + +let print_specific_operation printreg op ppf arg = + match op with + | Imultaddf -> + fprintf ppf "%a *f %a +f %a" + printreg arg.(0) printreg arg.(1) printreg arg.(2) + | Imultsubf -> + fprintf ppf "%a *f %a -f %a" + printreg arg.(0) printreg arg.(1) printreg arg.(2) diff -Nru ocaml-4.01.0/asmcomp/s390x/CSE.ml ocaml-4.05.0/asmcomp/s390x/CSE.ml --- ocaml-4.01.0/asmcomp/s390x/CSE.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/s390x/CSE.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,42 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Bill O'Farrell, IBM *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2015 IBM (Bill O'Farrell with help from Tristan Amini). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* CSE for the Z Processor *) + +open Arch +open Mach +open CSEgen + +class cse = object + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Imultaddf | Imultsubf) -> Op_pure + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n -> + n >= -0x8000_0000n && n <= 0x7FFF_FFFFn + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/s390x/emit.mlp ocaml-4.05.0/asmcomp/s390x/emit.mlp --- ocaml-4.01.0/asmcomp/s390x/emit.mlp 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/s390x/emit.mlp 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,759 @@ +#2 "asmcomp/s390x/emit.mlp" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Emission of Linux on Z 64-bit assembly code *) + +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Layout of the stack. The stack is kept 8-aligned. *) + +let stack_offset = ref 0 + +let frame_size () = + let size = + !stack_offset + (* Trap frame, outgoing parameters *) + size_int * num_stack_slots.(0) + (* Local int variables *) + size_float * num_stack_slots.(1) + (* Local float variables *) + (if !contains_calls then size_addr else 0) in (* The return address *) + Misc.align size 8 + +let slot_offset loc cls = + match loc with + Local n -> + if cls = 0 + then !stack_offset + num_stack_slots.(1) * size_float + n * size_int + else !stack_offset + n * size_float + | Incoming n -> frame_size() + n + | Outgoing n -> n + +(* Output a symbol *) + +let emit_symbol s = Emitaux.emit_symbol '.' s + +(* Output function call *) + +let emit_call s = + if !pic_code then + ` brasl %r14, {emit_symbol s}@PLT\n` + else + ` brasl %r14, {emit_symbol s}\n` + +(* Output a label *) + +let label_prefix = ".L" + +let emit_label lbl = + emit_string label_prefix; emit_int lbl + +(* Section switching *) + +let data_space = " .section \".data\"\n" + +let code_space = " .section \".text\"\n" + +let rodata_space = " .section \".rodata\"\n" + +(* Output a pseudo-register *) + +let emit_reg r = + match r.loc with + | Reg r -> emit_string (register_name r) + | _ -> fatal_error "Emit.emit_reg" + + +(* Special registers *) + +let check_phys_reg reg_idx name = + let reg = phys_reg reg_idx in + assert (register_name reg_idx = name); + reg + +let reg_f15 = check_phys_reg 115 "%f15" +let reg_r7 = check_phys_reg 5 "%r7" + +(* Output a stack reference *) + +let emit_stack r = + match r.loc with + Stack s -> + let ofs = slot_offset s (register_class r) in `{emit_int ofs}(%r15)` + | _ -> fatal_error "Emit.emit_stack" + + +(* Output a load of the address of a global symbol *) + +let emit_load_symbol_addr reg s = + if !pic_code then + ` lgrl {emit_reg reg}, {emit_symbol s}@GOTENT\n` + else + ` larl {emit_reg reg}, {emit_symbol s}\n` + +(* Output a load or store operation *) + +let emit_load_store instr addressing_mode addr n arg = + match addressing_mode with + | Iindexed ofs -> + ` {emit_string instr} {emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n` + | Iindexed2 ofs -> + ` {emit_string instr} {emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)},{emit_reg addr.(n+1)})\n` + +(* Adjust the stack pointer down by N. + Choose the shortest instruction possible for the value of N. *) + +let emit_stack_adjust n = + let n = -n in + if n = 0 then () + else if n >= 0 && n < 4096 then + ` la %r15, {emit_int n}(%r15)\n` + else if n >= -0x80000 && n < 0x80000 then + ` lay %r15, {emit_int n}(%r15)\n` + else + ` agfi %r15, {emit_int n}\n` + +(* Emit a 'add immediate' *) + +let emit_addimm res arg n = + if n >= 0 && n < 4096 then + ` la {emit_reg res}, {emit_int n}({emit_reg arg})\n` + else if n >= -0x80000 && n < 0x80000 then + ` lay {emit_reg res}, {emit_int n}({emit_reg arg})\n` + else begin + if arg.loc <> res.loc then + ` lgr {emit_reg res}, {emit_reg arg}\n`; + ` agfi {emit_reg res}, {emit_int n}\n` + end + +(* After a comparison, extract the result as 0 or 1 *) +(* The locgr instruction is not available in the z10 architecture, + so this code is currently unused. *) +(* +let emit_set_comp cmp res = + ` lghi %r1, 1\n`; + ` lghi {emit_reg res}, 0\n`; + begin match cmp with + Ceq -> ` locgre {emit_reg res}, %r1\n` + | Cne -> ` locgrne {emit_reg res}, %r1\n` + | Cgt -> ` locgrh {emit_reg res}, %r1\n` + | Cle -> ` locgrnh {emit_reg res}, %r1\n` + | Clt -> ` locgrl {emit_reg res}, %r1\n` + | Cge -> ` locgrnl {emit_reg res}, %r1\n` + end +*) + +(* Record live pointers at call points *) + +let record_frame_label ?label live raise_ dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in + let live_offset = ref [] in + Reg.Set.iter + (function + | {typ = Val; loc = Reg r} -> + live_offset := (r lsl 1) + 1 :: !live_offset + | {typ = Val; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | {typ = Addr} as r -> + Misc.fatal_error ("bad GC root " ^ Reg.name r) + | _ -> ()) + live; + record_frame_descr ~label:lbl ~frame_size:(frame_size()) + ~live_offset:!live_offset ~raise_frame:raise_ dbg; + lbl + +let record_frame ?label live raise_ dbg = + let lbl = record_frame_label ?label live raise_ dbg in + `{emit_label lbl}:` + +(* Record calls to caml_call_gc, emitted out of line. *) + +type gc_call = + { gc_lbl: label; (* Entry label *) + gc_return_lbl: label; (* Where to branch after GC *) + gc_frame_lbl: label } (* Label of frame descriptor *) + +let call_gc_sites = ref ([] : gc_call list) + +let emit_call_gc gc = + `{emit_label gc.gc_lbl}:`; emit_call "caml_call_gc"; + `{emit_label gc.gc_frame_lbl}: brcl 15, {emit_label gc.gc_return_lbl}\n` + +(* Record calls to caml_ml_array_bound_error, emitted out of line. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) +let bound_error_call = ref 0 + +let bound_error_label ?label dbg = + if !Clflags.debug then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}:`; emit_call "caml_ml_array_bound_error"; + `{emit_label bd.bd_frame}:\n` + +let emit_call_bound_errors () = + List.iter emit_call_bound_error !bound_error_sites; + if !bound_error_call > 0 then begin + `{emit_label !bound_error_call}:`; emit_call "caml_ml_array_bound_error"; + end + +(* Record floating-point and large integer literals *) + +let float_literals = ref ([] : (int64 * int) list) +let int_literals = ref ([] : (nativeint * int) list) + +(* Masks for conditional branches after comparisons *) + +let branch_for_comparison = function + Ceq -> 8 | Cne -> 7 + | Cle -> 12 | Cgt -> 2 + | Cge -> 10 | Clt -> 4 + +let name_for_int_comparison = function + Isigned cmp -> ("cgr", branch_for_comparison cmp) + | Iunsigned cmp -> ("clgr", branch_for_comparison cmp) + +let name_for_int_comparison_imm = function + Isigned cmp -> ("cgfi", branch_for_comparison cmp) + | Iunsigned cmp -> ("clgfi", branch_for_comparison cmp) + +(* bit 0 = eq, bit 1 = lt, bit 2 = gt, bit 3 = unordered*) +let branch_for_float_comparison cmp neg = + match cmp with + Ceq -> if neg then 7 else 8 + | Cne -> if neg then 8 else 7 + | Cle -> if neg then 3 else 12 + | Cgt -> if neg then 13 else 2 + | Cge -> if neg then 5 else 10 + | Clt -> if neg then 11 else 4 + +(* Names for various instructions *) + +let name_for_intop = function + Iadd -> "agr" + | Isub -> "sgr" + | Imul -> "msgr" + | Iand -> "ngr" + | Ior -> "ogr" + | Ixor -> "xgr" + | _ -> Misc.fatal_error "Emit.Intop" + +let name_for_floatop1 = function + Inegf -> "lcdbr" + | Iabsf -> "lpdbr" + | _ -> Misc.fatal_error "Emit.Iopf1" + +let name_for_floatop2 = function + Iaddf -> "adbr" + | Isubf -> "sdbr" + | Imulf -> "mdbr" + | Idivf -> "ddbr" + | _ -> Misc.fatal_error "Emit.Iopf2" + +let name_for_specific = function + Imultaddf -> "madbr" + | Imultsubf -> "msdbr" + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 + +(* Output the assembly code for an instruction *) + +let emit_instr i = + emit_debug_info i.dbg; + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + match (src, dst) with + {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} -> + ` lgr {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} -> + ` ldr {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} -> + ` stg {emit_reg src}, {emit_stack dst}\n` + | {loc = Reg _; typ = Float}, {loc = Stack _} -> + ` std {emit_reg src}, {emit_stack dst}\n` + | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} -> + ` lg {emit_reg dst}, {emit_stack src}\n` + | {loc = Stack _; typ = Float}, {loc = Reg _} -> + ` ldy {emit_reg dst}, {emit_stack src}\n` + | (_, _) -> + fatal_error "Emit: Imove" + end + | Lop(Iconst_int n) -> + if n >= -0x8000n && n <= 0x7FFFn then begin + ` lghi {emit_reg i.res.(0)}, {emit_nativeint n}\n`; + end else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin + ` lgfi {emit_reg i.res.(0)}, {emit_nativeint n}\n`; + end else begin + let lbl = new_label() in + int_literals := (n, lbl) :: !int_literals; + ` lgrl {emit_reg i.res.(0)}, {emit_label lbl}\n`; + end + | Lop(Iconst_float f) -> + let lbl = new_label() in + float_literals := (f, lbl) :: !float_literals; + ` larl %r1, {emit_label lbl}\n`; + ` ld {emit_reg i.res.(0)}, 0(%r1)\n` + | Lop(Iconst_symbol s) -> + emit_load_symbol_addr i.res.(0) s + | Lop(Icall_ind { label_after; }) -> + ` basr %r14, {emit_reg i.arg.(0)}\n`; + `{record_frame i.live false i.dbg ~label:label_after}\n` + + | Lop(Icall_imm { func; label_after; }) -> + emit_call func; + `{record_frame i.live false i.dbg ~label:label_after}\n` + | Lop(Itailcall_ind { label_after = _; }) -> + let n = frame_size() in + if !contains_calls then + ` lg %r14, {emit_int(n - size_addr)}(%r15)\n`; + emit_stack_adjust (-n); + ` br {emit_reg i.arg.(0)}\n` + | Lop(Itailcall_imm { func; label_after = _; }) -> + if func = !function_name then + ` brcl 15, {emit_label !tailrec_entry_point}\n` + else begin + let n = frame_size() in + if !contains_calls then + ` lg %r14, {emit_int(n - size_addr)}(%r15)\n`; + emit_stack_adjust (-n); + if !pic_code then + ` brcl 15, {emit_symbol func}@PLT\n` + else + ` brcl 15, {emit_symbol func}\n` + end + + | Lop(Iextcall { func; alloc; label_after; }) -> + if not alloc then emit_call func + else begin + emit_load_symbol_addr reg_r7 func; + emit_call "caml_c_call"; + `{record_frame i.live false i.dbg ~label:label_after}\n` + end + + | Lop(Istackoffset n) -> + emit_stack_adjust n; + stack_offset := !stack_offset + n + + | Lop(Iload(chunk, addr)) -> + let loadinstr = + match chunk with + Byte_unsigned -> "llgc" + | Byte_signed -> "lgb" + | Sixteen_unsigned -> "llgh" + | Sixteen_signed -> "lgh" + | Thirtytwo_unsigned -> "llgf" + | Thirtytwo_signed -> "lgf" + | Word_int | Word_val -> "lg" + | Single -> "ley" + | Double | Double_u -> "ldy" in + emit_load_store loadinstr addr i.arg 0 i.res.(0); + if chunk = Single then + ` ldebr {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + + | Lop(Istore(Single, addr, _)) -> + ` ledbr %f15, {emit_reg i.arg.(0)}\n`; + emit_load_store "stey" addr i.arg 1 reg_f15 + | Lop(Istore(chunk, addr, _)) -> + let storeinstr = + match chunk with + Byte_unsigned | Byte_signed -> "stcy" + | Sixteen_unsigned | Sixteen_signed -> "sthy" + | Thirtytwo_unsigned | Thirtytwo_signed -> "sty" + | Word_int | Word_val -> "stg" + | Single -> assert false + | Double | Double_u -> "stdy" in + emit_load_store storeinstr addr i.arg 1 i.arg.(0) + + | Lop(Ialloc { words = n; label_after_call_gc; }) -> + let lbl_redo = new_label() in + let lbl_call_gc = new_label() in + let lbl_frame = + record_frame_label i.live false i.dbg ?label:label_after_call_gc + in + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame_lbl = lbl_frame } :: !call_gc_sites; + `{emit_label lbl_redo}:`; + ` lay %r11, {emit_int(-n)}(%r11)\n`; + ` clgr %r11, %r10\n`; + ` brcl 4, {emit_label lbl_call_gc}\n`; (* less than *) + ` la {emit_reg i.res.(0)}, 8(%r11)\n` + + | Lop(Iintop Imulh) -> + (* Hacker's Delight section 8.3: + mul-high-signed(a, b) = mul-high-unsigned(a, b) + - a if b < 0 + - b if a < 0 + or, without branches, + mul-high-signed(a, b) = mul-high-unsigned(a, b) + - (a & (b >>s 63)) + - (b & (a >>s 63)) + *) + ` lgr %r1, {emit_reg i.arg.(0)}\n`; + ` mlgr %r0, {emit_reg i.arg.(1)}\n`; + (* r0:r1 is 128-bit unsigned product; r0 is the high bits *) + ` srag %r1, {emit_reg i.arg.(0)}, 63\n`; + ` ngr %r1, {emit_reg i.arg.(1)}\n`; + ` sgr %r0, %r1\n`; + ` srag %r1, {emit_reg i.arg.(1)}, 63\n`; + ` ngr %r1, {emit_reg i.arg.(0)}\n`; + ` sgr %r0, %r1\n`; + ` lgr {emit_reg i.res.(0)}, %r0\n` + | Lop(Iintop Imod) -> + ` lgr %r1, {emit_reg i.arg.(0)}\n`; + ` dsgr %r0, {emit_reg i.arg.(1)}\n`; + ` lgr {emit_reg i.res.(0)}, %r0\n` + | Lop(Iintop Idiv) -> + ` lgr %r1, {emit_reg i.arg.(0)}\n`; + ` dsgr %r0, {emit_reg i.arg.(1)}\n`; + ` lgr {emit_reg i.res.(0)}, %r1\n` + | Lop(Iintop Ilsl) -> + ` sllg {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(1)})\n` + | Lop(Iintop Ilsr) -> + ` srlg {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(1)})\n` + | Lop(Iintop Iasr) -> + ` srag {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(1)})\n` + | Lop(Iintop(Icomp cmp)) -> + let lbl = new_label() in + let (comp, mask) = name_for_int_comparison cmp in + ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` lghi {emit_reg i.res.(0)}, 1\n`; + ` brc {emit_int mask}, {emit_label lbl}\n`; + ` lghi {emit_reg i.res.(0)}, 0\n`; + `{emit_label lbl}:\n` + | Lop(Iintop (Icheckbound { label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in + ` clgr {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` brcl 12, {emit_label lbl}\n` (* branch if unsigned le *) + | Lop(Iintop op) -> + assert (i.arg.(0).loc = i.res.(0).loc); + let instr = name_for_intop op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop_imm(Iadd, n)) -> + emit_addimm i.res.(0) i.arg.(0) n + | Lop(Iintop_imm(Isub, n)) -> + emit_addimm i.res.(0) i.arg.(0) (-n) + | Lop(Iintop_imm(Icomp cmp, n)) -> + let lbl = new_label() in + let (comp, mask) = name_for_int_comparison_imm cmp in + ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}\n`; + ` lghi {emit_reg i.res.(0)}, 1\n`; + ` brc {emit_int mask}, {emit_label lbl}\n`; + ` lghi {emit_reg i.res.(0)}, 0\n`; + `{emit_label lbl}:\n` + | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in + if n >= 0 then begin + ` clgfi {emit_reg i.arg.(0)}, {emit_int n}\n`; + ` brcl 12, {emit_label lbl}\n` (* branch if unsigned le *) + end else begin + ` brcl 15, {emit_label lbl}\n` (* branch always *) + end + | Lop(Iintop_imm(Ilsl, n)) -> + ` sllg {emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n` + | Lop(Iintop_imm(Ilsr, n)) -> + ` srlg {emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n` + | Lop(Iintop_imm(Iasr, n)) -> + ` srag {emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n` + | Lop(Iintop_imm(Iand, n)) -> + assert (i.arg.(0).loc = i.res.(0).loc); + ` nilf {emit_reg i.res.(0)}, {emit_int (n land (1 lsl 32 - 1)(*0xFFFF_FFFF*))}\n` + | Lop(Iintop_imm(Ior, n)) -> + assert (i.arg.(0).loc = i.res.(0).loc); + ` oilf {emit_reg i.res.(0)}, {emit_int n}\n` + | Lop(Iintop_imm(Ixor, n)) -> + assert (i.arg.(0).loc = i.res.(0).loc); + ` xilf {emit_reg i.res.(0)}, {emit_int n}\n` + | Lop(Iintop_imm(Imul, n)) -> + assert (i.arg.(0).loc = i.res.(0).loc); + ` msgfi {emit_reg i.res.(0)}, {emit_int n}\n` + | Lop(Iintop_imm((Imulh | Idiv | Imod), _)) -> + assert false + | Lop(Inegf | Iabsf as op) -> + let instr = name_for_floatop1 op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> + assert (i.arg.(0).loc = i.res.(0).loc); + let instr = name_for_floatop2 op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n`; + | Lop(Ifloatofint) -> + ` cdgbr {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | Lop(Iintoffloat) -> + (* rounding method #5 = round toward 0 *) + ` cgdbr {emit_reg i.res.(0)}, 5, {emit_reg i.arg.(0)}\n` + | Lop(Ispecific sop) -> + assert (i.arg.(2).loc = i.res.(0).loc); + let instr = name_for_specific sop in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lreloadretaddr -> + let n = frame_size() in + ` lg %r14, {emit_int(n - size_addr)}(%r15)\n` + | Lreturn -> + let n = frame_size() in + emit_stack_adjust (-n); + ` br %r14\n` + | Llabel lbl -> + `{emit_label lbl}:\n` + | Lbranch lbl -> + ` brcl 15,{emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + ` cgfi {emit_reg i.arg.(0)}, 0\n`; + ` brcl 7, {emit_label lbl}\n` + | Ifalsetest -> + ` cgfi {emit_reg i.arg.(0)}, 0\n`; + ` brcl 8, {emit_label lbl}\n` + | Iinttest cmp -> + let (comp, mask) = name_for_int_comparison cmp in + ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` brcl {emit_int mask}, {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + let (comp, mask) = name_for_int_comparison_imm cmp in + ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}\n`; + ` brcl {emit_int mask}, {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + ` cdbr {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + let mask = branch_for_float_comparison cmp neg in + ` brcl {emit_int mask}, {emit_label lbl}\n` + | Ioddtest -> + ` tmll {emit_reg i.arg.(0)}, 1\n`; + ` brcl 1, {emit_label lbl}\n` + | Ieventest -> + ` tmll {emit_reg i.arg.(0)}, 1\n`; + ` brcl 8, {emit_label lbl}\n` + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cgfi {emit_reg i.arg.(0)}, 1\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` brcl 4, {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` brcl 8, {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` brcl 2, {emit_label lbl}\n` + end + | Lswitch jumptbl -> + let lbl = new_label() in + ` larl %r0, {emit_label lbl}\n`; + ` sllg %r1, {emit_reg i.arg.(0)}, 2(%r0)\n`; + ` agr %r1, %r0\n`; + ` lgf %r1, 0(%r1)\n`; + ` agr %r1, %r0\n`; + ` br %r1\n`; + emit_string rodata_space; + ` .align 8\n`; + `{emit_label lbl}:`; + for i = 0 to Array.length jumptbl - 1 do + ` .long {emit_label jumptbl.(i)} - {emit_label lbl}\n` + done; + emit_string code_space + | Lsetuptrap lbl -> + ` brasl %r14, {emit_label lbl}\n`; + | Lpushtrap -> + stack_offset := !stack_offset + 16; + emit_stack_adjust 16; + ` stg %r14, 0(%r15)\n`; + ` stg %r13, {emit_int size_addr}(%r15)\n`; + ` lgr %r13, %r15\n` + | Lpoptrap -> + ` lg %r13, {emit_int size_addr}(%r15)\n`; + emit_stack_adjust (-16); + stack_offset := !stack_offset - 16 + | Lraise k -> + begin match k with + | Cmm.Raise_withtrace -> + emit_call "caml_raise_exn"; + `{record_frame Reg.Set.empty true i.dbg}\n` + | Cmm.Raise_notrace -> + ` lg %r1, 0(%r13)\n`; + ` lgr %r15, %r13\n`; + ` lg %r13, {emit_int size_addr}(%r15)\n`; + emit_stack_adjust (-16); + ` br %r1\n` + end + + +(* Emit a sequence of instructions *) + +let rec emit_all i = + match i with + {desc = Lend} -> () + | _ -> + emit_instr i; + emit_all i.next + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + tailrec_entry_point := new_label(); + stack_offset := 0; + call_gc_sites := []; + bound_error_sites := []; + bound_error_call := 0; + float_literals := []; + int_literals := []; + ` .globl {emit_symbol fundecl.fun_name}\n`; + emit_debug_info fundecl.fun_dbg; + ` .type {emit_symbol fundecl.fun_name}, @function\n`; + emit_string code_space; + ` .align 8\n`; + `{emit_symbol fundecl.fun_name}:\n`; + let n = frame_size() in + emit_stack_adjust n; + if !contains_calls then + ` stg %r14, {emit_int(n - size_addr)}(%r15)\n`; + `{emit_label !tailrec_entry_point}:\n`; + emit_all fundecl.fun_body; + (* Emit the glue code to call the GC *) + List.iter emit_call_gc !call_gc_sites; + (* Emit the glue code to handle bound errors *) + emit_call_bound_errors(); + (* Emit the numeric literals *) + if !float_literals <> [] || !int_literals <> [] then begin + emit_string rodata_space; + ` .align 8\n`; + List.iter + (fun (f, lbl) -> + `{emit_label lbl}:`; + emit_float64_directive ".quad" f) + !float_literals; + List.iter + (fun (n, lbl) -> + `{emit_label lbl}: .quad {emit_nativeint n}\n`) + !int_literals + end + +(* Emission of data *) + +let declare_global_data s = + ` .globl {emit_symbol s}\n`; + ` .type {emit_symbol s}, @object\n` + +let emit_item = function + Cglobal_symbol s -> + declare_global_data s + | Cdefine_symbol s -> + `{emit_symbol s}:\n`; + | Cint8 n -> + ` .byte {emit_int n}\n` + | Cint16 n -> + ` .short {emit_int n}\n` + | Cint32 n -> + ` .long {emit_nativeint n}\n` + | Cint n -> + ` .quad {emit_nativeint n}\n` + | Csingle f -> + emit_float32_directive ".long" (Int32.bits_of_float f) + | Cdouble f -> + emit_float64_directive ".quad" (Int64.bits_of_float f) + | Csymbol_address s -> + ` .quad {emit_symbol s}\n` + | Cstring s -> + emit_bytes_directive " .byte " s + | Cskip n -> + if n > 0 then ` .space {emit_int n}\n` + | Calign n -> + if n < 8 then ` .align 8\n` + else ` .align {emit_int n}\n` + +let data l = + emit_string data_space; + ` .align 8\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + reset_debug_info(); + ` .file \"\"\n`; (* PR#7037 *) + (* Emit the beginning of the segments *) + let lbl_begin = Compilenv.make_symbol (Some "data_begin") in + emit_string data_space; + ` .align 8\n`; + declare_global_data lbl_begin; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.make_symbol (Some "code_begin") in + emit_string code_space; + declare_global_data lbl_begin; + `{emit_symbol lbl_begin}:\n` + +let end_assembly() = + (* Emit the end of the segments *) + emit_string code_space; + let lbl_end = Compilenv.make_symbol (Some "code_end") in + declare_global_data lbl_end; + `{emit_symbol lbl_end}:\n`; + ` .long 0\n`; + emit_string data_space; + ` .align 8\n`; + let lbl_end = Compilenv.make_symbol (Some "data_end") in + declare_global_data lbl_end; + `{emit_symbol lbl_end}:\n`; + ` .quad 0\n`; + (* Emit the frame descriptors *) + emit_string rodata_space; + ` .align 8\n`; + let lbl = Compilenv.make_symbol (Some "frametable") in + declare_global_data lbl; + `{emit_symbol lbl}:\n`; + emit_frames + { efa_code_label = (fun l -> ` .quad {emit_label l}\n`); + efa_data_label = (fun l -> ` .quad {emit_label l}\n`); + efa_16 = (fun n -> ` .short {emit_int n}\n`); + efa_32 = (fun n -> ` .long {emit_int32 n}\n`); + efa_word = (fun n -> ` .quad {emit_int n}\n`); + efa_align = (fun n -> ` .align {emit_int n}\n`); + efa_label_rel = (fun lbl ofs -> + ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`); + efa_def_label = (fun l -> `{emit_label l}:\n`); + efa_string = (fun s -> emit_bytes_directive " .byte " (s ^ "\000")) + }; + (* Mark stack as non-executable *) + ` .section .note.GNU-stack,\"\",%progbits\n` diff -Nru ocaml-4.01.0/asmcomp/s390x/NOTES.md ocaml-4.05.0/asmcomp/s390x/NOTES.md --- ocaml-4.01.0/asmcomp/s390x/NOTES.md 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/s390x/NOTES.md 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,16 @@ +# Supported platforms + +IBM z Systems version 10 and up, in 64-bit flat addressing mode, +running Linux (Debian architecture: `s390x`). + +# Reference documents + +* Instruction set architecture: + _z/Architecture Principles of Operation_, + SA22-7832-07, eight edition (Feb 2009). + This is the version that corresponds to z10. + Newer versions of this manual include additional instructions + that are not in z10. +* ELF ABI: + _zSeries ELF Application Binary Interface Supplement_ + (http://refspecs.linuxfoundation.org/ELF/zSeries/index.html) diff -Nru ocaml-4.01.0/asmcomp/s390x/proc.ml ocaml-4.05.0/asmcomp/s390x/proc.ml --- ocaml-4.01.0/asmcomp/s390x/proc.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/s390x/proc.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,214 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Bill O'Farrell, IBM *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2015 IBM (Bill O'Farrell with help from Tristan Amini). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Description of the Z Processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Instruction selection *) + +let word_addressed = false + +(* Registers available for register allocation *) + +(* Integer register map: + 0 temporary, null register for some operations (volatile) + 1 temporary (volatile) + 2 - 5 function arguments and results (volatile) + 6 function arguments and results (persevered by C) + 7 - 9 general purpose, preserved by C + 10 allocation limit (preserved by C) + 11 allocation pointer (preserved by C) + 12 general purpose (preserved by C) + 13 trap pointer (preserved by C) + 14 return address (volatile) + 15 stack pointer (preserved by C) + Floating-point register map: + 0, 2, 4, 6 function arguments and results (volatile) + 1, 3, 5, 7 general purpose (volatile) + 8 - 14 general purpose, preserved by C + 15 temporary, preserved by C + +Note: integer register r12 is used as GOT pointer by some C compilers. +The code generated by OCaml does not need a GOT pointer, using PC-relative +addressing instead for accessing the GOT. This frees r12 as a +general-purpose register. *) + +let int_reg_name = + [| "%r2"; "%r3"; "%r4"; "%r5"; "%r6"; "%r7"; "%r8"; "%r9"; "%r12" |] + +let float_reg_name = + [| "%f0"; "%f2"; "%f4"; "%f6"; "%f1"; "%f3"; "%f5"; "%f7"; + "%f8"; "%f9"; "%f10"; "%f11"; "%f12"; "%f13"; "%f14"; "%f15" |] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + | Val | Int | Addr -> 0 + | Float -> 1 + +let num_available_registers = [| 9; 15 |] + +let first_available_register = [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +let rotate_registers = true + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.make 9 Reg.dummy in + for i = 0 to 8 do v.(i) <- Reg.at_location Int (Reg i) done; v + +let hard_float_reg = + let v = Array.make 16 Reg.dummy in + for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *) + +(* Calling conventions *) + +let calling_conventions + first_int last_int first_float last_float make_stack stack_ofs arg = + let loc = Array.make (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref stack_ofs in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + | Val | Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, Misc.align !ofs 16) + (* Keep stack 16-aligned. *) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" + +let max_arguments_for_tailcalls = 5 + +let loc_arguments arg = + calling_conventions 0 4 100 103 outgoing 0 arg +let loc_parameters arg = + let (loc, _ofs) = calling_conventions 0 4 100 103 incoming 0 arg in loc +let loc_results res = + let (loc, _ofs) = calling_conventions 0 4 100 103 not_supported 0 res in loc + +(* C calling conventions under SVR4: + use GPR 2-6 and FPR 0,2,4,6 just like ML calling conventions. + Using a float register does not affect the int registers. + Always reserve 160 bytes at bottom of stack, plus whatever is needed + to hold the overflow arguments. *) + +let loc_external_arguments arg = + let arg = + Array.map (fun regs -> assert (Array.length regs = 1); regs.(0)) arg in + let (loc, ofs) = + calling_conventions 0 4 100 103 outgoing 160 arg in + (Array.map (fun reg -> [|reg|]) loc, ofs) + +(* Results are in GPR 2 and FPR 0 *) + +let loc_external_results res = + let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc + +(* Exceptions are in GPR 2 *) + +let loc_exn_bucket = phys_reg 0 + +(* Volatile registers: none *) + +let regs_are_volatile _rs = false + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = + Array.of_list(List.map phys_reg + [0; 1; 2; 3; 4; + 100; 101; 102; 103; 104; 105; 106; 107]) + +let destroyed_at_oper = function + Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _ }) -> + all_phys_regs + | Iop(Iextcall { alloc = false; _ }) -> destroyed_at_c_call + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + Iextcall _ -> 4 + | _ -> 9 + +let max_register_pressure = function + Iextcall _ -> [| 4; 7 |] + | _ -> [| 9; 15 |] + +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false + | Ispecific(Imultaddf | Imultsubf) -> true + | _ -> true + +(* Layout of the stack *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) + +let init () = () diff -Nru ocaml-4.01.0/asmcomp/s390x/reload.ml ocaml-4.05.0/asmcomp/s390x/reload.ml --- ocaml-4.01.0/asmcomp/s390x/reload.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/s390x/reload.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Reloading for the Z Processor *) + +open Arch +open Mach + +class reload = object (self) + +inherit Reloadgen.reload_generic as super + +(* For 2-address instructions, reloading must make sure that the + temporary result register is the same as the appropriate + argument register. *) + +method! reload_operation op arg res = + match op with + (* Two-address binary operations: arg.(0) and res.(0) must be the same *) + | Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf -> + let res = self#makereg res.(0) in + ([|res; self#makereg arg.(1)|], [|res|]) + (* Three-address ternary operations: arg.(2) and res.(0) must be the same *) + | Ispecific(Imultaddf|Imultsubf) -> + let res = self#makereg res.(0) in + ([|self#makereg arg.(0); self#makereg arg.(1); res|], [|res|]) + (* One-address unary operations: arg.(0) and res.(0) must be the same *) + | Iintop_imm((Imul|Iand|Ior|Ixor), _) -> + let res = self#makereg res.(0) in + ([|res|], [|res|]) + (* Other instructions are regular *) + | _ -> + super#reload_operation op arg res + +end + +let fundecl f = + (new reload)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/s390x/scheduling.ml ocaml-4.05.0/asmcomp/s390x/scheduling.ml --- ocaml-4.01.0/asmcomp/s390x/scheduling.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/s390x/scheduling.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Bill O'Farrell, IBM *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2015 IBM (Bill O'Farrell with help from Tristan Amini). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Instruction scheduling for the Z processor *) + +open Arch +open Mach + +(* The z10 processor is in-order, dual-issue. It could benefit from some + basic-block scheduling, although precise latency information + is not available. + The z196 and later are out-of-order processors. Basic-block + scheduling probably makes no difference. *) + +class scheduler = object + +inherit Schedgen.scheduler_generic + +(* Latencies (in cycles). Wild guesses. We multiply all latencies by 2 + to favor dual-issue. *) + +method oper_latency = function + Ireload -> 4 + | Iload(_, _) -> 4 + | Iconst_float _ -> 4 (* turned into a load *) + | Iintop(Imul) -> 10 + | Iintop_imm(Imul, _) -> 10 + | Iaddf | Isubf | Imulf -> 8 + | Idivf -> 40 + | Ispecific(Imultaddf | Imultsubf) -> 8 + | _ -> 2 + +method! reload_retaddr_latency = 4 + +(* Issue cycles. Rough approximations. *) + +method oper_issue_cycles = function + | Ialloc _ -> 4 + | Iintop(Imulh) -> 15 + | Iintop(Idiv|Imod) -> 20 + | Iintop(Icomp _) -> 4 + | Iintop_imm(Icomp _, _) -> 4 + | _ -> 1 + +method! reload_retaddr_issue_cycles = 1 + +end + +let fundecl f = (new scheduler)#schedule_fundecl f diff -Nru ocaml-4.01.0/asmcomp/s390x/selection.ml ocaml-4.05.0/asmcomp/s390x/selection.ml --- ocaml-4.01.0/asmcomp/s390x/selection.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/s390x/selection.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,120 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Bill O'Farrell, IBM *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2015 IBM (Bill O'Farrell with help from Tristan Amini). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Instruction selection for the Z processor *) + +open Cmm +open Arch +open Mach + +(* Recognition of addressing modes *) + +exception Use_default + +type addressing_expr = + | Alinear of expression + | Aadd of expression * expression + +let rec select_addr = function + | Cop((Caddi | Cadda | Caddv), [arg; Cconst_int m], _) -> + let (a, n) = select_addr arg in (a, n + m) + | Cop((Caddi | Cadda | Caddv), [Cconst_int m; arg], _) -> + let (a, n) = select_addr arg in (a, n + m) + | Cop((Caddi | Cadda | Caddv), [arg1; arg2], _) -> + begin match (select_addr arg1, select_addr arg2) with + ((Alinear e1, n1), (Alinear e2, n2)) -> + (Aadd(e1, e2), n1 + n2) + | _ -> + (Aadd(arg1, arg2), 0) + end + | exp -> + (Alinear exp, 0) + +(* Instruction selection *) + +let pseudoregs_for_operation op arg res = + match op with + (* Two-address binary operations: arg.(0) and res.(0) must be the same *) + | Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf -> + ([|res.(0); arg.(1)|], res) + | Ispecific _ -> + ( [| arg.(0); arg.(1); res.(0) |], [| res.(0) |]) + (* One-address unary operations: arg.(0) and res.(0) must be the same *) + | Iintop_imm((Imul|Iand|Ior|Ixor), _) -> (res, res) + (* Other instructions are regular *) + | _ -> raise Use_default + +class selector = object (self) + +inherit Selectgen.selector_generic as super + +method is_immediate n = n <= 0x7FFF_FFFF && n >= (-1-0x7FFF_FFFF) + (* -1-.... : hack so that this can be compiled on 32-bit + (cf 'make check_all_arches') *) + +method select_addressing _chunk exp = + let (a, d) = select_addr exp in + (* 20-bit signed displacement *) + if d < 0x80000 && d >= -0x80000 then begin + match a with + | Alinear e -> (Iindexed d, e) + | Aadd(e1, e2) -> (Iindexed2 d, Ctuple [e1; e2]) + end else + (Iindexed 0, exp) + +method! select_operation op args dbg = + match (op, args) with + (* Z does not support immediate operands for multiply high *) + (Cmulhi, _) -> (Iintop Imulh, args) + (* The and, or and xor instructions have a different range of immediate + operands than the other instructions *) + | (Cand, _) -> + self#select_logical Iand (-1 lsl 32 (*0x1_0000_0000*)) (-1) args + | (Cor, _) -> self#select_logical Ior 0 (1 lsl 32 - 1 (*0xFFFF_FFFF*)) args + | (Cxor, _) -> self#select_logical Ixor 0 (1 lsl 32 - 1 (*0xFFFF_FFFF*)) args + (* Recognize mult-add and mult-sub instructions *) + | (Caddf, [Cop(Cmulf, [arg1; arg2], _); arg3]) -> + (Ispecific Imultaddf, [arg1; arg2; arg3]) + | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2], _)]) -> + (Ispecific Imultaddf, [arg1; arg2; arg3]) + | (Csubf, [Cop(Cmulf, [arg1; arg2], _); arg3]) -> + (Ispecific Imultsubf, [arg1; arg2; arg3]) + | _ -> + super#select_operation op args dbg + +method select_logical op lo hi = function + [arg; Cconst_int n] when n >= lo && n <= hi -> + (Iintop_imm(op, n), [arg]) + | [Cconst_int n; arg] when n >= lo && n <= hi -> + (Iintop_imm(op, n), [arg]) + | args -> + (Iintop op, args) + + +method! insert_op_debug op dbg rs rd = + try + let (rsrc, rdst) = pseudoregs_for_operation op rs rd in + self#insert_moves rs rsrc; + self#insert_debug (Iop op) dbg rsrc rdst; + self#insert_moves rdst rd; + rd + with Use_default -> + super#insert_op_debug op dbg rs rd + +end + +let fundecl f = (new selector)#emit_fundecl f diff -Nru ocaml-4.01.0/asmcomp/schedgen.ml ocaml-4.05.0/asmcomp/schedgen.ml --- ocaml-4.01.0/asmcomp/schedgen.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/schedgen.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Instruction scheduling *) @@ -132,20 +135,22 @@ (* We treat Lreloadretaddr as a word-sized load *) -let some_load = (Iload(Cmm.Word, Arch.identity_addressing)) +let some_load = (Iload(Cmm.Word_int, Arch.identity_addressing)) (* The generic scheduler *) class virtual scheduler_generic = object (self) +val mutable trywith_nesting = 0 + (* Determine whether an operation ends a basic block or not. Can be overridden for some processors to signal specific instructions that terminate a basic block. *) method oper_in_basic_block = function - Icall_ind -> false + Icall_ind _ -> false | Icall_imm _ -> false - | Itailcall_ind -> false + | Itailcall_ind _ -> false | Itailcall_imm _ -> false | Iextcall _ -> false | Istackoffset _ -> false @@ -154,9 +159,16 @@ (* Determine whether an instruction ends a basic block or not *) -method private instr_in_basic_block instr = +(* PR#2719: it is generally incorrect to schedule checkbound instructions + within a try ... with Invalid_argument _ -> ... + Hence, a checkbound instruction within a try...with block ends the + current basic block. *) + +method private instr_in_basic_block instr try_nesting = match instr.desc with - Lop op -> self#oper_in_basic_block op + Lop op -> + self#oper_in_basic_block op && + not (try_nesting > 0 && self#is_checkbound op) | Lreloadretaddr -> true | _ -> false @@ -165,7 +177,7 @@ load or store instructions (e.g. on the I386). *) method is_store = function - Istore(_, _) -> true + Istore(_, _, _) -> true | _ -> false method is_load = function @@ -173,8 +185,8 @@ | _ -> false method is_checkbound = function - Iintop Icheckbound -> true - | Iintop_imm(Icheckbound, _) -> true + Iintop (Icheckbound _) -> true + | Iintop_imm(Icheckbound _, _) -> true | _ -> false method private instr_is_store instr = @@ -336,8 +348,8 @@ if son.emitted_ancestors = son.ancestors then new_queue := son :: !new_queue) node.sons; - instr_cons node.instr.desc node.instr.arg node.instr.res - (self#reschedule !new_queue (date + issue_cycles) cont) + { node.instr with next = + self#reschedule !new_queue (date + issue_cycles) cont } end (* Entry point *) @@ -345,38 +357,44 @@ method schedule_fundecl f = - let rec schedule i = + let rec schedule i try_nesting = match i.desc with - Lend -> i + | Lend -> i + | Lpushtrap -> { i with next = schedule i.next (try_nesting + 1) } + | Lpoptrap -> { i with next = schedule i.next (try_nesting - 1) } | _ -> - if self#instr_in_basic_block i then begin + if self#instr_in_basic_block i try_nesting then begin clear_code_dag(); - schedule_block [] i + schedule_block [] i try_nesting end else - { i with next = schedule i.next } + { i with next = schedule i.next try_nesting } - and schedule_block ready_queue i = - if self#instr_in_basic_block i then - schedule_block (self#add_instruction ready_queue i) i.next + and schedule_block ready_queue i try_nesting = + if self#instr_in_basic_block i try_nesting then + schedule_block (self#add_instruction ready_queue i) i.next try_nesting else begin let critical_outputs = match i.desc with - Lop(Icall_ind | Itailcall_ind) -> [| i.arg.(0) |] + Lop(Icall_ind _ | Itailcall_ind _) -> [| i.arg.(0) |] | Lop(Icall_imm _ | Itailcall_imm _ | Iextcall _) -> [||] | Lreturn -> [||] | _ -> i.arg in List.iter (fun x -> ignore (longest_path critical_outputs x)) ready_queue; - self#reschedule ready_queue 0 (schedule i) + self#reschedule ready_queue 0 (schedule i try_nesting) end in if f.fun_fast then begin - let new_body = schedule f.fun_body in + let new_body = schedule f.fun_body 0 in clear_code_dag(); { fun_name = f.fun_name; fun_body = new_body; fun_fast = f.fun_fast; - fun_dbg = f.fun_dbg } + fun_dbg = f.fun_dbg; + fun_spacetime_shape = f.fun_spacetime_shape; + } end else f end + +let reset () = clear_code_dag () diff -Nru ocaml-4.01.0/asmcomp/schedgen.mli ocaml-4.05.0/asmcomp/schedgen.mli --- ocaml-4.01.0/asmcomp/schedgen.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/schedgen.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Instruction scheduling *) @@ -42,3 +45,5 @@ (* Entry point *) method schedule_fundecl : Linearize.fundecl -> Linearize.fundecl end + +val reset : unit -> unit diff -Nru ocaml-4.01.0/asmcomp/scheduling.mli ocaml-4.05.0/asmcomp/scheduling.mli --- ocaml-4.01.0/asmcomp/scheduling.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/scheduling.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Instruction scheduling *) diff -Nru ocaml-4.01.0/asmcomp/selectgen.ml ocaml-4.05.0/asmcomp/selectgen.ml --- ocaml-4.01.0/asmcomp/selectgen.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/selectgen.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) @@ -18,45 +21,70 @@ open Reg open Mach -type environment = (Ident.t, Reg.t array) Tbl.t +type environment = + { vars : (Ident.t, Reg.t array) Tbl.t; + static_exceptions : (int, Reg.t array list) Tbl.t; + (** Which registers must be populated when jumping to the given + handler. *) + } + +let env_add id v env = + { env with vars = Tbl.add id v env.vars } + +let env_add_static_exception id v env = + { env with static_exceptions = Tbl.add id v env.static_exceptions } + +let env_find id env = + Tbl.find id env.vars + +let env_find_static_exception id env = + Tbl.find id env.static_exceptions + +let env_empty = { + vars = Tbl.empty; + static_exceptions = Tbl.empty; +} (* Infer the type of the result of an operation *) let oper_result_type = function - Capply(ty, _) -> ty - | Cextcall(s, ty, alloc, _) -> ty - | Cload c -> + Capply ty -> ty + | Cextcall(_s, ty, _alloc, _) -> ty + | Cload (c, _) -> begin match c with - Word -> typ_addr + | Word_val -> typ_val | Single | Double | Double_u -> typ_float | _ -> typ_int end - | Calloc -> typ_addr - | Cstore c -> typ_void - | Caddi | Csubi | Cmuli | Cdivi | Cmodi | + | Calloc -> typ_val + | Cstore (_c, _) -> typ_void + | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Ccmpa _ | Ccmpf _ -> typ_int - | Cadda | Csuba -> typ_addr + | Caddv -> typ_val + | Cadda -> typ_addr | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf -> typ_float | Cfloatofint -> typ_float | Cintoffloat -> typ_int | Craise _ -> typ_void - | Ccheckbound _ -> typ_void + | Ccheckbound -> typ_void -(* Infer the size in bytes of the result of a simple expression *) +(* Infer the size in bytes of the result of an expression whose evaluation + may be deferred (cf. [emit_parts]). *) -let size_expr env exp = +let size_expr (env:environment) exp = let rec size localenv = function Cconst_int _ | Cconst_natint _ -> Arch.size_int | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ -> Arch.size_addr | Cconst_float _ -> Arch.size_float + | Cblockheader _ -> Arch.size_int | Cvar id -> begin try Tbl.find id localenv with Not_found -> try - let regs = Tbl.find id env in + let regs = env_find id env in size_machtype (Array.map (fun r -> r.typ) regs) with Not_found -> fatal_error("Selection.size_expr: unbound var " ^ @@ -64,11 +92,11 @@ end | Ctuple el -> List.fold_right (fun e sz -> size localenv e + sz) el 0 - | Cop(op, args) -> + | Cop(op, _, _) -> size_machtype(oper_result_type op) | Clet(id, arg, body) -> size (Tbl.add id (size localenv arg) localenv) body - | Csequence(e1, e2) -> + | Csequence(_e1, e2) -> size localenv e2 | _ -> fatal_error "Selection.size_expr" @@ -85,7 +113,7 @@ let all_regs_anonymous rv = try for i = 0 to Array.length rv - 1 do - if String.length rv.(i).name > 0 then raise Exit + if not (Reg.anonymous rv.(i)) then raise Exit done; true with Exit -> @@ -93,10 +121,11 @@ let name_regs id rv = if Array.length rv = 1 then - rv.(0).name <- Ident.name id + rv.(0).raw_name <- Raw_name.create_from_ident id else for i = 0 to Array.length rv - 1 do - rv.(i).name <- Ident.name id ^ "#" ^ string_of_int i + rv.(i).raw_name <- Raw_name.create_from_ident id; + rv.(i).part <- Some i done (* "Join" two instruction sequences, making sure they return their results @@ -109,16 +138,21 @@ | (Some r1, Some r2) -> let l1 = Array.length r1 in assert (l1 = Array.length r2); - let r = Array.create l1 Reg.dummy in + let r = Array.make l1 Reg.dummy in for i = 0 to l1-1 do - if String.length r1.(i).name = 0 then begin + if Reg.anonymous r1.(i) + && Cmm.ge_component r1.(i).typ r2.(i).typ + then begin r.(i) <- r1.(i); seq2#insert_move r2.(i) r1.(i) - end else if String.length r2.(i).name = 0 then begin + end else if Reg.anonymous r2.(i) + && Cmm.ge_component r2.(i).typ r1.(i).typ + then begin r.(i) <- r2.(i); seq1#insert_move r1.(i) r2.(i) end else begin - r.(i) <- Reg.create r1.(i).typ; + let typ = Cmm.lub_component r1.(i).typ r2.(i).typ in + r.(i) <- Reg.create typ; seq1#insert_move r1.(i) r.(i); seq2#insert_move r2.(i) r.(i) end @@ -130,16 +164,25 @@ let join_array rs = let some_res = ref None in for i = 0 to Array.length rs - 1 do - let (r, s) = rs.(i) in - if r <> None then some_res := r + let (r, _) = rs.(i) in + match r with + | None -> () + | Some r -> + match !some_res with + | None -> some_res := Some (r, Array.map (fun r -> r.typ) r) + | Some (r', types) -> + let types = + Array.map2 (fun r typ -> Cmm.lub_component r.typ typ) r types + in + some_res := Some (r', types) done; match !some_res with None -> None - | Some template -> + | Some (template, types) -> let size_res = Array.length template in - let res = Array.create size_res Reg.dummy in + let res = Array.make size_res Reg.dummy in for i = 0 to size_res - 1 do - res.(i) <- Reg.create template.(i).typ + res.(i) <- Reg.create types.(i) done; for i = 0 to Array.length rs - 1 do let (r, s) = rs.(i) in @@ -149,31 +192,93 @@ done; Some res -(* Extract debug info contained in a C-- operation *) -let debuginfo_op = function - | Capply(_, dbg) -> dbg - | Cextcall(_, _, _, dbg) -> dbg - | Craise dbg -> dbg - | Ccheckbound dbg -> dbg - | _ -> Debuginfo.none - -(* Registers for catch constructs *) -let catch_regs = ref [] - (* Name of function being compiled *) let current_function_name = ref "" +module Effect = struct + type t = + | None + | Raise + | Arbitrary + + let join t1 t2 = + match t1, t2 with + | None, t2 -> t2 + | t1, None -> t1 + | Raise, Raise -> Raise + | Arbitrary, _ | _, Arbitrary -> Arbitrary + + let pure = function + | None -> true + | Raise | Arbitrary -> false +end + +module Coeffect = struct + type t = + | None + | Read_mutable + | Arbitrary + + let join t1 t2 = + match t1, t2 with + | None, t2 -> t2 + | t1, None -> t1 + | Read_mutable, Read_mutable -> Read_mutable + | Arbitrary, _ | _, Arbitrary -> Arbitrary + + let copure = function + | None -> true + | Read_mutable | Arbitrary -> false +end + +module Effect_and_coeffect : sig + type t + + val none : t + val arbitrary : t + + val effect : t -> Effect.t + val coeffect : t -> Coeffect.t + + val pure_and_copure : t -> bool + + val effect_only : Effect.t -> t + val coeffect_only : Coeffect.t -> t + + val join : t -> t -> t + val join_list_map : 'a list -> ('a -> t) -> t +end = struct + type t = Effect.t * Coeffect.t + + let none = Effect.None, Coeffect.None + let arbitrary = Effect.Arbitrary, Coeffect.Arbitrary + + let effect (e, _ce) = e + let coeffect (_e, ce) = ce + + let pure_and_copure (e, ce) = Effect.pure e && Coeffect.copure ce + + let effect_only e = e, Coeffect.None + let coeffect_only ce = Effect.None, ce + + let join (e1, ce1) (e2, ce2) = + Effect.join e1 e2, Coeffect.join ce1 ce2 + + let join_list_map xs f = + match xs with + | [] -> none + | x::xs -> List.fold_left (fun acc x -> join acc (f x)) (f x) xs +end + (* The default instruction selection class *) class virtual selector_generic = object (self) -(* Says if an expression is "simple". A "simple" expression has no - side-effects and its execution can be delayed until its value - is really needed. In the case of e.g. an [alloc] instruction, - the non-simple arguments are computed in right-to-left order - first, then the block is allocated, then the simple arguments are - evaluated and stored. *) - +(* A syntactic criterion used in addition to judgements about (co)effects as + to whether the evaluation of a given expression may be deferred by + [emit_parts]. This criterion is a property of the instruction selection + algorithm in this file rather than a property of the Cmm language. +*) method is_simple_expr = function Cconst_int _ -> true | Cconst_natint _ -> true @@ -181,19 +286,67 @@ | Cconst_symbol _ -> true | Cconst_pointer _ -> true | Cconst_natpointer _ -> true + | Cblockheader _ -> true | Cvar _ -> true | Ctuple el -> List.for_all self#is_simple_expr el - | Clet(id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body + | Clet(_id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body | Csequence(e1, e2) -> self#is_simple_expr e1 && self#is_simple_expr e2 - | Cop(op, args) -> + | Cop(op, args, _) -> begin match op with (* The following may have side effects *) | Capply _ | Cextcall _ | Calloc | Cstore _ | Craise _ -> false (* The remaining operations are simple if their args are *) - | _ -> - List.for_all self#is_simple_expr args + | Cload _ | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor + | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf + | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat + | Ccmpf _ | Ccheckbound -> List.for_all self#is_simple_expr args end - | _ -> false + | Cassign _ | Cifthenelse _ | Cswitch _ | Cloop _ | Ccatch _ | Cexit _ + | Ctrywith _ -> false + +(* Analyses the effects and coeffects of an expression. This is used across + a whole list of expressions with a view to determining which expressions + may have their evaluation deferred. The result of this function, modulo + target-specific judgements if the [effects_of] method is overridden, is a + property of the Cmm language rather than anything particular about the + instruction selection algorithm in this file. + + In the case of e.g. an OCaml function call, the arguments whose evaluation + cannot be deferred (cf. [emit_parts], below) are computed in right-to-left + order first with their results going into temporaries, then the block is + allocated, then the remaining arguments are evaluated before being + combined with the temporaries. *) +method effects_of exp = + let module EC = Effect_and_coeffect in + match exp with + | Cconst_int _ | Cconst_natint _ | Cconst_float _ | Cconst_symbol _ + | Cconst_pointer _ | Cconst_natpointer _ | Cblockheader _ + | Cvar _ -> EC.none + | Ctuple el -> EC.join_list_map el self#effects_of + | Clet (_id, arg, body) -> + EC.join (self#effects_of arg) (self#effects_of body) + | Csequence (e1, e2) -> + EC.join (self#effects_of e1) (self#effects_of e2) + | Cifthenelse (cond, ifso, ifnot) -> + EC.join (self#effects_of cond) + (EC.join (self#effects_of ifso) (self#effects_of ifnot)) + | Cop (op, args, _) -> + let from_op = + match op with + | Capply _ | Cextcall _ -> EC.arbitrary + | Calloc -> EC.none + | Cstore _ -> EC.effect_only Effect.Arbitrary + | Craise _ | Ccheckbound -> EC.effect_only Effect.Raise + | Cload (_, Asttypes.Immutable) -> EC.none + | Cload (_, Asttypes.Mutable) -> EC.coeffect_only Coeffect.Read_mutable + | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor + | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf | Cabsf + | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf _ -> + EC.none + in + EC.join from_op (EC.join_list_map args self#effects_of) + | Cassign _ | Cswitch _ | Cloop _ | Ccatch _ | Cexit _ | Ctrywith _ -> + EC.arbitrary (* Says whether an integer constant is a suitable immediate argument *) @@ -206,44 +359,90 @@ (* Default instruction selection for stores (of words) *) -method select_store addr arg = - (Istore(Word, addr), arg) +method select_store is_assign addr arg = + (Istore(Word_val, addr, is_assign), arg) + +(* call marking methods, documented in selectgen.mli *) + +method mark_call = + Proc.contains_calls := true + +method mark_tailcall = () + +method mark_c_tailcall = () + +method mark_instr = function + | Iop (Icall_ind _ | Icall_imm _ | Iextcall _) -> + self#mark_call + | Iop (Itailcall_ind _ | Itailcall_imm _) -> + self#mark_tailcall + | Iop (Ialloc _) -> + self#mark_call (* caml_alloc*, caml_garbage_collection *) + | Iop (Iintop (Icheckbound _) | Iintop_imm(Icheckbound _, _)) -> + self#mark_c_tailcall (* caml_ml_array_bound_error *) + | Iraise raise_kind -> + begin match raise_kind with + | Cmm.Raise_notrace -> () + | Cmm.Raise_withtrace -> + (* PR#6239 *) + (* caml_stash_backtrace; we #mark_call rather than + #mark_c_tailcall to get a good stack backtrace *) + self#mark_call + end + | Itrywith _ -> + self#mark_call + | _ -> () (* Default instruction selection for operators *) -method select_operation op args = +method select_allocation words = + Ialloc { words; spacetime_index = 0; label_after_call_gc = None; } +method select_allocation_args _env = [| |] + +method select_checkbound () = + Icheckbound { spacetime_index = 0; label_after_error = None; } +method select_checkbound_extra_args () = [] + +method select_operation op args _dbg = match (op, args) with - (Capply(ty, dbg), Cconst_symbol s :: rem) -> (Icall_imm s, rem) - | (Capply(ty, dbg), _) -> (Icall_ind, args) - | (Cextcall(s, ty, alloc, dbg), _) -> (Iextcall(s, alloc), args) - | (Cload chunk, [arg]) -> + | (Capply _, Cconst_symbol func :: rem) -> + let label_after = Cmm.new_label () in + (Icall_imm { func; label_after; }, rem) + | (Capply _, _) -> + let label_after = Cmm.new_label () in + (Icall_ind { label_after; }, args) + | (Cextcall(func, _ty, alloc, label_after), _) -> + let label_after = + match label_after with + | None -> Cmm.new_label () + | Some label_after -> label_after + in + Iextcall { func; alloc; label_after; }, args + | (Cload (chunk, _mut), [arg]) -> let (addr, eloc) = self#select_addressing chunk arg in (Iload(chunk, addr), [eloc]) - | (Cstore chunk, [arg1; arg2]) -> + | (Cstore (chunk, init), [arg1; arg2]) -> let (addr, eloc) = self#select_addressing chunk arg1 in - if chunk = Word then begin - let (op, newarg2) = self#select_store addr arg2 in + let is_assign = + match init with + | Lambda.Root_initialization -> false + | Lambda.Heap_initialization -> false + | Lambda.Assignment -> true + in + if chunk = Word_int || chunk = Word_val then begin + let (op, newarg2) = self#select_store is_assign addr arg2 in (op, [newarg2; eloc]) end else begin - (Istore(chunk, addr), [arg2; eloc]) + (Istore(chunk, addr, is_assign), [arg2; eloc]) (* Inversion addr/datum in Istore *) end - | (Calloc, _) -> (Ialloc 0, args) + | (Calloc, _) -> (self#select_allocation 0), args | (Caddi, _) -> self#select_arith_comm Iadd args | (Csubi, _) -> self#select_arith Isub args - | (Cmuli, [arg1; Cconst_int n]) -> - let l = Misc.log2 n in - if n = 1 lsl l - then (Iintop_imm(Ilsl, l), [arg1]) - else self#select_arith_comm Imul args - | (Cmuli, [Cconst_int n; arg1]) -> - let l = Misc.log2 n in - if n = 1 lsl l - then (Iintop_imm(Ilsl, l), [arg1]) - else self#select_arith_comm Imul args | (Cmuli, _) -> self#select_arith_comm Imul args - | (Cdivi, _) -> self#select_arith Idiv args - | (Cmodi, _) -> self#select_arith_comm Imod args + | (Cmulhi, _) -> self#select_arith_comm Imulh args + | (Cdivi, _) -> (Iintop Idiv, args) + | (Cmodi, _) -> (Iintop Imod, args) | (Cand, _) -> self#select_arith_comm Iand args | (Cor, _) -> self#select_arith_comm Ior args | (Cxor, _) -> self#select_arith_comm Ixor args @@ -251,8 +450,8 @@ | (Clsr, _) -> self#select_shift Ilsr args | (Casr, _) -> self#select_shift Iasr args | (Ccmpi comp, _) -> self#select_arith_comp (Isigned comp) args + | (Caddv, _) -> self#select_arith_comm Iadd args | (Cadda, _) -> self#select_arith_comm Iadd args - | (Csuba, _) -> self#select_arith Isub args | (Ccmpa comp, _) -> self#select_arith_comp (Iunsigned comp) args | (Cnegf, _) -> (Inegf, args) | (Cabsf, _) -> (Iabsf, args) @@ -262,7 +461,10 @@ | (Cdivf, _) -> (Idivf, args) | (Cfloatofint, _) -> (Ifloatofint, args) | (Cintoffloat, _) -> (Iintoffloat, args) - | (Ccheckbound _, _) -> self#select_arith Icheckbound args + | (Ccheckbound, _) -> + let extra_args = self#select_checkbound_extra_args () in + let op = self#select_checkbound () in + self#select_arith op (args @ extra_args) | _ -> fatal_error "Selection.select_oper" method private select_arith_comm op = function @@ -306,29 +508,29 @@ (* Instruction selection for conditionals *) method select_condition = function - Cop(Ccmpi cmp, [arg1; Cconst_int n]) when self#is_immediate n -> + Cop(Ccmpi cmp, [arg1; Cconst_int n], _) when self#is_immediate n -> (Iinttest_imm(Isigned cmp, n), arg1) - | Cop(Ccmpi cmp, [Cconst_int n; arg2]) when self#is_immediate n -> + | Cop(Ccmpi cmp, [Cconst_int n; arg2], _) when self#is_immediate n -> (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2) - | Cop(Ccmpi cmp, [arg1; Cconst_pointer n]) when self#is_immediate n -> + | Cop(Ccmpi cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n -> (Iinttest_imm(Isigned cmp, n), arg1) - | Cop(Ccmpi cmp, [Cconst_pointer n; arg2]) when self#is_immediate n -> + | Cop(Ccmpi cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n -> (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2) - | Cop(Ccmpi cmp, args) -> + | Cop(Ccmpi cmp, args, _) -> (Iinttest(Isigned cmp), Ctuple args) - | Cop(Ccmpa cmp, [arg1; Cconst_pointer n]) when self#is_immediate n -> + | Cop(Ccmpa cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n -> (Iinttest_imm(Iunsigned cmp, n), arg1) - | Cop(Ccmpa cmp, [arg1; Cconst_int n]) when self#is_immediate n -> + | Cop(Ccmpa cmp, [arg1; Cconst_int n], _) when self#is_immediate n -> (Iinttest_imm(Iunsigned cmp, n), arg1) - | Cop(Ccmpa cmp, [Cconst_pointer n; arg2]) when self#is_immediate n -> + | Cop(Ccmpa cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n -> (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2) - | Cop(Ccmpa cmp, [Cconst_int n; arg2]) when self#is_immediate n -> + | Cop(Ccmpa cmp, [Cconst_int n; arg2], _) when self#is_immediate n -> (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2) - | Cop(Ccmpa cmp, args) -> + | Cop(Ccmpa cmp, args, _) -> (Iinttest(Iunsigned cmp), Ctuple args) - | Cop(Ccmpf cmp, args) -> + | Cop(Ccmpf cmp, args, _) -> (Ifloattest(cmp, false), Ctuple args) - | Cop(Cand, [arg; Cconst_int 1]) -> + | Cop(Cand, [arg; Cconst_int 1], _) -> (Ioddtest, arg) | arg -> (Itruetest, arg) @@ -350,12 +552,15 @@ method insert desc arg res = instr_seq <- instr_cons desc arg res instr_seq -method extract = +method extract_core ~end_instr = let rec extract res i = if i == dummy_instr then res else extract {i with next = res} i.next in - extract (end_instr()) instr_seq + extract end_instr instr_seq + +method extract = + self#extract_core ~end_instr:(end_instr ()) (* Insert a sequence of moves from one pseudoreg set to another. *) @@ -368,6 +573,24 @@ self#insert_move src.(i) dst.(i) done +(* Adjust the types of destination pseudoregs for a [Cassign] assignment. + The type inferred at [let] binding might be [Int] while we assign + something of type [Val] (PR#6501). *) + +method adjust_type src dst = + let ts = src.typ and td = dst.typ in + if ts <> td then + match ts, td with + | Val, Int -> dst.typ <- Val + | Int, Val -> () + | _, _ -> fatal_error("Selection.adjust_type: bad assignment to " + ^ Reg.name dst) + +method adjust_types src dst = + for i = 0 to min (Array.length src) (Array.length dst) - 1 do + self#adjust_type src.(i) dst.(i) + done + (* Insert moves and stack offsets for function arguments and results *) method insert_move_args arg loc stacksize = @@ -389,10 +612,24 @@ method insert_op op rs rd = self#insert_op_debug op Debuginfo.none rs rd +method emit_blockheader _env n _dbg = + let r = self#regs_for typ_int in + Some(self#insert_op (Iconst_int n) [||] r) + +method about_to_emit_call _env _insn _arg = None + +(* Prior to a function call, update the Spacetime node hole pointer hard + register. *) + +method private maybe_emit_spacetime_move ~spacetime_reg = + Misc.Stdlib.Option.iter (fun reg -> + self#insert_moves reg [| Proc.loc_spacetime_node_hole |]) + spacetime_reg + (* Add the instructions for the given expression at the end of the self sequence *) -method emit_expr env exp = +method emit_expr (env:environment) exp = match exp with Cconst_int n -> let r = self#regs_for typ_int in @@ -402,19 +639,21 @@ Some(self#insert_op (Iconst_int n) [||] r) | Cconst_float n -> let r = self#regs_for typ_float in - Some(self#insert_op (Iconst_float n) [||] r) + Some(self#insert_op (Iconst_float (Int64.bits_of_float n)) [||] r) | Cconst_symbol n -> - let r = self#regs_for typ_addr in + let r = self#regs_for typ_val in Some(self#insert_op (Iconst_symbol n) [||] r) | Cconst_pointer n -> - let r = self#regs_for typ_addr in + let r = self#regs_for typ_val in (* integer as Caml value *) Some(self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r) | Cconst_natpointer n -> - let r = self#regs_for typ_addr in + let r = self#regs_for typ_val in (* integer as Caml value *) Some(self#insert_op (Iconst_int n) [||] r) + | Cblockheader(n, dbg) -> + self#emit_blockheader env n dbg | Cvar v -> begin try - Some(Tbl.find v env) + Some(env_find v env) with Not_found -> fatal_error("Selection.emit_expr: unbound var " ^ Ident.unique_name v) end @@ -426,12 +665,12 @@ | Cassign(v, e1) -> let rv = try - Tbl.find v env + env_find v env with Not_found -> fatal_error ("Selection.emit_expr: unbound var " ^ Ident.name v) in begin match self#emit_expr env e1 with None -> None - | Some r1 -> self#insert_moves r1 rv; Some [||] + | Some r1 -> self#adjust_types r1 rv; self#insert_moves r1 rv; Some [||] end | Ctuple [] -> Some [||] @@ -441,61 +680,72 @@ | Some(simple_list, ext_env) -> Some(self#emit_tuple ext_env simple_list) end - | Cop(Craise dbg, [arg]) -> + | Cop(Craise k, [arg], dbg) -> begin match self#emit_expr env arg with None -> None | Some r1 -> let rd = [|Proc.loc_exn_bucket|] in self#insert (Iop Imove) r1 rd; - self#insert_debug Iraise dbg rd [||]; + self#insert_debug (Iraise k) dbg rd [||]; None end - | Cop(Ccmpf comp, args) -> + | Cop(Ccmpf _, _, _) -> self#emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0)) - | Cop(op, args) -> + | Cop(op, args, dbg) -> begin match self#emit_parts_list env args with None -> None | Some(simple_args, env) -> let ty = oper_result_type op in - let (new_op, new_args) = self#select_operation op simple_args in - let dbg = debuginfo_op op in + let (new_op, new_args) = self#select_operation op simple_args dbg in match new_op with - Icall_ind -> - Proc.contains_calls := true; + Icall_ind _ -> let r1 = self#emit_tuple env new_args in let rarg = Array.sub r1 1 (Array.length r1 - 1) in let rd = self#regs_for ty in let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in let loc_res = Proc.loc_results rd in + let spacetime_reg = + self#about_to_emit_call env (Iop new_op) [| r1.(0) |] + in self#insert_move_args rarg loc_arg stack_ofs; - self#insert_debug (Iop Icall_ind) dbg + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug (Iop new_op) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd - | Icall_imm lbl -> - Proc.contains_calls := true; + | Icall_imm _ -> let r1 = self#emit_tuple env new_args in let rd = self#regs_for ty in let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in let loc_res = Proc.loc_results rd in + let spacetime_reg = + self#about_to_emit_call env (Iop new_op) [| |] + in self#insert_move_args r1 loc_arg stack_ofs; - self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res; + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug (Iop new_op) dbg loc_arg loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd - | Iextcall(lbl, alloc) -> - Proc.contains_calls := true; - let (loc_arg, stack_ofs) = - self#emit_extcall_args env new_args in + | Iextcall _ -> + let spacetime_reg = + self#about_to_emit_call env (Iop new_op) [| |] + in + let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in + self#maybe_emit_spacetime_move ~spacetime_reg; let rd = self#regs_for ty in - let loc_res = self#insert_op_debug (Iextcall(lbl, alloc)) dbg - loc_arg (Proc.loc_external_results rd) in + let loc_res = + self#insert_op_debug new_op dbg + loc_arg (Proc.loc_external_results rd) in self#insert_move_results loc_res rd stack_ofs; Some rd - | Ialloc _ -> - Proc.contains_calls := true; - let rd = self#regs_for typ_addr in + | Ialloc { words = _; spacetime_index; label_after_call_gc; } -> + let rd = self#regs_for typ_val in let size = size_expr env (Ctuple new_args) in - self#insert (Iop(Ialloc size)) [||] rd; + let op = + Ialloc { words = size; spacetime_index; label_after_call_gc; } + in + let args = self#select_allocation_args env in + self#insert_debug (Iop op) dbg args rd; self#emit_stores env new_args rd; Some rd | op -> @@ -506,7 +756,7 @@ | Csequence(e1, e2) -> begin match self#emit_expr env e1 with None -> None - | Some r1 -> self#emit_expr env e2 + | Some _ -> self#emit_expr env e2 end | Cifthenelse(econd, eif, eelse) -> let (cond, earg) = self#select_condition econd in @@ -520,57 +770,85 @@ rarg [||]; r end - | Cswitch(esel, index, ecases) -> + | Cswitch(esel, index, ecases, _dbg) -> begin match self#emit_expr env esel with None -> None | Some rsel -> let rscases = Array.map (self#emit_sequence env) ecases in let r = join_array rscases in self#insert (Iswitch(index, - Array.map (fun (r, s) -> s#extract) rscases)) + Array.map (fun (_, s) -> s#extract) rscases)) rsel [||]; r end | Cloop(ebody) -> - let (rarg, sbody) = self#emit_sequence env ebody in + let (_rarg, sbody) = self#emit_sequence env ebody in self#insert (Iloop(sbody#extract)) [||] [||]; Some [||] - | Ccatch(nfail, ids, e1, e2) -> - let rs = - List.map - (fun id -> - let r = self#regs_for typ_addr in name_regs id r; r) - ids in - catch_regs := (nfail, Array.concat rs) :: !catch_regs ; - let (r1, s1) = self#emit_sequence env e1 in - catch_regs := List.tl !catch_regs ; - let new_env = - List.fold_left - (fun env (id,r) -> Tbl.add id r env) - env (List.combine ids rs) in - let (r2, s2) = self#emit_sequence new_env e2 in - let r = join r1 s1 r2 s2 in - self#insert (Icatch(nfail, s1#extract, s2#extract)) [||] [||]; + | Ccatch(_, [], e1) -> + self#emit_expr env e1 + | Ccatch(rec_flag, handlers, body) -> + let handlers = + List.map (fun (nfail, ids, e2) -> + let rs = + List.map + (* CR-someday mshinwell: consider how we can do better than + [typ_val] when appropriate. *) + (fun id -> let r = self#regs_for typ_val in name_regs id r; r) + ids in + (nfail, ids, rs, e2)) + handlers + in + let env = + (* Since the handlers may be recursive, and called from the body, + the same environment is used for translating both the handlers and + the body. *) + List.fold_left (fun env (nfail, _ids, rs, _e2) -> + env_add_static_exception nfail rs env) + env handlers + in + let (r_body, s_body) = self#emit_sequence env body in + let translate_one_handler (nfail, ids, rs, e2) = + assert(List.length ids = List.length rs); + let new_env = + List.fold_left (fun env (id, r) -> env_add id r env) + env (List.combine ids rs) + in + let (r, s) = self#emit_sequence new_env e2 in + (nfail, (r, s)) + in + let l = List.map translate_one_handler handlers in + let a = Array.of_list ((r_body, s_body) :: List.map snd l) in + let r = join_array a in + let aux (nfail, (_r, s)) = (nfail, s#extract) in + self#insert (Icatch (rec_flag, List.map aux l, s_body#extract)) [||] [||]; r | Cexit (nfail,args) -> begin match self#emit_parts_list env args with None -> None | Some (simple_list, ext_env) -> let src = self#emit_tuple ext_env simple_list in - let dest = - try List.assoc nfail !catch_regs + let dest_args = + try env_find_static_exception nfail env with Not_found -> - Misc.fatal_error - ("Selectgen.emit_expr, on exit("^string_of_int nfail^")") in - self#insert_moves src dest ; + fatal_error ("Selection.emit_expr: unboun label "^ + string_of_int nfail) + in + (* Intermediate registers to handle cases where some + registers from src are present in dest *) + let tmp_regs = Reg.createv_like src in + (* Ccatch registers are created with type Val. They must not + contain out of heap pointers *) + Array.iter (fun reg -> assert(reg.typ <> Addr)) src; + self#insert_moves src tmp_regs ; + self#insert_moves tmp_regs (Array.concat dest_args) ; self#insert (Iexit nfail) [||] [||]; None end | Ctrywith(e1, v, e2) -> - Proc.contains_calls := true; let (r1, s1) = self#emit_sequence env e1 in - let rv = self#regs_for typ_addr in - let (r2, s2) = self#emit_sequence (Tbl.add v rv env) e2 in + let rv = self#regs_for typ_val in + let (r2, s2) = self#emit_sequence (env_add v rv env) e2 in let r = join r1 s1 r2 s2 in self#insert (Itrywith(s1#extract, @@ -579,24 +857,67 @@ [||] [||]; r -method private emit_sequence env exp = +method private emit_sequence (env:environment) exp = let s = {< instr_seq = dummy_instr >} in let r = s#emit_expr env exp in (r, s) -method private bind_let env v r1 = +method private bind_let (env:environment) v r1 = if all_regs_anonymous r1 then begin name_regs v r1; - Tbl.add v r1 env + env_add v r1 env end else begin let rv = Reg.createv_like r1 in name_regs v rv; self#insert_moves r1 rv; - Tbl.add v rv env + env_add v rv env end -method private emit_parts env exp = - if self#is_simple_expr exp then +(* The following two functions, [emit_parts] and [emit_parts_list], force + right-to-left evaluation order as required by the Flambda [Un_anf] pass + (and to be consistent with the bytecode compiler). *) + +method private emit_parts (env:environment) ~effects_after exp = + let module EC = Effect_and_coeffect in + let may_defer_evaluation = + let ec = self#effects_of exp in + match EC.effect ec with + | Effect.Arbitrary | Effect.Raise -> + (* Preserve the ordering of effectful expressions by evaluating them + early (in the correct order) and assigning their results to + temporaries. We can avoid this in just one case: if we know that + every [exp'] in the original expression list (cf. [emit_parts_list]) + to be evaluated after [exp] cannot possibly affect the result of + [exp] or depend on the result of [exp], then [exp] may be deferred. + (Checking purity here is not enough: we need to check copurity too + to avoid e.g. moving mutable reads earlier than the raising of + an exception.) *) + EC.pure_and_copure effects_after + | Effect.None -> + match EC.coeffect ec with + | Coeffect.None -> + (* Pure expressions may be moved. *) + true + | Coeffect.Read_mutable -> begin + (* Read-mutable expressions may only be deferred if evaluation of + every [exp'] (for [exp'] as in the comment above) has no effects + "worse" (in the sense of the ordering in [Effect.t]) than raising + an exception. *) + match EC.effect effects_after with + | Effect.None | Effect.Raise -> true + | Effect.Arbitrary -> false + end + | Coeffect.Arbitrary -> begin + (* Arbitrary expressions may only be deferred if evaluation of + every [exp'] (for [exp'] as in the comment above) has no effects. *) + match EC.effect effects_after with + | Effect.None -> true + | Effect.Arbitrary | Effect.Raise -> false + end + in + (* Even though some expressions may look like they can be deferred from + the (co)effect analysis, it may be forbidden to move them. *) + if may_defer_evaluation && self#is_simple_expr exp then Some (exp, env) else begin match self#emit_expr env exp with @@ -609,30 +930,39 @@ let id = Ident.create "bind" in if all_regs_anonymous r then (* r is an anonymous, unshared register; use it directly *) - Some (Cvar id, Tbl.add id r env) + Some (Cvar id, env_add id r env) else begin (* Introduce a fresh temp to hold the result *) let tmp = Reg.createv_like r in self#insert_moves r tmp; - Some (Cvar id, Tbl.add id tmp env) + Some (Cvar id, env_add id tmp env) end end end -method private emit_parts_list env exp_list = - match exp_list with - [] -> Some ([], env) - | exp :: rem -> - (* This ensures right-to-left evaluation, consistent with the - bytecode compiler *) - match self#emit_parts_list env rem with - None -> None - | Some(new_rem, new_env) -> - match self#emit_parts new_env exp with - None -> None - | Some(new_exp, fin_env) -> Some(new_exp :: new_rem, fin_env) +method private emit_parts_list (env:environment) exp_list = + let module EC = Effect_and_coeffect in + let exp_list_right_to_left, _effect = + (* Annotate each expression with the (co)effects that happen after it + when the original expression list is evaluated from right to left. + The resulting expression list has the rightmost expression first. *) + List.fold_left (fun (exp_list, effects_after) exp -> + let exp_effect = self#effects_of exp in + (exp, effects_after)::exp_list, EC.join exp_effect effects_after) + ([], EC.none) + exp_list + in + List.fold_left (fun results_and_env (exp, effects_after) -> + match results_and_env with + | None -> None + | Some (result, env) -> + match self#emit_parts env exp ~effects_after with + | None -> None + | Some (exp_result, env) -> Some (exp_result :: result, env)) + (Some ([], env)) + exp_list_right_to_left -method private emit_tuple env exp_list = +method private emit_tuple_not_flattened env exp_list = let rec emit_list = function [] -> [] | exp :: rem -> @@ -640,30 +970,42 @@ let loc_rem = emit_list rem in match self#emit_expr env exp with None -> assert false (* should have been caught in emit_parts *) - | Some loc_exp -> loc_exp :: loc_rem in - Array.concat(emit_list exp_list) + | Some loc_exp -> loc_exp :: loc_rem + in + emit_list exp_list + +method private emit_tuple env exp_list = + Array.concat (self#emit_tuple_not_flattened env exp_list) method emit_extcall_args env args = - let r1 = self#emit_tuple env args in - let (loc_arg, stack_ofs as arg_stack) = Proc.loc_external_arguments r1 in - self#insert_move_args r1 loc_arg stack_ofs; - arg_stack + let args = self#emit_tuple_not_flattened env args in + let arg_hard_regs, stack_ofs = + Proc.loc_external_arguments (Array.of_list args) + in + (* Flattening [args] and [arg_hard_regs] causes parts of values split + across multiple registers to line up correctly, by virtue of the + semantics of [split_int64_for_32bit_target] in cmmgen.ml, and the + required semantics of [loc_external_arguments] (see proc.mli). *) + let args = Array.concat args in + let arg_hard_regs = Array.concat (Array.to_list arg_hard_regs) in + self#insert_move_args args arg_hard_regs stack_ofs; + arg_hard_regs, stack_ofs method emit_stores env data regs_addr = let a = ref (Arch.offset_addressing Arch.identity_addressing (-Arch.size_int)) in List.iter (fun e -> - let (op, arg) = self#select_store !a e in + let (op, arg) = self#select_store false !a e in match self#emit_expr env arg with None -> assert false | Some regs -> match op with - Istore(_, _) -> + Istore(_, _, _) -> for i = 0 to Array.length regs - 1 do let r = regs.(i) in - let kind = if r.typ = Float then Double_u else Word in - self#insert (Iop(Istore(kind, !a))) + let kind = if r.typ = Float then Double_u else Word_val in + self#insert (Iop(Istore(kind, !a, false))) (Array.append [|r|] regs_addr) [||]; a := Arch.offset_addressing !a (size_component r.typ) done @@ -674,7 +1016,7 @@ (* Same, but in tail position *) -method private emit_return env exp = +method private emit_return (env:environment) exp = match self#emit_expr env exp with None -> () | Some r -> @@ -682,53 +1024,74 @@ self#insert_moves r loc; self#insert Ireturn loc [||] -method emit_tail env exp = +method emit_tail (env:environment) exp = match exp with Clet(v, e1, e2) -> begin match self#emit_expr env e1 with None -> () | Some r1 -> self#emit_tail (self#bind_let env v r1) e2 end - | Cop(Capply(ty, dbg) as op, args) -> + | Cop((Capply ty) as op, args, dbg) -> begin match self#emit_parts_list env args with None -> () | Some(simple_args, env) -> - let (new_op, new_args) = self#select_operation op simple_args in + let (new_op, new_args) = self#select_operation op simple_args dbg in match new_op with - Icall_ind -> + Icall_ind { label_after; } -> let r1 = self#emit_tuple env new_args in let rarg = Array.sub r1 1 (Array.length r1 - 1) in let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in if stack_ofs = 0 then begin + let call = Iop (Itailcall_ind { label_after; }) in + let spacetime_reg = + self#about_to_emit_call env call [| r1.(0) |] + in self#insert_moves rarg loc_arg; - self#insert (Iop Itailcall_ind) - (Array.append [|r1.(0)|] loc_arg) [||] + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug call dbg + (Array.append [|r1.(0)|] loc_arg) [||]; end else begin - Proc.contains_calls := true; let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in + let spacetime_reg = + self#about_to_emit_call env (Iop new_op) [| r1.(0) |] + in self#insert_move_args rarg loc_arg stack_ofs; - self#insert_debug (Iop Icall_ind) dbg + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug (Iop new_op) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; self#insert Ireturn loc_res [||] end - | Icall_imm lbl -> + | Icall_imm { func; label_after; } -> let r1 = self#emit_tuple env new_args in let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in if stack_ofs = 0 then begin + let call = Iop (Itailcall_imm { func; label_after; }) in + let spacetime_reg = + self#about_to_emit_call env call [| |] + in self#insert_moves r1 loc_arg; - self#insert (Iop(Itailcall_imm lbl)) loc_arg [||] - end else if lbl = !current_function_name then begin + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug call dbg loc_arg [||]; + end else if func = !current_function_name then begin + let call = Iop (Itailcall_imm { func; label_after; }) in let loc_arg' = Proc.loc_parameters r1 in + let spacetime_reg = + self#about_to_emit_call env call [| |] + in self#insert_moves r1 loc_arg'; - self#insert (Iop(Itailcall_imm lbl)) loc_arg' [||] + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug call dbg loc_arg' [||]; end else begin - Proc.contains_calls := true; let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in + let spacetime_reg = + self#about_to_emit_call env (Iop new_op) [| |] + in self#insert_move_args r1 loc_arg stack_ofs; - self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res; + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug (Iop new_op) dbg loc_arg loc_res; self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; self#insert Ireturn loc_res [||] end @@ -737,7 +1100,7 @@ | Csequence(e1, e2) -> begin match self#emit_expr env e1 with None -> () - | Some r1 -> self#emit_tail env e2 + | Some _ -> self#emit_tail env e2 end | Cifthenelse(econd, eif, eelse) -> let (cond, earg) = self#select_condition econd in @@ -748,7 +1111,7 @@ self#emit_tail_sequence env eelse)) rarg [||] end - | Cswitch(esel, index, ecases) -> + | Cswitch(esel, index, ecases, _dbg) -> begin match self#emit_expr env esel with None -> () | Some rsel -> @@ -756,28 +1119,35 @@ (Iswitch(index, Array.map (self#emit_tail_sequence env) ecases)) rsel [||] end - | Ccatch(nfail, ids, e1, e2) -> - let rs = - List.map - (fun id -> - let r = self#regs_for typ_addr in - name_regs id r ; - r) - ids in - catch_regs := (nfail, Array.concat rs) :: !catch_regs ; - let s1 = self#emit_tail_sequence env e1 in - catch_regs := List.tl !catch_regs ; - let new_env = - List.fold_left - (fun env (id,r) -> Tbl.add id r env) - env (List.combine ids rs) in - let s2 = self#emit_tail_sequence new_env e2 in - self#insert (Icatch(nfail, s1, s2)) [||] [||] + | Ccatch(_, [], e1) -> + self#emit_tail env e1 + | Ccatch(rec_flag, handlers, e1) -> + let handlers = + List.map (fun (nfail, ids, e2) -> + let rs = + List.map + (fun id -> let r = self#regs_for typ_val in name_regs id r; r) + ids in + (nfail, ids, rs, e2)) + handlers in + let env = + List.fold_left (fun env (nfail, _ids, rs, _e2) -> + env_add_static_exception nfail rs env) + env handlers in + let s_body = self#emit_tail_sequence env e1 in + let aux (nfail, ids, rs, e2) = + assert(List.length ids = List.length rs); + let new_env = + List.fold_left + (fun env (id,r) -> env_add id r env) + env (List.combine ids rs) in + nfail, self#emit_tail_sequence new_env e2 + in + self#insert (Icatch(rec_flag, List.map aux handlers, s_body)) [||] [||] | Ctrywith(e1, v, e2) -> - Proc.contains_calls := true; let (opt_r1, s1) = self#emit_sequence env e1 in - let rv = self#regs_for typ_addr in - let s2 = self#emit_tail_sequence (Tbl.add v rv env) e2 in + let rv = self#regs_for typ_val in + let s2 = self#emit_tail_sequence (env_add v rv env) e2 in self#insert (Itrywith(s1#extract, instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv s2)) @@ -797,8 +1167,16 @@ s#emit_tail env exp; s#extract +(* Insertion of the function prologue *) + +method insert_prologue _f ~loc_arg ~rarg ~spacetime_node_hole:_ ~env:_ = + self#insert_moves loc_arg rarg; + None + (* Sequentialization of a function definition *) +method initial_env () = env_empty + method emit_fundecl f = Proc.contains_calls := false; current_function_name := f.Cmm.fun_name; @@ -808,17 +1186,38 @@ f.Cmm.fun_args in let rarg = Array.concat rargs in let loc_arg = Proc.loc_parameters rarg in + (* To make it easier to add the Spacetime instrumentation code, we + first emit the body and extract the resulting instruction sequence; + then we emit the prologue followed by any Spacetime instrumentation. The + sequence resulting from extracting the latter (prologue + instrumentation) + together is then simply prepended to the body. *) let env = List.fold_right2 - (fun (id, ty) r env -> Tbl.add id r env) - f.Cmm.fun_args rargs Tbl.empty in - self#insert_moves loc_arg rarg; + (fun (id, _ty) r env -> env_add id r env) + f.Cmm.fun_args rargs (self#initial_env ()) in + let spacetime_node_hole, env = + if not Config.spacetime then None, env + else begin + let reg = self#regs_for typ_int in + let node_hole = Ident.create "spacetime_node_hole" in + Some (node_hole, reg), env_add node_hole reg env + end + in self#emit_tail env f.Cmm.fun_body; + let body = self#extract in + instr_seq <- dummy_instr; + let fun_spacetime_shape = + self#insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env + in + let body = self#extract_core ~end_instr:body in + instr_iter (fun instr -> self#mark_instr instr.Mach.desc) body; { fun_name = f.Cmm.fun_name; fun_args = loc_arg; - fun_body = self#extract; + fun_body = body; fun_fast = f.Cmm.fun_fast; - fun_dbg = f.Cmm.fun_dbg } + fun_dbg = f.Cmm.fun_dbg; + fun_spacetime_shape; + } end @@ -830,8 +1229,11 @@ let is_tail_call nargs = assert (Reg.dummy.typ = Int); let args = Array.make (nargs + 1) Reg.dummy in - let (loc_arg, stack_ofs) = Proc.loc_arguments args in + let (_loc_arg, stack_ofs) = Proc.loc_arguments args in stack_ofs = 0 let _ = Simplif.is_tail_native_heuristic := is_tail_call + +let reset () = + current_function_name := "" diff -Nru ocaml-4.01.0/asmcomp/selectgen.mli ocaml-4.05.0/asmcomp/selectgen.mli --- ocaml-4.01.0/asmcomp/selectgen.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/selectgen.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,22 +1,59 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) -type environment = (Ident.t, Reg.t array) Tbl.t +type environment + +val env_add : Ident.t -> Reg.t array -> environment -> environment + +val env_find : Ident.t -> environment -> Reg.t array val size_expr : environment -> Cmm.expression -> int +module Effect : sig + type t = + | None + | Raise + | Arbitrary +end + +module Coeffect : sig + type t = + | None + | Read_mutable + | Arbitrary +end + +module Effect_and_coeffect : sig + type t + + val none : t + val arbitrary : t + + val effect : t -> Effect.t + val coeffect : t -> Coeffect.t + + val effect_only : Effect.t -> t + val coeffect_only : Coeffect.t -> t + + val join : t -> t -> t + val join_list_map : 'a list -> ('a -> t) -> t +end + class virtual selector_generic : object (* The following methods must or can be overridden by the processor description *) @@ -27,15 +64,19 @@ Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression (* Must be defined to select addressing modes *) method is_simple_expr: Cmm.expression -> bool + method effects_of : Cmm.expression -> Effect_and_coeffect.t (* Can be overridden to reflect special extcalls known to be pure *) method select_operation : Cmm.operation -> - Cmm.expression list -> Mach.operation * Cmm.expression list + Cmm.expression list -> + Debuginfo.t -> + Mach.operation * Cmm.expression list (* Can be overridden to deal with special arithmetic instructions *) method select_condition : Cmm.expression -> Mach.test * Cmm.expression (* Can be overridden to deal with special test instructions *) method select_store : - Arch.addressing_mode -> Cmm.expression -> Mach.operation * Cmm.expression + bool -> Arch.addressing_mode -> Cmm.expression -> + Mach.operation * Cmm.expression (* Can be overridden to deal with special store constant instructions *) method regs_for : Cmm.machtype -> Reg.t array (* Return an array of fresh registers of the given type. @@ -58,13 +99,39 @@ (* Fill a freshly allocated block. Can be overridden for architectures that do not provide Arch.offset_addressing. *) - (* The following method is the entry point and should not be overridden *) + method mark_call : unit + (* informs the code emitter that the current function is non-leaf: + it may perform a (non-tail) call; by default, sets + [Proc.contains_calls := true] *) + + method mark_tailcall : unit + (* informs the code emitter that the current function may end with + a tail-call; by default, does nothing *) + + method mark_c_tailcall : unit + (* informs the code emitter that the current function may call + a C function that never returns; by default, does nothing. + + It is unecessary to save the stack pointer in this situation + (which is the main purpose of tracking leaf functions) but some + architectures still need to ensure that the stack is properly + aligned when the C function is called. This is achieved by + overloading this method to set [Proc.contains_calls := true] *) + + method mark_instr : Mach.instruction_desc -> unit + (* dispatches on instructions to call one of the marking function + above; overloading this is useful if Ispecific instructions need + marking *) + + (* The following method is the entry point and should not be overridden + (except by [Spacetime_profiling]). *) method emit_fundecl : Cmm.fundecl -> Mach.fundecl (* The following methods should not be overridden. They cannot be declared "private" in the current implementation because they are not always applied to "self", but ideally they should be private. *) method extract : Mach.instruction + method extract_core : end_instr:Mach.instruction -> Mach.instruction method insert : Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit method insert_debug : Mach.instruction_desc -> Debuginfo.t -> Reg.t array -> Reg.t array -> unit @@ -72,7 +139,38 @@ method insert_move_args : Reg.t array -> Reg.t array -> int -> unit method insert_move_results : Reg.t array -> Reg.t array -> int -> unit method insert_moves : Reg.t array -> Reg.t array -> unit + method adjust_type : Reg.t -> Reg.t -> unit + method adjust_types : Reg.t array -> Reg.t array -> unit method emit_expr : - (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> Reg.t array option - method emit_tail : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> unit + environment -> Cmm.expression -> Reg.t array option + method emit_tail : environment -> Cmm.expression -> unit + + (* Only for the use of [Spacetime_profiling]. *) + method select_allocation : int -> Mach.operation + method select_allocation_args : environment -> Reg.t array + method select_checkbound : unit -> Mach.integer_operation + method select_checkbound_extra_args : unit -> Cmm.expression list + method emit_blockheader + : environment + -> nativeint + -> Debuginfo.t + -> Reg.t array option + method about_to_emit_call + : environment + -> Mach.instruction_desc + -> Reg.t array + -> Reg.t array option + method initial_env : unit -> environment + method insert_prologue + : Cmm.fundecl + -> loc_arg:Reg.t array + -> rarg:Reg.t array + -> spacetime_node_hole:(Ident.t * Reg.t array) option + -> env:environment + -> Mach.spacetime_shape option + + val mutable instr_seq : Mach.instruction + end + +val reset : unit -> unit diff -Nru ocaml-4.01.0/asmcomp/selection.mli ocaml-4.05.0/asmcomp/selection.mli --- ocaml-4.01.0/asmcomp/selection.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/selection.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) diff -Nru ocaml-4.01.0/asmcomp/spacetime_profiling.ml ocaml-4.05.0/asmcomp/spacetime_profiling.ml --- ocaml-4.01.0/asmcomp/spacetime_profiling.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/spacetime_profiling.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,431 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2015--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +let node_num_header_words = 2 (* [Node_num_header_words] in the runtime. *) +let index_within_node = ref node_num_header_words +(* The [lazy]s are to ensure that we don't create [Ident.t]s at toplevel + when not using Spacetime profiling. (This could cause stamps to differ + between bytecode and native .cmis when no .mli is present, e.g. + arch.ml.) *) +let spacetime_node = ref (lazy (Cmm.Cvar (Ident.create "dummy"))) +let spacetime_node_ident = ref (lazy (Ident.create "dummy")) +let current_function_label = ref "" +let direct_tail_call_point_indexes = ref [] + +let reverse_shape = ref ([] : Mach.spacetime_shape) + +let something_was_instrumented () = + !index_within_node > node_num_header_words + +let next_index_within_node ~part_of_shape ~label = + let index = !index_within_node in + begin match part_of_shape with + | Mach.Direct_call_point _ | Mach.Indirect_call_point -> + incr index_within_node + | Mach.Allocation_point -> + incr index_within_node; + incr index_within_node; + incr index_within_node + end; + reverse_shape := (part_of_shape, label) :: !reverse_shape; + index + +let reset ~spacetime_node_ident:ident ~function_label = + index_within_node := node_num_header_words; + spacetime_node := lazy (Cmm.Cvar ident); + spacetime_node_ident := lazy ident; + direct_tail_call_point_indexes := []; + current_function_label := function_label; + reverse_shape := [] + +let code_for_function_prologue ~function_name ~node_hole = + let node = Ident.create "node" in + let new_node = Ident.create "new_node" in + let must_allocate_node = Ident.create "must_allocate_node" in + let is_new_node = Ident.create "is_new_node" in + let no_tail_calls = List.length !direct_tail_call_point_indexes < 1 in + let dbg = Debuginfo.none in + let open Cmm in + let initialize_direct_tail_call_points_and_return_node = + let new_node_encoded = Ident.create "new_node_encoded" in + (* The callee node pointers within direct tail call points must initially + point back at the start of the current node and be marked as per + [Encode_tail_caller_node] in the runtime. *) + let indexes = !direct_tail_call_point_indexes in + let body = + List.fold_left (fun init_code index -> + (* Cf. [Direct_callee_node] in the runtime. *) + let offset_in_bytes = index * Arch.size_addr in + Csequence ( + Cop (Cstore (Word_int, Lambda.Assignment), + [Cop (Caddi, [Cvar new_node; Cconst_int offset_in_bytes], dbg); + Cvar new_node_encoded], dbg), + init_code)) + (Cvar new_node) + indexes + in + match indexes with + | [] -> body + | _ -> + Clet (new_node_encoded, + (* Cf. [Encode_tail_caller_node] in the runtime. *) + Cop (Cor, [Cvar new_node; Cconst_int 1], dbg), + body) + in + let pc = Ident.create "pc" in + Clet (node, Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg), + Clet (must_allocate_node, + Cop (Cand, [Cvar node; Cconst_int 1], dbg), + Cifthenelse ( + Cop (Ccmpi Cne, [Cvar must_allocate_node; Cconst_int 1], dbg), + Cvar node, + Clet (is_new_node, + Clet (pc, Cconst_symbol function_name, + Cop (Cextcall ("caml_spacetime_allocate_node", + [| Int |], false, None), + [Cconst_int (1 (* header *) + !index_within_node); + Cvar pc; + Cvar node_hole; + ], + dbg)), + Clet (new_node, + Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg), + if no_tail_calls then Cvar new_node + else + Cifthenelse ( + Cop (Ccmpi Ceq, [Cvar is_new_node; Cconst_int 0], dbg), + Cvar new_node, + initialize_direct_tail_call_points_and_return_node)))))) + +let code_for_blockheader ~value's_header ~node ~dbg = + let num_words = Nativeint.shift_right_logical value's_header 10 in + let existing_profinfo = Ident.create "existing_profinfo" in + let existing_count = Ident.create "existing_count" in + let profinfo = Ident.create "profinfo" in + let address_of_profinfo = Ident.create "address_of_profinfo" in + let label = Cmm.new_label () in + let index_within_node = + next_index_within_node ~part_of_shape:Mach.Allocation_point ~label + in + let offset_into_node = Arch.size_addr * index_within_node in + let open Cmm in + let generate_new_profinfo = + (* This will generate a static branch to a function that should usually + be in the cache, which hopefully gives a good code size/performance + balance. + The "Some label" is important: it provides the link between the shape + table, the allocation point, and the frame descriptor table---enabling + the latter table to be used for resolving a program counter at such + a point to a location. + *) + Cop (Cextcall ("caml_spacetime_generate_profinfo", [| Int |], + false, Some label), + [Cvar address_of_profinfo; + Cconst_int (index_within_node + 1)], + dbg) + in + (* Check if we have already allocated a profinfo value for this allocation + point with the current backtrace. If so, use that value; if not, + allocate a new one. *) + Clet (address_of_profinfo, + Cop (Caddi, [ + Cvar node; + Cconst_int offset_into_node; + ], dbg), + Clet (existing_profinfo, + Cop (Cload (Word_int, Asttypes.Mutable), [Cvar address_of_profinfo], + dbg), + Clet (profinfo, + Cifthenelse ( + Cop (Ccmpi Cne, [Cvar existing_profinfo; Cconst_int 1 (* () *)], dbg), + Cvar existing_profinfo, + generate_new_profinfo), + Clet (existing_count, + Cop (Cload (Word_int, Asttypes.Mutable), [ + Cop (Caddi, + [Cvar address_of_profinfo; Cconst_int Arch.size_addr], dbg) + ], dbg), + Csequence ( + Cop (Cstore (Word_int, Lambda.Assignment), + [Cop (Caddi, + [Cvar address_of_profinfo; Cconst_int Arch.size_addr], dbg); + Cop (Caddi, [ + Cvar existing_count; + (* N.B. "*2" since the count is an OCaml integer. + The "1 +" is to count the value's header. *) + Cconst_int (2 * (1 + Nativeint.to_int num_words)); + ], dbg); + ], dbg), + (* [profinfo] looks like a black [Infix_tag] header. Instead of + having to mask [profinfo] before ORing it with the desired + header, we can use an XOR trick, to keep code size down. *) + let value's_header = + Nativeint.logxor value's_header + (Nativeint.logor + ((Nativeint.logor (Nativeint.of_int Obj.infix_tag) + (Nativeint.shift_left 3n (* <- Caml_black *) 8))) + (Nativeint.shift_left + (* The following is the [Infix_offset_val], in words. *) + (Nativeint.of_int (index_within_node + 1)) 10)) + in + Cop (Cxor, [Cvar profinfo; Cconst_natint value's_header], dbg)))))) + +type callee = + | Direct of string + | Indirect of Cmm.expression + +let code_for_call ~node ~callee ~is_tail ~label = + (* We treat self recursive calls as tail calls to avoid blow-ups in the + graph. *) + let is_self_recursive_call = + match callee with + | Direct callee -> callee = !current_function_label + | Indirect _ -> false + in + let is_tail = is_tail || is_self_recursive_call in + let index_within_node = + match callee with + | Direct callee -> + next_index_within_node + ~part_of_shape:(Mach.Direct_call_point { callee; }) + ~label + | Indirect _ -> + next_index_within_node ~part_of_shape:Mach.Indirect_call_point ~label + in + begin match callee with + (* If this is a direct tail call point, we need to note down its index, + so the correct initialization code can be emitted in the prologue. *) + | Direct _ when is_tail -> + direct_tail_call_point_indexes := + index_within_node::!direct_tail_call_point_indexes + | Direct _ | Indirect _ -> () + end; + let place_within_node = Ident.create "place_within_node" in + let dbg = Debuginfo.none in + let open Cmm in + Clet (place_within_node, + Cop (Caddi, [node; Cconst_int (index_within_node * Arch.size_addr)], dbg), + (* The following code returns the address that is to be moved into the + (hard) node hole pointer register immediately before the call. + (That move is inserted in [Selectgen].) *) + match callee with + | Direct _callee -> Cvar place_within_node + | Indirect callee -> + let caller_node = + if is_tail then node + else Cconst_int 1 (* [Val_unit] *) + in + Cop (Cextcall ("caml_spacetime_indirect_node_hole_ptr", + [| Int |], false, None), + [callee; Cvar place_within_node; caller_node], + dbg)) + +class virtual instruction_selection = object (self) + inherit Selectgen.selector_generic as super + + (* [disable_instrumentation] ensures that we don't try to instrument the + instrumentation... *) + val mutable disable_instrumentation = false + + method private instrument_direct_call ~env ~func ~is_tail ~label_after = + let instrumentation = + code_for_call + ~node:(Lazy.force !spacetime_node) + ~callee:(Direct func) + ~is_tail + ~label:label_after + in + match self#emit_expr env instrumentation with + | None -> assert false + | Some reg -> Some reg + + method private instrument_indirect_call ~env ~callee ~is_tail + ~label_after = + (* [callee] is a pseudoregister, so we have to bind it in the environment + and reference the variable to which it is bound. *) + let callee_ident = Ident.create "callee" in + let env = Selectgen.env_add callee_ident [| callee |] env in + let instrumentation = + code_for_call + ~node:(Lazy.force !spacetime_node) + ~callee:(Indirect (Cmm.Cvar callee_ident)) + ~is_tail + ~label:label_after + in + match self#emit_expr env instrumentation with + | None -> assert false + | Some reg -> Some reg + + method private can_instrument () = + Config.spacetime && not disable_instrumentation + + method! about_to_emit_call env desc arg = + if not (self#can_instrument ()) then None + else + let module M = Mach in + match desc with + | M.Iop (M.Icall_imm { func; label_after; }) -> + assert (Array.length arg = 0); + self#instrument_direct_call ~env ~func ~is_tail:false ~label_after + | M.Iop (M.Icall_ind { label_after; }) -> + assert (Array.length arg = 1); + self#instrument_indirect_call ~env ~callee:arg.(0) + ~is_tail:false ~label_after + | M.Iop (M.Itailcall_imm { func; label_after; }) -> + assert (Array.length arg = 0); + self#instrument_direct_call ~env ~func ~is_tail:true ~label_after + | M.Iop (M.Itailcall_ind { label_after; }) -> + assert (Array.length arg = 1); + self#instrument_indirect_call ~env ~callee:arg.(0) + ~is_tail:true ~label_after + | M.Iop (M.Iextcall { func; alloc = true; label_after; }) -> + (* N.B. No need to instrument "noalloc" external calls. *) + assert (Array.length arg = 0); + self#instrument_direct_call ~env ~func ~is_tail:false ~label_after + | _ -> None + + method private instrument_blockheader ~env ~value's_header ~dbg = + let instrumentation = + code_for_blockheader + ~node:(Lazy.force !spacetime_node_ident) + ~value's_header ~dbg + in + self#emit_expr env instrumentation + + method private emit_prologue f ~node_hole ~env = + (* We don't need the prologue unless we inserted some instrumentation. + This corresponds to adding the prologue if the function contains one + or more call or allocation points. *) + if something_was_instrumented () then begin + let prologue_cmm = + code_for_function_prologue ~function_name:f.Cmm.fun_name ~node_hole + in + disable_instrumentation <- true; + let node_temp_reg = + match self#emit_expr env prologue_cmm with + | None -> + Misc.fatal_error "Spacetime prologue instruction \ + selection did not yield a destination register" + | Some node_temp_reg -> node_temp_reg + in + disable_instrumentation <- false; + let node = Lazy.force !spacetime_node_ident in + let node_reg = Selectgen.env_find node env in + self#insert_moves node_temp_reg node_reg + end + + method! emit_blockheader env n dbg = + if self#can_instrument () then begin + disable_instrumentation <- true; + let result = self#instrument_blockheader ~env ~value's_header:n ~dbg in + disable_instrumentation <- false; + result + end else begin + super#emit_blockheader env n dbg + end + + method! select_allocation words = + if self#can_instrument () then begin + (* Leave space for a direct call point. We cannot easily insert any + instrumentation code, so the fields are filled in instead by + [caml_spacetime_caml_garbage_collection]. *) + let label = Cmm.new_label () in + let index = + next_index_within_node + ~part_of_shape:(Mach.Direct_call_point { callee = "caml_call_gc"; }) + ~label + in + Mach.Ialloc { + words; + label_after_call_gc = Some label; + spacetime_index = index; + } + end else begin + super#select_allocation words + end + + method! select_allocation_args env = + if self#can_instrument () then begin + let regs = Selectgen.env_find (Lazy.force !spacetime_node_ident) env in + match regs with + | [| reg |] -> [| reg |] + | _ -> failwith "Expected one register only for spacetime_node_ident" + end else begin + super#select_allocation_args env + end + + method! select_checkbound () = + (* This follows [select_allocation], above. *) + if self#can_instrument () then begin + let label = Cmm.new_label () in + let index = + next_index_within_node + ~part_of_shape:( + Mach.Direct_call_point { callee = "caml_ml_array_bound_error"; }) + ~label + in + Mach.Icheckbound { + label_after_error = Some label; + spacetime_index = index; + } + end else begin + super#select_checkbound () + end + + method! select_checkbound_extra_args () = + if self#can_instrument () then begin + (* This follows [select_allocation_args], above. *) + [Cmm.Cvar (Lazy.force !spacetime_node_ident)] + end else begin + super#select_checkbound_extra_args () + end + + method! initial_env () = + let env = super#initial_env () in + if Config.spacetime then + Selectgen.env_add (Lazy.force !spacetime_node_ident) + (self#regs_for Cmm.typ_int) env + else + env + + method! emit_fundecl f = + if Config.spacetime then begin + disable_instrumentation <- false; + let node = Ident.create "spacetime_node" in + reset ~spacetime_node_ident:node ~function_label:f.Cmm.fun_name + end; + super#emit_fundecl f + + method! insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env = + let fun_spacetime_shape = + super#insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env + in + (* CR-soon mshinwell: add check to make sure the node size doesn't exceed + the chunk size of the allocator *) + if not Config.spacetime then fun_spacetime_shape + else begin + let node_hole, node_hole_reg = + match spacetime_node_hole with + | None -> assert false + | Some (node_hole, reg) -> node_hole, reg + in + self#insert_moves [| Proc.loc_spacetime_node_hole |] node_hole_reg; + self#emit_prologue f ~node_hole ~env; + match !reverse_shape with + | [] -> None + (* N.B. We do not reverse the shape list, since the function that + reconstructs it (caml_spacetime_shape_table) reverses it again. *) + | reverse_shape -> Some reverse_shape + end +end diff -Nru ocaml-4.01.0/asmcomp/spacetime_profiling.mli ocaml-4.05.0/asmcomp/spacetime_profiling.mli --- ocaml-4.01.0/asmcomp/spacetime_profiling.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/spacetime_profiling.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,17 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2015--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Insertion of instrumentation code for Spacetime profiling. *) + +class virtual instruction_selection : Selectgen.selector_generic diff -Nru ocaml-4.01.0/asmcomp/sparc/arch.ml ocaml-4.05.0/asmcomp/sparc/arch.ml --- ocaml-4.01.0/asmcomp/sparc/arch.ml 2012-11-09 16:15:29.000000000 +0000 +++ ocaml-4.05.0/asmcomp/sparc/arch.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Specific operations for the Sparc processor *) @@ -30,6 +33,8 @@ type specific_operation = unit (* None worth mentioning *) +let spacetime_node_hole_pointer_is_live_before _specific_op = false + (* Addressing modes *) type addressing_mode = @@ -60,8 +65,8 @@ | Iindexed n -> Iindexed(n + delta) let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 + Ibased _ -> 0 + | Iindexed _ -> 1 (* Printing operations and addressing modes *) @@ -74,5 +79,5 @@ let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "%a%s" printreg arg.(0) idx -let print_specific_operation printreg op ppf arg = +let print_specific_operation _printreg _op _ppf _arg = Misc.fatal_error "Arch_sparc.print_specific_operation" diff -Nru ocaml-4.01.0/asmcomp/sparc/CSE.ml ocaml-4.05.0/asmcomp/sparc/CSE.ml --- ocaml-4.01.0/asmcomp/sparc/CSE.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/sparc/CSE.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* CSE for Sparc *) + +open Mach +open CSEgen + +class cse = object + +inherit cse_generic (* as super *) + +method! is_cheap_operation op = + match op with + | Iconst_int n -> n <= 4095n && n >= -4096n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/sparc/emit.mlp ocaml-4.05.0/asmcomp/sparc/emit.mlp --- ocaml-4.01.0/asmcomp/sparc/emit.mlp 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/asmcomp/sparc/emit.mlp 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,18 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +#2 "asmcomp/sparc/emit.mlp" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Emission of Sparc assembly code *) @@ -54,7 +58,7 @@ (* Return the other register in a register pair *) let next_in_pair = function - {loc = Reg r; typ = (Int | Addr)} -> phys_reg (r + 1) + {loc = Reg r; typ = (Int | Addr | Val)} -> phys_reg (r + 1) | {loc = Reg r; typ = Float} -> phys_reg (r + 16) | _ -> fatal_error "Emit.next_in_pair" @@ -64,7 +68,7 @@ if Config.system = "sunos" then "_" else "" let emit_symbol s = - if String.length s >= 1 & s.[0] = '.' + if String.length s >= 1 && s.[0] = '.' then emit_string s else begin emit_string symbol_prefix; Emitaux.emit_symbol '$' s end @@ -95,9 +99,6 @@ let emit_label lbl = emit_string label_prefix; emit_int lbl -let emit_data_label lbl = - emit_string label_prefix; emit_string "d"; emit_int lbl - (* Output a pseudo-register *) let emit_reg r = @@ -160,18 +161,24 @@ let frame_descriptors = ref([] : frame_descr list) -let record_frame live = - let lbl = new_label() in +let record_frame ?label live = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function - {typ = Addr; loc = Reg r} -> + | {typ = Val; loc = Reg r} -> live_offset := ((r lsl 1) + 1) :: !live_offset - | {typ = Addr; loc = Stack s} as reg -> - live_offset := - slot_offset s (register_class reg) :: !live_offset + | {typ = Val; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | {typ = Addr} as r -> + Misc.fatal_error ("bad GC root " ^ Reg.name r) | _ -> ()) live; + live_offset := List.sort_uniq (-) !live_offset; frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); @@ -190,7 +197,7 @@ (* Record floating-point constants *) -let float_constants = ref ([] : (int * string) list) +let float_constants = ref ([] : (int * int64) list) let emit_float_constant (lbl, cst) = rodata (); @@ -274,30 +281,39 @@ | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in begin match (src, dst) with - {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} -> + {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Reg _} -> ` mov {emit_reg src}, {emit_reg dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} -> if !arch_version = SPARC_V9 then ` fmovd {emit_reg src}, {emit_reg dst}\n` else begin ` fmovs {emit_reg src}, {emit_reg dst}\n`; ` fmovs {emit_reg(next_in_pair src)}, {emit_reg(next_in_pair dst)}\n` end - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = (Int | Addr)} -> + | {loc = Reg _; typ = Float}, {loc = Reg _; typ = (Int | Addr | Val)} -> (* This happens when calling C functions and passing a float arg in %o0...%o5 *) ` sub %sp, 8, %sp\n`; ` std {emit_reg src}, [%sp + 96]\n`; ` ld [%sp + 96], {emit_reg dst}\n`; - ` ld [%sp + 100], {emit_reg(next_in_pair dst)}\n`; + let dst2 = i.res.(1) in + begin match dst2 with + | {loc = Reg _; typ = Int} -> + ` ld [%sp + 100], {emit_reg dst2}\n`; + | {loc = Stack _; typ = Int} -> + ` ld [%sp + 100], %g1\n`; + ` st %g1, {emit_stack dst2}\n`; + | _ -> + fatal_error "Emit: Imove Float [| _; _ |]" + end; ` add %sp, 8, %sp\n` - | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} -> + | {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Stack _} -> ` st {emit_reg src}, {emit_stack dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + | {loc = Reg _; typ = Float}, {loc = Stack _} -> ` std {emit_reg src}, {emit_stack dst}\n` - | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} -> + | {loc = Stack _; typ = (Int | Addr | Val)}, {loc = Reg _} -> ` ld {emit_stack src}, {emit_reg dst}\n` - | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + | {loc = Stack _; typ = Float}, {loc = Reg _} -> ` ldd {emit_stack src}, {emit_reg dst}\n` | (_, _) -> fatal_error "Emit: Imove" @@ -309,47 +325,47 @@ ` sethi %hi({emit_nativeint n}), %g1\n`; ` or %g1, %lo({emit_nativeint n}), {emit_reg i.res.(0)}\n` end - | Lop(Iconst_float s) -> + | Lop(Iconst_float f) -> (* On UltraSPARC, the fzero instruction could be used to set a floating point register pair to zero. *) let lbl = new_label() in - float_constants := (lbl, s) :: !float_constants; + float_constants := (lbl, f) :: !float_constants; ` sethi %hi({emit_label lbl}), %g1\n`; ` ldd [%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n` | Lop(Iconst_symbol s) -> ` sethi %hi({emit_symbol s}), %g1\n`; ` or %g1, %lo({emit_symbol s}), {emit_reg i.res.(0)}\n` - | Lop(Icall_ind) -> - `{record_frame i.live} call {emit_reg i.arg.(0)}\n`; + | Lop(Icall_ind { label_after; }) -> + `{record_frame i.live ~label:label_after} call {emit_reg i.arg.(0)}\n`; fill_delay_slot dslot - | Lop(Icall_imm s) -> - `{record_frame i.live} call {emit_symbol s}\n`; + | Lop(Icall_imm { func; label_after; }) -> + `{record_frame i.live ~label:label_after} call {emit_symbol func}\n`; fill_delay_slot dslot - | Lop(Itailcall_ind) -> + | Lop(Itailcall_ind { label_after = _; }) -> let n = frame_size() in if !contains_calls then ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`; ` jmp {emit_reg i.arg.(0)}\n`; ` add %sp, {emit_int n}, %sp\n` (* in delay slot *) - | Lop(Itailcall_imm s) -> + | Lop(Itailcall_imm { func; label_after = _; }) -> let n = frame_size() in - if s = !function_name then begin + if func = !function_name then begin ` b {emit_label !tailrec_entry_point}\n`; fill_delay_slot dslot end else begin if !contains_calls then ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`; - ` sethi %hi({emit_symbol s}), %g1\n`; - ` jmp %g1 + %lo({emit_symbol s})\n`; + ` sethi %hi({emit_symbol func}), %g1\n`; + ` jmp %g1 + %lo({emit_symbol func})\n`; ` add %sp, {emit_int n}, %sp\n` (* in delay slot *) end - | Lop(Iextcall(s, alloc)) -> + | Lop(Iextcall { func; alloc; label_after; }) -> if alloc then begin - ` sethi %hi({emit_symbol s}), %g2\n`; - `{record_frame i.live} call {emit_symbol "caml_c_call"}\n`; - ` or %g2, %lo({emit_symbol s}), %g2\n` (* in delay slot *) + ` sethi %hi({emit_symbol func}), %g2\n`; + `{record_frame i.live ~label:label_after} call {emit_symbol "caml_c_call"}\n`; + ` or %g2, %lo({emit_symbol func}), %g2\n` (* in delay slot *) end else begin - ` call {emit_symbol s}\n`; + ` call {emit_symbol func}\n`; fill_delay_slot dslot end | Lop(Istackoffset n) -> @@ -375,7 +391,7 @@ | _ -> "ld" in emit_load loadinstr addr i.arg dest end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> let src = i.arg.(0) in begin match chunk with Double_u -> @@ -393,7 +409,7 @@ | _ -> "st" in emit_store storeinstr addr i.arg src end - | Lop(Ialloc n) -> + | Lop(Ialloc { words = n; label_after_call_gc; }) -> if !fastcode_flag then begin let lbl_cont = new_label() in if solaris then begin @@ -406,7 +422,7 @@ end; ` bgeu {emit_label lbl_cont}\n`; ` add %l6, 4, {emit_reg i.res.(0)}\n`; (* in delay slot *) - `{record_frame i.live} call {emit_symbol "caml_call_gc"}\n`; + `{record_frame i.live ?label:label_after_call_gc} call {emit_symbol "caml_call_gc"}\n`; ` mov {emit_int n}, %g2\n`; (* in delay slot *) ` add %l6, 4, {emit_reg i.res.(0)}\n`; `{emit_label lbl_cont}:\n` @@ -430,7 +446,7 @@ ` mov 0, {emit_reg i.res.(0)}\n`; `{emit_label lbl}:\n` end - | Lop(Iintop Icheckbound) -> + | Lop(Iintop (Icheckbound _)) -> ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; if solaris then ` tleu 5\n` (* 5 = ST_RANGE_CHECK *) @@ -443,36 +459,15 @@ ` sra {emit_reg i.arg.(0)}, 31, %g1\n`; ` wr %g1, %y\n`; ` sdiv {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop Imulh) -> + ` smul {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, %g1\n`; + ` rd %y, {emit_reg i.res.(0)}\n` | Lop(Iintop op) -> let instr = name_for_int_operation op in ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Ilsl, 1)) -> (* UltraSPARC has two add units but only one shifter. *) ` add {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - let l = Misc.log2 n in - if n = 1 lsl l then begin - let lbl = new_label() in - ` cmp {emit_reg i.arg.(0)}, 0\n`; - ` bge {emit_label lbl}\n`; - ` mov {emit_reg i.arg.(0)}, %g1\n`; (* in delay slot *) - ` add %g1, {emit_int (n-1)}, %g1\n`; - `{emit_label lbl}:\n`; - ` sra %g1, {emit_int l}, {emit_reg i.res.(0)}\n` - end else begin - ` sra {emit_reg i.arg.(0)}, 31, %g1\n`; - ` wr %g1, %y\n`; - ` sdiv {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` - end - | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) - let lbl = new_label() in - ` tst {emit_reg i.arg.(0)}\n`; - ` bge {emit_label lbl}\n`; - ` andcc {emit_reg i.arg.(0)}, {emit_int (n-1)}, {emit_reg i.res.(0)}\n`; (* in delay slot *) - ` be {emit_label lbl}\n`; - ` nop\n`; - ` sub {emit_reg i.res.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`; - `{emit_label lbl}:\n` | Lop(Iintop_imm(Icomp cmp, n)) -> ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; if !arch_version = SPARC_V9 then begin @@ -487,7 +482,7 @@ ` mov 0, {emit_reg i.res.(0)}\n`; `{emit_label lbl}:\n` end - | Lop(Iintop_imm(Icheckbound, n)) -> + | Lop(Iintop_imm(Icheckbound _, n)) -> ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; if solaris then ` tleu 5\n` (* 5 = ST_RANGE_CHECK *) @@ -496,6 +491,9 @@ ` bleu {emit_label !range_check_trap}\n`; ` nop\n` (* delay slot *) end + | Lop(Iintop_imm(Imulh, n)) -> + ` smul {emit_reg i.arg.(0)}, {emit_int n}, %g1\n`; + ` rd %y, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(op, n)) -> let instr = name_for_int_operation op in ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` @@ -519,7 +517,7 @@ ` st %f30, [%sp + 96]\n`; ` ld [%sp + 96], {emit_reg i.res.(0)}\n`; ` add %sp, 8, %sp\n` - | Lop(Ispecific sop) -> + | Lop(Ispecific _) -> assert false | Lreloadretaddr -> let n = frame_size() in @@ -603,7 +601,7 @@ ` ld [%sp + 100], %l5\n`; ` add %sp, 8, %sp\n`; stack_offset := !stack_offset - 8 - | Lraise -> + | Lraise _ -> ` ld [%l5 + 96], %g1\n`; ` mov %l5, %sp\n`; ` ld [%sp + 100], %l5\n`; @@ -618,7 +616,7 @@ that does not branch. *) let is_one_instr_op = function - Idiv | Imod | Icomp _ | Icheckbound -> false + Imulh | Idiv | Imod | Icomp _ | Icheckbound _ -> false | _ -> true let is_one_instr i = @@ -629,8 +627,8 @@ i.arg.(0).typ <> Float && i.res.(0).typ <> Float | Iconst_int n -> is_native_immediate n | Istackoffset _ -> true - | Iload(_, Iindexed n) -> i.res.(0).typ <> Float & is_immediate n - | Istore(_, Iindexed n) -> i.arg.(0).typ <> Float & is_immediate n + | Iload(_, Iindexed n) -> i.res.(0).typ <> Float && is_immediate n + | Istore(_, Iindexed n, _) -> i.arg.(0).typ <> Float && is_immediate n | Iintop(op) -> is_one_instr_op op | Iintop_imm(op, _) -> is_one_instr_op op | Iaddf | Isubf | Imulf | Idivf -> true @@ -655,20 +653,21 @@ let rec emit_all i = match i with {desc = Lend} -> () - | {next = {desc = Lop(Icall_imm _) | Lop(Iextcall(_, false)) | Lbranch _}} + | {next = {desc = Lop(Icall_imm _) + | Lop(Iextcall { alloc = false; }) | Lbranch _}} when is_one_instr i -> emit_instr i.next (Some i); emit_all i.next.next - | {next = {desc = Lop(Itailcall_imm s)}} - when s = !function_name & is_one_instr i -> + | {next = {desc = Lop(Itailcall_imm { func; _ })}} + when func = !function_name && is_one_instr i -> emit_instr i.next (Some i); emit_all i.next.next - | {next = {desc = Lop(Icall_ind)}} - when is_one_instr i & no_interference i.res i.next.arg -> + | {next = {desc = Lop(Icall_ind _)}} + when is_one_instr i && no_interference i.res i.next.arg -> emit_instr i.next (Some i); emit_all i.next.next | {next = {desc = Lcondbranch(_, _)}} - when is_one_instr i & no_interference i.res i.next.arg -> + when is_one_instr i && no_interference i.res i.next.arg -> emit_instr i.next (Some i); emit_all i.next.next | _ -> @@ -713,8 +712,6 @@ ` .global {emit_symbol s}\n`; | Cdefine_symbol s -> `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> @@ -724,13 +721,11 @@ | Cint n -> ` .word {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".word" f + emit_float32_directive ".word" (Int32.bits_of_float f) | Cdouble f -> - emit_float64_split_directive ".word" f + emit_float64_split_directive ".word" (Int64.bits_of_float f) | Csymbol_address s -> ` .word {emit_symbol s}\n` - | Clabel_address lbl -> - ` .word {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s | Cskip n -> diff -Nru ocaml-4.01.0/asmcomp/sparc/NOTES.md ocaml-4.05.0/asmcomp/sparc/NOTES.md --- ocaml-4.01.0/asmcomp/sparc/NOTES.md 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/sparc/NOTES.md 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,17 @@ +# Supported platforms + +SPARC v8 and up, in 32-bit mode. + +Operating systems: Solaris, Linux + (abandoned since major Linux distributions no longer support SPARC). + +Status of this port: nearly abandoned + (no hardware or virtual machine available for testing). + +# Reference documents + +* Instruction set architecture: + _The SPARC Architecture Manual_ version 8. +* ELF application binary interface: + _System V Application Binary Interface, + SPARC Processor Supplement_ diff -Nru ocaml-4.01.0/asmcomp/sparc/proc.ml ocaml-4.05.0/asmcomp/sparc/proc.ml --- ocaml-4.01.0/asmcomp/sparc/proc.ml 2013-06-03 18:03:59.000000000 +0000 +++ ocaml-4.05.0/asmcomp/sparc/proc.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Description of the Sparc processor *) @@ -65,8 +68,7 @@ let register_class r = match r.typ with - Int -> 0 - | Addr -> 0 + | Val | Int | Addr -> 0 | Float -> 1 let num_available_registers = [| 19; 15 |] @@ -81,12 +83,12 @@ (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 19 Reg.dummy in + let v = Array.make 19 Reg.dummy in for i = 0 to 18 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 32 Reg.dummy in + let v = Array.make 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v @@ -101,17 +103,19 @@ let stack_slot slot ty = Reg.at_location ty (Stack slot) +let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *) + (* Calling conventions *) let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in for i = 0 to Array.length arg - 1 do match arg.(i).typ with - Int | Addr as ty -> + | Val | Int | Addr as ty -> if !int <= last_int then begin loc.(i) <- phys_reg !int; incr int @@ -132,45 +136,67 @@ let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" + +let max_arguments_for_tailcalls = 10 let loc_arguments arg = calling_conventions 6 15 100 105 outgoing arg let loc_parameters arg = - let (loc, ofs) = calling_conventions 6 15 100 105 incoming arg in loc + let (loc, _ofs) = calling_conventions 6 15 100 105 incoming arg in loc let loc_results res = - let (loc, ofs) = calling_conventions 0 5 100 105 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 5 100 105 not_supported res in loc (* On the Sparc, all arguments to C functions, even floating-point arguments, are passed in %o0..%o5, then on the stack *) let loc_external_arguments arg = - let loc = ref [] in + let loc = Array.make (Array.length arg) [| |] in let reg = ref 0 (* %o0 *) in let ofs = ref (-4) in (* start at sp + 92 = sp + 96 - 4 *) - for i = 0 to Array.length arg - 1 do + let next_loc typ = if !reg <= 5 (* %o5 *) then begin - match arg.(i).typ with - Int | Addr -> - loc := phys_reg !reg :: !loc; - incr reg - | Float -> - if !reg = 5 then fatal_error "Proc_sparc: cannot call"; - loc := phys_reg (!reg + 1) :: phys_reg !reg :: !loc; - reg := !reg + 2 + assert (size_component typ = size_int); + let loc = phys_reg !reg in + incr reg; + loc end else begin - loc := stack_slot (outgoing !ofs) arg.(i).typ :: !loc; - ofs := !ofs + size_component arg.(i).typ + let loc = stack_slot (outgoing !ofs) typ in + ofs := !ofs + size_component typ; + loc end + in + for i = 0 to Array.length arg - 1 do + match arg.(i) with + | [| { typ = (Val | Int | Addr as typ) } |] -> + loc.(i) <- [| next_loc typ |] + | [| { typ = Float } |] -> + if !reg <= 5 then begin + let loc1 = next_loc Int in + let loc2 = next_loc Int in + loc.(i) <- [| loc1; loc2 |] + end else + loc.(i) <- [| next_loc Float |] + | [| { typ = Int }; { typ = Int } |] -> + (* int64 unboxed *) + let loc1 = next_loc Int in + let loc2 = next_loc Int in + loc.(i) <- [| loc1; loc2 |] + | _ -> + fatal_error "Proc.loc_external_arguments: cannot call" done; (* Keep stack 8-aligned *) - (Array.of_list(List.rev !loc), Misc.align (!ofs + 4) 8) + (loc, Misc.align (!ofs + 4) 8) let loc_external_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 1 100 100 not_supported res in loc let loc_exn_bucket = phys_reg 0 (* $o0 *) +(* Volatile registers: none *) + +let regs_are_volatile _rs = false + (* Registers destroyed by operations *) let destroyed_at_c_call = (* %l0-%l4, %i0-%i5 preserved *) @@ -180,8 +206,9 @@ 108; 109; 110; 111; 112; 113; 114]) let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call + Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) -> + all_phys_regs + | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call | _ -> [||] let destroyed_at_raise = all_phys_regs @@ -189,13 +216,22 @@ (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> 0 + Iextcall _ -> 0 | _ -> 15 let max_register_pressure = function - Iextcall(_, _) -> [| 11; 0 |] + Iextcall _ -> [| 11; 0 |] | _ -> [| 19; 15 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] diff -Nru ocaml-4.01.0/asmcomp/sparc/reload.ml ocaml-4.05.0/asmcomp/sparc/reload.ml --- ocaml-4.01.0/asmcomp/sparc/reload.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/sparc/reload.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Reloading for the Sparc *) diff -Nru ocaml-4.01.0/asmcomp/sparc/scheduling.ml ocaml-4.05.0/asmcomp/sparc/scheduling.ml --- ocaml-4.01.0/asmcomp/sparc/scheduling.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/sparc/scheduling.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Cmm open Mach @@ -46,11 +49,9 @@ | Iconst_symbol _ -> 2 | Ialloc _ -> 6 | Iintop(Icomp _) -> 4 - | Iintop(Icheckbound) -> 2 - | Iintop_imm(Idiv, _) -> 5 - | Iintop_imm(Imod, _) -> 5 + | Iintop(Icheckbound _) -> 2 | Iintop_imm(Icomp _, _) -> 4 - | Iintop_imm(Icheckbound, _) -> 2 + | Iintop_imm(Icheckbound _, _) -> 2 | Inegf -> 2 | Iabsf -> 2 | Ifloatofint -> 6 diff -Nru ocaml-4.01.0/asmcomp/sparc/selection.ml ocaml-4.05.0/asmcomp/sparc/selection.ml --- ocaml-4.01.0/asmcomp/sparc/selection.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/sparc/selection.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Instruction selection for the Sparc processor *) @@ -23,42 +26,36 @@ method is_immediate n = (n <= 4095) && (n >= -4096) -method select_addressing chunk = function +method select_addressing _chunk = function Cconst_symbol s -> (Ibased(s, 0), Ctuple []) - | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -> + | Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n], _) -> (Ibased(s, n), Ctuple []) - | Cop(Cadda, [arg; Cconst_int n]) -> + | Cop((Caddv | Cadda), [arg; Cconst_int n], _) -> (Iindexed n, arg) - | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> - (Iindexed n, Cop(Cadda, [arg1; arg2])) + | Cop((Caddv | Cadda as op), + [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg) -> + (Iindexed n, Cop(op, [arg1; arg2], dbg)) | arg -> (Iindexed 0, arg) -method! select_operation op args = +method private iextcall (func, alloc) = + Iextcall { func; alloc; label_after = Cmm.new_label (); } + +method! select_operation op args dbg = match (op, args) with (* For SPARC V7 multiplication, division and modulus are turned into - calls to C library routines, except if the dividend is a power of 2. + calls to C library routines. For SPARC V8 and V9, use hardware multiplication and division, but C library routine for modulus. *) - (Cmuli, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Ilsl, Misc.log2 n), [arg]) - | (Cmuli, [Cconst_int n; arg]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Ilsl, Misc.log2 n), [arg]) - | (Cmuli, _) when !arch_version = SPARC_V7 -> - (Iextcall(".umul", false), args) - | (Cdivi, [arg; Cconst_int n]) - when self#is_immediate n && n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg]) + (Cmuli, _) when !arch_version = SPARC_V7 -> + (self#iextcall(".umul", false), args) | (Cdivi, _) when !arch_version = SPARC_V7 -> - (Iextcall(".div", false), args) - | (Cmodi, [arg; Cconst_int n]) - when self#is_immediate n && n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg]) + (self#iextcall(".div", false), args) | (Cmodi, _) -> - (Iextcall(".rem", false), args) + (self#iextcall(".rem", false), args) | _ -> - super#select_operation op args + super#select_operation op args dbg (* Override insert_move_args to deal correctly with floating-point arguments being passed into pairs of integer registers. *) diff -Nru ocaml-4.01.0/asmcomp/spill.ml ocaml-4.05.0/asmcomp/spill.ml --- ocaml-4.01.0/asmcomp/spill.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/spill.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Insertion of moves to suggest possible spilling / reloading points before register allocation. *) @@ -40,7 +43,7 @@ with Not_found -> let spill_r = Reg.create r.typ in spill_r.spill <- true; - if String.length r.name > 0 then spill_r.name <- "spilled-" ^ r.name; + if not (Reg.anonymous r) then spill_r.raw_name <- r.raw_name; spill_env := Reg.Map.add r spill_r !spill_env; spill_r @@ -64,12 +67,12 @@ let max_pressure = Proc.max_register_pressure op in let regs = Reg.add_set_array live_regs res_regs in (* Compute the pressure in each register class *) - let pressure = Array.create Proc.num_register_classes 0 in + let pressure = Array.make Proc.num_register_classes 0 in Reg.Set.iter (fun r -> if Reg.Set.mem r spilled then () else begin match r.loc with - Stack s -> () + Stack _ -> () | _ -> let c = Proc.register_class r in pressure.(c) <- pressure.(c) + 1 end) @@ -129,8 +132,6 @@ with | Not_found -> Misc.fatal_error "Spill.find_reload_at_exit" -let reload_at_break = ref Reg.Set.empty - let rec reload i before = incr current_date; record_use i.arg; @@ -138,10 +139,10 @@ match i.desc with Iend -> (i, before) - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty) - | Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> + | Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) -> (* All regs live across must be spilled *) let (new_next, finally) = reload i.next i.live in (add_reloads (Reg.inter_set_array before i.arg) @@ -198,11 +199,13 @@ finally) | Iloop(body) -> let date_start = !current_date in + let destroyed_at_fork_start = !destroyed_at_fork in let at_head = ref before in let final_body = ref body in begin try while true do current_date := date_start; + destroyed_at_fork := destroyed_at_fork_start; let (new_body, new_at_head) = reload body !at_head in let merged_at_head = Reg.Set.union !at_head new_at_head in if Reg.Set.equal merged_at_head !at_head then begin @@ -216,16 +219,41 @@ let (new_next, finally) = reload i.next Reg.Set.empty in (instr_cons (Iloop(!final_body)) i.arg i.res new_next, finally) - | Icatch(nfail, body, handler) -> - let new_set = ref Reg.Set.empty in - reload_at_exit := (nfail, new_set) :: !reload_at_exit ; + | Icatch(rec_flag, handlers, body) -> + let new_sets = List.map + (fun (nfail, _) -> nfail, ref Reg.Set.empty) handlers in + let previous_reload_at_exit = !reload_at_exit in + reload_at_exit := new_sets @ !reload_at_exit ; let (new_body, after_body) = reload body before in - let at_exit = !new_set in - reload_at_exit := List.tl !reload_at_exit ; - let (new_handler, after_handler) = reload handler at_exit in - let (new_next, finally) = - reload i.next (Reg.Set.union after_body after_handler) in - (instr_cons (Icatch(nfail, new_body, new_handler)) i.arg i.res new_next, + let rec fixpoint () = + let at_exits = List.map (fun (nfail, set) -> (nfail, !set)) new_sets in + let res = + List.map2 (fun (nfail', handler) (nfail, at_exit) -> + assert(nfail = nfail'); + reload handler at_exit) handlers at_exits in + match rec_flag with + | Cmm.Nonrecursive -> + res + | Cmm.Recursive -> + let equal = List.for_all2 (fun (nfail', at_exit) (nfail, new_set) -> + assert(nfail = nfail'); + Reg.Set.equal at_exit !new_set) + at_exits new_sets in + if equal + then res + else fixpoint () + in + let res = fixpoint () in + reload_at_exit := previous_reload_at_exit; + let union = List.fold_left + (fun acc (_, after_handler) -> Reg.Set.union acc after_handler) + after_body res in + let (new_next, finally) = reload i.next union in + let new_handlers = List.map2 + (fun (nfail, _) (new_handler, _) -> nfail, new_handler) + handlers res in + (instr_cons + (Icatch(rec_flag, new_handlers, new_body)) i.arg i.res new_next, finally) | Iexit nfail -> let set = find_reload_at_exit nfail in @@ -233,12 +261,17 @@ (i, Reg.Set.empty) | Itrywith(body, handler) -> let (new_body, after_body) = reload body before in - let (new_handler, after_handler) = reload handler handler.live in + (* All registers live at the beginning of the handler are destroyed, + except the exception bucket *) + let before_handler = + Reg.Set.remove Proc.loc_exn_bucket + (Reg.add_set_array handler.live handler.arg) in + let (new_handler, after_handler) = reload handler before_handler in let (new_next, finally) = reload i.next (Reg.Set.union after_body after_handler) in (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next, finally) - | Iraise -> + | Iraise _ -> (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty) (* Second pass: add spill instructions based on what we've decided to reload. @@ -256,11 +289,15 @@ NB ter: is it the same thing for catch bodies ? *) +(* CR mshinwell for pchambart: Try to test the new algorithms for dealing + with Icatch. *) let spill_at_exit = ref [] let find_spill_at_exit k = try - List.assoc k !spill_at_exit + let used, set = List.assoc k !spill_at_exit in + used := true; + set with | Not_found -> Misc.fatal_error "Spill.find_spill_at_exit" @@ -278,7 +315,7 @@ match i.desc with Iend -> (i, finally) - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> (i, Reg.Set.empty) | Iop Ireload -> let (new_next, after) = spill i.next finally in @@ -290,8 +327,8 @@ let before1 = Reg.diff_set_array after i.res in let before = match i.desc with - Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) - | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> + Iop Icall_ind _ | Iop(Icall_imm _) | Iop(Iextcall _) + | Iop(Iintop (Icheckbound _)) | Iop(Iintop_imm((Icheckbound _), _)) -> Reg.Set.union before1 !spill_at_raise | _ -> before1 in @@ -303,7 +340,7 @@ let (new_ifso, before_ifso) = spill ifso at_join in let (new_ifnot, before_ifnot) = spill ifnot at_join in if - !inside_loop || !inside_arm + !inside_loop || !inside_arm || !inside_catch then (instr_cons (Iifthenelse(test, new_ifso, new_ifnot)) i.arg i.res new_next, @@ -357,16 +394,46 @@ inside_loop := saved_inside_loop; (instr_cons (Iloop(!final_body)) i.arg i.res new_next, !at_head) - | Icatch(nfail, body, handler) -> + | Icatch(rec_flag, handlers, body) -> let (new_next, at_join) = spill i.next finally in - let (new_handler, at_exit) = spill handler at_join in let saved_inside_catch = !inside_catch in inside_catch := true ; - spill_at_exit := (nfail, at_exit) :: !spill_at_exit ; - let (new_body, before) = spill body at_join in - spill_at_exit := List.tl !spill_at_exit; + let previous_spill_at_exit = !spill_at_exit in + let spill_at_exit_add at_exits = List.map2 + (fun (nfail,_) at_exit -> nfail, (ref false, at_exit)) + handlers at_exits + in + let rec fixpoint at_exits = + let spill_at_exit_add = spill_at_exit_add at_exits in + spill_at_exit := spill_at_exit_add @ !spill_at_exit; + let res = + List.map (fun (_, handler) -> spill handler at_join) handlers + in + spill_at_exit := previous_spill_at_exit; + match rec_flag with + | Cmm.Nonrecursive -> + res + | Cmm.Recursive -> + let equal = + List.for_all2 + (fun (_new_handler, new_at_exit) (_, (used, at_exit)) -> + Reg.Set.equal at_exit new_at_exit || not !used) + res spill_at_exit_add in + if equal + then res + else fixpoint (List.map snd res) + in + let res = fixpoint (List.map (fun _ -> Reg.Set.empty) handlers) in inside_catch := saved_inside_catch ; - (instr_cons (Icatch(nfail, new_body, new_handler)) i.arg i.res new_next, + let spill_at_exit_add = spill_at_exit_add (List.map snd res) in + spill_at_exit := spill_at_exit_add @ !spill_at_exit; + let (new_body, before) = spill body at_join in + spill_at_exit := previous_spill_at_exit; + let new_handlers = List.map2 + (fun (nfail, _) (handler, _) -> nfail, handler) + handlers res in + (instr_cons (Icatch(rec_flag, new_handlers, new_body)) + i.arg i.res new_next, before) | Iexit nfail -> (i, find_spill_at_exit nfail) @@ -379,23 +446,31 @@ spill_at_raise := saved_spill_at_raise; (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next, before_body) - | Iraise -> + | Iraise _ -> (i, !spill_at_raise) (* Entry point *) -let fundecl f = +let reset () = spill_env := Reg.Map.empty; use_date := Reg.Map.empty; current_date := 0; + destroyed_at_fork := [] + +let fundecl f = + reset (); + let (body1, _) = reload f.fun_body Reg.Set.empty in let (body2, tospill_at_entry) = spill body1 Reg.Set.empty in let new_body = add_spills (Reg.inter_set_array tospill_at_entry f.fun_args) body2 in spill_env := Reg.Map.empty; use_date := Reg.Map.empty; + destroyed_at_fork := []; { fun_name = f.fun_name; fun_args = f.fun_args; fun_body = new_body; fun_fast = f.fun_fast; - fun_dbg = f.fun_dbg } + fun_dbg = f.fun_dbg; + fun_spacetime_shape = f.fun_spacetime_shape; + } diff -Nru ocaml-4.01.0/asmcomp/spill.mli ocaml-4.05.0/asmcomp/spill.mli --- ocaml-4.01.0/asmcomp/spill.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/spill.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,16 +1,20 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Insertion of moves to suggest possible spilling / reloading points before register allocation. *) val fundecl: Mach.fundecl -> Mach.fundecl +val reset : unit -> unit diff -Nru ocaml-4.01.0/asmcomp/split.ml ocaml-4.05.0/asmcomp/split.ml --- ocaml-4.01.0/asmcomp/split.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/split.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Renaming of registers at reload points to split live ranges. *) @@ -30,7 +33,7 @@ None -> rv | Some s -> let n = Array.length rv in - let nv = Array.create n Reg.dummy in + let nv = Array.make n Reg.dummy in for i = 0 to n-1 do nv.(i) <- subst_reg rv.(i) s done; nv @@ -84,8 +87,8 @@ let merge_substs sub1 sub2 i = match (sub1, sub2) with (None, None) -> None - | (Some s1, None) -> sub1 - | (None, Some s2) -> sub2 + | (Some _, None) -> sub1 + | (None, Some _) -> sub2 | (Some s1, Some s2) -> Reg.Set.iter (identify_sub s1 s2) (Reg.add_set_array i.live i.arg); sub1 @@ -122,8 +125,8 @@ match i.desc with Iend -> (i, sub) - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> - (instr_cons i.desc (subst_regs i.arg sub) [||] i.next, + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> + (instr_cons_debug i.desc (subst_regs i.arg sub) [||] i.dbg i.next, None) | Iop Ireload when i.res.(0).loc = Unknown -> begin match sub with @@ -152,9 +155,9 @@ | Iswitch(index, cases) -> let new_sub_cases = Array.map (fun c -> rename c sub) cases in let sub_merge = - merge_subst_array (Array.map (fun (n, s) -> s) new_sub_cases) i.next in + merge_subst_array (Array.map (fun (_n, s) -> s) new_sub_cases) i.next in let (new_next, sub_next) = rename i.next sub_merge in - (instr_cons (Iswitch(index, Array.map (fun (n, s) -> n) new_sub_cases)) + (instr_cons (Iswitch(index, Array.map (fun (n, _s) -> n) new_sub_cases)) (subst_regs i.arg sub) [||] new_next, sub_next) | Iloop(body) -> @@ -162,16 +165,24 @@ let (new_next, sub_next) = rename i.next (merge_substs sub sub_body i) in (instr_cons (Iloop(new_body)) [||] [||] new_next, sub_next) - | Icatch(nfail, body, handler) -> - let new_subst = ref None in - exit_subst := (nfail, new_subst) :: !exit_subst ; + | Icatch(rec_flag, handlers, body) -> + let new_subst = List.map (fun (nfail, _) -> nfail, ref None) + handlers in + let previous_exit_subst = !exit_subst in + exit_subst := new_subst @ !exit_subst; let (new_body, sub_body) = rename body sub in - let sub_entry_handler = !new_subst in - exit_subst := List.tl !exit_subst; - let (new_handler, sub_handler) = rename handler sub_entry_handler in - let (new_next, sub_next) = - rename i.next (merge_substs sub_body sub_handler i.next) in - (instr_cons (Icatch(nfail, new_body, new_handler)) [||] [||] new_next, + let res = List.map2 (fun (_, handler) (_, new_subst) -> rename handler !new_subst) + handlers new_subst in + exit_subst := previous_exit_subst; + let merged_subst = + List.fold_left (fun acc (_, sub_handler) -> + merge_substs acc sub_handler i.next) + sub_body res in + let (new_next, sub_next) = rename i.next merged_subst in + let new_handlers = List.map2 (fun (nfail, _) (handler, _) -> + (nfail, handler)) handlers res in + (instr_cons + (Icatch(rec_flag, new_handlers, new_body)) [||] [||] new_next, sub_next) | Iexit nfail -> let r = find_exit_subst nfail in @@ -184,8 +195,8 @@ rename i.next (merge_substs sub_body sub_handler i.next) in (instr_cons (Itrywith(new_body, new_handler)) [||] [||] new_next, sub_next) - | Iraise -> - (instr_cons_debug Iraise (subst_regs i.arg sub) [||] i.dbg i.next, + | Iraise k -> + (instr_cons_debug (Iraise k) (subst_regs i.arg sub) [||] i.dbg i.next, None) (* Second pass: replace registers by their final representatives *) @@ -195,10 +206,15 @@ (* Entry point *) -let fundecl f = +let reset () = equiv_classes := Reg.Map.empty; + exit_subst := [] + +let fundecl f = + reset (); + let new_args = Array.copy f.fun_args in - let (new_body, sub_body) = rename f.fun_body (Some Reg.Map.empty) in + let (new_body, _sub_body) = rename f.fun_body (Some Reg.Map.empty) in repres_regs new_args; set_repres new_body; equiv_classes := Reg.Map.empty; @@ -206,4 +222,6 @@ fun_args = new_args; fun_body = new_body; fun_fast = f.fun_fast; - fun_dbg = f.fun_dbg } + fun_dbg = f.fun_dbg; + fun_spacetime_shape = f.fun_spacetime_shape; + } diff -Nru ocaml-4.01.0/asmcomp/split.mli ocaml-4.05.0/asmcomp/split.mli --- ocaml-4.01.0/asmcomp/split.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmcomp/split.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,20 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Renaming of registers at reload points to split live ranges. *) val fundecl: Mach.fundecl -> Mach.fundecl + +val reset : unit -> unit diff -Nru ocaml-4.01.0/asmcomp/strmatch.ml ocaml-4.05.0/asmcomp/strmatch.ml --- ocaml-4.01.0/asmcomp/strmatch.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/strmatch.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,395 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Translation of string matching from closed lambda to C-- *) + +open Lambda +open Cmm + +module type I = sig + val string_block_length : Cmm.expression -> Cmm.expression + val transl_switch : + Cmm.expression -> int -> int -> + (int * Cmm.expression) list -> Cmm.expression -> + Cmm.expression +end + +module Make(I:I) = struct + +(* Debug *) + + let dbg = false + + let mask = + let open Nativeint in + sub (shift_left one 8) one + + let pat_as_string p = + let rec digits k n p = + if n <= 0 then k + else + let d = Nativeint.to_int (Nativeint.logand mask p) in + let d = Char.escaped (Char.chr d) in + digits (d::k) (n-1) (Nativeint.shift_right_logical p 8) in + let ds = digits [] Arch.size_addr p in + let ds = + if Arch.big_endian then ds else List.rev ds in + String.concat "" ds + + let do_pp_cases chan cases = + List.iter + (fun (ps,_) -> + Printf.fprintf chan " [%s]\n" + (String.concat "; " (List.map pat_as_string ps))) + cases + + let pp_cases chan tag cases = + Printf.eprintf "%s:\n" tag ; + do_pp_cases chan cases + + let pp_match chan tag idxs cases = + Printf.eprintf + "%s: idx=[%s]\n" tag + (String.concat "; " (List.map string_of_int idxs)) ; + do_pp_cases chan cases + +(* Utilities *) + + let gen_cell_id () = Ident.create "cell" + let gen_size_id () = Ident.create "size" + + let mk_let_cell id str ind body = + let dbg = Debuginfo.none in + let cell = + Cop(Cload (Word_int, Asttypes.Mutable), + [Cop(Cadda,[str;Cconst_int(Arch.size_int*ind)], dbg)], + dbg) in + Clet(id, cell, body) + + let mk_let_size id str body = + let size = I.string_block_length str in + Clet(id, size, body) + + let mk_cmp_gen cmp_op id nat ifso ifnot = + let dbg = Debuginfo.none in + let test = + Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer nat ], dbg) + in + Cifthenelse (test, ifso, ifnot) + + let mk_lt = mk_cmp_gen Clt + let mk_eq = mk_cmp_gen Ceq + + module IntArg = + struct + type t = int + let compare (x:int) (y:int) = + if x < y then -1 + else if x > y then 1 + else 0 + end + + let interval m0 n = + let rec do_rec m = + if m >= n then [] + else m::do_rec (m+1) in + do_rec m0 + + +(*****************************************************) +(* Compile strings to a lists of words [native ints] *) +(*****************************************************) + + let pat_of_string str = + let len = String.length str in + let n = len / Arch.size_addr + 1 in + let get_byte i = + if i < len then int_of_char str.[i] + else if i < n * Arch.size_addr - 1 then 0 + else n * Arch.size_addr - 1 - len in + let mk_word ind = + let w = ref 0n in + let imin = ind * Arch.size_addr + and imax = (ind + 1) * Arch.size_addr - 1 in + if Arch.big_endian then + for i = imin to imax do + w := Nativeint.logor (Nativeint.shift_left !w 8) + (Nativeint.of_int (get_byte i)); + done + else + for i = imax downto imin do + w := Nativeint.logor (Nativeint.shift_left !w 8) + (Nativeint.of_int (get_byte i)); + done; + !w in + let rec mk_words ind = + if ind >= n then [] + else mk_word ind::mk_words (ind+1) in + mk_words 0 + +(*****************************) +(* Discriminating heuristics *) +(*****************************) + + module IntSet = Set.Make(IntArg) + module NativeSet = Set.Make(Nativeint) + + let rec add_one sets ps = match sets,ps with + | [],[] -> [] + | set::sets,p::ps -> + let sets = add_one sets ps in + NativeSet.add p set::sets + | _,_ -> assert false + + let count_arities cases = match cases with + | [] -> assert false + | (ps,_)::_ -> + let sets = + List.fold_left + (fun sets (ps,_) -> add_one sets ps) + (List.map (fun _ -> NativeSet.empty) ps) cases in + List.map NativeSet.cardinal sets + + let count_arities_first cases = + let set = + List.fold_left + (fun set case -> match case with + | (p::_,_) -> NativeSet.add p set + | _ -> assert false) + NativeSet.empty cases in + NativeSet.cardinal set + + let count_arities_length cases = + let set = + List.fold_left + (fun set (ps,_) -> IntSet.add (List.length ps) set) + IntSet.empty cases in + IntSet.cardinal set + + let best_col = + let rec do_rec kbest best k = function + | [] -> kbest + | x::xs -> + if x < best then + do_rec k x (k+1) xs + else + do_rec kbest best (k+1) xs in + let smallest = do_rec (-1) max_int 0 in + fun cases -> + let ars = count_arities cases in + smallest ars + + let swap_list = + let rec do_rec k xs = match xs with + | [] -> assert false + | x::xs -> + if k <= 0 then [],x,xs + else + let xs,mid,ys = do_rec (k-1) xs in + x::xs,mid,ys in + fun k xs -> + let xs,x,ys = do_rec k xs in + x::xs @ ys + + let swap k idxs cases = + if k = 0 then idxs,cases + else + let idxs = swap_list k idxs + and cases = + List.map + (fun (ps,act) -> swap_list k ps,act) + cases in + if dbg then begin + pp_match stderr "SWAP" idxs cases + end ; + idxs,cases + + let best_first idxs cases = match idxs with + | []|[_] -> idxs,cases (* optimisation: one column only *) + | _ -> + let k = best_col cases in + swap k idxs cases + +(************************************) +(* Divide according to first column *) +(************************************) + + module Divide(O:Set.OrderedType) = struct + + module OMap = Map.Make(O) + + let divide cases = + let env = + List.fold_left + (fun env (p,psact) -> + let old = + try OMap.find p env + with Not_found -> [] in + OMap.add p ((psact)::old) env) + OMap.empty cases in + let r = OMap.fold (fun key v k -> (key,v)::k) env [] in + List.rev r (* Now sorted *) + end + +(***************) +(* Compilation *) +(***************) + +(* Group by cell *) + + module DivideNative = Divide(Nativeint) + + let by_cell cases = + DivideNative.divide + (List.map + (fun case -> match case with + | (p::ps),act -> p,(ps,act) + | [],_ -> assert false) + cases) + +(* Split into two halves *) + + let rec do_split idx env = match env with + | [] -> assert false + | (midkey,_ as x)::rem -> + if idx <= 0 then [],midkey,env + else + let lt,midkey,ge = do_split (idx-1) rem in + x::lt,midkey,ge + + let split_env len env = do_split (len/2) env + +(* Switch according to one cell *) + +(* + Emit the switch, here as a comparison tree. + Argument compile_rec is to be called to compile the rest of patterns, + as match_on_cell can be called in two different contexts : + from do_compile_pats and top_compile below. + *) + let match_oncell compile_rec str default idx env = + let id = gen_cell_id () in + let rec comp_rec env = + let len = List.length env in + if len <= 3 then + List.fold_right + (fun (key,cases) ifnot -> + mk_eq id key + (compile_rec str default cases) + ifnot) + env default + else + let lt,midkey,ge = split_env len env in + mk_lt id midkey (comp_rec lt) (comp_rec ge) in + mk_let_cell id str idx (comp_rec env) + +(* + Recursive 'list of cells' compile function: + - choose the matched cell and switch on it + - notice: patterns (and idx) all have the same length + *) + + let rec do_compile_pats idxs str default cases = + if dbg then begin + pp_match stderr "COMPILE" idxs cases + end ; + match idxs with + | [] -> + begin match cases with + | [] -> default + | (_,e)::_ -> e + end + | _::_ -> + let idxs,cases = best_first idxs cases in + begin match idxs with + | [] -> assert false + | idx::idxs -> + match_oncell + (do_compile_pats idxs) str default idx (by_cell cases) + end + + +(* Group by size *) + + module DivideInt = Divide(IntArg) + + + let by_size cases = + DivideInt.divide + (List.map + (fun (ps,_ as case) -> List.length ps,case) + cases) +(* + Switch according to pattern size + Argument from_ind is the starting index, it can be zero + or one (when the swicth on the cell 0 has already been performed. + In that latter case pattern len is string length-1 and is corrected. + *) + + let compile_by_size dbg from_ind str default cases = + let size_cases = + List.map + (fun (len,cases) -> + let len = len+from_ind in + let act = + do_compile_pats + (interval from_ind len) + str default cases in + (len,act)) + (by_size cases) in + let id = gen_size_id () in + ignore dbg; + let switch = I.transl_switch (Cvar id) 1 max_int size_cases default in + mk_let_size id str switch + +(* + Compilation entry point: we choose to switch + either on size or on first cell, using the + 'least discriminant' heuristics. + *) + let top_compile debuginfo str default cases = + let a_len = count_arities_length cases + and a_fst = count_arities_first cases in + if a_len <= a_fst then begin + if dbg then pp_cases stderr "SIZE" cases ; + compile_by_size debuginfo 0 str default cases + end else begin + if dbg then pp_cases stderr "FIRST COL" cases ; + let compile_size_rest str default cases = + compile_by_size debuginfo 1 str default cases in + match_oncell compile_size_rest str default 0 (by_cell cases) + end + +(* Module entry point *) + + let catch arg k = match arg with + | Cexit (_e,[]) -> k arg + | _ -> + let e = next_raise_count () in + ccatch (e,[],k (Cexit (e,[])),arg) + + let compile dbg str default cases = +(* We do not attempt to really optimise default=None *) + let cases,default = match cases,default with + | (_,e)::cases,None + | cases,Some e -> cases,e + | [],None -> assert false in + let cases = + List.rev_map + (fun (s,act) -> pat_of_string s,act) + cases in + catch default (fun default -> top_compile dbg str default cases) + + end diff -Nru ocaml-4.01.0/asmcomp/strmatch.mli ocaml-4.05.0/asmcomp/strmatch.mli --- ocaml-4.01.0/asmcomp/strmatch.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/strmatch.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Translation of string matching from closed lambda to C-- *) + +module type I = sig + val string_block_length : Cmm.expression -> Cmm.expression + val transl_switch : + Cmm.expression -> int -> int -> + (int * Cmm.expression) list -> Cmm.expression -> + Cmm.expression +end + +module Make(I:I) : sig + (* Compile stringswitch (arg,cases,d) + Note: cases should not contain string duplicates *) + val compile : Debuginfo.t -> Cmm.expression (* arg *) + -> Cmm.expression option (* d *) -> + (string * Cmm.expression) list (* cases *)-> Cmm.expression +end diff -Nru ocaml-4.01.0/asmcomp/un_anf.ml ocaml-4.05.0/asmcomp/un_anf.ml --- ocaml-4.01.0/asmcomp/un_anf.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/un_anf.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,750 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +(* We say that an [Ident.t] is "linear" iff: + (a) it is used exactly once; + (b) it is never assigned to (using [Uassign]). +*) +type ident_info = + { used : Ident.Set.t; + linear : Ident.Set.t; + assigned : Ident.Set.t; + closure_environment : Ident.Set.t; + let_bound_vars_that_can_be_moved : Ident.Set.t; + } + +let ignore_uconstant (_ : Clambda.uconstant) = () +let ignore_ulambda (_ : Clambda.ulambda) = () +let ignore_ulambda_list (_ : Clambda.ulambda list) = () +let ignore_function_label (_ : Clambda.function_label) = () +let ignore_debuginfo (_ : Debuginfo.t) = () +let ignore_int (_ : int) = () +let ignore_ident (_ : Ident.t) = () +let ignore_ident_option (_ : Ident.t option) = () +let ignore_primitive (_ : Lambda.primitive) = () +let ignore_string (_ : string) = () +let ignore_int_array (_ : int array) = () +let ignore_ident_list (_ : Ident.t list) = () +let ignore_direction_flag (_ : Asttypes.direction_flag) = () +let ignore_meth_kind (_ : Lambda.meth_kind) = () + +(* CR-soon mshinwell: check we aren't traversing function bodies more than + once (need to analyse exactly what the calls are from Cmmgen into this + module). *) + +let closure_environment_ident (ufunction:Clambda.ufunction) = + (* The argument after the arity is the environment *) + if List.length ufunction.params = ufunction.arity + 1 then + let env_var = List.nth ufunction.params ufunction.arity in + assert(Ident.name env_var = "env"); + Some env_var + else + (* closed function, no environment *) + None + +let make_ident_info (clam : Clambda.ulambda) : ident_info = + let t : int Ident.Tbl.t = Ident.Tbl.create 42 in + let assigned_idents = ref Ident.Set.empty in + let environment_idents = ref Ident.Set.empty in + let rec loop : Clambda.ulambda -> unit = function + (* No underscores in the pattern match, to reduce the chance of failing + to traverse some subexpression. *) + | Uvar id -> + begin match Ident.Tbl.find t id with + | n -> Ident.Tbl.replace t id (n + 1) + | exception Not_found -> Ident.Tbl.add t id 1 + end + | Uconst const -> + (* The only variables that might occur in [const] are those in constant + closures---and those are all bound by such closures. It follows that + [const] cannot contain any variables that are bound in the current + scope, so we do not need to count them here. (The function bodies + of the closures will be traversed when this function is called from + [Cmmgen.transl_function].) *) + ignore_uconstant const + | Udirect_apply (label, args, dbg) -> + ignore_function_label label; + List.iter loop args; + ignore_debuginfo dbg + | Ugeneric_apply (func, args, dbg) -> + loop func; + List.iter loop args; + ignore_debuginfo dbg + | Uclosure (functions, captured_variables) -> + List.iter loop captured_variables; + List.iter (fun ( + { Clambda. label; arity; params; body; dbg; env; } as clos) -> + (match closure_environment_ident clos with + | None -> () + | Some env_var -> + environment_idents := + Ident.Set.add env_var !environment_idents); + ignore_function_label label; + ignore_int arity; + ignore_ident_list params; + loop body; + ignore_debuginfo dbg; + ignore_ident_option env) + functions + | Uoffset (expr, offset) -> + loop expr; + ignore_int offset + | Ulet (_let_kind, _value_kind, _ident, def, body) -> + loop def; + loop body + | Uletrec (defs, body) -> + List.iter (fun (ident, def) -> + ignore_ident ident; + loop def) + defs; + loop body + | Uprim (prim, args, dbg) -> + ignore_primitive prim; + List.iter loop args; + ignore_debuginfo dbg + | Uswitch (cond, { us_index_consts; us_actions_consts; + us_index_blocks; us_actions_blocks }) -> + loop cond; + ignore_int_array us_index_consts; + Array.iter loop us_actions_consts; + ignore_int_array us_index_blocks; + Array.iter loop us_actions_blocks + | Ustringswitch (cond, branches, default) -> + loop cond; + List.iter (fun (str, branch) -> + ignore_string str; + loop branch) + branches; + Misc.may loop default + | Ustaticfail (static_exn, args) -> + ignore_int static_exn; + List.iter loop args + | Ucatch (static_exn, idents, body, handler) -> + ignore_int static_exn; + ignore_ident_list idents; + loop body; + loop handler + | Utrywith (body, ident, handler) -> + loop body; + ignore_ident ident; + loop handler + | Uifthenelse (cond, ifso, ifnot) -> + loop cond; + loop ifso; + loop ifnot + | Usequence (e1, e2) -> + loop e1; + loop e2 + | Uwhile (cond, body) -> + loop cond; + loop body + | Ufor (ident, low, high, direction_flag, body) -> + ignore_ident ident; + loop low; + loop high; + ignore_direction_flag direction_flag; + loop body + | Uassign (ident, expr) -> + assigned_idents := Ident.Set.add ident !assigned_idents; + loop expr + | Usend (meth_kind, e1, e2, args, dbg) -> + ignore_meth_kind meth_kind; + loop e1; + loop e2; + List.iter loop args; + ignore_debuginfo dbg + | Uunreachable -> + () + in + loop clam; + let linear = + Ident.Tbl.fold (fun id n acc -> + assert (n >= 1); + if n = 1 && not (Ident.Set.mem id !assigned_idents) + then Ident.Set.add id acc + else acc) + t Ident.Set.empty + in + let assigned = !assigned_idents in + let used = + (* This doesn't work transitively and thus is somewhat restricted. In + particular, it does not allow us to get rid of useless chains of [let]s. + However it should be sufficient to remove the majority of unnecessary + [let] bindings that might hinder [Cmmgen]. *) + Ident.Tbl.fold (fun id _n acc -> Ident.Set.add id acc) + t assigned + in + { used; linear; assigned; closure_environment = !environment_idents; + let_bound_vars_that_can_be_moved = Ident.Set.empty; + } + +(* When sequences of [let]-bindings match the evaluation order in a subsequent + primitive or function application whose arguments are linearly-used + non-assigned variables bound by such lets (possibly interspersed with other + variables that are known to be constant), and it is known that there were no + intervening side-effects during the evaluation of the [let]-bindings, + permit substitution of the variables for their defining expressions. *) +let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) = + let obviously_constant = ref Ident.Set.empty in + let can_move = ref Ident.Set.empty in + let let_stack = ref [] in + let examine_argument_list args = + let rec loop let_bound_vars (args : Clambda.ulambda list) = + match let_bound_vars, args with + | _, [] -> + (* We've matched all arguments and will not substitute (in the + current application being considered) any of the remaining + [let_bound_vars]. As such they may stay on the stack. *) + let_bound_vars + | [], _ -> + (* There are no more [let]-bindings to consider, so the stack + is left empty. *) + [] + | let_bound_vars, (Uvar arg)::args + when Ident.Set.mem arg !obviously_constant -> + loop let_bound_vars args + | let_bound_var::let_bound_vars, (Uvar arg)::args + when Ident.same let_bound_var arg + && not (Ident.Set.mem arg ident_info.assigned) -> + assert (Ident.Set.mem arg ident_info.used); + assert (Ident.Set.mem arg ident_info.linear); + can_move := Ident.Set.add arg !can_move; + loop let_bound_vars args + | _::_, _::_ -> + (* The [let] sequence has ceased to match the evaluation order + or we have encountered some complicated argument. In this case + we empty the stack to ensure that we do not end up moving an + outer [let] across a side effect. *) + [] + in + (* Start at the most recent let binding and the leftmost argument + (the last argument to be evaluated). *) + let_stack := loop !let_stack args + in + let rec loop : Clambda.ulambda -> unit = function + | Uvar ident -> + if Ident.Set.mem ident ident_info.assigned then begin + let_stack := [] + end + | Uconst const -> + ignore_uconstant const + | Udirect_apply (label, args, dbg) -> + ignore_function_label label; + examine_argument_list args; + (* We don't currently traverse [args]; they should all be variables + anyway. If this is added in the future, take care to traverse [args] + following the evaluation order. *) + ignore_debuginfo dbg + | Ugeneric_apply (func, args, dbg) -> + examine_argument_list (args @ [func]); + ignore_debuginfo dbg + | Uclosure (functions, captured_variables) -> + ignore_ulambda_list captured_variables; + (* Start a new let stack for speed. *) + List.iter (fun { Clambda. label; arity; params; body; dbg; env; } -> + ignore_function_label label; + ignore_int arity; + ignore_ident_list params; + let_stack := []; + loop body; + let_stack := []; + ignore_debuginfo dbg; + ignore_ident_option env) + functions + | Uoffset (expr, offset) -> + (* [expr] should usually be a variable. *) + examine_argument_list [expr]; + ignore_int offset + | Ulet (_let_kind, _value_kind, ident, def, body) -> + begin match def with + | Uconst _ -> + (* The defining expression is obviously constant, so we don't + have to put this [let] on the stack, and we don't have to + traverse the defining expression either. *) + obviously_constant := Ident.Set.add ident !obviously_constant; + loop body + | _ -> + loop def; + if Ident.Set.mem ident ident_info.linear then begin + let_stack := ident::!let_stack + end else begin + (* If we encounter a non-linear [let]-binding then we must clear + the let stack, since we cannot now move any previous binding + across the non-linear one. *) + let_stack := [] + end; + loop body + end + | Uletrec (defs, body) -> + (* Evaluation order for [defs] is not defined, and this case + probably isn't important for [Cmmgen] anyway. *) + let_stack := []; + List.iter (fun (ident, def) -> + ignore_ident ident; + loop def; + let_stack := []) + defs; + loop body + | Uprim (prim, args, dbg) -> + ignore_primitive prim; + examine_argument_list args; + ignore_debuginfo dbg + | Uswitch (cond, { us_index_consts; us_actions_consts; + us_index_blocks; us_actions_blocks }) -> + examine_argument_list [cond]; + ignore_int_array us_index_consts; + Array.iter (fun action -> + let_stack := []; + loop action) + us_actions_consts; + ignore_int_array us_index_blocks; + Array.iter (fun action -> + let_stack := []; + loop action) + us_actions_blocks; + let_stack := [] + | Ustringswitch (cond, branches, default) -> + examine_argument_list [cond]; + List.iter (fun (str, branch) -> + ignore_string str; + let_stack := []; + loop branch) + branches; + let_stack := []; + Misc.may loop default; + let_stack := [] + | Ustaticfail (static_exn, args) -> + ignore_int static_exn; + ignore_ulambda_list args; + let_stack := [] + | Ucatch (static_exn, idents, body, handler) -> + ignore_int static_exn; + ignore_ident_list idents; + let_stack := []; + loop body; + let_stack := []; + loop handler; + let_stack := [] + | Utrywith (body, ident, handler) -> + let_stack := []; + loop body; + let_stack := []; + ignore_ident ident; + loop handler; + let_stack := [] + | Uifthenelse (cond, ifso, ifnot) -> + examine_argument_list [cond]; + let_stack := []; + loop ifso; + let_stack := []; + loop ifnot; + let_stack := [] + | Usequence (e1, e2) -> + loop e1; + let_stack := []; + loop e2; + let_stack := [] + | Uwhile (cond, body) -> + let_stack := []; + loop cond; + let_stack := []; + loop body; + let_stack := [] + | Ufor (ident, low, high, direction_flag, body) -> + ignore_ident ident; + (* Cmmgen generates code that evaluates low before high, + but we don't do anything here at the moment anyway. *) + ignore_ulambda low; + ignore_ulambda high; + ignore_direction_flag direction_flag; + let_stack := []; + loop body; + let_stack := [] + | Uassign (ident, expr) -> + ignore_ident ident; + ignore_ulambda expr; + let_stack := [] + | Usend (meth_kind, e1, e2, args, dbg) -> + ignore_meth_kind meth_kind; + ignore_ulambda e1; + ignore_ulambda e2; + ignore_ulambda_list args; + let_stack := []; + ignore_debuginfo dbg + | Uunreachable -> + let_stack := [] + in + loop clam; + !can_move + +(* Substitution of an expression for a let-moveable variable can cause the + surrounding expression to become fixed. To avoid confusion, do the + let-moveable substitutions first. *) +let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) + : Clambda.ulambda = + match clam with + | Uvar id -> + if not (Ident.Set.mem id is_let_moveable) then + clam + else + begin match Ident.Map.find id env with + | clam -> clam + | exception Not_found -> + Misc.fatal_errorf "substitute_let_moveable: Unbound identifier %a" + Ident.print id + end + | Uconst _ -> clam + | Udirect_apply (label, args, dbg) -> + let args = substitute_let_moveable_list is_let_moveable env args in + Udirect_apply (label, args, dbg) + | Ugeneric_apply (func, args, dbg) -> + let func = substitute_let_moveable is_let_moveable env func in + let args = substitute_let_moveable_list is_let_moveable env args in + Ugeneric_apply (func, args, dbg) + | Uclosure (functions, variables_bound_by_the_closure) -> + let functions = + List.map (fun (ufunction : Clambda.ufunction) -> + { ufunction with + body = substitute_let_moveable is_let_moveable env ufunction.body; + }) + functions + in + let variables_bound_by_the_closure = + substitute_let_moveable_list is_let_moveable env + variables_bound_by_the_closure + in + Uclosure (functions, variables_bound_by_the_closure) + | Uoffset (clam, n) -> + let clam = substitute_let_moveable is_let_moveable env clam in + Uoffset (clam, n) + | Ulet (let_kind, value_kind, id, def, body) -> + let def = substitute_let_moveable is_let_moveable env def in + if Ident.Set.mem id is_let_moveable then + let env = Ident.Map.add id def env in + substitute_let_moveable is_let_moveable env body + else + Ulet (let_kind, value_kind, + id, def, substitute_let_moveable is_let_moveable env body) + | Uletrec (defs, body) -> + let defs = + List.map (fun (id, def) -> + id, substitute_let_moveable is_let_moveable env def) + defs + in + let body = substitute_let_moveable is_let_moveable env body in + Uletrec (defs, body) + | Uprim (prim, args, dbg) -> + let args = substitute_let_moveable_list is_let_moveable env args in + Uprim (prim, args, dbg) + | Uswitch (cond, sw) -> + let cond = substitute_let_moveable is_let_moveable env cond in + let sw = + { sw with + us_actions_consts = + substitute_let_moveable_array is_let_moveable env + sw.us_actions_consts; + us_actions_blocks = + substitute_let_moveable_array is_let_moveable env + sw.us_actions_blocks; + } + in + Uswitch (cond, sw) + | Ustringswitch (cond, branches, default) -> + let cond = substitute_let_moveable is_let_moveable env cond in + let branches = + List.map (fun (s, branch) -> + s, substitute_let_moveable is_let_moveable env branch) + branches + in + let default = + Misc.may_map (substitute_let_moveable is_let_moveable env) default + in + Ustringswitch (cond, branches, default) + | Ustaticfail (n, args) -> + let args = substitute_let_moveable_list is_let_moveable env args in + Ustaticfail (n, args) + | Ucatch (n, ids, body, handler) -> + let body = substitute_let_moveable is_let_moveable env body in + let handler = substitute_let_moveable is_let_moveable env handler in + Ucatch (n, ids, body, handler) + | Utrywith (body, id, handler) -> + let body = substitute_let_moveable is_let_moveable env body in + let handler = substitute_let_moveable is_let_moveable env handler in + Utrywith (body, id, handler) + | Uifthenelse (cond, ifso, ifnot) -> + let cond = substitute_let_moveable is_let_moveable env cond in + let ifso = substitute_let_moveable is_let_moveable env ifso in + let ifnot = substitute_let_moveable is_let_moveable env ifnot in + Uifthenelse (cond, ifso, ifnot) + | Usequence (e1, e2) -> + let e1 = substitute_let_moveable is_let_moveable env e1 in + let e2 = substitute_let_moveable is_let_moveable env e2 in + Usequence (e1, e2) + | Uwhile (cond, body) -> + let cond = substitute_let_moveable is_let_moveable env cond in + let body = substitute_let_moveable is_let_moveable env body in + Uwhile (cond, body) + | Ufor (id, low, high, direction, body) -> + let low = substitute_let_moveable is_let_moveable env low in + let high = substitute_let_moveable is_let_moveable env high in + let body = substitute_let_moveable is_let_moveable env body in + Ufor (id, low, high, direction, body) + | Uassign (id, expr) -> + let expr = substitute_let_moveable is_let_moveable env expr in + Uassign (id, expr) + | Usend (kind, e1, e2, args, dbg) -> + let e1 = substitute_let_moveable is_let_moveable env e1 in + let e2 = substitute_let_moveable is_let_moveable env e2 in + let args = substitute_let_moveable_list is_let_moveable env args in + Usend (kind, e1, e2, args, dbg) + | Uunreachable -> + Uunreachable + +and substitute_let_moveable_list is_let_moveable env clams = + List.map (substitute_let_moveable is_let_moveable env) clams + +and substitute_let_moveable_array is_let_moveable env clams = + Array.map (substitute_let_moveable is_let_moveable env) clams + +(* We say that an expression is "moveable" iff it has neither effects nor + coeffects. (See semantics_of_primitives.mli.) +*) +type moveable = Fixed | Constant | Moveable + +let both_moveable a b = + match a, b with + | Constant, Constant -> Constant + | Constant, Moveable + | Moveable, Constant + | Moveable, Moveable -> Moveable + | Constant, Fixed + | Moveable, Fixed + | Fixed, Constant + | Fixed, Moveable + | Fixed, Fixed -> Fixed + +let primitive_moveable (prim : Lambda.primitive) + (args : Clambda.ulambda list) + (ident_info : ident_info) = + match prim, args with + | Pfield _, [Uconst (Uconst_ref (_, _))] -> + (* CR-someday mshinwell: Actually, maybe this shouldn't be needed; these + should have been simplified to [Read_symbol_field], which doesn't yield + a Clambda let. This might be fixed when Inline_and_simplify can + turn Pfield into Read_symbol_field. *) + (* Allow field access of symbols to be moveable. (The comment in + flambda.mli on [Read_symbol_field] may be helpful to the reader.) *) + Moveable + | Pfield _, [Uvar id] when Ident.Set.mem id ident_info.closure_environment -> + (* accesses to the function environment is coeffect free: this block + is never mutated *) + Moveable + | _ -> + match Semantics_of_primitives.for_primitive prim with + | No_effects, No_coeffects -> Moveable + | No_effects, Has_coeffects + | Only_generative_effects, No_coeffects + | Only_generative_effects, Has_coeffects + | Arbitrary_effects, No_coeffects + | Arbitrary_effects, Has_coeffects -> Fixed + +type moveable_for_env = Constant | Moveable + +(** Eliminate, through substitution, [let]-bindings of linear variables with + moveable defining expressions. *) +let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda) + : Clambda.ulambda * moveable = + match clam with + | Uvar id -> + begin match Ident.Map.find id env with + | Constant, def -> def, Constant + | Moveable, def -> def, Moveable + | exception Not_found -> + let moveable : moveable = + if Ident.Set.mem id ident_info.assigned then + Fixed + else + Moveable + in + clam, moveable + end + | Uconst _ -> + (* Constant closures are rewritten separately. *) + clam, Constant + | Udirect_apply (label, args, dbg) -> + let args = un_anf_list ident_info env args in + Udirect_apply (label, args, dbg), Fixed + | Ugeneric_apply (func, args, dbg) -> + let func = un_anf ident_info env func in + let args = un_anf_list ident_info env args in + Ugeneric_apply (func, args, dbg), Fixed + | Uclosure (functions, variables_bound_by_the_closure) -> + let functions = + List.map (fun (ufunction : Clambda.ufunction) -> + { ufunction with + body = un_anf ident_info env ufunction.body; + }) + functions + in + let variables_bound_by_the_closure = + un_anf_list ident_info env variables_bound_by_the_closure + in + Uclosure (functions, variables_bound_by_the_closure), Fixed + | Uoffset (clam, n) -> + let clam, moveable = un_anf_and_moveable ident_info env clam in + Uoffset (clam, n), both_moveable Moveable moveable + | Ulet (_let_kind, _value_kind, id, def, Uvar id') when Ident.same id id' -> + un_anf_and_moveable ident_info env def + | Ulet (let_kind, value_kind, id, def, body) -> + let def, def_moveable = un_anf_and_moveable ident_info env def in + let is_linear = Ident.Set.mem id ident_info.linear in + let is_used = Ident.Set.mem id ident_info.used in + let is_assigned = Ident.Set.mem id ident_info.assigned in + begin match def_moveable, is_linear, is_used, is_assigned with + | (Constant | Moveable), _, false, _ -> + (* A moveable expression that is never used may be eliminated. *) + un_anf_and_moveable ident_info env body + | Constant, _, true, false + (* A constant expression bound to an unassigned identifier can replace any + occurances of the identifier. *) + | Moveable, true, true, false -> + (* A moveable expression bound to a linear unassigned [Ident.t] + may replace the single occurrence of the identifier. *) + let def_moveable = + match def_moveable with + | Moveable -> Moveable + | Constant -> Constant + | Fixed -> assert false + in + let env = Ident.Map.add id (def_moveable, def) env in + un_anf_and_moveable ident_info env body + | (Constant | Moveable), _, _, true + (* Constant or Moveable but assigned. *) + | Moveable, false, _, _ + (* Moveable but not used linearly. *) + | Fixed, _, _, _ -> + let body, body_moveable = un_anf_and_moveable ident_info env body in + Ulet (let_kind, value_kind, id, def, body), + both_moveable def_moveable body_moveable + end + | Uletrec (defs, body) -> + let defs = + List.map (fun (id, def) -> id, un_anf ident_info env def) defs + in + let body = un_anf ident_info env body in + Uletrec (defs, body), Fixed + | Uprim (prim, args, dbg) -> + let args, args_moveable = un_anf_list_and_moveable ident_info env args in + let moveable = + both_moveable args_moveable (primitive_moveable prim args ident_info) + in + Uprim (prim, args, dbg), moveable + | Uswitch (cond, sw) -> + let cond = un_anf ident_info env cond in + let sw = + { sw with + us_actions_consts = un_anf_array ident_info env sw.us_actions_consts; + us_actions_blocks = un_anf_array ident_info env sw.us_actions_blocks; + } + in + Uswitch (cond, sw), Fixed + | Ustringswitch (cond, branches, default) -> + let cond = un_anf ident_info env cond in + let branches = + List.map (fun (s, branch) -> s, un_anf ident_info env branch) + branches + in + let default = Misc.may_map (un_anf ident_info env) default in + Ustringswitch (cond, branches, default), Fixed + | Ustaticfail (n, args) -> + let args = un_anf_list ident_info env args in + Ustaticfail (n, args), Fixed + | Ucatch (n, ids, body, handler) -> + let body = un_anf ident_info env body in + let handler = un_anf ident_info env handler in + Ucatch (n, ids, body, handler), Fixed + | Utrywith (body, id, handler) -> + let body = un_anf ident_info env body in + let handler = un_anf ident_info env handler in + Utrywith (body, id, handler), Fixed + | Uifthenelse (cond, ifso, ifnot) -> + let cond, cond_moveable = un_anf_and_moveable ident_info env cond in + let ifso, ifso_moveable = un_anf_and_moveable ident_info env ifso in + let ifnot, ifnot_moveable = un_anf_and_moveable ident_info env ifnot in + let moveable = + both_moveable cond_moveable + (both_moveable ifso_moveable ifnot_moveable) + in + Uifthenelse (cond, ifso, ifnot), moveable + | Usequence (e1, e2) -> + let e1 = un_anf ident_info env e1 in + let e2 = un_anf ident_info env e2 in + Usequence (e1, e2), Fixed + | Uwhile (cond, body) -> + let cond = un_anf ident_info env cond in + let body = un_anf ident_info env body in + Uwhile (cond, body), Fixed + | Ufor (id, low, high, direction, body) -> + let low = un_anf ident_info env low in + let high = un_anf ident_info env high in + let body = un_anf ident_info env body in + Ufor (id, low, high, direction, body), Fixed + | Uassign (id, expr) -> + let expr = un_anf ident_info env expr in + Uassign (id, expr), Fixed + | Usend (kind, e1, e2, args, dbg) -> + let e1 = un_anf ident_info env e1 in + let e2 = un_anf ident_info env e2 in + let args = un_anf_list ident_info env args in + Usend (kind, e1, e2, args, dbg), Fixed + | Uunreachable -> + Uunreachable, Fixed + +and un_anf ident_info env clam : Clambda.ulambda = + let clam, _moveable = un_anf_and_moveable ident_info env clam in + clam + +and un_anf_list_and_moveable ident_info env clams + : Clambda.ulambda list * moveable = + List.fold_right (fun clam (l, acc_moveable) -> + let clam, moveable = un_anf_and_moveable ident_info env clam in + clam :: l, both_moveable moveable acc_moveable) + clams ([], (Moveable : moveable)) + +and un_anf_list ident_info env clams : Clambda.ulambda list = + let clams, _moveable = un_anf_list_and_moveable ident_info env clams in + clams + +and un_anf_array ident_info env clams : Clambda.ulambda array = + Array.map (un_anf ident_info env) clams + +let apply clam ~what = + let ident_info = make_ident_info clam in + let let_bound_vars_that_can_be_moved = + let_bound_vars_that_can_be_moved ident_info clam + in + let clam = + substitute_let_moveable let_bound_vars_that_can_be_moved + Ident.Map.empty clam + in + let ident_info = make_ident_info clam in + let clam = un_anf ident_info Ident.Map.empty clam in + if !Clflags.dump_clambda then begin + Format.eprintf "@.un-anf (%s):@ %a@." what Printclambda.clambda clam + end; + clam diff -Nru ocaml-4.01.0/asmcomp/un_anf.mli ocaml-4.05.0/asmcomp/un_anf.mli --- ocaml-4.01.0/asmcomp/un_anf.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/un_anf.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Expand ANF-like constructs so that pattern matches in [Cmmgen] will + work correctly. *) +val apply + : Clambda.ulambda + -> what:string + -> Clambda.ulambda diff -Nru ocaml-4.01.0/asmcomp/x86_ast.mli ocaml-4.05.0/asmcomp/x86_ast.mli --- ocaml-4.01.0/asmcomp/x86_ast.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/x86_ast.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,219 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Structured representation of Intel assembly language (32 and 64 bit). *) + +type condition = + | L | GE (* signed comparisons: less/greater *) + | LE | G + | B | AE (* unsigned comparisons: below/above *) + | BE | A + | E | NE (* equal *) + | O | NO (* overflow *) + | S | NS (* sign *) + | P | NP (* parity *) + +type rounding = + | RoundUp + | RoundDown + | RoundNearest + | RoundTruncate + +type constant = + | Const of int64 + | ConstThis + | ConstLabel of string + | ConstAdd of constant * constant + | ConstSub of constant * constant + +(* data_type is used mainly on memory addressing to specify + the size of the addressed memory chunk. It is directly + used by the MASM emitter and indirectly by the GAS emitter + to infer the instruction suffix. *) + +type data_type = + | NONE + | REAL4 | REAL8 (* floating point values *) + | BYTE | WORD | DWORD | QWORD | OWORD (* integer values *) + | NEAR | PROC + +type reg64 = + | RAX | RBX | RCX | RDX | RSP | RBP | RSI | RDI + | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 + +type reg8h = + | AH | BH | CH | DH + + +type registerf = XMM of int | TOS | ST of int + +type arch = X64 | X86 + +type addr = + { + arch: arch; + typ: data_type; + idx: reg64; + scale: int; + base: reg64 option; + sym: string option; + displ: int; + } + (** Addressing modes: + displ + sym + base + idx * scale + (if scale = 0, idx is ignored and base must be None) + *) + +type arg = + | Imm of int64 + (** Operand is an immediate constant integer *) + + | Sym of string + (** Address of a symbol (absolute address except for call/jmp target + where it is interpreted as a relative displacement *) + + | Reg8L of reg64 + | Reg8H of reg8h + | Reg16 of reg64 + | Reg32 of reg64 + | Reg64 of reg64 + | Regf of registerf + + | Mem of addr + | Mem64_RIP of data_type * string * int + +type instruction = + | ADD of arg * arg + | ADDSD of arg * arg + | AND of arg * arg + | ANDPD of arg * arg + | BSWAP of arg + | CALL of arg + | CDQ + | CMOV of condition * arg * arg + | CMP of arg * arg + | COMISD of arg * arg + | CQO + | CVTSD2SI of arg * arg + | CVTSD2SS of arg * arg + | CVTSI2SD of arg * arg + | CVTSS2SD of arg * arg + | CVTTSD2SI of arg * arg + | DEC of arg + | DIVSD of arg * arg + | FABS + | FADD of arg + | FADDP of arg * arg + | FCHS + | FCOMP of arg + | FCOMPP + | FCOS + | FDIV of arg + | FDIVP of arg * arg + | FDIVR of arg + | FDIVRP of arg * arg + | FILD of arg + | FISTP of arg + | FLD of arg + | FLD1 + | FLDCW of arg + | FLDLG2 + | FLDLN2 + | FLDZ + | FMUL of arg + | FMULP of arg * arg + | FNSTCW of arg + | FNSTSW of arg + | FPATAN + | FPTAN + | FSIN + | FSQRT + | FSTP of arg + | FSUB of arg + | FSUBP of arg * arg + | FSUBR of arg + | FSUBRP of arg * arg + | FXCH of arg + | FYL2X + | HLT + | IDIV of arg + | IMUL of arg * arg option + | INC of arg + | J of condition * arg + | JMP of arg + | LEA of arg * arg + | LEAVE + | MOV of arg * arg + | MOVAPD of arg * arg + | MOVLPD of arg * arg + | MOVSD of arg * arg + | MOVSS of arg * arg + | MOVSX of arg * arg + | MOVSXD of arg * arg + | MOVZX of arg * arg + | MULSD of arg * arg + | NEG of arg + | NOP + | OR of arg * arg + | POP of arg + | PUSH of arg + | RET + | ROUNDSD of rounding * arg * arg + | SAL of arg * arg + | SAR of arg * arg + | SET of condition * arg + | SHR of arg * arg + | SQRTSD of arg * arg + | SUB of arg * arg + | SUBSD of arg * arg + | TEST of arg * arg + | UCOMISD of arg * arg + | XCHG of arg * arg + | XOR of arg * arg + | XORPD of arg * arg + +type asm_line = + | Ins of instruction + + | Align of bool * int + | Byte of constant + | Bytes of string + | Comment of string + | Global of string + | Long of constant + | NewLabel of string * data_type + | Quad of constant + | Section of string list * string option * string list + | Space of int + | Word of constant + + (* masm only (the gas emitter will fail on them) *) + | External of string * data_type + | Mode386 + | Model of string + + (* gas only (the masm emitter will fail on them) *) + | Cfi_adjust_cfa_offset of int + | Cfi_endproc + | Cfi_startproc + | File of int * string (* (file_num, file_name) *) + | Indirect_symbol of string + | Loc of int * int * int (* (file_num, line, col) *) + | Private_extern of string + | Set of string * constant + | Size of string * constant + | Type of string * string + +type asm_program = asm_line list diff -Nru ocaml-4.01.0/asmcomp/x86_dsl.ml ocaml-4.05.0/asmcomp/x86_dsl.ml --- ocaml-4.01.0/asmcomp/x86_dsl.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/x86_dsl.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,199 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, projet Gallium, 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Helpers for Intel code generators *) + +(* The DSL* modules expose functions to emit x86/x86_64 instructions + using a syntax close to AT&T (in particular, arguments are reversed compared + to the official Intel syntax). + + Some notes: + + - Unary floating point instructions such as fadd/fmul/fstp/fld/etc. + come with a single version supporting both the single and double + precision instructions. (As with Intel syntax.) + + - A legacy bug in GAS: + https://sourceware.org/binutils/docs-2.22/as/i386_002dBugs.html#i386_002dBugs + is not replicated here. It is managed by X86_gas. +*) + + +open X86_ast +open X86_proc + +let sym s = Sym s + +let nat n = Imm (Int64.of_nativeint n) +let int n = Imm (Int64.of_int n) + +let const_32 n = Const (Int64.of_int32 n) +let const_nat n = Const (Int64.of_nativeint n) +let const n = Const (Int64.of_int n) + +let al = Reg8L RAX +let ah = Reg8H AH +let cl = Reg8L RCX +let ax = Reg16 RAX +let rax = Reg64 RAX +let r10 = Reg64 R10 +let r11 = Reg64 R11 +let r13 = Reg64 R13 +let r14 = Reg64 R14 +let r15 = Reg64 R15 +let rsp = Reg64 RSP +let rbp = Reg64 RBP +let xmm15 = Regf (XMM 15) +let eax = Reg32 RAX +let ebx = Reg32 RBX +let ecx = Reg32 RCX +let edx = Reg32 RDX +let ebp = Reg32 RBP +let esp = Reg32 RSP +let st0 = Regf (ST 0) +let st1 = Regf (ST 1) + +let mem32 typ ?(scale = 1) ?base ?sym displ idx = + assert(scale >= 0); + Mem {arch = X86; typ; idx; scale; base; sym; displ} + +let mem64 typ ?(scale = 1) ?base ?sym displ idx = + assert(scale > 0); + Mem {arch = X64; typ; idx; scale; base; sym; displ} + +let mem64_rip typ ?(ofs = 0) s = + Mem64_RIP (typ, s, ofs) + +module D = struct + let section segment flags args = directive (Section (segment, flags, args)) + let align n = directive (Align (false, n)) + let byte n = directive (Byte n) + let bytes s = directive (Bytes s) + let cfi_adjust_cfa_offset n = directive (Cfi_adjust_cfa_offset n) + let cfi_endproc () = directive Cfi_endproc + let cfi_startproc () = directive Cfi_startproc + let comment s = directive (Comment s) + let data () = section [ ".data" ] None [] + let extrn s ptr = directive (External (s, ptr)) + let file ~file_num ~file_name = directive (File (file_num, file_name)) + let global s = directive (Global s) + let indirect_symbol s = directive (Indirect_symbol s) + let label ?(typ = NONE) s = directive (NewLabel (s, typ)) + let loc ~file_num ~line ~col = directive (Loc (file_num, line, col)) + let long cst = directive (Long cst) + let mode386 () = directive Mode386 + let model name = directive (Model name) + let private_extern s = directive (Private_extern s) + let qword cst = directive (Quad cst) + let setvar (x, y) = directive (Set (x, y)) + let size name cst = directive (Size (name, cst)) + let space n = directive (Space n) + let text () = section [ ".text" ] None [] + let type_ name typ = directive (Type (name, typ)) + let word cst = directive (Word cst) +end + +module I = struct + let add x y = emit (ADD (x, y)) + let addsd x y = emit (ADDSD (x, y)) + let and_ x y= emit (AND (x, y)) + let andpd x y = emit (ANDPD (x, y)) + let bswap x = emit (BSWAP x) + let call x = emit (CALL x) + let cdq () = emit CDQ + let cmp x y = emit (CMP (x, y)) + let comisd x y = emit (COMISD (x, y)) + let cqo () = emit CQO + let cvtsd2ss x y = emit (CVTSD2SS (x, y)) + let cvtsi2sd x y = emit (CVTSI2SD (x, y)) + let cvtss2sd x y = emit (CVTSS2SD (x, y)) + let cvttsd2si x y = emit (CVTTSD2SI (x, y)) + let dec x = emit (DEC x) + let divsd x y = emit (DIVSD (x, y)) + let fabs () = emit FABS + let fadd x = emit (FADD x) + let faddp x y = emit (FADDP (x, y)) + let fchs () = emit FCHS + let fcomp x = emit (FCOMP x) + let fcompp () = emit FCOMPP + let fcos () = emit FCOS + let fdiv x = emit (FDIV x) + let fdivp x y = emit (FDIVP (x, y)) + let fdivr x = emit (FDIVR x) + let fdivrp x y = emit (FDIVRP (x, y)) + let fild x = emit (FILD x) + let fistp x = emit (FISTP x) + let fld x = emit (FLD x) + let fld1 () = emit FLD1 + let fldcw x = emit (FLDCW x) + let fldlg2 () = emit FLDLG2 + let fldln2 () = emit FLDLN2 + let fldz () = emit FLDZ + let fmul x = emit (FMUL x) + let fmulp x y = emit (FMULP (x, y)) + let fnstcw x = emit (FNSTCW x) + let fnstsw x = emit (FNSTSW x) + let fpatan () = emit FPATAN + let fptan () = emit FPTAN + let fsin () = emit FSIN + let fsqrt () = emit FSQRT + let fstp x = emit (FSTP x) + let fsub x = emit (FSUB x) + let fsubp x y = emit (FSUBP (x, y)) + let fsubr x = emit (FSUBR x) + let fsubrp x y = emit (FSUBRP (x, y)) + let fxch x = emit (FXCH x) + let fyl2x () = emit FYL2X + let hlt () = emit HLT + let idiv x = emit (IDIV x) + let imul x y = emit (IMUL (x, y)) + let inc x = emit (INC x) + let j cond x = emit (J (cond, x)) + let ja = j A + let jae = j AE + let jb = j B + let jbe = j BE + let je = j E + let jg = j G + let jmp x = emit (JMP x) + let jne = j NE + let jp = j P + let lea x y = emit (LEA (x, y)) + let mov x y = emit (MOV (x, y)) + let movapd x y = emit (MOVAPD (x, y)) + let movsd x y = emit (MOVSD (x, y)) + let movss x y = emit (MOVSS (x, y)) + let movsx x y = emit (MOVSX (x, y)) + let movsxd x y = emit (MOVSXD (x, y)) + let movzx x y = emit (MOVZX (x, y)) + let mulsd x y = emit (MULSD (x, y)) + let nop () = emit NOP + let or_ x y = emit (OR (x, y)) + let pop x = emit (POP x) + let push x = emit (PUSH x) + let ret () = emit RET + let sal x y = emit (SAL (x, y)) + let sar x y = emit (SAR (x, y)) + let set cond x = emit (SET (cond, x)) + let shr x y = emit (SHR (x, y)) + let sqrtsd x y = emit (SQRTSD (x, y)) + let sub x y = emit (SUB (x, y)) + let subsd x y = emit (SUBSD (x, y)) + let test x y= emit (TEST (x, y)) + let ucomisd x y = emit (UCOMISD (x, y)) + let xchg x y = emit (XCHG (x, y)) + let xor x y= emit (XOR (x, y)) + let xorpd x y = emit (XORPD (x, y)) +end diff -Nru ocaml-4.01.0/asmcomp/x86_dsl.mli ocaml-4.05.0/asmcomp/x86_dsl.mli --- ocaml-4.01.0/asmcomp/x86_dsl.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/x86_dsl.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,192 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Helpers for Intel code generators *) + +(* The DSL* modules expose functions to emit x86/x86_64 instructions + using a syntax close to the official Intel syntax, except that + source and destination operands are reversed as in the AT&T + syntax: + + mov src dst +*) + + +open X86_ast + +val sym: string -> arg +val nat: nativeint -> arg +val int: int -> arg +val const_32: int32 -> constant +val const_nat: nativeint -> constant +val const: int -> constant +val al: arg +val ah: arg +val cl: arg +val ax: arg +val rax: arg +val r10: arg +val r11: arg +val r13: arg +val r14: arg +val r15: arg +val rsp: arg +val rbp: arg +val xmm15: arg +val eax: arg +val ebx: arg +val ecx: arg +val edx: arg +val ebp: arg +val esp: arg +val st0: arg +val st1: arg + +val mem32: + data_type -> ?scale:int -> ?base:reg64 -> ?sym:string -> + int -> reg64 -> arg + +val mem64: + data_type -> ?scale:int -> ?base:reg64 -> ?sym:string -> + int -> reg64 -> arg + +val mem64_rip: data_type -> ?ofs:int -> string -> arg + + +module D : sig + (** Directives *) + + val align: int -> unit + val byte: constant -> unit + val bytes: string -> unit + val cfi_adjust_cfa_offset: int -> unit + val cfi_endproc: unit -> unit + val cfi_startproc: unit -> unit + val comment: string -> unit + val data: unit -> unit + val extrn: string -> data_type -> unit + val file: file_num:int -> file_name:string -> unit + val global: string -> unit + val indirect_symbol: string -> unit + val label: ?typ:data_type -> string -> unit + val loc: file_num:int -> line:int -> col:int -> unit + val long: constant -> unit + val mode386: unit -> unit + val model: string -> unit + val private_extern: string -> unit + val qword: constant -> unit + val section: string list -> string option -> string list -> unit + val setvar: string * constant -> unit + val size: string -> constant -> unit + val space: int -> unit + val text: unit -> unit + val type_: string -> string -> unit + val word: constant -> unit +end + +module I : sig + (* Instructions *) + + val add: arg -> arg -> unit + val addsd: arg -> arg -> unit + val and_: arg -> arg -> unit + val andpd: arg -> arg -> unit + val bswap: arg -> unit + val call: arg -> unit + val cdq: unit -> unit + val cmp: arg -> arg -> unit + val comisd: arg -> arg -> unit + val cqo: unit -> unit + val cvtsd2ss: arg -> arg -> unit + val cvtsi2sd: arg -> arg -> unit + val cvtss2sd: arg -> arg -> unit + val cvttsd2si: arg -> arg -> unit + val dec: arg -> unit + val divsd: arg -> arg -> unit + val fabs: unit -> unit + val fadd: arg -> unit + val faddp: arg -> arg -> unit + val fchs: unit -> unit + val fcomp: arg -> unit + val fcompp: unit -> unit + val fcos: unit -> unit + val fdiv: arg -> unit + val fdivp: arg -> arg -> unit + val fdivr: arg -> unit + val fdivrp: arg -> arg -> unit + val fild: arg -> unit + val fistp: arg -> unit + val fld1: unit -> unit + val fld: arg -> unit + val fldcw: arg -> unit + val fldlg2: unit -> unit + val fldln2: unit -> unit + val fldz: unit -> unit + val fmul: arg -> unit + val fmulp: arg -> arg -> unit + val fnstcw: arg -> unit + val fnstsw: arg -> unit + val fpatan: unit -> unit + val fptan: unit -> unit + val fsin: unit -> unit + val fsqrt: unit -> unit + val fstp: arg -> unit + val fsub: arg -> unit + val fsubp: arg -> arg -> unit + val fsubr: arg -> unit + val fsubrp: arg -> arg -> unit + val fxch: arg -> unit + val fyl2x: unit -> unit + val hlt: unit -> unit + val idiv: arg -> unit + val imul: arg -> arg option -> unit + val inc: arg -> unit + val j: condition -> arg -> unit + val ja: arg -> unit + val jae: arg -> unit + val jb: arg -> unit + val jbe: arg -> unit + val je: arg -> unit + val jg: arg -> unit + val jmp: arg -> unit + val jne: arg -> unit + val jp: arg -> unit + val lea: arg -> arg -> unit + val mov: arg -> arg -> unit + val movapd: arg -> arg -> unit + val movsd: arg -> arg -> unit + val movss: arg -> arg -> unit + val movsx: arg -> arg -> unit + val movsxd: arg -> arg -> unit + val movzx: arg -> arg -> unit + val mulsd: arg -> arg -> unit + val nop: unit -> unit + val or_: arg -> arg -> unit + val pop: arg -> unit + val push: arg -> unit + val ret: unit -> unit + val sal: arg -> arg -> unit + val sar: arg -> arg -> unit + val set: condition -> arg -> unit + val shr: arg -> arg -> unit + val sqrtsd: arg -> arg -> unit + val sub: arg -> arg -> unit + val subsd: arg -> arg -> unit + val test: arg -> arg -> unit + val ucomisd: arg -> arg -> unit + val xchg: arg -> arg -> unit + val xor: arg -> arg -> unit + val xorpd: arg -> arg -> unit +end diff -Nru ocaml-4.01.0/asmcomp/x86_gas.ml ocaml-4.05.0/asmcomp/x86_gas.ml --- ocaml-4.01.0/asmcomp/x86_gas.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/x86_gas.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,311 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open X86_ast +open X86_proc + +let bprintf = Printf.bprintf + +let print_reg b f r = + Buffer.add_char b '%'; + Buffer.add_string b (f r) + +let opt_displ b displ = + if displ = 0 then () + else if displ > 0 then bprintf b "+%d" displ + else bprintf b "%d" displ + +let arg_mem b {arch; typ=_; idx; scale; base; sym; displ} = + let string_of_register = + match arch with + | X86 -> string_of_reg32 + | X64 -> string_of_reg64 + in + begin match sym with + | None -> + if displ <> 0 || scale = 0 then + Buffer.add_string b (string_of_int displ) + | Some s -> + Buffer.add_string b s; + opt_displ b displ + end; + if scale <> 0 then begin + Buffer.add_char b '('; + begin match base with + | None -> () + | Some base -> print_reg b string_of_register base + end; + if base != None || scale <> 1 then Buffer.add_char b ','; + print_reg b string_of_register idx; + if scale <> 1 then bprintf b ",%s" (string_of_int scale); + Buffer.add_char b ')' + end + +let arg b = function + | Sym x -> Buffer.add_char b '$'; Buffer.add_string b x + | Imm x -> bprintf b "$%Ld" x + | Reg8L x -> print_reg b string_of_reg8l x + | Reg8H x -> print_reg b string_of_reg8h x + | Reg16 x -> print_reg b string_of_reg16 x + | Reg32 x -> print_reg b string_of_reg32 x + | Reg64 x -> print_reg b string_of_reg64 x + | Regf x -> print_reg b string_of_registerf x + | Mem addr -> arg_mem b addr + | Mem64_RIP (_, s, displ) -> bprintf b "%s%a(%%rip)" s opt_displ displ + +let rec cst b = function + | ConstLabel _ | Const _ | ConstThis as c -> scst b c + | ConstAdd (c1, c2) -> bprintf b "%a + %a" scst c1 scst c2 + | ConstSub (c1, c2) -> bprintf b "%a - %a" scst c1 scst c2 + +and scst b = function + | ConstThis -> Buffer.add_string b "." + | ConstLabel l -> Buffer.add_string b l + | Const n when n <= 0x7FFF_FFFFL && n >= -0x8000_0000L -> + Buffer.add_string b (Int64.to_string n) + | Const n -> bprintf b "0x%Lx" n + | ConstAdd (c1, c2) -> bprintf b "(%a + %a)" scst c1 scst c2 + | ConstSub (c1, c2) -> bprintf b "(%a - %a)" scst c1 scst c2 + +let typeof = function + | Mem {typ; _} | Mem64_RIP (typ, _, _) -> typ + | Reg8L _ | Reg8H _ -> BYTE + | Reg16 _ -> WORD + | Reg32 _ -> DWORD + | Reg64 _ -> QWORD + | Imm _ | Sym _ -> NONE + | Regf _ -> assert false + +let suf arg = + match typeof arg with + | BYTE -> "b" + | WORD -> "w" + | DWORD | REAL8 -> "l" + | QWORD -> "q" + | REAL4 -> "s" + | NONE -> "" + | OWORD | NEAR | PROC -> assert false + +let i0 b s = bprintf b "\t%s" s +let i1 b s x = bprintf b "\t%s\t%a" s arg x +let i1_s b s x = bprintf b "\t%s%s\t%a" s (suf x) arg x +let i2 b s x y = bprintf b "\t%s\t%a, %a" s arg x arg y +let i2_s b s x y = bprintf b "\t%s%s\t%a, %a" s (suf y) arg x arg y +let i2_ss b s x y = bprintf b "\t%s%s%s\t%a, %a" s (suf x) (suf y) arg x arg y + +let i1_call_jmp b s = function + (* this is the encoding of jump labels: don't use * *) + | Mem {arch=X86; idx=_; scale=0; base=None; sym=Some _; _} as x -> + i1 b s x + | Reg32 _ | Reg64 _ | Mem _ | Mem64_RIP _ as x -> + bprintf b "\t%s\t*%a" s arg x + | Sym x -> bprintf b "\t%s\t%s" s x + | _ -> assert false + +let print_instr b = function + | ADD (arg1, arg2) -> i2_s b "add" arg1 arg2 + | ADDSD (arg1, arg2) -> i2 b "addsd" arg1 arg2 + | AND (arg1, arg2) -> i2_s b "and" arg1 arg2 + | ANDPD (arg1, arg2) -> i2 b "andpd" arg1 arg2 + | BSWAP arg -> i1 b "bswap" arg + | CALL arg -> i1_call_jmp b "call" arg + | CDQ -> i0 b "cltd" + | CMOV (c, arg1, arg2) -> i2 b ("cmov" ^ string_of_condition c) arg1 arg2 + | CMP (arg1, arg2) -> i2_s b "cmp" arg1 arg2 + | COMISD (arg1, arg2) -> i2 b "comisd" arg1 arg2 + | CQO -> i0 b "cqto" + | CVTSD2SI (arg1, arg2) -> i2 b "cvtsd2si" arg1 arg2 + | CVTSD2SS (arg1, arg2) -> i2 b "cvtsd2ss" arg1 arg2 + | CVTSI2SD (arg1, arg2) -> i2 b ("cvtsi2sd" ^ suf arg1) arg1 arg2 + | CVTSS2SD (arg1, arg2) -> i2 b "cvtss2sd" arg1 arg2 + | CVTTSD2SI (arg1, arg2) -> i2_s b "cvttsd2si" arg1 arg2 + | DEC arg -> i1_s b "dec" arg + | DIVSD (arg1, arg2) -> i2 b "divsd" arg1 arg2 + | FABS -> i0 b "fabs" + | FADD arg -> i1_s b "fadd" arg + | FADDP (arg1, arg2) -> i2 b "faddp" arg1 arg2 + | FCHS -> i0 b "fchs" + | FCOMP arg -> i1_s b "fcomp" arg + | FCOMPP -> i0 b "fcompp" + | FCOS -> i0 b "fcos" + | FDIV arg -> i1_s b "fdiv" arg + | FDIVP (Regf (ST 0), arg2) -> i2 b "fdivrp" (Regf (ST 0)) arg2 (* bug *) + | FDIVP (arg1, arg2) -> i2 b "fdivp" arg1 arg2 + | FDIVR arg -> i1_s b "fdivr" arg + | FDIVRP (Regf (ST 0), arg2) -> i2 b "fdivp" (Regf (ST 0)) arg2 (* bug *) + | FDIVRP (arg1, arg2) -> i2 b "fdivrp" arg1 arg2 + | FILD arg -> i1_s b "fild" arg + | FISTP arg -> i1_s b "fistp" arg + | FLD (Mem {typ=REAL4; _} as arg) -> i1 b "flds" arg + | FLD arg -> i1 b "fldl" arg + | FLD1 -> i0 b "fld1" + | FLDCW arg -> i1 b "fldcw" arg + | FLDLG2 -> i0 b "fldlg2" + | FLDLN2 -> i0 b "fldln2" + | FLDZ -> i0 b "fldz" + | FMUL arg -> i1_s b "fmul" arg + | FMULP (arg1, arg2) -> i2 b "fmulp" arg1 arg2 + | FNSTCW arg -> i1 b "fnstcw" arg + | FNSTSW arg -> i1 b "fnstsw" arg + | FPATAN -> i0 b "fpatan" + | FPTAN -> i0 b "fptan" + | FSIN -> i0 b "fsin" + | FSQRT -> i0 b "fsqrt" + | FSTP (Mem {typ=REAL4; _} as arg) -> i1 b "fstps" arg + | FSTP arg -> i1 b "fstpl" arg + | FSUB arg -> i1_s b "fsub" arg + | FSUBP (Regf (ST 0), arg2) -> i2 b "fsubrp" (Regf (ST 0)) arg2 (* bug *) + | FSUBP (arg1, arg2) -> i2 b "fsubp" arg1 arg2 + | FSUBR arg -> i1_s b "fsubr" arg + | FSUBRP (Regf (ST 0), arg2) -> i2 b "fsubp" (Regf (ST 0)) arg2 (* bug *) + | FSUBRP (arg1, arg2) -> i2 b "fsubrp" arg1 arg2 + | FXCH arg -> i1 b "fxch" arg + | FYL2X -> i0 b "fyl2x" + | HLT -> i0 b "hlt" + | IDIV arg -> i1_s b "idiv" arg + | IMUL (arg, None) -> i1_s b "imul" arg + | IMUL (arg1, Some arg2) -> i2_s b "imul" arg1 arg2 + | INC arg -> i1_s b "inc" arg + | J (c, arg) -> i1_call_jmp b ("j" ^ string_of_condition c) arg + | JMP arg -> i1_call_jmp b "jmp" arg + | LEA (arg1, arg2) -> i2_s b "lea" arg1 arg2 + | LEAVE -> i0 b "leave" + | MOV ((Imm n as arg1), (Reg64 _ as arg2)) + when not (n <= 0x7FFF_FFFFL && n >= -0x8000_0000L) -> + i2 b "movabsq" arg1 arg2 + | MOV ((Sym _ as arg1), (Reg64 _ as arg2)) when windows -> + i2 b "movabsq" arg1 arg2 + | MOV (arg1, arg2) -> i2_s b "mov" arg1 arg2 + | MOVAPD (arg1, arg2) -> i2 b "movapd" arg1 arg2 + | MOVLPD (arg1, arg2) -> i2 b "movlpd" arg1 arg2 + | MOVSD (arg1, arg2) -> i2 b "movsd" arg1 arg2 + | MOVSS (arg1, arg2) -> i2 b "movss" arg1 arg2 + | MOVSX (arg1, arg2) -> i2_ss b "movs" arg1 arg2 + | MOVSXD (arg1, arg2) -> i2 b "movslq" arg1 arg2 + | MOVZX (arg1, arg2) -> i2_ss b "movz" arg1 arg2 + | MULSD (arg1, arg2) -> i2 b "mulsd" arg1 arg2 + | NEG arg -> i1 b "neg" arg + | NOP -> i0 b "nop" + | OR (arg1, arg2) -> i2_s b "or" arg1 arg2 + | POP arg -> i1_s b "pop" arg + | PUSH arg -> i1_s b "push" arg + | RET -> i0 b "ret" + | ROUNDSD (r, arg1, arg2) -> i2 b (string_of_rounding r) arg1 arg2 + | SAL (arg1, arg2) -> i2_s b "sal" arg1 arg2 + | SAR (arg1, arg2) -> i2_s b "sar" arg1 arg2 + | SET (c, arg) -> i1 b ("set" ^ string_of_condition c) arg + | SHR (arg1, arg2) -> i2_s b "shr" arg1 arg2 + | SQRTSD (arg1, arg2) -> i2 b "sqrtsd" arg1 arg2 + | SUB (arg1, arg2) -> i2_s b "sub" arg1 arg2 + | SUBSD (arg1, arg2) -> i2 b "subsd" arg1 arg2 + | TEST (arg1, arg2) -> i2_s b "test" arg1 arg2 + | UCOMISD (arg1, arg2) -> i2 b "ucomisd" arg1 arg2 + | XCHG (arg1, arg2) -> i2 b "xchg" arg1 arg2 + | XOR (arg1, arg2) -> i2_s b "xor" arg1 arg2 + | XORPD (arg1, arg2) -> i2 b "xorpd" arg1 arg2 + +(* bug: + https://sourceware.org/binutils/docs-2.22/as/i386_002dBugs.html#i386_002dBugs + + The AT&T syntax has a bug for fsub/fdiv/fsubr/fdivr instructions when + the source register is %st and the destination is %st(i). In those + case, AT&T use fsub (resp. fsubr) in place of fsubr (resp. fsub), + and idem for fdiv/fdivr. + + Concretely, AT&T syntax interpretation of: + + fsub %st, %st(3) + + should normally be: + + %st(3) := %st(3) - %st + + but it should actually be interpreted as: + + %st(3) := %st - %st(3) + + which means the FSUBR instruction should be used. +*) + + +let print_line b = function + | Ins instr -> print_instr b instr + + | Align (_data,n) -> + (* MacOSX assembler interprets the integer n as a 2^n alignment *) + let n = if system = S_macosx then Misc.log2 n else n in + bprintf b "\t.align\t%d" n + | Byte n -> bprintf b "\t.byte\t%a" cst n + | Bytes s -> + if system = S_solaris then buf_bytes_directive b ".byte" s + else bprintf b "\t.ascii\t\"%s\"" (string_of_string_literal s) + | Comment s -> bprintf b "\t\t\t\t/* %s */" s + | Global s -> bprintf b "\t.globl\t%s" s; + | Long n -> bprintf b "\t.long\t%a" cst n + | NewLabel (s, _) -> bprintf b "%s:" s + | Quad n -> bprintf b "\t.quad\t%a" cst n + | Section ([".data" ], _, _) -> bprintf b "\t.data" + | Section ([".text" ], _, _) -> bprintf b "\t.text" + | Section (name, flags, args) -> + bprintf b "\t.section %s" (String.concat "," name); + begin match flags with + | None -> () + | Some flags -> bprintf b ",%S" flags + end; + begin match args with + | [] -> () + | _ -> bprintf b ",%s" (String.concat "," args) + end + | Space n -> + if system = S_solaris then bprintf b "\t.zero\t%d" n + else bprintf b "\t.space\t%d" n + | Word n -> + if system = S_solaris then bprintf b "\t.value\t%a" cst n + else bprintf b "\t.word\t%a" cst n + + (* gas only *) + | Cfi_adjust_cfa_offset n -> bprintf b "\t.cfi_adjust_cfa_offset %d" n + | Cfi_endproc -> bprintf b "\t.cfi_endproc" + | Cfi_startproc -> bprintf b "\t.cfi_startproc" + | File (file_num, file_name) -> + bprintf b "\t.file\t%d\t\"%s\"" + file_num (X86_proc.string_of_string_literal file_name) + | Indirect_symbol s -> bprintf b "\t.indirect_symbol %s" s + | Loc (file_num, line, col) -> + (* PR#7726: Location.none uses column -1, breaks LLVM assembler *) + if col >= 0 then bprintf b "\t.loc\t%d\t%d\t%d" file_num line col + else bprintf b "\t.loc\t%d\t%d" file_num line + | Private_extern s -> bprintf b "\t.private_extern %s" s + | Set (arg1, arg2) -> bprintf b "\t.set %s, %a" arg1 cst arg2 + | Size (s, c) -> bprintf b "\t.size %s,%a" s cst c + | Type (s, typ) -> bprintf b "\t.type %s,%s" s typ + + (* masm only *) + | External _ + | Mode386 + | Model _ + -> assert false + +let generate_asm oc lines = + let b = Buffer.create 10000 in + output_string oc "\t.file \"\"\n"; (* PR#7037 *) + List.iter + (fun i -> + Buffer.clear b; + print_line b i; + Buffer.add_char b '\n'; + Buffer.output_buffer oc b; + ) + lines diff -Nru ocaml-4.01.0/asmcomp/x86_gas.mli ocaml-4.05.0/asmcomp/x86_gas.mli --- ocaml-4.01.0/asmcomp/x86_gas.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/x86_gas.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Emit assembly instructions for gas. *) + +val generate_asm: out_channel -> X86_ast.asm_line list -> unit diff -Nru ocaml-4.01.0/asmcomp/x86_masm.ml ocaml-4.05.0/asmcomp/x86_masm.ml --- ocaml-4.01.0/asmcomp/x86_masm.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/x86_masm.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,261 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open X86_ast +open X86_proc + +let bprintf = Printf.bprintf + +let string_of_datatype = function + | QWORD -> "QWORD" + | OWORD -> "OWORD" + | NONE -> assert false + | REAL4 -> "REAL4" + | REAL8 -> "REAL8" + | BYTE -> "BYTE" + | WORD -> "WORD" + | DWORD -> "DWORD" + | NEAR -> "NEAR" + | PROC -> "PROC" + + +let string_of_datatype_ptr = function + | QWORD -> "QWORD PTR " + | OWORD -> "OWORD PTR " + | NONE -> "" + | REAL4 -> "REAL4 PTR " + | REAL8 -> "REAL8 PTR " + | BYTE -> "BYTE PTR " + | WORD -> "WORD PTR " + | DWORD -> "DWORD PTR " + | NEAR -> "NEAR PTR " + | PROC -> "PROC PTR " + +let arg_mem b {arch; typ; idx; scale; base; sym; displ} = + let string_of_register = + match arch with + | X86 -> string_of_reg32 + | X64 -> string_of_reg64 + in + Buffer.add_string b (string_of_datatype_ptr typ); + Buffer.add_char b '['; + begin match sym with + | None -> () + | Some s -> Buffer.add_string b s + end; + if scale <> 0 then begin + if sym <> None then Buffer.add_char b '+'; + Buffer.add_string b (string_of_register idx); + if scale <> 1 then bprintf b "*%d" scale; + end; + begin match base with + | None -> () + | Some r -> + assert(scale > 0); + Buffer.add_char b '+'; + Buffer.add_string b (string_of_register r); + end; + begin if displ > 0 then bprintf b "+%d" displ + else if displ < 0 then bprintf b "%d" displ + end; + Buffer.add_char b ']' + +let arg b = function + | Sym s -> bprintf b "OFFSET %s" s + | Imm n when n <= 0x7FFF_FFFFL && n >= -0x8000_0000L -> bprintf b "%Ld" n + | Imm int -> bprintf b "0%LxH" int (* force ml64 to use mov reg, imm64 *) + | Reg8L x -> Buffer.add_string b (string_of_reg8l x) + | Reg8H x -> Buffer.add_string b (string_of_reg8h x) + | Reg16 x -> Buffer.add_string b (string_of_reg16 x) + | Reg32 x -> Buffer.add_string b (string_of_reg32 x) + | Reg64 x -> Buffer.add_string b (string_of_reg64 x) + | Regf x -> Buffer.add_string b (string_of_registerf x) + + (* We don't need to specify RIP on Win64, since EXTERN will provide + the list of external symbols that need this addressing mode, and + MASM will automatically use RIP addressing when needed. *) + | Mem64_RIP (typ, s, displ) -> + bprintf b "%s%s" (string_of_datatype_ptr typ) s; + if displ > 0 then bprintf b "+%d" displ + else if displ < 0 then bprintf b "%d" displ + | Mem addr -> arg_mem b addr + +let rec cst b = function + | ConstLabel _ | Const _ | ConstThis as c -> scst b c + | ConstAdd (c1, c2) -> bprintf b "%a + %a" scst c1 scst c2 + | ConstSub (c1, c2) -> bprintf b "%a - %a" scst c1 scst c2 + +and scst b = function + | ConstThis -> Buffer.add_string b "THIS BYTE" + | ConstLabel l -> Buffer.add_string b l + | Const n when n <= 0x7FFF_FFFFL && n >= -0x8000_0000L -> + Buffer.add_string b (Int64.to_string n) + | Const n -> bprintf b "0%LxH" n + | ConstAdd (c1, c2) -> bprintf b "(%a + %a)" scst c1 scst c2 + | ConstSub (c1, c2) -> bprintf b "(%a - %a)" scst c1 scst c2 + +let i0 b s = bprintf b "\t%s" s +let i1 b s x = bprintf b "\t%s\t%a" s arg x +let i2 b s x y = bprintf b "\t%s\t%a, %a" s arg y arg x + +let i1_call_jmp b s = function + | Sym x -> bprintf b "\t%s\t%s" s x + | x -> i1 b s x + +let print_instr b = function + | ADD (arg1, arg2) -> i2 b "add" arg1 arg2 + | ADDSD (arg1, arg2) -> i2 b "addsd" arg1 arg2 + | AND (arg1, arg2) -> i2 b "and" arg1 arg2 + | ANDPD (arg1, arg2) -> i2 b "andpd" arg1 arg2 + | BSWAP arg -> i1 b "bswap" arg + | CALL arg -> i1_call_jmp b "call" arg + | CDQ -> i0 b "cdq" + | CMOV (c, arg1, arg2) -> i2 b ("cmov" ^ string_of_condition c) arg1 arg2 + | CMP (arg1, arg2) -> i2 b "cmp" arg1 arg2 + | COMISD (arg1, arg2) -> i2 b "comisd" arg1 arg2 + | CQO -> i0 b "cqo" + | CVTSD2SI (arg1, arg2) -> i2 b "cvtsd2si" arg1 arg2 + | CVTSD2SS (arg1, arg2) -> i2 b "cvtsd2ss" arg1 arg2 + | CVTSI2SD (arg1, arg2) -> i2 b "cvtsi2sd" arg1 arg2 + | CVTSS2SD (arg1, arg2) -> i2 b "cvtss2sd" arg1 arg2 + | CVTTSD2SI (arg1, arg2) -> i2 b "cvttsd2si" arg1 arg2 + | DEC arg -> i1 b "dec" arg + | DIVSD (arg1, arg2) -> i2 b "divsd" arg1 arg2 + | FABS -> i0 b "fabs" + | FADD arg -> i1 b "fadd" arg + | FADDP (arg1, arg2) -> i2 b "faddp" arg1 arg2 + | FCHS -> i0 b "fchs" + | FCOMP arg -> i1 b "fcomp" arg + | FCOMPP -> i0 b "fcompp" + | FCOS -> i0 b "fcos" + | FDIV arg -> i1 b "fdiv" arg + | FDIVP (arg1, arg2) -> i2 b "fdivp" arg1 arg2 + | FDIVR arg -> i1 b "fdivr" arg + | FDIVRP (arg1, arg2) -> i2 b "fdivrp" arg1 arg2 + | FILD arg -> i1 b "fild" arg + | FISTP arg -> i1 b "fistp" arg + | FLD arg -> i1 b "fld" arg + | FLD1 -> i0 b "fld1" + | FLDCW arg -> i1 b "fldcw" arg + | FLDLG2 -> i0 b "fldlg2" + | FLDLN2 -> i0 b "fldln2" + | FLDZ -> i0 b "fldz" + | FMUL arg -> i1 b "fmul" arg + | FMULP (arg1, arg2) -> i2 b "fmulp" arg1 arg2 + | FNSTCW arg -> i1 b "fnstcw" arg + | FNSTSW arg -> i1 b "fnstsw" arg + | FPATAN -> i0 b "fpatan" + | FPTAN -> i0 b "fptan" + | FSIN -> i0 b "fsin" + | FSQRT -> i0 b "fsqrt" + | FSTP arg -> i1 b "fstp" arg + | FSUB arg -> i1 b "fsub" arg + | FSUBP (arg1, arg2) -> i2 b "fsubp" arg1 arg2 + | FSUBR arg -> i1 b "fsubr" arg + | FSUBRP (arg1, arg2) -> i2 b "fsubrp" arg1 arg2 + | FXCH arg -> i1 b "fxch" arg + | FYL2X -> i0 b "fyl2x" + | HLT -> assert false + | IDIV arg -> i1 b "idiv" arg + | IMUL (arg, None) -> i1 b "imul" arg + | IMUL (arg1, Some arg2) -> i2 b "imul" arg1 arg2 + | INC arg -> i1 b "inc" arg + | J (c, arg) -> i1_call_jmp b ("j" ^ string_of_condition c) arg + | JMP arg -> i1_call_jmp b "jmp" arg + | LEA (arg1, arg2) -> i2 b "lea" arg1 arg2 + | LEAVE -> i0 b "leave" + | MOV (Imm n as arg1, Reg64 r) when + n >= 0x8000_0000L && n <= 0xFFFF_FFFFL -> + (* Work-around a bug in ml64. Use a mov to the corresponding + 32-bit lower register when the constant fits in 32-bit. + The associated higher 32-bit register will be zeroed. *) + i2 b "mov" arg1 (Reg32 r) + | MOV (arg1, arg2) -> i2 b "mov" arg1 arg2 + | MOVAPD (arg1, arg2) -> i2 b "movapd" arg1 arg2 + | MOVLPD (arg1, arg2) -> i2 b "movlpd" arg1 arg2 + | MOVSD (arg1, arg2) -> i2 b "movsd" arg1 arg2 + | MOVSS (arg1, arg2) -> i2 b "movss" arg1 arg2 + | MOVSX (arg1, arg2) -> i2 b "movsx" arg1 arg2 + | MOVSXD (arg1, arg2) -> i2 b "movsxd" arg1 arg2 + | MOVZX (arg1, arg2) -> i2 b "movzx" arg1 arg2 + | MULSD (arg1, arg2) -> i2 b "mulsd" arg1 arg2 + | NEG arg -> i1 b "neg" arg + | NOP -> i0 b "nop" + | OR (arg1, arg2) -> i2 b "or" arg1 arg2 + | POP arg -> i1 b "pop" arg + | PUSH arg -> i1 b "push" arg + | RET -> i0 b "ret" + | ROUNDSD (r, arg1, arg2) -> i2 b (string_of_rounding r) arg1 arg2 + | SAL (arg1, arg2) -> i2 b "sal" arg1 arg2 + | SAR (arg1, arg2) -> i2 b "sar" arg1 arg2 + | SET (c, arg) -> i1 b ("set" ^ string_of_condition c) arg + | SHR (arg1, arg2) -> i2 b "shr" arg1 arg2 + | SQRTSD (arg1, arg2) -> i2 b "sqrtsd" arg1 arg2 + | SUB (arg1, arg2) -> i2 b "sub" arg1 arg2 + | SUBSD (arg1, arg2) -> i2 b "subsd" arg1 arg2 + | TEST (arg1, arg2) -> i2 b "test" arg1 arg2 + | UCOMISD (arg1, arg2) -> i2 b "ucomisd" arg1 arg2 + | XCHG (arg1, arg2) -> i2 b "xchg" arg1 arg2 + | XOR (arg1, arg2) -> i2 b "xor" arg1 arg2 + | XORPD (arg1, arg2) -> i2 b "xorpd" arg1 arg2 + + +let print_line b = function + | Ins instr -> print_instr b instr + + | Align (_data,n) -> bprintf b "\tALIGN\t%d" n + | Byte n -> bprintf b "\tBYTE\t%a" cst n + | Bytes s -> buf_bytes_directive b "BYTE" s + | Comment s -> bprintf b " ; %s " s + | Global s -> bprintf b "\tPUBLIC\t%s" s + | Long n -> bprintf b "\tDWORD\t%a" cst n + | NewLabel (s, NONE) -> bprintf b "%s:" s + | NewLabel (s, ptr) -> bprintf b "%s LABEL %s" s (string_of_datatype ptr) + | Quad n -> bprintf b "\tQWORD\t%a" cst n + | Section ([".data"], None, []) -> bprintf b "\t.DATA" + | Section ([".text"], None, []) -> bprintf b "\t.CODE" + | Section _ -> assert false + | Space n -> bprintf b "\tBYTE\t%d DUP (?)" n + | Word n -> bprintf b "\tWORD\t%a" cst n + + (* windows only *) + | External (s, ptr) -> bprintf b "\tEXTRN\t%s: %s" s (string_of_datatype ptr) + | Mode386 -> bprintf b "\t.386" + | Model name -> bprintf b "\t.MODEL %s" name (* name = FLAT *) + + (* gas only *) + | Cfi_adjust_cfa_offset _ + | Cfi_endproc + | Cfi_startproc + | File _ + | Indirect_symbol _ + | Loc _ + | Private_extern _ + | Set _ + | Size _ + | Type _ + -> assert false + +let generate_asm oc lines = + let b = Buffer.create 10000 in + List.iter + (fun i -> + Buffer.clear b; + print_line b i; + Buffer.add_char b '\n'; + Buffer.output_buffer oc b + ) + lines; + output_string oc "\tEND\n" diff -Nru ocaml-4.01.0/asmcomp/x86_masm.mli ocaml-4.05.0/asmcomp/x86_masm.mli --- ocaml-4.01.0/asmcomp/x86_masm.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/x86_masm.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Emit assembly instructions for MASM (Intel syntax). *) + +val generate_asm: out_channel -> X86_ast.asm_line list -> unit diff -Nru ocaml-4.01.0/asmcomp/x86_proc.ml ocaml-4.05.0/asmcomp/x86_proc.ml --- ocaml-4.01.0/asmcomp/x86_proc.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/x86_proc.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,275 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open X86_ast + +type system = + (* 32 bits and 64 bits *) + | S_macosx + | S_gnu + | S_cygwin + + (* 32 bits only *) + | S_solaris + | S_win32 + | S_linux_elf + | S_bsd_elf + | S_beos + | S_mingw + + (* 64 bits only *) + | S_win64 + | S_linux + | S_mingw64 + + | S_unknown + + +let system = match Config.system with + | "macosx" -> S_macosx + | "solaris" -> S_solaris + | "win32" -> S_win32 + | "linux_elf" -> S_linux_elf + | "bsd_elf" -> S_bsd_elf + | "beos" -> S_beos + | "gnu" -> S_gnu + | "cygwin" -> S_cygwin + | "mingw" -> S_mingw + | "mingw64" -> S_mingw64 + | "win64" -> S_win64 + | "linux" -> S_linux + + | _ -> S_unknown + +let windows = + match system with + | S_mingw64 | S_cygwin | S_win64 -> true + | _ -> false + +let string_of_string_literal s = + let b = Buffer.create (String.length s + 2) in + let last_was_escape = ref false in + for i = 0 to String.length s - 1 do + let c = s.[i] in + if c >= '0' && c <= '9' then + if !last_was_escape + then Printf.bprintf b "\\%o" (Char.code c) + else Buffer.add_char b c + else if c >= ' ' && c <= '~' && c <> '"' (* '"' *) && c <> '\\' then begin + Buffer.add_char b c; + last_was_escape := false + end else begin + Printf.bprintf b "\\%o" (Char.code c); + last_was_escape := true + end + done; + Buffer.contents b + +let string_of_symbol prefix s = + let spec = ref false in + for i = 0 to String.length s - 1 do + match String.unsafe_get s i with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> () + | _ -> spec := true; + done; + if not !spec then if prefix = "" then s else prefix ^ s + else + let b = Buffer.create (String.length s + 10) in + Buffer.add_string b prefix; + String.iter + (function + | ('A'..'Z' | 'a'..'z' | '0'..'9' | '_') as c -> Buffer.add_char b c + | c -> Printf.bprintf b "$%02x" (Char.code c) + ) + s; + Buffer.contents b + +let buf_bytes_directive b directive s = + let pos = ref 0 in + for i = 0 to String.length s - 1 do + if !pos = 0 + then begin + if i > 0 then Buffer.add_char b '\n'; + Buffer.add_char b '\t'; + Buffer.add_string b directive; + Buffer.add_char b '\t'; + end + else Buffer.add_char b ','; + Printf.bprintf b "%d" (Char.code s.[i]); + incr pos; + if !pos >= 16 then begin pos := 0 end + done + +let string_of_reg64 = function + | RAX -> "rax" + | RBX -> "rbx" + | RDI -> "rdi" + | RSI -> "rsi" + | RDX -> "rdx" + | RCX -> "rcx" + | RBP -> "rbp" + | RSP -> "rsp" + | R8 -> "r8" + | R9 -> "r9" + | R10 -> "r10" + | R11 -> "r11" + | R12 -> "r12" + | R13 -> "r13" + | R14 -> "r14" + | R15 -> "r15" + +let string_of_reg8l = function + | RAX -> "al" + | RBX -> "bl" + | RCX -> "cl" + | RDX -> "dl" + | RSP -> "spl" + | RBP -> "bpl" + | RSI -> "sil" + | RDI -> "dil" + | R8 -> "r8b" + | R9 -> "r9b" + | R10 -> "r10b" + | R11 -> "r11b" + | R12 -> "r12b" + | R13 -> "r13b" + | R14 -> "r14b" + | R15 -> "r15b" + +let string_of_reg8h = function + | AH -> "ah" + | BH -> "bh" + | CH -> "ch" + | DH -> "dh" + +let string_of_reg16 = function + | RAX -> "ax" + | RBX -> "bx" + | RCX -> "cx" + | RDX -> "dx" + | RSP -> "sp" + | RBP -> "bp" + | RSI -> "si" + | RDI -> "di" + | R8 -> "r8w" + | R9 -> "r9w" + | R10 -> "r10w" + | R11 -> "r11w" + | R12 -> "r12w" + | R13 -> "r13w" + | R14 -> "r14w" + | R15 -> "r15w" + +let string_of_reg32 = function + | RAX -> "eax" + | RBX -> "ebx" + | RCX -> "ecx" + | RDX -> "edx" + | RSP -> "esp" + | RBP -> "ebp" + | RSI -> "esi" + | RDI -> "edi" + | R8 -> "r8d" + | R9 -> "r9d" + | R10 -> "r10d" + | R11 -> "r11d" + | R12 -> "r12d" + | R13 -> "r13d" + | R14 -> "r14d" + | R15 -> "r15d" + +let string_of_registerf = function + | XMM n -> Printf.sprintf "xmm%d" n + | TOS -> Printf.sprintf "tos" + | ST n -> Printf.sprintf "st(%d)" n + +let string_of_condition = function + | E -> "e" + | AE -> "ae" + | A -> "a" + | GE -> "ge" + | G -> "g" + | NE -> "ne" + | B -> "b" + | BE -> "be" + | L -> "l" + | LE -> "le" + | NP -> "np" + | P -> "p" + | NS -> "ns" + | S -> "s" + | NO -> "no" + | O -> "o" + +let string_of_rounding = function + | RoundDown -> "roundsd.down" + | RoundUp -> "roundsd.up" + | RoundTruncate -> "roundsd.trunc" + | RoundNearest -> "roundsd.near" + + +(* These hooks can be used to insert optimization passes on + the assembly code. *) +let assembler_passes = ref ([] : (asm_program -> asm_program) list) + +let internal_assembler = ref None +let register_internal_assembler f = internal_assembler := Some f + +(* Which asm conventions to use *) +let masm = + match system with + | S_win32 | S_win64 -> true + | _ -> false + +(* Shall we use an external assembler command ? + If [binary_content] contains some data, we can directly + save it. Otherwise, we have to ask an external command. +*) +let binary_content = ref None + +let compile infile outfile = + if masm then + Ccomp.command (Config.asm ^ + Filename.quote outfile ^ " " ^ Filename.quote infile ^ + (if !Clflags.verbose then "" else ">NUL")) + else + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) + +let assemble_file infile outfile = + match !binary_content with + | None -> compile infile outfile + | Some content -> content outfile; binary_content := None; 0 + +let asm_code = ref [] + +let directive dir = asm_code := dir :: !asm_code +let emit ins = directive (Ins ins) + +let reset_asm_code () = asm_code := [] + +let generate_code asm = + let instrs = List.rev !asm_code in + let instrs = + List.fold_left (fun instrs pass -> pass instrs) instrs !assembler_passes + in + begin match asm with + | Some f -> f instrs + | None -> () + end; + begin match !internal_assembler with + | Some f -> binary_content := Some (f instrs) + | None -> binary_content := None + end diff -Nru ocaml-4.01.0/asmcomp/x86_proc.mli ocaml-4.05.0/asmcomp/x86_proc.mli --- ocaml-4.01.0/asmcomp/x86_proc.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmcomp/x86_proc.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,91 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +(** Definitions shared between the 32 and 64 bit Intel backends. *) + +open X86_ast + +(** Helpers for textual emitters *) + +val string_of_reg8l: reg64 -> string +val string_of_reg8h: reg8h -> string +val string_of_reg16: reg64 -> string +val string_of_reg32: reg64 -> string +val string_of_reg64: reg64 -> string +val string_of_registerf: registerf -> string +val string_of_string_literal: string -> string +val string_of_condition: condition -> string +val string_of_symbol: (*prefix*) string -> string -> string +val string_of_rounding: rounding -> string +val buf_bytes_directive: + Buffer.t -> (*directive*) string -> (*data*)string -> unit + + +(** Buffer of assembly code *) + +val emit: instruction -> unit +val directive: asm_line -> unit +val reset_asm_code: unit -> unit + +(** Code emission *) + +val generate_code: (X86_ast.asm_line list -> unit) option -> unit + (** Post-process the stream of instructions. Dump it (using + the provided syntax emitter) in a file (if provided) and + compile it with an internal assembler (if registered + through [register_internal_assembler]). *) + +val assemble_file: (*infile*) string -> (*outfile*) string -> (*retcode*) int +(** Generate an object file corresponding to the last call to + [generate_code]. An internal assembler is used if available (and + the input file is ignored). Otherwise, the source asm file with an + external assembler. *) + +(** System detection *) + +type system = + (* 32 bits and 64 bits *) + | S_macosx + | S_gnu + | S_cygwin + + (* 32 bits only *) + | S_solaris + | S_win32 + | S_linux_elf + | S_bsd_elf + | S_beos + | S_mingw + + (* 64 bits only *) + | S_win64 + | S_linux + | S_mingw64 + + | S_unknown + +val system: system +val masm: bool +val windows:bool + +(** Support for plumbing a binary code emitter *) + +val register_internal_assembler: (asm_program -> string -> unit) -> unit + + +(** Hooks for rewriting the assembly code *) + +val assembler_passes: (asm_program -> asm_program) list ref diff -Nru ocaml-4.01.0/asmrun/amd64nt.asm ocaml-4.05.0/asmrun/amd64nt.asm --- ocaml-4.01.0/asmrun/amd64nt.asm 2013-06-03 18:03:59.000000000 +0000 +++ ocaml-4.05.0/asmrun/amd64nt.asm 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,17 @@ -;*********************************************************************** -;* * -;* OCaml * -;* * -;* Xavier Leroy, projet Gallium, INRIA Rocquencourt * -;* * -;* Copyright 2006 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. * -;* * -;*********************************************************************** +;************************************************************************** +;* * +;* OCaml * +;* * +;* Xavier Leroy, projet Gallium, INRIA Rocquencourt * +;* * +;* Copyright 2006 Institut National de Recherche en Informatique et * +;* en Automatique. * +;* * +;* All rights reserved. This file is distributed under the terms of * +;* the GNU Lesser General Public License version 2.1, with the * +;* special exception on linking described in the file LICENSE. * +;* * +;************************************************************************** ; Asm part of the runtime system, AMD64 processor, Intel syntax @@ -29,6 +31,7 @@ EXTRN caml_last_return_address: QWORD EXTRN caml_gc_regs: QWORD EXTRN caml_exception_pointer: QWORD + EXTRN caml_backtrace_pos: DWORD EXTRN caml_backtrace_active: DWORD EXTRN caml_stash_backtrace: NEAR @@ -324,13 +327,13 @@ ALIGN 16 caml_raise_exception: test caml_backtrace_active, 1 - jne L111 + jne L112 mov rax, rcx ; First argument is exn bucket mov rsp, caml_exception_pointer pop r14 ; Recover previous exception handler mov r15, caml_young_ptr ; Reload alloc ptr ret -L111: +L112: mov r12, rcx ; Save exception bucket in r12 ; Arg 1: exception bucket mov rdx, caml_last_return_address ; Arg 2: PC of raise diff -Nru ocaml-4.01.0/asmrun/amd64.S ocaml-4.05.0/asmrun/amd64.S --- ocaml-4.01.0/asmrun/amd64.S 2013-07-23 14:48:47.000000000 +0000 +++ ocaml-4.05.0/asmrun/amd64.S 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,17 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2003 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ /* Asm part of the runtime system, AMD64 processor */ /* Must be preprocessed by cpp */ @@ -32,7 +34,7 @@ .align FUNCTION_ALIGN; \ name: -#elif defined(SYS_mingw64) +#elif defined(SYS_mingw64) || defined(SYS_cygwin) #define LBL(x) .L##x #define G(r) r @@ -67,10 +69,14 @@ #define CFI_STARTPROC .cfi_startproc #define CFI_ENDPROC .cfi_endproc #define CFI_ADJUST(n) .cfi_adjust_cfa_offset n +#define CFI_OFFSET(r, n) .cfi_offset r, n +#define CFI_SAME_VALUE(r) .cfi_same_value r #else #define CFI_STARTPROC #define CFI_ENDPROC #define CFI_ADJUST(n) +#define CFI_OFFSET(r, n) +#define CFI_SAME_VALUE(r) #endif #ifdef WITH_FRAME_POINTERS @@ -90,7 +96,7 @@ #endif -#if defined(__PIC__) && !defined(SYS_mingw64) +#if defined(__PIC__) && !defined(SYS_mingw64) && !defined(SYS_cygwin) /* Position-independent operations on global variables. */ @@ -99,6 +105,10 @@ movq GREL(dstlabel)(%rip), %r11 ; \ movq srcreg, (%r11) +#define STORE_VAR32(srcreg,dstlabel) \ + movq GREL(dstlabel)(%rip), %r11 ; \ + movl srcreg, (%r11) + /* Load global [srclabel] in register [dstreg]. Clobbers %r11. */ #define LOAD_VAR(srclabel,dstreg) \ movq GREL(srclabel)(%rip), %r11 ; \ @@ -144,6 +154,9 @@ #define STORE_VAR(srcreg,dstlabel) \ movq srcreg, G(dstlabel)(%rip) +#define STORE_VAR32(srcreg,dstlabel) \ + movl srcreg, G(dstlabel)(%rip) + #define LOAD_VAR(srclabel,dstreg) \ movq G(srclabel)(%rip), dstreg @@ -172,19 +185,20 @@ /* Save and restore all callee-save registers on stack. Keep the stack 16-aligned. */ -#if defined(SYS_mingw64) +#if defined(SYS_mingw64) || defined(SYS_cygwin) /* Win64 API: callee-save regs are rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 */ #define PUSH_CALLEE_SAVE_REGS \ - pushq %rbx; CFI_ADJUST (8); \ - pushq %rbp; CFI_ADJUST (8); \ - pushq %rsi; CFI_ADJUST (8); \ - pushq %rdi; CFI_ADJUST (8); \ - pushq %r12; CFI_ADJUST (8); \ - pushq %r13; CFI_ADJUST (8); \ - pushq %r14; CFI_ADJUST (8); \ - pushq %r15; CFI_ADJUST (8); \ + pushq %rbx; CFI_ADJUST (8); CFI_OFFSET(rbx, -16); \ + pushq %rbp; CFI_ADJUST (8); CFI_OFFSET(rbp, -24); \ + /* Allows debugger to walk the stack */ \ + pushq %rsi; CFI_ADJUST (8); CFI_OFFSET(rsi, -32); \ + pushq %rdi; CFI_ADJUST (8); CFI_OFFSET(rdi, -40); \ + pushq %r12; CFI_ADJUST (8); CFI_OFFSET(r12, -48); \ + pushq %r13; CFI_ADJUST (8); CFI_OFFSET(r13, -56); \ + pushq %r14; CFI_ADJUST (8); CFI_OFFSET(r14, -64); \ + pushq %r15; CFI_ADJUST (8); CFI_OFFSET(r15, -72); \ subq $(8+10*16), %rsp; CFI_ADJUST (8+10*16); \ movupd %xmm6, 0*16(%rsp); \ movupd %xmm7, 1*16(%rsp); \ @@ -209,40 +223,40 @@ movupd 8*16(%rsp), %xmm14; \ movupd 9*16(%rsp), %xmm15; \ addq $(8+10*16), %rsp; CFI_ADJUST (-8-10*16); \ - popq %r15; CFI_ADJUST(-8); \ - popq %r14; CFI_ADJUST(-8); \ - popq %r13; CFI_ADJUST(-8); \ - popq %r12; CFI_ADJUST(-8); \ - popq %rdi; CFI_ADJUST(-8); \ - popq %rsi; CFI_ADJUST(-8); \ - popq %rbp; CFI_ADJUST(-8); \ - popq %rbx; CFI_ADJUST(-8) + popq %r15; CFI_ADJUST(-8); CFI_SAME_VALUE(r15); \ + popq %r14; CFI_ADJUST(-8); CFI_SAME_VALUE(r14); \ + popq %r13; CFI_ADJUST(-8); CFI_SAME_VALUE(r13); \ + popq %r12; CFI_ADJUST(-8); CFI_SAME_VALUE(r12); \ + popq %rdi; CFI_ADJUST(-8); CFI_SAME_VALUE(rdi); \ + popq %rsi; CFI_ADJUST(-8); CFI_SAME_VALUE(rsi); \ + popq %rbp; CFI_ADJUST(-8); CFI_SAME_VALUE(rbp); \ + popq %rbx; CFI_ADJUST(-8); CFI_SAME_VALUE(rbx) #else /* Unix API: callee-save regs are rbx, rbp, r12-r15 */ #define PUSH_CALLEE_SAVE_REGS \ - pushq %rbx; CFI_ADJUST(8); \ - pushq %rbp; CFI_ADJUST(8); \ - pushq %r12; CFI_ADJUST(8); \ - pushq %r13; CFI_ADJUST(8); \ - pushq %r14; CFI_ADJUST(8); \ - pushq %r15; CFI_ADJUST(8); \ + pushq %rbx; CFI_ADJUST(8); CFI_OFFSET(rbx, -16); \ + pushq %rbp; CFI_ADJUST(8); CFI_OFFSET(rbp, -24); \ + pushq %r12; CFI_ADJUST(8); CFI_OFFSET(r12, -32); \ + pushq %r13; CFI_ADJUST(8); CFI_OFFSET(r13, -40); \ + pushq %r14; CFI_ADJUST(8); CFI_OFFSET(r14, -48); \ + pushq %r15; CFI_ADJUST(8); CFI_OFFSET(r15, -56); \ subq $8, %rsp; CFI_ADJUST(8) #define POP_CALLEE_SAVE_REGS \ addq $8, %rsp; CFI_ADJUST(-8); \ - popq %r15; CFI_ADJUST(-8); \ - popq %r14; CFI_ADJUST(-8); \ - popq %r13; CFI_ADJUST(-8); \ - popq %r12; CFI_ADJUST(-8); \ - popq %rbp; CFI_ADJUST(-8); \ - popq %rbx; CFI_ADJUST(-8); + popq %r15; CFI_ADJUST(-8); CFI_SAME_VALUE(r15); \ + popq %r14; CFI_ADJUST(-8); CFI_SAME_VALUE(r14); \ + popq %r13; CFI_ADJUST(-8); CFI_SAME_VALUE(r13); \ + popq %r12; CFI_ADJUST(-8); CFI_SAME_VALUE(r12); \ + popq %rbp; CFI_ADJUST(-8); CFI_SAME_VALUE(rbp); \ + popq %rbx; CFI_ADJUST(-8); CFI_SAME_VALUE(rbx) #endif -#ifdef SYS_mingw64 +#if defined(SYS_mingw64) || defined (SYS_cygwin) /* Calls from OCaml to C must reserve 32 bytes of extra stack space */ # define PREPARE_FOR_C_CALL subq $32, %rsp; CFI_ADJUST(32) # define CLEANUP_AFTER_C_CALL addq $32, %rsp; CFI_ADJUST(-32) @@ -264,7 +278,7 @@ CFI_STARTPROC RECORD_STACK_FRAME(0) LBL(caml_call_gc): -#ifndef SYS_mingw64 +#if !defined(SYS_mingw64) && !defined(SYS_cygwin) /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ subq $32768, %rsp @@ -293,6 +307,9 @@ /* Save caml_young_ptr, caml_exception_pointer */ STORE_VAR(%r15, caml_young_ptr) STORE_VAR(%r14, caml_exception_pointer) +#ifdef WITH_SPACETIME + STORE_VAR(%r13, caml_spacetime_trie_node_ptr) +#endif /* Save floating-point registers */ subq $(16*8), %rsp; CFI_ADJUST (16*8); movsd %xmm0, 0*8(%rsp) @@ -418,14 +435,18 @@ addq $8, %rsp; CFI_ADJUST (-8) /* drop desired size */ ret LBL(103): + CFI_ADJUST(8) RECORD_STACK_FRAME(8) #ifdef WITH_FRAME_POINTERS - /* Do we need 16-byte alignment here ? */ + /* ensure 16 byte alignment by subq + enter using 16-bytes, PR#7417 */ + subq $8, %rsp; CFI_ADJUST (8) ENTER_FUNCTION #endif call LBL(caml_call_gc) #ifdef WITH_FRAME_POINTERS + /* ensure 16 byte alignment by leave + addq using 16-bytes PR#7417 */ LEAVE_FUNCTION + addq $8, %rsp; CFI_ADJUST (-8) #endif popq %rax; CFI_ADJUST(-8) /* recover desired size */ jmp LBL(caml_allocN) @@ -440,8 +461,13 @@ popq %r12; CFI_ADJUST(-8) STORE_VAR(%r12, caml_last_return_address) STORE_VAR(%rsp, caml_bottom_of_stack) +#ifdef WITH_SPACETIME + /* Record the trie node hole pointer that corresponds to + [caml_last_return_address] */ + STORE_VAR(%r13, caml_spacetime_trie_node_ptr) +#endif subq $8, %rsp; CFI_ADJUST(8) /* equivalent to pushq %r12 */ -#ifndef SYS_mingw64 +#if !defined(SYS_mingw64) && !defined(SYS_cygwin) /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ subq $32768, %rsp @@ -464,14 +490,33 @@ /* Save callee-save registers */ PUSH_CALLEE_SAVE_REGS /* Initial entry point is G(caml_program) */ - leaq GCALL(caml_program)(%rip), %r12 + LEA_VAR(caml_program, %r12) /* Common code for caml_start_program and caml_callback* */ LBL(caml_start_program): /* Build a callback link */ +#ifdef WITH_SPACETIME + PUSH_VAR(caml_spacetime_trie_node_ptr) +#else subq $8, %rsp; CFI_ADJUST (8) /* stack 16-aligned */ +#endif PUSH_VAR(caml_gc_regs) PUSH_VAR(caml_last_return_address) PUSH_VAR(caml_bottom_of_stack) +#ifdef WITH_SPACETIME + /* Save arguments to caml_callback* */ + pushq %rax; CFI_ADJUST (8) + pushq %rbx; CFI_ADJUST (8) + pushq %rdi; CFI_ADJUST (8) + pushq %rsi; CFI_ADJUST (8) + /* No need to push %r12: it's callee-save. */ + movq %r12, %rdi + LEA_VAR(caml_start_program, %rsi) + call GCALL(caml_spacetime_c_to_ocaml) + popq %rsi; CFI_ADJUST (-8) + popq %rdi; CFI_ADJUST (-8) + popq %rbx; CFI_ADJUST (-8) + popq %rax; CFI_ADJUST (-8) +#endif /* Setup alloc ptr and exception ptr */ LOAD_VAR(caml_young_ptr, %r15) LOAD_VAR(caml_exception_pointer, %r14) @@ -479,15 +524,16 @@ lea LBL(108)(%rip), %r13 pushq %r13; CFI_ADJUST(8) pushq %r14; CFI_ADJUST(8) - CFI_ADJUST(16) movq %rsp, %r14 +#ifdef WITH_SPACETIME + LOAD_VAR(caml_spacetime_trie_node_ptr, %r13) +#endif /* Call the OCaml code */ call *%r12 LBL(107): /* Pop the exception handler */ popq %r14; CFI_ADJUST(-8) popq %r12; CFI_ADJUST(-8) /* dummy register */ - CFI_ADJUST(-16) LBL(109): /* Update alloc ptr and exception ptr */ STORE_VAR(%r15,caml_young_ptr) @@ -496,7 +542,11 @@ POP_VAR(caml_bottom_of_stack) POP_VAR(caml_last_return_address) POP_VAR(caml_gc_regs) +#ifdef WITH_SPACETIME + POP_VAR(caml_spacetime_trie_node_ptr) +#else addq $8, %rsp; CFI_ADJUST (-8); +#endif /* Restore callee-save registers. */ POP_CALLEE_SAVE_REGS /* Return to caller. */ @@ -510,7 +560,7 @@ /* Registers holding arguments of C functions. */ -#ifdef SYS_mingw64 +#if defined(SYS_mingw64) || defined(SYS_cygwin) #define C_ARG_1 %rcx #define C_ARG_2 %rdx #define C_ARG_3 %r8 @@ -558,13 +608,13 @@ FUNCTION(G(caml_raise_exception)) CFI_STARTPROC TESTL_VAR($1, caml_backtrace_active) - jne LBL(111) + jne LBL(112) movq C_ARG_1, %rax LOAD_VAR(caml_exception_pointer, %rsp) /* Cut stack */ popq %r14 /* Recover previous exception handler */ LOAD_VAR(caml_young_ptr, %r15) /* Reload alloc ptr */ ret -LBL(111): +LBL(112): #ifdef WITH_FRAME_POINTERS ENTER_FUNCTION ; #endif @@ -592,7 +642,7 @@ backtrace anyway. */ FUNCTION(G(caml_stack_overflow)) - LEA_VAR(caml_bucket_Stack_overflow, %rax) + LEA_VAR(caml_exn_Stack_overflow, %rax) movq %r14, %rsp /* cut the stack */ popq %r14 /* recover previous exn handler */ ret /* jump to handler's code */ @@ -618,7 +668,7 @@ movq C_ARG_1, %rdi /* closure -- no op with Unix conventions */ movq C_ARG_2, %rax /* first argument */ movq C_ARG_3, %rbx /* second argument */ - leaq GCALL(caml_apply2)(%rip), %r12 /* code pointer */ + LEA_VAR(caml_apply2, %r12) /* code pointer */ jmp LBL(caml_start_program) CFI_ENDPROC @@ -631,13 +681,13 @@ movq C_ARG_3, %rbx /* second argument */ movq C_ARG_1, %rsi /* closure */ movq C_ARG_4, %rdi /* third argument */ - leaq GCALL(caml_apply3)(%rip), %r12 /* code pointer */ + LEA_VAR(caml_apply3, %r12) /* code pointer */ jmp LBL(caml_start_program) CFI_ENDPROC FUNCTION(G(caml_ml_array_bound_error)) CFI_STARTPROC - leaq GCALL(caml_array_bound_error)(%rip), %rax + LEA_VAR(caml_array_bound_error, %rax) jmp LBL(caml_c_call) CFI_ENDPROC @@ -653,10 +703,26 @@ .value -1 /* negative frame size => use callback link */ .value 0 /* no roots here */ .align EIGHT_ALIGN + .quad 16 + .quad 0 + .string "amd64.S" + +#ifdef WITH_SPACETIME + .data + .globl G(caml_system__spacetime_shapes) + .align EIGHT_ALIGN +G(caml_system__spacetime_shapes): + .quad G(caml_start_program) + .quad 2 /* indirect call point to OCaml code */ + .quad LBL(107) /* in caml_start_program / caml_callback* */ + .quad 0 /* end of shapes for caml_start_program */ + .quad 0 /* end of shape table */ + .align EIGHT_ALIGN +#endif #if defined(SYS_macosx) .literal16 -#elif defined(SYS_mingw64) +#elif defined(SYS_mingw64) || defined(SYS_cygwin) .section .rdata,"dr" #else .section .rodata.cst8,"a",@progbits diff -Nru ocaml-4.01.0/asmrun/arm64.S ocaml-4.05.0/asmrun/arm64.S --- ocaml-4.01.0/asmrun/arm64.S 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmrun/arm64.S 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,560 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ +/* */ +/* Copyright 2013 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Asm part of the runtime system, ARM processor, 64-bit mode */ +/* Must be preprocessed by cpp */ + +/* Special registers */ + +#define TRAP_PTR x26 +#define ALLOC_PTR x27 +#define ALLOC_LIMIT x28 +#define ARG x15 +#define TMP x16 +#define TMP2 x17 + +/* Support for CFI directives */ + +#if defined(ASM_CFI_SUPPORTED) +#define CFI_STARTPROC .cfi_startproc +#define CFI_ENDPROC .cfi_endproc +#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n +#else +#define CFI_STARTPROC +#define CFI_ENDPROC +#define CFI_ADJUST(n) +#endif + +/* Support for profiling with gprof */ + +#define PROFILE + +/* Macros to load and store global variables. Destroy TMP2 */ + +#if defined(__PIC__) + +#define ADDRGLOBAL(reg,symb) \ + adrp TMP2, :got:symb; \ + ldr reg, [TMP2, #:got_lo12:symb] + +#define LOADGLOBAL(reg,symb) \ + ADDRGLOBAL(TMP2,symb); \ + ldr reg, [TMP2] + +#define STOREGLOBAL(reg,symb) \ + ADDRGLOBAL(TMP2,symb); \ + str reg, [TMP2] + +#else + +#define ADDRGLOBAL(reg,symb) \ + adrp reg, symb; \ + add reg, reg, #:lo12:symb + +#define LOADGLOBAL(reg,symb) \ + adrp TMP2, symb; \ + ldr reg, [TMP2, #:lo12:symb] + +#define STOREGLOBAL(reg,symb) \ + adrp TMP2, symb; \ + str reg, [TMP2, #:lo12:symb] + +#endif + +/* Allocation functions and GC interface */ + + .globl caml_system__code_begin +caml_system__code_begin: + + .align 2 + .globl caml_call_gc +caml_call_gc: + CFI_STARTPROC + PROFILE + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Record lowest stack address */ + mov TMP, sp + STOREGLOBAL(TMP, caml_bottom_of_stack) +.Lcaml_call_gc: + /* Set up stack space, saving return address and frame pointer */ + /* (2 regs RA/GP, 24 allocatable int regs, 24 caller-save float regs) * 8 */ + stp x29, x30, [sp, -400]! + CFI_ADJUST(400) + add x29, sp, #0 + /* Save allocatable integer registers on the stack, in the order + given in proc.ml */ + stp x0, x1, [sp, 16] + stp x2, x3, [sp, 32] + stp x4, x5, [sp, 48] + stp x6, x7, [sp, 64] + stp x8, x9, [sp, 80] + stp x10, x11, [sp, 96] + stp x12, x13, [sp, 112] + stp x14, x15, [sp, 128] + stp x19, x20, [sp, 144] + stp x21, x22, [sp, 160] + stp x23, x24, [sp, 176] + str x25, [sp, 192] + /* Save caller-save floating-point registers on the stack + (callee-saves are preserved by caml_garbage_collection) */ + stp d0, d1, [sp, 208] + stp d2, d3, [sp, 224] + stp d4, d5, [sp, 240] + stp d6, d7, [sp, 256] + stp d16, d17, [sp, 272] + stp d18, d19, [sp, 288] + stp d20, d21, [sp, 304] + stp d22, d23, [sp, 320] + stp d24, d25, [sp, 336] + stp d26, d27, [sp, 352] + stp d28, d29, [sp, 368] + stp d30, d31, [sp, 384] + /* Store pointer to saved integer registers in caml_gc_regs */ + add TMP, sp, #16 + STOREGLOBAL(TMP, caml_gc_regs) + /* Save current allocation pointer for debugging purposes */ + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + /* Save trap pointer in case an exception is raised during GC */ + STOREGLOBAL(TRAP_PTR, caml_exception_pointer) + /* Call the garbage collector */ + bl caml_garbage_collection + /* Restore registers */ + ldp x0, x1, [sp, 16] + ldp x2, x3, [sp, 32] + ldp x4, x5, [sp, 48] + ldp x6, x7, [sp, 64] + ldp x8, x9, [sp, 80] + ldp x10, x11, [sp, 96] + ldp x12, x13, [sp, 112] + ldp x14, x15, [sp, 128] + ldp x19, x20, [sp, 144] + ldp x21, x22, [sp, 160] + ldp x23, x24, [sp, 176] + ldr x25, [sp, 192] + ldp d0, d1, [sp, 208] + ldp d2, d3, [sp, 224] + ldp d4, d5, [sp, 240] + ldp d6, d7, [sp, 256] + ldp d16, d17, [sp, 272] + ldp d18, d19, [sp, 288] + ldp d20, d21, [sp, 304] + ldp d22, d23, [sp, 320] + ldp d24, d25, [sp, 336] + ldp d26, d27, [sp, 352] + ldp d28, d29, [sp, 368] + ldp d30, d31, [sp, 384] + /* Reload new allocation pointer and allocation limit */ + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + /* Free stack space and return to caller */ + ldp x29, x30, [sp], 400 + ret + CFI_ENDPROC + .type caml_call_gc, %function + .size caml_call_gc, .-caml_call_gc + + .align 2 + .globl caml_alloc1 +caml_alloc1: + CFI_STARTPROC + PROFILE +1: sub ALLOC_PTR, ALLOC_PTR, #16 + cmp ALLOC_PTR, ALLOC_LIMIT + b.lo 2f + ret +2: stp x29, x30, [sp, -16]! + CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. This is the + address immediately above the pair of words (x29 and x30) we just + pushed. Those must not be included since otherwise the distance from + [caml_bottom_of_stack] to the highest address in the caller's stack + frame won't match the frame size contained in the relevant frame + descriptor. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) + add x29, sp, #0 + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Call GC */ + bl .Lcaml_call_gc + /* Restore return address */ + ldp x29, x30, [sp], 16 + CFI_ADJUST(-16) + /* Try again */ + b 1b + CFI_ENDPROC + .type caml_alloc1, %function + .size caml_alloc1, .-caml_alloc1 + + .align 2 + .globl caml_alloc2 +caml_alloc2: + CFI_STARTPROC + PROFILE +1: sub ALLOC_PTR, ALLOC_PTR, #24 + cmp ALLOC_PTR, ALLOC_LIMIT + b.lo 2f + ret +2: stp x29, x30, [sp, -16]! + CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. + See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) + add x29, sp, #0 + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Call GC */ + bl .Lcaml_call_gc + /* Restore return address */ + ldp x29, x30, [sp], 16 + CFI_ADJUST(-16) + /* Try again */ + b 1b + CFI_ENDPROC + .type caml_alloc2, %function + .size caml_alloc2, .-caml_alloc2 + + .align 2 + .globl caml_alloc3 +caml_alloc3: + CFI_STARTPROC + PROFILE +1: sub ALLOC_PTR, ALLOC_PTR, #32 + cmp ALLOC_PTR, ALLOC_LIMIT + b.lo 2f + ret +2: stp x29, x30, [sp, -16]! + CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. + See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) + add x29, sp, #0 + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Call GC */ + bl .Lcaml_call_gc + /* Restore return address */ + ldp x29, x30, [sp], 16 + CFI_ADJUST(-16) + /* Try again */ + b 1b + CFI_ENDPROC + .type caml_alloc3, %function + .size caml_alloc3, .-caml_alloc3 + + .align 2 + .globl caml_allocN +caml_allocN: + CFI_STARTPROC + PROFILE +1: sub ALLOC_PTR, ALLOC_PTR, ARG + cmp ALLOC_PTR, ALLOC_LIMIT + b.lo 2f + ret +2: stp x29, x30, [sp, -16]! + CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. + See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) + add x29, sp, #0 + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Call GC. This preserves ARG */ + bl .Lcaml_call_gc + /* Restore return address */ + ldp x29, x30, [sp], 16 + CFI_ADJUST(-16) + /* Try again */ + b 1b + CFI_ENDPROC + .type caml_allocN, %function + .size caml_allocN, .-caml_allocN + +/* Call a C function from OCaml */ +/* Function to call is in ARG */ + + .align 2 + .globl caml_c_call +caml_c_call: + CFI_STARTPROC + PROFILE + /* Preserve return address in callee-save register x19 */ + mov x19, x30 + /* Record lowest stack address and return address */ + STOREGLOBAL(x30, caml_last_return_address) + add TMP, sp, #0 + STOREGLOBAL(TMP, caml_bottom_of_stack) + /* Make the exception handler alloc ptr available to the C code */ + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + STOREGLOBAL(TRAP_PTR, caml_exception_pointer) + /* Call the function */ + blr ARG + /* Reload alloc ptr and alloc limit */ + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + /* Return */ + ret x19 + CFI_ENDPROC + .type caml_c_call, %function + .size caml_c_call, .-caml_c_call + +/* Start the OCaml program */ + + .align 2 + .globl caml_start_program +caml_start_program: + CFI_STARTPROC + PROFILE + ADDRGLOBAL(ARG, caml_program) + +/* Code shared with caml_callback* */ +/* Address of OCaml code to call is in ARG */ +/* Arguments to the OCaml code are in x0...x7 */ + +.Ljump_to_caml: + /* Set up stack frame and save callee-save registers */ + stp x29, x30, [sp, -160]! + CFI_ADJUST(160) + add x29, sp, #0 + stp x19, x20, [sp, 16] + stp x21, x22, [sp, 32] + stp x23, x24, [sp, 48] + stp x25, x26, [sp, 64] + stp x27, x28, [sp, 80] + stp d8, d9, [sp, 96] + stp d10, d11, [sp, 112] + stp d12, d13, [sp, 128] + stp d14, d15, [sp, 144] + /* Setup a callback link on the stack */ + LOADGLOBAL(x8, caml_bottom_of_stack) + LOADGLOBAL(x9, caml_last_return_address) + LOADGLOBAL(x10, caml_gc_regs) + stp x8, x9, [sp, -32]! /* 16-byte alignment */ + CFI_ADJUST(32) + str x10, [sp, 16] + /* Setup a trap frame to catch exceptions escaping the OCaml code */ + LOADGLOBAL(x8, caml_exception_pointer) + adr x9, .Ltrap_handler + stp x8, x9, [sp, -16]! + CFI_ADJUST(16) + add TRAP_PTR, sp, #0 + /* Reload allocation pointers */ + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + /* Call the OCaml code */ + blr ARG +.Lcaml_retaddr: + /* Pop the trap frame, restoring caml_exception_pointer */ + ldr x8, [sp], 16 + CFI_ADJUST(-16) + STOREGLOBAL(x8, caml_exception_pointer) + /* Pop the callback link, restoring the global variables */ +.Lreturn_result: + ldr x10, [sp, 16] + ldp x8, x9, [sp], 32 + CFI_ADJUST(-32) + STOREGLOBAL(x8, caml_bottom_of_stack) + STOREGLOBAL(x9, caml_last_return_address) + STOREGLOBAL(x10, caml_gc_regs) + /* Update allocation pointer */ + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + /* Reload callee-save registers and return address */ + ldp x19, x20, [sp, 16] + ldp x21, x22, [sp, 32] + ldp x23, x24, [sp, 48] + ldp x25, x26, [sp, 64] + ldp x27, x28, [sp, 80] + ldp d8, d9, [sp, 96] + ldp d10, d11, [sp, 112] + ldp d12, d13, [sp, 128] + ldp d14, d15, [sp, 144] + ldp x29, x30, [sp], 160 + CFI_ADJUST(-160) + /* Return to C caller */ + ret + CFI_ENDPROC + .type .Lcaml_retaddr, %function + .size .Lcaml_retaddr, .-.Lcaml_retaddr + .type caml_start_program, %function + .size caml_start_program, .-caml_start_program + +/* The trap handler */ + + .align 2 +.Ltrap_handler: + CFI_STARTPROC + /* Save exception pointer */ + STOREGLOBAL(TRAP_PTR, caml_exception_pointer) + /* Encode exception bucket as an exception result */ + orr x0, x0, #2 + /* Return it */ + b .Lreturn_result + CFI_ENDPROC + .type .Ltrap_handler, %function + .size .Ltrap_handler, .-.Ltrap_handler + +/* Raise an exception from OCaml */ + + .align 2 + .globl caml_raise_exn +caml_raise_exn: + CFI_STARTPROC + PROFILE + /* Test if backtrace is active */ + LOADGLOBAL(TMP, caml_backtrace_active) + cbnz TMP, 2f +1: /* Cut stack at current trap handler */ + mov sp, TRAP_PTR + /* Pop previous handler and jump to it */ + ldr TMP, [sp, 8] + ldr TRAP_PTR, [sp], 16 + br TMP +2: /* Preserve exception bucket in callee-save register x19 */ + mov x19, x0 + /* Stash the backtrace */ + /* arg1: exn bucket, already in x0 */ + mov x1, x30 /* arg2: pc of raise */ + add x2, sp, #0 /* arg3: sp of raise */ + mov x3, TRAP_PTR /* arg4: sp of handler */ + bl caml_stash_backtrace + /* Restore exception bucket and raise */ + mov x0, x19 + b 1b + CFI_ENDPROC + .type caml_raise_exn, %function + .size caml_raise_exn, .-caml_raise_exn + +/* Raise an exception from C */ + + .align 2 + .globl caml_raise_exception +caml_raise_exception: + CFI_STARTPROC + PROFILE + /* Reload trap ptr, alloc ptr and alloc limit */ + LOADGLOBAL(TRAP_PTR, caml_exception_pointer) + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + /* Test if backtrace is active */ + LOADGLOBAL(TMP, caml_backtrace_active) + cbnz TMP, 2f +1: /* Cut stack at current trap handler */ + mov sp, TRAP_PTR + /* Pop previous handler and jump to it */ + ldr TMP, [sp, 8] + ldr TRAP_PTR, [sp], 16 + br TMP +2: /* Preserve exception bucket in callee-save register x19 */ + mov x19, x0 + /* Stash the backtrace */ + /* arg1: exn bucket, already in x0 */ + LOADGLOBAL(x1, caml_last_return_address) /* arg2: pc of raise */ + LOADGLOBAL(x2, caml_bottom_of_stack) /* arg3: sp of raise */ + mov x3, TRAP_PTR /* arg4: sp of handler */ + bl caml_stash_backtrace + /* Restore exception bucket and raise */ + mov x0, x19 + b 1b + CFI_ENDPROC + .type caml_raise_exception, %function + .size caml_raise_exception, .-caml_raise_exception + +/* Callback from C to OCaml */ + + .align 2 + .globl caml_callback_exn +caml_callback_exn: + CFI_STARTPROC + PROFILE + /* Initial shuffling of arguments (x0 = closure, x1 = first arg) */ + mov TMP, x0 + mov x0, x1 /* x0 = first arg */ + mov x1, TMP /* x1 = closure environment */ + ldr ARG, [TMP] /* code pointer */ + b .Ljump_to_caml + CFI_ENDPROC + .type caml_callback_exn, %function + .size caml_callback_exn, .-caml_callback_exn + + .align 2 + .globl caml_callback2_exn +caml_callback2_exn: + CFI_STARTPROC + PROFILE + /* Initial shuffling of arguments (x0 = closure, x1 = arg1, x2 = arg2) */ + mov TMP, x0 + mov x0, x1 /* x0 = first arg */ + mov x1, x2 /* x1 = second arg */ + mov x2, TMP /* x2 = closure environment */ + ADDRGLOBAL(ARG, caml_apply2) + b .Ljump_to_caml + CFI_ENDPROC + .type caml_callback2_exn, %function + .size caml_callback2_exn, .-caml_callback2_exn + + .align 2 + .globl caml_callback3_exn +caml_callback3_exn: + CFI_STARTPROC + PROFILE + /* Initial shuffling of arguments */ + /* (x0 = closure, x1 = arg1, x2 = arg2, x3 = arg3) */ + mov TMP, x0 + mov x0, x1 /* x0 = first arg */ + mov x1, x2 /* x1 = second arg */ + mov x2, x3 /* x2 = third arg */ + mov x3, TMP /* x3 = closure environment */ + ADDRGLOBAL(ARG, caml_apply3) + b .Ljump_to_caml + CFI_ENDPROC + .type caml_callback3_exn, %function + .size caml_callback3_exn, .-caml_callback3_exn + + .align 2 + .globl caml_ml_array_bound_error +caml_ml_array_bound_error: + CFI_STARTPROC + PROFILE + /* Load address of [caml_array_bound_error] in ARG */ + ADDRGLOBAL(ARG, caml_array_bound_error) + /* Call that function */ + b caml_c_call + CFI_ENDPROC + .type caml_ml_array_bound_error, %function + .size caml_ml_array_bound_error, .-caml_ml_array_bound_error + + .globl caml_system__code_end +caml_system__code_end: + +/* GC roots for callback */ + + .data + .align 3 + .globl caml_system__frametable +caml_system__frametable: + .quad 1 /* one descriptor */ + .quad .Lcaml_retaddr /* return address into callback */ + .short -1 /* negative frame size => use callback link */ + .short 0 /* no roots */ + .align 3 + .type caml_system__frametable, %object + .size caml_system__frametable, .-caml_system__frametable + +/* Mark stack as non-executable */ + .section .note.GNU-stack,"",%progbits diff -Nru ocaml-4.01.0/asmrun/arm.S ocaml-4.05.0/asmrun/arm.S --- ocaml-4.01.0/asmrun/arm.S 2013-01-13 17:20:36.000000000 +0000 +++ ocaml-4.05.0/asmrun/arm.S 2017-07-13 08:56:44.000000000 +0000 @@ -1,16 +1,18 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Benedikt Meurer, University of Siegen */ -/* */ -/* Copyright 1998 Institut National de Recherche en Informatique */ -/* et en Automatique. Copyright 2012 Benedikt Meurer. 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Benedikt Meurer, University of Siegen */ +/* */ +/* Copyright 1998 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* Copyright 2012 Benedikt Meurer. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ /* Asm part of the runtime system, ARM processor */ /* Must be preprocessed by cpp */ @@ -44,6 +46,35 @@ cmp \reg, #0 beq \lbl .endm +#elif defined(SYS_netbsd) + + #if defined(MODEL_armv6) + .arch armv6 + .fpu vfpv2 + .arm + + /* Compatibility macros */ + .macro cbz reg, lbl + cmp \reg, #0 + beq \lbl + .endm + #elif defined(MODEL_armv7) + .arch armv7-a + .fpu vfpv3-d16 + .thumb + #else + #error "Only NetBSD eabihf supported" + #endif + +#elif defined(SYS_freebsd) + .arch armv6 + .arm + + /* Compatibility macros */ + .macro cbz reg, lbl + cmp \reg, #0 + beq \lbl + .endm #endif trap_ptr .req r8 @@ -64,7 +95,9 @@ /* Support for profiling with gprof */ -#if defined(PROFILING) && (defined(SYS_linux_eabihf) || defined(SYS_linux_eabi)) +#if defined(PROFILING) && (defined(SYS_linux_eabihf) \ + || defined(SYS_linux_eabi) \ + || defined(SYS_netbsd)) #define PROFILE \ push {lr}; CFI_ADJUST(4); \ bl __gnu_mcount_nc; CFI_ADJUST(-4) @@ -89,7 +122,7 @@ /* Record lowest stack address */ ldr r12, =caml_bottom_of_stack str sp, [r12] -#if defined(SYS_linux_eabihf) +#if defined(SYS_linux_eabihf) || defined(SYS_netbsd) /* Save caller floating-point registers on the stack */ vpush {d0-d7}; CFI_ADJUST(64) #endif @@ -108,7 +141,7 @@ bl caml_garbage_collection /* Restore integer registers and return address from the stack */ pop {r0-r7,r12,lr}; CFI_ADJUST(-40) -#if defined(SYS_linux_eabihf) +#if defined(SYS_linux_eabihf) || defined(SYS_netbsd) /* Restore floating-point registers from the stack */ vpop {d0-d7}; CFI_ADJUST(-64) #endif @@ -263,7 +296,7 @@ /* Arguments to the OCaml code are in r0...r3 */ .Ljump_to_caml: -#if defined(SYS_linux_eabihf) +#if defined(SYS_linux_eabihf) || defined(SYS_netbsd) /* Save callee-save floating-point registers */ vpush {d8-d15}; CFI_ADJUST(64) #endif @@ -318,7 +351,7 @@ str alloc_ptr, [r4] /* Reload callee-save registers and return address */ pop {r4-r8,r10,r11,lr}; CFI_ADJUST(-32) -#if defined(SYS_linux_eabihf) +#if defined(SYS_linux_eabihf) || defined(SYS_netbsd) /* Reload callee-save floating-point registers */ vpop {d8-d15}; CFI_ADJUST(-64) #endif @@ -489,3 +522,6 @@ .align 2 .type caml_system__frametable, %object .size caml_system__frametable, .-caml_system__frametable + +/* Mark stack as non-executable */ + .section .note.GNU-stack,"",%progbits diff -Nru ocaml-4.01.0/asmrun/backtrace.c ocaml-4.05.0/asmrun/backtrace.c --- ocaml-4.01.0/asmrun/backtrace.c 2013-07-23 14:48:47.000000000 +0000 +++ ocaml-4.05.0/asmrun/backtrace.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,355 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ -/* */ -/* Copyright 2006 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. */ -/* */ -/***********************************************************************/ - -/* Stack backtrace for uncaught exceptions */ - -#include -#include -#include - -#include "alloc.h" -#include "backtrace.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "stack.h" - -int caml_backtrace_active = 0; -int caml_backtrace_pos = 0; -code_t * caml_backtrace_buffer = NULL; -value caml_backtrace_last_exn = Val_unit; -#define BACKTRACE_BUFFER_SIZE 1024 - -/* Start or stop the backtrace machinery */ - -CAMLprim value caml_record_backtrace(value vflag) -{ - int flag = Int_val(vflag); - - if (flag != caml_backtrace_active) { - caml_backtrace_active = flag; - caml_backtrace_pos = 0; - if (flag) { - caml_register_global_root(&caml_backtrace_last_exn); - } else { - caml_remove_global_root(&caml_backtrace_last_exn); - } - } - return Val_unit; -} - -/* Return the status of the backtrace machinery */ - -CAMLprim value caml_backtrace_status(value vunit) -{ - return Val_bool(caml_backtrace_active); -} - -/* returns the next frame descriptor (or NULL if none is available), - and updates *pc and *sp to point to the following one. */ - -frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp) -{ - frame_descr * d; - uintnat h; - - if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); - - while (1) { - h = Hash_retaddr(*pc); - while (1) { - d = caml_frame_descriptors[h]; - if (d == 0) return NULL; /* can happen if some code compiled without -g */ - if (d->retaddr == *pc) break; - h = (h+1) & caml_frame_descriptors_mask; - } - /* Skip to next frame */ - if (d->frame_size != 0xFFFF) { - /* Regular frame, update sp/pc and return the frame descriptor */ -#ifndef Stack_grows_upwards - *sp += (d->frame_size & 0xFFFC); -#else - *sp -= (d->frame_size & 0xFFFC); -#endif - *pc = Saved_return_address(*sp); -#ifdef Mask_already_scanned - *pc = Mask_already_scanned(*pc); -#endif - return d; - } else { - /* Special frame marking the top of a stack chunk for an ML callback. - Skip C portion of stack and continue with next ML stack chunk. */ - struct caml_context * next_context = Callback_link(*sp); - *sp = next_context->bottom_of_stack; - *pc = next_context->last_retaddr; - /* A null sp means no more ML stack chunks; stop here. */ - if (*sp == NULL) return NULL; - } - } -} - -/* Stores the return addresses contained in the given stack fragment - into the backtrace array ; this version is performance-sensitive as - it is called at each [raise] in a program compiled with [-g], so we - preserved the global, statically bounded buffer of the old - implementation -- before the more flexible - [caml_get_current_callstack] was implemented. */ - -void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) -{ - if (exn != caml_backtrace_last_exn) { - caml_backtrace_pos = 0; - caml_backtrace_last_exn = exn; - } - if (caml_backtrace_buffer == NULL) { - caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); - if (caml_backtrace_buffer == NULL) return; - } - - /* iterate on each frame */ - while (1) { - frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); - if (descr == NULL) return; - /* store its descriptor in the backtrace buffer */ - if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; - caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) descr; - - /* Stop when we reach the current exception handler */ -#ifndef Stack_grows_upwards - if (sp > trapsp) return; -#else - if (sp < trapsp) return; -#endif - } -} - -/* Stores upto [max_frames_value] frames of the current call stack to - return to the user. This is used not in an exception-raising - context, but only when the user requests to save the trace - (hopefully less often). Instead of using a bounded buffer as - [caml_stash_backtrace], we first traverse the stack to compute the - right size, then allocate space for the trace. */ - -CAMLprim value caml_get_current_callstack(value max_frames_value) { - CAMLparam1(max_frames_value); - CAMLlocal1(trace); - - /* we use `intnat` here because, were it only `int`, passing `max_int` - from the OCaml side would overflow on 64bits machines. */ - intnat max_frames = Long_val(max_frames_value); - intnat trace_size; - - /* first compute the size of the trace */ - { - uintnat pc = caml_last_return_address; - /* note that [caml_bottom_of_stack] always points to the most recent - * frame, independently of the [Stack_grows_upwards] setting */ - char * sp = caml_bottom_of_stack; - char * limitsp = caml_top_of_stack; - - trace_size = 0; - while (1) { - frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); - if (descr == NULL) break; - if (trace_size >= max_frames) break; - ++trace_size; - -#ifndef Stack_grows_upwards - if (sp > limitsp) break; -#else - if (sp < limitsp) break; -#endif - } - } - - trace = caml_alloc((mlsize_t) trace_size, Abstract_tag); - - /* then collect the trace */ - { - uintnat pc = caml_last_return_address; - char * sp = caml_bottom_of_stack; - intnat trace_pos; - - for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { - frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); - Assert(descr != NULL); - /* The assignment below is safe without [caml_initialize], even - if the trace is large and allocated on the old heap, because - we assign values that are outside the OCaml heap. */ - Assert(!(Is_block((value) descr) && Is_in_heap((value) descr))); - Field(trace, trace_pos) = (value) descr; - } - } - - CAMLreturn(trace); -} - -/* Extract location information for the given frame descriptor */ - -struct loc_info { - int loc_valid; - int loc_is_raise; - char * loc_filename; - int loc_lnum; - int loc_startchr; - int loc_endchr; -}; - -static void extract_location_info(frame_descr * d, - /*out*/ struct loc_info * li) -{ - uintnat infoptr; - uint32 info1, info2; - - /* If no debugging information available, print nothing. - When everything is compiled with -g, this corresponds to - compiler-inserted re-raise operations. */ - if ((d->frame_size & 1) == 0) { - li->loc_valid = 0; - li->loc_is_raise = 1; - return; - } - /* Recover debugging info */ - infoptr = ((uintnat) d + - sizeof(char *) + sizeof(short) + sizeof(short) + - sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) - & -sizeof(frame_descr *); - info1 = ((uint32 *)infoptr)[0]; - info2 = ((uint32 *)infoptr)[1]; - /* Format of the two info words: - llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk - 44 36 26 2 0 - (32+12) (32+4) - k ( 2 bits): 0 if it's a call, 1 if it's a raise - n (24 bits): offset (in 4-byte words) of file name relative to infoptr - l (20 bits): line number - a ( 8 bits): beginning of character range - b (10 bits): end of character range */ - li->loc_valid = 1; - li->loc_is_raise = (info1 & 3) != 0; - li->loc_filename = (char *) infoptr + (info1 & 0x3FFFFFC); - li->loc_lnum = info2 >> 12; - li->loc_startchr = (info2 >> 4) & 0xFF; - li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26); -} - -/* Print location information -- same behavior as in Printexc - - note that the test for compiler-inserted raises is slightly redundant: - (!li->loc_valid && li->loc_is_raise) - extract_location_info above guarantees that when li->loc_valid is - 0, then li->loc_is_raise is always 1, so the latter test is - useless. We kept it to keep code identical to the byterun/ - implementation. */ - -static void print_location(struct loc_info * li, int index) -{ - char * info; - - /* Ignore compiler-inserted raise */ - if (!li->loc_valid && li->loc_is_raise) return; - - if (li->loc_is_raise) { - /* Initial raise if index == 0, re-raise otherwise */ - if (index == 0) - info = "Raised at"; - else - info = "Re-raised at"; - } else { - if (index == 0) - info = "Raised by primitive operation at"; - else - info = "Called from"; - } - if (! li->loc_valid) { - fprintf(stderr, "%s unknown location\n", info); - } else { - fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", - info, li->loc_filename, li->loc_lnum, - li->loc_startchr, li->loc_endchr); - } -} - -/* Print a backtrace */ - -void caml_print_exception_backtrace(void) -{ - int i; - struct loc_info li; - - for (i = 0; i < caml_backtrace_pos; i++) { - extract_location_info((frame_descr *) (caml_backtrace_buffer[i]), &li); - print_location(&li, i); - } -} - -/* Convert the raw backtrace to a data structure usable from OCaml */ - -CAMLprim value caml_convert_raw_backtrace(value backtrace) { - CAMLparam1(backtrace); - CAMLlocal4(res, arr, p, fname); - int i; - struct loc_info li; - - arr = caml_alloc(Wosize_val(backtrace), 0); - for (i = 0; i < Wosize_val(backtrace); i++) { - extract_location_info((frame_descr *) Field(backtrace, i), &li); - if (li.loc_valid) { - fname = caml_copy_string(li.loc_filename); - p = caml_alloc_small(5, 0); - Field(p, 0) = Val_bool(li.loc_is_raise); - Field(p, 1) = fname; - Field(p, 2) = Val_int(li.loc_lnum); - Field(p, 3) = Val_int(li.loc_startchr); - Field(p, 4) = Val_int(li.loc_endchr); - } else { - p = caml_alloc_small(1, 1); - Field(p, 0) = Val_bool(li.loc_is_raise); - } - caml_modify(&Field(arr, i), p); - } - res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ - CAMLreturn(res); -} - -/* Get a copy of the latest backtrace */ - -CAMLprim value caml_get_exception_raw_backtrace(value unit) -{ - CAMLparam0(); - CAMLlocal1(res); - res = caml_alloc(caml_backtrace_pos, Abstract_tag); - if(caml_backtrace_buffer != NULL) - memcpy(&Field(res, 0), caml_backtrace_buffer, - caml_backtrace_pos * sizeof(code_t)); - CAMLreturn(res); -} - -/* the function below is deprecated: we previously returned directly - the OCaml-usable representation, instead of the raw backtrace as an - abstract type, but this has a large performance overhead if you - store a lot of backtraces and print only some of them. - - It is not used by the Printexc library anymore, or anywhere else in - the compiler, but we have kept it in case some user still depends - on it as an external. -*/ - -CAMLprim value caml_get_exception_backtrace(value unit) -{ - CAMLparam0(); - CAMLlocal2(raw,res); - raw = caml_get_exception_raw_backtrace(unit); - res = caml_convert_raw_backtrace(raw); - CAMLreturn(res); -} diff -Nru ocaml-4.01.0/asmrun/backtrace_prim.c ocaml-4.05.0/asmrun/backtrace_prim.c --- ocaml-4.01.0/asmrun/backtrace_prim.c 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmrun/backtrace_prim.c 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,249 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ +/* */ +/* Copyright 2006 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +/* Stack backtrace for uncaught exceptions */ + +#include +#include +#include + +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/backtrace_prim.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/stack.h" + +/* Returns the next frame descriptor (or NULL if none is available), + and updates *pc and *sp to point to the following one. */ +frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp) +{ + frame_descr * d; + uintnat h; + + while (1) { + h = Hash_retaddr(*pc); + while (1) { + d = caml_frame_descriptors[h]; + if (d == NULL) return NULL; /* happens if some code compiled without -g */ + if (d->retaddr == *pc) break; + h = (h+1) & caml_frame_descriptors_mask; + } + /* Skip to next frame */ + if (d->frame_size != 0xFFFF) { + /* Regular frame, update sp/pc and return the frame descriptor */ +#ifndef Stack_grows_upwards + *sp += (d->frame_size & 0xFFFC); +#else + *sp -= (d->frame_size & 0xFFFC); +#endif + *pc = Saved_return_address(*sp); +#ifdef Mask_already_scanned + *pc = Mask_already_scanned(*pc); +#endif + return d; + } else { + /* Special frame marking the top of a stack chunk for an ML callback. + Skip C portion of stack and continue with next ML stack chunk. */ + struct caml_context * next_context = Callback_link(*sp); + *sp = next_context->bottom_of_stack; + *pc = next_context->last_retaddr; + /* A null sp means no more ML stack chunks; stop here. */ + if (*sp == NULL) return NULL; + } + } +} + +int caml_alloc_backtrace_buffer(void){ + Assert(caml_backtrace_pos == 0); + caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE + * sizeof(backtrace_slot)); + if (caml_backtrace_buffer == NULL) return -1; + return 0; +} + +/* Stores the return addresses contained in the given stack fragment + into the backtrace array ; this version is performance-sensitive as + it is called at each [raise] in a program compiled with [-g], so we + preserved the global, statically bounded buffer of the old + implementation -- before the more flexible + [caml_get_current_callstack] was implemented. */ +void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) +{ + if (exn != caml_backtrace_last_exn) { + caml_backtrace_pos = 0; + caml_backtrace_last_exn = exn; + } + + if (caml_backtrace_buffer == NULL && caml_alloc_backtrace_buffer() == -1) + return; + + /* iterate on each frame */ + while (1) { + frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); + if (descr == NULL) return; + /* store its descriptor in the backtrace buffer */ + if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; + caml_backtrace_buffer[caml_backtrace_pos++] = (backtrace_slot) descr; + + /* Stop when we reach the current exception handler */ +#ifndef Stack_grows_upwards + if (sp > trapsp) return; +#else + if (sp < trapsp) return; +#endif + } +} + +/* Stores upto [max_frames_value] frames of the current call stack to + return to the user. This is used not in an exception-raising + context, but only when the user requests to save the trace + (hopefully less often). Instead of using a bounded buffer as + [caml_stash_backtrace], we first traverse the stack to compute the + right size, then allocate space for the trace. */ +CAMLprim value caml_get_current_callstack(value max_frames_value) +{ + CAMLparam1(max_frames_value); + CAMLlocal1(trace); + + /* we use `intnat` here because, were it only `int`, passing `max_int` + from the OCaml side would overflow on 64bits machines. */ + intnat max_frames = Long_val(max_frames_value); + intnat trace_size; + + /* first compute the size of the trace */ + { + uintnat pc = caml_last_return_address; + /* note that [caml_bottom_of_stack] always points to the most recent + * frame, independently of the [Stack_grows_upwards] setting */ + char * sp = caml_bottom_of_stack; + char * limitsp = caml_top_of_stack; + + trace_size = 0; + while (1) { + frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); + if (descr == NULL) break; + if (trace_size >= max_frames) break; + ++trace_size; + +#ifndef Stack_grows_upwards + if (sp > limitsp) break; +#else + if (sp < limitsp) break; +#endif + } + } + + trace = caml_alloc((mlsize_t) trace_size, 0); + + /* then collect the trace */ + { + uintnat pc = caml_last_return_address; + char * sp = caml_bottom_of_stack; + intnat trace_pos; + + for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { + frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); + Assert(descr != NULL); + Field(trace, trace_pos) = Val_backtrace_slot((backtrace_slot) descr); + } + } + + CAMLreturn(trace); +} + + +debuginfo caml_debuginfo_extract(backtrace_slot slot) +{ + uintnat infoptr; + frame_descr * d = (frame_descr *)slot; + + if ((d->frame_size & 1) == 0) { + return NULL; + } + /* Recover debugging info */ + infoptr = ((uintnat) d + + sizeof(char *) + sizeof(short) + sizeof(short) + + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) + & -sizeof(frame_descr *); + return *((debuginfo*)infoptr); +} + +debuginfo caml_debuginfo_next(debuginfo dbg) +{ + uint32_t * infoptr; + + if (dbg == NULL) + return NULL; + + infoptr = dbg; + infoptr += 2; /* Two packed info fields */ + return *((debuginfo*)infoptr); +} + +/* Extract location information for the given frame descriptor */ +void caml_debuginfo_location(debuginfo dbg, /*out*/ struct caml_loc_info * li) +{ + uint32_t info1, info2; + + /* If no debugging information available, print nothing. + When everything is compiled with -g, this corresponds to + compiler-inserted re-raise operations. */ + if (dbg == NULL) { + li->loc_valid = 0; + li->loc_is_raise = 1; + li->loc_is_inlined = 0; + return; + } + /* Recover debugging info */ + info1 = ((uint32_t *)dbg)[0]; + info2 = ((uint32_t *)dbg)[1]; + /* Format of the two info words: + llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk + 44 36 26 2 0 + (32+12) (32+4) + k ( 2 bits): 0 if it's a call + 1 if it's a raise + n (24 bits): offset (in 4-byte words) of file name relative to dbg + l (20 bits): line number + a ( 8 bits): beginning of character range + b (10 bits): end of character range */ + li->loc_valid = 1; + li->loc_is_raise = (info1 & 3) == 1; + li->loc_is_inlined = caml_debuginfo_next(dbg) != NULL; + li->loc_filename = (char *) dbg + (info1 & 0x3FFFFFC); + li->loc_lnum = info2 >> 12; + li->loc_startchr = (info2 >> 4) & 0xFF; + li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26); +} + +CAMLprim value caml_add_debug_info(backtrace_slot start, value size, + value events) +{ + return Val_unit; +} + +CAMLprim value caml_remove_debug_info(backtrace_slot start) +{ + return Val_unit; +} + +int caml_debug_info_available(void) +{ + return 1; +} diff -Nru ocaml-4.01.0/asmrun/clambda_checks.c ocaml-4.05.0/asmrun/clambda_checks.c --- ocaml-4.01.0/asmrun/clambda_checks.c 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmrun/clambda_checks.c 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,89 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Pierre Chambart, OCamlPro */ +/* Mark Shinwell, Jane Street Europe */ +/* */ +/* Copyright 2013--2016 OCamlPro SAS */ +/* Copyright 2014--2016 Jane Street Group LLC */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Runtime checks to try to catch errors in code generation. + See flambda_to_clambda.ml for more information. */ + +#include +#include + +#include + +value caml_check_value_is_closure(value v, value v_descr) +{ + const char* descr = String_val(v_descr); + value orig_v = v; + + if (v == (value) 0) { + fprintf(stderr, "NULL is not a closure: %s\n", + descr); + abort(); + } + if (!Is_block(v)) { + fprintf(stderr, + "Expecting a closure, got a non-boxed value %p: %s\n", + (void*) v, descr); + abort(); + } + if (!(Tag_val(v) == Closure_tag || Tag_val(v) == Infix_tag)) { + fprintf(stderr, + "Expecting a closure, got a boxed value with tag %i: %s\n", + Tag_val(v), descr); + abort(); + } + if (Tag_val(v) == Infix_tag) { + v -= Infix_offset_val(v); + assert(Tag_val(v) == Closure_tag); + } + assert(Wosize_val(v) >= 2); + + return orig_v; +} + +value caml_check_field_access(value v, value pos, value v_descr) +{ + const char* descr = String_val(v_descr); + value orig_v = v; + if (v == (value) 0) { + fprintf(stderr, + "Access to field %" ARCH_INT64_PRINTF_FORMAT + "u of NULL: %s\n", (ARCH_UINT64_TYPE) Long_val(pos), descr); + abort(); + } + if (!Is_block(v)) { + fprintf(stderr, + "Access to field %" ARCH_INT64_PRINTF_FORMAT + "u of non-boxed value %p is illegal: %s\n", + (ARCH_UINT64_TYPE) Long_val(pos), (void*) v, descr); + abort(); + } + if (Tag_val(v) == Infix_tag) { + uintnat offset = Infix_offset_val(v); + v -= offset; + pos += offset / sizeof(value); + } + assert(Long_val(pos) >= 0); + if (Long_val(pos) >= Wosize_val(v)) { + fprintf(stderr, + "Access to field %" ARCH_INT64_PRINTF_FORMAT + "u of value %p of size %" ARCH_INT64_PRINTF_FORMAT "u is illegal: %s\n", + (ARCH_UINT64_TYPE) Long_val(pos), (void*) v, + (ARCH_UINT64_TYPE) Wosize_val(v), + descr); + abort(); + } + return orig_v; +} diff -Nru ocaml-4.01.0/asmrun/.depend ocaml-4.05.0/asmrun/.depend --- ocaml-4.01.0/asmrun/.depend 2013-08-15 16:13:16.000000000 +0000 +++ ocaml-4.05.0/asmrun/.depend 2017-07-13 08:56:44.000000000 +0000 @@ -1,753 +1,1520 @@ -alloc.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h -array.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h -backtrace.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h -callback.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h -compact.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h -compare.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h -custom.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -debugger.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ - ../byterun/misc.h -dynlink.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ - ../byterun/prims.h -extern.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h -fail.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ - ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h -finalise.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/signals.h -floats.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h -freelist.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h -gc_ctrl.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h stack.h -globroots.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/globroots.h ../byterun/roots.h -hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h -intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h -ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h -io.o: io.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ - ../byterun/sys.h -lexing.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h -main.o: main.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/sys.h -major_gc.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h -md5.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ - ../byterun/reverse.h -memory.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/signals.h -meta.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ - ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h -minor_gc.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ - ../byterun/weak.h -misc.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -natdynlink.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ - ../byterun/fail.h -obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h -parsing.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h -printexc.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h -roots.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h stack.h ../byterun/roots.h -signals.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ - ../byterun/sys.h -signals_asm.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ - signals_osdep.h stack.h -startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ - ../byterun/printexc.h stack.h ../byterun/sys.h -str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h -sys.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -terminfo.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/mlvalues.h -unix.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/osdeps.h -weak.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h -alloc.d.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h -array.d.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h -backtrace.d.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h -callback.d.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h -compact.d.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h -compare.d.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h -custom.d.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -debugger.d.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ - ../byterun/misc.h -dynlink.d.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ - ../byterun/prims.h -extern.d.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h -fail.d.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ - ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h -finalise.d.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/signals.h -floats.d.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h -freelist.d.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h -gc_ctrl.d.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h stack.h -globroots.d.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/globroots.h ../byterun/roots.h -hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h -intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h -ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h -io.d.o: io.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ - ../byterun/sys.h -lexing.d.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h -main.d.o: main.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/sys.h -major_gc.d.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h -md5.d.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ - ../byterun/reverse.h -memory.d.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/signals.h -meta.d.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ - ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h -minor_gc.d.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ - ../byterun/weak.h -misc.d.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -natdynlink.d.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ - ../byterun/fail.h -obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h -parsing.d.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h -printexc.d.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h -roots.d.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h stack.h ../byterun/roots.h -signals.d.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ - ../byterun/sys.h -signals_asm.d.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ - signals_osdep.h stack.h -startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ - ../byterun/printexc.h stack.h ../byterun/sys.h -str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h -sys.d.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -terminfo.d.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/mlvalues.h -unix.d.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/osdeps.h -weak.d.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h -alloc.p.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h -array.p.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h -backtrace.p.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h -callback.p.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h -compact.p.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h -compare.p.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h -custom.p.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -debugger.p.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ - ../byterun/misc.h -dynlink.p.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ - ../byterun/prims.h -extern.p.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h -fail.p.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ - ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h -finalise.p.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/signals.h -floats.p.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h -freelist.p.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h -gc_ctrl.p.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h stack.h -globroots.p.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/globroots.h ../byterun/roots.h -hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h -intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h -ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h -io.p.o: io.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ - ../byterun/sys.h -lexing.p.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h -main.p.o: main.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/sys.h -major_gc.p.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h -md5.p.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ - ../byterun/reverse.h -memory.p.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/signals.h -meta.p.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ - ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h -minor_gc.p.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ - ../byterun/weak.h -misc.p.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -natdynlink.p.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ - ../byterun/fail.h -obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h -parsing.p.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h -printexc.p.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h -roots.p.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h stack.h ../byterun/roots.h -signals.p.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ - ../byterun/sys.h -signals_asm.p.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ - signals_osdep.h stack.h -startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ - ../byterun/printexc.h stack.h ../byterun/sys.h -str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h -sys.p.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -terminfo.p.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/mlvalues.h -unix.p.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/osdeps.h -weak.p.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h +afl.o: afl.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h +alloc.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/stacks.h +array.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h ../byterun/caml/spacetime.h \ + ../byterun/caml/io.h ../byterun/caml/stack.h +backtrace.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/backtrace_prim.h ../byterun/caml/fail.h +backtrace_prim.o: backtrace_prim.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace.h \ + ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h +callback.o: callback.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h +clambda_checks.o: clambda_checks.c ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h +compact.o: compact.c ../byterun/caml/address_class.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \ + ../byterun/caml/weak.h ../byterun/caml/compact.h +compare.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +custom.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +debugger.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/debugger.h ../byterun/caml/osdeps.h +dynlink.o: dynlink.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/prims.h \ + ../byterun/caml/signals.h +extern.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/md5.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/reverse.h +fail.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/printexc.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/roots.h ../byterun/caml/callback.h +finalise.o: finalise.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/compact.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h +floats.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/reverse.h ../byterun/caml/stacks.h +freelist.o: freelist.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/freelist.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h +gc_ctrl.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/compact.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/startup_aux.h +globroots.o: globroots.c ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/globroots.h +hash.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/hash.h +intern.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/md5.h ../byterun/caml/memory.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/reverse.h +ints.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h +io.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h +lexing.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/stacks.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +main.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/sys.h +major_gc.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/weak.h +md5.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/reverse.h +memory.o: memory.c ../byterun/caml/address_class.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/signals.h +meta.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/fix_code.h \ + ../byterun/caml/interp.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/prims.h ../byterun/caml/stacks.h +minor_gc.o: minor_gc.c ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/weak.h +misc.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/version.h +natdynlink.o: natdynlink.c ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h ../byterun/caml/hooks.h +obj.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/prims.h \ + ../byterun/caml/spacetime.h ../byterun/caml/io.h \ + ../byterun/caml/stack.h +parsing.o: parsing.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/alloc.h +printexc.o: printexc.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h \ + ../byterun/caml/callback.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/printexc.h +roots.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/stack.h +signals.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/signals_machdep.h ../byterun/caml/sys.h +signals_asm.o: signals_asm.c ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ + signals_osdep.h ../byterun/caml/stack.h ../byterun/caml/spacetime.h \ + ../byterun/caml/io.h +spacetime.o: spacetime.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/sys.h ../byterun/caml/spacetime.h +spacetime_offline.o: spacetime_offline.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/sys.h ../byterun/caml/spacetime.h ../config/s.h +spacetime_snapshot.o: spacetime_snapshot.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/sys.h \ + ../byterun/caml/spacetime.h +startup.o: startup.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/backtrace.h \ + ../byterun/caml/exec.h ../byterun/caml/custom.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/printexc.h ../byterun/caml/stack.h \ + ../byterun/caml/startup_aux.h ../byterun/caml/sys.h +startup_aux.o: startup_aux.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/startup_aux.h +str.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h +sys.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/instruct.h \ + ../byterun/caml/io.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/sys.h ../byterun/caml/version.h +terminfo.o: terminfo.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h +unix.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h ../byterun/caml/io.h +weak.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/weak.h +afl.p.o: afl.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h +alloc.p.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/stacks.h +array.p.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h ../byterun/caml/spacetime.h \ + ../byterun/caml/io.h ../byterun/caml/stack.h +backtrace.p.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/backtrace_prim.h ../byterun/caml/fail.h +backtrace_prim.p.o: backtrace_prim.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace.h \ + ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h +callback.p.o: callback.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h +clambda_checks.p.o: clambda_checks.c ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h +compact.p.o: compact.c ../byterun/caml/address_class.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \ + ../byterun/caml/weak.h ../byterun/caml/compact.h +compare.p.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +custom.p.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +debugger.p.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/debugger.h ../byterun/caml/osdeps.h +dynlink.p.o: dynlink.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/prims.h \ + ../byterun/caml/signals.h +extern.p.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/md5.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/reverse.h +fail.p.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/printexc.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/roots.h ../byterun/caml/callback.h +finalise.p.o: finalise.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/compact.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h +floats.p.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/reverse.h ../byterun/caml/stacks.h +freelist.p.o: freelist.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/freelist.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h +gc_ctrl.p.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/compact.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/startup_aux.h +globroots.p.o: globroots.c ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/globroots.h +hash.p.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/hash.h +intern.p.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/md5.h ../byterun/caml/memory.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/reverse.h +ints.p.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h +io.p.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h +lexing.p.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/stacks.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +main.p.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/sys.h +major_gc.p.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/weak.h +md5.p.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/reverse.h +memory.p.o: memory.c ../byterun/caml/address_class.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/signals.h +meta.p.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/fix_code.h \ + ../byterun/caml/interp.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/prims.h ../byterun/caml/stacks.h +minor_gc.p.o: minor_gc.c ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/weak.h +misc.p.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/version.h +natdynlink.p.o: natdynlink.c ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h ../byterun/caml/hooks.h +obj.p.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/prims.h \ + ../byterun/caml/spacetime.h ../byterun/caml/io.h \ + ../byterun/caml/stack.h +parsing.p.o: parsing.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/alloc.h +printexc.p.o: printexc.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h \ + ../byterun/caml/callback.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/printexc.h +roots.p.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/stack.h +signals.p.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/signals_machdep.h ../byterun/caml/sys.h +signals_asm.p.o: signals_asm.c ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ + signals_osdep.h ../byterun/caml/stack.h ../byterun/caml/spacetime.h \ + ../byterun/caml/io.h +spacetime.p.o: spacetime.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/sys.h ../byterun/caml/spacetime.h +spacetime_offline.p.o: spacetime_offline.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/sys.h ../byterun/caml/spacetime.h ../config/s.h +spacetime_snapshot.p.o: spacetime_snapshot.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/sys.h \ + ../byterun/caml/spacetime.h +startup.p.o: startup.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/backtrace.h \ + ../byterun/caml/exec.h ../byterun/caml/custom.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/printexc.h ../byterun/caml/stack.h \ + ../byterun/caml/startup_aux.h ../byterun/caml/sys.h +startup_aux.p.o: startup_aux.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/startup_aux.h +str.p.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h +sys.p.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/instruct.h \ + ../byterun/caml/io.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/sys.h ../byterun/caml/version.h +terminfo.p.o: terminfo.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h +unix.p.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h ../byterun/caml/io.h +weak.p.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/weak.h +afl.d.o: afl.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h +alloc.d.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/stacks.h +array.d.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h ../byterun/caml/spacetime.h \ + ../byterun/caml/io.h ../byterun/caml/stack.h +backtrace.d.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/backtrace_prim.h ../byterun/caml/fail.h +backtrace_prim.d.o: backtrace_prim.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace.h \ + ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h +callback.d.o: callback.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h +clambda_checks.d.o: clambda_checks.c ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h +compact.d.o: compact.c ../byterun/caml/address_class.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \ + ../byterun/caml/weak.h ../byterun/caml/compact.h +compare.d.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +custom.d.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +debugger.d.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/debugger.h ../byterun/caml/osdeps.h +dynlink.d.o: dynlink.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/prims.h \ + ../byterun/caml/signals.h +extern.d.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/md5.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/reverse.h +fail.d.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/printexc.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/roots.h ../byterun/caml/callback.h +finalise.d.o: finalise.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/compact.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h +floats.d.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/reverse.h ../byterun/caml/stacks.h +freelist.d.o: freelist.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/freelist.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h +gc_ctrl.d.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/compact.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/startup_aux.h +globroots.d.o: globroots.c ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/globroots.h +hash.d.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/hash.h +intern.d.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/md5.h ../byterun/caml/memory.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/reverse.h +ints.d.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h +io.d.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h +lexing.d.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/stacks.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +main.d.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/sys.h +major_gc.d.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/weak.h +md5.d.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/reverse.h +memory.d.o: memory.c ../byterun/caml/address_class.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/signals.h +meta.d.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/fix_code.h \ + ../byterun/caml/interp.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/prims.h ../byterun/caml/stacks.h +minor_gc.d.o: minor_gc.c ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/weak.h +misc.d.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/version.h +natdynlink.d.o: natdynlink.c ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h ../byterun/caml/hooks.h +obj.d.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/prims.h \ + ../byterun/caml/spacetime.h ../byterun/caml/io.h \ + ../byterun/caml/stack.h +parsing.d.o: parsing.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/alloc.h +printexc.d.o: printexc.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h \ + ../byterun/caml/callback.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/printexc.h +roots.d.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/stack.h +signals.d.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/signals_machdep.h ../byterun/caml/sys.h +signals_asm.d.o: signals_asm.c ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ + signals_osdep.h ../byterun/caml/stack.h ../byterun/caml/spacetime.h \ + ../byterun/caml/io.h +spacetime.d.o: spacetime.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/sys.h ../byterun/caml/spacetime.h +spacetime_offline.d.o: spacetime_offline.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/sys.h ../byterun/caml/spacetime.h ../config/s.h +spacetime_snapshot.d.o: spacetime_snapshot.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/sys.h \ + ../byterun/caml/spacetime.h +startup.d.o: startup.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/backtrace.h \ + ../byterun/caml/exec.h ../byterun/caml/custom.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/printexc.h ../byterun/caml/stack.h \ + ../byterun/caml/startup_aux.h ../byterun/caml/sys.h +startup_aux.d.o: startup_aux.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/startup_aux.h +str.d.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h +sys.d.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/instruct.h \ + ../byterun/caml/io.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/sys.h ../byterun/caml/version.h +terminfo.d.o: terminfo.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h +unix.d.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h ../byterun/caml/io.h +weak.d.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/weak.h +afl.i.o: afl.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h +alloc.i.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/stacks.h +array.i.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h ../byterun/caml/spacetime.h \ + ../byterun/caml/io.h ../byterun/caml/stack.h +backtrace.i.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/backtrace_prim.h ../byterun/caml/fail.h +backtrace_prim.i.o: backtrace_prim.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace.h \ + ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h +callback.i.o: callback.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h +clambda_checks.i.o: clambda_checks.c ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h +compact.i.o: compact.c ../byterun/caml/address_class.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \ + ../byterun/caml/weak.h ../byterun/caml/compact.h +compare.i.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +custom.i.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +debugger.i.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/debugger.h ../byterun/caml/osdeps.h +dynlink.i.o: dynlink.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/prims.h \ + ../byterun/caml/signals.h +extern.i.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/md5.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/reverse.h +fail.i.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/printexc.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/roots.h ../byterun/caml/callback.h +finalise.i.o: finalise.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/compact.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h +floats.i.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/reverse.h ../byterun/caml/stacks.h +freelist.i.o: freelist.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/freelist.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h +gc_ctrl.i.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/compact.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/startup_aux.h +globroots.i.o: globroots.c ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/globroots.h +hash.i.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/hash.h +intern.i.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/md5.h ../byterun/caml/memory.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/reverse.h +ints.i.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h +io.i.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h +lexing.i.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/stacks.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +main.i.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/sys.h +major_gc.i.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/weak.h +md5.i.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/reverse.h +memory.i.o: memory.c ../byterun/caml/address_class.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/signals.h +meta.i.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/fix_code.h \ + ../byterun/caml/interp.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/prims.h ../byterun/caml/stacks.h +minor_gc.i.o: minor_gc.c ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/weak.h +misc.i.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/version.h +natdynlink.i.o: natdynlink.c ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h ../byterun/caml/hooks.h +obj.i.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/prims.h \ + ../byterun/caml/spacetime.h ../byterun/caml/io.h \ + ../byterun/caml/stack.h +parsing.i.o: parsing.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/alloc.h +printexc.i.o: printexc.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h \ + ../byterun/caml/callback.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/printexc.h +roots.i.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/stack.h +signals.i.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/signals_machdep.h ../byterun/caml/sys.h +signals_asm.i.o: signals_asm.c ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ + signals_osdep.h ../byterun/caml/stack.h ../byterun/caml/spacetime.h \ + ../byterun/caml/io.h +spacetime.i.o: spacetime.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/sys.h ../byterun/caml/spacetime.h +spacetime_offline.i.o: spacetime_offline.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/sys.h ../byterun/caml/spacetime.h ../config/s.h +spacetime_snapshot.i.o: spacetime_snapshot.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/sys.h \ + ../byterun/caml/spacetime.h +startup.i.o: startup.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/backtrace.h \ + ../byterun/caml/exec.h ../byterun/caml/custom.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/printexc.h ../byterun/caml/stack.h \ + ../byterun/caml/startup_aux.h ../byterun/caml/sys.h +startup_aux.i.o: startup_aux.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/startup_aux.h +str.i.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h +sys.i.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/instruct.h \ + ../byterun/caml/io.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/sys.h ../byterun/caml/version.h +terminfo.i.o: terminfo.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h +unix.i.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/osdeps.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h ../byterun/caml/io.h +weak.i.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/weak.h diff -Nru ocaml-4.01.0/asmrun/fail.c ocaml-4.05.0/asmrun/fail.c --- ocaml-4.01.0/asmrun/fail.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmrun/fail.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,29 +1,35 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Raising exceptions from C. */ +#include #include -#include "alloc.h" -#include "fail.h" -#include "io.h" -#include "gc.h" -#include "memory.h" -#include "mlvalues.h" -#include "printexc.h" -#include "signals.h" -#include "stack.h" -#include "roots.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/gc.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/printexc.h" +#include "caml/signals.h" +#include "caml/stack.h" +#include "caml/roots.h" +#include "caml/callback.h" /* The globals holding predefined exceptions */ @@ -42,13 +48,12 @@ caml_exn_Stack_overflow, caml_exn_Assert_failure, caml_exn_Undefined_recursive_module; -extern caml_generated_constant - caml_bucket_Out_of_memory, - caml_bucket_Stack_overflow; /* Exception raising */ -extern void caml_raise_exception (value bucket) Noreturn; +CAMLnoreturn_start + extern void caml_raise_exception (value bucket) +CAMLnoreturn_end; char * caml_exception_pointer = NULL; @@ -73,13 +78,7 @@ void caml_raise_constant(value tag) { - CAMLparam1 (tag); - CAMLlocal1 (bucket); - - bucket = caml_alloc_small (1, 0); - Field(bucket, 0) = tag; - caml_raise(bucket); - CAMLnoreturn; + caml_raise(tag); } void caml_raise_with_arg(value tag, value arg) @@ -111,7 +110,10 @@ void caml_raise_with_string(value tag, char const *msg) { - caml_raise_with_arg(tag, caml_copy_string(msg)); + CAMLparam1(tag); + value v_msg = caml_copy_string(msg); + caml_raise_with_arg(tag, v_msg); + CAMLnoreturn; } void caml_failwith (char const *msg) @@ -119,27 +121,29 @@ caml_raise_with_string((value) caml_exn_Failure, msg); } +void caml_failwith_value (value msg) +{ + caml_raise_with_arg((value) caml_exn_Failure, msg); +} + void caml_invalid_argument (char const *msg) { caml_raise_with_string((value) caml_exn_Invalid_argument, msg); } -/* To raise [Out_of_memory], we can't use [caml_raise_constant], - because it allocates and we're out of memory... - We therefore use a statically-allocated bucket constructed - by the ocamlopt linker. - This works OK because the exception value for [Out_of_memory] is also - statically allocated out of the heap. - The same applies to Stack_overflow. */ +void caml_invalid_argument_value (value msg) +{ + caml_raise_with_arg((value) caml_exn_Invalid_argument, msg); +} void caml_raise_out_of_memory(void) { - caml_raise((value) &caml_bucket_Out_of_memory); + caml_raise_constant((value) caml_exn_Out_of_memory); } void caml_raise_stack_overflow(void) { - caml_raise((value) &caml_bucket_Stack_overflow); + caml_raise_constant((value) caml_exn_Stack_overflow); } void caml_raise_sys_error(value msg) @@ -167,43 +171,24 @@ caml_raise_constant((value) caml_exn_Sys_blocked_io); } -/* We allocate statically the bucket for the exception because we can't +/* We use a pre-allocated exception because we can't do a GC before the exception is raised (lack of stack descriptors - for the ccall to [caml_array_bound_error]. */ - -#define BOUND_MSG "index out of bounds" -#define BOUND_MSG_LEN (sizeof(BOUND_MSG) - 1) - -static struct { - header_t hdr; - value exn; - value arg; -} array_bound_error_bucket; - -static struct { - header_t hdr; - char data[BOUND_MSG_LEN + sizeof(value)]; -} array_bound_error_msg = { 0, BOUND_MSG }; + for the ccall to [caml_array_bound_error]). */ -static int array_bound_error_bucket_inited = 0; +static value * caml_array_bound_error_exn = NULL; void caml_array_bound_error(void) { - if (! array_bound_error_bucket_inited) { - mlsize_t wosize = (BOUND_MSG_LEN + sizeof(value)) / sizeof(value); - mlsize_t offset_index = Bsize_wsize(wosize) - 1; - array_bound_error_msg.hdr = Make_header(wosize, String_tag, Caml_white); - array_bound_error_msg.data[offset_index] = offset_index - BOUND_MSG_LEN; - array_bound_error_bucket.hdr = Make_header(2, 0, Caml_white); - array_bound_error_bucket.exn = (value) caml_exn_Invalid_argument; - array_bound_error_bucket.arg = (value) array_bound_error_msg.data; - array_bound_error_bucket_inited = 1; - caml_page_table_add(In_static_data, - &array_bound_error_msg, - &array_bound_error_msg + 1); - array_bound_error_bucket_inited = 1; + if (caml_array_bound_error_exn == NULL) { + caml_array_bound_error_exn = + caml_named_value("Pervasives.array_bound_error"); + if (caml_array_bound_error_exn == NULL) { + fprintf(stderr, "Fatal error: exception " + "Invalid_argument(\"index out of bounds\")\n"); + exit(2); + } } - caml_raise((value) &array_bound_error_bucket.exn); + caml_raise(*caml_array_bound_error_exn); } int caml_is_special_exception(value exn) { diff -Nru ocaml-4.01.0/asmrun/i386nt.asm ocaml-4.05.0/asmrun/i386nt.asm --- ocaml-4.01.0/asmrun/i386nt.asm 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmrun/i386nt.asm 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,17 @@ -;*********************************************************************** -;* * -;* OCaml * -;* * -;* 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. * -;* * -;*********************************************************************** +;************************************************************************** +;* * +;* OCaml * +;* * +;* 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 Lesser General Public License version 2.1, with the * +;* special exception on linking described in the file LICENSE. * +;* * +;************************************************************************** ; Asm part of the runtime system, Intel 386 processor, Intel syntax @@ -27,6 +29,7 @@ EXTERN _caml_last_return_address: DWORD EXTERN _caml_gc_regs: DWORD EXTERN _caml_exception_pointer: DWORD + EXTERN _caml_backtrace_pos: DWORD EXTERN _caml_backtrace_active: DWORD EXTERN _caml_stash_backtrace: PROC @@ -225,12 +228,12 @@ ALIGN 4 _caml_raise_exception: test _caml_backtrace_active, 1 - jne L111 + jne L112 mov eax, [esp+4] mov esp, _caml_exception_pointer pop _caml_exception_pointer ret -L111: +L112: mov esi, [esp+4] ; Save exception bucket in esi push _caml_exception_pointer ; arg 4: SP of handler push _caml_bottom_of_stack ; arg 3: SP of raise diff -Nru ocaml-4.01.0/asmrun/i386.S ocaml-4.05.0/asmrun/i386.S --- ocaml-4.01.0/asmrun/i386.S 2013-03-22 18:21:34.000000000 +0000 +++ ocaml-4.05.0/asmrun/i386.S 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,17 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ /* Asm part of the runtime system, Intel 386 processor */ /* Must be preprocessed by cpp */ @@ -19,7 +21,7 @@ /* Linux/BSD with ELF binaries and Solaris do not prefix identifiers with _. Linux/BSD with a.out binaries and NextStep do. */ -#if defined(SYS_solaris) +#if (defined(SYS_solaris) && !defined(__GNUC__)) #define CONCAT(a,b) a/**/b #else #define CONCAT(a,b) a##b @@ -115,13 +117,10 @@ #define PROFILE_C #endif -#ifdef SYS_macosx +/* PR#6038: GCC and Clang seem to require 16-byte alignment nowadays, + even if only MacOS X's ABI formally requires it. */ #define ALIGN_STACK(amount) subl $ amount, %esp ; CFI_ADJUST(amount) #define UNDO_ALIGN_STACK(amount) addl $ amount, %esp ; CFI_ADJUST(-amount) -#else -#define ALIGN_STACK(amount) -#define UNDO_ALIGN_STACK(amount) -#endif /* Allocation */ @@ -304,11 +303,7 @@ LBL(107): /* Pop the exception handler */ popl G(caml_exception_pointer); CFI_ADJUST(-4) -#ifdef SYS_macosx addl $12, %esp ; CFI_ADJUST(-12) -#else - addl $4, %esp ; CFI_ADJUST(-4) -#endif LBL(109): /* Pop the callback link, restoring the global variables */ popl G(caml_bottom_of_stack); CFI_ADJUST(-4) @@ -362,13 +357,13 @@ CFI_STARTPROC PROFILE_C testl $1, G(caml_backtrace_active) - jne LBL(111) + jne LBL(112) movl 4(%esp), %eax movl G(caml_exception_pointer), %esp popl G(caml_exception_pointer); CFI_ADJUST(-4) UNDO_ALIGN_STACK(8) ret -LBL(111): +LBL(112): movl 4(%esp), %esi /* Save exception bucket in esi */ ALIGN_STACK(12) pushl G(caml_exception_pointer); CFI_ADJUST(4) /* 4: sp of handler */ @@ -449,10 +444,8 @@ movl %edx, G(caml_last_return_address) leal 4(%esp), %edx movl %edx, G(caml_bottom_of_stack) - /* For MacOS X: re-align the stack */ -#ifdef SYS_macosx + /* Re-align the stack */ andl $-16, %esp -#endif /* Branch to [caml_array_bound_error] (never returns) */ call G(caml_array_bound_error) CFI_ENDPROC diff -Nru ocaml-4.01.0/asmrun/.ignore ocaml-4.05.0/asmrun/.ignore --- ocaml-4.01.0/asmrun/.ignore 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/asmrun/.ignore 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -*.p.c -*.d.c -libasmrun.a -libasmrunp.a -main.c -misc.c -freelist.c -major_gc.c -minor_gc.c -memory.c -alloc.c -array.c -compare.c -ints.c -floats.c -str.c -io.c -extern.c -intern.c -hash.c -sys.c -parsing.c -gc_ctrl.c -terminfo.c -md5.c -obj.c -lexing.c -printexc.c -callback.c -weak.c -compact.c -finalise.c -custom.c -meta.c -globroots.c -unix.c -dynlink.c -signals.c -debugger.c -.depend.nt diff -Nru ocaml-4.01.0/asmrun/Makefile ocaml-4.05.0/asmrun/Makefile --- ocaml-4.01.0/asmrun/Makefile 2013-06-24 08:16:27.000000000 +0000 +++ ocaml-4.05.0/asmrun/Makefile 2017-07-13 08:56:44.000000000 +0000 @@ -1,209 +1,197 @@ -######################################################################### -# # -# OCaml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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. # -# # -######################################################################### +#************************************************************************** +#* * +#* OCaml * +#* * +#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * +#* * +#* Copyright 1999 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** include ../config/Makefile +LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ + compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ + parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ + weak.c compact.c finalise.c meta.c custom.c main.c globroots.c \ + $(UNIX_OR_WIN32).c dynlink.c signals.c debugger.c startup_aux.c \ + backtrace.c afl.c + +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + CC=$(NATIVECC) -FLAGS=-I../byterun -DCAML_NAME_SPACE -DNATIVE_CODE \ - -DTARGET_$(ARCH) -DSYS_$(SYSTEM) $(IFLEXDIR) -CFLAGS=$(FLAGS) -O $(NATIVECCCOMPOPTS) -DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS) -PFLAGS=$(FLAGS) -pg -O -DPROFILING $(NATIVECCPROFOPTS) - -COBJS=startup.o main.o fail.o roots.o globroots.o signals.o signals_asm.o \ - misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \ - floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \ - gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ - compact.o finalise.o custom.o unix.o backtrace.o natdynlink.o debugger.o \ - meta.o dynlink.o -ASMOBJS=$(ARCH).o +ifeq "$(UNIX_OR_WIN32)" "win32" +LN = cp +else +LN = ln -s +endif + +FLAGS=\ + -I../byterun \ + -DNATIVE_CODE -DTARGET_$(ARCH) + +ifeq "$(UNIX_OR_WIN32)" "unix" +FLAGS += -DMODEL_$(MODEL) +endif + +FLAGS += -DSYS_$(SYSTEM) \ + $(NATIVECCCOMPOPTS) $(IFLEXDIR) \ + $(LIBUNWIND_INCLUDE_FLAGS) + +ifeq "$(TOOLCHAIN)" "msvc" +DFLAGS=$(FLAGS) -DDEBUG +PFLAGS=$(FLAGS) -DPROFILING $(NATIVECCPROFOPTS) +OUTPUTOBJ = -Fo +ASMOBJS=$(ARCH)nt.$(O) +else +DFLAGS=$(FLAGS) -g -DDEBUG +PFLAGS=$(FLAGS) -pg -DPROFILING $(NATIVECCPROFOPTS) +OUTPUTOBJ = -o +ASMOBJS=$(ARCH).$(O) +endif + +IFLAGS=$(FLAGS) -DCAML_INSTR +PICFLAGS=$(FLAGS) $(SHAREDCCCOMPOPTS) + +ASPPFLAGS = -DSYS_$(SYSTEM) +ifeq "$(UNIX_OR_WIN32)" "unix" +ASPPFLAGS += -DMODEL_$(MODEL) +CFLAGS=$(FLAGS) -g +else +CFLAGS=$(FLAGS) +endif + +COBJS=startup_aux.$(O) startup.$(O) main.$(O) fail.$(O) \ + roots.$(O) signals.$(O) signals_asm.$(O) misc.$(O) freelist.$(O) \ + major_gc.$(O) minor_gc.$(O) memory.$(O) alloc.$(O) compare.$(O) \ + ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O) \ + intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) \ + terminfo.$(O) md5.$(O) obj.$(O) lexing.$(O) $(UNIX_OR_WIN32).$(O) \ + printexc.$(O) callback.$(O) weak.$(O) compact.$(O) finalise.$(O) \ + custom.$(O) globroots.$(O) backtrace_prim.$(O) backtrace.$(O) \ + natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O) \ + clambda_checks.$(O) spacetime.$(O) spacetime_snapshot.$(O) \ + spacetime_offline.$(O) afl.$(O) OBJS=$(COBJS) $(ASMOBJS) -DOBJS=$(COBJS:.o=.d.o) $(ASMOBJS) -POBJS=$(COBJS:.o=.p.o) $(ASMOBJS:.o=.p.o) -all: libasmrun.a all-$(RUNTIMED) all-$(PROFILING) +DOBJS=$(COBJS:.$(O)=.d.$(O)) $(ASMOBJS) +IOBJS=$(COBJS:.$(O)=.i.$(O)) $(ASMOBJS) +POBJS=$(COBJS:.$(O)=.p.$(O)) $(ASMOBJS:.$(O)=.p.$(O)) +PICOBJS=$(COBJS:.$(O)=.pic.$(O)) $(ASMOBJS:.$(O)=.pic.$(O)) -libasmrun.a: $(OBJS) - rm -f libasmrun.a - ar rc libasmrun.a $(OBJS) - $(RANLIB) libasmrun.a - -all-noruntimed: -.PHONY: all-noruntimed - -all-runtimed: libasmrund.a -.PHONY: all-runtimed - -libasmrund.a: $(DOBJS) - rm -f libasmrund.a - ar rc libasmrund.a $(DOBJS) - $(RANLIB) libasmrund.a - -all-noprof: - -all-prof: libasmrunp.a - -libasmrunp.a: $(POBJS) - rm -f libasmrunp.a - ar rc libasmrunp.a $(POBJS) - $(RANLIB) libasmrunp.a - -install: install-default install-$(RUNTIMED) install-$(PROFILING) - -install-default: - cp libasmrun.a $(LIBDIR)/libasmrun.a - cd $(LIBDIR); $(RANLIB) libasmrun.a - -install-noruntimed: -.PHONY: install-noruntimed - -install-runtimed: - cp libasmrund.a $(LIBDIR)/libasmrund.a - cd $(LIBDIR); $(RANLIB) libasmrund.a -.PHONY: install-runtimed - -install-noprof: - rm -f $(LIBDIR)/libasmrunp.a; ln -s libasmrun.a $(LIBDIR)/libasmrunp.a - -install-prof: - cp libasmrunp.a $(LIBDIR)/libasmrunp.a - cd $(LIBDIR); $(RANLIB) libasmrunp.a - -power-bsd_elf.S: power-elf.S - cp power-elf.S power-bsd_elf.S - -power.o: power-$(SYSTEM).o - cp power-$(SYSTEM).o power.o - -power.p.o: power-$(SYSTEM).o - cp power-$(SYSTEM).o power.p.o - -main.c: ../byterun/main.c - ln -s ../byterun/main.c main.c -misc.c: ../byterun/misc.c - ln -s ../byterun/misc.c misc.c -freelist.c: ../byterun/freelist.c - ln -s ../byterun/freelist.c freelist.c -major_gc.c: ../byterun/major_gc.c - ln -s ../byterun/major_gc.c major_gc.c -minor_gc.c: ../byterun/minor_gc.c - ln -s ../byterun/minor_gc.c minor_gc.c -memory.c: ../byterun/memory.c - ln -s ../byterun/memory.c memory.c -alloc.c: ../byterun/alloc.c - ln -s ../byterun/alloc.c alloc.c -array.c: ../byterun/array.c - ln -s ../byterun/array.c array.c -compare.c: ../byterun/compare.c - ln -s ../byterun/compare.c compare.c -ints.c: ../byterun/ints.c - ln -s ../byterun/ints.c ints.c -floats.c: ../byterun/floats.c - ln -s ../byterun/floats.c floats.c -str.c: ../byterun/str.c - ln -s ../byterun/str.c str.c -io.c: ../byterun/io.c - ln -s ../byterun/io.c io.c -extern.c: ../byterun/extern.c - ln -s ../byterun/extern.c extern.c -intern.c: ../byterun/intern.c - ln -s ../byterun/intern.c intern.c -hash.c: ../byterun/hash.c - ln -s ../byterun/hash.c hash.c -sys.c: ../byterun/sys.c - ln -s ../byterun/sys.c sys.c -parsing.c: ../byterun/parsing.c - ln -s ../byterun/parsing.c parsing.c -gc_ctrl.c: ../byterun/gc_ctrl.c - ln -s ../byterun/gc_ctrl.c gc_ctrl.c -terminfo.c: ../byterun/terminfo.c - ln -s ../byterun/terminfo.c terminfo.c -md5.c: ../byterun/md5.c - ln -s ../byterun/md5.c md5.c -obj.c: ../byterun/obj.c - ln -s ../byterun/obj.c obj.c -lexing.c: ../byterun/lexing.c - ln -s ../byterun/lexing.c lexing.c -printexc.c: ../byterun/printexc.c - ln -s ../byterun/printexc.c printexc.c -callback.c: ../byterun/callback.c - ln -s ../byterun/callback.c callback.c -weak.c: ../byterun/weak.c - ln -s ../byterun/weak.c weak.c -compact.c: ../byterun/compact.c - ln -s ../byterun/compact.c compact.c -finalise.c: ../byterun/finalise.c - ln -s ../byterun/finalise.c finalise.c -custom.c: ../byterun/custom.c - ln -s ../byterun/custom.c custom.c -meta.c: ../byterun/meta.c - ln -s ../byterun/meta.c meta.c -globroots.c: ../byterun/globroots.c - ln -s ../byterun/globroots.c globroots.c -unix.c: ../byterun/unix.c - ln -s ../byterun/unix.c unix.c -dynlink.c: ../byterun/dynlink.c - ln -s ../byterun/dynlink.c dynlink.c -signals.c: ../byterun/signals.c - ln -s ../byterun/signals.c signals.c -debugger.c: ../byterun/debugger.c - ln -s ../byterun/debugger.c debugger.c +TARGETS = libasmrun.$(A) -LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ - compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ - parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ - weak.c compact.c finalise.c meta.c custom.c main.c globroots.c unix.c \ - dynlink.c signals.c debugger.c +ifeq "$(RUNTIMED)" "true" +TARGETS += libasmrund.$(A) +endif -clean:: - rm -f $(LINKEDFILES) +ifeq "$(RUNTIMEI)" "true" +TARGETS += libasmruni.$(A) +endif + +ifeq "$(PROFILING)" "true" +TARGETS += libasmrunp.$(A) +endif + +ifeq "$(UNIX_OR_WIN32)" "unix" +ifeq "$(SUPPORTS_SHARED_LIBRARIES)" "true" +TARGETS += libasmrun_pic.$(A) libasmrun_shared.$(SO) +endif +endif + +.PHONY: all +all: $(TARGETS) + +libasmrun.$(A): $(OBJS) + $(call MKLIB,$@, $^) + +libasmrund.$(A): $(DOBJS) + $(call MKLIB,$@, $^) + +libasmruni.$(A): $(IOBJS) + $(call MKLIB,$@, $^) -.SUFFIXES: .S .d.o .p.o +libasmrunp.$(A): $(POBJS) + $(call MKLIB,$@, $^) -.S.o: - $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $*.o $*.S || \ +libasmrun_pic.$(A): $(PICOBJS) + $(call MKLIB,$@, $^) + +libasmrun_shared.$(SO): $(PICOBJS) + $(MKDLL) -o $@ $^ $(NATIVECCLIBS) + +.PHONY: install +install: + cp $(TARGETS) "$(INSTALL_LIBDIR)" + +$(LINKEDFILES): %.c: ../byterun/%.c + $(LN) $< $@ + +%.d.$(O): %.c + $(CC) -c $(DFLAGS) $(OUTPUTOBJ)$@ $< + +%.i.$(O): %.c + $(CC) -c $(IFLAGS) $(OUTPUTOBJ)$@ $< + +%.p.$(O): %.c + $(CC) -c $(PFLAGS) $(OUTPUTOBJ)$@ $< + +%.pic.$(O): %.c + $(CC) -c $(PICFLAGS) $(OUTPUTOBJ)$@ $< + +%.$(O): %.c + $(CC) $(CFLAGS) -c $< + +%.o: %.S + $(ASPP) $(ASPPFLAGS) -o $@ $< || \ { echo "If your assembler produced syntax errors, it is probably";\ echo "unhappy with the preprocessor. Check your assembler, or";\ echo "try producing $*.o by hand.";\ exit 2; } -.S.p.o: - $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.S +%.p.o: %.S + $(ASPP) $(ASPPFLAGS) $(ASPPPROFFLAGS) -o $@ $< + +%.pic.o: %.S + $(ASPP) $(ASPPFLAGS) $(SHAREDCCCOMPOPTS) -o $@ $< + +%.obj: %.asm + $(ASM)$@ $< + +%.pic.obj: %.asm + $(ASM)$@ $< + +.PHONY: clean +clean: + rm -f $(LINKEDFILES) + rm -f *.$(O) *.$(A) *.$(SO) + +.PHONY: distclean +distclean: clean + rm -r *~ + +ifneq "$(TOOLCHAIN)" "msvc" +.PHONY: depend +depend: $(COBJS:.$(O)=.c) $(LINKEDFILES) + $(CC) -MM $(FLAGS) *.c > .depend + $(CC) -MM $(FLAGS) -DPROFILING *.c | sed -e 's/\.o/.p.o/' >> .depend + $(CC) -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend + $(CC) -MM $(FLAGS) -DCAML_INSTR *.c | sed -e 's/\.o/.i.o/' >> .depend +endif + +ifeq "$(UNIX_OR_WIN32)" "win32" +.depend.nt: .depend + sed -e 's/\.o/.$(O)/g' .depend > .depend.nt -.c.d.o: - ln -s -f $*.c $*.d.c - $(CC) -c $(DFLAGS) $*.d.c - rm -f $*.d.c - -.c.p.o: - ln -s -f $*.c $*.p.c - $(CC) -c $(PFLAGS) $*.p.c - rm -f $*.p.c - -.s.o: - $(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.s - -.s.p.o: - $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.s - -clean:: - rm -f *.o *.a *~ - -depend: $(COBJS:.o=.c) ${LINKEDFILES} - -gcc -MM $(FLAGS) *.c > .depend - gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend - gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.p.o/' >> .depend +include .depend.nt +else include .depend +endif diff -Nru ocaml-4.01.0/asmrun/Makefile.nt ocaml-4.05.0/asmrun/Makefile.nt --- ocaml-4.01.0/asmrun/Makefile.nt 2013-04-30 09:25:14.000000000 +0000 +++ ocaml-4.05.0/asmrun/Makefile.nt 2017-07-13 08:56:44.000000000 +0000 @@ -1,83 +1,16 @@ -######################################################################### -# # -# OCaml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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. # -# # -######################################################################### +#************************************************************************** +#* * +#* OCaml * +#* * +#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * +#* * +#* Copyright 1999 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** -include ../config/Makefile - -CC=$(NATIVECC) -CFLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) \ - $(NATIVECCCOMPOPTS) - -COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) signals_asm.$(O)\ - misc.$(O) freelist.$(O) major_gc.$(O) minor_gc.$(O) memory.$(O) alloc.$(O) \ - compare.$(O) ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O) \ - intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) terminfo.$(O) \ - md5.$(O) obj.$(O) lexing.$(O) win32.$(O) printexc.$(O) callback.$(O) \ - weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O) \ - backtrace.$(O) natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O) - -LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ - compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ - parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ - weak.c compact.c meta.c finalise.c custom.c main.c globroots.c \ - dynlink.c signals.c debugger.c - -ifeq ($(TOOLCHAIN),mingw) -ASMOBJS=$(ARCH).o -else -ASMOBJS=$(ARCH)nt.obj -endif - -OBJS=$(COBJS) $(ASMOBJS) - -all: libasmrun.$(A) - -libasmrun.$(A): $(OBJS) - $(call MKLIB,libasmrun.$(A), $(OBJS)) - -i386nt.obj: i386nt.asm - $(ASM)i386nt.obj i386nt.asm - -amd64nt.obj: amd64nt.asm - $(ASM)amd64nt.obj amd64nt.asm - -i386.o: i386.S - $(ASPP) -DSYS_$(SYSTEM) i386.S - -amd64.o: amd64.S - $(ASPP) -DSYS_$(SYSTEM) amd64.S - -install: - cp libasmrun.$(A) $(LIBDIR) - -$(LINKEDFILES): %.c: ../byterun/%.c - cp ../byterun/$*.c $*.c - -# Need special compilation rule so as not to do -I../byterun -win32.$(O): ../byterun/win32.c - $(CC) -c $(NATIVECCCOMPOPTS) -DNATIVE_CODE $(IFLEXDIR) ../byterun/win32.c - -.SUFFIXES: .c .$(O) - -.c.$(O): - $(CC) $(CFLAGS) -c $< - -clean:: - rm -f $(LINKEDFILES) - -clean:: - rm -f *.$(O) *.$(A) *~ - -.depend.nt: .depend - sed -e 's/\.o/.$(O)/g' .depend > .depend.nt - -include .depend.nt +include Makefile diff -Nru ocaml-4.01.0/asmrun/natdynlink.c ocaml-4.05.0/asmrun/natdynlink.c --- ocaml-4.01.0/asmrun/natdynlink.c 2012-08-01 15:37:29.000000000 +0000 +++ ocaml-4.05.0/asmrun/natdynlink.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,44 +1,61 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Alain Frisch, projet Gallium, INRIA Rocquencourt */ -/* */ -/* Copyright 2007 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. */ -/* */ -/***********************************************************************/ - -#include "misc.h" -#include "mlvalues.h" -#include "memory.h" -#include "stack.h" -#include "callback.h" -#include "alloc.h" -#include "intext.h" -#include "osdeps.h" -#include "fail.h" +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Alain Frisch, projet Gallium, INRIA Rocquencourt */ +/* */ +/* Copyright 2007 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/memory.h" +#include "caml/stack.h" +#include "caml/callback.h" +#include "caml/alloc.h" +#include "caml/intext.h" +#include "caml/osdeps.h" +#include "caml/fail.h" +#include "caml/signals.h" +#ifdef WITH_SPACETIME +#include "caml/spacetime.h" +#endif + +#include "caml/hooks.h" + +CAMLexport void (*caml_natdynlink_hook)(void* handle, char* unit) = NULL; #include #include +#include + +#define Handle_val(v) (*((void **) Data_abstract_val(v))) +static value Val_handle(void* handle) { + value res = caml_alloc_small(1, Abstract_tag); + Handle_val(res) = handle; + return res; +} static void *getsym(void *handle, char *module, char *name){ - char *fullname = malloc(strlen(module) + strlen(name) + 5); + char *fullname = caml_strconcat(3, "caml", module, name); void *sym; - sprintf(fullname, "caml%s%s", module, name); sym = caml_dlsym (handle, fullname); /* printf("%s => %lx\n", fullname, (uintnat) sym); */ - free(fullname); + caml_stat_free(fullname); return sym; } -extern char caml_globals_map[]; - CAMLprim value caml_natdynlink_getmap(value unit) { - return (value)caml_globals_map; + return caml_input_value_from_block(caml_globals_map, INT_MAX); } CAMLprim value caml_natdynlink_globals_inited(value unit) @@ -48,32 +65,41 @@ CAMLprim value caml_natdynlink_open(value filename, value global) { - CAMLparam1 (filename); - CAMLlocal1 (res); + CAMLparam2 (filename, global); + CAMLlocal3 (res, handle, header); void *sym; - void *handle; + void *dlhandle; + char *p; /* TODO: dlclose in case of error... */ - handle = caml_dlopen(String_val(filename), 1, Int_val(global)); + p = caml_strdup(String_val(filename)); + caml_enter_blocking_section(); + dlhandle = caml_dlopen(p, 1, Int_val(global)); + caml_leave_blocking_section(); + caml_stat_free(p); - if (NULL == handle) - CAMLreturn(caml_copy_string(caml_dlerror())); + if (NULL == dlhandle) + caml_failwith(caml_dlerror()); - sym = caml_dlsym(handle, "caml_plugin_header"); + sym = caml_dlsym(dlhandle, "caml_plugin_header"); if (NULL == sym) - CAMLreturn(caml_copy_string("not an OCaml plugin")); + caml_failwith("not an OCaml plugin"); + + handle = Val_handle(dlhandle); + header = caml_input_value_from_block(sym, INT_MAX); res = caml_alloc_tuple(2); - Field(res, 0) = (value) handle; - Field(res, 1) = (value) (sym); + Field(res, 0) = handle; + Field(res, 1) = header; CAMLreturn(res); } -CAMLprim value caml_natdynlink_run(void *handle, value symbol) { - CAMLparam1 (symbol); +CAMLprim value caml_natdynlink_run(value handle_v, value symbol) { + CAMLparam2 (handle_v, symbol); CAMLlocal1 (result); void *sym,*sym2; + void* handle = Handle_val(handle_v); struct code_fragment * cf; #define optsym(n) getsym(handle,unit,n) @@ -85,7 +111,12 @@ sym = optsym("__frametable"); if (NULL != sym) caml_register_frametable(sym); - sym = optsym(""); +#ifdef WITH_SPACETIME + sym = optsym("__spacetime_shapes"); + if (NULL != sym) caml_spacetime_register_shapes(sym); +#endif + + sym = optsym("__gc_roots"); if (NULL != sym) caml_register_dyn_global(sym); sym = optsym("__data_begin"); @@ -104,6 +135,8 @@ caml_ext_table_add(&caml_code_fragments_table, cf); } + if( caml_natdynlink_hook != NULL ) caml_natdynlink_hook(handle,unit); + entrypoint = optsym("__entry"); if (NULL != entrypoint) result = caml_callback((value)(&entrypoint), 0); else result = Val_unit; @@ -116,20 +149,26 @@ CAMLprim value caml_natdynlink_run_toplevel(value filename, value symbol) { CAMLparam2 (filename, symbol); - CAMLlocal2 (res, v); + CAMLlocal3 (res, v, handle_v); void *handle; + char *p; /* TODO: dlclose in case of error... */ - handle = caml_dlopen(String_val(filename), 1, 1); + p = caml_strdup(String_val(filename)); + caml_enter_blocking_section(); + handle = caml_dlopen(p, 1, 1); + caml_leave_blocking_section(); + caml_stat_free(p); if (NULL == handle) { res = caml_alloc(1,1); v = caml_copy_string(caml_dlerror()); Store_field(res, 0, v); } else { + handle_v = Val_handle(handle); res = caml_alloc(1,0); - v = caml_natdynlink_run(handle, symbol); + v = caml_natdynlink_run(handle_v, symbol); Store_field(res, 0, v); } CAMLreturn(res); diff -Nru ocaml-4.01.0/asmrun/power-elf.S ocaml-4.05.0/asmrun/power-elf.S --- ocaml-4.01.0/asmrun/power-elf.S 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmrun/power-elf.S 1970-01-01 00:00:00.000000000 +0000 @@ -1,424 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -#define Addrglobal(reg,glob) \ - addis reg, 0, glob@ha; \ - addi reg, reg, glob@l -#define Loadglobal(reg,glob,tmp) \ - addis tmp, 0, glob@ha; \ - lwz reg, glob@l(tmp) -#define Storeglobal(reg,glob,tmp) \ - addis tmp, 0, glob@ha; \ - stw reg, glob@l(tmp) - - .section ".text" - -/* Invoke the garbage collector. */ - - .globl caml_system__code_begin -caml_system__code_begin: - - .globl caml_call_gc - .type caml_call_gc, @function -caml_call_gc: - /* Set up stack frame */ - stwu 1, -0x1A0(1) - /* 0x1A0 = 4*32 (int regs) + 8*32 (float regs) + 32 (space for C call) */ - /* Record return address into OCaml code */ - mflr 0 - Storeglobal(0, caml_last_return_address, 11) - /* Record lowest stack address */ - addi 0, 1, 0x1A0 - Storeglobal(0, caml_bottom_of_stack, 11) - /* Record pointer to register array */ - addi 0, 1, 8*32 + 32 - Storeglobal(0, caml_gc_regs, 11) - /* Save current allocation pointer for debugging purposes */ - Storeglobal(31, caml_young_ptr, 11) - /* Save exception pointer (if e.g. a sighandler raises) */ - Storeglobal(29, caml_exception_pointer, 11) - /* Save all registers used by the code generator */ - addi 11, 1, 8*32 + 32 - 4 - stwu 3, 4(11) - stwu 4, 4(11) - stwu 5, 4(11) - stwu 6, 4(11) - stwu 7, 4(11) - stwu 8, 4(11) - stwu 9, 4(11) - stwu 10, 4(11) - stwu 14, 4(11) - stwu 15, 4(11) - stwu 16, 4(11) - stwu 17, 4(11) - stwu 18, 4(11) - stwu 19, 4(11) - stwu 20, 4(11) - stwu 21, 4(11) - stwu 22, 4(11) - stwu 23, 4(11) - stwu 24, 4(11) - stwu 25, 4(11) - stwu 26, 4(11) - stwu 27, 4(11) - stwu 28, 4(11) - addi 11, 1, 32 - 8 - stfdu 1, 8(11) - stfdu 2, 8(11) - stfdu 3, 8(11) - stfdu 4, 8(11) - stfdu 5, 8(11) - stfdu 6, 8(11) - stfdu 7, 8(11) - stfdu 8, 8(11) - stfdu 9, 8(11) - stfdu 10, 8(11) - stfdu 11, 8(11) - stfdu 12, 8(11) - stfdu 13, 8(11) - stfdu 14, 8(11) - stfdu 15, 8(11) - stfdu 16, 8(11) - stfdu 17, 8(11) - stfdu 18, 8(11) - stfdu 19, 8(11) - stfdu 20, 8(11) - stfdu 21, 8(11) - stfdu 22, 8(11) - stfdu 23, 8(11) - stfdu 24, 8(11) - stfdu 25, 8(11) - stfdu 26, 8(11) - stfdu 27, 8(11) - stfdu 28, 8(11) - stfdu 29, 8(11) - stfdu 30, 8(11) - stfdu 31, 8(11) - /* Call the GC */ - bl caml_garbage_collection - /* Reload new allocation pointer and allocation limit */ - Loadglobal(31, caml_young_ptr, 11) - Loadglobal(30, caml_young_limit, 11) - /* Restore all regs used by the code generator */ - addi 11, 1, 8*32 + 32 - 4 - lwzu 3, 4(11) - lwzu 4, 4(11) - lwzu 5, 4(11) - lwzu 6, 4(11) - lwzu 7, 4(11) - lwzu 8, 4(11) - lwzu 9, 4(11) - lwzu 10, 4(11) - lwzu 14, 4(11) - lwzu 15, 4(11) - lwzu 16, 4(11) - lwzu 17, 4(11) - lwzu 18, 4(11) - lwzu 19, 4(11) - lwzu 20, 4(11) - lwzu 21, 4(11) - lwzu 22, 4(11) - lwzu 23, 4(11) - lwzu 24, 4(11) - lwzu 25, 4(11) - lwzu 26, 4(11) - lwzu 27, 4(11) - lwzu 28, 4(11) - addi 11, 1, 32 - 8 - lfdu 1, 8(11) - lfdu 2, 8(11) - lfdu 3, 8(11) - lfdu 4, 8(11) - lfdu 5, 8(11) - lfdu 6, 8(11) - lfdu 7, 8(11) - lfdu 8, 8(11) - lfdu 9, 8(11) - lfdu 10, 8(11) - lfdu 11, 8(11) - lfdu 12, 8(11) - lfdu 13, 8(11) - lfdu 14, 8(11) - lfdu 15, 8(11) - lfdu 16, 8(11) - lfdu 17, 8(11) - lfdu 18, 8(11) - lfdu 19, 8(11) - lfdu 20, 8(11) - lfdu 21, 8(11) - lfdu 22, 8(11) - lfdu 23, 8(11) - lfdu 24, 8(11) - lfdu 25, 8(11) - lfdu 26, 8(11) - lfdu 27, 8(11) - lfdu 28, 8(11) - lfdu 29, 8(11) - lfdu 30, 8(11) - lfdu 31, 8(11) - /* Return to caller, restarting the allocation */ - Loadglobal(0, caml_last_return_address, 11) - addic 0, 0, -16 /* Restart the allocation (4 instructions) */ - mtlr 0 - /* Say we are back into OCaml code */ - li 12, 0 - Storeglobal(12, caml_last_return_address, 11) - /* Deallocate stack frame */ - addi 1, 1, 0x1A0 - /* Return */ - blr - -/* Call a C function from OCaml */ - - .globl caml_c_call - .type caml_c_call, @function -caml_c_call: - /* Save return address */ - mflr 25 - /* Get ready to call C function (address in 11) */ - mtctr 11 - /* Record lowest stack address and return address */ - Storeglobal(1, caml_bottom_of_stack, 12) - Storeglobal(25, caml_last_return_address, 12) - /* Make the exception handler and alloc ptr available to the C code */ - Storeglobal(31, caml_young_ptr, 11) - Storeglobal(29, caml_exception_pointer, 11) - /* Call the function (address in CTR register) */ - bctrl - /* Restore return address (in 25, preserved by the C function) */ - mtlr 25 - /* Reload allocation pointer and allocation limit*/ - Loadglobal(31, caml_young_ptr, 11) - Loadglobal(30, caml_young_limit, 11) - /* Say we are back into OCaml code */ - li 12, 0 - Storeglobal(12, caml_last_return_address, 11) - /* Return to caller */ - blr - -/* Raise an exception from C */ - - .globl caml_raise_exception - .type caml_raise_exception, @function -caml_raise_exception: - /* Reload OCaml global registers */ - Loadglobal(1, caml_exception_pointer, 11) - Loadglobal(31, caml_young_ptr, 11) - Loadglobal(30, caml_young_limit, 11) - /* Say we are back into OCaml code */ - li 0, 0 - Storeglobal(0, caml_last_return_address, 11) - /* Pop trap frame */ - lwz 0, 0(1) - lwz 29, 4(1) - mtlr 0 - addi 1, 1, 16 - /* Branch to handler */ - blr - -/* Start the OCaml program */ - - .globl caml_start_program - .type caml_start_program, @function -caml_start_program: - Addrglobal(12, caml_program) - -/* Code shared between caml_start_program and caml_callback */ -.L102: - /* Allocate and link stack frame */ - stwu 1, -256(1) - /* Save return address */ - mflr 0 - stw 0, 256+4(1) - /* Save all callee-save registers */ - /* GPR 14 at sp+16 ... GPR 31 at sp+84 - FPR 14 at sp+92 ... FPR 31 at sp+228 */ - addi 11, 1, 16-4 - stwu 14, 4(11) - stwu 15, 4(11) - stwu 16, 4(11) - stwu 17, 4(11) - stwu 18, 4(11) - stwu 19, 4(11) - stwu 20, 4(11) - stwu 21, 4(11) - stwu 22, 4(11) - stwu 23, 4(11) - stwu 24, 4(11) - stwu 25, 4(11) - stwu 26, 4(11) - stwu 27, 4(11) - stwu 28, 4(11) - stwu 29, 4(11) - stwu 30, 4(11) - stwu 31, 4(11) - stfdu 14, 8(11) - stfdu 15, 8(11) - stfdu 16, 8(11) - stfdu 17, 8(11) - stfdu 18, 8(11) - stfdu 19, 8(11) - stfdu 20, 8(11) - stfdu 21, 8(11) - stfdu 22, 8(11) - stfdu 23, 8(11) - stfdu 24, 8(11) - stfdu 25, 8(11) - stfdu 26, 8(11) - stfdu 27, 8(11) - stfdu 28, 8(11) - stfdu 29, 8(11) - stfdu 30, 8(11) - stfdu 31, 8(11) - /* Set up a callback link */ - addi 1, 1, -16 - Loadglobal(9, caml_bottom_of_stack, 11) - Loadglobal(10, caml_last_return_address, 11) - Loadglobal(11, caml_gc_regs, 11) - stw 9, 0(1) - stw 10, 4(1) - stw 11, 8(1) - /* Build an exception handler to catch exceptions escaping out of OCaml */ - bl .L103 - b .L104 -.L103: - addi 1, 1, -16 - mflr 0 - stw 0, 0(1) - Loadglobal(11, caml_exception_pointer, 11) - stw 11, 4(1) - mr 29, 1 - /* Reload allocation pointers */ - Loadglobal(31, caml_young_ptr, 11) - Loadglobal(30, caml_young_limit, 11) - /* Say we are back into OCaml code */ - li 0, 0 - Storeglobal(0, caml_last_return_address, 11) - /* Call the OCaml code */ - mtlr 12 -.L105: - blrl - /* Pop the trap frame, restoring caml_exception_pointer */ - lwz 9, 4(1) - Storeglobal(9, caml_exception_pointer, 11) - addi 1, 1, 16 - /* Pop the callback link, restoring the global variables */ -.L106: - lwz 9, 0(1) - lwz 10, 4(1) - lwz 11, 8(1) - Storeglobal(9, caml_bottom_of_stack, 12) - Storeglobal(10, caml_last_return_address, 12) - Storeglobal(11, caml_gc_regs, 12) - addi 1, 1, 16 - /* Update allocation pointer */ - Storeglobal(31, caml_young_ptr, 11) - /* Restore callee-save registers */ - addi 11, 1, 16-4 - lwzu 14, 4(11) - lwzu 15, 4(11) - lwzu 16, 4(11) - lwzu 17, 4(11) - lwzu 18, 4(11) - lwzu 19, 4(11) - lwzu 20, 4(11) - lwzu 21, 4(11) - lwzu 22, 4(11) - lwzu 23, 4(11) - lwzu 24, 4(11) - lwzu 25, 4(11) - lwzu 26, 4(11) - lwzu 27, 4(11) - lwzu 28, 4(11) - lwzu 29, 4(11) - lwzu 30, 4(11) - lwzu 31, 4(11) - lfdu 14, 8(11) - lfdu 15, 8(11) - lfdu 16, 8(11) - lfdu 17, 8(11) - lfdu 18, 8(11) - lfdu 19, 8(11) - lfdu 20, 8(11) - lfdu 21, 8(11) - lfdu 22, 8(11) - lfdu 23, 8(11) - lfdu 24, 8(11) - lfdu 25, 8(11) - lfdu 26, 8(11) - lfdu 27, 8(11) - lfdu 28, 8(11) - lfdu 29, 8(11) - lfdu 30, 8(11) - lfdu 31, 8(11) - /* Reload return address */ - lwz 0, 256+4(1) - mtlr 0 - /* Return */ - addi 1, 1, 256 - blr - - /* The trap handler: */ -.L104: - /* Update caml_exception_pointer */ - Storeglobal(29, caml_exception_pointer, 11) - /* Encode exception bucket as an exception result and return it */ - ori 3, 3, 2 - b .L106 - -/* Callback from C to OCaml */ - - .globl caml_callback_exn - .type caml_callback_exn, @function -caml_callback_exn: - /* Initial shuffling of arguments */ - mr 0, 3 /* Closure */ - mr 3, 4 /* Argument */ - mr 4, 0 - lwz 12, 0(4) /* Code pointer */ - b .L102 - - .globl caml_callback2_exn - .type caml_callback2_exn, @function -caml_callback2_exn: - mr 0, 3 /* Closure */ - mr 3, 4 /* First argument */ - mr 4, 5 /* Second argument */ - mr 5, 0 - Addrglobal(12, caml_apply2) - b .L102 - - .globl caml_callback3_exn - .type caml_callback3_exn, @function -caml_callback3_exn: - mr 0, 3 /* Closure */ - mr 3, 4 /* First argument */ - mr 4, 5 /* Second argument */ - mr 5, 6 /* Third argument */ - mr 6, 0 - Addrglobal(12, caml_apply3) - b .L102 - - .globl caml_system__code_end -caml_system__code_end: - -/* Frame table */ - - .section ".data" - .globl caml_system__frametable - .type caml_system__frametable, @object -caml_system__frametable: - .long 1 /* one descriptor */ - .long .L105 + 4 /* return address into callback */ - .short -1 /* negative size count => use callback link */ - .short 0 /* no roots here */ diff -Nru ocaml-4.01.0/asmrun/power-rhapsody.S ocaml-4.05.0/asmrun/power-rhapsody.S --- ocaml-4.01.0/asmrun/power-rhapsody.S 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmrun/power-rhapsody.S 1970-01-01 00:00:00.000000000 +0000 @@ -1,488 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -#ifdef __ppc64__ -#define X(a,b) b -#else -#define X(a,b) a -#endif - -#define WORD X(4,8) -#define lg X(lwz,ld) -#define lgu X(lwzu,ldu) -#define stg X(stw,std) -#define stgu X(stwu,stdu) -#define gdata X(.long,.quad) - -.macro Addrglobal /* reg, glob */ - addis $0, 0, ha16($1) - addi $0, $0, lo16($1) -.endmacro -.macro Loadglobal /* reg,glob,tmp */ - addis $2, 0, ha16($1) - lg $0, lo16($1)($2) -.endmacro -.macro Storeglobal /* reg,glob,tmp */ - addis $2, 0, ha16($1) - stg $0, lo16($1)($2) -.endmacro - - .text - - .globl _caml_system__code_begin -_caml_system__code_begin: - -/* Invoke the garbage collector. */ - - .globl _caml_call_gc -_caml_call_gc: - /* Set up stack frame */ -#define FRAMESIZE (32*WORD + 32*8 + 32) - stwu r1, -FRAMESIZE(r1) - /* Record return address into OCaml code */ - mflr r0 - Storeglobal r0, _caml_last_return_address, r11 - /* Record lowest stack address */ - addi r0, r1, FRAMESIZE - Storeglobal r0, _caml_bottom_of_stack, r11 - /* Touch the stack to trigger a recoverable segfault - if insufficient space remains */ - addi r1, r1, -4096*WORD - stg r0, 0(r1) - addi r1, r1, 4096*WORD - /* Record pointer to register array */ - addi r0, r1, 8*32 + 32 - Storeglobal r0, _caml_gc_regs, r11 - /* Save current allocation pointer for debugging purposes */ - Storeglobal r31, _caml_young_ptr, r11 - /* Save exception pointer (if e.g. a sighandler raises) */ - Storeglobal r29, _caml_exception_pointer, r11 - /* Save all registers used by the code generator */ - addi r11, r1, 8*32 + 32 - WORD - stgu r3, WORD(r11) - stgu r4, WORD(r11) - stgu r5, WORD(r11) - stgu r6, WORD(r11) - stgu r7, WORD(r11) - stgu r8, WORD(r11) - stgu r9, WORD(r11) - stgu r10, WORD(r11) - stgu r14, WORD(r11) - stgu r15, WORD(r11) - stgu r16, WORD(r11) - stgu r17, WORD(r11) - stgu r18, WORD(r11) - stgu r19, WORD(r11) - stgu r20, WORD(r11) - stgu r21, WORD(r11) - stgu r22, WORD(r11) - stgu r23, WORD(r11) - stgu r24, WORD(r11) - stgu r25, WORD(r11) - stgu r26, WORD(r11) - stgu r27, WORD(r11) - stgu r28, WORD(r11) - addi r11, r1, 32 - 8 - stfdu f1, 8(r11) - stfdu f2, 8(r11) - stfdu f3, 8(r11) - stfdu f4, 8(r11) - stfdu f5, 8(r11) - stfdu f6, 8(r11) - stfdu f7, 8(r11) - stfdu f8, 8(r11) - stfdu f9, 8(r11) - stfdu f10, 8(r11) - stfdu f11, 8(r11) - stfdu f12, 8(r11) - stfdu f13, 8(r11) - stfdu f14, 8(r11) - stfdu f15, 8(r11) - stfdu f16, 8(r11) - stfdu f17, 8(r11) - stfdu f18, 8(r11) - stfdu f19, 8(r11) - stfdu f20, 8(r11) - stfdu f21, 8(r11) - stfdu f22, 8(r11) - stfdu f23, 8(r11) - stfdu f24, 8(r11) - stfdu f25, 8(r11) - stfdu f26, 8(r11) - stfdu f27, 8(r11) - stfdu f28, 8(r11) - stfdu f29, 8(r11) - stfdu f30, 8(r11) - stfdu f31, 8(r11) - /* Call the GC */ - bl _caml_garbage_collection - /* Reload new allocation pointer and allocation limit */ - Loadglobal r31, _caml_young_ptr, r11 - Loadglobal r30, _caml_young_limit, r11 - /* Restore all regs used by the code generator */ - addi r11, r1, 8*32 + 32 - WORD - lgu r3, WORD(r11) - lgu r4, WORD(r11) - lgu r5, WORD(r11) - lgu r6, WORD(r11) - lgu r7, WORD(r11) - lgu r8, WORD(r11) - lgu r9, WORD(r11) - lgu r10, WORD(r11) - lgu r14, WORD(r11) - lgu r15, WORD(r11) - lgu r16, WORD(r11) - lgu r17, WORD(r11) - lgu r18, WORD(r11) - lgu r19, WORD(r11) - lgu r20, WORD(r11) - lgu r21, WORD(r11) - lgu r22, WORD(r11) - lgu r23, WORD(r11) - lgu r24, WORD(r11) - lgu r25, WORD(r11) - lgu r26, WORD(r11) - lgu r27, WORD(r11) - lgu r28, WORD(r11) - addi r11, r1, 32 - 8 - lfdu f1, 8(r11) - lfdu f2, 8(r11) - lfdu f3, 8(r11) - lfdu f4, 8(r11) - lfdu f5, 8(r11) - lfdu f6, 8(r11) - lfdu f7, 8(r11) - lfdu f8, 8(r11) - lfdu f9, 8(r11) - lfdu f10, 8(r11) - lfdu f11, 8(r11) - lfdu f12, 8(r11) - lfdu f13, 8(r11) - lfdu f14, 8(r11) - lfdu f15, 8(r11) - lfdu f16, 8(r11) - lfdu f17, 8(r11) - lfdu f18, 8(r11) - lfdu f19, 8(r11) - lfdu f20, 8(r11) - lfdu f21, 8(r11) - lfdu f22, 8(r11) - lfdu f23, 8(r11) - lfdu f24, 8(r11) - lfdu f25, 8(r11) - lfdu f26, 8(r11) - lfdu f27, 8(r11) - lfdu f28, 8(r11) - lfdu f29, 8(r11) - lfdu f30, 8(r11) - lfdu f31, 8(r11) - /* Return to caller, restarting the allocation */ - Loadglobal r0, _caml_last_return_address, r11 - addic r0, r0, -16 /* Restart the allocation (4 instructions) */ - mtlr r0 - /* Say we are back into OCaml code */ - li r12, 0 - Storeglobal r12, _caml_last_return_address, r11 - /* Deallocate stack frame */ - addi r1, r1, FRAMESIZE - /* Return */ - blr -#undef FRAMESIZE - -/* Call a C function from OCaml */ - - .globl _caml_c_call -_caml_c_call: - /* Save return address */ - mflr r25 - /* Get ready to call C function (address in 11) */ - mtctr r11 - /* Record lowest stack address and return address */ - Storeglobal r1, _caml_bottom_of_stack, r12 - Storeglobal r25, _caml_last_return_address, r12 - /* Touch the stack to trigger a recoverable segfault - if insufficient space remains */ - addi r1, r1, -4096*WORD - stg r0, 0(r1) - addi r1, r1, 4096*WORD - /* Make the exception handler and alloc ptr available to the C code */ - Storeglobal r31, _caml_young_ptr, r11 - Storeglobal r29, _caml_exception_pointer, r11 - /* Call the function (address in link register) */ - bctrl - /* Restore return address (in 25, preserved by the C function) */ - mtlr r25 - /* Reload allocation pointer and allocation limit*/ - Loadglobal r31, _caml_young_ptr, r11 - Loadglobal r30, _caml_young_limit, r11 - /* Say we are back into OCaml code */ - li r12, 0 - Storeglobal r12, _caml_last_return_address, r11 - /* Return to caller */ - blr - -/* Raise an exception from OCaml */ - .globl _caml_raise_exn -_caml_raise_exn: - addis r11, 0, ha16(_caml_backtrace_active) - lwz r11, lo16(_caml_backtrace_active)(r11) - cmpwi r11, 0 - bne L110 -L111: - /* Pop trap frame */ - lg r0, 0(r29) - mr r1, r29 - mtlr r0 - lg r29, WORD(r1) - addi r1, r1, 16 - /* Branch to handler */ - blr - -L110: - mr r28, r3 /* preserve exn bucket in callee-save */ - /* arg 1: exception bucket (already in r3) */ - mflr r4 /* arg 2: PC of raise */ - mr r5, r1 /* arg 3: SP of raise */ - mr r6, r29 /* arg 4: SP of handler */ - addi r1, r1, -(16*WORD) /* reserve stack space for C call */ - bl _caml_stash_backtrace - mr r3, r28 - b L111 - -/* Raise an exception from C */ - - .globl _caml_raise_exception -_caml_raise_exception: - addis r11, 0, ha16(_caml_backtrace_active) - lwz r11, lo16(_caml_backtrace_active)(r11) - cmpwi r11, 0 - bne L112 -L113: - /* Reload OCaml global registers */ - Loadglobal r1, _caml_exception_pointer, r11 - Loadglobal r31, _caml_young_ptr, r11 - Loadglobal r30, _caml_young_limit, r11 - /* Say we are back into OCaml code */ - li r0, 0 - Storeglobal r0, _caml_last_return_address, r11 - /* Pop trap frame */ - lg r0, 0(r1) - lg r29, WORD(r1) - mtlr r0 - addi r1, r1, 16 - /* Branch to handler */ - blr -L112: - mr r28, r3 /* preserve exn bucket in callee-save */ - /* arg 1: exception bucket (already in r3) */ - Loadglobal r4, _caml_last_return_address, r11 /* arg 2: PC of raise */ - Loadglobal r5, _caml_bottom_of_stack, r11 /* arg 3: SP of raise */ - Loadglobal r6, _caml_exception_pointer, r11 /* arg 4: SP of handler */ - addi r1, r1, -(16*WORD) /* reserve stack space for C call */ - bl _caml_stash_backtrace - mr r3, r28 - b L113 - -/* Start the OCaml program */ - - .globl _caml_start_program -_caml_start_program: - Addrglobal r12, _caml_program - -/* Code shared between caml_start_program and caml_callback */ -L102: - /* Allocate and link stack frame */ -#define FRAMESIZE (16 + 20*WORD + 18*8) - stgu r1, -FRAMESIZE(r1) - /* Save return address */ - mflr r0 - stg r0, WORD(r1) - /* Save all callee-save registers */ - /* GPR14 ... GPR31, then FPR14 ... FPR31 starting at sp+16 */ - addi r11, r1, 16-WORD - stgu r14, WORD(r11) - stgu r15, WORD(r11) - stgu r16, WORD(r11) - stgu r17, WORD(r11) - stgu r18, WORD(r11) - stgu r19, WORD(r11) - stgu r20, WORD(r11) - stgu r21, WORD(r11) - stgu r22, WORD(r11) - stgu r23, WORD(r11) - stgu r24, WORD(r11) - stgu r25, WORD(r11) - stgu r26, WORD(r11) - stgu r27, WORD(r11) - stgu r28, WORD(r11) - stgu r29, WORD(r11) - stgu r30, WORD(r11) - stgu r31, WORD(r11) - stfdu f14, 8(r11) - stfdu f15, 8(r11) - stfdu f16, 8(r11) - stfdu f17, 8(r11) - stfdu f18, 8(r11) - stfdu f19, 8(r11) - stfdu f20, 8(r11) - stfdu f21, 8(r11) - stfdu f22, 8(r11) - stfdu f23, 8(r11) - stfdu f24, 8(r11) - stfdu f25, 8(r11) - stfdu f26, 8(r11) - stfdu f27, 8(r11) - stfdu f28, 8(r11) - stfdu f29, 8(r11) - stfdu f30, 8(r11) - stfdu f31, 8(r11) - /* Set up a callback link */ - addi r1, r1, -32 - Loadglobal r9, _caml_bottom_of_stack, r11 - Loadglobal r10, _caml_last_return_address, r11 - Loadglobal r11, _caml_gc_regs, r11 - stg r9, 0(r1) - stg r10, WORD(r1) - stg r11, 2*WORD(r1) - /* Build an exception handler to catch exceptions escaping out of OCaml */ - bl L103 - b L104 -L103: - addi r1, r1, -16 - mflr r0 - stg r0, 0(r1) - Loadglobal r11, _caml_exception_pointer, r11 - stg r11, WORD(r1) - mr r29, r1 - /* Reload allocation pointers */ - Loadglobal r31, _caml_young_ptr, r11 - Loadglobal r30, _caml_young_limit, r11 - /* Say we are back into OCaml code */ - li r0, 0 - Storeglobal r0, _caml_last_return_address, r11 - /* Call the OCaml code */ - mtctr r12 -L105: - bctrl - /* Pop the trap frame, restoring caml_exception_pointer */ - lg r9, WORD(r1) - Storeglobal r9, _caml_exception_pointer, r11 - addi r1, r1, 16 - /* Pop the callback link, restoring the global variables */ -L106: - lg r9, 0(r1) - lg r10, WORD(r1) - lg r11, 2*WORD(r1) - Storeglobal r9, _caml_bottom_of_stack, r12 - Storeglobal r10, _caml_last_return_address, r12 - Storeglobal r11, _caml_gc_regs, r12 - addi r1, r1, 32 - /* Update allocation pointer */ - Storeglobal r31, _caml_young_ptr, r11 - /* Restore callee-save registers */ - addi r11, r1, 16-WORD - lgu r14, WORD(r11) - lgu r15, WORD(r11) - lgu r16, WORD(r11) - lgu r17, WORD(r11) - lgu r18, WORD(r11) - lgu r19, WORD(r11) - lgu r20, WORD(r11) - lgu r21, WORD(r11) - lgu r22, WORD(r11) - lgu r23, WORD(r11) - lgu r24, WORD(r11) - lgu r25, WORD(r11) - lgu r26, WORD(r11) - lgu r27, WORD(r11) - lgu r28, WORD(r11) - lgu r29, WORD(r11) - lgu r30, WORD(r11) - lgu r31, WORD(r11) - lfdu f14, 8(r11) - lfdu f15, 8(r11) - lfdu f16, 8(r11) - lfdu f17, 8(r11) - lfdu f18, 8(r11) - lfdu f19, 8(r11) - lfdu f20, 8(r11) - lfdu f21, 8(r11) - lfdu f22, 8(r11) - lfdu f23, 8(r11) - lfdu f24, 8(r11) - lfdu f25, 8(r11) - lfdu f26, 8(r11) - lfdu f27, 8(r11) - lfdu f28, 8(r11) - lfdu f29, 8(r11) - lfdu f30, 8(r11) - lfdu f31, 8(r11) - /* Reload return address */ - lg r0, WORD(r1) - mtlr r0 - /* Return */ - addi r1, r1, FRAMESIZE - blr - - /* The trap handler: */ -L104: - /* Update caml_exception_pointer */ - Storeglobal r29, _caml_exception_pointer, r11 - /* Encode exception bucket as an exception result and return it */ - ori r3, r3, 2 - b L106 -#undef FRAMESIZE - -/* Callback from C to OCaml */ - - .globl _caml_callback_exn -_caml_callback_exn: - /* Initial shuffling of arguments */ - mr r0, r3 /* Closure */ - mr r3, r4 /* Argument */ - mr r4, r0 - lg r12, 0(r4) /* Code pointer */ - b L102 - - .globl _caml_callback2_exn -_caml_callback2_exn: - mr r0, r3 /* Closure */ - mr r3, r4 /* First argument */ - mr r4, r5 /* Second argument */ - mr r5, r0 - Addrglobal r12, _caml_apply2 - b L102 - - .globl _caml_callback3_exn -_caml_callback3_exn: - mr r0, r3 /* Closure */ - mr r3, r4 /* First argument */ - mr r4, r5 /* Second argument */ - mr r5, r6 /* Third argument */ - mr r6, r0 - Addrglobal r12, _caml_apply3 - b L102 - - .globl _caml_system__code_end -_caml_system__code_end: - -/* Frame table */ - - .const - .globl _caml_system__frametable -_caml_system__frametable: - gdata 1 /* one descriptor */ - gdata L105 + 4 /* return address into callback */ - .short -1 /* negative size count => use callback link */ - .short 0 /* no roots here */ - .align X(2,3) diff -Nru ocaml-4.01.0/asmrun/power.S ocaml-4.05.0/asmrun/power.S --- ocaml-4.01.0/asmrun/power.S 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmrun/power.S 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,680 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#if defined(MODEL_ppc64le) + .abiversion 2 +#endif + +#if defined(MODEL_ppc64) || defined(MODEL_ppc64le) +#define EITHER(a,b) b +#else +#define EITHER(a,b) a +#endif + +#define WORD EITHER(4,8) +#define lg EITHER(lwz,ld) +#define lgu EITHER(lwzu,ldu) +#define stg EITHER(stw,std) +#define stgu EITHER(stwu,stdu) +#define datag EITHER(.long,.quad) +#define wordalign EITHER(2,3) + +/* Stack layout */ +#if defined(MODEL_ppc) +#define RESERVED_STACK 16 +#define PARAM_SAVE_AREA 0 +#define LR_SAVE 4 +#define TRAP_SIZE 16 +#define TRAP_HANDLER_OFFSET 0 +#define TRAP_PREVIOUS_OFFSET 4 +#define CALLBACK_LINK_SIZE 16 +#define CALLBACK_LINK_OFFSET 0 +#endif +#if defined(MODEL_ppc64) +#define RESERVED_STACK 48 +#define PARAM_SAVE_AREA (8*8) +#define LR_SAVE 16 +#define TOC_SAVE 40 +#define TOC_SAVE_PARENT 8 +#define TRAP_SIZE 32 +#define TRAP_HANDLER_OFFSET 56 +#define TRAP_PREVIOUS_OFFSET 64 +#define CALLBACK_LINK_SIZE 32 +#define CALLBACK_LINK_OFFSET 48 +#endif +#if defined(MODEL_ppc64le) +#define RESERVED_STACK 32 +#define PARAM_SAVE_AREA 0 +#define LR_SAVE 16 +#define TOC_SAVE_PARENT 8 +#define TOC_SAVE 24 +#define TRAP_SIZE 32 +#define TRAP_HANDLER_OFFSET 40 +#define TRAP_PREVIOUS_OFFSET 48 +#define CALLBACK_LINK_SIZE 32 +#define CALLBACK_LINK_OFFSET 32 +#endif + +/* Function definitions */ + +#if defined(MODEL_ppc) +#define FUNCTION(name) \ + .section ".text"; \ + .globl name; \ + .type name, @function; \ + .align 2; \ + name: + +#define ENDFUNCTION(name) \ + .size name, . - name + +#endif + +#if defined(MODEL_ppc64) +#define FUNCTION(name) \ + .section ".opd","aw"; \ + .align 3; \ + .globl name; \ + .type name, @function; \ + name: .quad .L.name,.TOC.@tocbase; \ + .text; \ + .align 2; \ + .L.name: + +#define ENDFUNCTION(name) \ + .size name, . - .L.name + +#endif + +#if defined(MODEL_ppc64le) +#define FUNCTION(name) \ + .section ".text"; \ + .globl name; \ + .type name, @function; \ + .align 2; \ + name: ; \ + 0: addis 2, 12, (.TOC. - 0b)@ha; \ + addi 2, 2, (.TOC. - 0b)@l; \ + .localentry name, . - 0b + +#define ENDFUNCTION(name) \ + .size name, . - name + +#endif + +/* Accessing global variables. */ + +#if defined(MODEL_ppc) + +#define Addrglobal(reg,glob) \ + addis reg, 0, glob@ha; \ + addi reg, reg, glob@l +#define Loadglobal(reg,glob,tmp) \ + addis tmp, 0, glob@ha; \ + lg reg, glob@l(tmp) +#define Storeglobal(reg,glob,tmp) \ + addis tmp, 0, glob@ha; \ + stg reg, glob@l(tmp) +#define Loadglobal32(reg,glob,tmp) \ + addis tmp, 0, glob@ha; \ + lwz reg, glob@l(tmp) +#define Storeglobal32(reg,glob,tmp) \ + addis tmp, 0, glob@ha; \ + stw reg, glob@l(tmp) + +#endif + +#if defined(MODEL_ppc64) || defined(MODEL_ppc64le) + +#define LSYMB(glob) .L##glob + +#define Addrglobal(reg,glob) \ + ld reg, LSYMB(glob)@toc(2) +#define Loadglobal(reg,glob,tmp) \ + Addrglobal(tmp,glob); \ + lg reg, 0(tmp) +#define Storeglobal(reg,glob,tmp) \ + Addrglobal(tmp,glob); \ + stg reg, 0(tmp) +#define Loadglobal32(reg,glob,tmp) \ + Addrglobal(tmp,glob); \ + lwz reg, 0(tmp) +#define Storeglobal32(reg,glob,tmp) \ + Addrglobal(tmp,glob); \ + stw reg, 0(tmp) + +#endif + +#if defined(MODEL_ppc64) + .section ".opd","aw" +#else + .section ".text" +#endif + .globl caml_system__code_begin +caml_system__code_begin: + +/* Invoke the garbage collector. */ + +FUNCTION(caml_call_gc) +#define STACKSIZE (WORD*32 + 8*32 + PARAM_SAVE_AREA + RESERVED_STACK) + /* 32 integer registers + 32 float registers + space for C call */ + /* Set up stack frame */ + stwu 1, -STACKSIZE(1) + /* Record return address into OCaml code */ + mflr 0 + Storeglobal(0, caml_last_return_address, 11) + /* Record lowest stack address */ + addi 0, 1, STACKSIZE + Storeglobal(0, caml_bottom_of_stack, 11) + /* Record pointer to register array */ + addi 0, 1, 8*32 + PARAM_SAVE_AREA + RESERVED_STACK + Storeglobal(0, caml_gc_regs, 11) + /* Save current allocation pointer for debugging purposes */ + Storeglobal(31, caml_young_ptr, 11) + /* Save exception pointer (if e.g. a sighandler raises) */ + Storeglobal(29, caml_exception_pointer, 11) + /* Save all registers used by the code generator */ + addi 11, 1, 8*32 + PARAM_SAVE_AREA + RESERVED_STACK - WORD + stgu 3, WORD(11) + stgu 4, WORD(11) + stgu 5, WORD(11) + stgu 6, WORD(11) + stgu 7, WORD(11) + stgu 8, WORD(11) + stgu 9, WORD(11) + stgu 10, WORD(11) + stgu 14, WORD(11) + stgu 15, WORD(11) + stgu 16, WORD(11) + stgu 17, WORD(11) + stgu 18, WORD(11) + stgu 19, WORD(11) + stgu 20, WORD(11) + stgu 21, WORD(11) + stgu 22, WORD(11) + stgu 23, WORD(11) + stgu 24, WORD(11) + stgu 25, WORD(11) + stgu 26, WORD(11) + stgu 27, WORD(11) + stgu 28, WORD(11) + addi 11, 1, PARAM_SAVE_AREA + RESERVED_STACK - 8 + stfdu 1, 8(11) + stfdu 2, 8(11) + stfdu 3, 8(11) + stfdu 4, 8(11) + stfdu 5, 8(11) + stfdu 6, 8(11) + stfdu 7, 8(11) + stfdu 8, 8(11) + stfdu 9, 8(11) + stfdu 10, 8(11) + stfdu 11, 8(11) + stfdu 12, 8(11) + stfdu 13, 8(11) + stfdu 14, 8(11) + stfdu 15, 8(11) + stfdu 16, 8(11) + stfdu 17, 8(11) + stfdu 18, 8(11) + stfdu 19, 8(11) + stfdu 20, 8(11) + stfdu 21, 8(11) + stfdu 22, 8(11) + stfdu 23, 8(11) + stfdu 24, 8(11) + stfdu 25, 8(11) + stfdu 26, 8(11) + stfdu 27, 8(11) + stfdu 28, 8(11) + stfdu 29, 8(11) + stfdu 30, 8(11) + stfdu 31, 8(11) + /* Call the GC */ + bl caml_garbage_collection +#if defined(MODEL_ppc64) || defined(MODEL_ppc64le) + nop +#endif + /* Reload new allocation pointer and allocation limit */ + Loadglobal(31, caml_young_ptr, 11) + Loadglobal(30, caml_young_limit, 11) + /* Restore all regs used by the code generator */ + addi 11, 1, 8*32 + PARAM_SAVE_AREA + RESERVED_STACK - WORD + lgu 3, WORD(11) + lgu 4, WORD(11) + lgu 5, WORD(11) + lgu 6, WORD(11) + lgu 7, WORD(11) + lgu 8, WORD(11) + lgu 9, WORD(11) + lgu 10, WORD(11) + lgu 14, WORD(11) + lgu 15, WORD(11) + lgu 16, WORD(11) + lgu 17, WORD(11) + lgu 18, WORD(11) + lgu 19, WORD(11) + lgu 20, WORD(11) + lgu 21, WORD(11) + lgu 22, WORD(11) + lgu 23, WORD(11) + lgu 24, WORD(11) + lgu 25, WORD(11) + lgu 26, WORD(11) + lgu 27, WORD(11) + lgu 28, WORD(11) + addi 11, 1, PARAM_SAVE_AREA + RESERVED_STACK - 8 + lfdu 1, 8(11) + lfdu 2, 8(11) + lfdu 3, 8(11) + lfdu 4, 8(11) + lfdu 5, 8(11) + lfdu 6, 8(11) + lfdu 7, 8(11) + lfdu 8, 8(11) + lfdu 9, 8(11) + lfdu 10, 8(11) + lfdu 11, 8(11) + lfdu 12, 8(11) + lfdu 13, 8(11) + lfdu 14, 8(11) + lfdu 15, 8(11) + lfdu 16, 8(11) + lfdu 17, 8(11) + lfdu 18, 8(11) + lfdu 19, 8(11) + lfdu 20, 8(11) + lfdu 21, 8(11) + lfdu 22, 8(11) + lfdu 23, 8(11) + lfdu 24, 8(11) + lfdu 25, 8(11) + lfdu 26, 8(11) + lfdu 27, 8(11) + lfdu 28, 8(11) + lfdu 29, 8(11) + lfdu 30, 8(11) + lfdu 31, 8(11) + /* Return to caller, restarting the allocation */ + Loadglobal(11, caml_last_return_address, 11) + addi 11, 11, -16 /* Restart the allocation (4 instructions) */ + mtlr 11 + /* For PPC64: restore the TOC that the caller saved at the usual place */ +#ifdef TOC_SAVE + ld 2, (STACKSIZE + TOC_SAVE)(1) +#endif + /* Deallocate stack frame */ + addi 1, 1, STACKSIZE + blr +#undef STACKSIZE +ENDFUNCTION(caml_call_gc) + +/* Call a C function from OCaml */ + +FUNCTION(caml_c_call) + .cfi_startproc + /* Save return address in a callee-save register */ + mflr 27 + .cfi_register 65, 27 + /* Record lowest stack address and return address */ + Storeglobal(1, caml_bottom_of_stack, 11) + Storeglobal(27, caml_last_return_address, 11) + /* Make the exception handler and alloc ptr available to the C code */ + Storeglobal(31, caml_young_ptr, 11) + Storeglobal(29, caml_exception_pointer, 11) + /* Call C function (address in r28) */ +#if defined(MODEL_ppc) + mtctr 28 + bctrl +#elif defined(MODEL_ppc64) + ld 0, 0(28) + mr 26, 2 /* save current TOC in a callee-save register */ + mtctr 0 + ld 2, 8(28) + bctrl + mr 2, 26 /* restore current TOC */ +#elif defined(MODEL_ppc64le) + mtctr 28 + mr 12, 28 + mr 26, 2 /* save current TOC in a callee-save register */ + bctrl + mr 2, 26 /* restore current TOC */ +#else +#error "wrong MODEL" +#endif + /* Restore return address (in 27, preserved by the C function) */ + mtlr 27 + /* Reload allocation pointer and allocation limit*/ + Loadglobal(31, caml_young_ptr, 11) + Loadglobal(30, caml_young_limit, 11) + /* Return to caller */ + blr + .cfi_endproc +ENDFUNCTION(caml_c_call) + +/* Raise an exception from OCaml */ + +FUNCTION(caml_raise_exn) + Loadglobal32(0, caml_backtrace_active, 11) + cmpwi 0, 0 + bne .L111 +.L110: + /* Pop trap frame */ + lg 0, TRAP_HANDLER_OFFSET(29) + mr 1, 29 + mtctr 0 + lg 29, TRAP_PREVIOUS_OFFSET(1) + addi 1, 1, TRAP_SIZE + /* Branch to handler */ + bctr +.L111: + mr 28, 3 /* preserve exn bucket in callee-save reg */ + /* arg1: exception bucket, already in r3 */ + mflr 4 /* arg2: PC of raise */ + mr 5, 1 /* arg3: SP of raise */ + mr 6, 29 /* arg4: SP of handler */ + addi 1, 1, -(PARAM_SAVE_AREA + RESERVED_STACK) + /* reserve stack space for C call */ + bl caml_stash_backtrace +#if defined(MODEL_ppc64) || defined(MODEL_ppc64le) + nop +#endif + mr 3, 28 /* restore exn bucket */ + b .L110 /* raise the exn */ +ENDFUNCTION(caml_raise_exn) + +/* Raise an exception from C */ + +FUNCTION(caml_raise_exception) + Loadglobal32(0, caml_backtrace_active, 11) + cmpwi 0, 0 + bne .L121 +.L120: + /* Reload OCaml global registers */ + Loadglobal(1, caml_exception_pointer, 11) + Loadglobal(31, caml_young_ptr, 11) + Loadglobal(30, caml_young_limit, 11) + /* Pop trap frame */ + lg 0, TRAP_HANDLER_OFFSET(1) + mtctr 0 + lg 29, TRAP_PREVIOUS_OFFSET(1) + addi 1, 1, TRAP_SIZE + /* Branch to handler */ + bctr +.L121: + li 0, 0 + Storeglobal32(0, caml_backtrace_pos, 11) + mr 28, 3 /* preserve exn bucket in callee-save reg */ + /* arg1: exception bucket, already in r3 */ + Loadglobal(4, caml_last_return_address, 11) /* arg2: PC of raise */ + Loadglobal(5, caml_bottom_of_stack, 11) /* arg3: SP of raise */ + Loadglobal(6, caml_exception_pointer, 11) /* arg4: SP of handler */ + addi 1, 1, -(PARAM_SAVE_AREA + RESERVED_STACK) + /* reserve stack space for C call */ + bl caml_stash_backtrace +#if defined(MODEL_ppc64) || defined(MODEL_ppc64le) + nop +#endif + mr 3, 28 /* restore exn bucket */ + b .L120 /* raise the exn */ +ENDFUNCTION(caml_raise_exception) + +/* Start the OCaml program */ + +FUNCTION(caml_start_program) + .cfi_startproc +#define STACKSIZE (WORD*18 + 8*18 + CALLBACK_LINK_SIZE + RESERVED_STACK) + /* 18 callee-save GPR14...GPR31 + 18 callee-save FPR14...FPR31 */ + Addrglobal(12, caml_program) +/* Code shared between caml_start_program and caml_callback */ +.L102: + /* Allocate and link stack frame */ + stgu 1, -STACKSIZE(1) + .cfi_adjust_cfa_offset STACKSIZE + /* Save return address */ + mflr 0 + stg 0, (STACKSIZE + LR_SAVE)(1) + .cfi_offset 65, LR_SAVE + /* Save TOC pointer if applicable */ +#ifdef TOC_SAVE_PARENT + std 2, (STACKSIZE + TOC_SAVE_PARENT)(1) +#endif + /* Save all callee-save registers */ + addi 11, 1, CALLBACK_LINK_SIZE + RESERVED_STACK - WORD + stgu 14, WORD(11) + stgu 15, WORD(11) + stgu 16, WORD(11) + stgu 17, WORD(11) + stgu 18, WORD(11) + stgu 19, WORD(11) + stgu 20, WORD(11) + stgu 21, WORD(11) + stgu 22, WORD(11) + stgu 23, WORD(11) + stgu 24, WORD(11) + stgu 25, WORD(11) + stgu 26, WORD(11) + stgu 27, WORD(11) + stgu 28, WORD(11) + stgu 29, WORD(11) + stgu 30, WORD(11) + stgu 31, WORD(11) + stfdu 14, 8(11) + stfdu 15, 8(11) + stfdu 16, 8(11) + stfdu 17, 8(11) + stfdu 18, 8(11) + stfdu 19, 8(11) + stfdu 20, 8(11) + stfdu 21, 8(11) + stfdu 22, 8(11) + stfdu 23, 8(11) + stfdu 24, 8(11) + stfdu 25, 8(11) + stfdu 26, 8(11) + stfdu 27, 8(11) + stfdu 28, 8(11) + stfdu 29, 8(11) + stfdu 30, 8(11) + stfdu 31, 8(11) + /* Set up a callback link */ + Loadglobal(11, caml_bottom_of_stack, 11) + stg 11, CALLBACK_LINK_OFFSET(1) + Loadglobal(11, caml_last_return_address, 11) + stg 11, (CALLBACK_LINK_OFFSET + WORD)(1) + Loadglobal(11, caml_gc_regs, 11) + stg 11, (CALLBACK_LINK_OFFSET + 2 * WORD)(1) + /* Build an exception handler to catch exceptions escaping out of OCaml */ + bl .L103 + b .L104 +.L103: + addi 1, 1, -TRAP_SIZE + .cfi_adjust_cfa_offset TRAP_SIZE + mflr 0 + stg 0, TRAP_HANDLER_OFFSET(1) + Loadglobal(11, caml_exception_pointer, 11) + stg 11, TRAP_PREVIOUS_OFFSET(1) + mr 29, 1 + /* Reload allocation pointers */ + Loadglobal(31, caml_young_ptr, 11) + Loadglobal(30, caml_young_limit, 11) + /* Call the OCaml code (address in r12) */ +#if defined(MODEL_ppc) + mtctr 12 +.L105: bctrl +#elif defined(MODEL_ppc64) + ld 0, 0(12) + mtctr 0 + std 2, TOC_SAVE(1) + ld 2, 8(12) +.L105: bctrl + ld 2, TOC_SAVE(1) +#elif defined(MODEL_ppc64le) + mtctr 12 + std 2, TOC_SAVE(1) +.L105: bctrl + ld 2, TOC_SAVE(1) +#else +#error "wrong MODEL" +#endif + /* Pop the trap frame, restoring caml_exception_pointer */ + lg 0, TRAP_PREVIOUS_OFFSET(1) + Storeglobal(0, caml_exception_pointer, 11) + addi 1, 1, TRAP_SIZE + .cfi_adjust_cfa_offset -TRAP_SIZE + /* Pop the callback link, restoring the global variables */ +.L106: + lg 0, CALLBACK_LINK_OFFSET(1) + Storeglobal(0, caml_bottom_of_stack, 11) + lg 0, (CALLBACK_LINK_OFFSET + WORD)(1) + Storeglobal(0, caml_last_return_address, 11) + lg 0, (CALLBACK_LINK_OFFSET + 2 * WORD)(1) + Storeglobal(0, caml_gc_regs, 11) + /* Update allocation pointer */ + Storeglobal(31, caml_young_ptr, 11) + /* Restore callee-save registers */ + addi 11, 1, CALLBACK_LINK_SIZE + RESERVED_STACK - WORD + lgu 14, WORD(11) + lgu 15, WORD(11) + lgu 16, WORD(11) + lgu 17, WORD(11) + lgu 18, WORD(11) + lgu 19, WORD(11) + lgu 20, WORD(11) + lgu 21, WORD(11) + lgu 22, WORD(11) + lgu 23, WORD(11) + lgu 24, WORD(11) + lgu 25, WORD(11) + lgu 26, WORD(11) + lgu 27, WORD(11) + lgu 28, WORD(11) + lgu 29, WORD(11) + lgu 30, WORD(11) + lgu 31, WORD(11) + lfdu 14, 8(11) + lfdu 15, 8(11) + lfdu 16, 8(11) + lfdu 17, 8(11) + lfdu 18, 8(11) + lfdu 19, 8(11) + lfdu 20, 8(11) + lfdu 21, 8(11) + lfdu 22, 8(11) + lfdu 23, 8(11) + lfdu 24, 8(11) + lfdu 25, 8(11) + lfdu 26, 8(11) + lfdu 27, 8(11) + lfdu 28, 8(11) + lfdu 29, 8(11) + lfdu 30, 8(11) + lfdu 31, 8(11) + /* Reload return address */ + lg 0, (STACKSIZE + LR_SAVE)(1) + mtlr 0 + /* Return */ + addi 1, 1, STACKSIZE + blr + + /* The trap handler: */ +.L104: + /* Restore TOC pointer */ +#ifdef TOC_SAVE_PARENT + ld 2, (STACKSIZE + TOC_SAVE_PARENT)(1) +#endif + /* Update caml_exception_pointer */ + Storeglobal(29, caml_exception_pointer, 11) + /* Encode exception bucket as an exception result and return it */ + ori 3, 3, 2 + b .L106 +#undef STACKSIZE + .cfi_endproc +ENDFUNCTION(caml_start_program) + +/* Callback from C to OCaml */ + +FUNCTION(caml_callback_exn) + /* Initial shuffling of arguments */ + mr 0, 3 /* Closure */ + mr 3, 4 /* Argument */ + mr 4, 0 + lg 12, 0(4) /* Code pointer */ + b .L102 +ENDFUNCTION(caml_callback_exn) + +FUNCTION(caml_callback2_exn) + mr 0, 3 /* Closure */ + mr 3, 4 /* First argument */ + mr 4, 5 /* Second argument */ + mr 5, 0 + Addrglobal(12, caml_apply2) + b .L102 +ENDFUNCTION(caml_callback2_exn) + +FUNCTION(caml_callback3_exn) + mr 0, 3 /* Closure */ + mr 3, 4 /* First argument */ + mr 4, 5 /* Second argument */ + mr 5, 6 /* Third argument */ + mr 6, 0 + Addrglobal(12, caml_apply3) + b .L102 +ENDFUNCTION(caml_callback3_exn) + +#if defined(MODEL_ppc64) + .section ".opd","aw" +#else + .section ".text" +#endif + + .globl caml_system__code_end +caml_system__code_end: + +/* Frame table */ + + .section ".data" + .globl caml_system__frametable + .type caml_system__frametable, @object +caml_system__frametable: + datag 1 /* one descriptor */ + datag .L105 + 4 /* return address into callback */ + .short -1 /* negative size count => use callback link */ + .short 0 /* no roots here */ + +/* TOC entries */ + +#if defined(MODEL_ppc64) || defined(MODEL_ppc64le) + + .section ".toc", "aw" + +#define TOCENTRY(glob) LSYMB(glob): .quad glob + +TOCENTRY(caml_apply2) +TOCENTRY(caml_apply3) +TOCENTRY(caml_backtrace_active) +TOCENTRY(caml_backtrace_pos) +TOCENTRY(caml_bottom_of_stack) +TOCENTRY(caml_exception_pointer) +TOCENTRY(caml_gc_regs) +TOCENTRY(caml_last_return_address) +TOCENTRY(caml_program) +TOCENTRY(caml_young_limit) +TOCENTRY(caml_young_ptr) + +#endif + +/* Mark stack as non-executable */ + .section .note.GNU-stack,"",%progbits diff -Nru ocaml-4.01.0/asmrun/roots.c ocaml-4.05.0/asmrun/roots.c --- ocaml-4.01.0/asmrun/roots.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmrun/roots.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,27 +1,31 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* To walk the memory roots for garbage collection */ -#include "finalise.h" -#include "globroots.h" -#include "memory.h" -#include "major_gc.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "stack.h" -#include "roots.h" +#include "caml/finalise.h" +#include "caml/globroots.h" +#include "caml/memory.h" +#include "caml/major_gc.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/stack.h" +#include "caml/roots.h" #include #include @@ -32,9 +36,8 @@ void (*caml_scan_roots_hook) (scanning_action) = NULL; /* The hashtable of frame descriptors */ - frame_descr ** caml_frame_descriptors = NULL; -int caml_frame_descriptors_mask; +int caml_frame_descriptors_mask = 0; /* Linked-list */ @@ -56,52 +59,43 @@ /* Linked-list of frametables */ static link *frametables = NULL; +static intnat num_descr = 0; -void caml_register_frametable(intnat *table) { - frametables = cons(table,frametables); +static int count_descriptors(link *list) { + intnat num_descr = 0; + link *lnk; + iter_list(list,lnk) { + num_descr += *((intnat*) lnk->data); + } + return num_descr; +} - if (NULL != caml_frame_descriptors) { - caml_stat_free(caml_frame_descriptors); - caml_frame_descriptors = NULL; - /* force caml_init_frame_descriptors to be called */ +static link* frametables_list_tail(link *list) { + link *lnk, *tail = NULL; + iter_list(list,lnk) { + tail = lnk; } + return tail; } -void caml_init_frame_descriptors(void) -{ - intnat num_descr, tblsize, i, j, len; +static frame_descr * next_frame_descr(frame_descr * d) { + uintnat nextd; + nextd = + ((uintnat)d + + sizeof(char *) + sizeof(short) + sizeof(short) + + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) + & -sizeof(frame_descr *); + if (d->frame_size & 1) nextd += sizeof(void *); /* pointer to debuginfo */ + return((frame_descr *) nextd); +} + +static void fill_hashtable(link *frametables) { + intnat len, j; intnat * tbl; frame_descr * d; - uintnat nextd; uintnat h; - link *lnk; - - static int inited = 0; - - if (!inited) { - for (i = 0; caml_frametable[i] != 0; i++) - caml_register_frametable(caml_frametable[i]); - inited = 1; - } - - /* Count the frame descriptors */ - num_descr = 0; - iter_list(frametables,lnk) { - num_descr += *((intnat*) lnk->data); - } + link *lnk = NULL; - /* The size of the hashtable is a power of 2 greater or equal to - 2 times the number of descriptors */ - tblsize = 4; - while (tblsize < 2 * num_descr) tblsize *= 2; - - /* Allocate the hash table */ - caml_frame_descriptors = - (frame_descr **) caml_stat_alloc(tblsize * sizeof(frame_descr *)); - for (i = 0; i < tblsize; i++) caml_frame_descriptors[i] = NULL; - caml_frame_descriptors_mask = tblsize - 1; - - /* Fill the hash table */ iter_list(frametables,lnk) { tbl = (intnat*) lnk->data; len = *tbl; @@ -112,14 +106,115 @@ h = (h+1) & caml_frame_descriptors_mask; } caml_frame_descriptors[h] = d; - nextd = - ((uintnat)d + - sizeof(char *) + sizeof(short) + sizeof(short) + - sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) - & -sizeof(frame_descr *); - if (d->frame_size & 1) nextd += 8; - d = (frame_descr *) nextd; + d = next_frame_descr(d); + } + } +} + +static void init_frame_descriptors(link *new_frametables) +{ + intnat tblsize, increase, i; + link *tail = NULL; + + Assert(new_frametables); + + tail = frametables_list_tail(new_frametables); + increase = count_descriptors(new_frametables); + tblsize = caml_frame_descriptors_mask + 1; + + /* Reallocate the caml_frame_descriptor table if it is too small */ + if(tblsize < (num_descr + increase) * 2) { + + /* Merge both lists */ + tail->next = frametables; + frametables = NULL; + + /* [num_descr] can be less than [num_descr + increase] if frame + tables where unregistered */ + num_descr = count_descriptors(new_frametables); + + tblsize = 4; + while (tblsize < 2 * num_descr) tblsize *= 2; + + caml_frame_descriptors_mask = tblsize - 1; + if(caml_frame_descriptors) caml_stat_free(caml_frame_descriptors); + caml_frame_descriptors = + (frame_descr **) caml_stat_alloc(tblsize * sizeof(frame_descr *)); + for (i = 0; i < tblsize; i++) caml_frame_descriptors[i] = NULL; + + fill_hashtable(new_frametables); + } else { + num_descr += increase; + fill_hashtable(new_frametables); + tail->next = frametables; + } + + frametables = new_frametables; +} + +void caml_init_frame_descriptors(void) { + intnat i; + link *new_frametables = NULL; + for (i = 0; caml_frametable[i] != 0; i++) + new_frametables = cons(caml_frametable[i],new_frametables); + init_frame_descriptors(new_frametables); +} + +void caml_register_frametable(intnat *table) { + link *new_frametables = cons(table,NULL); + init_frame_descriptors(new_frametables); +} + +static void remove_entry(frame_descr * d) { + uintnat i; + uintnat r; + uintnat j; + + i = Hash_retaddr(d->retaddr); + while (caml_frame_descriptors[i] != d) { + i = (i+1) & caml_frame_descriptors_mask; + } + + r1: + j = i; + caml_frame_descriptors[i] = NULL; + r2: + i = (i+1) & caml_frame_descriptors_mask; + // r3 + if(caml_frame_descriptors[i] == NULL) return; + r = Hash_retaddr(caml_frame_descriptors[i]->retaddr); + /* If r is between i and j (cyclically), i.e. if + caml_frame_descriptors[i]->retaddr don't need to be moved */ + if(( ( j < r ) && ( r <= i ) ) || + ( ( i < j ) && ( j < r ) ) || /* i cycled, r not */ + ( ( r <= i ) && ( i < j ) ) ) { /* i and r cycled */ + goto r2; + } + // r4 + caml_frame_descriptors[j] = caml_frame_descriptors[i]; + goto r1; +} + +void caml_unregister_frametable(intnat *table) { + intnat len, j; + link *lnk; + link *previous = frametables; + frame_descr * d; + + len = *table; + d = (frame_descr *)(table + 1); + for (j = 0; j < len; j++) { + remove_entry(d); + d = next_frame_descr(d); + } + + iter_list(frametables,lnk) { + if(lnk->data == table) { + previous->next = lnk->next; + caml_stat_free(lnk); + break; } + previous = lnk; } } @@ -152,7 +247,7 @@ #else unsigned short * p; #endif - value glob; + value * glob; value * root; struct caml__roots_block *lr; link *lnk; @@ -161,23 +256,24 @@ for (i = caml_globals_scanned; i <= caml_globals_inited && caml_globals[i] != 0; i++) { - glob = caml_globals[i]; - for (j = 0; j < Wosize_val(glob); j++){ - Oldify (&Field (glob, j)); + for(glob = caml_globals[i]; *glob != 0; glob++) { + for (j = 0; j < Wosize_val(*glob); j++){ + Oldify (&Field (*glob, j)); + } } } caml_globals_scanned = caml_globals_inited; /* Dynamic global roots */ iter_list(caml_dyn_globals, lnk) { - glob = (value) lnk->data; - for (j = 0; j < Wosize_val(glob); j++){ - Oldify (&Field (glob, j)); + for(glob = (value *) lnk->data; *glob != 0; glob++) { + for (j = 0; j < Wosize_val(*glob); j++){ + Oldify (&Field (*glob, j)); + } } } /* The stack and local roots */ - if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); sp = caml_bottom_of_stack; retaddr = caml_last_return_address; regs = caml_gc_regs; @@ -238,49 +334,105 @@ /* Global C roots */ caml_scan_global_young_roots(&caml_oldify_one); /* Finalised values */ - caml_final_do_young_roots (&caml_oldify_one); + caml_final_oldify_young_roots (); /* Hook */ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one); } -/* Call [darken] on all roots */ +uintnat caml_incremental_roots_count = 0; -void caml_darken_all_roots (void) +/* Call [caml_darken] on all roots, incrementally: + [caml_darken_all_roots_start] does the non-incremental part and + sets things up for [caml_darken_all_roots_slice]. +*/ +void caml_darken_all_roots_start (void) { - caml_do_roots (caml_darken); + caml_do_roots (caml_darken, 0); } -void caml_do_roots (scanning_action f) +/* Call [caml_darken] on at most [work] global roots. Return the + amount of work not done, if any. If this is strictly positive, + the darkening is done. + */ +intnat caml_darken_all_roots_slice (intnat work) { - int i, j; - value glob; - link *lnk; + static int i, j; + static value *glob; + static int do_resume = 0; + static mlsize_t roots_count = 0; + intnat remaining_work = work; + CAML_INSTR_SETUP (tmr, ""); - /* The global roots */ + /* If the loop was started in a previous call, resume it. */ + if (do_resume) goto resume; + + /* This is the same loop as in [caml_do_roots], but we make it + suspend itself when [work] reaches 0. */ for (i = 0; caml_globals[i] != 0; i++) { - glob = caml_globals[i]; - for (j = 0; j < Wosize_val(glob); j++) - f (Field (glob, j), &Field (glob, j)); + for(glob = caml_globals[i]; *glob != 0; glob++) { + for (j = 0; j < Wosize_val(*glob); j++){ + caml_darken (Field (*glob, j), &Field (*glob, j)); + -- remaining_work; + if (remaining_work == 0){ + roots_count += work; + do_resume = 1; + goto suspend; + } + resume: ; + } + } } + /* The loop finished normally, so all roots are now darkened. */ + caml_incremental_roots_count = roots_count + work - remaining_work; + /* Prepare for the next run. */ + do_resume = 0; + roots_count = 0; + + suspend: + /* Do this in both cases. */ + CAML_INSTR_TIME (tmr, "major/mark/global_roots_slice"); + return remaining_work; +} + +void caml_do_roots (scanning_action f, int do_globals) +{ + int i, j; + value * glob; + link *lnk; + CAML_INSTR_SETUP (tmr, "major_roots"); + + if (do_globals){ + /* The global roots */ + for (i = 0; caml_globals[i] != 0; i++) { + for(glob = caml_globals[i]; *glob != 0; glob++) { + for (j = 0; j < Wosize_val(*glob); j++) + f (Field (*glob, j), &Field (*glob, j)); + } + } + } /* Dynamic global roots */ iter_list(caml_dyn_globals, lnk) { - glob = (value) lnk->data; - for (j = 0; j < Wosize_val(glob); j++){ - f (Field (glob, j), &Field (glob, j)); + for(glob = (value *) lnk->data; *glob != 0; glob++) { + for (j = 0; j < Wosize_val(*glob); j++){ + f (Field (*glob, j), &Field (*glob, j)); + } } } - + CAML_INSTR_TIME (tmr, "major_roots/dynamic_global"); /* The stack and local roots */ - if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); caml_do_local_roots(f, caml_bottom_of_stack, caml_last_return_address, caml_gc_regs, caml_local_roots); + CAML_INSTR_TIME (tmr, "major_roots/local"); /* Global C roots */ caml_scan_global_roots(f); + CAML_INSTR_TIME (tmr, "major_roots/C"); /* Finalised values */ - caml_final_do_strong_roots (f); + caml_final_do_roots (f); + CAML_INSTR_TIME (tmr, "major_roots/finalised"); /* Hook */ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f); + CAML_INSTR_TIME (tmr, "major_roots/hook"); } void caml_do_local_roots(scanning_action f, char * bottom_of_stack, diff -Nru ocaml-4.01.0/asmrun/s390x.S ocaml-4.05.0/asmrun/s390x.S --- ocaml-4.01.0/asmrun/s390x.S 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmrun/s390x.S 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,340 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ +/* Bill O'Farrell, IBM */ +/* */ +/* Copyright 2015 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* Copyright 2015 IBM (Bill O'Farrell with help from Tristan Amini). */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ +#define Addrglobal(reg,glob) \ + larl reg, glob +#define Loadglobal(reg,glob) \ + lgrl reg, glob +#define Storeglobal(reg,glob) \ + stgrl reg, glob +#define Loadglobal32(reg,glob) \ + lgfrl reg, glob +#define Storeglobal32(reg,glob) \ + strl reg, glob + + + .section ".text" + +/* Invoke the garbage collector. */ + + .globl caml_system__code_begin +caml_system__code_begin: + + .globl caml_call_gc + .type caml_call_gc, @function +caml_call_gc: + /* Set up stack frame */ +#define FRAMESIZE (16*8 + 16*8) + lay %r15, -FRAMESIZE(%r15) + /* Record return address into OCaml code */ + Storeglobal(%r14, caml_last_return_address) + /* Record lowest stack address */ + lay %r0, FRAMESIZE(%r15) + Storeglobal(%r0, caml_bottom_of_stack) + /* Record pointer to register array */ + lay %r0, (8*16)(%r15) + Storeglobal(%r0, caml_gc_regs) + /* Save current allocation pointer for debugging purposes */ + Storeglobal(%r11, caml_young_ptr) + /* Save exception pointer (if e.g. a sighandler raises) */ + Storeglobal(%r13, caml_exception_pointer) + /* Save all registers used by the code generator */ + stmg %r2,%r9, (8*16)(%r15) + stg %r12, (8*16 + 8*8)(%r15) + std %f0, 0(%r15) + std %f1, 8(%r15) + std %f2, 16(%r15) + std %f3, 24(%r15) + std %f4, 32(%r15) + std %f5, 40(%r15) + std %f6, 48(%r15) + std %f7, 56(%r15) + std %f8, 64(%r15) + std %f9, 72(%r15) + std %f10, 80(%r15) + std %f11, 88(%r15) + std %f12, 96(%r15) + std %f13, 108(%r15) + std %f14, 112(%r15) + std %f15, 120(%r15) + /* Call the GC */ + lay %r15, -160(%r15) + stg %r15, 0(%r15) + brasl %r14, caml_garbage_collection@PLT + lay %r15, 160(%r15) + /* Reload new allocation pointer and allocation limit */ + Loadglobal(%r11, caml_young_ptr) + Loadglobal(%r10, caml_young_limit) + /* Restore all regs used by the code generator */ + lmg %r2,%r9, (8*16)(%r15) + lg %r12, (8*16 + 8*8)(%r15) + ld %f0, 0(%r15) + ld %f1, 8(%r15) + ld %f2, 16(%r15) + ld %f3, 24(%r15) + ld %f4, 32(%r15) + ld %f5, 40(%r15) + ld %f6, 48(%r15) + ld %f7, 56(%r15) + ld %f8, 64(%r15) + ld %f9, 72(%r15) + ld %f10, 80(%r15) + ld %f11, 88(%r15) + ld %f12, 96(%r15) + ld %f13, 108(%r15) + ld %f14, 112(%r15) + ld %f15, 120(%r15) + /* Return to caller */ + Loadglobal(%r1, caml_last_return_address) + /* Deallocate stack frame */ + lay %r15, FRAMESIZE(%r15) + /* Return */ + br %r1 + +/* Call a C function from OCaml */ + + .globl caml_c_call + .type caml_c_call, @function +caml_c_call: + Storeglobal(%r15, caml_bottom_of_stack) +.L101: + /* Save return address */ + ldgr %f15, %r14 + /* Get ready to call C function (address in r7) */ + /* Record lowest stack address and return address */ + Storeglobal(%r14, caml_last_return_address) + /* Make the exception handler and alloc ptr available to the C code */ + Storeglobal(%r11, caml_young_ptr) + Storeglobal(%r13, caml_exception_pointer) + /* Call the function */ + basr %r14, %r7 + /* restore return address */ + lgdr %r14,%f15 + /* Reload allocation pointer and allocation limit*/ + Loadglobal(%r11, caml_young_ptr) + Loadglobal(%r10, caml_young_limit) + /* Return to caller */ + br %r14 + +/* Raise an exception from OCaml */ + .globl caml_raise_exn + .type caml_raise_exn, @function +caml_raise_exn: + Loadglobal32(%r0, caml_backtrace_active) + cgfi %r0, 0 + jne .L110 +.L111: + /* Pop trap frame */ + lg %r1, 0(%r13) + lgr %r15, %r13 + lg %r13, 8(13) + agfi %r15, 16 + /* Branch to handler */ + br %r1 +.L110: + ldgr %f15, %r2 /* preserve exn bucket in callee-save reg */ + /* arg1: exception bucket, already in r3 */ + lgr %r3,%r14 /* arg2: PC of raise */ + lgr %r4, %r15 /* arg3: SP of raise */ + lgr %r5, %r13 /* arg4: SP of handler */ + agfi %r15, -160 /* reserve stack space for C call */ + brasl %r14, caml_stash_backtrace@PLT + agfi %r15, 160 + lgdr %r2,%f15 /* restore exn bucket */ + j .L111 /* raise the exn */ + +/* Raise an exception from C */ + + .globl caml_raise_exception + .type caml_raise_exception, @function +caml_raise_exception: + Loadglobal32(%r0, caml_backtrace_active) + cgfi %r0, 0 + jne .L112 +.L113: + /* Reload OCaml global registers */ + Loadglobal(%r15, caml_exception_pointer) + Loadglobal(%r11, caml_young_ptr) + Loadglobal(%r10, caml_young_limit) + /* Pop trap frame */ + lg %r1, 0(%r15) + lg %r13, 8(%r15) + agfi %r15, 16 + /* Branch to handler */ + br %r1; +.L112: + lgfi %r0, 0 + Storeglobal32(%r0, caml_backtrace_pos) + ldgr %f15,%r2 /* preserve exn bucket in callee-save reg */ + /* arg1: exception bucket, already in r2 */ + Loadglobal(%r3, caml_last_return_address) /* arg2: PC of raise */ + Loadglobal(%r4, caml_bottom_of_stack) /* arg3: SP of raise */ + Loadglobal(%r5, caml_exception_pointer) /* arg4: SP of handler */ + /* reserve stack space for C call */ + lay %r15, -160(%r15) + brasl %r14, caml_stash_backtrace@PLT + lay %r15, 160(%r15) + lgdr %r2,%f15 /* restore exn bucket */ + j .L113 /* raise the exn */ + +/* Start the OCaml program */ + + .globl caml_start_program + .type caml_start_program, @function +caml_start_program: + Addrglobal(%r0, caml_program) + +/* Code shared between caml_start_program and caml_callback */ +.L102: + /* Allocate stack frame */ + lay %r15, -144(%r15) + /* Save all callee-save registers + return address */ + /* GPR 6..14 at sp + 0 ... sp + 64 + FPR 10..15 at sp + 72 ... sp + 128 */ + stmg %r6,%r14, 0(%r15) + std %f8, 72(%r15) + std %f9, 80(%r15) + std %f10, 88(%r15) + std %f11, 96(%r15) + std %f12, 104(%r15) + std %f13, 112(%r15) + std %f14, 120(%r15) + std %f15, 128(%r15) + + /* Set up a callback link */ + lay %r15, -32(%r15) + Loadglobal(%r1, caml_bottom_of_stack) + stg %r1, 0(%r15) + Loadglobal(%r1, caml_last_return_address) + stg %r1, 8(%r15) + Loadglobal(%r1, caml_gc_regs) + stg %r1, 16(%r15) + /* Build an exception handler to catch exceptions escaping out of OCaml */ + brasl %r14, .L103 + j .L104 +.L103: + lay %r15, -16(%r15) + stg %r14, 0(%r15) + Loadglobal(%r1, caml_exception_pointer) + stg %r1, 8(%r15) + lgr %r13, %r15 + /* Reload allocation pointers */ + Loadglobal(%r11, caml_young_ptr) + Loadglobal(%r10, caml_young_limit) + /* Call the OCaml code */ + lgr %r1,%r0 + basr %r14, %r1 +.L105: + /* Pop the trap frame, restoring caml_exception_pointer */ + lg %r0, 8(%r15) + Storeglobal(%r0, caml_exception_pointer) + la %r15, 16(%r15) + /* Pop the callback link, restoring the global variables */ +.L106: + lg %r5, 0(%r15) + lg %r6, 8(%r15) + lg %r1, 16(%r15) + Storeglobal(%r5, caml_bottom_of_stack) + Storeglobal(%r6, caml_last_return_address) + Storeglobal(%r1, caml_gc_regs) + la %r15, 32(%r15) + + /* Update allocation pointer */ + Storeglobal(%r11, caml_young_ptr) + + /* Restore registers */ + lmg %r6,%r14, 0(%r15) + ld %f8, 72(%r15) + ld %f9, 80(%r15) + ld %f10, 88(%r15) + ld %f11, 96(%r15) + ld %f12, 104(%r15) + ld %f13, 112(%r15) + ld %f14, 120(%r15) + ld %f15, 128(%r15) + + /* Return */ + lay %r15, 144(%r15) + br %r14 + + /* The trap handler: */ +.L104: + /* Update caml_exception_pointer */ + Storeglobal(%r13, caml_exception_pointer) + /* Encode exception bucket as an exception result and return it */ + oill %r2, 2 + j .L106 + +/* Callback from C to OCaml */ + + .globl caml_callback_exn + .type caml_callback_exn, @function +caml_callback_exn: + /* Initial shuffling of arguments */ + lgr %r0, %r2 /* Closure */ + lgr %r2, %r3 /* Argument */ + lgr %r3, %r0 + lg %r0, 0(%r3) /* Code pointer */ + j .L102 + + .globl caml_callback2_exn + .type caml_callback2_exn, @function +caml_callback2_exn: + lgr %r0, %r2 /* Closure */ + lgr %r2, %r3 /* First argument */ + lgr %r3, %r4 /* Second argument */ + lgr %r4, %r0 + Addrglobal(%r0, caml_apply2) + j .L102 + + .globl caml_callback3_exn + .type caml_callback3_exn, @function +caml_callback3_exn: + lgr %r0, %r2 /* Closure */ + lgr %r2, %r3 /* First argument */ + lgr %r3, %r4 /* Second argument */ + lgr %r4, %r5 /* Third argument */ + lgr %r5, %r0 + Addrglobal(%r0, caml_apply3) + j .L102 + + .globl caml_ml_array_bound_error + .type caml_ml_array_bound_error, @function +caml_ml_array_bound_error: + /* Save return address before decrementing SP, otherwise + the frame descriptor for the call site is not correct */ + Storeglobal(%r15, caml_bottom_of_stack) + lay %r15, -160(%r15) /* Reserve stack space for C call */ + larl %r7, caml_array_bound_error + j .L101 + .globl caml_system__code_end +caml_system__code_end: + +/* Frame table */ + + .section ".data" + .align 8 + .globl caml_system__frametable + .type caml_system__frametable, @object +caml_system__frametable: + .quad 1 /* one descriptor */ + .quad .L105 /* return address into callback */ + .short -1 /* negative size count => use callback link */ + .short 0 /* no roots here */ + .align 8 + +/* Mark stack as non-executable */ + .section .note.GNU-stack,"",%progbits diff -Nru ocaml-4.01.0/asmrun/signals_asm.c ocaml-4.05.0/asmrun/signals_asm.c --- ocaml-4.01.0/asmrun/signals_asm.c 2013-07-23 14:48:47.000000000 +0000 +++ ocaml-4.05.0/asmrun/signals_asm.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,19 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ -/* */ -/* Copyright 2007 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ +/* */ +/* Copyright 2007 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Signal handling, code specific to the native-code compiler */ @@ -19,13 +23,14 @@ #include #include #include -#include "fail.h" -#include "memory.h" -#include "osdeps.h" -#include "signals.h" -#include "signals_machdep.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/signals_machdep.h" #include "signals_osdep.h" -#include "stack.h" +#include "caml/stack.h" +#include "caml/spacetime.h" #ifdef HAS_STACK_OVERFLOW_DETECTION #include @@ -47,6 +52,8 @@ extern char * caml_code_area_start, * caml_code_area_end; extern char caml_system__code_begin, caml_system__code_end; +/* Do not use the macro from address_class.h here. */ +#undef Is_in_code_area #define Is_in_code_area(pc) \ ( ((char *)(pc) >= caml_code_area_start && \ (char *)(pc) <= caml_code_area_end) \ @@ -65,10 +72,18 @@ void caml_garbage_collection(void) { - caml_young_limit = caml_young_start; - if (caml_young_ptr < caml_young_start || caml_force_major_slice) { - caml_minor_collection(); + caml_young_limit = caml_young_trigger; + if (caml_requested_major_slice || caml_requested_minor_gc || + caml_young_ptr - caml_young_trigger < Max_young_whsize){ + caml_gc_dispatch (); + } + +#ifdef WITH_SPACETIME + if (caml_young_ptr == caml_young_alloc_end) { + caml_spacetime_automatic_snapshot(); } +#endif + caml_process_pending_signals(); } @@ -142,7 +157,9 @@ /* Machine- and OS-dependent handling of bound check trap */ -#if defined(TARGET_power) || (defined(TARGET_sparc) && defined(SYS_solaris)) +#if defined(TARGET_power) \ + || defined(TARGET_s390x) \ + || (defined(TARGET_sparc) && defined(SYS_solaris)) DECLARE_SIGNAL_HANDLER(trap_handler) { #if defined(SYS_solaris) @@ -165,11 +182,9 @@ } #endif caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER; - caml_young_ptr = (char *) CONTEXT_YOUNG_PTR; -#if defined(SYS_rhapsody) + caml_young_ptr = (value *) CONTEXT_YOUNG_PTR; caml_bottom_of_stack = (char *) CONTEXT_SP; caml_last_return_address = (uintnat) CONTEXT_PC; -#endif caml_array_bound_error(); } #endif @@ -226,7 +241,7 @@ /* Raise a Stack_overflow exception straight from this signal handler */ #if defined(CONTEXT_YOUNG_PTR) && defined(CONTEXT_EXCEPTION_POINTER) caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER; - caml_young_ptr = (char *) CONTEXT_YOUNG_PTR; + caml_young_ptr = (value *) CONTEXT_YOUNG_PTR; #endif caml_raise_stack_overflow(); #endif @@ -267,6 +282,14 @@ } #endif +#if defined(TARGET_s390x) + { struct sigaction act; + sigemptyset(&act.sa_mask); + SET_SIGACT(act, trap_handler); + sigaction(SIGFPE, &act, NULL); + } +#endif + /* Stack overflow handling */ #ifdef HAS_STACK_OVERFLOW_DETECTION { diff -Nru ocaml-4.01.0/asmrun/signals_osdep.h ocaml-4.05.0/asmrun/signals_osdep.h --- ocaml-4.01.0/asmrun/signals_osdep.h 2013-06-24 08:16:27.000000000 +0000 +++ ocaml-4.05.0/asmrun/signals_osdep.h 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,17 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2004 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2004 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ /* Processor- and OS-dependent signal interface */ @@ -66,18 +68,7 @@ #elif defined(TARGET_arm) && (defined(SYS_linux_eabi) \ || defined(SYS_linux_eabihf)) - #if defined(__ANDROID__) - // The Android NDK does not have sys/ucontext.h yet. - typedef struct ucontext { - uint32_t uc_flags; - struct ucontext *uc_link; - stack_t uc_stack; - struct sigcontext uc_mcontext; - // Other fields omitted... - } ucontext_t; - #else - #include - #endif + #include #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, ucontext_t * context) @@ -92,6 +83,25 @@ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.arm_r8) #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address) +/****************** ARM64, Linux */ + +#elif defined(TARGET_arm64) && defined(SYS_linux) + + #include + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, ucontext_t * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ + sigact.sa_flags = SA_SIGINFO + + typedef unsigned long context_reg; + #define CONTEXT_PC (context->uc_mcontext.pc) + #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.regs[26]) + #define CONTEXT_YOUNG_PTR (context->uc_mcontext.regs[27]) + #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address) + /****************** AMD64, Solaris x86 */ #elif defined(TARGET_amd64) && defined (SYS_solaris) @@ -111,6 +121,39 @@ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15]) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) +/****************** AMD64, OpenBSD */ + +#elif defined(TARGET_amd64) && defined (SYS_openbsd) + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, struct sigcontext * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ + sigact.sa_flags = SA_SIGINFO + + #define CONTEXT_PC (context->sc_rip) + #define CONTEXT_EXCEPTION_POINTER (context->sc_r14) + #define CONTEXT_YOUNG_PTR (context->sc_r15) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + +/****************** AMD64, NetBSD */ + +#elif defined(TARGET_amd64) && defined (SYS_netbsd) + + #include + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, ucontext_t * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ + sigact.sa_flags = SA_SIGINFO + + #define CONTEXT_PC (_UC_MACHINE_PC(context)) + #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14]) + #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15]) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + /****************** I386, Linux */ #elif defined(TARGET_i386) && defined(SYS_linux_elf) @@ -124,6 +167,30 @@ #define CONTEXT_FAULTING_ADDRESS ((char *) context.cr2) +/****************** I386, BSD_ELF */ + +#elif defined(TARGET_i386) && defined(SYS_bsd_elf) + + #if defined (__NetBSD__) + #include + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, ucontext_t * context) + #else + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, struct sigcontext * context) + #endif + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ + sigact.sa_flags = SA_SIGINFO + + #if defined (__NetBSD__) + #define CONTEXT_PC (_UC_MACHINE_PC(context)) + #else + #define CONTEXT_PC (context->sc_eip) + #endif + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + /****************** I386, BSD */ #elif defined(TARGET_i386) && defined(SYS_bsd) @@ -234,10 +301,29 @@ #define CONTEXT_EXCEPTION_POINTER (context->regs->gpr[29]) #define CONTEXT_YOUNG_LIMIT (context->regs->gpr[30]) #define CONTEXT_YOUNG_PTR (context->regs->gpr[31]) + #define CONTEXT_SP (context->regs->gpr[1]) + +/****************** s390x, ELF (Linux) */ +#elif defined(TARGET_s390x) && defined(SYS_elf) + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, struct sigcontext * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_handler = (void (*)(int)) (name); \ + sigact.sa_flags = 0 + + typedef unsigned long context_reg; + #define CONTEXT_PC (context->sregs->regs.psw.addr) + #define CONTEXT_EXCEPTION_POINTER (context->sregs->regs.gprs[13]) + #define CONTEXT_YOUNG_LIMIT (context->sregs->regs.gprs[10]) + #define CONTEXT_YOUNG_PTR (context->sregs->regs.gprs[11]) + #define CONTEXT_SP (context->sregs->regs.gprs[15]) /****************** PowerPC, BSD */ -#elif defined(TARGET_power) && (defined(SYS_bsd) || defined(SYS_bsd_elf)) +#elif defined(TARGET_power) && \ + (defined(SYS_bsd) || defined(SYS_bsd_elf) || defined(SYS_netbsd)) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, int code, struct sigcontext * context) @@ -247,9 +333,11 @@ sigact.sa_flags = 0 typedef unsigned long context_reg; + #define CONTEXT_PC (context->sc_frame.srr0) #define CONTEXT_EXCEPTION_POINTER (context->sc_frame.fixreg[29]) #define CONTEXT_YOUNG_LIMIT (context->sc_frame.fixreg[30]) #define CONTEXT_YOUNG_PTR (context->sc_frame.fixreg[31]) + #define CONTEXT_SP (context->sc_frame.fixreg[1]) /****************** SPARC, Solaris */ @@ -268,6 +356,7 @@ #define CONTEXT_PC (context->uc_mcontext.gregs[REG_PC]) /* Local register number N is saved on the stack N words after the stack pointer */ + #define CONTEXT_SP (context->uc_mcontext.gregs[REG_SP]) #define SPARC_L_REG(n) ((long *)(context->uc_mcontext.gregs[REG_SP]))[n] #define CONTEXT_EXCEPTION_POINTER (SPARC_L_REG(5)) #define CONTEXT_YOUNG_LIMIT (SPARC_L_REG(7)) diff -Nru ocaml-4.01.0/asmrun/spacetime.c ocaml-4.05.0/asmrun/spacetime.c --- ocaml-4.01.0/asmrun/spacetime.c 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmrun/spacetime.c 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,1123 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Mark Shinwell and Leo White, Jane Street Europe */ +/* */ +/* Copyright 2013--2016, Jane Street Group, LLC */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "caml/config.h" +#ifdef HAS_UNISTD +#include +#endif + +#include "caml/alloc.h" +#include "caml/backtrace_prim.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/intext.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/osdeps.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/stack.h" +#include "caml/sys.h" +#include "caml/spacetime.h" + +#ifdef WITH_SPACETIME + +/* We force "noinline" in certain places to be sure we know how many + frames there will be on the stack. */ +#define NOINLINE __attribute__((noinline)) + +#ifdef HAS_LIBUNWIND +#define UNW_LOCAL_ONLY +#include "libunwind.h" +#endif + +static int automatic_snapshots = 0; +static double snapshot_interval = 0.0; +static double next_snapshot_time = 0.0; +static struct channel *snapshot_channel; +static int pid_when_snapshot_channel_opened; + +extern value caml_spacetime_debug(value); + +static char* start_of_free_node_block; +static char* end_of_free_node_block; + +typedef struct per_thread { + value* trie_node_root; + value* finaliser_trie_node_root; + struct per_thread* next; +} per_thread; + +/* List of tries corresponding to threads that have been created. */ +/* CR-soon mshinwell: just include the main trie in this list. */ +static per_thread* per_threads = NULL; +static int num_per_threads = 0; + +/* [caml_spacetime_shapes] is defined in the startup file. */ +extern uint64_t* caml_spacetime_shapes; + +uint64_t** caml_spacetime_static_shape_tables = NULL; +shape_table* caml_spacetime_dynamic_shape_tables = NULL; + +static uintnat caml_spacetime_profinfo = (uintnat) 0; + +value caml_spacetime_trie_root = Val_unit; +value* caml_spacetime_trie_node_ptr = &caml_spacetime_trie_root; + +static value caml_spacetime_finaliser_trie_root_main_thread = Val_unit; +value* caml_spacetime_finaliser_trie_root + = &caml_spacetime_finaliser_trie_root_main_thread; + +/* CR-someday mshinwell: think about thread safety of the manipulation of + this list for multicore */ +allocation_point* caml_all_allocation_points = NULL; + +static const uintnat chunk_size = 1024 * 1024; + +static void reinitialise_free_node_block(void) +{ + size_t index; + + start_of_free_node_block = (char*) malloc(chunk_size); + end_of_free_node_block = start_of_free_node_block + chunk_size; + + for (index = 0; index < chunk_size / sizeof(value); index++) { + ((value*) start_of_free_node_block)[index] = Val_unit; + } +} + +#ifndef O_BINARY +#define O_BINARY 0 +#endif + +#if defined (_WIN32) || defined (_WIN64) +extern value val_process_id; +#endif + +static uint32_t version_number = 0; +static uint32_t magic_number_base = 0xace00ace; + +static void caml_spacetime_write_magic_number_internal(struct channel* chan) +{ + value magic_number = + Val_long(((uint64_t) magic_number_base) + | (((uint64_t) version_number) << 32)); + + Lock(chan); + caml_output_val(chan, magic_number, Val_long(0)); + Unlock(chan); +} + +CAMLprim value caml_spacetime_write_magic_number(value v_channel) +{ + caml_spacetime_write_magic_number_internal(Channel(v_channel)); + return Val_unit; +} + +static char* automatic_snapshot_dir; + +static void open_snapshot_channel(void) +{ + int fd; + char filename[8192]; + int pid; +#if defined (_WIN32) || defined (_WIN64) + pid = Int_val(val_process_id); +#else + pid = getpid(); +#endif + snprintf(filename, 8192, "%s/spacetime-%d", automatic_snapshot_dir, pid); + filename[8191] = '\0'; + fd = open(filename, O_WRONLY | O_CREAT | O_TRUNC | O_BINARY, 0666); + if (fd == -1) { + automatic_snapshots = 0; + } + else { + snapshot_channel = caml_open_descriptor_out(fd); + snapshot_channel->flags |= CHANNEL_FLAG_BLOCKING_WRITE; + pid_when_snapshot_channel_opened = pid; + caml_spacetime_write_magic_number_internal(snapshot_channel); + } +} + +static void maybe_reopen_snapshot_channel(void) +{ + /* This function should be used before writing to the automatic snapshot + channel. It detects whether we have forked since the channel was opened. + If so, we close the old channel (ignoring any errors just in case the + old fd has been closed, e.g. in a double-fork situation where the middle + process has a loop to manually close all fds and no Spacetime snapshot + was written during that time) and then open a new one. */ + + int pid; +#if defined (_WIN32) || defined (_WIN64) + pid = Int_val(val_process_id); +#else + pid = getpid(); +#endif + + if (pid != pid_when_snapshot_channel_opened) { + caml_close_channel(snapshot_channel); + open_snapshot_channel(); + } +} + +extern void caml_spacetime_automatic_save(void); + +void caml_spacetime_initialize(void) +{ + /* Note that this is called very early (even prior to GC initialisation). */ + + char *ap_interval; + + reinitialise_free_node_block(); + + caml_spacetime_static_shape_tables = &caml_spacetime_shapes; + + ap_interval = caml_secure_getenv ("OCAML_SPACETIME_INTERVAL"); + if (ap_interval != NULL) { + unsigned int interval = 0; + sscanf(ap_interval, "%u", &interval); + if (interval != 0) { + double time; + char cwd[4096]; + char* user_specified_automatic_snapshot_dir; + int dir_ok = 1; + + user_specified_automatic_snapshot_dir = + caml_secure_getenv("OCAML_SPACETIME_SNAPSHOT_DIR"); + + if (user_specified_automatic_snapshot_dir == NULL) { +#ifdef HAS_GETCWD + if (getcwd(cwd, sizeof(cwd)) == NULL) { + dir_ok = 0; + } +#else + if (getwd(cwd) == NULL) { + dir_ok = 0; + } +#endif + if (dir_ok) { + automatic_snapshot_dir = strdup(cwd); + } + } + else { + automatic_snapshot_dir = + strdup(user_specified_automatic_snapshot_dir); + } + + if (dir_ok) { + automatic_snapshots = 1; + open_snapshot_channel(); + if (automatic_snapshots) { +#ifdef SIGINT + /* Catch interrupt so that the profile can be completed. + We do this by marking the signal as handled without + specifying an actual handler. This causes the signal + to be handled by a call to exit. */ + caml_set_signal_action(SIGINT, 2); +#endif + snapshot_interval = interval / 1e3; + time = caml_sys_time_unboxed(Val_unit); + next_snapshot_time = time + snapshot_interval; + atexit(&caml_spacetime_automatic_save); + } + } + } + } +} + +void caml_spacetime_register_shapes(void* dynlinked_table) +{ + shape_table* table; + table = (shape_table*) malloc(sizeof(shape_table)); + if (table == NULL) { + fprintf(stderr, "Out of memory whilst registering shape table"); + abort(); + } + table->table = (uint64_t*) dynlinked_table; + table->next = caml_spacetime_dynamic_shape_tables; + caml_spacetime_dynamic_shape_tables = table; +} + +CAMLprim value caml_spacetime_trie_is_initialized (value v_unit) +{ + return (caml_spacetime_trie_root == Val_unit) ? Val_false : Val_true; +} + +CAMLprim value caml_spacetime_get_trie_root (value v_unit) +{ + return caml_spacetime_trie_root; +} + +void caml_spacetime_register_thread( + value* trie_node_root, value* finaliser_trie_node_root) +{ + per_thread* thr; + + thr = (per_thread*) malloc(sizeof(per_thread)); + if (thr == NULL) { + fprintf(stderr, "Out of memory while registering thread for profiling\n"); + abort(); + } + thr->next = per_threads; + per_threads = thr; + + thr->trie_node_root = trie_node_root; + thr->finaliser_trie_node_root = finaliser_trie_node_root; + + /* CR-soon mshinwell: record thread ID (and for the main thread too) */ + + num_per_threads++; +} + +static void caml_spacetime_save_event_internal (value v_time_opt, + struct channel* chan, + value v_event_name) +{ + value v_time; + double time_override = 0.0; + int use_time_override = 0; + + if (Is_block(v_time_opt)) { + time_override = Double_field(Field(v_time_opt, 0), 0); + use_time_override = 1; + } + v_time = caml_spacetime_timestamp(time_override, use_time_override); + + Lock(chan); + caml_output_val(chan, Val_long(2), Val_long(0)); + caml_output_val(chan, v_event_name, Val_long(0)); + caml_extern_allow_out_of_heap = 1; + caml_output_val(chan, v_time, Val_long(0)); + caml_extern_allow_out_of_heap = 0; + Unlock(chan); + + caml_stat_free(Hp_val(v_time)); +} + +CAMLprim value caml_spacetime_save_event (value v_time_opt, + value v_channel, + value v_event_name) +{ + struct channel* chan = Channel(v_channel); + + caml_spacetime_save_event_internal(v_time_opt, chan, v_event_name); + + return Val_unit; +} + + +void save_trie (struct channel *chan, double time_override, + int use_time_override) +{ + value v_time, v_frames, v_shapes; + /* CR-someday mshinwell: The commented-out changes here are for multicore, + where we think we should have one trie per domain. */ + /* int num_marshalled = 0; + per_thread* thr = per_threads; */ + + Lock(chan); + + caml_output_val(chan, Val_long(1), Val_long(0)); + + v_time = caml_spacetime_timestamp(time_override, use_time_override); + v_frames = caml_spacetime_frame_table(); + v_shapes = caml_spacetime_shape_table(); + + caml_extern_allow_out_of_heap = 1; + caml_output_val(chan, v_time, Val_long(0)); + caml_output_val(chan, v_frames, Val_long(0)); + caml_output_val(chan, v_shapes, Val_long(0)); + caml_extern_allow_out_of_heap = 0; + + caml_output_val(chan, Val_long(1) /* Val_long(num_per_threads + 1) */, + Val_long(0)); + + /* Marshal both the main and finaliser tries, for all threads that have + been created, to an [out_channel]. This can be done by using the + extern.c code as usual, since the trie looks like standard OCaml values; + but we must allow it to traverse outside the heap. */ + + caml_extern_allow_out_of_heap = 1; + caml_output_val(chan, caml_spacetime_trie_root, Val_long(0)); + caml_output_val(chan, + caml_spacetime_finaliser_trie_root_main_thread, Val_long(0)); + /* while (thr != NULL) { + caml_output_val(chan, *(thr->trie_node_root), Val_long(0)); + caml_output_val(chan, *(thr->finaliser_trie_node_root), + Val_long(0)); + thr = thr->next; + num_marshalled++; + } + Assert(num_marshalled == num_per_threads); */ + caml_extern_allow_out_of_heap = 0; + + Unlock(chan); +} + +CAMLprim value caml_spacetime_save_trie (value v_time_opt, value v_channel) +{ + struct channel* channel = Channel(v_channel); + double time_override = 0.0; + int use_time_override = 0; + + if (Is_block(v_time_opt)) { + time_override = Double_field(Field(v_time_opt, 0), 0); + use_time_override = 1; + } + + save_trie(channel, time_override, use_time_override); + + return Val_unit; +} + +c_node_type caml_spacetime_classify_c_node(c_node* node) +{ + return (node->pc & 2) ? CALL : ALLOCATION; +} + +c_node* caml_spacetime_c_node_of_stored_pointer(value node_stored) +{ + Assert(node_stored == Val_unit || Is_c_node(node_stored)); + return (node_stored == Val_unit) ? NULL : (c_node*) Hp_val(node_stored); +} + +c_node* caml_spacetime_c_node_of_stored_pointer_not_null( + value node_stored) +{ + Assert(Is_c_node(node_stored)); + return (c_node*) Hp_val(node_stored); +} + +value caml_spacetime_stored_pointer_of_c_node(c_node* c_node) +{ + value node; + Assert(c_node != NULL); + node = Val_hp(c_node); + Assert(Is_c_node(node)); + return node; +} + +#ifdef HAS_LIBUNWIND +static int pc_inside_c_node_matches(c_node* node, void* pc) +{ + return Decode_c_node_pc(node->pc) == pc; +} +#endif + +static value allocate_uninitialized_ocaml_node(int size_including_header) +{ + void* node; + uintnat size; + + Assert(size_including_header >= 3); + node = caml_stat_alloc(sizeof(uintnat) * size_including_header); + + size = size_including_header * sizeof(value); + + node = (void*) start_of_free_node_block; + if (end_of_free_node_block - start_of_free_node_block < size) { + reinitialise_free_node_block(); + node = (void*) start_of_free_node_block; + Assert(end_of_free_node_block - start_of_free_node_block >= size); + } + + start_of_free_node_block += size; + + /* We don't currently rely on [uintnat] alignment, but we do need some + alignment, so just be sure. */ + Assert (((uintnat) node) % sizeof(uintnat) == 0); + return Val_hp(node); +} + +static value find_tail_node(value node, void* callee) +{ + /* Search the tail chain within [node] (which corresponds to an invocation + of a caller of [callee]) to determine whether it contains a tail node + corresponding to [callee]. Returns any such node, or [Val_unit] if no + such node exists. */ + + value starting_node; + value pc; + value found = Val_unit; + + starting_node = node; + pc = Encode_node_pc(callee); + + do { + Assert(Is_ocaml_node(node)); + if (Node_pc(node) == pc) { + found = node; + } + else { + node = Tail_link(node); + } + } while (found == Val_unit && starting_node != node); + + return found; +} + +CAMLprim value caml_spacetime_allocate_node( + int size_including_header, void* pc, value* node_hole) +{ + value node; + value caller_node = Val_unit; + + node = *node_hole; + /* The node hole should either contain [Val_unit], indicating that this + function was not tail called and we have not been to this point in the + trie before; or it should contain a value encoded using + [Encoded_tail_caller_node] that points at the node of a caller + that tail called the current function. (Such a value is necessary to + be able to find the start of the caller's node, and hence its tail + chain, so we as a tail-called callee can link ourselves in.) */ + Assert(Is_tail_caller_node_encoded(node)); + + if (node != Val_unit) { + value tail_node; + /* The callee was tail called. Find whether there already exists a node + for it in the tail call chain within the caller's node. The caller's + node must always be an OCaml node. */ + caller_node = Decode_tail_caller_node(node); + tail_node = find_tail_node(caller_node, pc); + if (tail_node != Val_unit) { + /* This tail calling sequence has happened before; just fill the hole + with the existing node and return. */ + *node_hole = tail_node; + return 0; /* indicates an existing node was returned */ + } + } + + node = allocate_uninitialized_ocaml_node(size_including_header); + Hd_val(node) = + Make_header(size_including_header - 1, OCaml_node_tag, Caml_black); + Assert((((uintnat) pc) % 1) == 0); + Node_pc(node) = Encode_node_pc(pc); + /* If the callee was tail called, then the tail link field will link this + new node into an existing tail chain. Otherwise, it is initialized with + the empty tail chain, i.e. the one pointing directly at [node]. */ + if (caller_node == Val_unit) { + Tail_link(node) = node; + } + else { + Tail_link(node) = Tail_link(caller_node); + Tail_link(caller_node) = node; + } + + /* The callee node pointers for direct tail call points are + initialized from code emitted by the OCaml compiler. This is done to + avoid having to pass this function a description of which nodes are + direct tail call points. (We cannot just count them and put them at the + beginning of the node because we need the indexes of elements within the + node during instruction selection before we have found all call points.) + + All other fields have already been initialised by + [reinitialise_free_node_block]. + */ + + *node_hole = node; + + return 1; /* indicates a new node was created */ +} + +static c_node* allocate_c_node(void) +{ + c_node* node; + size_t index; + + node = (c_node*) start_of_free_node_block; + if (end_of_free_node_block - start_of_free_node_block < sizeof(c_node)) { + reinitialise_free_node_block(); + node = (c_node*) start_of_free_node_block; + Assert(end_of_free_node_block - start_of_free_node_block + >= sizeof(c_node)); + } + start_of_free_node_block += sizeof(c_node); + + Assert((sizeof(c_node) % sizeof(uintnat)) == 0); + + /* CR-soon mshinwell: remove this and pad the structure properly */ + for (index = 0; index < sizeof(c_node) / sizeof(value); index++) { + ((value*) node)[index] = Val_unit; + } + + node->gc_header = + Make_header(sizeof(c_node)/sizeof(uintnat) - 1, C_node_tag, Caml_black); + node->data.callee_node = Val_unit; + node->next = Val_unit; + + return node; +} + +/* Since a given indirect call site either always yields tail calls or + always yields non-tail calls, the output of + [caml_spacetime_indirect_node_hole_ptr] is uniquely determined by its + first two arguments (the callee and the node hole). We cache these + to increase performance of recursive functions containing an indirect + call (e.g. [List.map] when not inlined). */ +static void* last_indirect_node_hole_ptr_callee; +static value* last_indirect_node_hole_ptr_node_hole; +static value* last_indirect_node_hole_ptr_result; + +CAMLprim value* caml_spacetime_indirect_node_hole_ptr + (void* callee, value* node_hole, value caller_node) +{ + /* Find the address of the node hole for an indirect call to [callee]. + If [caller_node] is not [Val_unit], it is a pointer to the caller's + node, and indicates that this is a tail call site. */ + + c_node* c_node; + value encoded_callee; + + if (callee == last_indirect_node_hole_ptr_callee + && node_hole == last_indirect_node_hole_ptr_node_hole) { + return last_indirect_node_hole_ptr_result; + } + + last_indirect_node_hole_ptr_callee = callee; + last_indirect_node_hole_ptr_node_hole = node_hole; + + encoded_callee = Encode_c_node_pc_for_call(callee); + + while (*node_hole != Val_unit) { + Assert(((uintnat) *node_hole) % sizeof(value) == 0); + + c_node = caml_spacetime_c_node_of_stored_pointer_not_null(*node_hole); + + Assert(c_node != NULL); + Assert(caml_spacetime_classify_c_node(c_node) == CALL); + + if (c_node->pc == encoded_callee) { + last_indirect_node_hole_ptr_result = &(c_node->data.callee_node); + return last_indirect_node_hole_ptr_result; + } + else { + node_hole = &c_node->next; + } + } + + c_node = allocate_c_node(); + c_node->pc = encoded_callee; + + if (caller_node != Val_unit) { + /* This is a tail call site. + Perform the initialization equivalent to that emitted by + [Spacetime.code_for_function_prologue] for direct tail call + sites. */ + c_node->data.callee_node = Encode_tail_caller_node(caller_node); + } + + *node_hole = caml_spacetime_stored_pointer_of_c_node(c_node); + + Assert(((uintnat) *node_hole) % sizeof(value) == 0); + Assert(*node_hole != Val_unit); + + last_indirect_node_hole_ptr_result = &(c_node->data.callee_node); + + return last_indirect_node_hole_ptr_result; +} + +/* Some notes on why caml_call_gc doesn't need a distinguished node. + (Remember that thread switches are irrelevant here because each thread + has its own trie.) + + caml_call_gc only invokes OCaml functions in the following circumstances: + 1. running an OCaml finaliser; + 2. executing an OCaml signal handler. + Both of these are done on the finaliser trie. Furthermore, both of + these invocations start via caml_callback; the code in this file for + handling that (caml_spacetime_c_to_ocaml) correctly copes with that by + attaching a single "caml_start_program" node that can cope with any + number of indirect OCaml calls from that point. + + caml_call_gc may also invoke C functions that cause allocation. All of + these (assuming libunwind support is present) will cause a chain of + c_node structures to be attached to the trie, starting at the node hole + passed to caml_call_gc from OCaml code. These structures are extensible + and can thus accommodate any number of C backtraces leading from + caml_call_gc. +*/ +/* CR-soon mshinwell: it might in fact be the case now that nothing called + from caml_call_gc will do any allocation that ends up on the trie. We + can revisit this after the first release. */ + +static NOINLINE void* find_trie_node_from_libunwind(int for_allocation, + uintnat wosize, struct ext_table** cached_frames) +{ +#ifdef HAS_LIBUNWIND + /* Given that [caml_last_return_address] is the most recent call site in + OCaml code, and that we are now in C (or other) code called from that + site, obtain a backtrace using libunwind and graft the most recent + portion (everything back to but not including [caml_last_return_address]) + onto the trie. See the important comment below regarding the fact that + call site, and not callee, addresses are recorded during this process. + + If [for_allocation] is non-zero, the final node recorded will be for + an allocation, and the returned pointer is to the allocation node. + Otherwise, no node is recorded for the innermost frame, and the + returned pointer is a pointer to the *node hole* where a node for that + frame should be attached. + + If [for_allocation] is non-zero then [wosize] must give the size in + words, excluding the header, of the value being allocated. + + If [cached_frames != NULL] then: + 1. If [*cached_frames] is NULL then save the captured backtrace in a + newly-allocated table and store the pointer to that table in + [*cached_frames]; + 2. Otherwise use [*cached_frames] as the unwinding information. + The intention is that when the context is known (e.g. a function such + as [caml_make_vect] known to have been directly invoked from OCaml), + we can avoid expensive calls to libunwind. + */ + + unw_cursor_t cur; + unw_context_t ctx; + int ret; + int innermost_frame; + int frame; + static struct ext_table frames_local; + struct ext_table* frames; + static int ext_table_initialised = 0; + int have_frames_already = 0; + value* node_hole; + c_node* node = NULL; + int initial_table_size = 1000; + int must_initialise_node_for_allocation = 0; + + if (!cached_frames) { + if (!ext_table_initialised) { + caml_ext_table_init(&frames_local, initial_table_size); + ext_table_initialised = 1; + } + else { + caml_ext_table_clear(&frames_local, 0); + } + frames = &frames_local; + } else { + if (*cached_frames) { + frames = *cached_frames; + have_frames_already = 1; + } + else { + frames = (struct ext_table*) malloc(sizeof(struct ext_table)); + if (!frames) { + caml_fatal_error("Not enough memory for ext_table allocation"); + } + caml_ext_table_init(frames, initial_table_size); + *cached_frames = frames; + } + } + + if (!have_frames_already) { + /* Get the stack backtrace as far as [caml_last_return_address]. */ + + ret = unw_getcontext(&ctx); + if (ret != UNW_ESUCCESS) { + return NULL; + } + + ret = unw_init_local(&cur, &ctx); + if (ret != UNW_ESUCCESS) { + return NULL; + } + + while ((ret = unw_step(&cur)) > 0) { + unw_word_t ip; + unw_get_reg(&cur, UNW_REG_IP, &ip); + if (caml_last_return_address == (uintnat) ip) { + break; + } + else { + /* Inlined some of [caml_ext_table_add] for speed. */ + if (frames->size < frames->capacity) { + frames->contents[frames->size++] = (void*) ip; + } else { + caml_ext_table_add(frames, (void*) ip); + } + } + } + } + + /* We always need to ignore the frames for: + #0 find_trie_node_from_libunwind + #1 caml_spacetime_c_to_ocaml + Further, if this is not an allocation point, we should not create the + node for the current C function that triggered us (i.e. frame #2). */ + innermost_frame = for_allocation ? 1 : 2; + + if (frames->size - 1 < innermost_frame) { + /* Insufficiently many frames (maybe no frames) returned from + libunwind; just don't do anything. */ + return NULL; + } + + node_hole = caml_spacetime_trie_node_ptr; + /* Note that if [node_hole] is filled, then it must point to a C node, + since it is not possible for there to be a call point in an OCaml + function that sometimes calls C and sometimes calls OCaml. */ + + for (frame = frames->size - 1; frame >= innermost_frame; frame--) { + c_node_type expected_type; + void* pc = frames->contents[frame]; + Assert (pc != (void*) caml_last_return_address); + + if (!for_allocation) { + expected_type = CALL; + } + else { + expected_type = (frame > innermost_frame ? CALL : ALLOCATION); + } + + if (*node_hole == Val_unit) { + node = allocate_c_node(); + /* Note: for CALL nodes, the PC is the program counter at each call + site. We do not store program counter addresses of the start of + callees, unlike for OCaml nodes. This means that some trie nodes + will become conflated. These can be split during post-processing by + working out which function each call site was in. */ + node->pc = (expected_type == CALL ? Encode_c_node_pc_for_call(pc) + : Encode_c_node_pc_for_alloc_point(pc)); + *node_hole = caml_spacetime_stored_pointer_of_c_node(node); + if (expected_type == ALLOCATION) { + must_initialise_node_for_allocation = 1; + } + } + else { + c_node* prev; + int found = 0; + + node = caml_spacetime_c_node_of_stored_pointer_not_null(*node_hole); + Assert(node != NULL); + Assert(node->next == Val_unit + || (((uintnat) (node->next)) % sizeof(value) == 0)); + + prev = NULL; + + while (!found && node != NULL) { + if (caml_spacetime_classify_c_node(node) == expected_type + && pc_inside_c_node_matches(node, pc)) { + found = 1; + } + else { + prev = node; + node = caml_spacetime_c_node_of_stored_pointer(node->next); + } + } + if (!found) { + Assert(prev != NULL); + node = allocate_c_node(); + node->pc = (expected_type == CALL ? Encode_c_node_pc_for_call(pc) + : Encode_c_node_pc_for_alloc_point(pc)); + if (expected_type == ALLOCATION) { + must_initialise_node_for_allocation = 1; + } + prev->next = caml_spacetime_stored_pointer_of_c_node(node); + } + } + + Assert(node != NULL); + + Assert(caml_spacetime_classify_c_node(node) == expected_type); + Assert(pc_inside_c_node_matches(node, pc)); + node_hole = &node->data.callee_node; + } + + if (must_initialise_node_for_allocation) { + caml_spacetime_profinfo++; + if (caml_spacetime_profinfo > PROFINFO_MASK) { + /* Profiling counter overflow. */ + caml_spacetime_profinfo = PROFINFO_MASK; + } + node->data.allocation.profinfo = + Make_header_with_profinfo( + /* "-1" because [c_node] has the GC header as its first + element. */ + offsetof(c_node, data.allocation.count)/sizeof(value) - 1, + Infix_tag, + Caml_black, + caml_spacetime_profinfo); + node->data.allocation.count = Val_long(0); + + /* Add the new allocation point into the linked list of all allocation + points. */ + if (caml_all_allocation_points != NULL) { + node->data.allocation.next = + (value) &caml_all_allocation_points->count; + } else { + node->data.allocation.next = Val_unit; + } + caml_all_allocation_points = &node->data.allocation; + } + + if (for_allocation) { + Assert(caml_spacetime_classify_c_node(node) == ALLOCATION); + Assert(caml_spacetime_c_node_of_stored_pointer(node->next) != node); + Assert(Profinfo_hd(node->data.allocation.profinfo) > 0); + node->data.allocation.count = + Val_long(Long_val(node->data.allocation.count) + (1 + wosize)); + } + + Assert(node->next != (value) NULL); + + return for_allocation ? (void*) node : (void*) node_hole; +#else + return NULL; +#endif +} + +void caml_spacetime_c_to_ocaml(void* ocaml_entry_point, + void* identifying_pc_for_caml_start_program) +{ + /* Called in [caml_start_program] and [caml_callback*] when we are about + to cross from C into OCaml. [ocaml_entry_point] is the branch target. + This situation is handled by ensuring the presence of a new OCaml node + for the callback veneer; the node contains a single indirect call point + which accumulates the [ocaml_entry_point]s. + + The layout of the node is described in the "system shape table"; see + asmrun/amd64.S. + */ + + value node; + + /* Update the trie with the current backtrace, as far back as + [caml_last_return_address], and leave the node hole pointer at + the correct place for attachment of a [caml_start_program] node. */ + +#ifdef HAS_LIBUNWIND + value* node_temp; + node_temp = (value*) find_trie_node_from_libunwind(0, 0, NULL); + if (node_temp != NULL) { + caml_spacetime_trie_node_ptr = node_temp; + } +#endif + + if (*caml_spacetime_trie_node_ptr == Val_unit) { + uintnat size_including_header; + + size_including_header = + 1 /* GC header */ + Node_num_header_words + Indirect_num_fields; + + node = allocate_uninitialized_ocaml_node(size_including_header); + Hd_val(node) = + Make_header(size_including_header - 1, OCaml_node_tag, Caml_black); + Assert((((uintnat) identifying_pc_for_caml_start_program) % 1) == 0); + Node_pc(node) = Encode_node_pc(identifying_pc_for_caml_start_program); + Tail_link(node) = node; + Indirect_pc_linked_list(node, Node_num_header_words) = Val_unit; + *caml_spacetime_trie_node_ptr = node; + } + else { + node = *caml_spacetime_trie_node_ptr; + /* If there is a node here already, it should never be an initialized + (but as yet unused) tail call point, since calls from OCaml into C + are never tail calls (and no C -> C call is marked as tail). */ + Assert(!Is_tail_caller_node_encoded(node)); + } + + Assert(Is_ocaml_node(node)); + Assert(Decode_node_pc(Node_pc(node)) + == identifying_pc_for_caml_start_program); + Assert(Tail_link(node) == node); + Assert(Wosize_val(node) == Node_num_header_words + Indirect_num_fields); + + /* Search the node to find the node hole corresponding to the indirect + call to the OCaml function. */ + caml_spacetime_trie_node_ptr = + caml_spacetime_indirect_node_hole_ptr( + ocaml_entry_point, + &Indirect_pc_linked_list(node, Node_num_header_words), + Val_unit); + Assert(*caml_spacetime_trie_node_ptr == Val_unit + || Is_ocaml_node(*caml_spacetime_trie_node_ptr)); +} + +extern void caml_garbage_collection(void); /* signals_asm.c */ +extern void caml_array_bound_error(void); /* fail.c */ + +CAMLprim uintnat caml_spacetime_generate_profinfo (void* profinfo_words, + uintnat index_within_node) +{ + /* Called from code that creates a value's header inside an OCaml + function. */ + + value node; + uintnat profinfo; + + caml_spacetime_profinfo++; + if (caml_spacetime_profinfo > PROFINFO_MASK) { + /* Profiling counter overflow. */ + caml_spacetime_profinfo = PROFINFO_MASK; + } + profinfo = caml_spacetime_profinfo; + + /* CR-someday mshinwell: we could always use the [struct allocation_point] + overlay instead of the macros now. */ + + /* [node] isn't really a node; it points into the middle of + one---specifically to the "profinfo" word of an allocation point. + It's done like this to avoid re-calculating the place in the node + (which already has to be done in the OCaml-generated code run before + this function). */ + node = (value) profinfo_words; + Assert(Alloc_point_profinfo(node, 0) == Val_unit); + + /* The profinfo value is stored shifted to reduce the number of + instructions required on the OCaml side. It also enables us to use + [Infix_tag] to obtain valid value pointers into the middle of nodes, + which is used for the linked list of all allocation points. */ + profinfo = Make_header_with_profinfo( + index_within_node, Infix_tag, Caml_black, profinfo); + + Assert(!Is_block(profinfo)); + Alloc_point_profinfo(node, 0) = profinfo; + /* The count is set to zero by the initialisation when the node was + created (see above). */ + Assert(Alloc_point_count(node, 0) == Val_long(0)); + + /* Add the new allocation point into the linked list of all allocation + points. */ + if (caml_all_allocation_points != NULL) { + Alloc_point_next_ptr(node, 0) = (value) &caml_all_allocation_points->count; + } + else { + Assert(Alloc_point_next_ptr(node, 0) == Val_unit); + } + caml_all_allocation_points = (allocation_point*) node; + + return profinfo; +} + +uintnat caml_spacetime_my_profinfo (struct ext_table** cached_frames, + uintnat wosize) +{ + /* Return the profinfo value that should be written into a value's header + during an allocation from C. This may necessitate extending the trie + with information obtained from libunwind. */ + + c_node* node; + uintnat profinfo = 0; + + node = find_trie_node_from_libunwind(1, wosize, cached_frames); + if (node != NULL) { + profinfo = ((uintnat) (node->data.allocation.profinfo)) >> PROFINFO_SHIFT; + } + + return profinfo; /* N.B. not shifted by PROFINFO_SHIFT */ +} + +void caml_spacetime_automatic_snapshot (void) +{ + if (automatic_snapshots) { + double start_time, end_time; + start_time = caml_sys_time_unboxed(Val_unit); + if (start_time >= next_snapshot_time) { + maybe_reopen_snapshot_channel(); + caml_spacetime_save_snapshot(snapshot_channel, 0.0, 0); + end_time = caml_sys_time_unboxed(Val_unit); + next_snapshot_time = end_time + snapshot_interval; + } + } +} + +CAMLprim value caml_spacetime_save_event_for_automatic_snapshots + (value v_event_name) +{ + if (automatic_snapshots) { + maybe_reopen_snapshot_channel(); + caml_spacetime_save_event_internal (Val_unit, snapshot_channel, + v_event_name); + } + return Val_unit; +} + +void caml_spacetime_automatic_save (void) +{ + /* Called from [atexit]. */ + + if (automatic_snapshots) { + automatic_snapshots = 0; + maybe_reopen_snapshot_channel(); + save_trie(snapshot_channel, 0.0, 0); + caml_flush(snapshot_channel); + caml_close_channel(snapshot_channel); + } +} + +CAMLprim value caml_spacetime_enabled (value v_unit) +{ + return Val_true; +} + +CAMLprim value caml_register_channel_for_spacetime (value v_channel) +{ + struct channel* channel = Channel(v_channel); + channel->flags |= CHANNEL_FLAG_BLOCKING_WRITE; + return Val_unit; +} + +#else + +/* Functions for when the compiler was not configured with "-spacetime". */ + +CAMLprim value caml_spacetime_write_magic_number(value v_channel) +{ + return Val_unit; +} + +CAMLprim value caml_spacetime_enabled (value v_unit) +{ + return Val_false; +} + +CAMLprim value caml_spacetime_save_event (value v_time_opt, + value v_channel, + value v_event_name) +{ + return Val_unit; +} + +CAMLprim value caml_spacetime_save_event_for_automatic_snapshots + (value v_event_name) +{ + return Val_unit; +} + +CAMLprim value caml_spacetime_save_trie (value ignored) +{ + return Val_unit; +} + +CAMLprim value caml_register_channel_for_spacetime (value v_channel) +{ + return Val_unit; +} + +#endif diff -Nru ocaml-4.01.0/asmrun/spacetime_offline.c ocaml-4.05.0/asmrun/spacetime_offline.c --- ocaml-4.01.0/asmrun/spacetime_offline.c 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmrun/spacetime_offline.c 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,228 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Mark Shinwell and Leo White, Jane Street Europe */ +/* */ +/* Copyright 2013--2016, Jane Street Group, LLC */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +#include +#include +#include +#include +#include + +#include "caml/alloc.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/intext.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/stack.h" +#include "caml/sys.h" +#include "caml/spacetime.h" + +#include "../config/s.h" + +#ifdef ARCH_SIXTYFOUR + +/* CR-someday lwhite: The following two definitions are copied from spacetime.c + because they are needed here, but must be inlined in spacetime.c + for performance. Perhaps a macro or "static inline" would be + more appropriate. */ + +c_node* caml_spacetime_offline_c_node_of_stored_pointer_not_null + (value node_stored) +{ + Assert(Is_c_node(node_stored)); + return (c_node*) Hp_val(node_stored); +} + +c_node_type caml_spacetime_offline_classify_c_node(c_node* node) +{ + return (node->pc & 2) ? CALL : ALLOCATION; +} + +CAMLprim value caml_spacetime_compare_node( + value node1, value node2) +{ + Assert(!Is_in_value_area(node1)); + Assert(!Is_in_value_area(node2)); + + if (node1 == node2) { + return Val_long(0); + } + if (node1 < node2) { + return Val_long(-1); + } + return Val_long(1); +} + +CAMLprim value caml_spacetime_unmarshal_trie (value v_channel) +{ + return caml_input_value_to_outside_heap(v_channel); +} + +CAMLprim value caml_spacetime_node_num_header_words(value unit) +{ + unit = Val_unit; + return Val_long(Node_num_header_words); +} + +CAMLprim value caml_spacetime_is_ocaml_node(value node) +{ + Assert(Is_ocaml_node(node) || Is_c_node(node)); + return Val_bool(Is_ocaml_node(node)); +} + +CAMLprim value caml_spacetime_ocaml_function_identifier(value node) +{ + Assert(Is_ocaml_node(node)); + return caml_copy_int64((uint64_t) Decode_node_pc(Node_pc(node))); +} + +CAMLprim value caml_spacetime_ocaml_tail_chain(value node) +{ + Assert(Is_ocaml_node(node)); + return Tail_link(node); +} + +CAMLprim value caml_spacetime_classify_direct_call_point + (value node, value offset) +{ + uintnat field; + value callee_node; + + Assert(Is_ocaml_node(node)); + + field = Long_val(offset); + + callee_node = Direct_callee_node(node, field); + if (!Is_block(callee_node)) { + /* An unused call point (may be a tail call point). */ + return Val_long(0); + } else if (Is_ocaml_node(callee_node)) { + return Val_long(1); /* direct call point to OCaml code */ + } else { + return Val_long(2); /* direct call point to non-OCaml code */ + } +} + +CAMLprim value caml_spacetime_ocaml_allocation_point_annotation + (value node, value offset) +{ + uintnat profinfo_shifted; + profinfo_shifted = (uintnat) Alloc_point_profinfo(node, Long_val(offset)); + return Val_long(Profinfo_hd(profinfo_shifted)); +} + +CAMLprim value caml_spacetime_ocaml_allocation_point_count + (value node, value offset) +{ + value count = Alloc_point_count(node, Long_val(offset)); + Assert(!Is_block(count)); + return count; +} + +CAMLprim value caml_spacetime_ocaml_direct_call_point_callee_node + (value node, value offset) +{ + return Direct_callee_node(node, Long_val(offset)); +} + +CAMLprim value caml_spacetime_ocaml_indirect_call_point_callees + (value node, value offset) +{ + value callees = Indirect_pc_linked_list(node, Long_val(offset)); + Assert(Is_block(callees)); + Assert(Is_c_node(callees)); + return callees; +} + +CAMLprim value caml_spacetime_c_node_is_call(value node) +{ + c_node* c_node; + Assert(node != (value) NULL); + Assert(Is_c_node(node)); + c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node); + switch (caml_spacetime_offline_classify_c_node(c_node)) { + case CALL: return Val_true; + case ALLOCATION: return Val_false; + } + Assert(0); + return Val_unit; /* silence compiler warning */ +} + +CAMLprim value caml_spacetime_c_node_next(value node) +{ + c_node* c_node; + + Assert(node != (value) NULL); + Assert(Is_c_node(node)); + c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node); + Assert(c_node->next == Val_unit || Is_c_node(c_node->next)); + return c_node->next; +} + +CAMLprim value caml_spacetime_c_node_call_site(value node) +{ + c_node* c_node; + Assert(node != (value) NULL); + Assert(Is_c_node(node)); + c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node); + return caml_copy_int64((uint64_t) Decode_c_node_pc(c_node->pc)); +} + +CAMLprim value caml_spacetime_c_node_callee_node(value node) +{ + c_node* c_node; + Assert(node != (value) NULL); + Assert(Is_c_node(node)); + c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node); + Assert(caml_spacetime_offline_classify_c_node(c_node) == CALL); + /* This might be an uninitialised tail call point: for example if an OCaml + callee was indirectly called but the callee wasn't instrumented (e.g. a + leaf function that doesn't allocate). */ + if (Is_tail_caller_node_encoded(c_node->data.callee_node)) { + return Val_unit; + } + return c_node->data.callee_node; +} + +CAMLprim value caml_spacetime_c_node_profinfo(value node) +{ + c_node* c_node; + Assert(node != (value) NULL); + Assert(Is_c_node(node)); + c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node); + Assert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION); + Assert(!Is_block(c_node->data.allocation.profinfo)); + return Val_long(Profinfo_hd(c_node->data.allocation.profinfo)); +} + +CAMLprim value caml_spacetime_c_node_allocation_count(value node) +{ + c_node* c_node; + Assert(node != (value) NULL); + Assert(Is_c_node(node)); + c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node); + Assert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION); + Assert(!Is_block(c_node->data.allocation.count)); + return c_node->data.allocation.count; +} + +#endif diff -Nru ocaml-4.01.0/asmrun/spacetime_snapshot.c ocaml-4.05.0/asmrun/spacetime_snapshot.c --- ocaml-4.01.0/asmrun/spacetime_snapshot.c 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/asmrun/spacetime_snapshot.c 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,600 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Mark Shinwell and Leo White, Jane Street Europe */ +/* */ +/* Copyright 2013--2016, Jane Street Group, LLC */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +#include +#include +#include +#include +#include + +#include "caml/alloc.h" +#include "caml/backtrace_prim.h" +#include "caml/config.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/intext.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/stack.h" +#include "caml/sys.h" +#include "caml/spacetime.h" + +#ifdef WITH_SPACETIME + +/* The following structures must match the type definitions in the + [Spacetime] module. */ + +typedef struct { + /* (GC header here.) */ + value minor_words; + value promoted_words; + value major_words; + value minor_collections; + value major_collections; + value heap_words; + value heap_chunks; + value compactions; + value top_heap_words; +} gc_stats; + +typedef struct { + value profinfo; + value num_blocks; + value num_words_including_headers; +} snapshot_entry; + +typedef struct { + /* (GC header here.) */ + snapshot_entry entries[0]; +} snapshot_entries; + +typedef struct { + /* (GC header here.) */ + value time; + value gc_stats; + value entries; + value words_scanned; + value words_scanned_with_profinfo; + value total_allocations; +} snapshot; + +typedef struct { + uintnat num_blocks; + uintnat num_words_including_headers; +} raw_snapshot_entry; + +static value allocate_outside_heap_with_tag(mlsize_t size_in_bytes, tag_t tag) +{ + /* CR-soon mshinwell: this function should live somewhere else */ + header_t* block; + + Assert(size_in_bytes % sizeof(value) == 0); + block = caml_stat_alloc(sizeof(header_t) + size_in_bytes); + *block = Make_header(size_in_bytes / sizeof(value), tag, Caml_black); + return (value) &block[1]; +} + +static value allocate_outside_heap(mlsize_t size_in_bytes) +{ + Assert(size_in_bytes > 0); + return allocate_outside_heap_with_tag(size_in_bytes, 0); +} + +static value take_gc_stats(void) +{ + value v_stats; + gc_stats* stats; + + v_stats = allocate_outside_heap(sizeof(gc_stats)); + stats = (gc_stats*) v_stats; + + stats->minor_words = Val_long(caml_stat_minor_words); + stats->promoted_words = Val_long(caml_stat_promoted_words); + stats->major_words = + Val_long(((uintnat) caml_stat_major_words) + + ((uintnat) caml_allocated_words)); + stats->minor_collections = Val_long(caml_stat_minor_collections); + stats->major_collections = Val_long(caml_stat_major_collections); + stats->heap_words = Val_long(caml_stat_heap_wsz / sizeof(value)); + stats->heap_chunks = Val_long(caml_stat_heap_chunks); + stats->compactions = Val_long(caml_stat_compactions); + stats->top_heap_words = Val_long(caml_stat_top_heap_wsz / sizeof(value)); + + return v_stats; +} + +static value get_total_allocations(void) +{ + value v_total_allocations = Val_unit; + allocation_point* total = caml_all_allocation_points; + + while (total != NULL) { + value v_total; + v_total = allocate_outside_heap_with_tag(3 * sizeof(value), 0); + + /* [v_total] is of type [Raw_spacetime_lib.total_allocations]. */ + Field(v_total, 0) = Val_long(Profinfo_hd(total->profinfo)); + Field(v_total, 1) = total->count; + Field(v_total, 2) = v_total_allocations; + v_total_allocations = v_total; + + Assert (total->next == Val_unit + || (Is_block(total->next) && Tag_val(total->next) == Infix_tag)); + if (total->next == Val_unit) { + total = NULL; + } + else { + total = (allocation_point*) Hp_val(total->next); + } + } + + return v_total_allocations; +} + +static value take_snapshot(double time_override, int use_time_override) +{ + value v_snapshot; + snapshot* heap_snapshot; + value v_entries; + snapshot_entries* entries; + char* chunk; + value gc_stats; + uintnat index; + uintnat target_index; + value v_time; + double time; + uintnat profinfo; + uintnat num_distinct_profinfos; + /* Fixed size buffer to avoid needing a hash table: */ + static raw_snapshot_entry* raw_entries = NULL; + uintnat words_scanned = 0; + uintnat words_scanned_with_profinfo = 0; + value v_total_allocations; + + if (!use_time_override) { + time = caml_sys_time_unboxed(Val_unit); + } + else { + time = time_override; + } + + gc_stats = take_gc_stats(); + + if (raw_entries == NULL) { + size_t size = (PROFINFO_MASK + 1) * sizeof(raw_snapshot_entry); + raw_entries = caml_stat_alloc(size); + memset(raw_entries, '\0', size); + } else { + size_t size = (PROFINFO_MASK + 1) * sizeof(raw_snapshot_entry); + memset(raw_entries, '\0', size); + } + + num_distinct_profinfos = 0; + + /* CR-someday mshinwell: consider reintroducing minor heap scanning, + properly from roots, which would then give a snapshot function + that doesn't do a minor GC. Although this may not be that important + and potentially not worth the effort (it's quite tricky). */ + + /* Scan the major heap. */ + chunk = caml_heap_start; + while (chunk != NULL) { + char* hp; + char* limit; + + hp = chunk; + limit = chunk + Chunk_size (chunk); + + while (hp < limit) { + header_t hd = Hd_hp (hp); + switch (Color_hd(hd)) { + case Caml_blue: + break; + + default: + if (Wosize_hd(hd) > 0) { /* ignore atoms */ + profinfo = Profinfo_hd(hd); + words_scanned += Whsize_hd(hd); + if (profinfo > 0 && profinfo < PROFINFO_MASK) { + words_scanned_with_profinfo += Whsize_hd(hd); + Assert (raw_entries[profinfo].num_blocks >= 0); + if (raw_entries[profinfo].num_blocks == 0) { + num_distinct_profinfos++; + } + raw_entries[profinfo].num_blocks++; + raw_entries[profinfo].num_words_including_headers += + Whsize_hd(hd); + } + } + break; + } + hp += Bhsize_hd (hd); + Assert (hp <= limit); + } + + chunk = Chunk_next (chunk); + } + + if (num_distinct_profinfos > 0) { + v_entries = allocate_outside_heap( + num_distinct_profinfos*sizeof(snapshot_entry)); + entries = (snapshot_entries*) v_entries; + target_index = 0; + for (index = 0; index <= PROFINFO_MASK; index++) { + Assert(raw_entries[index].num_blocks >= 0); + if (raw_entries[index].num_blocks > 0) { + Assert(target_index < num_distinct_profinfos); + entries->entries[target_index].profinfo = Val_long(index); + entries->entries[target_index].num_blocks + = Val_long(raw_entries[index].num_blocks); + entries->entries[target_index].num_words_including_headers + = Val_long(raw_entries[index].num_words_including_headers); + target_index++; + } + } + } else { + v_entries = Atom(0); + } + + Assert(sizeof(double) == sizeof(value)); + v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag); + Double_field(v_time, 0) = time; + + v_snapshot = allocate_outside_heap(sizeof(snapshot)); + heap_snapshot = (snapshot*) v_snapshot; + + v_total_allocations = get_total_allocations(); + + heap_snapshot->time = v_time; + heap_snapshot->gc_stats = gc_stats; + heap_snapshot->entries = v_entries; + heap_snapshot->words_scanned + = Val_long(words_scanned); + heap_snapshot->words_scanned_with_profinfo + = Val_long(words_scanned_with_profinfo); + heap_snapshot->total_allocations = v_total_allocations; + + return v_snapshot; +} + +void caml_spacetime_save_snapshot (struct channel *chan, double time_override, + int use_time_override) +{ + value v_snapshot; + value v_total_allocations; + snapshot* heap_snapshot; + + Lock(chan); + + v_snapshot = take_snapshot(time_override, use_time_override); + + caml_output_val(chan, Val_long(0), Val_long(0)); + + caml_extern_allow_out_of_heap = 1; + caml_output_val(chan, v_snapshot, Val_long(0)); + caml_extern_allow_out_of_heap = 0; + + Unlock(chan); + + heap_snapshot = (snapshot*) v_snapshot; + caml_stat_free(Hp_val(heap_snapshot->time)); + caml_stat_free(Hp_val(heap_snapshot->gc_stats)); + if (Wosize_val(heap_snapshot->entries) > 0) { + caml_stat_free(Hp_val(heap_snapshot->entries)); + } + v_total_allocations = heap_snapshot->total_allocations; + while (v_total_allocations != Val_unit) { + value next = Field(v_total_allocations, 2); + caml_stat_free(Hp_val(v_total_allocations)); + v_total_allocations = next; + } + + caml_stat_free(Hp_val(v_snapshot)); +} + +CAMLprim value caml_spacetime_take_snapshot(value v_time_opt, value v_channel) +{ + struct channel * channel = Channel(v_channel); + double time_override = 0.0; + int use_time_override = 0; + + if (Is_block(v_time_opt)) { + time_override = Double_field(Field(v_time_opt, 0), 0); + use_time_override = 1; + } + + caml_spacetime_save_snapshot(channel, time_override, use_time_override); + + return Val_unit; +} + +extern struct custom_operations caml_int64_ops; /* ints.c */ + +static value +allocate_int64_outside_heap(uint64_t i) +{ + value v; + + v = allocate_outside_heap_with_tag(2 * sizeof(value), Custom_tag); + Custom_ops_val(v) = &caml_int64_ops; + Int64_val(v) = i; + + return v; +} + +static value +copy_string_outside_heap(char const *s) +{ + int len; + mlsize_t wosize, offset_index; + value result; + + len = strlen(s); + wosize = (len + sizeof (value)) / sizeof (value); + result = allocate_outside_heap_with_tag(wosize * sizeof(value), String_tag); + + Field (result, wosize - 1) = 0; + offset_index = Bsize_wsize (wosize) - 1; + Byte (result, offset_index) = offset_index - len; + memmove(String_val(result), s, len); + + return result; +} + +static value +allocate_loc_outside_heap(struct caml_loc_info li) +{ + value result; + + if (li.loc_valid) { + result = allocate_outside_heap_with_tag(5 * sizeof(value), 0); + Field(result, 0) = Val_bool(li.loc_is_raise); + Field(result, 1) = copy_string_outside_heap(li.loc_filename); + Field(result, 2) = Val_int(li.loc_lnum); + Field(result, 3) = Val_int(li.loc_startchr); + Field(result, 4) = Val_int(li.loc_endchr); + } else { + result = allocate_outside_heap_with_tag(sizeof(value), 1); + Field(result, 0) = Val_bool(li.loc_is_raise); + } + + return result; +} + +value caml_spacetime_timestamp(double time_override, int use_time_override) +{ + double time; + value v_time; + + if (!use_time_override) { + time = caml_sys_time_unboxed(Val_unit); + } + else { + time = time_override; + } + + v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag); + Double_field(v_time, 0) = time; + + return v_time; +} + +value caml_spacetime_frame_table(void) +{ + /* Flatten the frame table into a single associative list. */ + + value list = Val_long(0); /* the empty list */ + uintnat i; + + if (!caml_debug_info_available()) { + return list; + } + + if (caml_frame_descriptors == NULL) { + caml_init_frame_descriptors(); + } + + for (i = 0; i <= caml_frame_descriptors_mask; i++) { + frame_descr* descr = caml_frame_descriptors[i]; + if (descr != NULL) { + value location, return_address, pair, new_list_element, location_list; + struct caml_loc_info li; + debuginfo dbg; + if (descr->frame_size != 0xffff) { + dbg = caml_debuginfo_extract(descr); + if (dbg != NULL) { + location_list = Val_unit; + while (dbg != NULL) { + value list_element; + + caml_debuginfo_location(dbg, &li); + location = allocate_loc_outside_heap(li); + + list_element = + allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */); + Field(list_element, 0) = location; + Field(list_element, 1) = location_list; + location_list = list_element; + + dbg = caml_debuginfo_next(dbg); + } + + return_address = allocate_int64_outside_heap(descr->retaddr); + pair = allocate_outside_heap_with_tag(2 * sizeof(value), 0); + Field(pair, 0) = return_address; + Field(pair, 1) = location_list; + + new_list_element = + allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */); + Field(new_list_element, 0) = pair; + Field(new_list_element, 1) = list; + list = new_list_element; + } + } + } + } + + return list; +} + +static void add_unit_to_shape_table(uint64_t *unit_table, value *list) +{ + /* This function reverses the order of the lists giving the layout of each + node; however, spacetime_profiling.ml ensures they are emitted in + reverse order, so at the end of it all they're not reversed. */ + + uint64_t* ptr = unit_table; + + while (*ptr != (uint64_t) 0) { + value new_list_element, pair, function_address, layout; + + function_address = + allocate_int64_outside_heap(*ptr++); + + layout = Val_long(0); /* the empty list */ + while (*ptr != (uint64_t) 0) { + int tag; + int stored_tag; + value part_of_shape; + value new_part_list_element; + value location; + int has_extra_argument = 0; + + stored_tag = *ptr++; + /* CR-soon mshinwell: share with emit.mlp */ + switch (stored_tag) { + case 1: /* direct call to given location */ + tag = 0; + has_extra_argument = 1; /* the address of the callee */ + break; + + case 2: /* indirect call to given location */ + tag = 1; + break; + + case 3: /* allocation at given location */ + tag = 2; + break; + + default: + Assert(0); + abort(); /* silence compiler warning */ + } + + location = allocate_int64_outside_heap(*ptr++); + + part_of_shape = allocate_outside_heap_with_tag( + sizeof(value) * (has_extra_argument ? 2 : 1), tag); + Field(part_of_shape, 0) = location; + if (has_extra_argument) { + Field(part_of_shape, 1) = + allocate_int64_outside_heap(*ptr++); + } + + new_part_list_element = + allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */); + Field(new_part_list_element, 0) = part_of_shape; + Field(new_part_list_element, 1) = layout; + layout = new_part_list_element; + } + + pair = allocate_outside_heap_with_tag(2 * sizeof(value), 0); + Field(pair, 0) = function_address; + Field(pair, 1) = layout; + + new_list_element = + allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */); + Field(new_list_element, 0) = pair; + Field(new_list_element, 1) = *list; + *list = new_list_element; + + ptr++; + } +} + +value caml_spacetime_shape_table(void) +{ + value list; + uint64_t* unit_table; + shape_table *dynamic_table; + uint64_t** static_table; + + /* Flatten the hierarchy of shape tables into a single associative list + mapping from function symbols to node layouts. The node layouts are + themselves lists. */ + + list = Val_long(0); /* the empty list */ + + /* Add static shape tables */ + static_table = caml_spacetime_static_shape_tables; + while (*static_table != (uint64_t) 0) { + unit_table = *static_table++; + add_unit_to_shape_table(unit_table, &list); + } + + /* Add dynamic shape tables */ + dynamic_table = caml_spacetime_dynamic_shape_tables; + + while (dynamic_table != NULL) { + unit_table = dynamic_table->table; + add_unit_to_shape_table(unit_table, &list); + dynamic_table = dynamic_table->next; + } + + return list; +} + +#else + +static value spacetime_disabled() +{ + caml_failwith("Spacetime profiling not enabled"); + Assert(0); /* unreachable */ +} + +CAMLprim value caml_spacetime_take_snapshot(value ignored) +{ + return Val_unit; +} + +CAMLprim value caml_spacetime_marshal_frame_table () +{ + return spacetime_disabled(); +} + +CAMLprim value caml_spacetime_frame_table () +{ + return spacetime_disabled(); +} + +CAMLprim value caml_spacetime_marshal_shape_table () +{ + return spacetime_disabled(); +} + +CAMLprim value caml_spacetime_shape_table () +{ + return spacetime_disabled(); +} + +#endif diff -Nru ocaml-4.01.0/asmrun/sparc.S ocaml-4.05.0/asmrun/sparc.S --- ocaml-4.01.0/asmrun/sparc.S 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/asmrun/sparc.S 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,17 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ /* Asm part of the runtime system for the Sparc processor. */ /* Must be preprocessed by cpp */ diff -Nru ocaml-4.01.0/asmrun/stack.h ocaml-4.05.0/asmrun/stack.h --- ocaml-4.01.0/asmrun/stack.h 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/asmrun/stack.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,101 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* Machine-dependent interface with the asm code */ - -#ifndef CAML_STACK_H -#define CAML_STACK_H - -/* Macros to access the stack frame */ - -#ifdef TARGET_sparc -#define Saved_return_address(sp) *((intnat *)((sp) + 92)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 104)) -#endif - -#ifdef TARGET_i386 -#define Saved_return_address(sp) *((intnat *)((sp) - 4)) -#ifdef SYS_macosx -#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -#else -#define Callback_link(sp) ((struct caml_context *)((sp) + 8)) -#endif -#endif - -#ifdef TARGET_power -#define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR)) -#define Already_scanned(sp, retaddr) ((retaddr) & 1) -#define Mark_scanned(sp, retaddr) \ - (*((intnat *)((sp) - SIZEOF_PTR)) = (retaddr) | 1) -#define Mask_already_scanned(retaddr) ((retaddr) & ~1) -#ifdef SYS_aix -#define Trap_frame_size 32 -#else -#define Trap_frame_size 16 -#endif -#define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size)) -#endif - -#ifdef TARGET_arm -#define Saved_return_address(sp) *((intnat *)((sp) - 4)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 8)) -#endif - -#ifdef TARGET_amd64 -#define Saved_return_address(sp) *((intnat *)((sp) - 8)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -#endif - -/* Structure of OCaml callback contexts */ - -struct caml_context { - char * bottom_of_stack; /* beginning of OCaml stack chunk */ - uintnat last_retaddr; /* last return address in OCaml code */ - value * gc_regs; /* pointer to register block */ -}; - -/* Structure of frame descriptors */ - -typedef struct { - uintnat retaddr; - unsigned short frame_size; - unsigned short num_live; - unsigned short live_ofs[1]; -} frame_descr; - -/* Hash table of frame descriptors */ - -extern frame_descr ** caml_frame_descriptors; -extern int caml_frame_descriptors_mask; - -#define Hash_retaddr(addr) \ - (((uintnat)(addr) >> 3) & caml_frame_descriptors_mask) - -extern void caml_init_frame_descriptors(void); -extern void caml_register_frametable(intnat *); -extern void caml_register_dyn_global(void *); - -extern uintnat caml_stack_usage (void); -extern uintnat (*caml_stack_usage_hook)(void); - -/* Declaration of variables used in the asm code */ -extern char * caml_top_of_stack; -extern char * caml_bottom_of_stack; -extern uintnat caml_last_return_address; -extern value * caml_gc_regs; -extern char * caml_exception_pointer; -extern value caml_globals[]; -extern intnat caml_globals_inited; -extern intnat * caml_frametable[]; - -#endif /* CAML_STACK_H */ diff -Nru ocaml-4.01.0/asmrun/startup.c ocaml-4.05.0/asmrun/startup.c --- ocaml-4.01.0/asmrun/startup.c 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/asmrun/startup.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,38 +1,46 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Start-up code */ #include #include -#include "callback.h" -#include "backtrace.h" -#include "custom.h" -#include "debugger.h" -#include "fail.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "intext.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "osdeps.h" -#include "printexc.h" -#include "stack.h" -#include "sys.h" +#include "caml/callback.h" +#include "caml/backtrace.h" +#include "caml/custom.h" +#include "caml/debugger.h" +#include "caml/fail.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/intext.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/osdeps.h" +#include "caml/printexc.h" +#include "caml/stack.h" +#include "caml/startup_aux.h" +#include "caml/sys.h" +#ifdef WITH_SPACETIME +#include "caml/spacetime.h" +#endif #ifdef HAS_UI -#include "ui.h" +#include "caml/ui.h" #endif extern int caml_parser_trace; @@ -43,18 +51,13 @@ struct segment { char * begin; char * end; }; -static void init_atoms(void) +static void init_static(void) { extern struct segment caml_data_segments[], caml_code_segments[]; int i; struct code_fragment * cf; - for (i = 0; i < 256; i++) { - caml_atom_table[i] = Make_header(0, i, Caml_white); - } - if (caml_page_table_add(In_static_data, - caml_atom_table, caml_atom_table + 256) != 0) - caml_fatal_error("Fatal error: not enough memory for initial page table"); + caml_init_atom_table (); for (i = 0; caml_data_segments[i].begin != 0; i++) { /* PR#5509: we must include the zero word at end of data segment, @@ -82,63 +85,6 @@ caml_ext_table_add(&caml_code_fragments_table, cf); } -/* Configuration parameters and flags */ - -static uintnat percent_free_init = Percent_free_def; -static uintnat max_percent_free_init = Max_percent_free_def; -static uintnat minor_heap_init = Minor_heap_def; -static uintnat heap_chunk_init = Heap_chunk_def; -static uintnat heap_size_init = Init_heap_def; -static uintnat max_stack_init = Max_stack_def; - -/* Parse the CAMLRUNPARAM variable */ -/* The option letter for each runtime option is the first letter of the - last word of the ML name of the option (see [stdlib/gc.mli]). - Except for l (maximum stack size) and h (initial heap size). -*/ -/* Note: option l is irrelevant to the native-code runtime. */ - -/* If you change these functions, see also their copy in byterun/startup.c */ - -static void scanmult (char *opt, uintnat *var) -{ - char mult = ' '; - int val; - sscanf (opt, "=%u%c", &val, &mult); - sscanf (opt, "=0x%x%c", &val, &mult); - switch (mult) { - case 'k': *var = (uintnat) val * 1024; break; - case 'M': *var = (uintnat) val * 1024 * 1024; break; - case 'G': *var = (uintnat) val * 1024 * 1024 * 1024; break; - default: *var = (uintnat) val; break; - } -} - -static void parse_camlrunparam(void) -{ - char *opt = getenv ("OCAMLRUNPARAM"); - uintnat p; - - if (opt == NULL) opt = getenv ("CAMLRUNPARAM"); - - if (opt != NULL){ - while (*opt != '\0'){ - switch (*opt++){ - case 's': scanmult (opt, &minor_heap_init); break; - case 'i': scanmult (opt, &heap_chunk_init); break; - case 'h': scanmult (opt, &heap_size_init); break; - case 'l': scanmult (opt, &max_stack_init); break; - case 'o': scanmult (opt, &percent_free_init); break; - case 'O': scanmult (opt, &max_percent_free_init); break; - case 'v': scanmult (opt, &caml_verb_gc); break; - case 'b': caml_record_backtrace(Val_true); break; - case 'p': caml_parser_trace = 1; break; - case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; - } - } - } -} - /* These are termination hooks used by the systhreads library */ struct longjmp_buffer caml_termination_jmpbuf; void (*caml_termination_hook)(void *) = NULL; @@ -147,59 +93,67 @@ extern void caml_init_ieee_floats (void); extern void caml_init_signals (void); -#ifdef _MSC_VER +#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L /* PR 4887: avoid crash box of windows runtime on some system calls */ extern void caml_install_invalid_parameter_handler(); #endif - -void caml_main(char **argv) +value caml_startup_exn(char **argv) { - char * exe_name; -#ifdef __linux__ - static char proc_self_exe[256]; -#endif - value res; + char * exe_name, * proc_self_exe; char tos; +#ifdef WITH_SPACETIME + caml_spacetime_initialize(); +#endif + caml_init_frame_descriptors(); caml_init_ieee_floats(); -#ifdef _MSC_VER +#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L caml_install_invalid_parameter_handler(); #endif caml_init_custom_operations(); + caml_top_of_stack = &tos; #ifdef DEBUG - caml_verb_gc = 63; + caml_verb_gc = 0x3F; #endif - caml_top_of_stack = &tos; - parse_camlrunparam(); - caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, - percent_free_init, max_percent_free_init); - init_atoms(); + caml_parse_ocamlrunparam(); +#ifdef DEBUG + caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0); +#endif + caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz, + caml_init_heap_chunk_sz, caml_init_percent_free, + caml_init_max_percent_free, caml_init_major_window); + init_static(); caml_init_signals(); + caml_init_backtrace(); caml_debugger_init (); /* force debugger.o stub to be linked */ exe_name = argv[0]; if (exe_name == NULL) exe_name = ""; -#ifdef __linux__ - if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) + proc_self_exe = caml_executable_name(); + if (proc_self_exe != NULL) exe_name = proc_self_exe; else exe_name = caml_search_exe_in_path(exe_name); -#else - exe_name = caml_search_exe_in_path(exe_name); -#endif caml_sys_init(exe_name, argv); if (sigsetjmp(caml_termination_jmpbuf.buf, 0)) { if (caml_termination_hook != NULL) caml_termination_hook(NULL); - return; + return Val_unit; } - res = caml_start_program(); - if (Is_exception_result(res)) - caml_fatal_uncaught_exception(Extract_exception(res)); + return caml_start_program(); } void caml_startup(char **argv) { - caml_main(argv); + value res = caml_startup_exn(argv); + + if (Is_exception_result(res)) { + caml_fatal_uncaught_exception(Extract_exception(res)); + } +} + +void caml_main(char **argv) +{ + caml_startup(argv); } diff -Nru ocaml-4.01.0/boot/.ignore ocaml-4.05.0/boot/.ignore --- ocaml-4.01.0/boot/.ignore 2012-07-26 19:21:54.000000000 +0000 +++ ocaml-4.05.0/boot/.ignore 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -Saved -ocamlrun -ocamlrun.exe -ocamlyacc -ocamlyacc.exe -camlheader -myocamlbuild -myocamlbuild.native Binary files /tmp/tmpq4G9uf/XIGdWu05OM/ocaml-4.01.0/boot/myocamlbuild.boot and /tmp/tmpq4G9uf/Vx200jEjRm/ocaml-4.05.0/boot/myocamlbuild.boot differ Binary files /tmp/tmpq4G9uf/XIGdWu05OM/ocaml-4.01.0/boot/ocamlc and /tmp/tmpq4G9uf/Vx200jEjRm/ocaml-4.05.0/boot/ocamlc differ Binary files /tmp/tmpq4G9uf/XIGdWu05OM/ocaml-4.01.0/boot/ocamldep and /tmp/tmpq4G9uf/Vx200jEjRm/ocaml-4.05.0/boot/ocamldep differ Binary files /tmp/tmpq4G9uf/XIGdWu05OM/ocaml-4.01.0/boot/ocamllex and /tmp/tmpq4G9uf/Vx200jEjRm/ocaml-4.05.0/boot/ocamllex differ diff -Nru ocaml-4.01.0/build/boot-c-parts.sh ocaml-4.05.0/build/boot-c-parts.sh --- ocaml-4.01.0/build/boot-c-parts.sh 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/build/boot-c-parts.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. -set -ex - -. config/config.sh - -if "$WINDOWS"; then - MAKEOPTS='-f Makefile.nt' - LINK='cp -f' -else - MAKEOPTS='' - LINK='ln -s -f' -fi - -(cd byterun && make $MAKEOPTS) -(cd asmrun && make $MAKEOPTS all meta."$O" dynlink."$O") -(cd yacc && make $MAKEOPTS) - -if "$WINDOWS"; then - (cd win32caml && make) -fi - -mkdir -p _build/boot - -# Create a bunch of symlinks (or copies) to _build/boot -(cd _build/boot && -$LINK ../../byterun/ocamlrun$EXE \ - ../../byterun/libcamlrun.$A \ - ../../asmrun/libasmrun.$A \ - ../../yacc/ocamlyacc$EXE \ - ../../boot/ocamlc \ - ../../boot/ocamllex \ - ../../boot/ocamldep \ - . ) - -(cd boot && -[ -f boot/ocamlrun$EXE ] || $LINK ../byterun/ocamlrun$EXE . ) diff -Nru ocaml-4.01.0/build/boot.sh ocaml-4.05.0/build/boot.sh --- ocaml-4.01.0/build/boot.sh 2013-02-18 12:09:06.000000000 +0000 +++ ocaml-4.05.0/build/boot.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. -set -ex -TAG_LINE='true: -use_stdlib' - -# If you modify this list, modify it also in camlp4-native-only.sh -STDLIB_MODULES='Pervasives,Arg,Array,Buffer,Char,Digest,Filename,Format,Hashtbl,Lazy,Lexing,List,Map,Printexc,Printf,Scanf,Set,String,Sys,Parsing,Int32,Int64,Nativeint,Obj,Queue,Sort,Stream,Stack' - -./boot/ocamlrun boot/myocamlbuild.boot -ignore "$STDLIB_MODULES" \ - -tag-line "$TAG_LINE" \ - boot/stdlib.cma boot/std_exit.cmo - -boot/ocamlrun boot/myocamlbuild.boot \ - -tag-line "$TAG_LINE" -log _boot_log1 \ - ocamlbuild/ocamlbuildlightlib.cma ocamlbuild/ocamlbuildlight.byte - -rm -f _build/myocamlbuild - -boot/ocamlrun boot/myocamlbuild.boot \ - -just-plugin -install-lib-dir _build/ocamlbuild -byte-plugin - -cp _build/myocamlbuild boot/myocamlbuild - -./boot/ocamlrun boot/myocamlbuild \ - -tag-line "$TAG_LINE" \ - $@ -log _boot_log2 boot/camlheader ocamlc diff -Nru ocaml-4.01.0/build/buildbot ocaml-4.05.0/build/buildbot --- ocaml-4.01.0/build/buildbot 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/build/buildbot 1970-01-01 00:00:00.000000000 +0000 @@ -1,125 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# If you want to help me by participating to the build/test effort: -# http://gallium.inria.fr/~pouillar/ocaml-testing.html -# -- Nicolas Pouillard - -usage() { - echo "Usage: $0 (make|ocb|ocamlbuild) (win (mingw|msvc|msvc64) | *)" - exit 1 -} - -logfile="buildbot.log" - -finish() { - curl -s -0 -F "log=@$logfile" \ - -F "host=`hostname`" \ - -F "mode=$mode-$opt_win-$opt_win2" \ - http://buildbot.feydakins.org/dropbox || : -} - -rm -f buildbot.failed -rm -f $logfile - -bad() { - touch buildbot.failed -} - -finish_if_bad() { - if [ -f buildbot.failed ]; then - finish - exit 2 - fi -} - -if figlet "test" > /dev/null 2> /dev/null; then - draw="figlet" -else - draw="echo ----------- " -fi - -if echo | tee -a tee.log > /dev/null 2> /dev/null; then - tee="tee -a $logfile" -else - tee=: -fi - -rm -f tee.log - -log() { - $draw $@ - $tee -} - -mode=$1 -shift 1 - -case "$mode" in - make|ocb|ocamlbuild) : ;; - *) usage;; -esac - -case "$1" in - win) - opt_win=win - opt_win2=$2 - shift 2 - Makefile=Makefile.nt;; - *) Makefile=Makefile;; -esac - -( [ -f config/Makefile ] && make -f $Makefile clean || : ) 2>&1 | log clean - -( ./build/distclean.sh || : ) 2>&1 | log distclean - -(cvs -q up -dP -r release311 || bad) 2>&1 | log cvs up -finish_if_bad - -case "$opt_win" in -win) - - # FIXME - sed -e 's/\(OTHERLIBRARIES=.*\) labltk/\1/' \ - < "config/Makefile.$opt_win2" > config/Makefile || bad - finish_if_bad - - cp config/m-nt.h config/m.h || bad - finish_if_bad - cp config/s-nt.h config/s.h || bad - finish_if_bad - ;; - -*) - (./configure --prefix `pwd`/_install $@ || bad) 2>&1 | log configure - finish_if_bad - ;; -esac - -case "$mode" in - make) - (make -f $Makefile world opt opt.opt install || bad) 2>&1 | log build install - finish_if_bad - ;; - ocb|ocamlbuild) - (./build/fastworld.sh || bad) 2>&1 | log build - finish_if_bad - (./build/install.sh || bad) 2>&1 | log install - finish_if_bad - ;; -esac - -(cat _build/not_installed || bad) 2>&1 | log not_installed - -finish diff -Nru ocaml-4.01.0/build/camlp4-bootstrap-recipe.txt ocaml-4.05.0/build/camlp4-bootstrap-recipe.txt --- ocaml-4.01.0/build/camlp4-bootstrap-recipe.txt 2012-08-02 08:17:59.000000000 +0000 +++ ocaml-4.05.0/build/camlp4-bootstrap-recipe.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,181 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2010 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -=== Initial setup === - make clean - ./build/distclean.sh - ./configure -prefix `pwd`/_install - (cd otherlibs/labltk/browser; make help.ml) - ./build/fastworld.sh - # Go to "Bootstrap camlp4" - -=== Install the bootstrapping camlp4 processor === - ./build/install.sh - -=== Build camlp4 === - # This step is not needed right after a "./build/world.sh byte" - ./build/camlp4-byte-only.sh - -=== Bootstrap camlp4 === - # First "Build camlp4" - # Then "Install the bootstrapping camlp4 processor" - # Indeed the following bootstrapping script - # does use the installed version! - ./build/camlp4-bootstrap.sh - # If the fixpoint not is reached yet - # Go to "Bootstrap camlp4" - # Otherwise - # Have a look at the changes in - # camlp4/boot it may be a good idea to commit them - -=== Generate Camlp4Ast.ml === - # First "Install the bootstrapping camlp4 processor" - # Indeed the following bootstrapping script - # does use the installed version! - ./build/camlp4-mkCamlp4Ast.sh - -=== Case study "let open M in e" === - - Open the revised parser - Camlp4Parsers/Camlp4OCamlRevisedParser.ml - - Look for similar constructs, indeed rules - that start by the same prefix should in - the same entry. It is simpler to stick - them close to each other. - - [ "let"; r = opt_rec; ... - | "let"; "module"; m = a_UIDENT; ... - - So we naturally add something like - - | "let"; "open"; ... - - Then have a look to the "open" construct: - - | "open"; i = module_longident -> - - So we need a module_longident, it becomes: - - | "let"; "open"; i = module_longident; "in"; e = SELF -> - - Then we leave a dummy action but very close to what we want - in the end: - - | "let"; "open"; i = module_longident; "in"; e = SELF -> - <:expr< open_in $id:i$ $e$ >> - - Here it is just calling a (non-existing) function called open_in. - - Check that there is no other place where we have to duplicate this - rule (yuk!). In our case it is! The sequence entry have the "let" - rules again. - - Then go into Camlp4Parsers/Camlp4OCamlParser.ml and look for other - occurences. - - When copy/pasting the rule take care of SELF occurences, you may - have to replace it by expr and expr LEVEL ";" in our case. - - The return type of the production might be different from expr in - our case an action become <:str_item<...>> instead of <:expr<...> - - Watch the DELETE_RULE as well, in our case I'm searching for the - literal string "let" in the source: - - DELETE_RULE Gram expr: "let"; "open"; module_longident; "in"; SELF END; - - Then build and bootstrap. - - Then you can at last extend the AST, go in: - - Camlp4/Camlp4Ast.partial.ml - - And add the "open in" constructor (at the end). - - (* let open i in e *) - | ExOpI of loc and ident and expr - - Then "Generate Camlp4Ast.ml" and build. - - We get a single warning in Camlp4/Struct/Camlp4Ast2OCamlAst.ml but - don't fix it now. Notice that you may need to disable '-warn-error' - in order to be able to successfully compile, despite of the warning. - - Then I hacked the camlp4/boot/camlp4boot.ml to generate: - Ast.ExOpI(_loc, i, e) - instead of - Ast.ExApp(_loc .... "open_in" ... i ... e ...) - - Build. Bootstrap once and build again. - - Then change the parsers again and replace the - open_in $id:i$ $e$ - by - let open $i$ in $e$ - - Then change the Parsetree generation in - Camlp4/Struct/Camlp4Ast2OCamlAst.ml - - | <:expr@loc< let open $i$ in $e$ >> -> - mkexp loc (Pexp_open (long_uident i) (expr e)) - - Change the pretty-printers as well (drawing inspiration in - "let module" in this case): - - In Camlp4/Printers/OCaml.ml: - | <:expr< let open $i$ in $e$ >> -> - pp f "@[<2>let open %a@]@ @[<2>in@ %a@]" - o#ident i o#reset_semi#expr e - And at the end of #simple_expr: - <:expr< let open $_$ in $_$ >> - - Have a look in Camlp4/Printers/OCamlr.ml as well. - -=== Second case study "with t := ..." === - -1/ Change the revised parser first. -Add new parsing rules for := but keep the old actions for now. - -2/ Change Camlp4Ast.partial.ml, add: - (* type t := t *) - | WcTyS of loc and ctyp and ctyp - (* module i := i *) - | WcMoS of loc and ident and ident - -3/ "Generate Camlp4Ast.ml" and build. - -4/ Change the generated camlp4/boot/camlp4boot.ml: - Look for ":=" and change occurences of - WcMod by WcMoS and WcTyp by WcTyS - -5/ Build (DO NOT bootstrap) - "Install the bootstrapping camlp4 processor" - -6/ Change the required files: - Camlp4/Printers/OCaml.ml: - just copy/paste&adapt what is done for - "... with type t = u" and - "... with module M = N" - Camlp4/Struct/Camlp4Ast2OCamlAst.ml: - I've factored out a common part under - another function and then copy/pasted. - Camlp4Parsers/Camlp4OCamlRevisedParser.ml: - Change the <:with_constr< type $...$ = $...$ >> - we've introduced earlier by replacing the '=' - by ':='. - Camlp4Parsers/Camlp4OCamlParser.ml: - Copy paste what we have done in Camlp4OCamlRevisedParser - and but we need to call opt_private_ctyp instead of - ctyp (just like the "type =" construct). - -7/ Build & Bootstrap diff -Nru ocaml-4.01.0/build/camlp4-bootstrap.sh ocaml-4.05.0/build/camlp4-bootstrap.sh --- ocaml-4.01.0/build/camlp4-bootstrap.sh 2013-08-30 11:39:33.000000000 +0000 +++ ocaml-4.05.0/build/camlp4-bootstrap.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# README: to bootstrap camlp4 have a look at build/camlp4-bootstrap-recipe.txt - -set -e -cd `dirname $0`/.. - -. config/config.sh -export PATH=$BINDIR:$PATH - -TMPTARGETS="\ - camlp4/boot/Lexer.ml" - -TARGETS="\ - camlp4/Camlp4/Struct/Camlp4Ast.ml \ - camlp4/boot/Camlp4.ml \ - camlp4/boot/camlp4boot.ml" - -for target in $TARGETS camlp4/boot/Camlp4Ast.ml; do - [ -f "$target" ] && mv "$target" "$target.old" - rm -f "_build/$target" -done - -if [ -x ./boot/myocamlbuild.native ]; then - OCAMLBUILD=./boot/myocamlbuild.native -else - OCAMLBUILD="./boot/ocamlrun boot/myocamlbuild" -fi -$OCAMLBUILD $TMPTARGETS $TARGETS - -for t in $TARGETS; do - echo promote $t - cp _build/$t camlp4/boot/`basename $t` - if cmp _build/$t camlp4/boot/`basename $t`.old; then - echo fixpoint for $t - else - echo $t is different, you should rebootstrap it by cleaning, building and call this script - fi -done diff -Nru ocaml-4.01.0/build/camlp4-byte-only.sh ocaml-4.05.0/build/camlp4-byte-only.sh --- ocaml-4.01.0/build/camlp4-byte-only.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/camlp4-byte-only.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ byte_stdlib_mixed_mode $OCAMLC_BYTE $OCAMLLEX_BYTE $CAMLP4_BYTE diff -Nru ocaml-4.01.0/build/camlp4-mkCamlp4Ast.sh ocaml-4.05.0/build/camlp4-mkCamlp4Ast.sh --- ocaml-4.01.0/build/camlp4-mkCamlp4Ast.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/camlp4-mkCamlp4Ast.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2010 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. - -. config/config.sh -export PATH=$BINDIR:$PATH - -CAMLP4AST=camlp4/Camlp4/Struct/Camlp4Ast.ml -BOOTP4AST=camlp4/boot/Camlp4Ast.ml - -[ -f "$BOOTP4AST" ] && mv "$BOOTP4AST" "$BOOTP4AST.old" -rm -f "_build/$BOOTP4AST" -rm -f "_build/$CAMLP4AST" - -if [ -x ./boot/myocamlbuild.native ]; then - OCAMLBUILD=./boot/myocamlbuild.native -else - OCAMLBUILD="./boot/ocamlrun boot/myocamlbuild" -fi -$OCAMLBUILD $CAMLP4AST - -echo promote $CAMLP4AST -cp _build/$CAMLP4AST camlp4/boot/`basename $CAMLP4AST` diff -Nru ocaml-4.01.0/build/camlp4-native-only.sh ocaml-4.05.0/build/camlp4-native-only.sh --- ocaml-4.01.0/build/camlp4-native-only.sh 2013-02-18 12:09:06.000000000 +0000 +++ ocaml-4.05.0/build/camlp4-native-only.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x - -# If you modify this list, modify it also in boot.sh -STDLIB_MODULES='Pervasives,Arg,Array,Buffer,Char,Digest,Filename,Format,Hashtbl,Lazy,Lexing,List,Map,Printexc,Printf,Scanf,Set,String,Sys,Parsing,Int32,Int64,Nativeint,Obj,Queue,Sort,Stream,Stack' - -$OCAMLBUILD -ignore "$STDLIB_MODULES" $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $CAMLP4_NATIVE diff -Nru ocaml-4.01.0/build/camlp4-targets.sh ocaml-4.05.0/build/camlp4-targets.sh --- ocaml-4.01.0/build/camlp4-targets.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/camlp4-targets.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -CAMLP4_COMMON="\ - camlp4/Camlp4/Camlp4Ast.partial.ml \ - camlp4/boot/camlp4boot.byte" -CAMLP4_BYTE="$CAMLP4_COMMON \ - camlp4/Camlp4.cmo \ - camlp4/Camlp4Top.cmo \ - camlp4/camlp4prof.byte$EXE \ - camlp4/mkcamlp4.byte$EXE \ - camlp4/camlp4.byte$EXE \ - camlp4/camlp4fulllib.cma" -CAMLP4_NATIVE="$CAMLP4_COMMON \ - camlp4/Camlp4.cmx \ - camlp4/Camlp4Top.cmx \ - camlp4/camlp4prof.native$EXE \ - camlp4/mkcamlp4.native$EXE \ - camlp4/camlp4.native$EXE \ - camlp4/camlp4fulllib.cmxa" - -for i in camlp4boot camlp4r camlp4rf camlp4o camlp4of camlp4oof camlp4orf; do - CAMLP4_BYTE="$CAMLP4_BYTE camlp4/$i.byte$EXE camlp4/$i.cma" - CAMLP4_NATIVE="$CAMLP4_NATIVE camlp4/$i.native$EXE" -done - -cd camlp4 -for dir in Camlp4Parsers Camlp4Printers Camlp4Filters; do - for file in $dir/*.ml; do - base=camlp4/$dir/`basename $file .ml` - CAMLP4_BYTE="$CAMLP4_BYTE $base.cmo" - CAMLP4_NATIVE="$CAMLP4_NATIVE $base.cmx $base.$O" - done -done -cd .. diff -Nru ocaml-4.01.0/build/distclean.sh ocaml-4.05.0/build/distclean.sh --- ocaml-4.01.0/build/distclean.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/distclean.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,43 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. -set -ex -(cd byterun && make clean) || : -(cd asmrun && make clean) || : -(cd yacc && make clean) || : -rm -f build/ocamlbuild_mixed_mode -rm -rf _build -rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader \ - boot/myocamlbuild boot/myocamlbuild.native boot/myocamlbuild.native.exe \ - myocamlbuild_config.ml config/config.sh config/Makefile \ - boot/ocamlyacc tools/cvt_emit.bak tools/*.bak \ - config/s.h config/m.h boot/*.cm* _log _*_log* - -# from partial boot -rm -f driver/main.byte driver/optmain.byte lex/main.byte \ - tools/ocamlmklib.byte camlp4/build/location.ml \ - camlp4/build/location.mli \ - tools/myocamlbuild_config.ml camlp4/build/linenum.mli \ - camlp4/build/linenum.mll \ - camlp4/build/terminfo.mli camlp4/build/terminfo.ml - -# from ocamlbuild bootstrap -rm -f ocamlbuild/_log ocamlbuild/,ocamlbuild.byte.start \ - ocamlbuild/boot/ocamlbuild ocamlbuild/myocamlbuild_config.ml \ - ocamlbuild/myocamlbuild_config.mli -rm -rf ocamlbuild/_build ocamlbuild/_start - -# from the old build system -rm -f camlp4/build/camlp4_config.ml camlp4/**/*.cm* diff -Nru ocaml-4.01.0/build/fastworld.sh ocaml-4.05.0/build/fastworld.sh --- ocaml-4.01.0/build/fastworld.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/fastworld.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,48 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0` -set -e -if [ -e ocamlbuild_mixed_mode ]; then - echo ocamlbuild mixed mode detected - echo 'please cleanup and re-launch (make clean ; ./build/distclean.sh)' - exit 1 -fi -./mkconfig.sh -./mkmyocamlbuild_config.sh -./boot-c-parts.sh -./boot.sh $@ - -cd .. -. build/targets.sh -OCAMLMKLIB_BYTE="tools/ocamlmklib.byte" -set -x -$OCAMLBUILD $@ -log _boot_fast_log \ - $STDLIB_BYTE $OCAMLOPT_BYTE $STDLIB_NATIVE \ - $OCAMLOPT_NATIVE $OCAMLMKLIB_BYTE $OTHERLIBS_UNIX_NATIVE $OCAMLBUILD_NATIVE - -rm -f _build/myocamlbuild -boot/ocamlrun boot/myocamlbuild \ - -just-plugin -install-lib-dir _build/ocamlbuild \ - -ocamlopt "../_build/ocamlopt.opt -nostdlib -I boot -I stdlib -I $UNIXDIR" -cp _build/myocamlbuild boot/myocamlbuild.native - -./boot/myocamlbuild.native $@ \ - $OCAMLC_NATIVE $TOPLEVEL $OTHERLIBS_BYTE $OTHERLIBS_NATIVE $OCAMLLEX_BYTE \ - $OCAMLLEX_NATIVE $TOOLS_BYTE $TOOLS_NATIVE $DEBUGGER \ - $OCAMLDOC_BYTE $OCAMLDOC_NATIVE $OCAMLBUILD_BYTE $CAMLP4_BYTE $CAMLP4_NATIVE - -cd tools -make objinfo_helper -cd .. diff -Nru ocaml-4.01.0/build/.ignore ocaml-4.05.0/build/.ignore --- ocaml-4.01.0/build/.ignore 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/build/.ignore 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -ocamlbuild_mixed_mode diff -Nru ocaml-4.01.0/build/install.sh ocaml-4.05.0/build/install.sh --- ocaml-4.01.0/build/install.sh 2013-01-01 04:53:49.000000000 +0000 +++ ocaml-4.05.0/build/install.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,573 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e - -cd `dirname $0`/.. - -. config/config.sh - -not_installed=$PWD/_build/not_installed - -rm -f "$not_installed" -touch "$not_installed" - -wontinstall() { - echo "$1" >> "$not_installed" - echo " don't install $1" -} - -installbin() { - if [ -f "$1" ]; then - echo " install binary $2" - cp -f "$1" "$2" - [ -x "$2" ] || chmod +x "$2" - else - wontinstall "$1" - fi -} - -installbestbin() { - if [ -f "$1" ]; then - echo " install binary $3 (with `basename $1`)" - cp -f "$1" "$3" - else - if [ -f "$2" ]; then - echo " install binary $3 (with `basename $2`)" - cp -f "$2" "$3" - else - echo "None of $1, $2 exists" - exit 3 - fi - fi - [ -x "$3" ] || chmod +x "$3" -} - -installlib() { - if [ -f "$1" ]; then - dest="$2/`basename $1`" - echo " install library $dest" - cp -f "$1" "$2" - if [ "$RANLIB" != "" ]; then - "$RANLIB" "$dest" - fi - else - wontinstall "$1" - fi -} - -installdir() { - args="" - while [ $# -gt 1 ]; do - if [ -f "$1" ]; then - args="$args $1" - else - wontinstall "$1" - fi - shift - done - last="$1" - for file in $args; do - echo " install $last/`basename $file`" - cp -f "$file" "$last" - done -} - -installlibdir() { - args="" - while [ $# -gt 1 ]; do - args="$args $1" - shift - done - last="$1" - for file in $args; do - installlib "$file" "$last" - done -} - -mkdir -p $BINDIR -mkdir -p $LIBDIR -mkdir -p $LIBDIR/caml -mkdir -p $LIBDIR/camlp4 -mkdir -p $LIBDIR/vmthreads -mkdir -p $LIBDIR/threads -mkdir -p $LIBDIR/labltk -mkdir -p $LIBDIR/ocamlbuild -mkdir -p $LIBDIR/ocamldoc -mkdir -p $LIBDIR/ocamldoc/custom -mkdir -p $STUBLIBDIR -mkdir -p $MANDIR/man1 -mkdir -p $MANDIR/man3 -mkdir -p $MANDIR/man$MANEXT - -echo "Installing core libraries..." -installlibdir byterun/libcamlrun.$A asmrun/libasmrun.$A asmrun/libasmrunp.$A \ - $LIBDIR -installdir byterun/libcamlrun_shared$EXT_DLL $LIBDIR - -PUBLIC_INCLUDES="\ - alloc.h callback.h config.h custom.h fail.h intext.h \ - memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h" - -cd byterun -for i in $PUBLIC_INCLUDES; do - echo " install caml/$i" - sed -f ../tools/cleanup-header $i > $LIBDIR/caml/$i -done -cd .. - -WIN32="" -if [ "x$EXE" = "x.exe" ]; then - installbin win32caml/ocamlwin.exe $PREFIX/OCamlWin.exe - WIN32=win32 -fi - -installdir otherlibs/"$WIN32"unix/unixsupport.h \ - otherlibs/bigarray/bigarray.h \ - $LIBDIR/caml - -installdir yacc/ocamlyacc$EXE byterun/ocamlrun$EXE $BINDIR - -installdir config/Makefile $LIBDIR/Makefile.config -installdir byterun/ld.conf $LIBDIR - -cd _build - -echo "Installing the toplevel and compilers..." -installbin ocaml$EXE $BINDIR/ocaml$EXE -installbin ocamlc$EXE $BINDIR/ocamlc$EXE -installbin ocamlopt$EXE $BINDIR/ocamlopt$EXE -installbin ocamlc.opt$EXE $BINDIR/ocamlc.opt$EXE -installbin ocamlopt.opt$EXE $BINDIR/ocamlopt.opt$EXE - -set=set # coloration workaround - -echo "Installing the standard library..." -installdir \ - stdlib/stdlib.cma \ - stdlib/stdlib.cmxa stdlib/stdlib.p.cmxa \ - stdlib/camlheader \ - stdlib/camlheader_ur \ - stdlib/std_exit.cm[io] stdlib/std_exit.ml \ - stdlib/arg.cmi stdlib/arg.ml stdlib/arg.mli \ - stdlib/array.cmi stdlib/array.ml stdlib/array.mli \ - stdlib/arrayLabels.cmi stdlib/arrayLabels.ml stdlib/arrayLabels.mli \ - stdlib/buffer.cmi stdlib/buffer.ml stdlib/buffer.mli \ - stdlib/callback.cmi stdlib/callback.ml stdlib/callback.mli \ - stdlib/camlinternalLazy.cmi stdlib/camlinternalLazy.ml stdlib/camlinternalLazy.mli \ - stdlib/camlinternalMod.cmi stdlib/camlinternalMod.ml stdlib/camlinternalMod.mli \ - stdlib/camlinternalOO.cmi stdlib/camlinternalOO.ml stdlib/camlinternalOO.mli \ - stdlib/char.cmi stdlib/char.ml stdlib/char.mli \ - stdlib/complex.cmi stdlib/complex.ml stdlib/complex.mli \ - stdlib/digest.cmi stdlib/digest.ml stdlib/digest.mli \ - stdlib/filename.cmi stdlib/filename.ml stdlib/filename.mli \ - stdlib/format.cmi stdlib/format.ml stdlib/format.mli \ - stdlib/gc.cmi stdlib/gc.ml stdlib/gc.mli \ - stdlib/genlex.cmi stdlib/genlex.ml stdlib/genlex.mli \ - stdlib/hashtbl.cmi stdlib/hashtbl.ml stdlib/hashtbl.mli \ - stdlib/int32.cmi stdlib/int32.ml stdlib/int32.mli \ - stdlib/int64.cmi stdlib/int64.ml stdlib/int64.mli \ - stdlib/lazy.cmi stdlib/lazy.ml stdlib/lazy.mli \ - stdlib/lexing.cmi stdlib/lexing.ml stdlib/lexing.mli \ - stdlib/list.cmi stdlib/list.ml stdlib/list.mli \ - stdlib/listLabels.cmi stdlib/listLabels.ml stdlib/listLabels.mli \ - stdlib/map.cmi stdlib/map.ml stdlib/map.mli \ - stdlib/marshal.cmi stdlib/marshal.ml stdlib/marshal.mli \ - stdlib/moreLabels.cmi stdlib/moreLabels.ml stdlib/moreLabels.mli \ - stdlib/nativeint.cmi stdlib/nativeint.ml stdlib/nativeint.mli \ - stdlib/obj.cmi stdlib/obj.ml stdlib/obj.mli \ - stdlib/oo.cmi stdlib/oo.ml stdlib/oo.mli \ - stdlib/parsing.cmi stdlib/parsing.ml stdlib/parsing.mli \ - stdlib/pervasives.cmi stdlib/pervasives.ml stdlib/pervasives.mli \ - stdlib/printexc.cmi stdlib/printexc.ml stdlib/printexc.mli \ - stdlib/printf.cmi stdlib/printf.ml stdlib/printf.mli \ - stdlib/queue.cmi stdlib/queue.ml stdlib/queue.mli \ - stdlib/random.cmi stdlib/random.ml stdlib/random.mli \ - stdlib/scanf.cmi stdlib/scanf.ml stdlib/scanf.mli \ - stdlib/sort.cmi stdlib/sort.ml stdlib/sort.mli \ - stdlib/stack.cmi stdlib/stack.ml stdlib/stack.mli \ - stdlib/stdLabels.cmi stdlib/stdLabels.ml stdlib/stdLabels.mli \ - stdlib/stream.cmi stdlib/stream.ml stdlib/stream.mli \ - stdlib/string.cmi stdlib/string.ml stdlib/string.mli \ - stdlib/stringLabels.cmi stdlib/stringLabels.ml stdlib/stringLabels.mli \ - stdlib/sys.cmi stdlib/sys.ml stdlib/sys.mli \ - stdlib/weak.cmi stdlib/weak.ml stdlib/weak.mli \ - stdlib/$set.cmi stdlib/$set.ml stdlib/$set.mli \ - stdlib/arg.cmx stdlib/arg.p.cmx \ - stdlib/array.cmx stdlib/array.p.cmx \ - stdlib/arrayLabels.cmx stdlib/arrayLabels.p.cmx \ - stdlib/buffer.cmx stdlib/buffer.p.cmx \ - stdlib/callback.cmx stdlib/callback.p.cmx \ - stdlib/camlinternalLazy.cmx stdlib/camlinternalLazy.p.cmx \ - stdlib/camlinternalMod.cmx stdlib/camlinternalMod.p.cmx \ - stdlib/camlinternalOO.cmx stdlib/camlinternalOO.p.cmx \ - stdlib/char.cmx stdlib/char.p.cmx \ - stdlib/complex.cmx stdlib/complex.p.cmx \ - stdlib/digest.cmx stdlib/digest.p.cmx \ - stdlib/filename.cmx stdlib/filename.p.cmx \ - stdlib/format.cmx stdlib/format.p.cmx \ - stdlib/gc.cmx stdlib/gc.p.cmx \ - stdlib/genlex.cmx stdlib/genlex.p.cmx \ - stdlib/hashtbl.cmx stdlib/hashtbl.p.cmx \ - stdlib/int32.cmx stdlib/int32.p.cmx \ - stdlib/int64.cmx stdlib/int64.p.cmx \ - stdlib/lazy.cmx stdlib/lazy.p.cmx \ - stdlib/lexing.cmx stdlib/lexing.p.cmx \ - stdlib/list.cmx stdlib/list.p.cmx \ - stdlib/listLabels.cmx stdlib/listLabels.p.cmx \ - stdlib/map.cmx stdlib/map.p.cmx \ - stdlib/marshal.cmx stdlib/marshal.p.cmx \ - stdlib/moreLabels.cmx stdlib/moreLabels.p.cmx \ - stdlib/nativeint.cmx stdlib/nativeint.p.cmx \ - stdlib/obj.cmx stdlib/obj.p.cmx \ - stdlib/oo.cmx stdlib/oo.p.cmx \ - stdlib/parsing.cmx stdlib/parsing.p.cmx \ - stdlib/pervasives.cmx stdlib/pervasives.p.cmx \ - stdlib/printexc.cmx stdlib/printexc.p.cmx \ - stdlib/printf.cmx stdlib/printf.p.cmx \ - stdlib/queue.cmx stdlib/queue.p.cmx \ - stdlib/random.cmx stdlib/random.p.cmx \ - stdlib/scanf.cmx stdlib/scanf.p.cmx \ - stdlib/sort.cmx stdlib/sort.p.cmx \ - stdlib/stack.cmx stdlib/stack.p.cmx \ - stdlib/stdLabels.cmx stdlib/stdLabels.p.cmx \ - stdlib/std_exit.cmx stdlib/std_exit.p.cmx stdlib/std_exit.$O stdlib/std_exit.p.$O \ - stdlib/stream.cmx stdlib/stream.p.cmx \ - stdlib/string.cmx stdlib/string.p.cmx \ - stdlib/stringLabels.cmx stdlib/stringLabels.p.cmx \ - stdlib/sys.cmx stdlib/sys.p.cmx \ - stdlib/weak.cmx stdlib/weak.p.cmx \ - stdlib/$set.cmx stdlib/$set.p.cmx \ - $LIBDIR - -installlibdir \ - stdlib/stdlib.$A stdlib/stdlib.p.$A \ - $LIBDIR - -echo "Installing ocamllex, ocamldebug..." -installbin lex/ocamllex$EXE $BINDIR/ocamllex$EXE -installbin debugger/ocamldebug$EXE $BINDIR/ocamldebug$EXE -installbin lex/ocamllex.opt$EXE $BINDIR/ocamllex.opt$EXE -installbin tools/ocamldep.native$EXE $BINDIR/ocamldep.opt$EXE - -echo "Installing some tools..." -installbin tools/objinfo.byte$EXE $BINDIR/ocamlobjinfo$EXE -installbin ../tools/objinfo_helper$EXE $LIBDIR/objinfo_helper$EXE -installbin tools/ocamlcp.byte$EXE $BINDIR/ocamlcp$EXE -installbin tools/ocamldep.byte$EXE $BINDIR/ocamldep$EXE -installbin tools/ocamlmklib.byte$EXE $BINDIR/ocamlmklib$EXE -installbin tools/ocamlmktop.byte$EXE $BINDIR/ocamlmktop$EXE -installbin tools/ocamlprof.byte$EXE $BINDIR/ocamlprof$EXE -installbin toplevel/expunge.byte$EXE $LIBDIR/expunge$EXE -installbin tools/addlabels.byte $LIBDIR/addlabels -installbin tools/scrapelabels.byte $LIBDIR/scrapelabels -installbin otherlibs/dynlink/extract_crc.byte $LIBDIR/extract_crc -installbin otherlibs/labltk/lib/labltk$EXE $BINDIR/labltk$EXE -installbin otherlibs/labltk/browser/ocamlbrowser$EXE $BINDIR/ocamlbrowser$EXE -installbin otherlibs/labltk/compiler/pp$EXE $LIBDIR/labltk/pp$EXE -installbin otherlibs/labltk/lib/labltktop$EXE $LIBDIR/labltk/labltktop$EXE - -echo "Installing libraries..." -installdir \ - otherlibs/bigarray/bigarray.cma \ - otherlibs/dbm/dbm.cma \ - otherlibs/dynlink/dynlink.cma \ - otherlibs/"$WIN32"graph/graphics.cma \ - otherlibs/num/nums.cma \ - otherlibs/str/str.cma \ - otherlibs/"$WIN32"unix/unix.cma \ - otherlibs/bigarray/bigarray.cmxa \ - otherlibs/dbm/dbm.cmxa \ - otherlibs/dynlink/dynlink.cmxa \ - otherlibs/"$WIN32"graph/graphics.cmxa \ - otherlibs/num/nums.cmxa \ - otherlibs/str/str.cmxa \ - otherlibs/"$WIN32"unix/unix.cmxa \ - toplevel/toplevellib.cma \ - otherlibs/systhreads/thread.mli \ - otherlibs/systhreads/mutex.mli \ - otherlibs/systhreads/condition.mli \ - otherlibs/systhreads/event.mli \ - otherlibs/systhreads/threadUnix.mli \ - $LIBDIR - -installdir \ - otherlibs/labltk/support/fileevent.mli \ - otherlibs/labltk/support/fileevent.cmi \ - otherlibs/labltk/support/fileevent.cmx \ - otherlibs/labltk/support/protocol.mli \ - otherlibs/labltk/support/protocol.cmi \ - otherlibs/labltk/support/protocol.cmx \ - otherlibs/labltk/support/textvariable.mli \ - otherlibs/labltk/support/textvariable.cmi \ - otherlibs/labltk/support/textvariable.cmx \ - otherlibs/labltk/support/timer.mli \ - otherlibs/labltk/support/timer.cmi \ - otherlibs/labltk/support/timer.cmx \ - otherlibs/labltk/support/rawwidget.mli \ - otherlibs/labltk/support/rawwidget.cmi \ - otherlibs/labltk/support/rawwidget.cmx \ - otherlibs/labltk/support/widget.mli \ - otherlibs/labltk/support/widget.cmi \ - otherlibs/labltk/support/widget.cmx \ - otherlibs/labltk/support/tkthread.mli \ - otherlibs/labltk/support/tkthread.cmi \ - otherlibs/labltk/support/tkthread.cmo \ - otherlibs/labltk/support/tkthread.$O \ - otherlibs/labltk/support/tkthread.cmx \ - otherlibs/labltk/labltk/[^_]*.mli \ - otherlibs/labltk/labltk/*.cmi \ - otherlibs/labltk/labltk/*.cmx \ - otherlibs/labltk/camltk/[^_]*.mli \ - otherlibs/labltk/camltk/*.cmi \ - otherlibs/labltk/camltk/*.cmx \ - otherlibs/labltk/frx/frxlib.cma \ - otherlibs/labltk/frx/frxlib.cmxa \ - ../otherlibs/labltk/frx/*.mli \ - otherlibs/labltk/frx/*.cmi \ - otherlibs/labltk/jpf/jpflib.cma \ - otherlibs/labltk/jpf/jpflib.cmxa \ - otherlibs/labltk/jpf/*.mli \ - otherlibs/labltk/jpf/*.cmi \ - otherlibs/labltk/jpf/*.cmx \ - otherlibs/labltk/lib/labltk.cma \ - otherlibs/labltk/lib/labltk.cmxa \ - otherlibs/labltk/lib/labltk.cmx \ - otherlibs/labltk/compiler/tkcompiler \ - $LIBDIR/labltk - -installdir \ - otherlibs/systhreads/threads.cma \ - otherlibs/systhreads/threads.cmxa \ - otherlibs/systhreads/thread.cmi \ - otherlibs/systhreads/thread.cmx \ - otherlibs/systhreads/mutex.cmi \ - otherlibs/systhreads/mutex.cmx \ - otherlibs/systhreads/condition.cmi \ - otherlibs/systhreads/condition.cmx \ - otherlibs/systhreads/event.cmi \ - otherlibs/systhreads/event.cmx \ - otherlibs/systhreads/threadUnix.cmi \ - otherlibs/systhreads/threadUnix.cmx \ - $LIBDIR/threads - -installdir \ - otherlibs/bigarray/dllbigarray$EXT_DLL \ - otherlibs/dbm/dllmldbm$EXT_DLL \ - otherlibs/"$WIN32"graph/dllgraphics$EXT_DLL \ - otherlibs/num/dllnums$EXT_DLL \ - otherlibs/str/dllstr$EXT_DLL \ - otherlibs/systhreads/dllthreads$EXT_DLL \ - otherlibs/"$WIN32"unix/dllunix$EXT_DLL \ - otherlibs/threads/dllvmthreads$EXT_DLL \ - otherlibs/labltk/support/dlllabltk$EXT_DLL \ - $STUBLIBDIR - -installlibdir \ - otherlibs/threads/libvmthreads.$A \ - $LIBDIR/vmthreads - -installdir \ - otherlibs/threads/thread.cmi \ - otherlibs/threads/thread.mli \ - otherlibs/threads/mutex.cmi \ - otherlibs/threads/mutex.mli \ - otherlibs/threads/condition.cmi \ - otherlibs/threads/condition.mli \ - otherlibs/threads/event.cmi \ - otherlibs/threads/event.mli \ - otherlibs/threads/threadUnix.cmi \ - otherlibs/threads/threadUnix.mli \ - otherlibs/threads/threads.cma \ - otherlibs/threads/stdlib.cma \ - otherlibs/threads/unix.cma \ - $LIBDIR/vmthreads - -installlibdir \ - otherlibs/labltk/support/liblabltk.$A \ - otherlibs/labltk/lib/labltk.$A \ - otherlibs/labltk/jpf/jpflib.$A \ - otherlibs/labltk/frx/frxlib.$A \ - $LIBDIR/labltk - -installlibdir \ - otherlibs/bigarray/libbigarray.$A \ - otherlibs/dbm/libmldbm.$A \ - otherlibs/"$WIN32"graph/libgraphics.$A \ - otherlibs/num/libnums.$A \ - otherlibs/str/libstr.$A \ - otherlibs/systhreads/libthreads.$A \ - otherlibs/systhreads/libthreadsnat.$A \ - otherlibs/"$WIN32"unix/libunix.$A \ - $LIBDIR - -echo "Installing object files and interfaces..." -installdir \ - tools/profiling.cm[oi] \ - toplevel/topstart.cmo \ - toplevel/toploop.cmi \ - toplevel/topdirs.cmi \ - toplevel/topmain.cmi \ - typing/outcometree.cmi \ - typing/outcometree.mli \ - otherlibs/graph/graphicsX11.cmi \ - otherlibs/graph/graphicsX11.mli \ - otherlibs/dynlink/dynlink.cmi \ - otherlibs/dynlink/dynlink.mli \ - otherlibs/num/arith_status.cmi \ - otherlibs/num/arith_status.mli \ - otherlibs/num/big_int.cmi \ - otherlibs/num/big_int.mli \ - otherlibs/num/nat.cmi \ - otherlibs/num/nat.mli \ - otherlibs/num/num.cmi \ - otherlibs/num/num.mli \ - otherlibs/num/ratio.cmi \ - otherlibs/num/ratio.mli \ - otherlibs/bigarray/bigarray.cmi \ - otherlibs/bigarray/bigarray.mli \ - otherlibs/dbm/dbm.cmi \ - otherlibs/dbm/dbm.mli \ - otherlibs/dynlink/dynlink.cmx \ - otherlibs/"$WIN32"graph/graphics.cmi \ - otherlibs/"$WIN32"graph/graphics.mli \ - otherlibs/str/str.cmi \ - otherlibs/str/str.mli \ - otherlibs/"$WIN32"unix/unix.cmi \ - otherlibs/"$WIN32"unix/unix.mli \ - otherlibs/"$WIN32"unix/unixLabels.cmi \ - otherlibs/"$WIN32"unix/unixLabels.mli \ - otherlibs/num/arith_flags.cmx \ - otherlibs/num/int_misc.cmx \ - otherlibs/num/arith_status.cmx \ - otherlibs/num/big_int.cmx \ - otherlibs/num/nat.cmx \ - otherlibs/num/num.cmx \ - otherlibs/num/ratio.cmx \ - otherlibs/bigarray/bigarray.cmx \ - otherlibs/dbm/dbm.cmx \ - otherlibs/"$WIN32"graph/graphics.cmx \ - otherlibs/graph/graphicsX11.cmx \ - otherlibs/str/str.cmx \ - otherlibs/"$WIN32"unix/unix.cmx \ - otherlibs/"$WIN32"unix/unixLabels.cmx \ - $LIBDIR - -installlibdir \ - otherlibs/bigarray/bigarray.$A \ - otherlibs/dbm/dbm.$A \ - otherlibs/dynlink/dynlink.$A \ - otherlibs/"$WIN32"graph/graphics.$A \ - otherlibs/num/nums.$A \ - otherlibs/str/str.$A \ - otherlibs/"$WIN32"unix/unix.$A \ - stdlib/stdlib.$A \ - $LIBDIR - -installlibdir \ - otherlibs/systhreads/threads.$A \ - $LIBDIR/threads - -echo "Installing manuals..." -(cd ../man && make install) - -echo "Installing ocamldoc..." -installbin ocamldoc/ocamldoc $BINDIR/ocamldoc$EXE -installbin ocamldoc/ocamldoc.opt $BINDIR/ocamldoc.opt$EXE - -installdir \ - ../ocamldoc/ocamldoc.hva \ - ocamldoc/*.cmi \ - ocamldoc/odoc_info.mli ocamldoc/odoc_info.cm[ia] ocamldoc/odoc_info.cmxa \ - ocamldoc/odoc_info.$A \ - $LIBDIR/ocamldoc - -installdir \ - ocamldoc/stdlib_man/* \ - $MANDIR/man3 - -echo "Installing camlp4..." -installbin camlp4/camlp4prof.byte$EXE $BINDIR/camlp4prof$EXE -installbin camlp4/mkcamlp4.byte$EXE $BINDIR/mkcamlp4$EXE -installbin camlp4/camlp4.byte$EXE $BINDIR/camlp4$EXE -installbin camlp4/camlp4boot.byte$EXE $BINDIR/camlp4boot$EXE -installbin camlp4/camlp4o.byte$EXE $BINDIR/camlp4o$EXE -installbin camlp4/camlp4of.byte$EXE $BINDIR/camlp4of$EXE -installbin camlp4/camlp4oof.byte$EXE $BINDIR/camlp4oof$EXE -installbin camlp4/camlp4orf.byte$EXE $BINDIR/camlp4orf$EXE -installbin camlp4/camlp4r.byte$EXE $BINDIR/camlp4r$EXE -installbin camlp4/camlp4rf.byte$EXE $BINDIR/camlp4rf$EXE -installbin camlp4/camlp4o.native$EXE $BINDIR/camlp4o.opt$EXE -installbin camlp4/camlp4of.native$EXE $BINDIR/camlp4of.opt$EXE -installbin camlp4/camlp4oof.native$EXE $BINDIR/camlp4oof.opt$EXE -installbin camlp4/camlp4orf.native$EXE $BINDIR/camlp4orf.opt$EXE -installbin camlp4/camlp4r.native$EXE $BINDIR/camlp4r.opt$EXE -installbin camlp4/camlp4rf.native$EXE $BINDIR/camlp4rf.opt$EXE - -cd camlp4 -CAMLP4DIR=$LIBDIR/camlp4 -for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do - echo "Installing $dir..." - mkdir -p $CAMLP4DIR/$dir - installdir \ - $dir/*.cm* \ - $dir/*.$O \ - $CAMLP4DIR/$dir -done -installdir \ - camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \ - camlp4fulllib.cma camlp4fulllib.cmxa \ - camlp4o.cma camlp4of.cma camlp4oof.cma \ - camlp4orf.cma camlp4r.cma camlp4rf.cma \ - Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \ - Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \ - $CAMLP4DIR -installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR -cd .. - -echo "Installing ocamlbuild..." - -cd ocamlbuild -installbin ocamlbuild.byte$EXE $BINDIR/ocamlbuild.byte$EXE -installbin ocamlbuild.native$EXE $BINDIR/ocamlbuild.native$EXE -installbestbin ocamlbuild.native$EXE ocamlbuild.byte$EXE $BINDIR/ocamlbuild$EXE - -installlibdir \ - ocamlbuildlib.$A \ - $LIBDIR/ocamlbuild - -installdir \ - ocamlbuildlib.cmxa \ - ocamlbuildlib.cma \ - ocamlbuild_plugin.cmi \ - ocamlbuild_plugin.cmo \ - ocamlbuild_plugin.cmx \ - ocamlbuild_pack.cmi \ - ocamlbuild_unix_plugin.cmi \ - ocamlbuild_unix_plugin.cmo \ - ocamlbuild_unix_plugin.cmx \ - ocamlbuild_unix_plugin.$O \ - ocamlbuild_executor.cmi \ - ocamlbuild_executor.cmo \ - ocamlbuild_executor.cmx \ - ocamlbuild_executor.$O \ - ocamlbuild.cmo \ - ocamlbuild.cmx \ - ocamlbuild.$O \ - $LIBDIR/ocamlbuild -cd .. - -installdir \ - ../ocamlbuild/man/ocamlbuild.1 \ - $MANDIR/man1 diff -Nru ocaml-4.01.0/build/mixed-boot.sh ocaml-4.05.0/build/mixed-boot.sh --- ocaml-4.01.0/build/mixed-boot.sh 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/build/mixed-boot.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -ex -cd `dirname $0`/.. -touch build/ocamlbuild_mixed_mode -mkdir -p _build -cp -rf boot _build/ -./build/mkconfig.sh -./build/mkmyocamlbuild_config.sh -./build/boot.sh diff -Nru ocaml-4.01.0/build/mkconfig.sh ocaml-4.05.0/build/mkconfig.sh --- ocaml-4.01.0/build/mkconfig.sh 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/build/mkconfig.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. - -sed -e 's/^\(.*\$([0-9]).*\)$/# \1/' \ - -e 's/\$(\([^)]*\))/${\1}/g' \ - -e 's/^FLEX.*$//g' \ - -e 's/^\([^#=]*\)=\([^"]*\)$/if [ "x$\1" = "x" ]; then \1="\2"; fi/' \ - config/Makefile > config/config.sh - -if [ "x$EXE" = "x.exe" -a "x$SYSTEM" != "xcygwin" ]; then - echo "WINDOWS=true" >> config/config.sh -else - echo "WINDOWS=false" >> config/config.sh -fi diff -Nru ocaml-4.01.0/build/mkmyocamlbuild_config.sh ocaml-4.05.0/build/mkmyocamlbuild_config.sh --- ocaml-4.01.0/build/mkmyocamlbuild_config.sh 2013-05-17 12:03:58.000000000 +0000 +++ ocaml-4.05.0/build/mkmyocamlbuild_config.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. - -sed \ - -e 's/^.*FLEXDIR.*$//g' \ - -e '/^SET_LD_PATH/d' \ - -e 's/^#ml \(.*\)/\1/' \ - -e 's/^\([^"][^"]*\("[^"]*"[^"]*\)*\)#.*$/\1/' \ - -e 's/^\(#.*\)$/(* \1 *)/' \ - -e 's/^\(.*\$([0-9]).*\)$/(* \1 *)/' \ - -e 's/^\([^(=]*\)=\([^"]*\)$/let <:lower<\1>> = "\2";;/' \ - -e 's/\$(AS)/as/g' \ - -e 's/\$(\([^)]*\))/"\^<:lower<\1>>\^"/g' \ - -e 's/""\^//g' \ - -e 's/\^""//g' \ - -e 's/^let <:lower myocamlbuild_config.ml diff -Nru ocaml-4.01.0/build/mkruntimedef.sh ocaml-4.05.0/build/mkruntimedef.sh --- ocaml-4.01.0/build/mkruntimedef.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/mkruntimedef.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -echo 'let builtin_exceptions = [|'; \ -sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$| \1;|p' byterun/fail.h | \ -sed -e '$s/;$//'; \ -echo '|]'; \ -echo 'let builtin_primitives = [|'; \ -sed -e 's/.*/ "&";/' -e '$s/;$//' byterun/primitives; \ -echo '|]' diff -Nru ocaml-4.01.0/build/myocamlbuild.sh ocaml-4.05.0/build/myocamlbuild.sh --- ocaml-4.01.0/build/myocamlbuild.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/myocamlbuild.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. -set -xe -if [ ! -x _build/ocamlbuild/ocamlbuildlight.byte ]; then - if [ ! -x ocamlbuild/_build/ocamlbuildlight.byte ]; then - (cd ocamlbuild && ${GNUMAKE:-make}) - fi - mkdir -p _build/ocamlbuild - for i in "light.cmo" "light.byte" "lightlib.cma" "_plugin.cmi" "_pack.cmi" - do - cp ocamlbuild/_build/ocamlbuild$i _build/ocamlbuild - done -fi -rm -f ocamlbuild/myocamlbuild_config.ml ocamlbuild/myocamlbuild_config.mli -rm -rf _build/myocamlbuild boot/myocamlbuild boot/myocamlbuild.native -./boot/ocamlrun _build/ocamlbuild/ocamlbuildlight.byte -no-hygiene \ - -tag debug -install-lib-dir _build/ocamlbuild -byte-plugin -just-plugin -cp _build/myocamlbuild boot/myocamlbuild.boot diff -Nru ocaml-4.01.0/build/new-build-system ocaml-4.05.0/build/new-build-system --- ocaml-4.01.0/build/new-build-system 2012-08-02 08:17:59.000000000 +0000 +++ ocaml-4.05.0/build/new-build-system 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -_tags # Defines tags to setup exceptions -myocamlbuild.ml # Contains all needed rules that are differents -boot/ocamldep -myocamlbuild_config.mli -utils/config.mlbuild # Should be renamed as utils/config.ml - -# Files that just contain module names of object files. -**/*.mllib # Files that describe the contents of an OCaml library -**/*.mlpack # Files that describe the contents of an OCaml package -**/*.cilb # Files that describe the contents of an C static library -**/*.dilb # Files that describe the contents of an C dynamic library - -build/ - world.sh # Build all the OCaml world - world.byte.sh # Build the bytecode world - world.native.sh # Build the native world - world.all.sh # Build all the world the don't bootstrap - fastworld.sh # Same as above but faster - boot-c-parts.sh # Compile byterun, ocamlyacc and asmrun with the Makefiles - boot.sh # Compile the stdlib and ocamlc - camlp4-targets.sh # Setup camlp4 targets - otherlibs-targets.sh # Setup otherlibs targets - targets.sh # All targets of the OCaml distribution - - - install.sh # Install all needed files - distclean.sh # Clean all generated files - - myocamlbuild.sh # Regenerate the boot/myocamlbuild program - mkconfig.sh # Generate config/config.sh - mkmyocamlbuild_config.sh # Generate myocamlbuild_config.ml - - camlp4-bootstrap.sh - - # Partial stuffs (just camlp4 and ocamlbuild) - mixed-boot.sh - camlp4-byte-only.sh - camlp4-native-only.sh - ocamlbuild-byte-only.sh - ocamlbuild-native-only.sh diff -Nru ocaml-4.01.0/build/ocamlbuild-byte-only.sh ocaml-4.05.0/build/ocamlbuild-byte-only.sh --- ocaml-4.01.0/build/ocamlbuild-byte-only.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/ocamlbuild-byte-only.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ byte_stdlib_mixed_mode $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLBUILD_BYTE diff -Nru ocaml-4.01.0/build/ocamlbuildlib-native-only.sh ocaml-4.05.0/build/ocamlbuildlib-native-only.sh --- ocaml-4.01.0/build/ocamlbuildlib-native-only.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/ocamlbuildlib-native-only.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $OCAMLBUILDLIB_NATIVE diff -Nru ocaml-4.01.0/build/ocamlbuild-native-only.sh ocaml-4.05.0/build/ocamlbuild-native-only.sh --- ocaml-4.01.0/build/ocamlbuild-native-only.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/ocamlbuild-native-only.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $OCAMLBUILD_NATIVE diff -Nru ocaml-4.01.0/build/otherlibs-targets.sh ocaml-4.05.0/build/otherlibs-targets.sh --- ocaml-4.01.0/build/otherlibs-targets.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/otherlibs-targets.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,120 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -OTHERLIBS_BYTE="" -OTHERLIBS_NATIVE="" -OTHERLIBS_UNIX_NATIVE="" -UNIXDIR="otherlibs/unix" - -add_native() { - for native_file in $@; do - OTHERLIBS_NATIVE="$OTHERLIBS_NATIVE otherlibs/$lib/$native_file" - case $lib in - unix|win32unix) - OTHERLIBS_UNIX_NATIVE="$OTHERLIBS_UNIX_NATIVE otherlibs/$lib/$native_file";; - esac - done -} - -add_byte() { - for byte_file in $@; do - OTHERLIBS_BYTE="$OTHERLIBS_BYTE otherlibs/$lib/$byte_file" - done -} - -add_file() { - add_byte $@ - add_native $@ -} - -add_bin() { - for bin_file in $@; do - add_byte $bin_file.byte$EXE - add_native $bin_file.native$EXE - done -} - -add_c_lib() { - add_file "lib$1.$A" -} - -add_ocaml_lib() { - add_native "$1.cmxa" - add_native "$1.$A" - add_byte "$1.cma" -} - -add_dll() { - add_file "dll$1$EXT_DLL" -} - -add() { - add_c_lib $1 - add_ocaml_lib $1 - add_dll $1 -} - -THREADS_CMIS="thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi" - -for lib in $OTHERLIBRARIES; do - case $lib in - num) - add nums;; - systhreads) - add_ocaml_lib threads - add_dll threads - add_file $THREADS_CMIS - add_byte libthreads.$A - add_native libthreadsnat.$A;; - graph|win32graph) - add graphics;; - threads) - add_byte pervasives.cmi pervasives.mli \ - $THREADS_CMIS marshal.cmi marshal.mli \ - stdlib.cma unix.cma threads.cma libvmthreads.$A;; - labltk) - add_file support/camltk.h - add_byte support/byte.otarget - add_native support/native.otarget - add_file support/liblabltk.$A - add_byte compiler/tkcompiler$EXE compiler/pp$EXE - add_file labltk/tk.ml labltk/labltk.ml - add_byte labltk/byte.otarget - add_native labltk/native.otarget - add_byte camltk/byte.otarget - add_native camltk/native.otarget - add_ocaml_lib lib/labltk - add_byte lib/labltktop$EXE lib/labltk$EXE - add_ocaml_lib jpf/jpflib - add_ocaml_lib frx/frxlib - add_byte browser/ocamlbrowser$EXE - ;; - dbm) - add_ocaml_lib dbm - add_c_lib mldbm;; - dynlink) - add_ocaml_lib dynlink - add_native dynlink.cmx dynlink.$O - add_file $lib.cmi extract_crc;; - win32unix) - UNIXDIR="otherlibs/win32unix" - add_file unixsupport.h cst2constr.h socketaddr.h - add unix;; - unix) - add_file unixsupport.h - add unix;; - *) - add $lib - esac -done diff -Nru ocaml-4.01.0/build/partial-install.sh ocaml-4.05.0/build/partial-install.sh --- ocaml-4.01.0/build/partial-install.sh 2013-01-01 04:53:49.000000000 +0000 +++ ocaml-4.05.0/build/partial-install.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,188 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -###################################### -######### Copied from build/install.sh -###################################### - -set -e - -cd `dirname $0`/.. - -. config/config.sh - -not_installed=$PWD/_build/not_installed - -rm -f "$not_installed" -touch "$not_installed" - -wontinstall() { - echo "$1" >> "$not_installed" - echo " don't install $1" -} - -installbin() { - if [ -f "$1" ]; then - echo " install binary $2" - cp -f "$1" "$2" - [ -x "$2" ] || chmod +x "$2" - else - wontinstall "$1" - fi -} - -installbestbin() { - if [ -f "$1" ]; then - echo " install binary $3 (with `basename $1`)" - cp -f "$1" "$3" - else - if [ -f "$2" ]; then - echo " install binary $3 (with `basename $2`)" - cp -f "$2" "$3" - else - echo "None of $1, $2 exists" - exit 3 - fi - fi - [ -x "$3" ] || chmod +x "$3" -} - -installlib() { - if [ -f "$1" ]; then - dest="$2/`basename $1`" - echo " install library $dest" - cp -f "$1" "$2" - if [ "$RANLIB" != "" ]; then - "$RANLIB" "$dest" - fi - else - wontinstall "$1" - fi -} - -installdir() { - args="" - while [ $# -gt 1 ]; do - if [ -f "$1" ]; then - args="$args $1" - else - wontinstall "$1" - fi - shift - done - last="$1" - for file in $args; do - echo " install $last/`basename $file`" - cp -f "$file" "$last" - done -} - -installlibdir() { - args="" - while [ $# -gt 1 ]; do - args="$args $1" - shift - done - last="$1" - for file in $args; do - installlib "$file" "$last" - done -} - -mkdir -p $BINDIR -mkdir -p $LIBDIR -mkdir -p $LIBDIR/camlp4 -mkdir -p $LIBDIR/ocamlbuild -mkdir -p $STUBLIBDIR -mkdir -p $MANDIR/man1 -mkdir -p $MANDIR/man3 -mkdir -p $MANDIR/man$MANEXT - -cd _build - -echo "Installing camlp4..." -installbin camlp4/camlp4prof.byte$EXE $BINDIR/camlp4prof$EXE -installbin camlp4/mkcamlp4.byte$EXE $BINDIR/mkcamlp4$EXE -installbin camlp4/camlp4.byte$EXE $BINDIR/camlp4$EXE -installbin camlp4/camlp4boot.byte$EXE $BINDIR/camlp4boot$EXE -installbin camlp4/camlp4o.byte$EXE $BINDIR/camlp4o$EXE -installbin camlp4/camlp4of.byte$EXE $BINDIR/camlp4of$EXE -installbin camlp4/camlp4oof.byte$EXE $BINDIR/camlp4oof$EXE -installbin camlp4/camlp4orf.byte$EXE $BINDIR/camlp4orf$EXE -installbin camlp4/camlp4r.byte$EXE $BINDIR/camlp4r$EXE -installbin camlp4/camlp4rf.byte$EXE $BINDIR/camlp4rf$EXE -installbin camlp4/camlp4o.native$EXE $BINDIR/camlp4o.opt$EXE -installbin camlp4/camlp4of.native$EXE $BINDIR/camlp4of.opt$EXE -installbin camlp4/camlp4oof.native$EXE $BINDIR/camlp4oof.opt$EXE -installbin camlp4/camlp4orf.native$EXE $BINDIR/camlp4orf.opt$EXE -installbin camlp4/camlp4r.native$EXE $BINDIR/camlp4r.opt$EXE -installbin camlp4/camlp4rf.native$EXE $BINDIR/camlp4rf.opt$EXE - -if test -d camlp4; then - cd camlp4 - CAMLP4DIR=$LIBDIR/camlp4 - for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do - echo "Installing $dir..." - mkdir -p $CAMLP4DIR/$dir - installdir \ - $dir/*.cm* \ - $dir/*.$O \ - $CAMLP4DIR/$dir - done - installdir \ - camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \ - camlp4fulllib.cma camlp4fulllib.cmxa \ - camlp4o.cma camlp4of.cma camlp4oof.cma \ - camlp4orf.cma camlp4r.cma camlp4rf.cma \ - Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \ - Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \ - $CAMLP4DIR - installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR - cd .. -fi - -echo "Installing ocamlbuild..." -cd ocamlbuild -installbin ocamlbuild.byte$EXE $BINDIR/ocamlbuild.byte$EXE -installbin ocamlbuild.native$EXE $BINDIR/ocamlbuild.native$EXE -installbestbin ocamlbuild.native$EXE ocamlbuild.byte$EXE $BINDIR/ocamlbuild$EXE - -installlibdir \ - ocamlbuildlib.$A \ - $LIBDIR/ocamlbuild - -installdir \ - ocamlbuildlib.cmxa \ - ocamlbuildlib.cma \ - ocamlbuild_plugin.cmi \ - ocamlbuild_plugin.cmo \ - ocamlbuild_plugin.cmx \ - ocamlbuild_pack.cmi \ - ocamlbuild_unix_plugin.cmi \ - ocamlbuild_unix_plugin.cmo \ - ocamlbuild_unix_plugin.cmx \ - ocamlbuild_unix_plugin.$O \ - ocamlbuild_executor.cmi \ - ocamlbuild_executor.cmo \ - ocamlbuild_executor.cmx \ - ocamlbuild_executor.$O \ - ocamlbuild.cmo \ - ocamlbuild.cmx \ - ocamlbuild.$O \ - $LIBDIR/ocamlbuild -cd .. - -installdir \ - ../ocamlbuild/man/ocamlbuild.1 \ - $MANDIR/man1 diff -Nru ocaml-4.01.0/build/targets.sh ocaml-4.05.0/build/targets.sh --- ocaml-4.01.0/build/targets.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/targets.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -. config/config.sh -. build/otherlibs-targets.sh -. build/camlp4-targets.sh - -INSTALL_BIN="$BINDIR" -export INSTALL_BIN - -STDLIB_BYTE="stdlib/libcamlrun.$A stdlib/stdlib.cma \ - stdlib/std_exit.cmo stdlib/camlheader stdlib/camlheader_ur" -OCAMLLEX_BYTE=lex/ocamllex$EXE -OCAMLC_BYTE=ocamlc$EXE -OCAMLOPT_BYTE=ocamlopt$EXE -OCAMLBUILD_BYTE="ocamlbuild/ocamlbuildlib.cma \ - ocamlbuild/ocamlbuildlightlib.cma \ - ocamlbuild/ocamlbuild.byte$EXE \ - ocamlbuild/ocamlbuildlight.byte$EXE" -TOPLEVEL=ocaml$EXE -TOOLS_BYTE="tools/objinfo.byte$EXE \ - tools/ocamldep.byte$EXE tools/profiling.cmo \ - tools/ocamlprof.byte$EXE tools/ocamlcp.byte$EXE \ - tools/ocamlmktop.byte$EXE tools/ocamlmklib$EXE \ - tools/scrapelabels.byte tools/addlabels.byte \ - tools/dumpobj.byte$EXE" -if [ ! -z "$DEBUGGER" ]; then - DEBUGGER=debugger/ocamldebug$EXE -fi -OCAMLDOC_BYTE="ocamldoc/ocamldoc$EXE ocamldoc/odoc_info.cma" -STDLIB_NATIVE="stdlib/stdlib.cmxa stdlib/std_exit.cmx asmrun/libasmrun.$A" -case $PROFILING in -prof) - STDLIB_NATIVE="$STDLIB_NATIVE asmrun/libasmrunp.$A \ - stdlib/stdlib.p.cmxa stdlib/std_exit.p.cmx";; -noprof) ;; -*) echo "unexpected PROFILING value $PROFILING"; exit 1;; -esac -OCAMLC_NATIVE=ocamlc.opt$EXE -OCAMLOPT_NATIVE=ocamlopt.opt$EXE -OCAMLLEX_NATIVE=lex/ocamllex.opt$EXE -TOOLS_NATIVE=tools/ocamldep.native$EXE -OCAMLDOC_NATIVE="ocamldoc/ocamldoc.opt$EXE ocamldoc/odoc_info.cmxa ocamldoc/stdlib_man/Pervasives.3o" -OCAMLBUILDLIB_NATIVE="ocamlbuild/ocamlbuildlib.cmxa \ - ocamlbuild/ocamlbuildlightlib.cmxa" -OCAMLBUILD_NATIVE="$OCAMLBUILDLIB_NATIVE \ - ocamlbuild/ocamlbuild.native$EXE \ - ocamlbuild/ocamlbuildlight.native$EXE" -if [ -x boot/myocamlbuild.native ]; then - OCAMLBUILD=./boot/myocamlbuild.native -else - OCAMLBUILD="./boot/ocamlrun boot/myocamlbuild" -fi diff -Nru ocaml-4.01.0/build/tolower.sed ocaml-4.05.0/build/tolower.sed --- ocaml-4.01.0/build/tolower.sed 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/build/tolower.sed 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# tolower.sed expands one ...<:lower>... to ...foo... per line -h -s/.*<:lower<\(.*\)>>.*/\1/ -t cont -b end -:cont -y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ -s/$/|/ -G -s/\(.*\)|\n\(.*\)<:lower<\(.*\)>>/\2\1/ -:end diff -Nru ocaml-4.01.0/build/world.all.sh ocaml-4.05.0/build/world.all.sh --- ocaml-4.01.0/build/world.all.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/world.all.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ \ - $STDLIB_BYTE $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLOPT_BYTE $TOPLEVEL \ - $TOOLS_BYTE $OTHERLIBS_BYTE $OCAMLBUILD_BYTE $DEBUGGER $OCAMLDOC_BYTE \ - $CAMLP4_BYTE $STDLIB_NATIVE $OCAMLC_NATIVE $OCAMLOPT_NATIVE \ - $OCAMLLEX_NATIVE $TOOLS_NATIVE $OTHERLIBS_NATIVE \ - $OCAMLBUILD_NATIVE $OCAMLDOC_NATIVE $CAMLP4_NATIVE diff -Nru ocaml-4.01.0/build/world.byte.sh ocaml-4.05.0/build/world.byte.sh --- ocaml-4.01.0/build/world.byte.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/world.byte.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ \ - $STDLIB_BYTE $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLOPT_BYTE $TOPLEVEL $TOOLS_BYTE \ - $OTHERLIBS_BYTE $OCAMLBUILD_BYTE $DEBUGGER $OCAMLDOC_BYTE $CAMLP4_BYTE diff -Nru ocaml-4.01.0/build/world.native.sh ocaml-4.05.0/build/world.native.sh --- ocaml-4.01.0/build/world.native.sh 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/build/world.native.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ \ - $STDLIB_NATIVE $OCAMLC_NATIVE $OCAMLOPT_NATIVE \ - $OCAMLLEX_NATIVE $TOOLS_NATIVE $OTHERLIBS_NATIVE \ - $OCAMLBUILD_NATIVE $OCAMLDOC_NATIVE $CAMLP4_NATIVE diff -Nru ocaml-4.01.0/build/world.sh ocaml-4.05.0/build/world.sh --- ocaml-4.01.0/build/world.sh 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/build/world.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0` -set -e -if [ -e ocamlbuild_mixed_mode ]; then - echo ocamlbuild mixed mode detected - echo 'please cleanup and re-launch (make clean ; ./build/distclean.sh)' - exit 1 -fi -case "$1" in - all|a|al) mode=all;; - byte|b|by|byt) mode=byte;; - native|na|nat|nati|nativ) mode=native;; - *) echo 'Unexpected target. Expected targets are: all,byte,native' \ - >/dev/stderr - exit 1;; -esac -shift -./mkconfig.sh -./mkmyocamlbuild_config.sh -./boot-c-parts.sh -./boot.sh "$@" -./world."$mode".sh "$@" diff -Nru ocaml-4.01.0/bytecomp/bytegen.ml ocaml-4.05.0/bytecomp/bytegen.ml --- ocaml-4.01.0/bytecomp/bytegen.ml 2012-11-29 09:55:00.000000000 +0000 +++ ocaml-4.05.0/bytecomp/bytegen.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* bytegen.ml : translation of lambda terms to lists of instructions. *) @@ -74,7 +77,7 @@ match cont with (Kbranch _ as branch) :: _ -> (branch, cont) | (Kreturn _ as return) :: _ -> (return, cont) - | Kraise :: _ -> (Kraise, cont) + | Kraise k :: _ -> (Kraise k, cont) | Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont | _ -> make_branch_2 (None) 0 cont cont @@ -108,7 +111,7 @@ match cont with Kpop m :: cont -> add_pop (n + m) cont | Kreturn m :: cont -> Kreturn(n + m) :: cont - | Kraise :: _ -> cont + | Kraise _ :: _ -> cont | _ -> Kpop n :: cont (* Add the constant "unit" in front of a continuation *) @@ -128,36 +131,46 @@ | RHS_block of int | RHS_floatblock of int | RHS_nonrec + | RHS_function of int * int ;; let rec check_recordwith_updates id e = match e with - | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; _]), cont) + | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; _], _), cont) -> id2 = id && check_recordwith_updates id cont | Lvar id2 -> id2 = id | _ -> false ;; let rec size_of_lambda = function - | Lfunction(kind, params, body) as funct -> - RHS_block (1 + IdentSet.cardinal(free_variables funct)) - | Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body) + | Lfunction{params} as funct -> + RHS_function (1 + IdentSet.cardinal(free_variables funct), + List.length params) + | Llet (Strict, _k, id, Lprim (Pduprecord (kind, size), _, _), body) when check_recordwith_updates id body -> begin match kind with - | Record_regular -> RHS_block size + | Record_regular | Record_inlined _ -> RHS_block size + | Record_unboxed _ -> assert false | Record_float -> RHS_floatblock size + | Record_extension -> RHS_block (size + 1) end - | Llet(str, id, arg, body) -> size_of_lambda body - | Lletrec(bindings, body) -> size_of_lambda body - | Lprim(Pmakeblock(tag, mut), args) -> RHS_block (List.length args) - | Lprim (Pmakearray (Paddrarray|Pintarray), args) -> + | Llet(_str, _k, _id, _arg, body) -> size_of_lambda body + | Lletrec(_bindings, body) -> size_of_lambda body + | Lprim(Pmakeblock _, args, _) -> RHS_block (List.length args) + | Lprim (Pmakearray ((Paddrarray|Pintarray), _), args, _) -> RHS_block (List.length args) - | Lprim (Pmakearray Pfloatarray, args) -> RHS_floatblock (List.length args) - | Lprim (Pmakearray Pgenarray, args) -> assert false - | Lprim (Pduprecord (Record_regular, size), args) -> RHS_block size - | Lprim (Pduprecord (Record_float, size), args) -> RHS_floatblock size + | Lprim (Pmakearray (Pfloatarray, _), args, _) -> + RHS_floatblock (List.length args) + | Lprim (Pmakearray (Pgenarray, _), _, _) -> assert false + | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), _, _) -> + RHS_block size + | Lprim (Pduprecord (Record_unboxed _, _), _, _) -> + assert false + | Lprim (Pduprecord (Record_extension, size), _, _) -> + RHS_block (size + 1) + | Lprim (Pduprecord (Record_float, size), _, _) -> RHS_floatblock size | Levent (lam, _) -> size_of_lambda lam - | Lsequence (lam, lam') -> size_of_lambda lam' + | Lsequence (_lam, lam') -> size_of_lambda lam' | _ -> RHS_nonrec (**** Merging consecutive events ****) @@ -233,9 +246,15 @@ (**** Compilation of a lambda expression ****) -(* association staticraise numbers -> (lbl,size of stack *) +let try_blocks = ref [] (* list of stack size for each nested try block *) + +(* association staticraise numbers -> (lbl,size of stack, try_blocks *) let sz_static_raises = ref [] + +let push_static_raise i lbl_handler sz = + sz_static_raises := (i, (lbl_handler, sz, !try_blocks)) :: !sz_static_raises + let find_raise_label i = try List.assoc i !sz_static_raises @@ -247,8 +266,8 @@ (* Will the translation of l lead to a jump to label ? *) let code_as_jump l sz = match l with | Lstaticraise (i,[]) -> - let label,size = find_raise_label i in - if sz = size then + let label,size,tb = find_raise_label i in + if sz = size && tb == !try_blocks then Some label else None @@ -275,6 +294,10 @@ let max_stack_used = ref 0 + +(* Sequence of string tests *) + + (* Translate a primitive to a bytecode instruction (possibly a call to a C function) *) @@ -290,19 +313,21 @@ Pgetglobal id -> Kgetglobal id | Psetglobal id -> Ksetglobal id | Pintcomp cmp -> Kintcomp cmp - | Pmakeblock(tag, mut) -> Kmakeblock(List.length args, tag) + | Pmakeblock(tag, _mut, _) -> Kmakeblock(List.length args, tag) | Pfield n -> Kgetfield n - | Psetfield(n, ptr) -> Ksetfield n + | Pfield_computed -> Kgetvectitem + | Psetfield(n, _ptr, _init) -> Ksetfield n + | Psetfield_computed(_ptr, _init) -> Ksetvectitem | Pfloatfield n -> Kgetfloatfield n - | Psetfloatfield n -> Ksetfloatfield n + | Psetfloatfield (n, _init) -> Ksetfloatfield n | Pduprecord _ -> Kccall("caml_obj_dup", 1) | Pccall p -> Kccall(p.prim_name, p.prim_arity) | Pnegint -> Knegint | Paddint -> Kaddint | Psubint -> Ksubint | Pmulint -> Kmulint - | Pdivint -> Kdivint - | Pmodint -> Kmodint + | Pdivint _ -> Kdivint + | Pmodint _ -> Kmodint | Pandint -> Kandint | Porint -> Korint | Pxorint -> Kxorint @@ -326,17 +351,19 @@ | Pfloatcomp Cle -> Kccall("caml_le_float", 2) | Pfloatcomp Cge -> Kccall("caml_ge_float", 2) | Pstringlength -> Kccall("caml_ml_string_length", 1) + | Pbyteslength -> Kccall("caml_ml_bytes_length", 1) | Pstringrefs -> Kccall("caml_string_get", 2) - | Pstringsets -> Kccall("caml_string_set", 3) - | Pstringrefu -> Kgetstringchar - | Pstringsetu -> Ksetstringchar + | Pbytesrefs -> Kccall("caml_bytes_get", 2) + | Pbytessets -> Kccall("caml_bytes_set", 3) + | Pstringrefu | Pbytesrefu -> Kgetstringchar + | Pbytessetu -> Ksetstringchar | Pstring_load_16(_) -> Kccall("caml_string_get16", 2) | Pstring_load_32(_) -> Kccall("caml_string_get32", 2) | Pstring_load_64(_) -> Kccall("caml_string_get64", 2) | Pstring_set_16(_) -> Kccall("caml_string_set16", 3) | Pstring_set_32(_) -> Kccall("caml_string_set32", 3) | Pstring_set_64(_) -> Kccall("caml_string_set64", 3) - | Parraylength kind -> Kvectlength + | Parraylength _ -> Kvectlength | Parrayrefs Pgenarray -> Kccall("caml_array_get", 2) | Parrayrefs Pfloatarray -> Kccall("caml_array_get_float", 2) | Parrayrefs _ -> Kccall("caml_array_get_addr", 2) @@ -353,9 +380,12 @@ let const_name = match c with | Big_endian -> "big_endian" | Word_size -> "word_size" + | Int_size -> "int_size" + | Max_wosize -> "max_wosize" | Ostype_unix -> "ostype_unix" | Ostype_win32 -> "ostype_win32" - | Ostype_cygwin -> "ostype_cygwin" in + | Ostype_cygwin -> "ostype_cygwin" + | Backend_type -> "backend_type" in Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1) | Pisint -> Kisint | Pisout -> Kisout @@ -372,20 +402,20 @@ | Paddbint bi -> comp_bint_primitive bi "add" args | Psubbint bi -> comp_bint_primitive bi "sub" args | Pmulbint bi -> comp_bint_primitive bi "mul" args - | Pdivbint bi -> comp_bint_primitive bi "div" args - | Pmodbint bi -> comp_bint_primitive bi "mod" args + | Pdivbint { size = bi } -> comp_bint_primitive bi "div" args + | Pmodbint { size = bi } -> comp_bint_primitive bi "mod" args | Pandbint bi -> comp_bint_primitive bi "and" args | Porbint bi -> comp_bint_primitive bi "or" args | Pxorbint bi -> comp_bint_primitive bi "xor" args | Plslbint bi -> comp_bint_primitive bi "shift_left" args | Plsrbint bi -> comp_bint_primitive bi "shift_right_unsigned" args | Pasrbint bi -> comp_bint_primitive bi "shift_right" args - | Pbintcomp(bi, Ceq) -> Kccall("caml_equal", 2) - | Pbintcomp(bi, Cneq) -> Kccall("caml_notequal", 2) - | Pbintcomp(bi, Clt) -> Kccall("caml_lessthan", 2) - | Pbintcomp(bi, Cgt) -> Kccall("caml_greaterthan", 2) - | Pbintcomp(bi, Cle) -> Kccall("caml_lessequal", 2) - | Pbintcomp(bi, Cge) -> Kccall("caml_greaterequal", 2) + | Pbintcomp(_, Ceq) -> Kccall("caml_equal", 2) + | Pbintcomp(_, Cneq) -> Kccall("caml_notequal", 2) + | Pbintcomp(_, Clt) -> Kccall("caml_lessthan", 2) + | Pbintcomp(_, Cgt) -> Kccall("caml_greaterthan", 2) + | Pbintcomp(_, Cle) -> Kccall("caml_lessequal", 2) + | Pbintcomp(_, Cge) -> Kccall("caml_greaterequal", 2) | Pbigarrayref(_, n, _, _) -> Kccall("caml_ba_get_" ^ string_of_int n, n + 1) | Pbigarrayset(_, n, _, _) -> Kccall("caml_ba_set_" ^ string_of_int n, n + 2) | Pbigarraydim(n) -> Kccall("caml_ba_dim_" ^ string_of_int n, 1) @@ -397,10 +427,15 @@ | Pbigstring_set_64(_) -> Kccall("caml_ba_uint8_set64", 3) | Pbswap16 -> Kccall("caml_bswap16", 1) | Pbbswap(bi) -> comp_bint_primitive bi "bswap" args + | Pint_as_pointer -> Kccall("caml_int_as_pointer", 1) | _ -> fatal_error "Bytegen.comp_primitive" let is_immed n = immed_min <= n && n <= immed_max +module Storer = + Switch.Store + (struct type t = lambda type key = lambda + let make_key = Lambda.make_key end) (* Compile an expression. The value of the expression is left in the accumulator. @@ -426,12 +461,11 @@ let ofs = Ident.find_same id env.ce_rec in Koffsetclosure(ofs) :: cont with Not_found -> - Format.eprintf "%a@." Ident.print id; fatal_error ("Bytegen.comp_expr: var " ^ Ident.unique_name id) end | Lconst cst -> Kconst cst :: cont - | Lapply(func, args, loc) -> + | Lapply{ap_func = func; ap_args = args} -> let nargs = List.length args in if is_tailcall cont then begin comp_args env args sz @@ -471,7 +505,7 @@ comp_args env args' (sz + 3) (getmethod :: Kapply nargs :: cont1) end - | Lfunction(kind, params, body) -> (* assume kind = Curried *) + | Lfunction{params; body} -> (* assume kind = Curried *) let lbl = new_label() in let fv = IdentSet.elements(free_variables exp) in let to_compile = @@ -480,21 +514,21 @@ Stack.push to_compile functions_to_compile; comp_args env (List.map (fun n -> Lvar n) fv) sz (Kclosure(lbl, List.length fv) :: cont) - | Llet(str, id, arg, body) -> + | Llet(_str, _k, id, arg, body) -> comp_expr env arg sz (Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1) (add_pop 1 cont)) | Lletrec(decl, body) -> let ndecl = List.length decl in - if List.for_all (function (_, Lfunction(_,_,_)) -> true | _ -> false) + if List.for_all (function (_, Lfunction _) -> true | _ -> false) decl then begin (* let rec of functions *) let fv = IdentSet.elements (free_variables (Lletrec(decl, lambda_unit))) in - let rec_idents = List.map (fun (id, lam) -> id) decl in + let rec_idents = List.map (fun (id, _lam) -> id) decl in let rec comp_fun pos = function [] -> [] - | (id, Lfunction(kind, params, body)) :: rem -> + | (_id, Lfunction{params; body}) :: rem -> let lbl = new_label() in let to_compile = { params = params; body = body; label = lbl; free_vars = fv; @@ -512,51 +546,65 @@ List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in let rec comp_init new_env sz = function | [] -> comp_nonrec new_env sz ndecl decl_size - | (id, exp, RHS_floatblock blocksize) :: rem -> + | (id, _exp, RHS_floatblock blocksize) :: rem -> Kconst(Const_base(Const_int blocksize)) :: Kccall("caml_alloc_dummy_float", 1) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem - | (id, exp, RHS_block blocksize) :: rem -> + | (id, _exp, RHS_block blocksize) :: rem -> Kconst(Const_base(Const_int blocksize)) :: Kccall("caml_alloc_dummy", 1) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem - | (id, exp, RHS_nonrec) :: rem -> + | (id, _exp, RHS_function (blocksize,arity)) :: rem -> + Kconst(Const_base(Const_int arity)) :: + Kpush :: + Kconst(Const_base(Const_int blocksize)) :: + Kccall("caml_alloc_dummy_function", 2) :: Kpush :: + comp_init (add_var id (sz+1) new_env) (sz+1) rem + | (id, _exp, RHS_nonrec) :: rem -> Kconst(Const_base(Const_int 0)) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem and comp_nonrec new_env sz i = function | [] -> comp_rec new_env sz ndecl decl_size - | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + | (_id, _exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) + :: rem -> comp_nonrec new_env sz (i-1) rem - | (id, exp, RHS_nonrec) :: rem -> + | (_id, exp, RHS_nonrec) :: rem -> comp_expr new_env exp sz (Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem) and comp_rec new_env sz i = function | [] -> comp_expr new_env body sz (add_pop ndecl cont) - | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + | (_id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) + :: rem -> comp_expr new_env exp sz (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) :: comp_rec new_env sz (i-1) rem) - | (id, exp, RHS_nonrec) :: rem -> + | (_id, _exp, RHS_nonrec) :: rem -> comp_rec new_env sz (i-1) rem in comp_init env sz decl_size end - | Lprim(Pidentity, [arg]) -> + | Lprim((Pidentity | Popaque | Pbytes_to_string | Pbytes_of_string), [arg], _) + -> comp_expr env arg sz cont - | Lprim(Pignore, [arg]) -> + | Lprim(Pignore, [arg], _) -> comp_expr env arg sz (add_const_unit cont) - | Lprim(Pdirapply loc, [func;arg]) - | Lprim(Prevapply loc, [arg;func]) -> - let exp = Lapply(func, [arg], loc) in + | Lprim(Pdirapply, [func;arg], loc) + | Lprim(Prevapply, [arg;func], loc) -> + let exp = Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=func; + ap_args=[arg]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} in comp_expr env exp sz cont - | Lprim(Pnot, [arg]) -> + | Lprim(Pnot, [arg], _) -> let newcont = match cont with Kbranchif lbl :: cont1 -> Kbranchifnot lbl :: cont1 | Kbranchifnot lbl :: cont1 -> Kbranchif lbl :: cont1 | _ -> Kboolnot :: cont in comp_expr env arg sz newcont - | Lprim(Psequand, [exp1; exp2]) -> + | Lprim(Psequand, [exp1; exp2], _) -> begin match cont with Kbranchifnot lbl :: _ -> comp_expr env exp1 sz (Kbranchifnot lbl :: @@ -570,7 +618,7 @@ comp_expr env exp1 sz (Kstrictbranchifnot lbl :: comp_expr env exp2 sz cont1) end - | Lprim(Psequor, [exp1; exp2]) -> + | Lprim(Psequor, [exp1; exp2], _) -> begin match cont with Kbranchif lbl :: _ -> comp_expr env exp1 sz (Kbranchif lbl :: @@ -584,21 +632,21 @@ comp_expr env exp1 sz (Kstrictbranchif lbl :: comp_expr env exp2 sz cont1) end - | Lprim(Praise, [arg]) -> - comp_expr env arg sz (Kraise :: discard_dead_code cont) - | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))]) + | Lprim(Praise k, [arg], _) -> + comp_expr env arg sz (Kraise k :: discard_dead_code cont) + | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))], _) when is_immed n -> comp_expr env arg sz (Koffsetint n :: cont) - | Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))]) + | Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))], _) when is_immed (-n) -> comp_expr env arg sz (Koffsetint (-n) :: cont) - | Lprim (Poffsetint n, [arg]) + | Lprim (Poffsetint n, [arg], _) when not (is_immed n) -> comp_expr env arg sz (Kpush:: Kconst (Const_base (Const_int n)):: Kaddint::cont) - | Lprim(Pmakearray kind, args) -> + | Lprim(Pmakearray (kind, _), args, _) -> begin match kind with Pintarray | Paddrarray -> comp_args env args sz (Kmakeblock(List.length args, 0) :: cont) @@ -611,14 +659,25 @@ (Kmakeblock(List.length args, 0) :: Kccall("caml_make_array", 1) :: cont) end + | Lprim (Pduparray (kind, mutability), + [Lprim (Pmakearray (kind',_),args,_)], loc) -> + assert (kind = kind'); + comp_expr env (Lprim (Pmakearray (kind, mutability), args, loc)) sz cont + | Lprim (Pduparray _, [arg], loc) -> + let prim_obj_dup = + Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true + in + comp_expr env (Lprim (Pccall prim_obj_dup, [arg], loc)) sz cont + | Lprim (Pduparray _, _, _) -> + Misc.fatal_error "Bytegen.comp_expr: Pduparray takes exactly one arg" (* Integer first for enabling futher optimization (cf. emitcode.ml) *) - | Lprim (Pintcomp c, [arg ; (Lconst _ as k)]) -> + | Lprim (Pintcomp c, [arg ; (Lconst _ as k)], _) -> let p = Pintcomp (commute_comparison c) and args = [k ; arg] in comp_args env args sz (comp_primitive p args :: cont) - | Lprim(p, args) -> + | Lprim(p, args, _) -> comp_args env args sz (comp_primitive p args :: cont) - | Lstaticcatch (body, (i, vars) , handler) -> + | Lstaticcatch (body, (i, vars) , handler) -> let nvars = List.length vars in let branch1, cont1 = make_branch cont in let r = @@ -628,8 +687,7 @@ (comp_expr (add_vars vars (sz+1) env) handler (sz+nvars) (add_pop nvars cont1)) in - sz_static_raises := - (i, (lbl_handler, sz+nvars)) :: !sz_static_raises ; + push_static_raise i lbl_handler (sz+nvars); push_dummies nvars (comp_expr env body (sz+nvars) (add_pop nvars (branch1 :: cont2))) @@ -640,30 +698,39 @@ (Kpush::comp_expr (add_var var (sz+1) env) handler (sz+1) (add_pop 1 cont1)) in - sz_static_raises := - (i, (lbl_handler, sz)) :: !sz_static_raises ; + push_static_raise i lbl_handler sz; comp_expr env body sz (branch1 :: cont2) end in sz_static_raises := List.tl !sz_static_raises ; r | Lstaticraise (i, args) -> let cont = discard_dead_code cont in - let label,size = find_raise_label i in + let label,size,tb = find_raise_label i in + let cont = branch_to label cont in + let rec loop sz tbb = + if tb == tbb then add_pop (sz-size) cont + else match tbb with + | [] -> assert false + | try_sz :: tbb -> add_pop (sz-try_sz-4) (Kpoptrap :: loop try_sz tbb) + in + let cont = loop sz !try_blocks in begin match args with | [arg] -> (* optim, argument passed in accumulator *) - comp_expr env arg sz - (add_pop (sz-size) (branch_to label cont)) - | _ -> - comp_exit_args env args sz size - (add_pop (sz-size) (branch_to label cont)) + comp_expr env arg sz cont + | _ -> comp_exit_args env args sz size cont end | Ltrywith(body, id, handler) -> let (branch1, cont1) = make_branch cont in let lbl_handler = new_label() in - Kpushtrap lbl_handler :: - comp_expr env body (sz+4) (Kpoptrap :: branch1 :: - Klabel lbl_handler :: Kpush :: - comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1)) + let body_cont = + Kpoptrap :: branch1 :: + Klabel lbl_handler :: Kpush :: + comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1) + in + try_blocks := sz :: !try_blocks; + let l = comp_expr env body (sz+4) body_cont in + try_blocks := List.tl !try_blocks; + Kpushtrap lbl_handler :: l | Lifthenelse(cond, ifso, ifnot) -> comp_binary_test env cond ifso ifnot sz cont | Lsequence(exp1, exp2) -> @@ -691,10 +758,11 @@ | Lswitch(arg, sw) -> let (branch, cont1) = make_branch cont in let c = ref (discard_dead_code cont1) in + (* Build indirection vectors *) - let store = mk_store Lambda.same in - let act_consts = Array.create sw.sw_numconsts 0 - and act_blocks = Array.create sw.sw_numblocks 0 in + let store = Storer.mk_store () in + let act_consts = Array.make sw.sw_numconsts 0 + and act_blocks = Array.make sw.sw_numblocks 0 in begin match sw.sw_failaction with (* default is index 0 *) | Some fail -> ignore (store.act_store fail) | None -> () @@ -703,10 +771,20 @@ (fun (n, act) -> act_consts.(n) <- store.act_store act) sw.sw_consts; List.iter (fun (n, act) -> act_blocks.(n) <- store.act_store act) sw.sw_blocks; - (* Compile and label actions *) let acts = store.act_get () in - let lbls = Array.create (Array.length acts) 0 in +(* + let a = store.act_get_shared () in + Array.iter + (function + | Switch.Shared (Lstaticraise _) -> () + | Switch.Shared act -> + Printlambda.lambda Format.str_formatter act ; + Printf.eprintf "SHARE BYTE:\n%s\n" (Format.flush_str_formatter ()) + | _ -> ()) + a ; +*) + let lbls = Array.make (Array.length acts) 0 in for i = Array.length acts-1 downto 0 do let lbl,c1 = label_code (comp_expr env acts.(i) sz (branch :: !c)) in lbls.(i) <- lbl ; @@ -714,15 +792,17 @@ done ; (* Build label vectors *) - let lbl_blocks = Array.create sw.sw_numblocks 0 in + let lbl_blocks = Array.make sw.sw_numblocks 0 in for i = sw.sw_numblocks - 1 downto 0 do lbl_blocks.(i) <- lbls.(act_blocks.(i)) done; - let lbl_consts = Array.create sw.sw_numconsts 0 in + let lbl_consts = Array.make sw.sw_numconsts 0 in for i = sw.sw_numconsts - 1 downto 0 do lbl_consts.(i) <- lbls.(act_consts.(i)) done; comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c) + | Lstringswitch (arg,sw,d,loc) -> + comp_expr env (Matching.expand_stringswitch loc arg sw d) sz cont | Lassign(id, expr) -> begin try let pos = Ident.find_same id env.ce_stack in @@ -764,12 +844,16 @@ let c = comp_expr env lam sz cont in let ev = event Event_pseudo Event_function in add_event ev c + | Lev_pseudo -> + let c = comp_expr env lam sz cont in + let ev = event Event_pseudo Event_other in + add_event ev c | Lev_after _ when is_tailcall cont -> (* don't destroy tail call opt *) comp_expr env lam sz cont | Lev_after ty -> let info = match lam with - Lapply(_, args, _) -> Event_return (List.length args) + Lapply{ap_args = args} -> Event_return (List.length args) | Lsend(_, _, _, args, _) -> Event_return (List.length args + 1) | _ -> Event_other in @@ -832,9 +916,9 @@ let comp_block env exp sz cont = max_stack_used := 0; let code = comp_expr env exp sz cont in - (* +1 because comp_expr may have pushed one more word *) - if !max_stack_used + 1 > Config.stack_threshold then - Kconst(Const_base(Const_int(!max_stack_used + 1))) :: + let used_safe = !max_stack_used + Config.stack_safety_margin in + if used_safe > Config.stack_threshold then + Kconst(Const_base(Const_int used_safe)) :: Kccall("caml_ensure_stack_capacity", 1) :: code else @@ -890,3 +974,10 @@ let init_code = comp_block empty_env expr 1 [Kreturn 1] in let fun_code = comp_remainder [] in (init_code, fun_code) + +let reset () = + label_counter := 0; + sz_static_raises := []; + compunit_name := ""; + Stack.clear functions_to_compile; + max_stack_used := 0 diff -Nru ocaml-4.01.0/bytecomp/bytegen.mli ocaml-4.05.0/bytecomp/bytegen.mli --- ocaml-4.01.0/bytecomp/bytegen.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/bytegen.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Generation of bytecode from lambda terms *) @@ -17,3 +20,4 @@ val compile_implementation: string -> lambda -> instruction list val compile_phrase: lambda -> instruction list * instruction list +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/bytelibrarian.ml ocaml-4.05.0/bytecomp/bytelibrarian.ml --- ocaml-4.01.0/bytecomp/bytelibrarian.ml 2013-06-05 16:34:40.000000000 +0000 +++ ocaml-4.05.0/bytecomp/bytelibrarian.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Build libraries of .cmo files *) @@ -26,7 +29,7 @@ let copy_compunit ic oc compunit = seek_in ic compunit.cu_pos; compunit.cu_pos <- pos_out oc; - compunit.cu_force_link <- !Clflags.link_everything; + compunit.cu_force_link <- compunit.cu_force_link || !Clflags.link_everything; copy_file_chunk ic oc compunit.cu_codesize; if compunit.cu_debug > 0 then begin seek_in ic compunit.cu_debug; @@ -60,7 +63,7 @@ raise(Error(File_not_found name)) in let ic = open_in_bin file_name in try - let buffer = input_bytes ic (String.length cmo_magic_number) in + let buffer = really_input_string ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin let compunit_pos = input_binary_int ic in seek_in ic compunit_pos; @@ -117,3 +120,15 @@ | Not_an_object_file name -> fprintf ppf "The file %a is not a bytecode object file" Location.print_filename name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + lib_ccobjs := []; + lib_ccopts := []; + lib_dllibs := [] diff -Nru ocaml-4.01.0/bytecomp/bytelibrarian.mli ocaml-4.05.0/bytecomp/bytelibrarian.mli --- ocaml-4.01.0/bytecomp/bytelibrarian.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/bytelibrarian.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Build libraries of .cmo files *) @@ -30,3 +33,5 @@ open Format val report_error: formatter -> error -> unit + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/bytelink.ml ocaml-4.05.0/bytecomp/bytelink.ml --- ocaml-4.01.0/bytecomp/bytelink.ml 2013-07-23 14:48:47.000000000 +0000 +++ ocaml-4.05.0/bytecomp/bytelink.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Link a set of .cmo files and produce a bytecode executable. *) @@ -26,6 +29,7 @@ | File_exists of string | Cannot_open_dll of string | Not_compatible_32 + | Required_module_unavailable of string exception Error of error @@ -42,7 +46,7 @@ let lib_ccopts = ref [] let lib_dllibs = ref [] -let add_ccobjs l = +let add_ccobjs origin l = if not !Clflags.no_auto_link then begin if String.length !Clflags.use_runtime = 0 @@ -50,7 +54,10 @@ then begin if l.lib_custom then Clflags.custom_runtime := true; lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; - lib_ccopts := l.lib_ccopts @ !lib_ccopts; + let replace_origin = + Misc.replace_substring ~before:"$CAMLORIGIN" ~after:origin + in + lib_ccopts := List.map replace_origin l.lib_ccopts @ !lib_ccopts; end; lib_dllibs := l.lib_dllibs @ !lib_dllibs end @@ -79,27 +86,30 @@ (* First pass: determine which units are needed *) -module IdentSet = - Set.Make(struct - type t = Ident.t - let compare = compare - end) +module IdentSet = Lambda.IdentSet let missing_globals = ref IdentSet.empty -let is_required (rel, pos) = +let is_required (rel, _pos) = match rel with Reloc_setglobal id -> IdentSet.mem id !missing_globals | _ -> false -let add_required (rel, pos) = - match rel with - Reloc_getglobal id -> - missing_globals := IdentSet.add id !missing_globals - | _ -> () +let add_required compunit = + let add_required_by_reloc (rel, _pos) = + match rel with + Reloc_getglobal id -> + missing_globals := IdentSet.add id !missing_globals + | _ -> () + in + let add_required_for_effects id = + missing_globals := IdentSet.add id !missing_globals + in + List.iter add_required_by_reloc compunit.cu_reloc; + List.iter add_required_for_effects compunit.cu_required_globals -let remove_required (rel, pos) = +let remove_required (rel, _pos) = match rel with Reloc_setglobal id -> missing_globals := IdentSet.remove id !missing_globals @@ -113,7 +123,7 @@ raise(Error(File_not_found obj_name)) in let ic = open_in_bin file_name in try - let buffer = input_bytes ic (String.length cmo_magic_number) in + let buffer = really_input_string ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin (* This is a .cmo file. It must be linked in any case. Read the relocation information to see which modules it @@ -122,7 +132,8 @@ seek_in ic compunit_pos; let compunit = (input_value ic : compilation_unit) in close_in ic; - List.iter add_required compunit.cu_reloc; + add_required compunit; + List.iter remove_required compunit.cu_reloc; Link_object(file_name, compunit) :: tolink end else if buffer = cma_magic_number then begin @@ -132,7 +143,7 @@ seek_in ic pos_toc; let toc = (input_value ic : library) in close_in ic; - add_ccobjs toc; + add_ccobjs (Filename.dirname file_name) toc; let required = List.fold_right (fun compunit reqd -> @@ -140,8 +151,8 @@ || !Clflags.link_everything || List.exists is_required compunit.cu_reloc then begin + add_required compunit; List.iter remove_required compunit.cu_reloc; - List.iter add_required compunit.cu_reloc; compunit :: reqd end else reqd) @@ -158,15 +169,20 @@ (* Consistency check between interfaces *) let crc_interfaces = Consistbl.create () +let interfaces = ref ([] : string list) let implementations_defined = ref ([] : (string * string) list) let check_consistency ppf file_name cu = begin try List.iter - (fun (name, crc) -> - if name = cu.cu_name - then Consistbl.set crc_interfaces name crc file_name - else Consistbl.check crc_interfaces name crc file_name) + (fun (name, crco) -> + interfaces := name :: !interfaces; + match crco with + None -> () + | Some crc -> + if name = cu.cu_name + then Consistbl.set crc_interfaces name crc file_name + else Consistbl.check crc_interfaces name crc file_name) cu.cu_imports with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_import(name, user, auth))) @@ -183,11 +199,15 @@ (cu.cu_name, file_name) :: !implementations_defined let extract_crc_interfaces () = - Consistbl.extract crc_interfaces + Consistbl.extract !interfaces crc_interfaces + +let clear_crc_interfaces () = + Consistbl.clear crc_interfaces; + interfaces := [] (* Record compilation events *) -let debug_info = ref ([] : (int * LongString.t) list) +let debug_info = ref ([] : (int * Instruct.debug_event list * string list) list) (* Link in a compilation unit *) @@ -198,8 +218,14 @@ Symtable.ls_patch_object code_block compunit.cu_reloc; if !Clflags.debug && compunit.cu_debug > 0 then begin seek_in inchan compunit.cu_debug; - let buffer = LongString.input_bytes inchan compunit.cu_debugsize in - debug_info := (currpos_fun(), buffer) :: !debug_info + let debug_event_list : Instruct.debug_event list = input_value inchan in + let debug_dirs : string list = input_value inchan in + let file_path = Filename.dirname (Location.absolute_path file_name) in + let debug_dirs = + if List.mem file_path debug_dirs + then debug_dirs + else file_path :: debug_dirs in + debug_info := (currpos_fun(), debug_event_list, debug_dirs) :: !debug_info end; Array.iter output_fun code_block; if !Clflags.link_everything then @@ -254,9 +280,10 @@ let output_debug_info oc = output_binary_int oc (List.length !debug_info); List.iter - (fun (ofs, evl) -> + (fun (ofs, evl, debug_dirs) -> output_binary_int oc ofs; - Array.iter (output_string oc) evl) + output_value oc evl; + output_value oc debug_dirs) !debug_info; debug_info := [] @@ -307,19 +334,20 @@ (* The bytecode *) let start_code = pos_out outchan in Symtable.init(); - Consistbl.clear crc_interfaces; + clear_crc_interfaces (); let sharedobjs = List.map Dll.extract_dll_name !Clflags.dllibs in - if standalone then begin + let check_dlls = standalone && Config.target = Config.host in + if check_dlls then begin (* Initialize the DLL machinery *) Dll.init_compile !Clflags.no_std_include; Dll.add_path !load_path; try Dll.open_dlls Dll.For_checking sharedobjs with Failure reason -> raise(Error(Cannot_open_dll reason)) end; - let output_fun = output_string outchan + let output_fun = output_bytes outchan and currpos_fun () = pos_out outchan - start_code in List.iter (link_file ppf output_fun currpos_fun) tolink; - if standalone then Dll.close_all_dlls(); + if check_dlls then Dll.close_all_dlls(); (* The final STOP instruction *) output_byte outchan Opcodes.opSTOP; output_byte outchan 0; output_byte outchan 0; output_byte outchan 0; @@ -370,12 +398,12 @@ let output_code_string outchan code = let pos = ref 0 in - let len = String.length code in + let len = Bytes.length code in while !pos < len do - let c1 = Char.code(code.[!pos]) in - let c2 = Char.code(code.[!pos + 1]) in - let c3 = Char.code(code.[!pos + 2]) in - let c4 = Char.code(code.[!pos + 3]) in + let c1 = Char.code(Bytes.get code !pos) in + let c2 = Char.code(Bytes.get code (!pos + 1)) in + let c3 = Char.code(Bytes.get code (!pos + 2)) in + let c4 = Char.code(Bytes.get code (!pos + 3)) in pos := !pos + 4; Printf.fprintf outchan "0x%02x%02x%02x%02x, " c4 c3 c2 c1; incr output_code_string_counter; @@ -439,11 +467,11 @@ \n char **argv);\n"; output_string outchan "static int caml_code[] = {\n"; Symtable.init(); - Consistbl.clear crc_interfaces; + clear_crc_interfaces (); let currpos = ref 0 in let output_fun code = output_code_string outchan code; - currpos := !currpos + String.length code + currpos := !currpos + Bytes.length code and currpos_fun () = !currpos in List.iter (link_file ppf output_fun currpos_fun) tolink; (* The final STOP instruction *) @@ -473,6 +501,13 @@ \n caml_sections, sizeof(caml_sections),\ \n argv);\ \n}\ +\nvalue caml_startup_exn(char ** argv)\ +\n{\ +\n return caml_startup_code_exn(caml_code, sizeof(caml_code),\ +\n caml_data, sizeof(caml_data),\ +\n caml_sections, sizeof(caml_sections),\ +\n argv);\ +\n}\ \n#ifdef __cplusplus\ \n}\ \n#endif\n"; @@ -519,6 +554,14 @@ else if !Clflags.output_c_object then "stdlib.cma" :: objfiles else "stdlib.cma" :: (objfiles @ ["std_exit.cmo"]) in let tolink = List.fold_right scan_file objfiles [] in + let missing_modules = + IdentSet.filter (fun id -> not (Ident.is_predef_exn id)) !missing_globals + in + begin + match IdentSet.elements missing_modules with + | [] -> () + | id :: _ -> raise (Error (Required_module_unavailable (Ident.name id))) + end; Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; (* put user's libs last *) Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; (* put user's opts first *) @@ -562,22 +605,36 @@ raise x end else begin let basename = Filename.chop_extension output_name in - let c_file = basename ^ ".c" - and obj_file = basename ^ Config.ext_obj in + let c_file = + if !Clflags.output_complete_object + then Filename.temp_file "camlobj" ".c" + else basename ^ ".c" + and obj_file = + if !Clflags.output_complete_object + then Filename.temp_file "camlobj" Config.ext_obj + else basename ^ Config.ext_obj + in if Sys.file_exists c_file then raise(Error(File_exists c_file)); let temps = ref [] in try link_bytecode_as_c ppf tolink c_file; if not (Filename.check_suffix output_name ".c") then begin temps := c_file :: !temps; - if Ccomp.compile_file c_file <> 0 then raise(Error Custom_runtime); - if not (Filename.check_suffix output_name Config.ext_obj) then begin + if Ccomp.compile_file c_file <> 0 then + raise(Error Custom_runtime); + if not (Filename.check_suffix output_name Config.ext_obj) || + !Clflags.output_complete_object then begin temps := obj_file :: !temps; + let mode, c_libs = + if Filename.check_suffix output_name Config.ext_obj + then Ccomp.Partial, "" + else Ccomp.MainDll, Config.bytecomp_c_libraries + in if not ( let runtime_lib = "-lcamlrun" ^ !Clflags.runtime_variant in - Ccomp.call_linker Ccomp.MainDll output_name + Ccomp.call_linker mode output_name ([obj_file] @ List.rev !Clflags.ccobjs @ [runtime_lib]) - Config.bytecomp_c_libraries + c_libs ) then raise (Error Custom_runtime); end end; @@ -621,3 +678,22 @@ | Not_compatible_32 -> fprintf ppf "Generated bytecode executable cannot be run\ \ on a 32-bit platform" + | Required_module_unavailable s -> + fprintf ppf "Required module `%s' is unavailable" s + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + lib_ccobjs := []; + lib_ccopts := []; + lib_dllibs := []; + missing_globals := IdentSet.empty; + Consistbl.clear crc_interfaces; + implementations_defined := []; + debug_info := []; + output_code_string_counter := 0 diff -Nru ocaml-4.01.0/bytecomp/bytelink.mli ocaml-4.05.0/bytecomp/bytelink.mli --- ocaml-4.01.0/bytecomp/bytelink.mli 2013-04-18 11:58:59.000000000 +0000 +++ ocaml-4.05.0/bytecomp/bytelink.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,23 +1,27 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Link .cmo files and produce a bytecode executable. *) val link : Format.formatter -> string list -> string -> unit +val reset : unit -> unit val check_consistency: Format.formatter -> string -> Cmo_format.compilation_unit -> unit -val extract_crc_interfaces: unit -> (string * Digest.t) list +val extract_crc_interfaces: unit -> (string * Digest.t option) list type error = File_not_found of string @@ -29,6 +33,7 @@ | File_exists of string | Cannot_open_dll of string | Not_compatible_32 + | Required_module_unavailable of string exception Error of error diff -Nru ocaml-4.01.0/bytecomp/bytepackager.ml ocaml-4.05.0/bytecomp/bytepackager.ml --- ocaml-4.01.0/bytecomp/bytepackager.ml 2013-07-23 14:48:47.000000000 +0000 +++ ocaml-4.05.0/bytecomp/bytepackager.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* "Package" a set of .cmo files into one .cmo file having the original compilation units as sub-modules. *) @@ -17,6 +20,8 @@ open Instruct open Cmo_format +module StringSet = Set.Make(String) + type error = Forward_reference of string * Ident.t | Multiple_definition of string * Ident.t @@ -30,6 +35,7 @@ let relocs = ref ([] : (reloc_info * int) list) let events = ref ([] : debug_event list) +let debug_dirs = ref StringSet.empty let primitives = ref ([] : string list) let force_link = ref false @@ -93,26 +99,30 @@ let read_member_info file = ( let name = - String.capitalize(Filename.basename(chop_extensions file)) in + String.capitalize_ascii(Filename.basename(chop_extensions file)) in let kind = - if Filename.check_suffix file ".cmo" then begin - let ic = open_in_bin file in - try - let buffer = input_bytes ic (String.length Config.cmo_magic_number) in - if buffer <> Config.cmo_magic_number then - raise(Error(Not_an_object_file file)); - let compunit_pos = input_binary_int ic in - seek_in ic compunit_pos; - let compunit = (input_value ic : compilation_unit) in - if compunit.cu_name <> name - then raise(Error(Illegal_renaming(name, file, compunit.cu_name))); - close_in ic; - PM_impl compunit - with x -> - close_in ic; - raise x - end else - PM_intf in + (* PR#7479: make sure it is either a .cmi or a .cmo *) + if Filename.check_suffix file ".cmi" then + PM_intf + else begin + let ic = open_in_bin file in + try + let buffer = + really_input_string ic (String.length Config.cmo_magic_number) + in + if buffer <> Config.cmo_magic_number then + raise(Error(Not_an_object_file file)); + let compunit_pos = input_binary_int ic in + seek_in ic compunit_pos; + let compunit = (input_value ic : compilation_unit) in + if compunit.cu_name <> name + then raise(Error(Illegal_renaming(name, file, compunit.cu_name))); + close_in ic; + PM_impl compunit + with x -> + close_in ic; + raise x + end in { pm_file = file; pm_name = name; pm_kind = kind } ) @@ -137,6 +147,10 @@ if !Clflags.debug && compunit.cu_debug > 0 then begin seek_in ic compunit.cu_debug; List.iter (relocate_debug ofs prefix subst) (input_value ic); + debug_dirs := List.fold_left + (fun s e -> StringSet.add e s) + !debug_dirs + (input_value ic); end; close_in ic; compunit.cu_codesize @@ -174,7 +188,7 @@ let build_global_target oc target_name members mapping pos coercion = let components = List.map2 - (fun m (id1, id2) -> + (fun m (_id1, id2) -> match m.pm_kind with | PM_intf -> None | PM_impl _ -> Some id2) @@ -182,6 +196,8 @@ let lam = Translmod.transl_package components (Ident.create_persistent target_name) coercion in + if !Clflags.dump_lambda then + Format.printf "%a@." Printlambda.lambda lam; let instrs = Bytegen.compile_implementation target_name lam in let rel = @@ -193,6 +209,24 @@ let package_object_files ppf files targetfile targetname coercion = let members = map_left_right read_member_info files in + let required_globals = + List.fold_right (fun compunit required_globals -> match compunit with + | { pm_kind = PM_intf } -> + required_globals + | { pm_kind = PM_impl { cu_required_globals; cu_reloc } } -> + let remove_required (rel, _pos) required_globals = + match rel with + Reloc_setglobal id -> + Ident.Set.remove id required_globals + | _ -> + required_globals + in + let required_globals = + List.fold_right remove_required cu_reloc required_globals + in + List.fold_right Ident.Set.add cu_required_globals required_globals) + members Ident.Set.empty + in let unit_names = List.map (fun m -> m.pm_name) members in let mapping = @@ -211,20 +245,24 @@ targetname Subst.identity members in build_global_target oc targetname members mapping ofs coercion; let pos_debug = pos_out oc in - if !Clflags.debug && !events <> [] then + if !Clflags.debug && !events <> [] then begin output_value oc (List.rev !events); + output_value oc (StringSet.elements !debug_dirs); + end; let pos_final = pos_out oc in let imports = List.filter - (fun (name, crc) -> not (List.mem name unit_names)) + (fun (name, _crc) -> not (List.mem name unit_names)) (Bytelink.extract_crc_interfaces()) in let compunit = { cu_name = targetname; cu_pos = pos_code; cu_codesize = pos_debug - pos_code; cu_reloc = List.rev !relocs; - cu_imports = (targetname, Env.crc_of_unit targetname) :: imports; + cu_imports = + (targetname, Some (Env.crc_of_unit targetname)) :: imports; cu_primitives = !primitives; + cu_required_globals = Ident.Set.elements required_globals; cu_force_link = !force_link; cu_debug = if pos_final > pos_debug then pos_debug else 0; cu_debugsize = pos_final - pos_debug } in @@ -238,7 +276,7 @@ (* The entry point *) -let package_files ppf files targetfile = +let package_files ppf initial_env files targetfile = let files = List.map (fun f -> @@ -247,13 +285,13 @@ files in let prefix = chop_extensions targetfile in let targetcmi = prefix ^ ".cmi" in - let targetname = String.capitalize(Filename.basename prefix) in + let targetname = String.capitalize_ascii(Filename.basename prefix) in try - let coercion = Typemod.package_units files targetcmi targetname in - let ret = package_object_files ppf files targetfile targetname coercion in - ret - with x -> - remove_file targetfile; raise x + let coercion = + Typemod.package_units initial_env files targetcmi targetname in + package_object_files ppf files targetfile targetname coercion + with x -> + remove_file targetfile; raise x (* Error report *) @@ -276,3 +314,16 @@ Location.print_filename file name id | File_not_found file -> fprintf ppf "File %s not found" file + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + relocs := []; + events := []; + primitives := []; + force_link := false diff -Nru ocaml-4.01.0/bytecomp/bytepackager.mli ocaml-4.05.0/bytecomp/bytepackager.mli --- ocaml-4.01.0/bytecomp/bytepackager.mli 2013-04-29 14:57:38.000000000 +0000 +++ ocaml-4.05.0/bytecomp/bytepackager.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,19 +1,22 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* "Package" a set of .cmo files into one .cmo file having the original compilation units as sub-modules. *) -val package_files: Format.formatter -> string list -> string -> unit +val package_files: Format.formatter -> Env.t -> string list -> string -> unit type error = Forward_reference of string * Ident.t @@ -25,3 +28,4 @@ exception Error of error val report_error: Format.formatter -> error -> unit +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/bytesections.ml ocaml-4.05.0/bytecomp/bytesections.ml --- ocaml-4.01.0/bytecomp/bytesections.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/bytesections.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Handling of sections in bytecode executable files *) @@ -46,12 +49,14 @@ let pos_trailer = in_channel_length ic - 16 in seek_in ic pos_trailer; let num_sections = input_binary_int ic in - let header = Misc.input_bytes ic (String.length Config.exec_magic_number) in + let header = + really_input_string ic (String.length Config.exec_magic_number) + in if header <> Config.exec_magic_number then raise Bad_magic_number; seek_in ic (pos_trailer - 8 * num_sections); section_table := []; for _i = 1 to num_sections do - let name = Misc.input_bytes ic 4 in + let name = really_input_string ic 4 in let len = input_binary_int ic in section_table := (name, len) :: !section_table done @@ -77,7 +82,7 @@ (* Return the contents of a section, as a string *) let read_section_string ic name = - Misc.input_bytes ic (seek_section ic name) + really_input_string ic (seek_section ic name) (* Return the contents of a section, as marshalled data *) @@ -89,4 +94,8 @@ let pos_first_section ic = in_channel_length ic - 16 - 8 * List.length !section_table - - List.fold_left (fun total (name, len) -> total + len) 0 !section_table + List.fold_left (fun total (_name, len) -> total + len) 0 !section_table + +let reset () = + section_table := []; + section_beginning := 0 diff -Nru ocaml-4.01.0/bytecomp/bytesections.mli ocaml-4.05.0/bytecomp/bytesections.mli --- ocaml-4.01.0/bytecomp/bytesections.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/bytesections.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Handling of sections in bytecode executable files *) @@ -50,3 +53,5 @@ val pos_first_section: in_channel -> int (* Return the position of the beginning of the first section *) + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/cmo_format.mli ocaml-4.05.0/bytecomp/cmo_format.mli --- ocaml-4.01.0/bytecomp/cmo_format.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/cmo_format.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Symbol table information for .cmo and .cma files *) @@ -27,7 +30,11 @@ mutable cu_pos: int; (* Absolute position in file *) cu_codesize: int; (* Size of code block *) cu_reloc: (reloc_info * int) list; (* Relocation information *) - cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *) + cu_imports: + (string * Digest.t option) list; (* Names and CRC of intfs imported *) + cu_required_globals: Ident.t list; (* Compilation units whose initialization + side effects must occur before this + one. *) cu_primitives: string list; (* Primitives declared inside *) mutable cu_force_link: bool; (* Must be linked even if unref'ed *) mutable cu_debug: int; (* Position of debugging info, or 0 *) @@ -56,3 +63,9 @@ ... object code for last library member library descriptor *) + +(* Tables for numbering objects *) + +type 'a numtable = + { num_cnt: int; (* The next number *) + num_tbl: ('a, int) Tbl.t } (* The table of already numbered objects *) diff -Nru ocaml-4.01.0/bytecomp/dll.ml ocaml-4.05.0/bytecomp/dll.ml --- ocaml-4.01.0/bytecomp/dll.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/dll.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Handling of dynamically-linked libraries *) @@ -173,3 +176,9 @@ opened_dlls := Array.to_list (get_current_dlls()); names_of_opened_dlls := []; linking_in_core := true + +let reset () = + search_path := []; + opened_dlls :=[]; + names_of_opened_dlls := []; + linking_in_core := false diff -Nru ocaml-4.01.0/bytecomp/dll.mli ocaml-4.05.0/bytecomp/dll.mli --- ocaml-4.01.0/bytecomp/dll.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/dll.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Handling of dynamically-linked libraries *) @@ -59,3 +62,5 @@ contents of ld.conf file). Take note of the DLLs that were opened when starting the running program. *) val init_toplevel: string -> unit + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/emitcode.ml ocaml-4.05.0/bytecomp/emitcode.ml --- ocaml-4.01.0/bytecomp/emitcode.ml 2013-04-17 09:07:00.000000000 +0000 +++ ocaml-4.05.0/bytecomp/emitcode.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Generation of bytecode + relocation information *) @@ -20,6 +23,8 @@ open Opcodes open Cmo_format +module StringSet = Set.Make(String) + (* Buffering of bytecode *) let out_buffer = ref(LongString.create 1024) @@ -80,7 +85,7 @@ let extend_label_table needed = let new_size = ref(Array.length !label_table) in while needed >= !new_size do new_size := 2 * !new_size done; - let new_table = Array.create !new_size (Label_undefined []) in + let new_table = Array.make !new_size (Label_undefined []) in Array.blit !label_table 0 new_table 0 (Array.length !label_table); label_table := new_table @@ -135,8 +140,14 @@ (* Debugging events *) let events = ref ([] : debug_event list) +let debug_dirs = ref StringSet.empty let record_event ev = + let path = ev.ev_loc.Location.loc_start.Lexing.pos_fname in + let abspath = Location.absolute_path path in + debug_dirs := StringSet.add (Filename.dirname abspath) !debug_dirs; + if Filename.is_relative path then + debug_dirs := StringSet.add (Sys.getcwd ()) !debug_dirs; ev.ev_pos <- !out_position; events := ev :: !events @@ -144,8 +155,9 @@ let init () = out_position := 0; - label_table := Array.create 16 (Label_undefined []); + label_table := Array.make 16 (Label_undefined []); reloc_info := []; + debug_dirs := StringSet.empty; events := [] (* Emission of one instruction *) @@ -243,7 +255,9 @@ | Kboolnot -> out opBOOLNOT | Kpushtrap lbl -> out opPUSHTRAP; out_label lbl | Kpoptrap -> out opPOPTRAP - | Kraise -> out opRAISE + | Kraise Raise_regular -> out opRAISE + | Kraise Raise_reraise -> out opRERAISE + | Kraise Raise_notrace -> out opRAISE_NOTRACE | Kcheck_signals -> out opCHECK_SIGNALS | Kccall(name, n) -> if n <= 5 @@ -351,7 +365,7 @@ (* Emission to a file *) -let to_file outchan unit_name code = +let to_file outchan unit_name objfile ~required_globals code = init(); output_string outchan cmo_magic_number; let pos_depl = pos_out outchan in @@ -361,8 +375,12 @@ LongString.output outchan !out_buffer 0 !out_position; let (pos_debug, size_debug) = if !Clflags.debug then begin + debug_dirs := StringSet.add + (Filename.dirname (Location.absolute_path objfile)) + !debug_dirs; let p = pos_out outchan in output_value outchan !events; + output_value outchan (StringSet.elements !debug_dirs); (p, pos_out outchan - p) end else (0, 0) in @@ -371,10 +389,11 @@ cu_pos = pos_code; cu_codesize = !out_position; cu_reloc = List.rev !reloc_info; - cu_imports = Env.imported_units(); + cu_imports = Env.imports(); cu_primitives = List.map Primitive.byte_name !Translmod.primitive_declarations; - cu_force_link = false; + cu_required_globals = Ident.Set.elements required_globals; + cu_force_link = !Clflags.link_everything; cu_debug = pos_debug; cu_debugsize = size_debug } in init(); (* Free out_buffer and reloc_info *) @@ -392,11 +411,12 @@ emit init_code; emit fun_code; let code = Meta.static_alloc !out_position in - LongString.unsafe_blit_to_string !out_buffer 0 code 0 !out_position; + LongString.unsafe_blit_to_bytes !out_buffer 0 code 0 !out_position; let reloc = List.rev !reloc_info and code_size = !out_position in + let events = !events in init(); - (code, code_size, reloc) + (code, code_size, reloc, events) (* Emission to a file for a packed library *) @@ -407,3 +427,9 @@ let reloc = !reloc_info in init(); reloc + +let reset () = + out_buffer := LongString.create 1024; + out_position := 0; + label_table := [| |]; + reloc_info := [] diff -Nru ocaml-4.01.0/bytecomp/emitcode.mli ocaml-4.05.0/bytecomp/emitcode.mli --- ocaml-4.01.0/bytecomp/emitcode.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/emitcode.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,34 +1,42 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Generation of bytecode for .cmo files *) open Cmo_format open Instruct -val to_file: out_channel -> string -> instruction list -> unit +val to_file: out_channel -> string -> string -> + required_globals:Ident.Set.t -> instruction list -> unit (* Arguments: channel on output file name of compilation unit implemented + path of cmo file being written + required_globals: list of compilation units that must be + evaluated before this one list of instructions to emit *) val to_memory: instruction list -> instruction list -> - string * int * (reloc_info * int) list + bytes * int * (reloc_info * int) list * debug_event list (* Arguments: initialization code (terminated by STOP) function code Results: block of relocatable bytecode size of this block - relocation information *) + relocation information + debug events *) val to_packed_file: out_channel -> instruction list -> (reloc_info * int) list (* Arguments: @@ -36,3 +44,5 @@ list of instructions to emit Result: relocation information (reversed) *) + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/.ignore ocaml-4.05.0/bytecomp/.ignore --- ocaml-4.01.0/bytecomp/.ignore 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/bytecomp/.ignore 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -runtimedef.ml -opcodes.ml diff -Nru ocaml-4.01.0/bytecomp/instruct.ml ocaml-4.05.0/bytecomp/instruct.ml --- ocaml-4.01.0/bytecomp/instruct.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/instruct.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Lambda @@ -85,7 +88,7 @@ | Kboolnot | Kpushtrap of label | Kpoptrap - | Kraise + | Kraise of raise_kind | Kcheck_signals | Kccall of string * int | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint diff -Nru ocaml-4.01.0/bytecomp/instruct.mli ocaml-4.05.0/bytecomp/instruct.mli --- ocaml-4.01.0/bytecomp/instruct.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/instruct.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* The type of the instructions of the abstract machine *) @@ -105,7 +108,7 @@ | Kboolnot | Kpushtrap of label | Kpoptrap - | Kraise + | Kraise of raise_kind | Kcheck_signals | Kccall of string * int | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint diff -Nru ocaml-4.01.0/bytecomp/lambda.ml ocaml-4.05.0/bytecomp/lambda.ml --- ocaml-4.01.0/bytecomp/lambda.ml 2012-11-29 09:55:00.000000000 +0000 +++ ocaml-4.05.0/bytecomp/lambda.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Misc open Path @@ -17,35 +20,64 @@ type compile_time_constant = | Big_endian | Word_size + | Int_size + | Max_wosize | Ostype_unix | Ostype_win32 | Ostype_cygwin + | Backend_type + +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + +type immediate_or_pointer = + | Immediate + | Pointer + +type initialization_or_assignment = + | Assignment + | Heap_initialization + | Root_initialization + +type is_safe = + | Safe + | Unsafe type primitive = - Pidentity + | Pidentity + | Pbytes_to_string + | Pbytes_of_string | Pignore - | Prevapply of Location.t - | Pdirapply of Location.t + | Prevapply + | Pdirapply + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t (* Operations on heap blocks *) - | Pmakeblock of int * mutable_flag + | Pmakeblock of int * mutable_flag * block_shape | Pfield of int - | Psetfield of int * bool + | Pfield_computed + | Psetfield of int * immediate_or_pointer * initialization_or_assignment + | Psetfield_computed of immediate_or_pointer * initialization_or_assignment | Pfloatfield of int - | Psetfloatfield of int + | Psetfloatfield of int * initialization_or_assignment | Pduprecord of Types.record_representation * int (* Force lazy values *) | Plazyforce (* External call *) | Pccall of Primitive.description (* Exceptions *) - | Praise + | Praise of raise_kind (* Boolean operations *) | Psequand | Psequor | Pnot (* Integer operations *) - | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint + | Pnegint | Paddint | Psubint | Pmulint + | Pdivint of is_safe | Pmodint of is_safe | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp of comparison @@ -57,9 +89,11 @@ | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat | Pfloatcomp of comparison (* String operations *) - | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets + | Pstringlength | Pstringrefu | Pstringrefs + | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets (* Array operations *) - | Pmakearray of array_kind + | Pmakearray of array_kind * mutable_flag + | Pduparray of array_kind * mutable_flag | Parraylength of array_kind | Parrayrefu of array_kind | Parraysetu of array_kind @@ -79,8 +113,8 @@ | Paddbint of boxed_integer | Psubbint of boxed_integer | Pmulbint of boxed_integer - | Pdivbint of boxed_integer - | Pmodbint of boxed_integer + | Pdivbint of { size : boxed_integer; is_safe : is_safe } + | Pmodbint of { size : boxed_integer; is_safe : is_safe } | Pandbint of boxed_integer | Porbint of boxed_integer | Pxorbint of boxed_integer @@ -113,14 +147,24 @@ (* byte swap *) | Pbswap16 | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer + (* Inhibition of optimisation *) + | Popaque and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge +and value_kind = + Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + +and block_shape = + value_kind list option + and array_kind = Pgenarray | Paddrarray | Pintarray | Pfloatarray -and boxed_integer = +and boxed_integer = Primitive.boxed_integer = Pnativeint | Pint32 | Pint64 and bigarray_kind = @@ -137,6 +181,11 @@ | Pbigarray_c_layout | Pbigarray_fortran_layout +and raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + type structured_constant = Const_base of constant | Const_pointer of int @@ -144,6 +193,17 @@ | Const_float_array of string list | Const_immstring of string +type inline_attribute = + | Always_inline (* [@inline] or [@inline always] *) + | Never_inline (* [@inline never] *) + | Unroll of int (* [@unroll x] *) + | Default_inline (* no [@inline] attribute *) + +type specialise_attribute = + | Always_specialise (* [@specialise] or [@specialise always] *) + | Never_specialise (* [@specialise never] *) + | Default_specialise (* no [@specialise] attribute *) + type function_kind = Curried | Tupled type let_kind = Strict | Alias | StrictOpt | Variable @@ -152,15 +212,24 @@ type shared_code = (int * int) list +type function_attribute = { + inline : inline_attribute; + specialise : specialise_attribute; + is_a_functor: bool; + stub: bool; +} + type lambda = Lvar of Ident.t | Lconst of structured_constant - | Lapply of lambda * lambda list * Location.t - | Lfunction of function_kind * Ident.t list * lambda - | Llet of let_kind * Ident.t * lambda * lambda + | Lapply of lambda_apply + | Lfunction of lfunction + | Llet of let_kind * value_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list + | Lprim of primitive * lambda list * Location.t | Lswitch of lambda * lambda_switch + | Lstringswitch of + lambda * (string * lambda) list * lambda option * Location.t | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -173,6 +242,21 @@ | Levent of lambda * lambda_event | Lifused of Ident.t * lambda +and lfunction = + { kind: function_kind; + params: Ident.t list; + body: lambda; + attr: function_attribute; (* specified with [@inline] attribute *) + loc: Location.t; } + +and lambda_apply = + { ap_func : lambda; + ap_args : lambda list; + ap_loc : Location.t; + ap_should_be_tailcall : bool; + ap_inlined : inline_attribute; + ap_specialised : specialise_attribute; } + and lambda_switch = { sw_numconsts: int; sw_consts: (int * lambda) list; @@ -190,111 +274,167 @@ Lev_before | Lev_after of Types.type_expr | Lev_function + | Lev_pseudo + +type program = + { module_ident : Ident.t; + main_module_block_size : int; + required_globals : Ident.Set.t; + code : lambda } let const_unit = Const_pointer 0 let lambda_unit = Lconst const_unit -let rec same l1 l2 = - match (l1, l2) with - | Lvar v1, Lvar v2 -> - Ident.same v1 v2 - | Lconst c1, Lconst c2 -> - c1 = c2 - | Lapply(a1, bl1, _), Lapply(a2, bl2, _) -> - same a1 a2 && samelist same bl1 bl2 - | Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) -> - k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2 - | Llet(k1, id1, a1, b1), Llet(k2, id2, a2, b2) -> - k1 = k2 && Ident.same id1 id2 && same a1 a2 && same b1 b2 - | Lletrec (bl1, a1), Lletrec (bl2, a2) -> - samelist samebinding bl1 bl2 && same a1 a2 - | Lprim(p1, al1), Lprim(p2, al2) -> - p1 = p2 && samelist same al1 al2 - | Lswitch(a1, s1), Lswitch(a2, s2) -> - same a1 a2 && sameswitch s1 s2 - | Lstaticraise(n1, al1), Lstaticraise(n2, al2) -> - n1 = n2 && samelist same al1 al2 - | Lstaticcatch(a1, (n1, idl1), b1), Lstaticcatch(a2, (n2, idl2), b2) -> - same a1 a2 && n1 = n2 && samelist Ident.same idl1 idl2 && same b1 b2 - | Ltrywith(a1, id1, b1), Ltrywith(a2, id2, b2) -> - same a1 a2 && Ident.same id1 id2 && same b1 b2 - | Lifthenelse(a1, b1, c1), Lifthenelse(a2, b2, c2) -> - same a1 a2 && same b1 b2 && same c1 c2 - | Lsequence(a1, b1), Lsequence(a2, b2) -> - same a1 a2 && same b1 b2 - | Lwhile(a1, b1), Lwhile(a2, b2) -> - same a1 a2 && same b1 b2 - | Lfor(id1, a1, b1, df1, c1), Lfor(id2, a2, b2, df2, c2) -> - Ident.same id1 id2 && same a1 a2 && - same b1 b2 && df1 = df2 && same c1 c2 - | Lassign(id1, a1), Lassign(id2, a2) -> - Ident.same id1 id2 && same a1 a2 - | Lsend(k1, a1, b1, cl1, _), Lsend(k2, a2, b2, cl2, _) -> - k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2 - | Levent(a1, ev1), Levent(a2, ev2) -> - same a1 a2 && ev1.lev_loc = ev2.lev_loc - | Lifused(id1, a1), Lifused(id2, a2) -> - Ident.same id1 id2 && same a1 a2 - | _, _ -> - false - -and samebinding (id1, c1) (id2, c2) = - Ident.same id1 id2 && same c1 c2 - -and sameswitch sw1 sw2 = - let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in - sw1.sw_numconsts = sw2.sw_numconsts && - sw1.sw_numblocks = sw2.sw_numblocks && - samelist samecase sw1.sw_consts sw2.sw_consts && - samelist samecase sw1.sw_blocks sw2.sw_blocks && - (match (sw1.sw_failaction, sw2.sw_failaction) with - | (None, None) -> true - | (Some a1, Some a2) -> same a1 a2 - | _ -> false) +let default_function_attribute = { + inline = Default_inline; + specialise = Default_specialise; + is_a_functor = false; + stub = false; +} + +let default_stub_attribute = + { default_function_attribute with stub = true } + +(* Build sharing keys *) +(* + Those keys are later compared with Pervasives.compare. + For that reason, they should not include cycles. +*) + +exception Not_simple + +let max_raw = 32 + +let make_key e = + let count = ref 0 (* Used for controling size *) + and make_key = Ident.make_key_generator () in + (* make_key is used for normalizing let-bound variables *) + let rec tr_rec env e = + incr count ; + if !count > max_raw then raise Not_simple ; (* Too big ! *) + match e with + | Lvar id -> + begin + try Ident.find_same id env + with Not_found -> e + end + | Lconst (Const_base (Const_string _)) -> + (* Mutable constants are not shared *) + raise Not_simple + | Lconst _ -> e + | Lapply ap -> + Lapply {ap with ap_func = tr_rec env ap.ap_func; + ap_args = tr_recs env ap.ap_args; + ap_loc = Location.none} + | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *) + let ex = tr_rec env ex in + tr_rec (Ident.add x ex env) e + | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x -> + tr_rec env ex + | Llet (str,k,x,ex,e) -> + (* Because of side effects, keep other lets with normalized names *) + let ex = tr_rec env ex in + let y = make_key x in + Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e) + | Lprim (p,es,_) -> + Lprim (p,tr_recs env es, Location.none) + | Lswitch (e,sw) -> + Lswitch (tr_rec env e,tr_sw env sw) + | Lstringswitch (e,sw,d,_) -> + Lstringswitch + (tr_rec env e, + List.map (fun (s,e) -> s,tr_rec env e) sw, + tr_opt env d, + Location.none) + | Lstaticraise (i,es) -> + Lstaticraise (i,tr_recs env es) + | Lstaticcatch (e1,xs,e2) -> + Lstaticcatch (tr_rec env e1,xs,tr_rec env e2) + | Ltrywith (e1,x,e2) -> + Ltrywith (tr_rec env e1,x,tr_rec env e2) + | Lifthenelse (cond,ifso,ifnot) -> + Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) + | Lsequence (e1,e2) -> + Lsequence (tr_rec env e1,tr_rec env e2) + | Lassign (x,e) -> + Lassign (x,tr_rec env e) + | Lsend (m,e1,e2,es,_loc) -> + Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none) + | Lifused (id,e) -> Lifused (id,tr_rec env e) + | Lletrec _|Lfunction _ + | Lfor _ | Lwhile _ +(* Beware: (PR#6412) the event argument to Levent + may include cyclic structure of type Type.typexpr *) + | Levent _ -> + raise Not_simple + + and tr_recs env es = List.map (tr_rec env) es + + and tr_sw env sw = + { sw with + sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ; + sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ; + sw_failaction = tr_opt env sw.sw_failaction ; } + + and tr_opt env = function + | None -> None + | Some e -> Some (tr_rec env e) in + + try + Some (tr_rec Ident.empty e) + with Not_simple -> None -let name_lambda arg fn = +(***************) + +let name_lambda strict arg fn = match arg with Lvar id -> fn id - | _ -> let id = Ident.create "let" in Llet(Strict, id, arg, fn id) + | _ -> let id = Ident.create "let" in Llet(strict, Pgenval, id, arg, fn id) let name_lambda_list args fn = let rec name_list names = function [] -> fn (List.rev names) - | (Lvar id as arg) :: rem -> + | (Lvar _ as arg) :: rem -> name_list (arg :: names) rem | arg :: rem -> let id = Ident.create "let" in - Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in + Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in name_list [] args + +let iter_opt f = function + | None -> () + | Some e -> f e + let iter f = function Lvar _ | Lconst _ -> () - | Lapply(fn, args, _) -> + | Lapply{ap_func = fn; ap_args = args} -> f fn; List.iter f args - | Lfunction(kind, params, body) -> + | Lfunction{body} -> f body - | Llet(str, id, arg, body) -> + | Llet(_str, _k, _id, arg, body) -> f arg; f body | Lletrec(decl, body) -> f body; - List.iter (fun (id, exp) -> f exp) decl - | Lprim(p, args) -> + List.iter (fun (_id, exp) -> f exp) decl + | Lprim(_p, args, _loc) -> List.iter f args | Lswitch(arg, sw) -> f arg; - List.iter (fun (key, case) -> f case) sw.sw_consts; - List.iter (fun (key, case) -> f case) sw.sw_blocks; - begin match sw.sw_failaction with - | None -> () - | Some l -> f l - end + List.iter (fun (_key, case) -> f case) sw.sw_consts; + List.iter (fun (_key, case) -> f case) sw.sw_blocks; + iter_opt f sw.sw_failaction + | Lstringswitch (arg,cases,default,_) -> + f arg ; + List.iter (fun (_,act) -> f act) cases ; + iter_opt f default | Lstaticraise (_,args) -> List.iter f args - | Lstaticcatch(e1, (_,vars), e2) -> + | Lstaticcatch(e1, _, e2) -> f e1; f e2 - | Ltrywith(e1, exn, e2) -> + | Ltrywith(e1, _, e2) -> f e1; f e2 | Lifthenelse(e1, e2, e3) -> f e1; f e2; f e3 @@ -302,22 +442,19 @@ f e1; f e2 | Lwhile(e1, e2) -> f e1; f e2 - | Lfor(v, e1, e2, dir, e3) -> + | Lfor(_v, e1, e2, _dir, e3) -> f e1; f e2; f e3 - | Lassign(id, e) -> + | Lassign(_, e) -> f e - | Lsend (k, met, obj, args, _) -> + | Lsend (_k, met, obj, args, _) -> List.iter f (met::obj::args) - | Levent (lam, evt) -> + | Levent (lam, _evt) -> f lam - | Lifused (v, e) -> + | Lifused (_v, e) -> f e -module IdentSet = - Set.Make(struct - type t = Ident.t - let compare = compare - end) + +module IdentSet = Set.Make(Ident) let free_ids get l = let fv = ref IdentSet.empty in @@ -325,22 +462,22 @@ iter free l; fv := List.fold_right IdentSet.add (get l) !fv; match l with - Lfunction(kind, params, body) -> + Lfunction{params} -> List.iter (fun param -> fv := IdentSet.remove param !fv) params - | Llet(str, id, arg, body) -> + | Llet(_str, _k, id, _arg, _body) -> fv := IdentSet.remove id !fv - | Lletrec(decl, body) -> - List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl - | Lstaticcatch(e1, (_,vars), e2) -> + | Lletrec(decl, _body) -> + List.iter (fun (id, _exp) -> fv := IdentSet.remove id !fv) decl + | Lstaticcatch(_e1, (_,vars), _e2) -> List.iter (fun id -> fv := IdentSet.remove id !fv) vars - | Ltrywith(e1, exn, e2) -> + | Ltrywith(_e1, exn, _e2) -> fv := IdentSet.remove exn !fv - | Lfor(v, e1, e2, dir, e3) -> + | Lfor(v, _e1, _e2, _dir, _e3) -> fv := IdentSet.remove v !fv - | Lassign(id, e) -> + | Lassign(id, _e) -> fv := IdentSet.add id !fv | Lvar _ | Lconst _ | Lapply _ - | Lprim _ | Lswitch _ | Lstaticraise _ + | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lwhile _ | Lsend _ | Levent _ | Lifused _ -> () in free l; !fv @@ -349,7 +486,7 @@ free_ids (function Lvar id -> [id] | _ -> []) l let free_methods l = - free_ids (function Lsend(Self, Lvar meth, obj, _, _) -> [meth] | _ -> []) l + free_ids (function Lsend(Self, Lvar meth, _, _, _) -> [meth] | _ -> []) l (* Check if an action has a "when" guard *) let raise_count = ref 0 @@ -358,34 +495,47 @@ incr raise_count ; !raise_count +let negative_raise_count = ref 0 + +let next_negative_raise_count () = + decr negative_raise_count ; + !negative_raise_count + (* Anticipated staticraise, for guards *) let staticfail = Lstaticraise (0,[]) let rec is_guarded = function - | Lifthenelse( cond, body, Lstaticraise (0,[])) -> true - | Llet(str, id, lam, body) -> is_guarded body - | Levent(lam, ev) -> is_guarded lam + | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true + | Llet(_str, _k, _id, _lam, body) -> is_guarded body + | Levent(lam, _ev) -> is_guarded lam | _ -> false let rec patch_guarded patch = function | Lifthenelse (cond, body, Lstaticraise (0,[])) -> Lifthenelse (cond, body, patch) - | Llet(str, id, lam, body) -> - Llet (str, id, lam, patch_guarded patch body) + | Llet(str, k, id, lam, body) -> + Llet (str, k, id, lam, patch_guarded patch body) | Levent(lam, ev) -> Levent (patch_guarded patch lam, ev) | _ -> fatal_error "Lambda.patch_guarded" (* Translate an access path *) -let rec transl_path = function +let rec transl_normal_path = function Pident id -> - if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id - | Pdot(p, s, pos) -> - Lprim(Pfield pos, [transl_path p]) - | Papply(p1, p2) -> + if Ident.global id + then Lprim(Pgetglobal id, [], Location.none) + else Lvar id + | Pdot(p, _s, pos) -> + Lprim(Pfield pos, [transl_normal_path p], Location.none) + | Papply _ -> fatal_error "Lambda.transl_path" +(* Translation of value identifiers *) + +let transl_path ?(loc=Location.none) env path = + transl_normal_path (Env.normalize_path (Some loc) env path) + (* Compile a sequence of expressions *) let rec make_sequence fn = function @@ -404,21 +554,23 @@ let rec subst = function Lvar id as l -> begin try Ident.find_same id s with Not_found -> l end - | Lconst sc as l -> l - | Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc) - | Lfunction(kind, params, body) -> Lfunction(kind, params, subst body) - | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body) + | Lconst _ as l -> l + | Lapply ap -> + Lapply{ap with ap_func = subst ap.ap_func; + ap_args = List.map subst ap.ap_args} + | Lfunction{kind; params; body; attr; loc} -> + Lfunction{kind; params; body = subst body; attr; loc} + | Llet(str, k, id, arg, body) -> Llet(str, k, id, subst arg, subst body) | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body) - | Lprim(p, args) -> Lprim(p, List.map subst args) + | Lprim(p, args, loc) -> Lprim(p, List.map subst args, loc) | Lswitch(arg, sw) -> Lswitch(subst arg, {sw with sw_consts = List.map subst_case sw.sw_consts; sw_blocks = List.map subst_case sw.sw_blocks; - sw_failaction = - match sw.sw_failaction with - | None -> None - | Some l -> Some (subst l)}) - + sw_failaction = subst_opt sw.sw_failaction; }) + | Lstringswitch (arg,cases,default,loc) -> + Lstringswitch + (subst arg,List.map subst_strcase cases,subst_opt default,loc) | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args) | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2) | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2) @@ -433,15 +585,80 @@ | Lifused (v, e) -> Lifused (v, subst e) and subst_decl (id, exp) = (id, subst exp) and subst_case (key, case) = (key, subst case) + and subst_strcase (key, case) = (key, subst case) + and subst_opt = function + | None -> None + | Some e -> Some (subst e) in subst lam +let rec map f lam = + let lam = + match lam with + | Lvar _ -> lam + | Lconst _ -> lam + | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall; + ap_inlined; ap_specialised } -> + Lapply { + ap_func = map f ap_func; + ap_args = List.map (map f) ap_args; + ap_loc; + ap_should_be_tailcall; + ap_inlined; + ap_specialised; + } + | Lfunction { kind; params; body; attr; loc; } -> + Lfunction { kind; params; body = map f body; attr; loc; } + | Llet (str, k, v, e1, e2) -> + Llet (str, k, v, map f e1, map f e2) + | Lletrec (idel, e2) -> + Lletrec (List.map (fun (v, e) -> (v, map f e)) idel, map f e2) + | Lprim (p, el, loc) -> + Lprim (p, List.map (map f) el, loc) + | Lswitch (e, sw) -> + Lswitch (map f e, + { sw_numconsts = sw.sw_numconsts; + sw_consts = List.map (fun (n, e) -> (n, map f e)) sw.sw_consts; + sw_numblocks = sw.sw_numblocks; + sw_blocks = List.map (fun (n, e) -> (n, map f e)) sw.sw_blocks; + sw_failaction = Misc.may_map (map f) sw.sw_failaction; + }) + | Lstringswitch (e, sw, default, loc) -> + Lstringswitch ( + map f e, + List.map (fun (s, e) -> (s, map f e)) sw, + Misc.may_map (map f) default, + loc) + | Lstaticraise (i, args) -> + Lstaticraise (i, List.map (map f) args) + | Lstaticcatch (body, id, handler) -> + Lstaticcatch (map f body, id, map f handler) + | Ltrywith (e1, v, e2) -> + Ltrywith (map f e1, v, map f e2) + | Lifthenelse (e1, e2, e3) -> + Lifthenelse (map f e1, map f e2, map f e3) + | Lsequence (e1, e2) -> + Lsequence (map f e1, map f e2) + | Lwhile (e1, e2) -> + Lwhile (map f e1, map f e2) + | Lfor (v, e1, e2, dir, e3) -> + Lfor (v, map f e1, map f e2, dir, map f e3) + | Lassign (v, e) -> + Lassign (v, map f e) + | Lsend (k, m, o, el, loc) -> + Lsend (k, map f m, map f o, List.map (map f) el, loc) + | Levent (l, ev) -> + Levent (map f l, ev) + | Lifused (v, e) -> + Lifused (v, map f e) + in + f lam (* To let-bind expressions to variables *) let bind str var exp body = match exp with Lvar var' when Ident.same var var' -> body - | _ -> Llet(str, var, exp, body) + | _ -> Llet(str, Pgenval, var, exp, body) and commute_comparison = function | Ceq -> Ceq| Cneq -> Cneq @@ -452,3 +669,36 @@ | Ceq -> Cneq| Cneq -> Ceq | Clt -> Cge | Cle -> Cgt | Cgt -> Cle | Cge -> Clt + +let raise_kind = function + | Raise_regular -> "raise" + | Raise_reraise -> "reraise" + | Raise_notrace -> "raise_notrace" + +let lam_of_loc kind loc = + let loc_start = loc.Location.loc_start in + let (file, lnum, cnum) = Location.get_pos_info loc_start in + let enum = loc.Location.loc_end.Lexing.pos_cnum - + loc_start.Lexing.pos_cnum + cnum in + match kind with + | Loc_POS -> + Lconst (Const_block (0, [ + Const_immstring file; + Const_base (Const_int lnum); + Const_base (Const_int cnum); + Const_base (Const_int enum); + ])) + | Loc_FILE -> Lconst (Const_immstring file) + | Loc_MODULE -> + let filename = Filename.basename file in + let name = Env.get_unit_name () in + let module_name = if name = "" then "//"^filename^"//" else name in + Lconst (Const_immstring module_name) + | Loc_LOC -> + let loc = Printf.sprintf "File %S, line %d, characters %d-%d" + file lnum cnum enum in + Lconst (Const_immstring loc) + | Loc_LINE -> Lconst (Const_base (Const_int lnum)) + +let reset () = + raise_count := 0 diff -Nru ocaml-4.01.0/bytecomp/lambda.mli ocaml-4.05.0/bytecomp/lambda.mli --- ocaml-4.01.0/bytecomp/lambda.mli 2012-11-29 09:55:00.000000000 +0000 +++ ocaml-4.05.0/bytecomp/lambda.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* The "lambda" intermediate code *) @@ -17,35 +20,69 @@ type compile_time_constant = | Big_endian | Word_size + | Int_size + | Max_wosize | Ostype_unix | Ostype_win32 | Ostype_cygwin + | Backend_type + +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + +type immediate_or_pointer = + | Immediate + | Pointer + +type initialization_or_assignment = + | Assignment + (* Initialization of in heap values, like [caml_initialize] C primitive. The + field should not have been read before and initialization should happen + only once. *) + | Heap_initialization + (* Initialization of roots only. Compiles to a simple store. + No checks are done to preserve GC invariants. *) + | Root_initialization + +type is_safe = + | Safe + | Unsafe type primitive = - Pidentity + | Pidentity + | Pbytes_to_string + | Pbytes_of_string | Pignore - | Prevapply of Location.t - | Pdirapply of Location.t + | Prevapply + | Pdirapply + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t (* Operations on heap blocks *) - | Pmakeblock of int * mutable_flag + | Pmakeblock of int * mutable_flag * block_shape | Pfield of int - | Psetfield of int * bool + | Pfield_computed + | Psetfield of int * immediate_or_pointer * initialization_or_assignment + | Psetfield_computed of immediate_or_pointer * initialization_or_assignment | Pfloatfield of int - | Psetfloatfield of int + | Psetfloatfield of int * initialization_or_assignment | Pduprecord of Types.record_representation * int (* Force lazy values *) | Plazyforce (* External call *) | Pccall of Primitive.description (* Exceptions *) - | Praise + | Praise of raise_kind (* Boolean operations *) | Psequand | Psequor | Pnot (* Integer operations *) - | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint + | Pnegint | Paddint | Psubint | Pmulint + | Pdivint of is_safe | Pmodint of is_safe | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp of comparison @@ -57,9 +94,14 @@ | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat | Pfloatcomp of comparison (* String operations *) - | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets + | Pstringlength | Pstringrefu | Pstringrefs + | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets (* Array operations *) - | Pmakearray of array_kind + | Pmakearray of array_kind * mutable_flag + | Pduparray of array_kind * mutable_flag + (** For [Pduparray], the argument must be an immutable array. + The arguments of [Pduparray] give the kind and mutability of the + array being *produced* by the duplication. *) | Parraylength of array_kind | Parrayrefu of array_kind | Parraysetu of array_kind @@ -79,8 +121,8 @@ | Paddbint of boxed_integer | Psubbint of boxed_integer | Pmulbint of boxed_integer - | Pdivbint of boxed_integer - | Pmodbint of boxed_integer + | Pdivbint of { size : boxed_integer; is_safe : is_safe } + | Pmodbint of { size : boxed_integer; is_safe : is_safe } | Pandbint of boxed_integer | Porbint of boxed_integer | Pxorbint of boxed_integer @@ -113,6 +155,10 @@ (* byte swap *) | Pbswap16 | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer + (* Inhibition of optimisation *) + | Popaque and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -120,7 +166,13 @@ and array_kind = Pgenarray | Paddrarray | Pintarray | Pfloatarray -and boxed_integer = +and value_kind = + Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + +and block_shape = + value_kind list option + +and boxed_integer = Primitive.boxed_integer = Pnativeint | Pint32 | Pint64 and bigarray_kind = @@ -137,6 +189,11 @@ | Pbigarray_c_layout | Pbigarray_fortran_layout +and raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + type structured_constant = Const_base of constant | Const_pointer of int @@ -144,6 +201,17 @@ | Const_float_array of string list | Const_immstring of string +type inline_attribute = + | Always_inline (* [@inline] or [@inline always] *) + | Never_inline (* [@inline never] *) + | Unroll of int (* [@unroll x] *) + | Default_inline (* no [@inline] attribute *) + +type specialise_attribute = + | Always_specialise (* [@specialise] or [@specialise always] *) + | Never_specialise (* [@specialise never] *) + | Default_specialise (* no [@specialise] attribute *) + type function_kind = Curried | Tupled type let_kind = Strict | Alias | StrictOpt | Variable @@ -155,21 +223,33 @@ in e' StrictOpt: e does not have side-effects, but depend on the store; we can discard e if x does not appear in e' - Variable: the variable x is assigned later in e' *) + Variable: the variable x is assigned later in e' + *) type meth_kind = Self | Public | Cached type shared_code = (int * int) list (* stack size -> code label *) +type function_attribute = { + inline : inline_attribute; + specialise : specialise_attribute; + is_a_functor: bool; + stub: bool; +} + type lambda = Lvar of Ident.t | Lconst of structured_constant - | Lapply of lambda * lambda list * Location.t - | Lfunction of function_kind * Ident.t list * lambda - | Llet of let_kind * Ident.t * lambda * lambda + | Lapply of lambda_apply + | Lfunction of lfunction + | Llet of let_kind * value_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list + | Lprim of primitive * lambda list * Location.t | Lswitch of lambda * lambda_switch +(* switch on strings, clauses are sorted by string order, + strings are pairwise distinct *) + | Lstringswitch of + lambda * (string * lambda) list * lambda option * Location.t | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -182,6 +262,21 @@ | Levent of lambda * lambda_event | Lifused of Ident.t * lambda +and lfunction = + { kind: function_kind; + params: Ident.t list; + body: lambda; + attr: function_attribute; (* specified with [@inline] attribute *) + loc : Location.t; } + +and lambda_apply = + { ap_func : lambda; + ap_args : lambda list; + ap_loc : Location.t; + ap_should_be_tailcall : bool; (* true if [@tailcall] was specified *) + ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *) + ap_specialised : specialise_attribute; } + and lambda_switch = { sw_numconsts: int; (* Number of integer cases *) sw_consts: (int * lambda) list; (* Integer cases *) @@ -198,11 +293,32 @@ Lev_before | Lev_after of Types.type_expr | Lev_function + | Lev_pseudo + +type program = + { module_ident : Ident.t; + main_module_block_size : int; + required_globals : Ident.Set.t; (* Modules whose initializer side effects + must occur before [code]. *) + code : lambda } +(* Lambda code for the middle-end. + * In the closure case the code is a sequence of assignments to a + preallocated block of size [main_module_block_size] using + (Setfield(Getglobal(module_ident))). The size is used to preallocate + the block. + * In the flambda case the code is an expression returning a block + value of size [main_module_block_size]. The size is used to build + the module root as an initialize_symbol + Initialize_symbol(module_name, 0, + [getfield 0; ...; getfield (main_module_block_size - 1)]) +*) + +(* Sharing key *) +val make_key: lambda -> lambda option -val same: lambda -> lambda -> bool val const_unit: structured_constant val lambda_unit: lambda -val name_lambda: lambda -> (Ident.t -> lambda) -> lambda +val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda val iter: (lambda -> unit) -> lambda -> unit @@ -210,25 +326,39 @@ val free_variables: lambda -> IdentSet.t val free_methods: lambda -> IdentSet.t -val transl_path: Path.t -> lambda +val transl_normal_path: Path.t -> lambda (* Path.t is already normal *) +val transl_path: ?loc:Location.t -> Env.t -> Path.t -> lambda val make_sequence: ('a -> lambda) -> 'a list -> lambda val subst_lambda: lambda Ident.tbl -> lambda -> lambda +val map : (lambda -> lambda) -> lambda -> lambda val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda val commute_comparison : comparison -> comparison val negate_comparison : comparison -> comparison +val default_function_attribute : function_attribute +val default_stub_attribute : function_attribute + (***********************) (* For static failures *) (***********************) (* Get a new static failure ident *) val next_raise_count : unit -> int - +val next_negative_raise_count : unit -> int + (* Negative raise counts are used to compile 'match ... with + exception x -> ...'. This disabled some simplifications + performed by the Simplif module that assume that static raises + are in tail position in their handler. *) val staticfail : lambda (* Anticipated static failure *) (* Check anticipated failure, substitute its final value *) val is_guarded: lambda -> bool val patch_guarded : lambda -> lambda -> lambda + +val raise_kind: raise_kind -> string +val lam_of_loc : loc_kind -> Location.t -> lambda + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/matching.ml ocaml-4.05.0/bytecomp/matching.ml --- ocaml-4.01.0/bytecomp/matching.ml 2013-07-23 14:48:47.000000000 +0000 +++ ocaml-4.05.0/bytecomp/matching.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,30 +1,35 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Compilation of pattern matching *) open Misc open Asttypes -open Primitive open Types open Typedtree open Lambda open Parmatch open Printf + +let dbg = false + (* See Peyton-Jones, ``The Implementation of functional programming languages'', chapter 5. *) (* - Bon, au commencement du monde c'etait vrai. + Well, it was true at the beginning of the world. Now, see Lefessant-Maranget ``Optimizing Pattern-Matching'' ICFP'2001 *) @@ -38,6 +43,10 @@ - Jump summaries: mapping from exit numbers to contexts *) +let string_of_lam lam = + Printlambda.lambda Format.str_formatter lam ; + Format.flush_str_formatter () + type matrix = pattern list list let add_omega_column pss = List.map (fun ps -> omega::ps) pss @@ -63,7 +72,7 @@ | _ -> assert false let lforget {left=left ; right=right} = match right with -| x::xs -> {left=omega::left ; right=xs} +| _::xs -> {left=omega::left ; right=xs} | _ -> assert false let rec small_enough n = function @@ -160,12 +169,24 @@ let ctx_matcher p = let p = normalize_pat p in match p.pat_desc with - | Tpat_construct (_, cstr,omegas,_) -> - (fun q rem -> match q.pat_desc with - | Tpat_construct (_, cstr',args,_) when cstr.cstr_tag=cstr'.cstr_tag -> - p,args @ rem - | Tpat_any -> p,omegas @ rem - | _ -> raise NoMatch) + | Tpat_construct (_, cstr,omegas) -> + begin match cstr.cstr_tag with + | Cstr_extension _ -> + let nargs = List.length omegas in + (fun q rem -> match q.pat_desc with + | Tpat_construct (_, _cstr',args) + when List.length args = nargs -> + p,args @ rem + | Tpat_any -> p,omegas @ rem + | _ -> raise NoMatch) + | _ -> + (fun q rem -> match q.pat_desc with + | Tpat_construct (_, cstr',args) + when cstr.cstr_tag=cstr'.cstr_tag -> + p,args @ rem + | Tpat_any -> p,omegas @ rem + | _ -> raise NoMatch) + end | Tpat_constant cst -> (fun q rem -> match q.pat_desc with | Tpat_constant cst' when const_compare cst cst' = 0 -> @@ -375,7 +396,7 @@ let pretty_cases cases = List.iter - (fun ((ps),l) -> + (fun (ps,_l) -> List.iter (fun p -> Parmatch.top_pretty Format.str_formatter p ; @@ -412,6 +433,7 @@ | PmOr x -> prerr_endline "++++ OR ++++" ; pretty_pm x.body ; + pretty_matrix x.or_matrix ; List.iter (fun (_,i,_,pm) -> eprintf "++ Handler %d ++\n" i ; @@ -428,76 +450,132 @@ -(* A slight attempt to identify semantically equivalent lambda-expressions *) -exception Not_simple +(* Identifing some semantically equivalent lambda-expressions, + Our goal here is also to + find alpha-equivalent (simple) terms *) + +(* However, as shown by PR#6359 such sharing may hinders the + lambda-code invariant that all bound idents are unique, + when switches are compiled to test sequences. + The definitive fix is the systematic introduction of exit/catch + in case action sharing is present. +*) + + +module StoreExp = + Switch.Store + (struct + type t = lambda + type key = lambda + let make_key = Lambda.make_key + end) + + +let make_exit i = Lstaticraise (i,[]) + +(* Introduce a catch, if worth it *) +let make_catch d k = match d with +| Lstaticraise (_,[]) -> k d +| _ -> + let e = next_raise_count () in + Lstaticcatch (k (make_exit e),(e,[]),d) + +(* Introduce a catch, if worth it, delayed version *) +let rec as_simple_exit = function + | Lstaticraise (i,[]) -> Some i + | Llet (Alias,_k,_,_,e) -> as_simple_exit e + | _ -> None + + +let make_catch_delayed handler = match as_simple_exit handler with +| Some i -> i,(fun act -> act) +| None -> + let i = next_raise_count () in +(* + Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); +*) + i, + (fun body -> match body with + | Lstaticraise (j,_) -> + if i=j then handler else body + | _ -> Lstaticcatch (body,(i,[]),handler)) + + +let raw_action l = + match make_key l with | Some l -> l | None -> l -let rec raw_rec env : lambda -> lambda = function - | Llet(Alias,x,ex, body) -> raw_rec ((x,raw_rec env ex)::env) body - | Lvar id as l -> - begin try List.assoc id env with - | Not_found -> l - end - | Lprim (Pfield i,args) -> - Lprim (Pfield i, List.map (raw_rec env) args) - | Lconst _ as l -> l - | Lstaticraise (i,args) -> - Lstaticraise (i, List.map (raw_rec env) args) - | _ -> raise Not_simple -let raw_action l = try raw_rec [] l with Not_simple -> l +let tr_raw act = match make_key act with +| Some act -> act +| None -> raise Exit let same_actions = function | [] -> None | [_,act] -> Some act | (_,act0) :: rem -> try - let raw_act0 = raw_rec [] act0 in + let raw_act0 = tr_raw act0 in let rec s_rec = function | [] -> Some act0 | (_,act)::rem -> - if raw_act0 = raw_rec [] act then + if raw_act0 = tr_raw act then s_rec rem else None in s_rec rem with - | Not_simple -> None + | Exit -> None -let equal_action act1 act2 = - try - let raw1 = raw_rec [] act1 - and raw2 = raw_rec [] act2 in - raw1 = raw2 - with - | Not_simple -> false (* Test for swapping two clauses *) let up_ok_action act1 act2 = try - let raw1 = raw_rec [] act1 - and raw2 = raw_rec [] act2 in - match raw1, raw2 with - | Lstaticraise (i1,[]), Lstaticraise (i2,[]) -> i1=i2 - | _,_ -> raw1 = raw2 + let raw1 = tr_raw act1 + and raw2 = tr_raw act2 in + raw1 = raw2 with - | Not_simple -> false + | Exit -> false + +(* Nothing is known about exception/extension patterns, + because of potential rebind *) +let rec exc_inside p = match p.pat_desc with + | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true + | Tpat_any|Tpat_constant _|Tpat_var _ + | Tpat_construct (_,_,[]) + | Tpat_variant (_,None,_) + -> false + | Tpat_construct (_,_,ps) + | Tpat_tuple ps + | Tpat_array ps + -> exc_insides ps + | Tpat_variant (_, Some q,_) + | Tpat_alias (q,_,_) + | Tpat_lazy q + -> exc_inside q + | Tpat_record (lps,_) -> + List.exists (fun (_,_,p) -> exc_inside p) lps + | Tpat_or (p1,p2,_) -> exc_inside p1 || exc_inside p2 + +and exc_insides ps = List.exists exc_inside ps let up_ok (ps,act_p) l = - List.for_all - (fun (qs,act_q) -> - up_ok_action act_p act_q || - not (Parmatch.compats ps qs)) - l + if exc_insides ps then match l with [] -> true | _::_ -> false + else + List.for_all + (fun (qs,act_q) -> + up_ok_action act_p act_q || + not (Parmatch.compats ps qs)) + l (* Simplify fonction normalize the first column of the match - - records are expanded so that they posses all fields + - records are expanded so that they possess all fields - aliases are removed and replaced by bindings in actions. However or-patterns are simplified differently, - aliases are not removed - - or patterns (_|p) are changed into _ + - or-patterns (_|p) are changed into _ *) exception Var of pattern @@ -568,7 +646,7 @@ -(* Once matchings are simplified one easily finds +(* Once matchings are simplified one can easily find their nature *) let rec what_is_cases cases = match cases with @@ -581,9 +659,19 @@ -(* A few operation on default environments *) +(* A few operations on default environments *) let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases) +(* For extension matching, record no information in matrix *) +let as_matrix_omega cases = + get_mins le_pats + (List.map + (fun (ps,_) -> + match ps with + | [] -> assert false + | _::ps -> omega::ps) + cases) + let cons_default matrix raise_num default = match matrix with | [] -> default @@ -614,7 +702,7 @@ List.fold_left (fun r (_, _, p) -> extract_vars r p) r lpats -| Tpat_construct (_, _, pats,_) -> +| Tpat_construct (_, _, pats) -> List.fold_left extract_vars r pats | Tpat_array pats -> List.fold_left extract_vars r pats @@ -658,13 +746,16 @@ (* Basic grouping predicates *) +let pat_as_constr = function + | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr + | _ -> fatal_error "Matching.pat_as_constr" let group_constant = function | {pat_desc= Tpat_constant _} -> true | _ -> false and group_constructor = function - | {pat_desc = Tpat_construct _} -> true + | {pat_desc = Tpat_construct (_,_,_)} -> true | _ -> false and group_variant = function @@ -762,7 +853,7 @@ ors,(p::ps,act)::no else (* p # q, go on with append/insert *) attempt (cl::seen) rem - end else (* q is not a or-pat, go on with append/insert *) + end else (* q is not an or-pat, go on with append/insert *) attempt (cl::seen) rem | _ -> (* [] in fact *) (p::ps,act)::ors,no in (* success in appending *) @@ -792,7 +883,7 @@ Splitting is first directed by or-patterns, then by tests (e.g. constructors)/variable transitions. - The approach is greedy, every split function attempt to + The approach is greedy, every split function attempts to raise rows as much as possible in the top matrix, then splitting applies again to the remaining rows. @@ -847,10 +938,74 @@ do_split [] [] [] cls +(* Ultra-naive splitting, close to semantics, used for extension, + as potential rebind prevents any kind of optimisation *) + +and split_naive cls args def k = + + let rec split_exc cstr0 yes = function + | [] -> + let yes = List.rev yes in + { me = Pm {cases=yes; args=args; default=def;} ; + matrix = as_matrix_omega yes ; + top_default=def}, + k + | (p::_,_ as cl)::rem -> + if group_constructor p then + let cstr = pat_as_constr p in + if cstr = cstr0 then split_exc cstr0 (cl::yes) rem + else + let yes = List.rev yes in + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_exc cstr [cl] rem in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + { me = Pm {cases=yes; args=args; default=def} ; + matrix = as_matrix_omega yes ; + top_default = def; }, + (idef,next)::nexts + else + let yes = List.rev yes in + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_noexc [cl] rem in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + { me = Pm {cases=yes; args=args; default=def} ; + matrix = as_matrix_omega yes ; + top_default = def; }, + (idef,next)::nexts + | _ -> assert false + + and split_noexc yes = function + | [] -> precompile_var args (List.rev yes) def k + | (p::_,_ as cl)::rem -> + if group_constructor p then + let yes= List.rev yes in + let {me=next; matrix=matrix; top_default=def;},nexts = + split_exc (pat_as_constr p) [cl] rem in + let idef = next_raise_count () in + precompile_var + args yes + (cons_default matrix idef def) + ((idef,next)::nexts) + else split_noexc (cl::yes) rem + | _ -> assert false in + + match cls with + | [] -> assert false + | (p::_,_ as cl)::rem -> + if group_constructor p then + split_exc (pat_as_constr p) [cl] rem + else + split_noexc [cl] rem + | _ -> assert false + and split_constr cls args def k = let ex_pat = what_is_cases cls in match ex_pat.pat_desc with | Tpat_any -> precompile_var args cls def k + | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> + split_naive cls args def k | _ -> let group = get_group ex_pat in @@ -903,7 +1058,7 @@ end | [ps,_ as cl] when List.for_all group_var ps && yes <> [] -> - (* This enables an extra division in some frequent case : + (* This enables an extra division in some frequent cases : last row is made of variables only *) split_noex yes (cl::no) [] | (p::_,_) as cl::rem -> @@ -923,7 +1078,7 @@ | [] -> assert false | _::((Lvar v as av,_) as arg)::rargs -> begin match cls with - | [ps,_] -> (* as splitted as it can *) + | [_] -> (* as splitted as it can *) dont_precompile_var args cls def k | _ -> (* Precompile *) @@ -956,12 +1111,21 @@ matrix=as_matrix cls ; top_default=def},k +and is_exc p = match p.pat_desc with +| Tpat_or (p1,p2,_) -> is_exc p1 || is_exc p2 +| Tpat_alias (p,_,_) -> is_exc p +| Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true +| _ -> false + and precompile_or argo cls ors args def k = match ors with | [] -> split_constr cls args def k | _ -> let rec do_cases = function | ({pat_desc=Tpat_or _} as orp::patl, action)::rem -> - let others,rem = get_equiv orp rem in + let do_opt = not (is_exc orp) in + let others,rem = + if do_opt then get_equiv orp rem + else [],rem in let orpm = {cases = (patl, action):: @@ -971,7 +1135,7 @@ | _ -> assert false) others ; args = (match args with _::r -> r | _ -> assert false) ; - default = default_compat orp def} in + default = default_compat (if do_opt then orp else omega) def} in let vars = IdentSet.elements (IdentSet.inter @@ -984,17 +1148,19 @@ Lstaticraise (or_num, List.map (fun v -> Lvar v) vs) in - let body,handlers = do_cases rem in + let do_optrec,body,handlers = do_cases rem in + do_opt && do_optrec, explode_or_pat argo new_patl mk_new_action body vars [] orp, - (([[orp]], or_num, vars , orpm):: handlers) + let mat = if do_opt then [[orp]] else [[omega]] in + ((mat, or_num, vars , orpm):: handlers) | cl::rem -> - let new_ord,new_to_catch = do_cases rem in - cl::new_ord,new_to_catch - | [] -> [],[] in + let b,new_ord,new_to_catch = do_cases rem in + b,cl::new_ord,new_to_catch + | [] -> true,[],[] in - let end_body, handlers = do_cases ors in - let matrix = as_matrix (cls@ors) + let do_opt,end_body, handlers = do_cases ors in + let matrix = (if do_opt then as_matrix else as_matrix_omega) (cls@ors) and body = {cases=cls@end_body ; args=args ; default=def} in {me = PmOr {body=body ; handlers=handlers ; or_matrix=matrix} ; matrix=matrix ; @@ -1003,13 +1169,12 @@ let split_precompile argo pm = let {me=next}, nexts = split_or argo pm.cases pm.args pm.default in -(* - if nexts <> [] || (match next with PmOr _ -> true | _ -> false) then begin + if dbg && (nexts <> [] || (match next with PmOr _ -> true | _ -> false)) + then begin prerr_endline "** SPLIT **" ; pretty_pm pm ; pretty_precompiled_res next nexts end ; -*) next, nexts @@ -1063,15 +1228,15 @@ There is one set of functions per matching style (constants, constructors etc.) - - matcher function are arguments to make_default (for defaukt handlers) + - matcher functions are arguments to make_default (for default handlers) They may raise NoMatch or OrPat and perform the full matching (selection + arguments). - get_args and get_key are for the compiled matrices, note that - selection and geting arguments are separed. + selection and getting arguments are separated. - - make_ _matching combines the previous functions for produicing + - make_ _matching combines the previous functions for producing new ``pattern_matching'' records. *) @@ -1121,26 +1286,21 @@ (* Matching against a constructor *) -let make_field_args binding_kind arg first_pos last_pos argl = +let make_field_args loc binding_kind arg first_pos last_pos argl = let rec make_args pos = if pos > last_pos then argl - else (Lprim(Pfield pos, [arg]), binding_kind) :: make_args (pos + 1) + else (Lprim(Pfield pos, [arg], loc), binding_kind) :: make_args (pos + 1) in make_args first_pos let get_key_constr = function - | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr.cstr_tag + | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr.cstr_tag | _ -> assert false let get_args_constr p rem = match p with -| {pat_desc=Tpat_construct (_, _, args, _)} -> args @ rem +| {pat_desc=Tpat_construct (_, _, args)} -> args @ rem | _ -> assert false -let pat_as_constr = function - | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr - | _ -> fatal_error "Matching.pat_as_constr" - - let matcher_constr cstr = match cstr.cstr_arity with | 0 -> let rec matcher_rec q rem = match q.pat_desc with @@ -1151,7 +1311,7 @@ with | NoMatch -> matcher_rec p2 rem end - | Tpat_construct (_, cstr1, [],_) when cstr.cstr_tag = cstr1.cstr_tag -> + | Tpat_construct (_, cstr1, []) when cstr.cstr_tag = cstr1.cstr_tag -> rem | Tpat_any -> rem | _ -> raise NoMatch in @@ -1165,14 +1325,14 @@ | None, None -> raise NoMatch | Some r1, None -> r1 | None, Some r2 -> r2 - | Some (a1::rem1), Some (a2::_) -> + | Some (a1::_), Some (a2::_) -> {a1 with pat_loc = Location.none ; pat_desc = Tpat_or (a1, a2, None)}:: rem | _, _ -> assert false end - | Tpat_construct (_, cstr1, [arg],_) + | Tpat_construct (_, cstr1, [arg]) when cstr.cstr_tag = cstr1.cstr_tag -> arg::rem | Tpat_any -> omega::rem | _ -> raise NoMatch in @@ -1180,21 +1340,24 @@ | _ -> fun q rem -> match q.pat_desc with | Tpat_or (_,_,_) -> raise OrPat - | Tpat_construct (_, cstr1, args,_) + | Tpat_construct (_, cstr1, args) when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem | _ -> raise NoMatch let make_constr_matching p def ctx = function [] -> fatal_error "Matching.make_constr_matching" - | ((arg, mut) :: argl) -> + | ((arg, _mut) :: argl) -> let cstr = pat_as_constr p in let newargs = - match cstr.cstr_tag with + if cstr.cstr_inlined <> None then + (arg, Alias) :: argl + else match cstr.cstr_tag with Cstr_constant _ | Cstr_block _ -> - make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl - | Cstr_exception _ -> - make_field_args Alias arg 1 cstr.cstr_arity argl in + make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl + | Cstr_unboxed -> (arg, Alias) :: argl + | Cstr_extension _ -> + make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl in {pm= {cases = []; args = newargs; default = make_default (matcher_constr cstr) def} ; @@ -1225,7 +1388,7 @@ let make_variant_matching_constant p lab def ctx = function [] -> fatal_error "Matching.make_variant_matching_constant" - | ((arg, mut) :: argl) -> + | (_ :: argl) -> let def = make_default (matcher_variant_const lab) def and ctx = filter_ctx p ctx in {pm={ cases = []; args = argl ; default=def} ; @@ -1241,20 +1404,15 @@ let make_variant_matching_nonconst p lab def ctx = function [] -> fatal_error "Matching.make_variant_matching_nonconst" - | ((arg, mut) :: argl) -> + | ((arg, _mut) :: argl) -> let def = make_default (matcher_variant_nonconst lab) def and ctx = filter_ctx p ctx in {pm= - {cases = []; args = (Lprim(Pfield 1, [arg]), Alias) :: argl; + {cases = []; args = (Lprim(Pfield 1, [arg], p.pat_loc), Alias) :: argl; default=def} ; ctx=ctx ; pat = normalize_pat p} -let get_key_variant p = match p.pat_desc with -| Tpat_variant(lab, Some _ , _) -> Cstr_block (Btype.hash_variant lab) -| Tpat_variant(lab, None , _) -> Cstr_constant (Btype.hash_variant lab) -| _ -> assert false - let divide_variant row ctx {cases = cl; args = al; default=def} = let row = Btype.row_repr row in let rec divide = function @@ -1274,7 +1432,7 @@ add (make_variant_matching_nonconst p lab def ctx) variants (=) (Cstr_block tag) (pat :: patl, action) al end - | cl -> [] + | _ -> [] in divide cl @@ -1310,21 +1468,18 @@ | _ -> get_arg_lazy p rem (* Inlining the tag tests before calling the primitive that works on - lazy blocks. This is alse used in translcore.ml. - No call other than Obj.tag when the value has been forced before. + lazy blocks. This is also used in translcore.ml. + No other call than Obj.tag when the value has been forced before. *) let prim_obj_tag = - {prim_name = "caml_obj_tag"; - prim_arity = 1; prim_alloc = false; - prim_native_name = ""; - prim_native_float = false} + Primitive.simple ~name:"caml_obj_tag" ~arity:1 ~alloc:false let get_mod_field modname field = lazy ( try let mod_ident = Ident.create_persistent modname in - let env = Env.open_pers_signature modname Env.initial in + let env = Env.open_pers_signature modname Env.initial_safe_string in let p = try match Env.lookup_value (Longident.Lident field) env with | (Path.Pdot(_,_,i), _) -> i @@ -1332,7 +1487,9 @@ with Not_found -> fatal_error ("Primitive "^modname^"."^field^" not found.") in - Lprim(Pfield p, [Lprim(Pgetglobal mod_ident, [])]) + Lprim(Pfield p, + [Lprim(Pgetglobal mod_ident, [], Location.none)], + Location.none) with Not_found -> fatal_error ("Module "^modname^" unavailable.") ) @@ -1355,18 +1512,25 @@ let varg = Lvar idarg in let tag = Ident.create "tag" in let force_fun = Lazy.force code_force_lazy_block in - Llet(Strict, idarg, arg, - Llet(Alias, tag, Lprim(Pccall prim_obj_tag, [varg]), + Llet(Strict, Pgenval, idarg, arg, + Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg], loc), Lifthenelse( (* if (tag == Obj.forward_tag) then varg.(0) else ... *) Lprim(Pintcomp Ceq, - [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))]), - Lprim(Pfield 0, [varg]), + [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))], + loc), + Lprim(Pfield 0, [varg], loc), Lifthenelse( (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *) Lprim(Pintcomp Ceq, - [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))]), - Lapply(force_fun, [varg], loc), + [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))], + loc), + Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=force_fun; + ap_args=[varg]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}, (* ... arg *) varg)))) @@ -1374,17 +1538,22 @@ let idarg = Ident.create "lzarg" in let varg = Lvar idarg in let force_fun = Lazy.force code_force_lazy_block in - Llet(Strict, idarg, arg, + Llet(Strict, Pgenval, idarg, arg, Lifthenelse( - Lprim(Pisint, [varg]), varg, + Lprim(Pisint, [varg], loc), varg, (Lswitch (varg, { sw_numconsts = 0; sw_consts = []; sw_numblocks = 256; (* PR#6033 - tag ranges from 0 to 255 *) sw_blocks = - [ (Obj.forward_tag, Lprim(Pfield 0, [varg])); + [ (Obj.forward_tag, Lprim(Pfield 0, [varg], loc)); (Obj.lazy_tag, - Lapply(force_fun, [varg], loc)) ]; + Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=force_fun; + ap_args=[varg]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}) ]; sw_failaction = Some varg } )))) let inline_lazy_force arg loc = @@ -1398,7 +1567,7 @@ let make_lazy_matching def = function [] -> fatal_error "Matching.make_lazy_matching" - | (arg,mut) :: argl -> + | (arg,_mut) :: argl -> { cases = []; args = (inline_lazy_force arg Location.none, Strict) :: argl; @@ -1425,13 +1594,13 @@ | Tpat_var _ -> get_args_tuple arity omega rem | _ -> get_args_tuple arity p rem -let make_tuple_matching arity def = function +let make_tuple_matching loc arity def = function [] -> fatal_error "Matching.make_tuple_matching" - | (arg, mut) :: argl -> + | (arg, _mut) :: argl -> let rec make_args pos = if pos >= arity then argl - else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in + else (Lprim(Pfield pos, [arg], loc), Alias) :: make_args (pos + 1) in {cases = []; args = make_args 0 ; default=make_default (matcher_tuple arity) def} @@ -1439,14 +1608,14 @@ let divide_tuple arity p ctx pm = divide_line (filter_ctx p) - (make_tuple_matching arity) + (make_tuple_matching p.pat_loc arity) (get_args_tuple arity) p ctx pm (* Matching against a record pattern *) let record_matching_line num_fields lbl_pat_list = - let patv = Array.create num_fields omega in + let patv = Array.make num_fields omega in List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; Array.to_list patv @@ -1462,21 +1631,25 @@ | Tpat_var _ -> get_args_record num_fields omega rem | _ -> get_args_record num_fields p rem -let make_record_matching all_labels def = function +let make_record_matching loc all_labels def = function [] -> fatal_error "Matching.make_record_matching" - | ((arg, mut) :: argl) -> + | ((arg, _mut) :: argl) -> let rec make_args pos = if pos >= Array.length all_labels then argl else begin let lbl = all_labels.(pos) in let access = match lbl.lbl_repres with - Record_regular -> Pfield lbl.lbl_pos - | Record_float -> Pfloatfield lbl.lbl_pos in + | Record_regular | Record_inlined _ -> + Lprim (Pfield lbl.lbl_pos, [arg], loc) + | Record_unboxed _ -> arg + | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [arg], loc) + | Record_extension -> Lprim (Pfield (lbl.lbl_pos + 1), [arg], loc) + in let str = match lbl.lbl_mut with Immutable -> Alias | Mutable -> StrictOpt in - (Lprim(access, [arg]), str) :: make_args(pos + 1) + (access, str) :: make_args(pos + 1) end in let nfields = Array.length all_labels in let def= make_default (matcher_record nfields) def in @@ -1487,7 +1660,7 @@ let get_args = get_args_record (Array.length all_labels) in divide_line (filter_ctx p) - (make_record_matching all_labels) + (make_record_matching p.pat_loc all_labels) get_args p ctx pm @@ -1509,12 +1682,14 @@ let make_array_matching kind p def ctx = function | [] -> fatal_error "Matching.make_array_matching" - | ((arg, mut) :: argl) -> + | ((arg, _mut) :: argl) -> let len = get_key_array p in let rec make_args pos = if pos >= len then argl - else (Lprim(Parrayrefu kind, [arg; Lconst(Const_base(Const_int pos))]), + else (Lprim(Parrayrefu kind, + [arg; Lconst(Const_base(Const_int pos))], + p.pat_loc), StrictOpt) :: make_args (pos + 1) in let def = make_default (matcher_array len) def and ctx = filter_ctx p ctx in @@ -1527,10 +1702,163 @@ (make_array_matching kind) (=) get_key_array get_args_array ctx pm -(* To combine sub-matchings together *) + +(* + Specific string test sequence + Will be called by the bytecode compiler, from bytegen.ml. + The strategy is first dichotomic search (we perform 3-way tests + with compare_string), then sequence of equality tests + when there are less then T=strings_test_threshold static strings to match. + + Increasing T entails (slightly) less code, decreasing T + (slightly) favors runtime speed. + T=8 looks a decent tradeoff. +*) + +(* Utilities *) + +let strings_test_threshold = 8 + +let prim_string_notequal = + Pccall(Primitive.simple + ~name:"caml_string_notequal" + ~arity:2 + ~alloc:false) + +let prim_string_compare = + Pccall(Primitive.simple + ~name:"caml_string_compare" + ~arity:2 + ~alloc:false) + +let bind_sw arg k = match arg with +| Lvar _ -> k arg +| _ -> + let id = Ident.create "switch" in + Llet (Strict,Pgenval,id,arg,k (Lvar id)) + + +(* Sequential equality tests *) + +let make_string_test_sequence loc arg sw d = + let d,sw = match d with + | None -> + begin match sw with + | (_,d)::sw -> d,sw + | [] -> assert false + end + | Some d -> d,sw in + bind_sw arg + (fun arg -> + List.fold_right + (fun (s,lam) k -> + Lifthenelse + (Lprim + (prim_string_notequal, + [arg; Lconst (Const_immstring s)], loc), + k,lam)) + sw d) + +let rec split k xs = match xs with +| [] -> assert false +| x0::xs -> + if k <= 1 then [],x0,xs + else + let xs,y0,ys = split (k-2) xs in + x0::xs,y0,ys + +let zero_lam = Lconst (Const_base (Const_int 0)) + +let tree_way_test loc arg lt eq gt = + Lifthenelse + (Lprim (Pintcomp Clt,[arg;zero_lam], loc),lt, + Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg], loc),gt,eq)) + +(* Dichotomic tree *) + + +let rec do_make_string_test_tree loc arg sw delta d = + let len = List.length sw in + if len <= strings_test_threshold+delta then + make_string_test_sequence loc arg sw d + else + let lt,(s,act),gt = split len sw in + bind_sw + (Lprim + (prim_string_compare, + [arg; Lconst (Const_immstring s)], loc;)) + (fun r -> + tree_way_test loc r + (do_make_string_test_tree loc arg lt delta d) + act + (do_make_string_test_tree loc arg gt delta d)) + +(* Entry point *) +let expand_stringswitch loc arg sw d = match d with +| None -> + bind_sw arg + (fun arg -> do_make_string_test_tree loc arg sw 0 None) +| Some e -> + bind_sw arg + (fun arg -> + make_catch e + (fun d -> do_make_string_test_tree loc arg sw 1 (Some d))) + +(**********************) +(* Generic test trees *) +(**********************) + +(* Sharing *) + +(* Add handler, if shared *) +let handle_shared () = + let hs = ref (fun x -> x) in + let handle_shared act = match act with + | Switch.Single act -> act + | Switch.Shared act -> + let i,h = make_catch_delayed act in + let ohs = !hs in + hs := (fun act -> h (ohs act)) ; + make_exit i in + hs,handle_shared + + +let share_actions_tree sw d = + let store = StoreExp.mk_store () in +(* Default action is always shared *) + let d = + match d with + | None -> None + | Some d -> Some (store.Switch.act_store_shared d) in +(* Store all other actions *) + let sw = + List.map (fun (cst,act) -> cst,store.Switch.act_store act) sw in + +(* Retrieve all actions, including potentiel default *) + let acts = store.Switch.act_get_shared () in + +(* Array of actual actions *) + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + +(* Reconstruct default and switch list *) + let d = match d with + | None -> None + | Some d -> Some (acts.(d)) in + let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in + !hs,sw,d + +(* Note: dichotomic search requires sorted input with no duplicates *) +let rec uniq_lambda_list sw = match sw with + | []|[_] -> sw + | (c1,_ as p1)::((c2,_)::sw2 as sw1) -> + if const_compare c1 c2 = 0 then uniq_lambda_list (p1::sw2) + else p1::uniq_lambda_list sw1 let sort_lambda_list l = - List.sort (fun (x,_) (y,_) -> const_compare x y) l + let l = + List.stable_sort (fun (x,_) (y,_) -> const_compare x y) l in + uniq_lambda_list l let rec cut n l = if n = 0 then [],l @@ -1538,146 +1866,45 @@ [] -> raise (Invalid_argument "cut") | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2 -let rec do_tests_fail fail tst arg = function +let rec do_tests_fail loc fail tst arg = function | [] -> fail | (c, act)::rem -> Lifthenelse - (Lprim (tst, [arg ; Lconst (Const_base c)]), - do_tests_fail fail tst arg rem, + (Lprim (tst, [arg ; Lconst (Const_base c)], loc), + do_tests_fail loc fail tst arg rem, act) -let rec do_tests_nofail tst arg = function +let rec do_tests_nofail loc tst arg = function | [] -> fatal_error "Matching.do_tests_nofail" | [_,act] -> act | (c,act)::rem -> Lifthenelse - (Lprim (tst, [arg ; Lconst (Const_base c)]), - do_tests_nofail tst arg rem, + (Lprim (tst, [arg ; Lconst (Const_base c)], loc), + do_tests_nofail loc tst arg rem, act) -let make_test_sequence fail tst lt_tst arg const_lambda_list = +let make_test_sequence loc fail tst lt_tst arg const_lambda_list = + let const_lambda_list = sort_lambda_list const_lambda_list in + let hs,const_lambda_list,fail = + share_actions_tree const_lambda_list fail in + let rec make_test_sequence const_lambda_list = - if List.length const_lambda_list >= 4 && lt_tst <> Praise then + if List.length const_lambda_list >= 4 && lt_tst <> Pignore then split_sequence const_lambda_list else match fail with - | None -> do_tests_nofail tst arg const_lambda_list - | Some fail -> do_tests_fail fail tst arg const_lambda_list + | None -> do_tests_nofail loc tst arg const_lambda_list + | Some fail -> do_tests_fail loc fail tst arg const_lambda_list and split_sequence const_lambda_list = let list1, list2 = cut (List.length const_lambda_list / 2) const_lambda_list in - Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]), + Lifthenelse(Lprim(lt_tst, + [arg; Lconst(Const_base (fst(List.hd list2)))], + loc), make_test_sequence list1, make_test_sequence list2) - in make_test_sequence (sort_lambda_list const_lambda_list) - - -let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg]) - - - -let prim_string_notequal = - Pccall{prim_name = "caml_string_notequal"; - prim_arity = 2; prim_alloc = false; - prim_native_name = ""; prim_native_float = false} - -let rec explode_inter offset i j act k = - if i <= j then - explode_inter offset i (j-1) act ((j-offset,act)::k) - else - k + in + hs (make_test_sequence const_lambda_list) -let max_vals cases acts = - let vals = Array.create (Array.length acts) 0 in - for i=Array.length cases-1 downto 0 do - let l,h,act = cases.(i) in - vals.(act) <- h - l + 1 + vals.(act) - done ; - let max = ref 0 in - for i = Array.length vals-1 downto 0 do - if vals.(i) >= vals.(!max) then - max := i - done ; - if vals.(!max) > 1 then - !max - else - -1 - -let as_int_list cases acts = - let default = max_vals cases acts in - let min_key,_,_ = cases.(0) - and _,max_key,_ = cases.(Array.length cases-1) in - - let rec do_rec i k = - if i >= 0 then - let low, high, act = cases.(i) in - if act = default then - do_rec (i-1) k - else - do_rec (i-1) (explode_inter min_key low high acts.(act) k) - else - k in - min_key, max_key,do_rec (Array.length cases-1) [], - (if default >= 0 then Some acts.(default) else None) - - -let make_switch_offset arg min_key max_key int_lambda_list default = - let numcases = max_key - min_key + 1 in - let cases = - List.map (fun (key, l) -> (key - min_key, l)) int_lambda_list in - let offsetarg = make_offset (-min_key) arg in - Lswitch(offsetarg, - {sw_numconsts = numcases; sw_consts = cases; - sw_numblocks = 0; sw_blocks = []; - sw_failaction = default}) - -let make_switch_switcher arg cases acts = - let l = ref [] in - for i = Array.length cases-1 downto 0 do - l := (i,acts.(cases.(i))) :: !l - done ; - Lswitch(arg, - {sw_numconsts = Array.length cases ; sw_consts = !l ; - sw_numblocks = 0 ; sw_blocks = [] ; - sw_failaction = None}) - -let full sw = - List.length sw.sw_consts = sw.sw_numconsts && - List.length sw.sw_blocks = sw.sw_numblocks - -let make_switch (arg,sw) = match sw.sw_failaction with -| None -> - let t = Hashtbl.create 17 in - let seen l = match l with - | Lstaticraise (i,[]) -> - let old = try Hashtbl.find t i with Not_found -> 0 in - Hashtbl.replace t i (old+1) - | _ -> () in - List.iter (fun (_,lam) -> seen lam) sw.sw_consts ; - List.iter (fun (_,lam) -> seen lam) sw.sw_blocks ; - let i_max = ref (-1) - and max = ref (-1) in - Hashtbl.iter - (fun i c -> - if c > !max then begin - i_max := i ; - max := c - end) t ; - if !i_max >= 0 then - let default = !i_max in - let rec remove = function - | [] -> [] - | (_,Lstaticraise (j,[]))::rem when j=default -> - remove rem - | x::rem -> x::remove rem in - Lswitch - (arg, - {sw with -sw_consts = remove sw.sw_consts ; -sw_blocks = remove sw.sw_blocks ; -sw_failaction = Some (Lstaticraise (default,[]))}) - else - Lswitch (arg,sw) -| _ -> Lswitch (arg,sw) module SArg = struct type primitive = Lambda.primitive @@ -1691,10 +1918,11 @@ type act = Lambda.lambda - let make_prim p args = Lprim (p,args) + let make_prim p args = Lprim (p,args,Location.none) let make_offset arg n = match n with | 0 -> arg - | _ -> Lprim (Poffsetint n,[arg]) + | _ -> Lprim (Poffsetint n,[arg],Location.none) + let bind arg body = let newvar,newarg = match arg with | Lvar v -> v,arg @@ -1702,18 +1930,92 @@ let newvar = Ident.create "switcher" in newvar,Lvar newvar in bind Alias newvar arg (body newarg) - - let make_isout h arg = Lprim (Pisout, [h ; arg]) - let make_isin h arg = Lprim (Pnot,[make_isout h arg]) + let make_const i = Lconst (Const_base (Const_int i)) + let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none) + let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - let make_switch = make_switch_switcher + let make_switch arg cases acts = + let l = ref [] in + for i = Array.length cases-1 downto 0 do + l := (i,acts.(cases.(i))) :: !l + done ; + Lswitch(arg, + {sw_numconsts = Array.length cases ; sw_consts = !l ; + sw_numblocks = 0 ; sw_blocks = [] ; + sw_failaction = None}) + let make_catch = make_catch_delayed + let make_exit = make_exit + end +(* Action sharing for Lswitch argument *) +let share_actions_sw sw = +(* Attempt sharing on all actions *) + let store = StoreExp.mk_store () in + let fail = match sw.sw_failaction with + | None -> None + | Some fail -> + (* Fail is translated to exit, whatever happens *) + Some (store.Switch.act_store_shared fail) in + let consts = + List.map + (fun (i,e) -> i,store.Switch.act_store e) + sw.sw_consts + and blocks = + List.map + (fun (i,e) -> i,store.Switch.act_store e) + sw.sw_blocks in + let acts = store.Switch.act_get_shared () in + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + let fail = match fail with + | None -> None + | Some fail -> Some (acts.(fail)) in + !hs, + { sw with + sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ; + sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ; + sw_failaction = fail; } + +(* Reintroduce fail action in switch argument, + for the sake of avoiding carrying over huge switches *) + +let reintroduce_fail sw = match sw.sw_failaction with +| None -> + let t = Hashtbl.create 17 in + let seen (_,l) = match as_simple_exit l with + | Some i -> + let old = try Hashtbl.find t i with Not_found -> 0 in + Hashtbl.replace t i (old+1) + | None -> () in + List.iter seen sw.sw_consts ; + List.iter seen sw.sw_blocks ; + let i_max = ref (-1) + and max = ref (-1) in + Hashtbl.iter + (fun i c -> + if c > !max then begin + i_max := i ; + max := c + end) t ; + if !max >= 3 then + let default = !i_max in + let remove = + List.filter + (fun (_,lam) -> match as_simple_exit lam with + | Some j -> j <> default + | None -> true) in + {sw with + sw_consts = remove sw.sw_consts ; + sw_blocks = remove sw.sw_blocks ; + sw_failaction = Some (make_exit default)} + else sw +| Some _ -> sw + + module Switcher = Switch.Make(SArg) open Switch -let lambda_of_int i = Lconst (Const_base (Const_int i)) - let rec last def = function | [] -> def | [x,_] -> x @@ -1725,7 +2027,16 @@ let as_interval_canfail fail low high l = - let store = mk_store equal_action in + let store = StoreExp.mk_store () in + + let do_store _tag act = + + let i = store.act_store act in +(* + eprintf "STORE [%s] %i %s\n" tag i (string_of_lam act) ; +*) + i in + let rec nofail_rec cur_low cur_high cur_act = function | [] -> if cur_high = high then @@ -1733,7 +2044,7 @@ else [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)] | ((i,act_i)::rem) as all -> - let act_index = store.act_store act_i in + let act_index = do_store "NO" act_i in if cur_high+1= i then if act_index=cur_act then nofail_rec cur_low i cur_act rem @@ -1741,23 +2052,27 @@ (cur_low,i-1, cur_act)::fail_rec i i rem else (cur_low, i-1, cur_act)::nofail_rec i i act_index rem + else if act_index = 0 then + (cur_low, cur_high, cur_act):: + fail_rec (cur_high+1) (cur_high+1) all else (cur_low, cur_high, cur_act):: - fail_rec ((cur_high+1)) (cur_high+1) all + (cur_high+1,i-1,0):: + nofail_rec i i act_index rem and fail_rec cur_low cur_high = function | [] -> [(cur_low, cur_high, 0)] | (i,act_i)::rem -> - let index = store.act_store act_i in + let index = do_store "YES" act_i in if index=0 then fail_rec cur_low i rem else (cur_low,i-1,0):: nofail_rec i i index rem in let init_rec = function - | [] -> [] + | [] -> [low,high,0] | (i,act_i)::rem -> - let index = store.act_store act_i in + let index = do_store "INIT" act_i in if index=0 then fail_rec low i rem else @@ -1766,13 +2081,16 @@ else nofail_rec i i index rem in - ignore (store.act_store fail) ; (* fail has action index 0 *) + assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *) let r = init_rec l in - Array.of_list r, store.act_get () + Array.of_list r, store let as_interval_nofail l = - let store = mk_store equal_action in - + let store = StoreExp.mk_store () in + let rec some_hole = function + | []|[_] -> false + | (i,_)::((j,_)::_ as rem) -> + j > i+1 || some_hole rem in let rec i_rec cur_low cur_high cur_act = function | [] -> [cur_low, cur_high, cur_act] @@ -1785,11 +2103,20 @@ i_rec i i act_index rem in let inters = match l with | (i,act)::rem -> - let act_index = store.act_store act in + let act_index = + (* In case there is some hole and that a switch is emitted, + action 0 will be used as the action of unreacheable + cases (cf. switch.ml, make_switch). + Hence, this action will be shared *) + if some_hole rem then + store.act_store_shared act + else + store.act_store act in + assert (act_index = 0) ; i_rec i i act_index rem | _ -> assert false in - Array.of_list inters, store.act_get () + Array.of_list inters, store let sort_int_lambda_list l = @@ -1807,18 +2134,11 @@ | None -> as_interval_nofail l | Some act -> as_interval_canfail act low high l) -let call_switcher konst fail arg low high int_lambda_list = +let call_switcher fail arg low high int_lambda_list = let edges, (cases, actions) = as_interval fail low high int_lambda_list in - Switcher.zyva edges konst arg cases actions - + Switcher.zyva edges arg cases actions -let exists_ctx ok ctx = - List.exists - (function - | {right=p::_} -> ok p - | _ -> assert false) - ctx let rec list_as_pat = function | [] -> fatal_error "Matching.list_as_pat" @@ -1827,41 +2147,6 @@ {pat with pat_desc = Tpat_or (pat,list_as_pat rem,None)} -let rec pat_as_list k = function - | {pat_desc=Tpat_or (p1,p2,_)} -> - pat_as_list (pat_as_list k p2) p1 - | p -> p::k - -(* Extracting interesting patterns *) -exception All - -let rec extract_pat seen k p = match p.pat_desc with -| Tpat_or (p1,p2,_) -> - let k1,seen1 = extract_pat seen k p1 in - extract_pat seen1 k1 p2 -| Tpat_alias (p,_,_) -> - extract_pat seen k p -| Tpat_var _|Tpat_any -> - raise All -| _ -> - let q = normalize_pat p in - if List.exists (compat q) seen then - k, seen - else - q::k, q::seen - -let extract_mat seen pss = - let r,_ = - List.fold_left - (fun (k,seen) ps -> match ps with - | p::_ -> extract_pat seen k p - | _ -> assert false) - ([],seen) - pss in - r - - - let complete_pats_constrs = function | p::_ as pats -> List.map @@ -1870,33 +2155,6 @@ | _ -> assert false -let mk_res get_key env last_choice idef cant_fail ctx = - - let env,fail,jumps_fail = match last_choice with - | [] -> - env, None, jumps_empty - | [p] when group_var p -> - env, - Some (Lstaticraise (idef,[])), - jumps_singleton idef ctx - | _ -> - (idef,cant_fail,last_choice)::env, - None, jumps_empty in - let klist,jumps = - List.fold_right - (fun (i,cant_fail,pats) (klist,jumps) -> - let act = Lstaticraise (i,[]) - and pat = list_as_pat pats in - let klist = - List.fold_right - (fun pat klist -> (get_key pat,act)::klist) - pats klist - and ctx = if cant_fail then ctx else ctx_lub pat ctx in - klist,jumps_add i ctx jumps) - env ([],jumps_fail) in - fail, klist, jumps - - (* Following two ``failaction'' function compute n, the trap handler to jump to in case of failure of elementary tests @@ -1906,20 +2164,25 @@ | Partial -> begin match def with | (_,idef)::_ -> - Some (Lstaticraise (idef,[])),[],jumps_singleton idef ctx - | _ -> + Some (Lstaticraise (idef,[])),jumps_singleton idef ctx + | [] -> (* Act as Total, this means If no appropriate default matrix exists, then this switch cannot fail *) - None, [], jumps_empty + None, jumps_empty end | Total -> - None, [], jumps_empty + None, jumps_empty -(* Conforme a l'article et plus simple qu'avant *) -and mk_failaction_pos partial seen ctx defs = +(* In line with the article and simpler than before *) +let mk_failaction_pos partial seen ctx defs = + if dbg then begin + prerr_endline "**POS**" ; + pretty_def defs ; + () + end ; let rec scan_def env to_test defs = match to_test,defs with | ([],_)|(_,[]) -> List.fold_left @@ -1936,60 +2199,84 @@ | _,(pss,idef)::rem -> let now, later = List.partition - (fun (p,p_ctx) -> ctx_match p_ctx pss) to_test in + (fun (_p,p_ctx) -> ctx_match p_ctx pss) to_test in match now with | [] -> scan_def env to_test rem | _ -> scan_def ((List.map fst now,idef)::env) later rem in - scan_def - [] - (List.map - (fun pat -> pat, ctx_lub pat ctx) - (complete_pats_constrs seen)) - defs - + let fail_pats = complete_pats_constrs seen in + if List.length fail_pats < 32 then begin + let fail,jmps = + scan_def + [] + (List.map + (fun pat -> pat, ctx_lub pat ctx) + fail_pats) + defs in + if dbg then begin + eprintf "POSITIVE JUMPS [%i]:\n" (List.length fail_pats); + pretty_jumps jmps + end ; + None,fail,jmps + end else begin (* Too many non-matched constructors -> reduced information *) + if dbg then eprintf "POS->NEG!!!\n%!" ; + let fail,jumps = mk_failaction_neg partial ctx defs in + if dbg then + eprintf "FAIL: %s\n" + (match fail with + | None -> "" + | Some lam -> string_of_lam lam) ; + fail,[],jumps + end -let combine_constant arg cst partial ctx def - (const_lambda_list, total, pats) = - let fail, to_add, local_jumps = +let combine_constant loc arg cst partial ctx def + (const_lambda_list, total, _pats) = + let fail, local_jumps = mk_failaction_neg partial ctx def in - let const_lambda_list = to_add@const_lambda_list in let lambda1 = match cst with | Const_int _ -> let int_lambda_list = List.map (function Const_int n, l -> n,l | _ -> assert false) const_lambda_list in - call_switcher - lambda_of_int fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list | Const_char _ -> let int_lambda_list = List.map (function Const_char c, l -> (Char.code c, l) | _ -> assert false) const_lambda_list in - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - fail arg 0 255 int_lambda_list + call_switcher fail arg 0 255 int_lambda_list | Const_string _ -> - make_test_sequence - fail prim_string_notequal Praise arg const_lambda_list +(* Note as the bytecode compiler may resort to dichotomic search, + the clauses of stringswitch are sorted with duplicates removed. + This partly applies to the native code compiler, which requires + no duplicates *) + let const_lambda_list = sort_lambda_list const_lambda_list in + let sw = + List.map + (fun (c,act) -> match c with + | Const_string (s,_) -> s,act + | _ -> assert false) + const_lambda_list in + let hs,sw,fail = share_actions_tree sw fail in + hs (Lstringswitch (arg,sw,fail,loc)) | Const_float _ -> - make_test_sequence + make_test_sequence loc fail (Pfloatcomp Cneq) (Pfloatcomp Clt) arg const_lambda_list | Const_int32 _ -> - make_test_sequence + make_test_sequence loc fail (Pbintcomp(Pint32, Cneq)) (Pbintcomp(Pint32, Clt)) arg const_lambda_list | Const_int64 _ -> - make_test_sequence + make_test_sequence loc fail (Pbintcomp(Pint64, Cneq)) (Pbintcomp(Pint64, Clt)) arg const_lambda_list | Const_nativeint _ -> - make_test_sequence + make_test_sequence loc fail (Pbintcomp(Pnativeint, Cneq)) (Pbintcomp(Pnativeint, Clt)) arg const_lambda_list @@ -2005,102 +2292,139 @@ match cstr with Cstr_constant n -> ((n, act) :: consts, nonconsts) | Cstr_block n -> (consts, (n, act) :: nonconsts) - | _ -> assert false in + | Cstr_unboxed -> (consts, (0, act) :: nonconsts) + | Cstr_extension _ -> assert false in let const, nonconst = split_rec tag_lambda_list in sort_int_lambda_list const, sort_int_lambda_list nonconst +let split_extension_cases tag_lambda_list = + let rec split_rec = function + [] -> ([], []) + | (cstr, act) :: rem -> + let (consts, nonconsts) = split_rec rem in + match cstr with + Cstr_extension(path, true) -> ((path, act) :: consts, nonconsts) + | Cstr_extension(path, false) -> (consts, (path, act) :: nonconsts) + | _ -> assert false in + split_rec tag_lambda_list -let combine_constructor arg ex_pat cstr partial ctx def + +let combine_constructor loc arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = if cstr.cstr_consts < 0 then begin - (* Special cases for exceptions *) - let fail, to_add, local_jumps = + (* Special cases for extensions *) + let fail, local_jumps = mk_failaction_neg partial ctx def in - let tag_lambda_list = to_add@tag_lambda_list in let lambda1 = - let default, tests = + let consts, nonconsts = split_extension_cases tag_lambda_list in + let default, consts, nonconsts = match fail with | None -> - begin match tag_lambda_list with - | (_, act)::rem -> act,rem + begin match consts, nonconsts with + | _, (_, act)::rem -> act, consts, rem + | (_, act)::rem, _ -> act, rem, nonconsts | _ -> assert false end - | Some fail -> fail, tag_lambda_list in - List.fold_right - (fun (ex, act) rem -> - match ex with - | Cstr_exception (path, _) -> - Lifthenelse(Lprim(Pintcomp Ceq, - [Lprim(Pfield 0, [arg]); transl_path path]), - act, rem) - | _ -> assert false) - tests default in + | Some fail -> fail, consts, nonconsts in + let nonconst_lambda = + match nonconsts with + [] -> default + | _ -> + let tag = Ident.create "tag" in + let tests = + List.fold_right + (fun (path, act) rem -> + Lifthenelse(Lprim(Pintcomp Ceq, + [Lvar tag; + transl_path ex_pat.pat_env path], loc), + act, rem)) + nonconsts + default + in + Llet(Alias, Pgenval,tag, Lprim(Pfield 0, [arg], loc), tests) + in + List.fold_right + (fun (path, act) rem -> + Lifthenelse(Lprim(Pintcomp Ceq, + [arg; transl_path ex_pat.pat_env path], loc), + act, rem)) + consts + nonconst_lambda + in lambda1, jumps_union local_jumps total1 end else begin (* Regular concrete type *) let ncases = List.length tag_lambda_list and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in let sig_complete = ncases = nconstrs in - let fails,local_jumps = - if sig_complete then [],jumps_empty + let fail_opt,fails,local_jumps = + if sig_complete then None,[],jumps_empty else mk_failaction_pos partial pats ctx def in let tag_lambda_list = fails @ tag_lambda_list in let (consts, nonconsts) = split_cases tag_lambda_list in let lambda1 = - match same_actions tag_lambda_list with - | Some act -> act + match fail_opt,same_actions tag_lambda_list with + | None,Some act -> act (* Identical actions, no failure *) | _ -> match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with | (1, 1, [0, act1], [0, act2]) -> + (* Typically, match on lists, will avoid isint primitive in that + case *) Lifthenelse(arg, act2, act1) - | (n,_,_,[]) -> - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - None arg 0 (n-1) consts + | (n,0,_,[]) -> (* The type defines constant constructors only *) + call_switcher fail_opt arg 0 (n-1) consts | (n, _, _, _) -> - match same_actions nonconsts with - | None -> - make_switch(arg, {sw_numconsts = cstr.cstr_consts; - sw_consts = consts; - sw_numblocks = cstr.cstr_nonconsts; - sw_blocks = nonconsts; - sw_failaction = None}) + let act0 = + (* = Some act when all non-const constructors match to act *) + match fail_opt,nonconsts with + | Some a,[] -> Some a + | Some _,_ -> + if List.length nonconsts = cstr.cstr_nonconsts then + same_actions nonconsts + else None + | None,_ -> same_actions nonconsts in + match act0 with | Some act -> Lifthenelse - (Lprim (Pisint, [arg]), + (Lprim (Pisint, [arg], loc), call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - None arg + fail_opt arg 0 (n-1) consts, - act) in + act) +(* Emit a switch, as bytecode implements this sophisticated instruction *) + | None -> + let sw = + {sw_numconsts = cstr.cstr_consts; sw_consts = consts; + sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts; + sw_failaction = fail_opt} in + let hs,sw = share_actions_sw sw in + let sw = reintroduce_fail sw in + hs (Lswitch (arg,sw)) in lambda1, jumps_union local_jumps total1 end let make_test_sequence_variant_constant fail arg int_lambda_list = let _, (cases, actions) = as_interval fail min_int max_int int_lambda_list in - Switcher.test_sequence - (fun i -> Lconst (Const_base (Const_int i))) arg cases actions + Switcher.test_sequence arg cases actions let call_switcher_variant_constant fail arg int_lambda_list = - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list -let call_switcher_variant_constr fail arg int_lambda_list = +let call_switcher_variant_constr loc fail arg int_lambda_list = let v = Ident.create "variant" in - Llet(Alias, v, Lprim(Pfield 0, [arg]), + Llet(Alias, Pgenval, v, Lprim(Pfield 0, [arg], loc), call_switcher - (fun i -> Lconst (Const_base (Const_int i))) fail (Lvar v) min_int max_int int_lambda_list) -let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = +let combine_variant loc row arg partial ctx def + (tag_lambda_list, total1, _pats) = let row = Btype.row_repr row in let num_constr = ref 0 in if row.row_closed then @@ -2113,28 +2437,27 @@ else num_constr := max_int; let test_int_or_block arg if_int if_block = - Lifthenelse(Lprim (Pisint, [arg]), if_int, if_block) in + Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) in let sig_complete = List.length tag_lambda_list = !num_constr and one_action = same_actions tag_lambda_list in - let fail, to_add, local_jumps = + let fail, local_jumps = if sig_complete || (match partial with Total -> true | _ -> false) then - None, [], jumps_empty + None, jumps_empty else mk_failaction_neg partial ctx def in - let tag_lambda_list = to_add@tag_lambda_list in let (consts, nonconsts) = split_cases tag_lambda_list in let lambda1 = match fail, one_action with | None, Some act -> act | _,_ -> match (consts, nonconsts) with - | ([n, act1], [m, act2]) when fail=None -> + | ([_, act1], [_, act2]) when fail=None -> test_int_or_block arg act1 act2 | (_, []) -> (* One can compare integers and pointers *) make_test_sequence_variant_constant fail arg consts | ([], _) -> - let lam = call_switcher_variant_constr + let lam = call_switcher_variant_constr loc fail arg nonconsts in (* One must not dereference integers *) begin match fail with @@ -2146,26 +2469,24 @@ call_switcher_variant_constant fail arg consts and lam_nonconst = - call_switcher_variant_constr + call_switcher_variant_constr loc fail arg nonconsts in test_int_or_block arg lam_const lam_nonconst in lambda1, jumps_union local_jumps total1 -let combine_array arg kind partial ctx def - (len_lambda_list, total1, pats) = - let fail, to_add, local_jumps = mk_failaction_neg partial ctx def in - let len_lambda_list = to_add @ len_lambda_list in +let combine_array loc arg kind partial ctx def + (len_lambda_list, total1, _pats) = + let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = let newvar = Ident.create "len" in let switch = call_switcher - lambda_of_int fail (Lvar newvar) 0 max_int len_lambda_list in bind - Alias newvar (Lprim(Parraylength kind, [arg])) switch in + Alias newvar (Lprim(Parraylength kind, [arg], loc)) switch in lambda1, jumps_union local_jumps total1 (* Insertion of debugging events *) @@ -2180,10 +2501,10 @@ lev_kind = ev.lev_kind; lev_repr = repr; lev_env = ev.lev_env}) - | (Llet(str, id, lam, body), _) -> - Llet(str, id, lam, event_branch repr body) + | (Llet(str, k, id, lam, body), _) -> + Llet(str, k, id, lam, event_branch repr body) | Lstaticraise _,_ -> lam - | (_, Some r) -> + | (_, Some _) -> Printlambda.lambda Format.str_formatter lam ; fatal_error ("Matching.event_branch: "^Format.flush_str_formatter ()) @@ -2194,11 +2515,11 @@ This exception is raised when the compiler cannot produce code because control cannot reach the compiled clause, - Unused is raised initialy in compile_test. + Unused is raised initially in compile_test. compile_list (for compiling switch results) catch Unused - comp_match_handlers (for compililing splitted matches) + comp_match_handlers (for compiling splitted matches) may reraise Unused @@ -2260,8 +2581,8 @@ match c_div with | [],_,_ -> begin match mk_failaction_neg partial ctx to_match.default with - | None,_,_ -> raise Unused - | Some l,_,total -> l,total + | None,_ -> raise Unused + | Some l,total -> l,total end | _ -> combine ctx to_match.default c_div @@ -2273,17 +2594,13 @@ | Lconst _ -> false | Lstaticraise (_,args) -> List.exists (fun lam -> approx_present v lam) args - | Lprim (_,args) -> + | Lprim (_,args,_) -> List.exists (fun lam -> approx_present v lam) args - | Llet (Alias, _, l1, l2) -> + | Llet (Alias, _k, _, l1, l2) -> approx_present v l1 || approx_present v l2 | Lvar vv -> Ident.same v vv | _ -> true -let string_of_lam lam = - Printlambda.lambda Format.str_formatter lam ; - Format.flush_str_formatter () - let rec lower_bind v arg lam = match lam with | Lifthenelse (cond, ifso, ifnot) -> let pcond = approx_present v cond @@ -2303,11 +2620,11 @@ | Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw)) when not (approx_present v ls) -> Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]}) -| Llet (Alias, vv, lv, l) -> +| Llet (Alias, k, vv, lv, l) -> if approx_present v lv then bind Alias v arg lam else - Llet (Alias, vv, lv, lower_bind v arg l) + Llet (Alias, k, vv, lv, lower_bind v arg l) | _ -> bind Alias v arg lam @@ -2328,7 +2645,7 @@ | rem -> let rec c_rec body total_body = function | [] -> body, total_body - (* Hum, -1 meant never taken + (* Hum, -1 means never taken | (-1,pm)::rem -> c_rec body total_body rem *) | (i,pm)::rem -> let ctx_i,total_rem = jumps_extract i total_body in @@ -2359,10 +2676,10 @@ (* To find reasonable names for variables *) let rec name_pattern default = function - (pat :: patl, action) :: rem -> + (pat :: _, _) :: rem -> begin match pat.pat_desc with Tpat_var (id, _) -> id - | Tpat_alias(p, id, _) -> id + | Tpat_alias(_, id, _) -> id | _ -> name_pattern default rem end | _ -> Ident.create default @@ -2385,10 +2702,8 @@ Output: a lambda term, a jump summary {..., exit number -> context, .. } *) -let dbg = false - let rec compile_match repr partial ctx m = match m with -| { cases = [] } -> comp_exit ctx m +| { cases = []; args = [] } -> comp_exit ctx m | { cases = ([], action) :: rem } -> if is_guarded action then begin let (lambda, total) = @@ -2442,26 +2757,27 @@ compile_test (compile_match repr partial) partial divide_constant - (combine_constant arg cst partial) + (combine_constant pat.pat_loc arg cst partial) ctx pm - | Tpat_construct (_, cstr, _, _) -> + | Tpat_construct (_, cstr, _) -> compile_test (compile_match repr partial) partial - divide_constructor (combine_constructor arg pat cstr partial) + divide_constructor + (combine_constructor pat.pat_loc arg pat cstr partial) ctx pm | Tpat_array _ -> let kind = Typeopt.array_pattern_kind pat in compile_test (compile_match repr partial) partial - (divide_array kind) (combine_array arg kind partial) + (divide_array kind) (combine_array pat.pat_loc arg kind partial) ctx pm | Tpat_lazy _ -> compile_no_test (divide_lazy (normalize_pat pat)) ctx_combine repr partial ctx pm - | Tpat_variant(lab, _, row) -> + | Tpat_variant(_, _, row) -> compile_test (compile_match repr partial) partial (divide_variant !row) - (combine_variant !row arg partial) + (combine_variant pat.pat_loc !row arg partial) ctx pm | _ -> assert false end @@ -2490,15 +2806,15 @@ Notice that exhaustiveness information is trusted by the compiler, that is, a match flagged as Total should not fail at runtime. - More specifically, for instance if match y with x::_ -> x uis flagged + More specifically, for instance if match y with x::_ -> x is flagged total (as it happens during JoCaml compilation) then y cannot be [] at runtime. As a consequence, the static Total exhaustiveness information - have to to be downgraded to Partial, in the dubious cases where guards + have to be downgraded to Partial, in the dubious cases where guards or lazy pattern execute arbitrary code that may perform side effects and change the subject values. LM: Lazy pattern was PR #5992, initial patch by lwp25. - I have generalized teh patch, so as to also find mutable fields. + I have generalized the patch, so as to also find mutable fields. *) let find_in_pat pred = @@ -2507,7 +2823,7 @@ begin match p.pat_desc with | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p -> find_rec p - | Tpat_tuple ps|Tpat_construct (_,_,ps,_) | Tpat_array ps -> + | Tpat_tuple ps|Tpat_construct (_,_,ps) | Tpat_array ps -> List.exists find_rec ps | Tpat_record (lpats,_) -> List.exists @@ -2554,6 +2870,7 @@ | Partial -> Partial | Total -> if + pat_act_list = [] || (* allow empty case list *) List.exists (fun (pats, lam) -> is_mutable pats && (is_guarded lam || is_lazy pats)) @@ -2576,7 +2893,7 @@ Lstaticcatch(lambda, (i,[]), handler_fun()) end -let compile_matching loc repr handler_fun arg pat_act_list partial = +let compile_matching repr handler_fun arg pat_act_list partial = let partial = check_partial pat_act_list partial in match partial with | Partial -> @@ -2604,23 +2921,153 @@ let partial_function loc () = (* [Location.get_pos_info] is too expensive *) let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in - Lprim(Praise, [Lprim(Pmakeblock(0, Immutable), - [transl_path Predef.path_match_failure; + Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable, None), + [transl_normal_path Predef.path_match_failure; Lconst(Const_block(0, - [Const_base(Const_string fname); + [Const_base(Const_string (fname, None)); Const_base(Const_int line); - Const_base(Const_int char)]))])]) + Const_base(Const_int char)]))], loc)], loc) let for_function loc repr param pat_act_list partial = - compile_matching loc repr (partial_function loc) param pat_act_list partial + compile_matching repr (partial_function loc) param pat_act_list partial (* In the following two cases, exhaustiveness info is not available! *) let for_trywith param pat_act_list = - compile_matching Location.none None (fun () -> Lprim(Praise, [param])) + compile_matching None + (fun () -> Lprim(Praise Raise_reraise, [param], Location.none)) param pat_act_list Partial +let simple_for_let loc param pat body = + compile_matching None (partial_function loc) param [pat, body] Partial + + +(* Optimize binding of immediate tuples + + The goal of the implementation of 'for_let' below, which replaces + 'simple_for_let', is to avoid tuple allocation in cases such as + this one: + + let (x,y) = + let foo = ... in + if foo then (1, 2) else (3,4) + in bar + + The compiler easily optimizes the simple `let (x,y) = (1,2) in ...` + case (call to Matching.for_multiple_match from Translcore), but + didn't optimize situations where the rhs tuples are hidden under + a more complex context. + + The idea comes from Alain Frisch who suggested and implemented + the following compilation method, based on Lassign: + + let x = dummy in let y = dummy in + begin + let foo = ... in + if foo then + (let x1 = 1 in let y1 = 2 in x <- x1; y <- y1) + else + (let x2 = 3 in let y2 = 4 in x <- x2; y <- y2) + end; + bar + + The current implementation from Gabriel Scherer uses Lstaticcatch / + Lstaticraise instead: + + catch + let foo = ... in + if foo then + (let x1 = 1 in let y1 = 2 in exit x1 y1) + else + (let x2 = 3 in let y2 = 4 in exit x2 y2) + with x y -> + bar + + The catch/exit is used to avoid duplication of the let body ('bar' + in the example), on 'if' branches for example; it is useless for + linear contexts such as 'let', but we don't need to be careful to + generate nice code because Simplif will remove such useless + catch/exit. +*) + +let rec map_return f = function + | Llet (str, k, id, l1, l2) -> Llet (str, k, id, l1, map_return f l2) + | Lletrec (l1, l2) -> Lletrec (l1, map_return f l2) + | Lifthenelse (lcond, lthen, lelse) -> + Lifthenelse (lcond, map_return f lthen, map_return f lelse) + | Lsequence (l1, l2) -> Lsequence (l1, map_return f l2) + | Levent (l, ev) -> Levent (map_return f l, ev) + | Ltrywith (l1, id, l2) -> Ltrywith (map_return f l1, id, map_return f l2) + | Lstaticcatch (l1, b, l2) -> + Lstaticcatch (map_return f l1, b, map_return f l2) + | Lstaticraise _ | Lprim(Praise _, _, _) as l -> l + | l -> f l + +(* The 'opt' reference indicates if the optimization is worthy. + + It is shared by the different calls to 'assign_pat' performed from + 'map_return'. For example with the code + let (x, y) = if foo then z else (1,2) + the else-branch will activate the optimization for both branches. + + That means that the optimization is activated if *there exists* an + interesting tuple in one hole of the let-rhs context. We could + choose to activate it only if *all* holes are interesting. We made + that choice because being optimistic is extremely cheap (one static + exit/catch overhead in the "wrong cases"), while being pessimistic + can be costly (one unnecessary tuple allocation). +*) + +let assign_pat opt nraise catch_ids loc pat lam = + let rec collect acc pat lam = match pat.pat_desc, lam with + | Tpat_tuple patl, Lprim(Pmakeblock _, lams, _) -> + opt := true; + List.fold_left2 collect acc patl lams + | Tpat_tuple patl, Lconst(Const_block(_, scl)) -> + opt := true; + let collect_const acc pat sc = collect acc pat (Lconst sc) in + List.fold_left2 collect_const acc patl scl + | _ -> + (* pattern idents will be bound in staticcatch (let body), so we + refresh them here to guarantee binders uniqueness *) + let pat_ids = pat_bound_idents pat in + let fresh_ids = List.map (fun id -> id, Ident.rename id) pat_ids in + (fresh_ids, alpha_pat fresh_ids pat, lam) :: acc + in + + (* sublets were accumulated by 'collect' with the leftmost tuple + pattern at the bottom of the list; to respect right-to-left + evaluation order for tuples, we must evaluate sublets + top-to-bottom. To preserve tail-rec, we will fold_left the + reversed list. *) + let rev_sublets = List.rev (collect [] pat lam) in + let exit = + (* build an Ident.tbl to avoid quadratic refreshing costs *) + let add t (id, fresh_id) = Ident.add id fresh_id t in + let add_ids acc (ids, _pat, _lam) = List.fold_left add acc ids in + let tbl = List.fold_left add_ids Ident.empty rev_sublets in + let fresh_var id = Lvar (Ident.find_same id tbl) in + Lstaticraise(nraise, List.map fresh_var catch_ids) + in + let push_sublet code (_ids, pat, lam) = simple_for_let loc lam pat code in + List.fold_left push_sublet exit rev_sublets + let for_let loc param pat body = - compile_matching loc None (partial_function loc) param [pat, body] Partial + match pat.pat_desc with + | Tpat_any -> + (* This eliminates a useless variable (and stack slot in bytecode) + for "let _ = ...". See #6865. *) + Lsequence(param, body) + | Tpat_var (id, _) -> + (* fast path, and keep track of simple bindings to unboxable numbers *) + let k = Typeopt.value_kind pat.pat_env pat.pat_type in + Llet(Strict, k, id, param, body) + | _ -> + let opt = ref false in + let nraise = next_raise_count () in + let catch_ids = pat_bound_idents pat in + let bind = map_return (assign_pat opt nraise catch_ids loc pat) param in + if !opt then Lstaticcatch(bind, (nraise, catch_ids), body) + else simple_for_let loc param pat body (* Handling of tupled functions and matchings *) @@ -2714,12 +3161,12 @@ let raise_num = next_raise_count () in raise_num, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ; + args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict]; default = [[[omega]],raise_num] } | _ -> -1, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ; + args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict]; default = [] } in try @@ -2763,13 +3210,6 @@ (* #PR4828: Believe it or not, the 'paraml' argument below may not be side effect free. *) -let arg_to_var arg cls = match arg with -| Lvar v -> v,arg -| _ -> - let v = name_pattern "match" cls in - v,Lvar v - - let param_to_var param = match param with | Lvar v -> v,None | _ -> Ident.create "match",Some param diff -Nru ocaml-4.01.0/bytecomp/matching.mli ocaml-4.05.0/bytecomp/matching.mli --- ocaml-4.01.0/bytecomp/matching.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/matching.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,20 +1,25 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Compilation of pattern-matching *) open Typedtree open Lambda + +(* Entry points to match compiler *) val for_function: Location.t -> int ref option -> lambda -> (pattern * lambda) list -> partial -> lambda @@ -34,8 +39,8 @@ val flatten_pattern: int -> pattern -> pattern list -val make_test_sequence: - lambda option -> primitive -> primitive -> lambda -> - (Asttypes.constant * lambda) list -> lambda +(* Expand stringswitch to string test tree *) +val expand_stringswitch: + Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda val inline_lazy_force : lambda -> Location.t -> lambda diff -Nru ocaml-4.01.0/bytecomp/meta.ml ocaml-4.05.0/bytecomp/meta.ml --- ocaml-4.01.0/bytecomp/meta.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/meta.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,25 +1,33 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) external global_data : unit -> Obj.t array = "caml_get_global_data" external realloc_global_data : int -> unit = "caml_realloc_global" -external static_alloc : int -> string = "caml_static_alloc" -external static_free : string -> unit = "caml_static_free" -external static_resize : string -> int -> string = "caml_static_resize" -external static_release_bytecode : string -> int -> unit +external static_alloc : int -> bytes = "caml_static_alloc" +external static_free : bytes -> unit = "caml_static_free" +external static_resize : bytes -> int -> bytes = "caml_static_resize" +external static_release_bytecode : bytes -> int -> unit = "caml_static_release_bytecode" type closure = unit -> Obj.t -external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" +external reify_bytecode : bytes -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t = "caml_invoke_traced_function" external get_section_table : unit -> (string * Obj.t) list = "caml_get_section_table" +external add_debug_info : + bytes -> int -> Instruct.debug_event list array -> unit + = "caml_add_debug_info" +external remove_debug_info : bytes -> unit + = "caml_remove_debug_info" diff -Nru ocaml-4.01.0/bytecomp/meta.mli ocaml-4.05.0/bytecomp/meta.mli --- ocaml-4.01.0/bytecomp/meta.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/meta.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,27 +1,35 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* To control the runtime system and bytecode interpreter *) external global_data : unit -> Obj.t array = "caml_get_global_data" external realloc_global_data : int -> unit = "caml_realloc_global" -external static_alloc : int -> string = "caml_static_alloc" -external static_free : string -> unit = "caml_static_free" -external static_release_bytecode : string -> int -> unit +external static_alloc : int -> bytes = "caml_static_alloc" +external static_free : bytes -> unit = "caml_static_free" +external static_release_bytecode : bytes -> int -> unit = "caml_static_release_bytecode" -external static_resize : string -> int -> string = "caml_static_resize" +external static_resize : bytes -> int -> bytes = "caml_static_resize" type closure = unit -> Obj.t -external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" +external reify_bytecode : bytes -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t = "caml_invoke_traced_function" external get_section_table : unit -> (string * Obj.t) list = "caml_get_section_table" +external add_debug_info : + bytes -> int -> Instruct.debug_event list array -> unit + = "caml_add_debug_info" +external remove_debug_info : bytes -> unit + = "caml_remove_debug_info" diff -Nru ocaml-4.01.0/bytecomp/printinstr.ml ocaml-4.05.0/bytecomp/printinstr.ml --- ocaml-4.01.0/bytecomp/printinstr.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/printinstr.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Pretty-print lists of instructions *) @@ -67,7 +70,7 @@ | Kboolnot -> fprintf ppf "\tboolnot" | Kpushtrap lbl -> fprintf ppf "\tpushtrap L%i" lbl | Kpoptrap -> fprintf ppf "\tpoptrap" - | Kraise -> fprintf ppf "\traise" + | Kraise k-> fprintf ppf "\t%s" (Lambda.raise_kind k) | Kcheck_signals -> fprintf ppf "\tcheck_signals" | Kccall(s, n) -> fprintf ppf "\tccall %s, %i" s n diff -Nru ocaml-4.01.0/bytecomp/printinstr.mli ocaml-4.05.0/bytecomp/printinstr.mli --- ocaml-4.01.0/bytecomp/printinstr.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/printinstr.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Pretty-print lists of instructions *) diff -Nru ocaml-4.01.0/bytecomp/printlambda.ml ocaml-4.05.0/bytecomp/printlambda.ml --- ocaml-4.01.0/bytecomp/printlambda.ml 2012-11-29 09:55:00.000000000 +0000 +++ ocaml-4.05.0/bytecomp/printlambda.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Format open Asttypes @@ -20,7 +23,7 @@ let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n | Const_base(Const_char c) -> fprintf ppf "%C" c - | Const_base(Const_string s) -> fprintf ppf "%S" s + | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f | Const_base(Const_int32 n) -> fprintf ppf "%lil" n @@ -40,13 +43,28 @@ List.iter (fun f -> fprintf ppf "@ %s" f) fl in fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl +let array_kind = function + | Pgenarray -> "gen" + | Paddrarray -> "addr" + | Pintarray -> "int" + | Pfloatarray -> "float" + let boxed_integer_name = function | Pnativeint -> "nativeint" | Pint32 -> "int32" | Pint64 -> "int64" -let print_boxed_integer name ppf bi = - fprintf ppf "%s_%s" (boxed_integer_name bi) name +let value_kind = function + | Pgenval -> "" + | Pintval -> "[int]" + | Pfloatval -> "[float]" + | Pboxedintval bi -> Printf.sprintf "[%s]" (boxed_integer_name bi) + +let field_kind = function + | Pgenval -> "*" + | Pintval -> "int" + | Pfloatval -> "float" + | Pboxedintval bi -> boxed_integer_name bi let print_boxed_integer_conversion ppf bi1 bi2 = fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) @@ -84,28 +102,87 @@ let record_rep ppf r = match r with | Record_regular -> fprintf ppf "regular" + | Record_inlined i -> fprintf ppf "inlined(%i)" i + | Record_unboxed false -> fprintf ppf "unboxed" + | Record_unboxed true -> fprintf ppf "inlined(unboxed)" | Record_float -> fprintf ppf "float" + | Record_extension -> fprintf ppf "ext" ;; +let string_of_loc_kind = function + | Loc_FILE -> "loc_FILE" + | Loc_LINE -> "loc_LINE" + | Loc_MODULE -> "loc_MODULE" + | Loc_POS -> "loc_POS" + | Loc_LOC -> "loc_LOC" + +let block_shape ppf shape = match shape with + | None | Some [] -> () + | Some l when List.for_all ((=) Pgenval) l -> () + | Some [elt] -> + Format.fprintf ppf " (%s)" (field_kind elt) + | Some (h :: t) -> + Format.fprintf ppf " (%s" (field_kind h); + List.iter (fun elt -> + Format.fprintf ppf ",%s" (field_kind elt)) + t; + Format.fprintf ppf ")" + let primitive ppf = function | Pidentity -> fprintf ppf "id" + | Pbytes_to_string -> fprintf ppf "bytes_to_string" + | Pbytes_of_string -> fprintf ppf "bytes_of_string" | Pignore -> fprintf ppf "ignore" - | Prevapply _ -> fprintf ppf "revapply" - | Pdirapply _ -> fprintf ppf "dirapply" + | Prevapply -> fprintf ppf "revapply" + | Pdirapply -> fprintf ppf "dirapply" + | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind) | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id - | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag - | Pmakeblock(tag, Mutable) -> fprintf ppf "makemutable %i" tag + | Pmakeblock(tag, Immutable, shape) -> + fprintf ppf "makeblock %i%a" tag block_shape shape + | Pmakeblock(tag, Mutable, shape) -> + fprintf ppf "makemutable %i%a" tag block_shape shape | Pfield n -> fprintf ppf "field %i" n - | Psetfield(n, ptr) -> - let instr = if ptr then "setfield_ptr " else "setfield_imm " in - fprintf ppf "%s%i" instr n + | Pfield_computed -> fprintf ppf "field_computed" + | Psetfield(n, ptr, init) -> + let instr = + match ptr with + | Pointer -> "ptr" + | Immediate -> "imm" + in + let init = + match init with + | Heap_initialization -> "(heap-init)" + | Root_initialization -> "(root-init)" + | Assignment -> "" + in + fprintf ppf "setfield_%s%s %i" instr init n + | Psetfield_computed (ptr, init) -> + let instr = + match ptr with + | Pointer -> "ptr" + | Immediate -> "imm" + in + let init = + match init with + | Heap_initialization -> "(heap-init)" + | Root_initialization -> "(root-init)" + | Assignment -> "" + in + fprintf ppf "setfield_%s%s_computed" instr init | Pfloatfield n -> fprintf ppf "floatfield %i" n - | Psetfloatfield n -> fprintf ppf "setfloatfield %i" n + | Psetfloatfield (n, init) -> + let init = + match init with + | Heap_initialization -> "(heap-init)" + | Root_initialization -> "(root-init)" + | Assignment -> "" + in + fprintf ppf "setfloatfield%s %i" init n | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size | Plazyforce -> fprintf ppf "force" | Pccall p -> fprintf ppf "%s" p.prim_name - | Praise -> fprintf ppf "raise" + | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) | Psequand -> fprintf ppf "&&" | Psequor -> fprintf ppf "||" | Pnot -> fprintf ppf "not" @@ -113,8 +190,10 @@ | Paddint -> fprintf ppf "+" | Psubint -> fprintf ppf "-" | Pmulint -> fprintf ppf "*" - | Pdivint -> fprintf ppf "/" - | Pmodint -> fprintf ppf "mod" + | Pdivint Safe -> fprintf ppf "/" + | Pdivint Unsafe -> fprintf ppf "/u" + | Pmodint Safe -> fprintf ppf "mod" + | Pmodint Unsafe -> fprintf ppf "mod_unsafe" | Pandint -> fprintf ppf "and" | Porint -> fprintf ppf "or" | Pxorint -> fprintf ppf "xor" @@ -145,22 +224,32 @@ | Pfloatcomp(Cge) -> fprintf ppf ">=." | Pstringlength -> fprintf ppf "string.length" | Pstringrefu -> fprintf ppf "string.unsafe_get" - | Pstringsetu -> fprintf ppf "string.unsafe_set" | Pstringrefs -> fprintf ppf "string.get" - | Pstringsets -> fprintf ppf "string.set" - | Parraylength _ -> fprintf ppf "array.length" - | Pmakearray _ -> fprintf ppf "makearray " - | Parrayrefu _ -> fprintf ppf "array.unsafe_get" - | Parraysetu _ -> fprintf ppf "array.unsafe_set" - | Parrayrefs _ -> fprintf ppf "array.get" - | Parraysets _ -> fprintf ppf "array.set" + | Pbyteslength -> fprintf ppf "bytes.length" + | Pbytesrefu -> fprintf ppf "bytes.unsafe_get" + | Pbytessetu -> fprintf ppf "bytes.unsafe_set" + | Pbytesrefs -> fprintf ppf "bytes.get" + | Pbytessets -> fprintf ppf "bytes.set" + + | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k) + | Pmakearray (k, Mutable) -> fprintf ppf "makearray[%s]" (array_kind k) + | Pmakearray (k, Immutable) -> fprintf ppf "makearray_imm[%s]" (array_kind k) + | Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k) + | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k) + | Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k) + | Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k) + | Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k) + | Parraysets k -> fprintf ppf "array.set[%s]" (array_kind k) | Pctconst c -> let const_name = match c with | Big_endian -> "big_endian" | Word_size -> "word_size" + | Int_size -> "int_size" + | Max_wosize -> "max_wosize" | Ostype_unix -> "ostype_unix" | Ostype_win32 -> "ostype_win32" - | Ostype_cygwin -> "ostype_cygwin" in + | Ostype_cygwin -> "ostype_cygwin" + | Backend_type -> "backend_type" in fprintf ppf "sys.constant_%s" const_name | Pisint -> fprintf ppf "isint" | Pisout -> fprintf ppf "isout" @@ -172,8 +261,14 @@ | Paddbint bi -> print_boxed_integer "add" ppf bi | Psubbint bi -> print_boxed_integer "sub" ppf bi | Pmulbint bi -> print_boxed_integer "mul" ppf bi - | Pdivbint bi -> print_boxed_integer "div" ppf bi - | Pmodbint bi -> print_boxed_integer "mod" ppf bi + | Pdivbint { size = bi; is_safe = Safe } -> + print_boxed_integer "div" ppf bi + | Pdivbint { size = bi; is_safe = Unsafe } -> + print_boxed_integer "div_unsafe" ppf bi + | Pmodbint { size = bi; is_safe = Safe } -> + print_boxed_integer "mod" ppf bi + | Pmodbint { size = bi; is_safe = Unsafe } -> + print_boxed_integer "mod_unsafe" ppf bi | Pandbint bi -> print_boxed_integer "and" ppf bi | Porbint bi -> print_boxed_integer "or" ppf bi | Pxorbint bi -> print_boxed_integer "xor" ppf bi @@ -186,9 +281,9 @@ | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi - | Pbigarrayref(unsafe, n, kind, layout) -> + | Pbigarrayref(unsafe, _n, kind, layout) -> print_bigarray "get" unsafe kind ppf layout - | Pbigarrayset(unsafe, n, kind, layout) -> + | Pbigarrayset(unsafe, _n, kind, layout) -> print_bigarray "set" unsafe kind ppf layout | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n | Pstring_load_16(unsafe) -> @@ -229,17 +324,157 @@ else fprintf ppf "bigarray.array1.set64" | Pbswap16 -> fprintf ppf "bswap16" | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi + | Pint_as_pointer -> fprintf ppf "int_as_pointer" + | Popaque -> fprintf ppf "opaque" + +let name_of_primitive = function + | Pidentity -> "Pidentity" + | Pbytes_of_string -> "Pbytes_of_string" + | Pbytes_to_string -> "Pbytes_to_string" + | Pignore -> "Pignore" + | Prevapply -> "Prevapply" + | Pdirapply -> "Pdirapply" + | Ploc _ -> "Ploc" + | Pgetglobal _ -> "Pgetglobal" + | Psetglobal _ -> "Psetglobal" + | Pmakeblock _ -> "Pmakeblock" + | Pfield _ -> "Pfield" + | Pfield_computed -> "Pfield_computed" + | Psetfield _ -> "Psetfield" + | Psetfield_computed _ -> "Psetfield_computed" + | Pfloatfield _ -> "Pfloatfield" + | Psetfloatfield _ -> "Psetfloatfield" + | Pduprecord _ -> "Pduprecord" + | Plazyforce -> "Plazyforce" + | Pccall _ -> "Pccall" + | Praise _ -> "Praise" + | Psequand -> "Psequand" + | Psequor -> "Psequor" + | Pnot -> "Pnot" + | Pnegint -> "Pnegint" + | Paddint -> "Paddint" + | Psubint -> "Psubint" + | Pmulint -> "Pmulint" + | Pdivint _ -> "Pdivint" + | Pmodint _ -> "Pmodint" + | Pandint -> "Pandint" + | Porint -> "Porint" + | Pxorint -> "Pxorint" + | Plslint -> "Plslint" + | Plsrint -> "Plsrint" + | Pasrint -> "Pasrint" + | Pintcomp _ -> "Pintcomp" + | Poffsetint _ -> "Poffsetint" + | Poffsetref _ -> "Poffsetref" + | Pintoffloat -> "Pintoffloat" + | Pfloatofint -> "Pfloatofint" + | Pnegfloat -> "Pnegfloat" + | Pabsfloat -> "Pabsfloat" + | Paddfloat -> "Paddfloat" + | Psubfloat -> "Psubfloat" + | Pmulfloat -> "Pmulfloat" + | Pdivfloat -> "Pdivfloat" + | Pfloatcomp _ -> "Pfloatcomp" + | Pstringlength -> "Pstringlength" + | Pstringrefu -> "Pstringrefu" + | Pstringrefs -> "Pstringrefs" + | Pbyteslength -> "Pbyteslength" + | Pbytesrefu -> "Pbytesrefu" + | Pbytessetu -> "Pbytessetu" + | Pbytesrefs -> "Pbytesrefs" + | Pbytessets -> "Pbytessets" + | Parraylength _ -> "Parraylength" + | Pmakearray _ -> "Pmakearray" + | Pduparray _ -> "Pduparray" + | Parrayrefu _ -> "Parrayrefu" + | Parraysetu _ -> "Parraysetu" + | Parrayrefs _ -> "Parrayrefs" + | Parraysets _ -> "Parraysets" + | Pctconst _ -> "Pctconst" + | Pisint -> "Pisint" + | Pisout -> "Pisout" + | Pbittest -> "Pbittest" + | Pbintofint _ -> "Pbintofint" + | Pintofbint _ -> "Pintofbint" + | Pcvtbint _ -> "Pcvtbint" + | Pnegbint _ -> "Pnegbint" + | Paddbint _ -> "Paddbint" + | Psubbint _ -> "Psubbint" + | Pmulbint _ -> "Pmulbint" + | Pdivbint _ -> "Pdivbint" + | Pmodbint _ -> "Pmodbint" + | Pandbint _ -> "Pandbint" + | Porbint _ -> "Porbint" + | Pxorbint _ -> "Pxorbint" + | Plslbint _ -> "Plslbint" + | Plsrbint _ -> "Plsrbint" + | Pasrbint _ -> "Pasrbint" + | Pbintcomp _ -> "Pbintcomp" + | Pbigarrayref _ -> "Pbigarrayref" + | Pbigarrayset _ -> "Pbigarrayset" + | Pbigarraydim _ -> "Pbigarraydim" + | Pstring_load_16 _ -> "Pstring_load_16" + | Pstring_load_32 _ -> "Pstring_load_32" + | Pstring_load_64 _ -> "Pstring_load_64" + | Pstring_set_16 _ -> "Pstring_set_16" + | Pstring_set_32 _ -> "Pstring_set_32" + | Pstring_set_64 _ -> "Pstring_set_64" + | Pbigstring_load_16 _ -> "Pbigstring_load_16" + | Pbigstring_load_32 _ -> "Pbigstring_load_32" + | Pbigstring_load_64 _ -> "Pbigstring_load_64" + | Pbigstring_set_16 _ -> "Pbigstring_set_16" + | Pbigstring_set_32 _ -> "Pbigstring_set_32" + | Pbigstring_set_64 _ -> "Pbigstring_set_64" + | Pbswap16 -> "Pbswap16" + | Pbbswap _ -> "Pbbswap" + | Pint_as_pointer -> "Pint_as_pointer" + | Popaque -> "Popaque" + +let function_attribute ppf { inline; specialise; is_a_functor; stub } = + if is_a_functor then + fprintf ppf "is_a_functor@ "; + if stub then + fprintf ppf "stub@ "; + begin match inline with + | Default_inline -> () + | Always_inline -> fprintf ppf "always_inline@ " + | Never_inline -> fprintf ppf "never_inline@ " + | Unroll i -> fprintf ppf "unroll(%i)@ " i + end; + begin match specialise with + | Default_specialise -> () + | Always_specialise -> fprintf ppf "always_specialise@ " + | Never_specialise -> fprintf ppf "never_specialise@ " + end + +let apply_tailcall_attribute ppf tailcall = + if tailcall then + fprintf ppf " @@tailcall" + +let apply_inlined_attribute ppf = function + | Default_inline -> () + | Always_inline -> fprintf ppf " always_inline" + | Never_inline -> fprintf ppf " never_inline" + | Unroll i -> fprintf ppf " never_inline(%i)" i + +let apply_specialised_attribute ppf = function + | Default_specialise -> () + | Always_specialise -> fprintf ppf " always_specialise" + | Never_specialise -> fprintf ppf " never_specialise" let rec lam ppf = function | Lvar id -> Ident.print ppf id | Lconst cst -> struct_const ppf cst - | Lapply(lfun, largs, _) -> + | Lapply ap -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs - | Lfunction(kind, params, body) -> + fprintf ppf "@[<2>(apply@ %a%a%a%a%a)@]" lam ap.ap_func lams ap.ap_args + apply_tailcall_attribute ap.ap_should_be_tailcall + apply_inlined_attribute ap.ap_inlined + apply_specialised_attribute ap.ap_specialised + | Lfunction{kind; params; body; attr} -> let pr_params ppf params = match kind with | Curried -> @@ -253,14 +488,20 @@ Ident.print ppf param) params; fprintf ppf ")" in - fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body - | Llet(str, id, arg, body) -> + fprintf ppf "@[<2>(function%a@ %a%a)@]" pr_params params + function_attribute attr lam body + | Llet(str, k, id, arg, body) -> + let kind = function + Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" + in let rec letbody = function - | Llet(str, id, arg, body) -> - fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg; + | Llet(str, k, id, arg, body) -> + fprintf ppf "@ @[<2>%a =%s%s@ %a@]" + Ident.print id (kind str) (value_kind k) lam arg; letbody body | expr -> expr in - fprintf ppf "@[<2>(let@ @[(@[<2>%a@ %a@]" Ident.print id lam arg; + fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s%s@ %a@]" + Ident.print id (kind str) (value_kind k) lam arg; let expr = letbody body in fprintf ppf ")@]@ %a)@]" lam expr | Lletrec(id_arg_list, body) -> @@ -273,7 +514,7 @@ id_arg_list in fprintf ppf "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Lprim(prim, largs) -> + | Lprim(prim, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs @@ -296,11 +537,26 @@ if !spc then fprintf ppf "@ " else spc := true; fprintf ppf "@[default:@ %a@]" lam l end in - fprintf ppf "@[<1>(%s %a@ @[%a@])@]" (match sw.sw_failaction with None -> "switch*" | _ -> "switch") lam larg switch sw + | Lstringswitch(arg, cases, default, _) -> + let switch ppf cases = + let spc = ref false in + List.iter + (fun (s, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) + cases; + begin match default with + | Some default -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam default + | None -> () + end in + fprintf ppf + "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases | Lstaticraise (i, ls) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in @@ -343,7 +599,9 @@ match ev.lev_kind with | Lev_before -> "before" | Lev_after _ -> "after" - | Lev_function -> "funct-body" in + | Lev_function -> "funct-body" + | Lev_pseudo -> "pseudo" + in fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind ev.lev_loc.Location.loc_start.Lexing.pos_fname ev.lev_loc.Location.loc_start.Lexing.pos_lnum @@ -363,3 +621,5 @@ let structured_constant = struct_const let lambda = lam + +let program ppf { code } = lambda ppf code diff -Nru ocaml-4.01.0/bytecomp/printlambda.mli ocaml-4.05.0/bytecomp/printlambda.mli --- ocaml-4.01.0/bytecomp/printlambda.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/printlambda.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Lambda @@ -16,4 +19,7 @@ val structured_constant: formatter -> structured_constant -> unit val lambda: formatter -> lambda -> unit +val program: formatter -> program -> unit val primitive: formatter -> primitive -> unit +val name_of_primitive : primitive -> string +val value_kind : value_kind -> string diff -Nru ocaml-4.01.0/bytecomp/runtimedef.mli ocaml-4.05.0/bytecomp/runtimedef.mli --- ocaml-4.01.0/bytecomp/runtimedef.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/runtimedef.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Values and functions known and/or provided by the runtime system *) diff -Nru ocaml-4.01.0/bytecomp/semantics_of_primitives.ml ocaml-4.05.0/bytecomp/semantics_of_primitives.ml --- ocaml-4.01.0/bytecomp/semantics_of_primitives.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/bytecomp/semantics_of_primitives.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,177 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +type effects = No_effects | Only_generative_effects | Arbitrary_effects +type coeffects = No_coeffects | Has_coeffects + +let for_primitive (prim : Lambda.primitive) = + match prim with + | Pignore | Pidentity | Pbytes_to_string | Pbytes_of_string -> + No_effects, No_coeffects + | Pmakeblock _ + | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects + | Pmakearray (_, Immutable) -> No_effects, No_coeffects + | Pduparray (_, Immutable) -> + No_effects, No_coeffects (* Pduparray (_, Immutable) is allowed only on + immutable arrays. *) + | Pduparray (_, Mutable) | Pduprecord _ -> + Only_generative_effects, Has_coeffects + | Pccall { prim_name = + ( "caml_format_float" | "caml_format_int" | "caml_int32_format" + | "caml_nativeint_format" | "caml_int64_format" ) } -> + No_effects, No_coeffects + | Plazyforce + | Pccall _ -> Arbitrary_effects, Has_coeffects + | Praise _ -> Arbitrary_effects, No_coeffects + | Pnot + | Pnegint + | Paddint + | Psubint + | Pmulint + | Pandint + | Porint + | Pxorint + | Plslint + | Plsrint + | Pasrint + | Pintcomp _ -> No_effects, No_coeffects + | Pdivbint { is_safe = Unsafe } + | Pmodbint { is_safe = Unsafe } + | Pdivint Unsafe + | Pmodint Unsafe -> + No_effects, No_coeffects (* Will not raise [Division_by_zero]. *) + | Pdivbint { is_safe = Safe } + | Pmodbint { is_safe = Safe } + | Pdivint Safe + | Pmodint Safe -> + Arbitrary_effects, No_coeffects + | Poffsetint _ -> No_effects, No_coeffects + | Poffsetref _ -> Arbitrary_effects, Has_coeffects + | Pintoffloat + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat + | Pfloatcomp _ -> No_effects, No_coeffects + | Pstringlength | Pbyteslength + | Parraylength _ -> + No_effects, Has_coeffects (* That old chestnut: [Obj.truncate]. *) + | Pisint + | Pisout + | Pbittest + | Pbintofint _ + | Pintofbint _ + | Pcvtbint _ + | Pnegbint _ + | Paddbint _ + | Psubbint _ + | Pmulbint _ + | Pandbint _ + | Porbint _ + | Pxorbint _ + | Plslbint _ + | Plsrbint _ + | Pasrbint _ + | Pbintcomp _ -> No_effects, No_coeffects + | Pbigarraydim _ -> + No_effects, Has_coeffects (* Some people resize bigarrays in place. *) + | Pfield _ + | Pfield_computed + | Pfloatfield _ + | Pgetglobal _ + | Parrayrefu _ + | Pstringrefu + | Pbytesrefu + | Pstring_load_16 true + | Pstring_load_32 true + | Pstring_load_64 true + | Pbigarrayref (true, _, _, _) + | Pbigstring_load_16 true + | Pbigstring_load_32 true + | Pbigstring_load_64 true -> + No_effects, Has_coeffects + | Parrayrefs _ + | Pstringrefs + | Pbytesrefs + | Pstring_load_16 false + | Pstring_load_32 false + | Pstring_load_64 false + | Pbigarrayref (false, _, _, _) + | Pbigstring_load_16 false + | Pbigstring_load_32 false + | Pbigstring_load_64 false -> + (* May trigger a bounds check exception. *) + Arbitrary_effects, Has_coeffects + | Psetfield _ + | Psetfield_computed _ + | Psetfloatfield _ + | Psetglobal _ + | Parraysetu _ + | Parraysets _ + | Pbytessetu + | Pbytessets + | Pstring_set_16 _ + | Pstring_set_32 _ + | Pstring_set_64 _ + | Pbigarrayset _ + | Pbigstring_set_16 _ + | Pbigstring_set_32 _ + | Pbigstring_set_64 _ -> + (* Whether or not some of these are "unsafe" is irrelevant; they always + have an effect. *) + Arbitrary_effects, No_coeffects + | Pctconst _ -> No_effects, No_coeffects + | Pbswap16 + | Pbbswap _ -> No_effects, No_coeffects + | Pint_as_pointer -> No_effects, No_coeffects + | Popaque -> Arbitrary_effects, Has_coeffects + | Ploc _ -> + (* Removed by [Translcore]. *) + No_effects, No_coeffects + | Prevapply + | Pdirapply -> + (* Removed by [Simplif], but there is no reason to prevent using + the current analysis function before/during Simplif. *) + Arbitrary_effects, Has_coeffects + | Psequand + | Psequor -> + (* Removed by [Closure_conversion] in the flambda pipeline. *) + No_effects, No_coeffects + +type return_type = + | Float + | Other + +let return_type_of_primitive (prim:Lambda.primitive) = + match prim with + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat + | Pfloatfield _ + | Parrayrefu Pfloatarray + | Parrayrefs Pfloatarray -> + Float + | _ -> + Other diff -Nru ocaml-4.01.0/bytecomp/semantics_of_primitives.mli ocaml-4.05.0/bytecomp/semantics_of_primitives.mli --- ocaml-4.01.0/bytecomp/semantics_of_primitives.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/bytecomp/semantics_of_primitives.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,69 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-30-40-41-42"] + +(** Description of the semantics of primitives, to be used for optimization + purposes. + + "No effects" means that the primitive does not change the observable state + of the world. For example, it must not write to any mutable storage, + call arbitrary external functions or change control flow (e.g. by raising + an exception). Note that allocation is not "No effects" (see below). + + It is assumed in the compiler that applications of primitives with no + effects, whose results are not used, may be eliminated. It is further + assumed that applications of primitives with no effects may be + duplicated (and thus possibly executed more than once). + + (Exceptions arising from allocation points, for example "out of memory" or + exceptions propagated from finalizers or signal handlers, are treated as + "effects out of the ether" and thus ignored for our determination here + of effectfulness. The same goes for floating point operations that may + cause hardware traps on some platforms.) + + "Only generative effects" means that a primitive does not change the + observable state of the world save for possibly affecting the state of + the garbage collector by performing an allocation. Applications of + primitives that only have generative effects and whose results are unused + may be eliminated by the compiler. However, unlike "No effects" + primitives, such applications will never be eligible for duplication. + + "Arbitrary effects" covers all other primitives. + + "No coeffects" means that the primitive does not observe the effects (in + the sense described above) of other expressions. For example, it must not + read from any mutable storage or call arbitrary external functions. + + It is assumed in the compiler that, subject to data dependencies, + expressions with neither effects nor coeffects may be reordered with + respect to other expressions. +*) + +type effects = No_effects | Only_generative_effects | Arbitrary_effects +type coeffects = No_coeffects | Has_coeffects + +(** Describe the semantics of a primitive. This does not take into account of + the (non-)(co)effectfulness of the arguments in a primitive application. + To determine whether such an application is (co)effectful, the arguments + must also be analysed. *) +val for_primitive: Lambda.primitive -> effects * coeffects + +type return_type = + | Float + | Other + +val return_type_of_primitive: Lambda.primitive -> return_type diff -Nru ocaml-4.01.0/bytecomp/simplif.ml ocaml-4.05.0/bytecomp/simplif.ml --- ocaml-4.01.0/bytecomp/simplif.ml 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/bytecomp/simplif.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Elimination of useless Llet(Alias) bindings. Also transform let-bound references into variables. *) @@ -23,26 +26,27 @@ let rec eliminate_ref id = function Lvar v as lam -> if Ident.same v id then raise Real_reference else lam - | Lconst cst as lam -> lam - | Lapply(e1, el, loc) -> - Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc) - | Lfunction(kind, params, body) as lam -> + | Lconst _ as lam -> lam + | Lapply ap -> + Lapply{ap with ap_func = eliminate_ref id ap.ap_func; + ap_args = List.map (eliminate_ref id) ap.ap_args} + | Lfunction _ as lam -> if IdentSet.mem id (free_variables lam) then raise Real_reference else lam - | Llet(str, v, e1, e2) -> - Llet(str, v, eliminate_ref id e1, eliminate_ref id e2) + | Llet(str, kind, v, e1, e2) -> + Llet(str, kind, v, eliminate_ref id e1, eliminate_ref id e2) | Lletrec(idel, e2) -> Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel, eliminate_ref id e2) - | Lprim(Pfield 0, [Lvar v]) when Ident.same v id -> + | Lprim(Pfield 0, [Lvar v], _) when Ident.same v id -> Lvar id - | Lprim(Psetfield(0, _), [Lvar v; e]) when Ident.same v id -> + | Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id -> Lassign(id, eliminate_ref id e) - | Lprim(Poffsetref delta, [Lvar v]) when Ident.same v id -> - Lassign(id, Lprim(Poffsetint delta, [Lvar id])) - | Lprim(p, el) -> - Lprim(p, List.map (eliminate_ref id) el) + | Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id -> + Lassign(id, Lprim(Poffsetint delta, [Lvar id], loc)) + | Lprim(p, el, loc) -> + Lprim(p, List.map (eliminate_ref id) el, loc) | Lswitch(e, sw) -> Lswitch(eliminate_ref id e, {sw_numconsts = sw.sw_numconsts; @@ -51,9 +55,13 @@ sw_numblocks = sw.sw_numblocks; sw_blocks = List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks; - sw_failaction = match sw.sw_failaction with - | None -> None - | Some l -> Some (eliminate_ref id l)}) + sw_failaction = + Misc.may_map (eliminate_ref id) sw.sw_failaction; }) + | Lstringswitch(e, sw, default, loc) -> + Lstringswitch + (eliminate_ref id e, + List.map (fun (s, e) -> (s, eliminate_ref id e)) sw, + Misc.may_map (eliminate_ref id) default, loc) | Lstaticraise (i,args) -> Lstaticraise (i,List.map (eliminate_ref id) args) | Lstaticcatch(e1, i, e2) -> @@ -102,19 +110,28 @@ let rec count = function | (Lvar _| Lconst _) -> () - | Lapply(l1, ll, _) -> count l1; List.iter count ll - | Lfunction(kind, params, l) -> count l - | Llet(str, v, l1, l2) -> + | Lapply ap -> count ap.ap_func; List.iter count ap.ap_args + | Lfunction {body} -> count body + | Llet(_str, _kind, _v, l1, l2) -> count l2; count l1 | Lletrec(bindings, body) -> - List.iter (fun (v, l) -> count l) bindings; + List.iter (fun (_v, l) -> count l) bindings; count body - | Lprim(p, ll) -> List.iter count ll + | Lprim(_p, ll, _) -> List.iter count ll | Lswitch(l, sw) -> count_default sw ; count l; List.iter (fun (_, l) -> count l) sw.sw_consts; List.iter (fun (_, l) -> count l) sw.sw_blocks + | Lstringswitch(l, sw, d, _) -> + count l; + List.iter (fun (_, l) -> count l) sw; + begin match d with + | None -> () + | Some d -> match sw with + | []|[_] -> count d + | _ -> count d; count d (* default will get replicated *) + end | Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) -> (* i will be replaced by j in l1, so each occurence of i in l1 @@ -133,18 +150,15 @@ l2 will be removed, so don't count its exits *) if count_exit i > 0 then count l2 - | Ltrywith(l1, v, l2) -> count l1; count l2 + | Ltrywith(l1, _v, l2) -> count l1; count l2 | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3 | Lsequence(l1, l2) -> count l1; count l2 | Lwhile(l1, l2) -> count l1; count l2 - | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3 - | Lassign(v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refcount *) - count l - | Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll) + | Lfor(_, l1, l2, _dir, l3) -> count l1; count l2; count l3 + | Lassign(_v, l) -> count l + | Lsend(_k, m, o, ll, _) -> List.iter count (m::o::ll) | Levent(l, _) -> count l - | Lifused(v, l) -> count l + | Lifused(_v, l) -> count l and count_default sw = match sw.sw_failaction with | None -> () @@ -183,39 +197,54 @@ let rec simplif = function | (Lvar _|Lconst _) as l -> l - | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc) - | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) - | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2) + | Lapply ap -> + Lapply{ap with ap_func = simplif ap.ap_func; + ap_args = List.map simplif ap.ap_args} + | Lfunction{kind; params; body = l; attr; loc} -> + Lfunction{kind; params; body = simplif l; attr; loc} + | Llet(str, kind, v, l1, l2) -> Llet(str, kind, v, simplif l1, simplif l2) | Lletrec(bindings, body) -> Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) - | Lprim(p, ll) -> begin + | Lprim(p, ll, loc) -> begin let ll = List.map simplif ll in match p, ll with (* Simplify %revapply, for n-ary functions with n > 1 *) - | Prevapply loc, [x; Lapply(f, args, _)] - | Prevapply loc, [x; Levent (Lapply(f, args, _),_)] -> - Lapply(f, args@[x], loc) - | Prevapply loc, [x; f] -> Lapply(f, [x], loc) + | Prevapply, [x; Lapply ap] + | Prevapply, [x; Levent (Lapply ap,_)] -> + Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} + | Prevapply, [x; f] -> Lapply {ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=f; + ap_args=[x]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} (* Simplify %apply, for n-ary functions with n > 1 *) - | Pdirapply loc, [Lapply(f, args, _); x] - | Pdirapply loc, [Levent (Lapply(f, args, _),_); x] -> - Lapply(f, args@[x], loc) - | Pdirapply loc, [f; x] -> Lapply(f, [x], loc) + | Pdirapply, [Lapply ap; x] + | Pdirapply, [Levent (Lapply ap,_); x] -> + Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} + | Pdirapply, [f; x] -> Lapply {ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=f; + ap_args=[x]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} - | _ -> Lprim(p, ll) + | _ -> Lprim(p, ll, loc) end | Lswitch(l, sw) -> let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = match sw.sw_failaction with - | None -> None - | Some l -> Some (simplif l) in + and new_fail = Misc.may_map simplif sw.sw_failaction in Lswitch (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) + | Lstringswitch(l,sw,d,loc) -> + Lstringswitch + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d,loc) | Lstaticraise (i,[]) as l -> begin try let _,handler = Hashtbl.find subst i in @@ -233,25 +262,18 @@ (fun x y t -> Ident.add x (Lvar y) t) xs ys Ident.empty in List.fold_right2 - (fun y l r -> Llet (Alias, y, l, r)) + (fun y l r -> Llet (Alias, Pgenval, y, l, r)) ys ls (Lambda.subst_lambda env handler) with | Not_found -> Lstaticraise (i,ls) end - | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) -> + | Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2)) -> Hashtbl.add subst i ([],simplif l2) ; simplif l1 - | Lstaticcatch (l1,(i,xs), (Lvar _ as l2)) -> - begin match count_exit i with - | 0 -> simplif l1 - | _ -> - Hashtbl.add subst i (xs,l2) ; - simplif l1 - end | Lstaticcatch (l1,(i,xs),l2) -> begin match count_exit i with | 0 -> simplif l1 - | 1 -> + | 1 when i >= 0 -> Hashtbl.add subst i (xs,simplif l2) ; simplif l1 | _ -> @@ -280,7 +302,7 @@ *) let beta_reduce params body args = - List.fold_left2 (fun l param arg -> Llet(Strict, param, arg, l)) + List.fold_left2 (fun l param arg -> Llet(Strict, Pgenval, param, arg, l)) body params args (* Simplification of lets *) @@ -330,45 +352,57 @@ () in let rec count bv = function - | Lconst cst -> () + | Lconst _ -> () | Lvar v -> use_var bv v 1 - | Lapply(Lfunction(Curried, params, body), args, _) + | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} when optimize && List.length params = List.length args -> count bv (beta_reduce params body args) - | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _) + | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; + ap_args = [Lprim(Pmakeblock _, args, _)]} when optimize && List.length params = List.length args -> count bv (beta_reduce params body args) - | Lapply(l1, ll, _) -> + | Lapply{ap_func = l1; ap_args = ll} -> count bv l1; List.iter (count bv) ll - | Lfunction(kind, params, l) -> - count Tbl.empty l - | Llet(str, v, Lvar w, l2) when optimize -> + | Lfunction {body} -> + count Tbl.empty body + | Llet(_str, _k, v, Lvar w, l2) when optimize -> (* v will be replaced by w in l2, so each occurrence of v in l2 increases w's refcount *) count (bind_var bv v) l2; use_var bv w (count_var v) - | Llet(str, v, l1, l2) -> + | Llet(str, _kind, v, l1, l2) -> count (bind_var bv v) l2; (* If v is unused, l1 will be removed, so don't count its variables *) if str = Strict || count_var v > 0 then count bv l1 | Lletrec(bindings, body) -> - List.iter (fun (v, l) -> count bv l) bindings; + List.iter (fun (_v, l) -> count bv l) bindings; count bv body - | Lprim(p, ll) -> List.iter (count bv) ll + | Lprim(_p, ll, _) -> List.iter (count bv) ll | Lswitch(l, sw) -> count_default bv sw ; count bv l; List.iter (fun (_, l) -> count bv l) sw.sw_consts; List.iter (fun (_, l) -> count bv l) sw.sw_blocks - | Lstaticraise (i,ls) -> List.iter (count bv) ls - | Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2 - | Ltrywith(l1, v, l2) -> count bv l1; count bv l2 + | Lstringswitch(l, sw, d, _) -> + count bv l ; + List.iter (fun (_, l) -> count bv l) sw ; + begin match d with + | Some d -> + begin match sw with + | []|[_] -> count bv d + | _ -> count bv d ; count bv d + end + | None -> () + end + | Lstaticraise (_i,ls) -> List.iter (count bv) ls + | Lstaticcatch(l1, _, l2) -> count bv l1; count bv l2 + | Ltrywith(l1, _v, l2) -> count bv l1; count bv l2 | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3 | Lsequence(l1, l2) -> count bv l1; count bv l2 | Lwhile(l1, l2) -> count Tbl.empty l1; count Tbl.empty l2 - | Lfor(_, l1, l2, dir, l3) -> count bv l1; count bv l2; count Tbl.empty l3 - | Lassign(v, l) -> + | Lfor(_, l1, l2, _dir, l3) -> count bv l1; count bv l2; count Tbl.empty l3 + | Lassign(_v, l) -> (* Lalias-bound variables are never assigned, so don't increase v's refcount *) count bv l @@ -401,9 +435,9 @@ (* This (small) optimisation is always legal, it may uncover some tail call later on. *) - let mklet (kind,v,e1,e2) = match e2 with + let mklet str kind v e1 e2 = match e2 with | Lvar w when optimize && Ident.same v w -> e1 - | _ -> Llet (kind,v,e1,e2) in + | _ -> Llet (str, kind,v,e1,e2) in let rec simplif = function @@ -413,53 +447,70 @@ with Not_found -> l end - | Lconst cst as l -> l - | Lapply(Lfunction(Curried, params, body), args, _) + | Lconst _ as l -> l + | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} when optimize && List.length params = List.length args -> simplif (beta_reduce params body args) - | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _) + | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; + ap_args = [Lprim(Pmakeblock _, args, _)]} when optimize && List.length params = List.length args -> simplif (beta_reduce params body args) - | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc) - | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) - | Llet(str, v, Lvar w, l2) when optimize -> + | Lapply ap -> Lapply {ap with ap_func = simplif ap.ap_func; + ap_args = List.map simplif ap.ap_args} + | Lfunction{kind; params; body = l; attr; loc} -> + begin match simplif l with + Lfunction{kind=Curried; params=params'; body; attr; loc} + when kind = Curried && optimize -> + Lfunction{kind; params = params @ params'; body; attr; loc} + | body -> + Lfunction{kind; params; body; attr; loc} + end + | Llet(_str, _k, v, Lvar w, l2) when optimize -> Hashtbl.add subst v (simplif (Lvar w)); simplif l2 - | Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [linit]), lbody) + | Llet(Strict, kind, v, + Lprim(Pmakeblock(0, Mutable, kind_ref) as prim, [linit], loc), lbody) when optimize -> let slinit = simplif linit in let slbody = simplif lbody in begin try - mklet (Variable, v, slinit, eliminate_ref v slbody) + let kind = match kind_ref with + | None -> Pgenval + | Some [field_kind] -> field_kind + | Some _ -> assert false + in + mklet Variable kind v slinit (eliminate_ref v slbody) with Real_reference -> - mklet(Strict, v, Lprim(Pmakeblock(0, Mutable), [slinit]), slbody) + mklet Strict kind v (Lprim(prim, [slinit], loc)) slbody end - | Llet(Alias, v, l1, l2) -> + | Llet(Alias, kind, v, l1, l2) -> begin match count_var v with 0 -> simplif l2 | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2 - | n -> Llet(Alias, v, simplif l1, simplif l2) + | _ -> Llet(Alias, kind, v, simplif l1, simplif l2) end - | Llet(StrictOpt, v, l1, l2) -> + | Llet(StrictOpt, kind, v, l1, l2) -> begin match count_var v with 0 -> simplif l2 - | n -> mklet(Alias, v, simplif l1, simplif l2) + | _ -> mklet Alias kind v (simplif l1) (simplif l2) end - | Llet(kind, v, l1, l2) -> mklet(kind, v, simplif l1, simplif l2) + | Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2) | Lletrec(bindings, body) -> Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) - | Lprim(p, ll) -> Lprim(p, List.map simplif ll) + | Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc) | Lswitch(l, sw) -> let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = match sw.sw_failaction with - | None -> None - | Some l -> Some (simplif l) in + and new_fail = Misc.may_map simplif sw.sw_failaction in Lswitch (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) + | Lstringswitch (l,sw,d,loc) -> + Lstringswitch + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d,loc) | Lstaticraise (i,ls) -> Lstaticraise (i, List.map simplif ls) | Lstaticcatch(l1, (i,args), l2) -> @@ -486,7 +537,7 @@ (* Tail call info in annotation files *) let is_tail_native_heuristic : (int -> bool) ref = - ref (fun n -> true) + ref (fun _ -> true) let rec emit_tail_infos is_tail lambda = let call_kind args = @@ -498,29 +549,42 @@ match lambda with | Lvar _ -> () | Lconst _ -> () - | Lapply (func, l, loc) -> - list_emit_tail_infos false l; - Stypes.record (Stypes.An_call (loc, call_kind l)) - | Lfunction (_, _, lam) -> + | Lapply ap -> + if ap.ap_should_be_tailcall + && not is_tail + && Warnings.is_active Warnings.Expect_tailcall + then Location.prerr_warning ap.ap_loc Warnings.Expect_tailcall; + emit_tail_infos false ap.ap_func; + list_emit_tail_infos false ap.ap_args; + if !Clflags.annotations then + Stypes.record (Stypes.An_call (ap.ap_loc, call_kind ap.ap_args)) + | Lfunction {body = lam} -> emit_tail_infos true lam - | Llet (_, _, lam, body) -> + | Llet (_str, _k, _, lam, body) -> emit_tail_infos false lam; emit_tail_infos is_tail body | Lletrec (bindings, body) -> List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings; emit_tail_infos is_tail body - | Lprim (Pidentity, [arg]) -> + | Lprim ((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _) -> emit_tail_infos is_tail arg - | Lprim (Psequand, [arg1; arg2]) - | Lprim (Psequor, [arg1; arg2]) -> + | Lprim (Psequand, [arg1; arg2], _) + | Lprim (Psequor, [arg1; arg2], _) -> emit_tail_infos false arg1; emit_tail_infos is_tail arg2 - | Lprim (_, l) -> + | Lprim (_, l, _) -> list_emit_tail_infos false l | Lswitch (lam, sw) -> emit_tail_infos false lam; list_emit_tail_infos_fun snd is_tail sw.sw_consts; - list_emit_tail_infos_fun snd is_tail sw.sw_blocks + list_emit_tail_infos_fun snd is_tail sw.sw_blocks; + Misc.may (emit_tail_infos is_tail) sw.sw_failaction + | Lstringswitch (lam, sw, d, _) -> + emit_tail_infos false lam; + List.iter + (fun (_,lam) -> emit_tail_infos is_tail lam) + sw ; + Misc.may (emit_tail_infos is_tail) d | Lstaticraise (_, l) -> list_emit_tail_infos false l | Lstaticcatch (body, _, handler) -> @@ -549,7 +613,8 @@ emit_tail_infos false meth; emit_tail_infos false obj; list_emit_tail_infos false args; - Stypes.record (Stypes.An_call (loc, call_kind (obj :: args))) + if !Clflags.annotations then + Stypes.record (Stypes.An_call (loc, call_kind (obj :: args))); | Levent (lam, _) -> emit_tail_infos is_tail lam | Lifused (_, lam) -> @@ -559,10 +624,72 @@ and list_emit_tail_infos is_tail = List.iter (emit_tail_infos is_tail) +(* Split a function with default parameters into a wrapper and an + inner function. The wrapper fills in missing optional parameters + with their default value and tail-calls the inner function. The + wrapper can then hopefully be inlined on most call sites to avoid + the overhead associated with boxing an optional argument with a + 'Some' constructor, only to deconstruct it immediately in the + function's body. *) + +let split_default_wrapper ~id:fun_id ~kind ~params ~body ~attr ~loc = + let rec aux map = function + | Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when + Ident.name optparam = "*opt*" && List.mem optparam params + && not (List.mem_assoc optparam map) + -> + let wrapper_body, inner = aux ((optparam, id) :: map) rest in + Llet(Strict, k, id, def, wrapper_body), inner + | _ when map = [] -> raise Exit + | body -> + (* Check that those *opt* identifiers don't appear in the remaining + body. This should not appear, but let's be on the safe side. *) + let fv = Lambda.free_variables body in + List.iter (fun (id, _) -> if IdentSet.mem id fv then raise Exit) map; + + let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in + let map_param p = try List.assoc p map with Not_found -> p in + let args = List.map (fun p -> Lvar (map_param p)) params in + let wrapper_body = + Lapply { + ap_func = Lvar inner_id; + ap_args = args; + ap_loc = Location.none; + ap_should_be_tailcall = false; + ap_inlined = Default_inline; + ap_specialised = Default_specialise; + } + in + let inner_params = List.map map_param params in + let new_ids = List.map Ident.rename inner_params in + let subst = List.fold_left2 + (fun s id new_id -> + Ident.add id (Lvar new_id) s) + Ident.empty inner_params new_ids + in + let body = Lambda.subst_lambda subst body in + let inner_fun = + Lfunction { kind = Curried; params = new_ids; body; attr; loc; } + in + (wrapper_body, (inner_id, inner_fun)) + in + try + let body, inner = aux [] body in + let attr = default_stub_attribute in + [(fun_id, Lfunction{kind; params; body; attr; loc}); inner] + with Exit -> + [(fun_id, Lfunction{kind; params; body; attr; loc})] + +module Hooks = Misc.MakeHooks(struct + type t = lambda + end) + (* The entry point: simplification + emission of tailcall annotations, if needed. *) -let simplify_lambda lam = +let simplify_lambda sourcefile lam = let res = simplify_lets (simplify_exits lam) in - if !Clflags.annotations then emit_tail_infos true res; + let res = Hooks.apply_hooks { Misc.sourcefile } res in + if !Clflags.annotations || Warnings.is_active Warnings.Expect_tailcall + then emit_tail_infos true res; res diff -Nru ocaml-4.01.0/bytecomp/simplif.mli ocaml-4.05.0/bytecomp/simplif.mli --- ocaml-4.01.0/bytecomp/simplif.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/simplif.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Elimination of useless Llet(Alias) bindings. Transformation of let-bound references into variables. @@ -17,8 +20,19 @@ open Lambda -val simplify_lambda: lambda -> lambda +val simplify_lambda: string -> lambda -> lambda + +val split_default_wrapper + : id:Ident.t + -> kind:function_kind + -> params:Ident.t list + -> body:lambda + -> attr:function_attribute + -> loc:Location.t + -> (Ident.t * lambda) list (* To be filled by asmcomp/selectgen.ml *) val is_tail_native_heuristic: (int -> bool) ref (* # arguments -> can tailcall *) + +module Hooks : Misc.HookSig with type t = lambda diff -Nru ocaml-4.01.0/bytecomp/switch.ml ocaml-4.05.0/bytecomp/switch.ml --- ocaml-4.01.0/bytecomp/switch.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/bytecomp/switch.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,40 +1,89 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) -(* Store for actions in object style *) -exception Found of int + +type 'a shared = Shared of 'a | Single of 'a type 'a t_store = - {act_get : unit -> 'a array ; act_store : 'a -> int} + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'a -> int ; + act_store_shared : 'a -> int ; } + +exception Not_simple + +module type Stored = sig + type t + type key + val make_key : t -> key option +end -let mk_store same = - let r_acts = ref [] in - let store act = - let rec store_rec i = function - | [] -> i,[act] - | act0::rem -> - if same act0 act then raise (Found i) - else - let i,rem = store_rec (i+1) rem in - i,act0::rem in - try - let i,acts = store_rec 0 !r_acts in - r_acts := acts ; - i - with - | Found i -> i +module Store(A:Stored) = struct + module AMap = + Map.Make(struct type t = A.key let compare = Pervasives.compare end) + + type intern = + { mutable map : (bool * int) AMap.t ; + mutable next : int ; + mutable acts : (bool * A.t) list; } + + let mk_store () = + let st = + { map = AMap.empty ; + next = 0 ; + acts = [] ; } in + + let add mustshare act = + let i = st.next in + st.acts <- (mustshare,act) :: st.acts ; + st.next <- i+1 ; + i in + + let store mustshare act = match A.make_key act with + | Some key -> + begin try + let (shared,i) = AMap.find key st.map in + if not shared then st.map <- AMap.add key (true,i) st.map ; + i + with Not_found -> + let i = add mustshare act in + st.map <- AMap.add key (mustshare,i) st.map ; + i + end + | None -> + add mustshare act - and get () = Array.of_list !r_acts in - {act_store=store ; act_get=get} + and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts) + + and get_shared () = + let acts = + Array.of_list + (List.rev_map + (fun (shared,act) -> + if shared then Shared act else Single act) + st.acts) in + AMap.iter + (fun _ (shared,i) -> + if shared then match acts.(i) with + | Single act -> acts.(i) <- Shared act + | Shared _ -> ()) + st.map ; + acts in + {act_store = store false ; act_store_shared = store true ; + act_get = get; act_get_shared = get_shared; } +end @@ -50,13 +99,15 @@ type act val bind : act -> (act -> act) -> act + val make_const : int -> act val make_offset : act -> int -> act val make_prim : primitive -> act list -> act val make_isout : act -> act -> act val make_isin : act -> act -> act val make_if : act -> act -> act -> act - val make_switch : - act -> int array -> act array -> act + val make_switch : act -> int array -> act array -> act + val make_catch : act -> int * (act -> act) + val make_exit : int -> act end (* The module will ``produce good code for the case statement'' *) @@ -91,6 +142,7 @@ let cut = ref 8 and more_cut = ref 16 +(* let pint chan i = if i = min_int then Printf.fprintf chan "-oo" else if i=max_int then Printf.fprintf chan "oo" @@ -105,8 +157,9 @@ Printf.fprintf chan "%a..%a:%d " pint l pint h act done - let prerr_inter i = Printf.fprintf stderr +let prerr_inter i = Printf.fprintf stderr "cases=%a" pcases i.cases +*) let get_act cases i = let _,_,r = cases.(i) in @@ -122,6 +175,7 @@ let too_much = {n=max_int ; ni=max_int} +(* let ptests chan {n=n ; ni=ni} = Printf.fprintf chan "{n=%d ; ni=%d}" n ni @@ -129,23 +183,7 @@ for i =0 to Array.length t-1 do Printf.fprintf chan "%d: %a\n" i ptests t.(i) done - -let count_tests s = - let r = - Array.init - (Array.length s.actions) - (fun _ -> {n=0 ; ni=0 }) in - let c = s.cases in - let imax = Array.length c-1 in - for i=0 to imax do - let l,h,act = c.(i) in - let x = r.(act) in - x.n <- x.n+1 ; - if l < h && i<> 0 && i<>imax then - x.ni <- x.ni+1 ; - done ; - r - +*) let less_tests c1 c2 = if c1.n < c2.n then @@ -160,8 +198,6 @@ and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni -let min_tests c1 c2 = if less_tests c1 c2 then c1 else c2 - let less2tests (c1,d1) (c2,d2) = if eq_tests c1 c2 then less_tests d1 d2 @@ -174,10 +210,12 @@ type t_ret = Inter of int * int | Sep of int | No +(* let pret chan = function | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j | Sep i -> Printf.fprintf chan "Sep %d" i | No -> Printf.fprintf chan "No" +*) let coupe cases i = let l,_,_ = cases.(i) in @@ -196,7 +234,7 @@ let l1,h1,act1 = c1.(Array.length c1-1) and l2,h2,act2 = c2.(0) in if act1 = act2 then - let r = Array.create (len1+len2-1) c1.(0) in + let r = Array.make (len1+len2-1) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -225,7 +263,7 @@ done ; r else if h1 > l1 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -235,7 +273,7 @@ done ; r else if h2 > l2 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-1 do r.(i) <- c1.(i) done ; @@ -258,6 +296,7 @@ type kind = Kvalue of int | Kinter of int | Kempty +(* let pkind chan = function | Kvalue i ->Printf.fprintf chan "V%d" i | Kinter i -> Printf.fprintf chan "I%d" i @@ -268,6 +307,7 @@ | [k] -> pkind chan k | k::rem -> Printf.fprintf chan "%a %a" pkey rem pkind k +*) let t = Hashtbl.create 17 @@ -338,8 +378,7 @@ let rec opt_count top cases = let key = make_key cases in try - let r = Hashtbl.find t key in - r + Hashtbl.find t key with | Not_found -> let r = @@ -351,13 +390,13 @@ if lcases < !cut then enum top cases else if lcases < !more_cut then - heuristic top cases + heuristic cases else - divide top cases in + divide cases in Hashtbl.add t key r ; r -and divide top cases = +and divide cases = let lcases = Array.length cases in let m = lcases/2 in let _,left,right = coupe cases m in @@ -373,10 +412,10 @@ add_test cm cml ; Sep m,(cm, ci) -and heuristic top cases = +and heuristic cases = let lcases = Array.length cases in - let sep,csep = divide false cases + let sep,csep = divide cases and inter,cinter = if !ok_inter then begin @@ -489,80 +528,68 @@ end ; !r, !rc - let make_if_test konst test arg i ifso ifnot = + let make_if_test test arg i ifso ifnot = Arg.make_if - (Arg.make_prim test [arg ; konst i]) + (Arg.make_prim test [arg ; Arg.make_const i]) ifso ifnot - let make_if_lt konst arg i ifso ifnot = match i with + let make_if_lt arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.leint arg 0 ifso ifnot - | _ -> - make_if_test konst Arg.ltint arg i ifso ifnot - - and make_if_le konst arg i ifso ifnot = match i with - | -1 -> - make_if_test konst Arg.ltint arg 0 ifso ifnot - | _ -> - make_if_test konst Arg.leint arg i ifso ifnot - - and make_if_gt konst arg i ifso ifnot = match i with - | -1 -> - make_if_test konst Arg.geint arg 0 ifso ifnot + make_if_test Arg.leint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.gtint arg i ifso ifnot + make_if_test Arg.ltint arg i ifso ifnot - and make_if_ge konst arg i ifso ifnot = match i with + and make_if_ge arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.gtint arg 0 ifso ifnot + make_if_test Arg.gtint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.geint arg i ifso ifnot + make_if_test Arg.geint arg i ifso ifnot - and make_if_eq konst arg i ifso ifnot = - make_if_test konst Arg.eqint arg i ifso ifnot + and make_if_eq arg i ifso ifnot = + make_if_test Arg.eqint arg i ifso ifnot - and make_if_ne konst arg i ifso ifnot = - make_if_test konst Arg.neint arg i ifso ifnot + and make_if_ne arg i ifso ifnot = + make_if_test Arg.neint arg i ifso ifnot let do_make_if_out h arg ifso ifno = Arg.make_if (Arg.make_isout h arg) ifso ifno - let make_if_out konst ctx l d mk_ifso mk_ifno = match l with + let make_if_out ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_out - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_out - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) let do_make_if_in h arg ifso ifno = Arg.make_if (Arg.make_isin h arg) ifso ifno - let make_if_in konst ctx l d mk_ifso mk_ifno = match l with + let make_if_in ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_in - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_in - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - - let rec c_test konst ctx ({cases=cases ; actions=actions} as s) = + let rec c_test ctx ({cases=cases ; actions=actions} as s) = let lcases = Array.length cases in assert(lcases > 0) ; if lcases = 1 then actions.(get_act cases 0) ctx + else begin - let w,c = opt_count false cases in + let w,_c = opt_count false cases in (* Printf.fprintf stderr "off=%d tactic=%a for %a\n" @@ -579,31 +606,31 @@ if low=high then begin if less_tests coutside cinside then make_if_eq - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=inside}) - (c_test konst ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) else make_if_ne - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=outside}) - (c_test konst ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) end else begin if less_tests coutside cinside then make_if_in - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=inside}) - (fun ctx -> c_test konst ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) else make_if_out - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=outside}) - (fun ctx -> c_test konst ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) end | Sep i -> let lim,left,right = coupe cases i in @@ -613,17 +640,17 @@ and right = {s with cases=right} in if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then - make_if_ne konst + make_if_ne ctx.arg 0 - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) else if less_tests cright cleft then - make_if_lt konst + make_if_lt ctx.arg (lim+ctx.off) - (c_test konst ctx left) (c_test konst ctx right) + (c_test ctx left) (c_test ctx right) else - make_if_ge konst + make_if_ge ctx.arg (lim+ctx.off) - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) end @@ -637,13 +664,13 @@ (* Particular case 0, 1, 2 *) let particular_case cases i j = j-i = 2 && - (let l1,h1,act1 = cases.(i) - and l2,h2,act2 = cases.(i+1) + (let l1,_h1,act1 = cases.(i) + and l2,_h2,_act2 = cases.(i+1) and l3,h3,act3 = cases.(i+2) in l1+1=l2 && l2+1=l3 && l3=h3 && act1 <> act3) -let approx_count cases i j n_actions = +let approx_count cases i j = let l = j-i+1 in if l < !cut then let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in @@ -653,12 +680,12 @@ (* Sends back a boolean that says whether is switch is worth or not *) -let dense {cases=cases ; actions=actions} i j = +let dense {cases} i j = if i=j then true else let l,_,_ = cases.(i) and _,h,_ = cases.(j) in - let ntests = approx_count cases i j (Array.length actions) in + let ntests = approx_count cases i j in (* (ntests+1) >= theta * (h-l+1) *) @@ -674,10 +701,10 @@ Software Practice and Exprience Vol. 24(2) 233 (Feb 1994) *) -let comp_clusters ({cases=cases ; actions=actions} as s) = - let len = Array.length cases in - let min_clusters = Array.create len max_int - and k = Array.create len 0 in +let comp_clusters s = + let len = Array.length s.cases in + let min_clusters = Array.make len max_int + and k = Array.make len 0 in let get_min i = if i < 0 then 0 else min_clusters.(i) in for i = 0 to len-1 do @@ -697,7 +724,7 @@ let make_switch {cases=cases ; actions=actions} i j = let ll,_,_ = cases.(i) and _,hh,_ = cases.(j) in - let tbl = Array.create (hh-ll+1) 0 + let tbl = Array.make (hh-ll+1) 0 and t = Hashtbl.create 17 and index = ref 0 in let get_index act = @@ -717,7 +744,7 @@ tbl.(kk) <- index done done ; - let acts = Array.create !index actions.(0) in + let acts = Array.make !index actions.(0) in Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t ; @@ -732,7 +759,7 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = let len = Array.length cases in - let r = Array.create n_clusters (0,0,0) + let r = Array.make n_clusters (0,0,0) and t = Hashtbl.create 17 and index = ref 0 and bidon = ref (Array.length actions) in @@ -768,31 +795,52 @@ if i > 0 then zyva (i-1) (ir-1) in zyva (len-1) (n_clusters-1) ; - let acts = Array.create !index (fun _ -> assert false) in + let acts = Array.make !index (fun _ -> assert false) in Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; {cases = r ; actions = acts} ;; -let zyva (low,high) konst arg cases actions = +let do_zyva (low,high) arg cases actions = let old_ok = !ok_inter in ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; if !ok_inter <> old_ok then Hashtbl.clear t ; let s = {cases=cases ; actions=actions} in + (* - Printf.eprintf "ZYVA: %b\n" !ok_inter ; + Printf.eprintf "ZYVA: %b [low=%i,high=%i]\n" !ok_inter low high ; pcases stderr cases ; prerr_endline "" ; *) let n_clusters,k = comp_clusters s in let clusters = make_clusters s n_clusters k in - let r = c_test konst {arg=arg ; off=0} clusters in - r - + c_test {arg=arg ; off=0} clusters - -and test_sequence konst arg cases actions = +let abstract_shared actions = + let handlers = ref (fun x -> x) in + let actions = + Array.map + (fun act -> match act with + | Single act -> act + | Shared act -> + let i,h = Arg.make_catch act in + let oh = !handlers in + handlers := (fun act -> h (oh act)) ; + Arg.make_exit i) + actions in + !handlers,actions + +let zyva lh arg cases actions = + assert (Array.length cases > 0) ; + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in + hs (do_zyva lh arg cases actions) + +and test_sequence arg cases actions = + assert (Array.length cases > 0) ; + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in let old_ok = !ok_inter in ok_inter := false ; if !ok_inter <> old_ok then Hashtbl.clear t ; @@ -804,8 +852,7 @@ pcases stderr cases ; prerr_endline "" ; *) - let r = c_test konst {arg=arg ; off=0} s in - r + hs (c_test {arg=arg ; off=0} s) ;; end diff -Nru ocaml-4.01.0/bytecomp/switch.mli ocaml-4.05.0/bytecomp/switch.mli --- ocaml-4.01.0/bytecomp/switch.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/bytecomp/switch.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* This module transforms generic switches in combinations @@ -17,9 +20,35 @@ (* For detecting action sharing, object style *) +(* Store for actions in object style: + act_store : store an action, returns index in table + In case an action with equal key exists, returns index + of the stored action. Otherwise add entry in table. + act_store_shared : This stored action will always be shared. + act_get : retrieve table + act_get_shared : retrieve table, with sharing explicit +*) + +type 'a shared = Shared of 'a | Single of 'a + type 'a t_store = - {act_get : unit -> 'a array ; act_store : 'a -> int} -val mk_store : ('a -> 'a -> bool) -> 'a t_store + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'a -> int ; + act_store_shared : 'a -> int ; } + +exception Not_simple + +module type Stored = sig + type t + type key + val make_key : t -> key option +end + +module Store(A:Stored) : + sig + val mk_store : unit -> A.t t_store + end (* Arguments to the Make functor *) module type S = @@ -39,6 +68,7 @@ (* Various constructors, for making a binder, adding one integer, etc. *) val bind : act -> (act -> act) -> act + val make_const : int -> act val make_offset : act -> int -> act val make_prim : primitive -> act list -> act val make_isout : act -> act -> act @@ -49,12 +79,15 @@ NB: cases is in the value form *) val make_switch : act -> int array -> act array -> act + (* Build last minute sharing of action stuff *) + val make_catch : act -> int * (act -> act) + val make_exit : int -> act + end (* - Make.zyva mk_const arg low high cases actions where - - mk_const takes an integer sends a constant action. + Make.zyva arg low high cases actions where - arg is the argument of the switch. - low, high are the interval limits. - cases is a list of sub-interval and action indices @@ -66,17 +99,18 @@ module Make : functor (Arg : S) -> sig +(* Standard entry point, sharing is tracked *) val zyva : (int * int) -> - (int -> Arg.act) -> Arg.act -> (int * int * int) array -> - Arg.act array -> + Arg.act t_store -> Arg.act + +(* Output test sequence, sharing tracked *) val test_sequence : - (int -> Arg.act) -> Arg.act -> (int * int * int) array -> - Arg.act array -> + Arg.act t_store -> Arg.act end diff -Nru ocaml-4.01.0/bytecomp/symtable.ml ocaml-4.05.0/bytecomp/symtable.ml --- ocaml-4.01.0/bytecomp/symtable.ml 2013-04-17 09:07:00.000000000 +0000 +++ ocaml-4.05.0/bytecomp/symtable.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* To assign numbers to globals and primitives *) @@ -27,12 +30,6 @@ exception Error of error -(* Tables for numbering objects *) - -type 'a numtable = - { num_cnt: int; (* The next number *) - num_tbl: ('a, int) Tbl.t } (* The table of already numbered objects *) - let empty_numtable = { num_cnt = 0; num_tbl = Tbl.empty } let find_numtable nt key = @@ -81,7 +78,9 @@ try find_numtable !c_prim_table name with Not_found -> - if !Clflags.custom_runtime then + if !Clflags.custom_runtime || Config.host <> Config.target + || !Clflags.no_check_prims + then enter_numtable c_prim_table name else begin let symb = @@ -96,7 +95,7 @@ if name.[0] <> '%' then ignore(num_of_prim name) let all_primitives () = - let prim = Array.create !c_prim_table.num_cnt "" in + let prim = Array.make !c_prim_table.num_cnt "" in Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl; prim @@ -134,13 +133,17 @@ let init () = (* Enter the predefined exceptions *) - Array.iter - (fun name -> + Array.iteri + (fun i name -> let id = try List.assoc name Predef.builtin_values with Not_found -> fatal_error "Symtable.init" in let c = slot_for_setglobal id in - let cst = Const_block(0, [Const_base(Const_string name)]) in + let cst = Const_block(Obj.object_tag, + [Const_base(Const_string (name, None)); + Const_base(Const_int (-i-1)) + ]) + in literal_table := (c, cst) :: !literal_table) Runtimedef.builtin_exceptions; (* Initialize the known C primitives *) @@ -194,7 +197,7 @@ gen_patch_int str_set buff pos (num_of_prim name)) patchlist -let patch_object = gen_patch_object String.unsafe_set +let patch_object = gen_patch_object Bytes.unsafe_set let ls_patch_object = gen_patch_object LongString.set (* Translate structured constants *) @@ -202,7 +205,7 @@ let rec transl_const = function Const_base(Const_int i) -> Obj.repr i | Const_base(Const_char c) -> Obj.repr c - | Const_base(Const_string s) -> Obj.repr s + | Const_base(Const_string (s, _)) -> Obj.repr s | Const_base(Const_float f) -> Obj.repr (float_of_string f) | Const_base(Const_int32 i) -> Obj.repr i | Const_base(Const_int64 i) -> Obj.repr i @@ -222,7 +225,7 @@ (* Build the initial table of globals *) let initial_global_table () = - let glob = Array.create !global_table.num_cnt (Obj.repr 0) in + let glob = Array.make !global_table.num_cnt (Obj.repr 0) in List.iter (fun (slot, cst) -> glob.(slot) <- transl_const cst) !literal_table; @@ -296,7 +299,8 @@ Dll.init_toplevel dllpath; (* Recover CRC infos for interfaces *) let crcintfs = - try (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t) list) + try + (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list) with Not_found -> [] in (* Done *) sect.close_reader(); @@ -322,12 +326,12 @@ List.fold_left (fun accu rel -> match rel with - (Reloc_setglobal id, pos) -> id :: accu + (Reloc_setglobal id, _pos) -> id :: accu | _ -> accu) [] patchlist in (* Then check that all referenced, not defined globals have a value *) let check_reference = function - (Reloc_getglobal id, pos) -> + (Reloc_getglobal id, _pos) -> if not (List.mem id defined_globals) && Obj.is_int (get_global_value id) then raise (Error(Uninitialized_global(Ident.name id))) @@ -372,3 +376,15 @@ fprintf ppf "Cannot find or execute the runtime system %s" s | Uninitialized_global s -> fprintf ppf "The value of the global `%s' is not yet computed" s + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + global_table := empty_numtable; + literal_table := []; + c_prim_table := empty_numtable diff -Nru ocaml-4.01.0/bytecomp/symtable.mli ocaml-4.05.0/bytecomp/symtable.mli --- ocaml-4.01.0/bytecomp/symtable.mli 2013-04-17 09:07:00.000000000 +0000 +++ ocaml-4.05.0/bytecomp/symtable.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Assign locations and numbers to globals and primitives *) @@ -17,7 +20,7 @@ (* Functions for batch linking *) val init: unit -> unit -val patch_object: string -> (reloc_info * int) list -> unit +val patch_object: bytes -> (reloc_info * int) list -> unit val ls_patch_object: Misc.LongString.t -> (reloc_info * int) list -> unit val require_primitive: string -> unit val initial_global_table: unit -> Obj.t array @@ -26,10 +29,11 @@ val output_primitive_table: out_channel -> unit val data_global_map: unit -> Obj.t val data_primitive_names: unit -> string +val transl_const: Lambda.structured_constant -> Obj.t (* Functions for the toplevel *) -val init_toplevel: unit -> (string * Digest.t) list +val init_toplevel: unit -> (string * Digest.t option) list val update_global_table: unit -> unit val get_global_value: Ident.t -> Obj.t val is_global_defined: Ident.t -> bool @@ -57,3 +61,5 @@ open Format val report_error: formatter -> error -> unit + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/translattribute.ml ocaml-4.05.0/bytecomp/translattribute.ml --- ocaml-4.01.0/bytecomp/translattribute.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/bytecomp/translattribute.ml 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,255 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Typedtree +open Lambda +open Location + +let is_inline_attribute = function + | {txt=("inline"|"ocaml.inline")}, _ -> true + | _ -> false + +let is_inlined_attribute = function + | {txt=("inlined"|"ocaml.inlined")}, _ -> true + | {txt=("unrolled"|"ocaml.unrolled")}, _ when Config.flambda -> true + | _ -> false + +let is_specialise_attribute = function + | {txt=("specialise"|"ocaml.specialise")}, _ when Config.flambda -> true + | _ -> false + +let is_specialised_attribute = function + | {txt=("specialised"|"ocaml.specialised")}, _ when Config.flambda -> true + | _ -> false + +let find_attribute p attributes = + let inline_attribute, other_attributes = + List.partition p attributes + in + let attr = + match inline_attribute with + | [] -> None + | [attr] -> Some attr + | _ :: ({txt;loc}, _) :: _ -> + Location.prerr_warning loc (Warnings.Duplicated_attribute txt); + None + in + attr, other_attributes + +let is_unrolled = function + | {txt="unrolled"|"ocaml.unrolled"} -> true + | {txt="inline"|"ocaml.inline"|"inlined"|"ocaml.inlined"} -> false + | _ -> assert false + +let parse_inline_attribute attr = + match attr with + | None -> Default_inline + | Some ({txt;loc} as id, payload) -> + let open Parsetree in + if is_unrolled id then begin + (* the 'unrolled' attributes must be used as [@unrolled n]. *) + let warning txt = Warnings.Attribute_payload + (txt, "It must be an integer literal") + in + match payload with + | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin + match pexp_desc with + | Pexp_constant (Pconst_integer(s, None)) -> begin + try + Unroll (Misc.Int_literal_converter.int s) + with Failure _ -> + Location.prerr_warning loc (warning txt); + Default_inline + end + | _ -> + Location.prerr_warning loc (warning txt); + Default_inline + end + | _ -> + Location.prerr_warning loc (warning txt); + Default_inline + end else begin + (* the 'inline' and 'inlined' attributes can be used as + [@inline], [@inline never] or [@inline always]. + [@inline] is equivalent to [@inline always] *) + let warning txt = + Warnings.Attribute_payload + (txt, "It must be either empty, 'always' or 'never'") + in + match payload with + | PStr [] -> Always_inline + | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin + match pexp_desc with + | Pexp_ident { txt = Longident.Lident "never" } -> + Never_inline + | Pexp_ident { txt = Longident.Lident "always" } -> + Always_inline + | _ -> + Location.prerr_warning loc (warning txt); + Default_inline + end + | _ -> + Location.prerr_warning loc (warning txt); + Default_inline + end + +let parse_specialise_attribute attr = + match attr with + | None -> Default_specialise + | Some ({txt; loc}, payload) -> + let open Parsetree in + let warning txt = + Warnings.Attribute_payload + (txt, "It must be either empty, 'always' or 'never'") + in + match payload with + | PStr [] -> Always_specialise + | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin + (* the 'specialise' and 'specialised' attributes can be used as + [@specialise], [@specialise never] or [@specialise always]. + [@specialise] is equivalent to [@specialise always] *) + match pexp_desc with + | Pexp_ident { txt = Longident.Lident "never" } -> + Never_specialise + | Pexp_ident { txt = Longident.Lident "always" } -> + Always_specialise + | _ -> + Location.prerr_warning loc (warning txt); + Default_specialise + end + | _ -> + Location.prerr_warning loc (warning txt); + Default_specialise + +let get_inline_attribute l = + let attr, _ = find_attribute is_inline_attribute l in + parse_inline_attribute attr + +let get_specialise_attribute l = + let attr, _ = find_attribute is_specialise_attribute l in + parse_specialise_attribute attr + +let add_inline_attribute expr loc attributes = + match expr, get_inline_attribute attributes with + | expr, Default_inline -> expr + | Lfunction({ attr = { stub = false } as attr } as funct), inline -> + begin match attr.inline with + | Default_inline -> () + | Always_inline | Never_inline | Unroll _ -> + Location.prerr_warning loc + (Warnings.Duplicated_attribute "inline") + end; + let attr = { attr with inline } in + Lfunction { funct with attr = attr } + | expr, (Always_inline | Never_inline | Unroll _) -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute "inline"); + expr + +let add_specialise_attribute expr loc attributes = + match expr, get_specialise_attribute attributes with + | expr, Default_specialise -> expr + | Lfunction({ attr = { stub = false } as attr } as funct), specialise -> + begin match attr.specialise with + | Default_specialise -> () + | Always_specialise | Never_specialise -> + Location.prerr_warning loc + (Warnings.Duplicated_attribute "specialise") + end; + let attr = { attr with specialise } in + Lfunction { funct with attr } + | expr, (Always_specialise | Never_specialise) -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute "specialise"); + expr + +(* Get the [@inlined] attribute payload (or default if not present). + It also returns the expression without this attribute. This is + used to ensure that this attribute is not misplaced: If it + appears on any expression, it is an error, otherwise it would + have been removed by this function *) +let get_and_remove_inlined_attribute e = + let attr, exp_attributes = + find_attribute is_inlined_attribute e.exp_attributes + in + let inlined = parse_inline_attribute attr in + inlined, { e with exp_attributes } + +let get_and_remove_inlined_attribute_on_module e = + let attr, mod_attributes = + find_attribute is_inlined_attribute e.mod_attributes + in + let inlined = parse_inline_attribute attr in + inlined, { e with mod_attributes } + +let get_and_remove_specialised_attribute e = + let attr, exp_attributes = + find_attribute is_specialised_attribute e.exp_attributes + in + let specialised = parse_specialise_attribute attr in + specialised, { e with exp_attributes } + +(* It also remove the attribute from the expression, like + get_inlined_attribute *) +let get_tailcall_attribute e = + let is_tailcall_attribute = function + | {txt=("tailcall"|"ocaml.tailcall")}, _ -> true + | _ -> false + in + let tailcalls, exp_attributes = + List.partition is_tailcall_attribute e.exp_attributes + in + match tailcalls with + | [] -> false, e + | _ :: r -> + begin match r with + | [] -> () + | ({txt;loc}, _) :: _ -> + Location.prerr_warning loc (Warnings.Duplicated_attribute txt) + end; + true, { e with exp_attributes } + +let check_attribute e ({ txt; loc }, _) = + match txt with + | "inline" | "ocaml.inline" + | "specialise" | "ocaml.specialise" -> begin + match e.exp_desc with + | Texp_function _ -> () + | _ -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute txt) + end + | "inlined" | "ocaml.inlined" + | "specialised" | "ocaml.specialised" + | "tailcall" | "ocaml.tailcall" -> + (* Removed by the Texp_apply cases *) + Location.prerr_warning loc + (Warnings.Misplaced_attribute txt) + | _ -> () + +let check_attribute_on_module e ({ txt; loc }, _) = + match txt with + | "inline" | "ocaml.inline" -> begin + match e.mod_desc with + | Tmod_functor _ -> () + | _ -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute txt) + end + | "inlined" | "ocaml.inlined" -> + (* Removed by the Texp_apply cases *) + Location.prerr_warning loc + (Warnings.Misplaced_attribute txt) + | _ -> () diff -Nru ocaml-4.01.0/bytecomp/translattribute.mli ocaml-4.05.0/bytecomp/translattribute.mli --- ocaml-4.01.0/bytecomp/translattribute.mli 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/bytecomp/translattribute.mli 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,60 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +val check_attribute + : Typedtree.expression + -> string Location.loc * _ + -> unit + +val check_attribute_on_module + : Typedtree.module_expr + -> string Location.loc * _ + -> unit + +val add_inline_attribute + : Lambda.lambda + -> Location.t + -> Parsetree.attributes + -> Lambda.lambda + +val get_inline_attribute + : Parsetree.attributes + -> Lambda.inline_attribute + +val add_specialise_attribute + : Lambda.lambda + -> Location.t + -> Parsetree.attributes + -> Lambda.lambda + +val get_specialise_attribute + : Parsetree.attributes + -> Lambda.specialise_attribute + +val get_and_remove_inlined_attribute + : Typedtree.expression + -> Lambda.inline_attribute * Typedtree.expression + +val get_and_remove_inlined_attribute_on_module + : Typedtree.module_expr + -> Lambda.inline_attribute * Typedtree.module_expr + +val get_and_remove_specialised_attribute + : Typedtree.expression + -> Lambda.specialise_attribute * Typedtree.expression + +val get_tailcall_attribute + : Typedtree.expression + -> bool * Typedtree.expression diff -Nru ocaml-4.01.0/bytecomp/translclass.ml ocaml-4.05.0/bytecomp/translclass.ml --- ocaml-4.01.0/bytecomp/translclass.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/translclass.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Asttypes open Types @@ -17,7 +20,7 @@ open Translobj open Translcore -(* XXX Rajouter des evenements... *) +(* XXX Rajouter des evenements... | Add more events... *) type error = Illegal_class_expr | Tags of label * label @@ -26,24 +29,34 @@ let lfunction params body = if params = [] then body else match body with - Lfunction (Curried, params', body') -> - Lfunction (Curried, params @ params', body') + | Lfunction {kind = Curried; params = params'; body = body'; attr; loc} -> + Lfunction {kind = Curried; params = params @ params'; body = body'; attr; + loc} | _ -> - Lfunction (Curried, params, body) - -let lapply func args loc = - match func with - Lapply(func', args', _) -> - Lapply(func', args' @ args, loc) + Lfunction {kind = Curried; params; + body; + attr = default_function_attribute; + loc = Location.none} + +let lapply ap = + match ap.ap_func with + Lapply ap' -> + Lapply {ap with ap_func = ap'.ap_func; ap_args = ap'.ap_args @ ap.ap_args} | _ -> - Lapply(func, args, loc) + Lapply ap -let mkappl (func, args) = Lapply (func, args, Location.none);; +let mkappl (func, args) = + Lapply {ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=func; + ap_args=args; + ap_inlined=Default_inline; + ap_specialised=Default_specialise};; let lsequence l1 l2 = if l2 = lambda_unit then l1 else Lsequence(l1, l2) -let lfield v i = Lprim(Pfield i, [Lvar v]) +let lfield v i = Lprim(Pfield i, [Lvar v], Location.none) let transl_label l = share (Const_immstring l) @@ -53,18 +66,8 @@ (0, List.map (fun lab -> Const_immstring lab) lst)) let set_inst_var obj id expr = - let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in - Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr]) - -let copy_inst_var obj id expr templ offset = - let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in - let id' = Ident.create (Ident.name id) in - Llet(Strict, id', Lprim (Pidentity, [Lvar id]), - Lprim(Parraysetu kind, - [Lvar obj; Lvar id'; - Lprim(Parrayrefu kind, [Lvar templ; Lprim(Paddint, - [Lvar id'; - Lvar offset])])])) + Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment), + [Lvar obj; Lvar id; transl_exp expr], Location.none) let transl_val tbl create name = mkappl (oo_prim (if create then "new_variable" else "get_variable"), @@ -73,7 +76,7 @@ let transl_vals tbl create strict vals rem = List.fold_right (fun (name, id) rem -> - Llet(strict, id, transl_val tbl create name, rem)) + Llet(strict, Pgenval, id, transl_val tbl create name, rem)) vals rem let meths_super tbl meths inh_meths = @@ -88,7 +91,8 @@ let bind_super tbl (vals, meths) cl_init = transl_vals tbl false StrictOpt vals - (List.fold_right (fun (nm, id, def) rem -> Llet(StrictOpt, id, def, rem)) + (List.fold_right (fun (_nm, id, def) rem -> + Llet(StrictOpt, Pgenval, id, def, rem)) meths cl_init) let create_object cl obj init = @@ -101,7 +105,7 @@ [obj; Lvar cl])) else begin (inh_init, - Llet(Strict, obj', + Llet(Strict, Pgenval, obj', mkappl (oo_prim "create_object_opt", [obj; Lvar cl]), Lsequence(obj_init, if not has_init then Lvar obj' else @@ -109,6 +113,15 @@ [obj; Lvar obj'; Lvar cl])))) end +let name_pattern default p = + match p.pat_desc with + | Tpat_var (id, _) -> id + | Tpat_alias(_, id, _) -> id + | _ -> Ident.create default + +let normalize_cl_path cl path = + Env.normalize_path (Some cl.cl_loc) cl.cl_env path + let rec build_object_init cl_table obj params inh_init obj_init cl = match cl.cl_desc with Tcl_ident ( path, _, _) -> @@ -116,9 +129,13 @@ let envs, inh_init = inh_init in let env = match envs with None -> [] - | Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])] + | Some envs -> + [Lprim(Pfield (List.length inh_init + 1), + [Lvar envs], + Location.none)] in - ((envs, (obj_init, path)::inh_init), + ((envs, (obj_init, normalize_cl_path cl path) + ::inh_init), mkappl(Lvar obj_init, env @ [obj])) | Tcl_structure str -> create_object cl_table obj (fun obj -> @@ -126,18 +143,18 @@ List.fold_right (fun field (inh_init, obj_init, has_init) -> match field.cf_desc with - Tcf_inher (_, cl, _, _, _) -> + Tcf_inherit (_, cl, _, _, _) -> let (inh_init, obj_init') = build_object_init cl_table (Lvar obj) [] inh_init (fun _ -> lambda_unit) cl in (inh_init, lsequence obj_init' obj_init, true) - | Tcf_val (_, _, _, id, Tcfk_concrete exp, _) -> + | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) -> (inh_init, lsequence (set_inst_var obj id exp) obj_init, has_init) - | Tcf_meth _ | Tcf_val _ | Tcf_constr _ -> + | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _-> (inh_init, obj_init, has_init) - | Tcf_init _ -> + | Tcf_initializer _ -> (inh_init, obj_init, true) ) str.cstr_fields @@ -156,14 +173,16 @@ in (inh_init, let build params rem = - let param = name_pattern "param" [pat, ()] in - Lfunction (Curried, param::params, - Matching.for_function - pat.pat_loc None (Lvar param) [pat, rem] partial) + let param = name_pattern "param" pat in + Lfunction {kind = Curried; params = param::params; + attr = default_function_attribute; + loc = pat.pat_loc; + body = Matching.for_function + pat.pat_loc None (Lvar param) [pat, rem] partial} in begin match obj_init with - Lfunction (Curried, params, rem) -> build params rem - | rem -> build [] rem + Lfunction {kind = Curried; params; body = rem} -> build params rem + | rem -> build [] rem end) | Tcl_apply (cl, oexprs) -> let (inh_init, obj_init) = @@ -176,12 +195,12 @@ build_object_init cl_table obj (vals @ params) inh_init obj_init cl in (inh_init, Translcore.transl_let rec_flag defs obj_init) - | Tcl_constraint (cl, _, vals, pub_meths, concr_meths) -> + | Tcl_constraint (cl, _, _vals, _pub_meths, _concr_meths) -> build_object_init cl_table obj params inh_init obj_init cl let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = match cl.cl_desc with - Tcl_let (rec_flag, defs, vals, cl) -> + Tcl_let (_rec_flag, _defs, vals, cl) -> let vals = List.map (fun (id, _, e) -> id,e) vals in build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids | _ -> @@ -190,14 +209,14 @@ let obj = if ids = [] then lambda_unit else Lvar self in let envs = if top then None else Some env in let ((_,inh_init), obj_init) = - build_object_init cl_table obj params (envs,[]) (copy_env env) cl in + build_object_init cl_table obj params (envs,[]) copy_env cl in let obj_init = if ids = [] then obj_init else lfunction [self] obj_init in (inh_init, lfunction [env] (subst_env env inh_init obj_init)) let bind_method tbl lab id cl_init = - Llet(Strict, id, mkappl (oo_prim "get_method_label", + Llet(Strict, Pgenval, id, mkappl (oo_prim "get_method_label", [Lvar tbl; transl_label lab]), cl_init) @@ -212,11 +231,12 @@ if nvals = 0 then "get_method_labels", [] else "new_methods_variables", [transl_meth_list (List.map fst vals)] in - Llet(Strict, ids, + Llet(Strict, Pgenval, ids, mkappl (oo_prim getter, [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), List.fold_right - (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam)) + (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Pgenval, id, + lfield ids !i, lam)) (methl @ vals) cl_init) let output_methods tbl methods lam = @@ -226,7 +246,8 @@ lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam | _ -> lsequence (mkappl(oo_prim "set_methods", - [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)])) + [Lvar tbl; Lprim(Pmakeblock(0,Immutable,None), + methods, Location.none)])) lam let rec ignore_cstrs cl = @@ -246,12 +267,13 @@ match cl.cl_desc with Tcl_ident ( path, _, _) -> begin match inh_init with - (obj_init, path')::inh_init -> - let lpath = transl_path path in + (obj_init, _path')::inh_init -> + let lpath = transl_path ~loc:cl.cl_loc cl.cl_env path in (inh_init, - Llet (Strict, obj_init, - mkappl(Lprim(Pfield 1, [lpath]), Lvar cla :: - if top then [Lprim(Pfield 3, [lpath])] else []), + Llet (Strict, Pgenval, obj_init, + mkappl(Lprim(Pfield 1, [lpath], Location.none), Lvar cla :: + if top then [Lprim(Pfield 3, [lpath], Location.none)] + else []), bind_super cla super cl_init)) | _ -> assert false @@ -262,52 +284,56 @@ List.fold_right (fun field (inh_init, cl_init, methods, values) -> match field.cf_desc with - Tcf_inher (_, cl, _, vals, meths) -> + Tcf_inherit (_, cl, _, vals, meths) -> let cl_init = output_methods cla methods cl_init in let inh_init, cl_init = build_class_init cla false (vals, meths_super cla str.cstr_meths meths) inh_init cl_init msubst top cl in (inh_init, cl_init, [], values) - | Tcf_val (name, _, _, id, exp, over) -> - let values = if over then values else (name, id) :: values in + | Tcf_val (name, _, id, _, over) -> + let values = + if over then values else (name.txt, id) :: values + in (inh_init, cl_init, methods, values) - | Tcf_meth (_, _, _, Tcfk_virtual _, _) - | Tcf_constr _ + | Tcf_method (_, _, Tcfk_virtual _) + | Tcf_constraint _ -> (inh_init, cl_init, methods, values) - | Tcf_meth (name, _, _, Tcfk_concrete exp, over) -> + | Tcf_method (name, _, Tcfk_concrete (_, exp)) -> let met_code = msubst true (transl_exp exp) in let met_code = if !Clflags.native_code && List.length met_code = 1 then (* Force correct naming of method for profiles *) - let met = Ident.create ("method_" ^ name) in - [Llet(Strict, met, List.hd met_code, Lvar met)] + let met = Ident.create ("method_" ^ name.txt) in + [Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)] else met_code in (inh_init, cl_init, - Lvar (Meths.find name str.cstr_meths) :: met_code @ methods, + Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods, values) - | Tcf_init exp -> + | Tcf_initializer exp -> (inh_init, Lsequence(mkappl (oo_prim "add_initializer", Lvar cla :: msubst false (transl_exp exp)), cl_init), - methods, values)) + methods, values) + | Tcf_attribute _ -> + (inh_init, cl_init, methods, values)) str.cstr_fields (inh_init, cl_init, [], []) in let cl_init = output_methods cla methods cl_init in (inh_init, bind_methods cla str.cstr_meths values cl_init) - | Tcl_fun (_, pat, vals, cl, _) -> + | Tcl_fun (_, _pat, vals, cl, _) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in let vals = List.map bind_id_as_val vals in (inh_init, transl_vals cla true StrictOpt vals cl_init) - | Tcl_apply (cl, exprs) -> + | Tcl_apply (cl, _exprs) -> build_class_init cla cstr super inh_init cl_init msubst top cl - | Tcl_let (rec_flag, defs, vals, cl) -> + | Tcl_let (_rec_flag, _defs, vals, cl) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in @@ -325,27 +351,29 @@ let cl = ignore_cstrs cl in begin match cl.cl_desc, inh_init with Tcl_ident (path, _, _), (obj_init, path')::inh_init -> - assert (Path.same path path'); - let lpath = transl_path path in + assert (Path.same (normalize_cl_path cl path) path'); + let lpath = transl_normal_path path' in let inh = Ident.create "inh" and ofs = List.length vals + 1 and valids, methids = super in let cl_init = List.fold_left (fun init (nm, id, _) -> - Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs), + Llet(StrictOpt, Pgenval, id, + lfield inh (index nm concr_meths + ofs), init)) cl_init methids in let cl_init = List.fold_left (fun init (nm, id) -> - Llet(StrictOpt, id, lfield inh (index nm vals + 1), init)) + Llet(StrictOpt, Pgenval, id, + lfield inh (index nm vals + 1), init)) cl_init valids in (inh_init, - Llet (Strict, inh, + Llet (Strict, Pgenval, inh, mkappl(oo_prim "inherits", narrow_args @ [lpath; Lconst(Const_pointer(if top then 1 else 0))]), - Llet(StrictOpt, obj_init, lfield inh 0, cl_init))) + Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init))) | _ -> let core cl_init = build_class_init cla true super inh_init cl_init msubst top cl @@ -361,7 +389,7 @@ let rec build_class_lets cl ids = match cl.cl_desc with - Tcl_let (rec_flag, defs, vals, cl') -> + Tcl_let (rec_flag, defs, _vals, cl') -> let env, wrap = build_class_lets cl' [] in (env, fun x -> let lam = Translcore.transl_let rec_flag defs (wrap x) in @@ -383,6 +411,7 @@ (* XXX Il devrait etre peu couteux d'ecrire des classes : + | Writing classes should be cheap class c x y = d e f *) let rec transl_class_rebind obj_init cl vf = @@ -392,23 +421,25 @@ try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit with Not_found -> raise Exit end; - (path, obj_init) + (normalize_cl_path cl path, obj_init) | Tcl_fun (_, pat, _, cl, partial) -> let path, obj_init = transl_class_rebind obj_init cl vf in let build params rem = - let param = name_pattern "param" [pat, ()] in - Lfunction (Curried, param::params, - Matching.for_function - pat.pat_loc None (Lvar param) [pat, rem] partial) + let param = name_pattern "param" pat in + Lfunction {kind = Curried; params = param::params; + attr = default_function_attribute; + loc = pat.pat_loc; + body = Matching.for_function + pat.pat_loc None (Lvar param) [pat, rem] partial} in (path, match obj_init with - Lfunction (Curried, params, rem) -> build params rem - | rem -> build [] rem) + Lfunction {kind = Curried; params; body} -> build params body + | rem -> build [] rem) | Tcl_apply (cl, oexprs) -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, transl_apply obj_init oexprs Location.none) - | Tcl_let (rec_flag, defs, vals, cl) -> + | Tcl_let (rec_flag, defs, _vals, cl) -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) | Tcl_structure _ -> raise Exit @@ -416,7 +447,7 @@ let path, obj_init = transl_class_rebind obj_init cl' vf in let rec check_constraint = function Cty_constr(path', _, _) when Path.same path path' -> () - | Cty_fun (_, _, cty) -> check_constraint cty + | Cty_arrow (_, _, cty) -> check_constraint cty | _ -> raise Exit in check_constraint cl.cl_type; @@ -424,7 +455,7 @@ let rec transl_class_rebind_0 self obj_init cl vf = match cl.cl_desc with - Tcl_let (rec_flag, defs, vals, cl) -> + Tcl_let (rec_flag, defs, _vals, cl) -> let path, obj_init = transl_class_rebind_0 self obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) | _ -> @@ -435,12 +466,19 @@ try let obj_init = Ident.create "obj_init" and self = Ident.create "self" in - let obj_init0 = lapply (Lvar obj_init) [Lvar self] Location.none in + let obj_init0 = + lapply {ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lvar obj_init; + ap_args=[Lvar self]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + in let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in if not (Translcore.check_recursive_lambda ids obj_init') then raise(Error(cl.cl_loc, Illegal_class_expr)); let id = (obj_init' = lfunction [self] obj_init0) in - if id then transl_path path else + if id then transl_normal_path path else let cla = Ident.create "class" and new_init = Ident.create "new_init" @@ -448,19 +486,20 @@ and table = Ident.create "table" and envs = Ident.create "envs" in Llet( - Strict, new_init, lfunction [obj_init] obj_init', + Strict, Pgenval, new_init, lfunction [obj_init] obj_init', Llet( - Alias, cla, transl_path path, - Lprim(Pmakeblock(0, Immutable), + Alias, Pgenval, cla, transl_normal_path path, + Lprim(Pmakeblock(0, Immutable, None), [mkappl(Lvar new_init, [lfield cla 0]); lfunction [table] - (Llet(Strict, env_init, + (Llet(Strict, Pgenval, env_init, mkappl(lfield cla 1, [Lvar table]), lfunction [envs] (mkappl(Lvar new_init, [mkappl(Lvar env_init, [Lvar envs])])))); lfield cla 2; - lfield cla 3]))) + lfield cla 3], + Location.none))) with Exit -> lambda_unit @@ -469,14 +508,14 @@ let rec module_path = function Lvar id -> let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z' - | Lprim(Pfield _, [p]) -> module_path p - | Lprim(Pgetglobal _, []) -> true - | _ -> false + | Lprim(Pfield _, [p], _) -> module_path p + | Lprim(Pgetglobal _, [], _) -> true + | _ -> false let const_path local = function Lvar id -> not (List.mem id local) | Lconst _ -> true - | Lfunction (Curried, _, body) -> + | Lfunction {kind = Curried; body} -> let fv = free_variables body in List.for_all (fun x -> not (IdentSet.mem x fv)) local | p -> module_path p @@ -486,23 +525,23 @@ let conv = function (* Lvar s when List.mem s self -> "_self", [] *) | p when const_path p -> "const", [p] - | Lprim(Parrayrefu _, [Lvar s; Lvar n]) when List.mem s self -> + | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self -> "var", [Lvar n] - | Lprim(Pfield n, [Lvar e]) when Ident.same e env -> + | Lprim(Pfield n, [Lvar e], _) when Ident.same e env -> "env", [Lvar env2; Lconst(Const_pointer n)] | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> "meth", [met] | _ -> raise Not_found in match body with - | Llet(_, s', Lvar s, body) when List.mem s self -> + | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> builtin_meths (s'::self) env env2 body - | Lapply(f, [arg], _) when const_path f -> + | Lapply{ap_func = f; ap_args = [arg]} when const_path f -> let s, args = conv arg in ("app_"^s, f :: args) - | Lapply(f, [arg; p], _) when const_path f && const_path p -> + | Lapply{ap_func = f; ap_args = [arg; p]} when const_path f && const_path p -> let s, args = conv arg in ("app_"^s^"_const", f :: args @ [p]) - | Lapply(f, [p; arg], _) when const_path f && const_path p -> + | Lapply{ap_func = f; ap_args = [p; arg]} when const_path f && const_path p -> let s, args = conv arg in ("app_const_"^s, f :: p :: args) | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self -> @@ -516,12 +555,12 @@ | Lsend(Cached, met, arg, [_;_], _) -> let s, args = conv arg in ("send_"^s, met :: args) - | Lfunction (Curried, [x], body) -> + | Lfunction {kind = Curried; params = [x]; body} -> let rec enter self = function - | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x']) + | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _) when Ident.same x x' && List.mem s self -> ("set_var", [Lvar n]) - | Llet(_, s', Lvar s, body) when List.mem s self -> + | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> enter (s'::self) body | _ -> raise Not_found in enter self body @@ -566,26 +605,29 @@ (* - Traduction d'une classe. - Plusieurs cas: - * reapplication d'une classe connue -> transl_class_rebind - * classe sans dependances locales -> traduction directe - * avec dependances locale -> creation d'un arbre de stubs, - avec un noeud pour chaque classe locale heritee - Une classe est un 4-uplet: + Class translation. + Three subcases: + * reapplication of a known class -> transl_class_rebind + * class without local dependencies -> direct translation + * with local dependencies -> generate a stubs tree, + with a node for every local classes inherited + A class is a 4-tuple: (obj_init, class_init, env_init, env) - obj_init: fonction de creation d'objet (unit -> obj) - class_init: fonction d'heritage (table -> env_init) - (une seule par code source) - env_init: parametrage par l'environnement local (env -> params -> obj_init) - (une par combinaison de class_init herites) + obj_init: creation function (unit -> obj) + class_init: inheritance function (table -> env_init) + (one by source code) + env_init: parameterisation by the local environment + (env -> params -> obj_init) + (one for each combination of inherited class_init ) env: environnement local - Si ids=0 (objet immediat), alors on ne conserve que env_init. + If ids=0 (immediate object), then only env_init is conserved. *) +(* let prerr_ids msg ids = let names = List.map Ident.unique_toplevel_name ids in prerr_endline (String.concat " " (msg :: names)) +*) let transl_class ids cl_id pub_meths cl vflag = (* First check if it is not only a rebind *) @@ -624,7 +666,7 @@ in let new_ids_meths = ref [] in let msubst arr = function - Lfunction (Curried, self :: args, body) -> + Lfunction {kind = Curried; params = self :: args; body} -> let env = Ident.create "env" in let body' = if new_ids = [] then body else @@ -637,24 +679,27 @@ with Not_found -> [lfunction (self :: args) (if not (IdentSet.mem env (free_variables body')) then body' else - Llet(Alias, env, - Lprim(Parrayrefu Paddrarray, - [Lvar self; Lvar env2]), body'))] + Llet(Alias, Pgenval, env, + Lprim(Pfield_computed, + [Lvar self; Lvar env2], + Location.none), + body'))] end | _ -> assert false in let new_ids_init = ref [] in let env1 = Ident.create "env" and env1' = Ident.create "env'" in - let copy_env envs self = + let copy_env self = if top then lambda_unit else - Lifused(env2, Lprim(Parraysetu Paddrarray, - [Lvar self; Lvar env2; Lvar env1'])) + Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment), + [Lvar self; Lvar env2; Lvar env1'], + Location.none)) and subst_env envs l lam = if top then lam else (* must be called only once! *) let lam = subst_lambda (subst env1 lam 1 new_ids_init) lam in - Llet(Alias, env1, (if l = [] then Lvar envs else lfield envs 0), - Llet(Alias, env1', + Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0), + Llet(Alias, Pgenval, env1', (if !new_ids_init = [] then Lvar env1 else lfield env1 0), lam)) in @@ -684,10 +729,10 @@ if name' <> name then raise(Error(cl.cl_loc, Tags(name, name')))) tags pub_meths; let ltable table lam = - Llet(Strict, table, + Llet(Strict, Pgenval, table, mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam) and ldirect obj_init = - Llet(Strict, obj_init, cl_init, + Llet(Strict, Pgenval, obj_init, cl_init, Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), mkappl (Lvar obj_init, [lambda_unit]))) in @@ -696,8 +741,11 @@ let concrete = (vflag = Concrete) and lclass lam = - let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in - Llet(Strict, class_init, cl_init, lam (free_variables cl_init)) + let cl_init = llets (Lfunction{kind = Curried; + attr = default_function_attribute; + loc = Location.none; + params = [cla]; body = cl_init}) in + Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init)) and lbody fv = if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then mkappl (oo_prim "make_class",[transl_meth_list pub_meths; @@ -705,15 +753,21 @@ else ltable table ( Llet( - Strict, env_init, mkappl (Lvar class_init, [Lvar table]), + Strict, Pgenval, env_init, mkappl (Lvar class_init, [Lvar table]), Lsequence( mkappl (oo_prim "init_class", [Lvar table]), - Lprim(Pmakeblock(0, Immutable), + Lprim(Pmakeblock(0, Immutable, None), [mkappl (Lvar env_init, [lambda_unit]); - Lvar class_init; Lvar env_init; lambda_unit])))) + Lvar class_init; Lvar env_init; lambda_unit], + Location.none)))) and lbody_virt lenvs = - Lprim(Pmakeblock(0, Immutable), - [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs]) + Lprim(Pmakeblock(0, Immutable, None), + [lambda_unit; Lfunction{kind = Curried; + attr = default_function_attribute; + loc = Location.none; + params = [cla]; body = cl_init}; + lambda_unit; lenvs], + Location.none) in (* Still easy: a class defined at toplevel *) if top && concrete then lclass lbody else @@ -729,49 +783,64 @@ let lenv = let menv = if !new_ids_meths = [] then lambda_unit else - Lprim(Pmakeblock(0, Immutable), - List.map (fun id -> Lvar id) !new_ids_meths) in + Lprim(Pmakeblock(0, Immutable, None), + List.map (fun id -> Lvar id) !new_ids_meths, + Location.none) in if !new_ids_init = [] then menv else - Lprim(Pmakeblock(0, Immutable), - menv :: List.map (fun id -> Lvar id) !new_ids_init) + Lprim(Pmakeblock(0, Immutable, None), + menv :: List.map (fun id -> Lvar id) !new_ids_init, + Location.none) and linh_envs = - List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p])) + List.map + (fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p], Location.none)) (List.rev inh_init) in let make_envs lam = - Llet(StrictOpt, envs, + Llet(StrictOpt, Pgenval, envs, (if linh_envs = [] then lenv else - Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)), + Lprim(Pmakeblock(0, Immutable, None), + lenv :: linh_envs, Location.none)), lam) and def_ids cla lam = - Llet(StrictOpt, env2, + Llet(StrictOpt, Pgenval, env2, mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]), lam) in let inh_paths = List.filter - (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in + (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init + in let inh_keys = - List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in + List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p], + Location.none)) + inh_paths + in let lclass lam = - Llet(Strict, class_init, - Lfunction(Curried, [cla], def_ids cla cl_init), lam) + Llet(Strict, Pgenval, class_init, + Lfunction{kind = Curried; params = [cla]; + attr = default_function_attribute; + loc = Location.none; + body = def_ids cla cl_init}, lam) and lcache lam = - if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else - Llet(Strict, cached, + if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else + Llet(Strict, Pgenval, cached, mkappl (oo_prim "lookup_tables", - [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]), + [Lvar tables; Lprim(Pmakeblock(0, Immutable, None), + inh_keys, Location.none)]), lam) and lset cached i lam = - Lprim(Psetfield(i, true), [Lvar cached; lam]) + Lprim(Psetfield(i, Pointer, Assignment), + [Lvar cached; lam], Location.none) in let ldirect () = ltable cla - (Llet(Strict, env_init, def_ids cla cl_init, + (Llet(Strict, Pgenval, env_init, def_ids cla cl_init, Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), lset cached 0 (Lvar env_init)))) and lclass_virt () = - lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init)) + lset cached 0 (Lfunction{kind = Curried; attr = default_function_attribute; + loc = Location.none; + params = [cla]; body = def_ids cla cl_init}) in llets ( lcache ( @@ -785,20 +854,21 @@ Lvar class_init; Lvar cached]))), make_envs ( if ids = [] then mkappl (lfield cached 0, [lenvs]) else - Lprim(Pmakeblock(0, Immutable), - if concrete then + Lprim(Pmakeblock(0, Immutable, None), + (if concrete then [mkappl (lfield cached 0, [lenvs]); lfield cached 1; lfield cached 0; lenvs] - else [lambda_unit; lfield cached 0; lambda_unit; lenvs] + else [lambda_unit; lfield cached 0; lambda_unit; lenvs]), + Location.none ))))) (* Wrapper for class compilation *) (* let cl_id = ci.ci_id_class in (* TODO: cl_id is used somewhere else as typesharp ? *) - let _arity = List.length (fst ci.ci_params) in + let _arity = List.length ci.ci_params in let pub_meths = m in let cl = ci.ci_expr in let vflag = vf in @@ -820,3 +890,12 @@ | Tags (lab1, lab2) -> fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s" lab1 lab2 "Change one of them." + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) diff -Nru ocaml-4.01.0/bytecomp/translclass.mli ocaml-4.05.0/bytecomp/translclass.mli --- ocaml-4.01.0/bytecomp/translclass.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/translclass.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Typedtree open Lambda diff -Nru ocaml-4.01.0/bytecomp/translcore.ml ocaml-4.05.0/bytecomp/translcore.ml --- ocaml-4.01.0/bytecomp/translcore.ml 2013-05-28 11:05:58.000000000 +0000 +++ ocaml-4.05.0/bytecomp/translcore.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Translation from typed abstract syntax to lambda terms, for the core language *) @@ -26,132 +29,167 @@ | Illegal_letrec_expr | Free_super_var | Unknown_builtin_primitive of string + | Unreachable_reached exception Error of Location.t * error +let use_dup_for_constant_arrays_bigger_than = 4 + (* Forward declaration -- to be filled in by Translmod.transl_module *) let transl_module = - ref((fun cc rootpath modl -> assert false) : + ref((fun _cc _rootpath _modl -> assert false) : module_coercion -> Path.t option -> module_expr -> lambda) let transl_object = - ref (fun id s cl -> assert false : + ref (fun _id _s _cl -> assert false : Ident.t -> string list -> class_expr -> lambda) +(* Compile an exception/extension definition *) + +let prim_fresh_oo_id = + Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false) + +let transl_extension_constructor env path ext = + let name = + match path, !Clflags.for_package with + None, _ -> Ident.name ext.ext_id + | Some p, None -> Path.name p + | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p) + in + let loc = ext.ext_loc in + match ext.ext_kind with + Text_decl _ -> + Lprim (Pmakeblock (Obj.object_tag, Immutable, None), + [Lconst (Const_base (Const_string (name, None))); + Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)], + loc) + | Text_rebind(path, _lid) -> + transl_path ~loc env path + (* Translation of primitives *) let comparisons_table = create_hashtable 11 [ "%equal", - (Pccall{prim_name = "caml_equal"; prim_arity = 2; prim_alloc = true; - prim_native_name = ""; prim_native_float = false}, + (Pccall(Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true), Pintcomp Ceq, Pfloatcomp Ceq, - Pccall{prim_name = "caml_string_equal"; prim_arity = 2; - prim_alloc = false; - prim_native_name = ""; prim_native_float = false}, + Pccall(Primitive.simple ~name:"caml_string_equal" ~arity:2 + ~alloc:false), + Pccall(Primitive.simple ~name:"caml_bytes_equal" ~arity:2 + ~alloc:false), Pbintcomp(Pnativeint, Ceq), Pbintcomp(Pint32, Ceq), Pbintcomp(Pint64, Ceq), true); "%notequal", - (Pccall{prim_name = "caml_notequal"; prim_arity = 2; prim_alloc = true; - prim_native_name = ""; prim_native_float = false}, + (Pccall(Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true), Pintcomp Cneq, Pfloatcomp Cneq, - Pccall{prim_name = "caml_string_notequal"; prim_arity = 2; - prim_alloc = false; prim_native_name = ""; - prim_native_float = false}, + Pccall(Primitive.simple ~name:"caml_string_notequal" ~arity:2 + ~alloc:false), + Pccall(Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 + ~alloc:false), Pbintcomp(Pnativeint, Cneq), Pbintcomp(Pint32, Cneq), Pbintcomp(Pint64, Cneq), true); "%lessthan", - (Pccall{prim_name = "caml_lessthan"; prim_arity = 2; prim_alloc = true; - prim_native_name = ""; prim_native_float = false}, + (Pccall(Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true), Pintcomp Clt, Pfloatcomp Clt, - Pccall{prim_name = "caml_string_lessthan"; prim_arity = 2; - prim_alloc = false; prim_native_name = ""; - prim_native_float = false}, + Pccall(Primitive.simple ~name:"caml_string_lessthan" ~arity:2 + ~alloc:false), + Pccall(Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 + ~alloc:false), Pbintcomp(Pnativeint, Clt), Pbintcomp(Pint32, Clt), Pbintcomp(Pint64, Clt), false); "%greaterthan", - (Pccall{prim_name = "caml_greaterthan"; prim_arity = 2; prim_alloc = true; - prim_native_name = ""; prim_native_float = false}, + (Pccall(Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true), Pintcomp Cgt, Pfloatcomp Cgt, - Pccall{prim_name = "caml_string_greaterthan"; prim_arity = 2; - prim_alloc = false; prim_native_name = ""; - prim_native_float = false}, + Pccall(Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 + ~alloc: false), + Pccall(Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 + ~alloc: false), Pbintcomp(Pnativeint, Cgt), Pbintcomp(Pint32, Cgt), Pbintcomp(Pint64, Cgt), false); "%lessequal", - (Pccall{prim_name = "caml_lessequal"; prim_arity = 2; prim_alloc = true; - prim_native_name = ""; prim_native_float = false}, + (Pccall(Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true), Pintcomp Cle, Pfloatcomp Cle, - Pccall{prim_name = "caml_string_lessequal"; prim_arity = 2; - prim_alloc = false; prim_native_name = ""; - prim_native_float = false}, + Pccall(Primitive.simple ~name:"caml_string_lessequal" ~arity:2 + ~alloc:false), + Pccall(Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 + ~alloc:false), Pbintcomp(Pnativeint, Cle), Pbintcomp(Pint32, Cle), Pbintcomp(Pint64, Cle), false); "%greaterequal", - (Pccall{prim_name = "caml_greaterequal"; prim_arity = 2; - prim_alloc = true; - prim_native_name = ""; prim_native_float = false}, + (Pccall(Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true), Pintcomp Cge, Pfloatcomp Cge, - Pccall{prim_name = "caml_string_greaterequal"; prim_arity = 2; - prim_alloc = false; prim_native_name = ""; - prim_native_float = false}, + Pccall(Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 + ~alloc:false), + Pccall(Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 + ~alloc:false), Pbintcomp(Pnativeint, Cge), Pbintcomp(Pint32, Cge), Pbintcomp(Pint64, Cge), false); "%compare", - (Pccall{prim_name = "caml_compare"; prim_arity = 2; prim_alloc = true; - prim_native_name = ""; prim_native_float = false}, - Pccall{prim_name = "caml_int_compare"; prim_arity = 2; - prim_alloc = false; prim_native_name = ""; - prim_native_float = false}, - Pccall{prim_name = "caml_float_compare"; prim_arity = 2; - prim_alloc = false; prim_native_name = ""; - prim_native_float = false}, - Pccall{prim_name = "caml_string_compare"; prim_arity = 2; - prim_alloc = false; prim_native_name = ""; - prim_native_float = false}, - Pccall{prim_name = "caml_nativeint_compare"; prim_arity = 2; - prim_alloc = false; prim_native_name = ""; - prim_native_float = false}, - Pccall{prim_name = "caml_int32_compare"; prim_arity = 2; - prim_alloc = false; prim_native_name = ""; - prim_native_float = false}, - Pccall{prim_name = "caml_int64_compare"; prim_arity = 2; - prim_alloc = false; prim_native_name = ""; - prim_native_float = false}, + let unboxed_compare name native_repr = + Pccall( Primitive.make ~name ~alloc:false + ~native_name:(name^"_unboxed") + ~native_repr_args:[native_repr;native_repr] + ~native_repr_res:Untagged_int + ) in + (Pccall(Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true), + (* Not unboxed since the comparison is done directly on tagged int *) + Pccall(Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false), + unboxed_compare "caml_float_compare" Unboxed_float, + Pccall(Primitive.simple ~name:"caml_string_compare" ~arity:2 + ~alloc:false), + Pccall(Primitive.simple ~name:"caml_bytes_compare" ~arity:2 + ~alloc:false), + unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint), + unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32), + unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64), false) ] let primitives_table = create_hashtable 57 [ "%identity", Pidentity; + "%bytes_to_string", Pbytes_to_string; + "%bytes_of_string", Pbytes_of_string; "%ignore", Pignore; + "%revapply", Prevapply; + "%apply", Pdirapply; + "%loc_LOC", Ploc Loc_LOC; + "%loc_FILE", Ploc Loc_FILE; + "%loc_LINE", Ploc Loc_LINE; + "%loc_POS", Ploc Loc_POS; + "%loc_MODULE", Ploc Loc_MODULE; "%field0", Pfield 0; "%field1", Pfield 1; - "%setfield0", Psetfield(0, true); - "%makeblock", Pmakeblock(0, Immutable); - "%makemutable", Pmakeblock(0, Mutable); - "%raise", Praise; + "%setfield0", Psetfield(0, Pointer, Assignment); + "%makeblock", Pmakeblock(0, Immutable, None); + "%makemutable", Pmakeblock(0, Mutable, None); + "%raise", Praise Raise_regular; + "%reraise", Praise Raise_reraise; + "%raise_notrace", Praise Raise_notrace; "%sequand", Psequand; "%sequor", Psequor; "%boolnot", Pnot; "%big_endian", Pctconst Big_endian; + "%backend_type", Pctconst Backend_type; "%word_size", Pctconst Word_size; + "%int_size", Pctconst Int_size; + "%max_wosize", Pctconst Max_wosize; "%ostype_unix", Pctconst Ostype_unix; "%ostype_win32", Pctconst Ostype_win32; "%ostype_cygwin", Pctconst Ostype_cygwin; @@ -161,8 +199,8 @@ "%addint", Paddint; "%subint", Psubint; "%mulint", Pmulint; - "%divint", Pdivint; - "%modint", Pmodint; + "%divint", Pdivint Safe; + "%modint", Pmodint Safe; "%andint", Pandint; "%orint", Porint; "%xorint", Pxorint; @@ -193,9 +231,14 @@ "%gefloat", Pfloatcomp Cge; "%string_length", Pstringlength; "%string_safe_get", Pstringrefs; - "%string_safe_set", Pstringsets; + "%string_safe_set", Pbytessets; "%string_unsafe_get", Pstringrefu; - "%string_unsafe_set", Pstringsetu; + "%string_unsafe_set", Pbytessetu; + "%bytes_length", Pbyteslength; + "%bytes_safe_get", Pbytesrefs; + "%bytes_safe_set", Pbytessets; + "%bytes_unsafe_get", Pbytesrefu; + "%bytes_unsafe_set", Pbytessetu; "%array_length", Parraylength Pgenarray; "%array_safe_get", Parrayrefs Pgenarray; "%array_safe_set", Parraysets Pgenarray; @@ -212,8 +255,8 @@ "%nativeint_add", Paddbint Pnativeint; "%nativeint_sub", Psubbint Pnativeint; "%nativeint_mul", Pmulbint Pnativeint; - "%nativeint_div", Pdivbint Pnativeint; - "%nativeint_mod", Pmodbint Pnativeint; + "%nativeint_div", Pdivbint { size = Pnativeint; is_safe = Safe }; + "%nativeint_mod", Pmodbint { size = Pnativeint; is_safe = Safe }; "%nativeint_and", Pandbint Pnativeint; "%nativeint_or", Porbint Pnativeint; "%nativeint_xor", Pxorbint Pnativeint; @@ -226,8 +269,8 @@ "%int32_add", Paddbint Pint32; "%int32_sub", Psubbint Pint32; "%int32_mul", Pmulbint Pint32; - "%int32_div", Pdivbint Pint32; - "%int32_mod", Pmodbint Pint32; + "%int32_div", Pdivbint { size = Pint32; is_safe = Safe }; + "%int32_mod", Pmodbint { size = Pint32; is_safe = Safe }; "%int32_and", Pandbint Pint32; "%int32_or", Porbint Pint32; "%int32_xor", Pxorbint Pint32; @@ -240,8 +283,8 @@ "%int64_add", Paddbint Pint64; "%int64_sub", Psubbint Pint64; "%int64_mul", Pmulbint Pint64; - "%int64_div", Pdivbint Pint64; - "%int64_mod", Pmodbint Pint64; + "%int64_div", Pdivbint { size = Pint64; is_safe = Safe }; + "%int64_mod", Pmodbint { size = Pint64; is_safe = Safe }; "%int64_and", Pandbint Pint64; "%int64_or", Porbint Pint64; "%int64_xor", Pxorbint Pint64; @@ -309,142 +352,176 @@ "%bswap_int32", Pbbswap(Pint32); "%bswap_int64", Pbbswap(Pint64); "%bswap_native", Pbbswap(Pnativeint); + "%int_as_pointer", Pint_as_pointer; + "%opaque", Popaque; ] -let prim_makearray = - { prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true; - prim_native_name = ""; prim_native_float = false } - -let prim_obj_dup = - { prim_name = "caml_obj_dup"; prim_arity = 1; prim_alloc = true; - prim_native_name = ""; prim_native_float = false } - -let find_primitive loc prim_name = - match prim_name with - "%revapply" -> Prevapply loc - | "%apply" -> Pdirapply loc - | name -> Hashtbl.find primitives_table name +let find_primitive prim_name = + Hashtbl.find primitives_table prim_name -let transl_prim loc prim args = - let prim_name = prim.prim_name in +let prim_restore_raw_backtrace = + Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false + +let specialize_comparison table env ty = + let (gencomp, intcomp, floatcomp, stringcomp, bytescomp, + nativeintcomp, int32comp, int64comp, _) = table in + match () with + | () when is_base_type env ty Predef.path_int + || is_base_type env ty Predef.path_char + || (maybe_pointer_type env ty = Immediate) -> intcomp + | () when is_base_type env ty Predef.path_float -> floatcomp + | () when is_base_type env ty Predef.path_string -> stringcomp + | () when is_base_type env ty Predef.path_bytes -> bytescomp + | () when is_base_type env ty Predef.path_nativeint -> nativeintcomp + | () when is_base_type env ty Predef.path_int32 -> int32comp + | () when is_base_type env ty Predef.path_int64 -> int64comp + | () -> gencomp + +(* Specialize a primitive from available type information, + raise Not_found if primitive is unknown *) + +let specialize_primitive p env ty ~has_constant_constructor = try - let (gencomp, intcomp, floatcomp, stringcomp, - nativeintcomp, int32comp, int64comp, - simplify_constant_constructor) = - Hashtbl.find comparisons_table prim_name in - begin match args with - [arg1; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _, _)}] - when simplify_constant_constructor -> - intcomp - | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _, _)}; arg2] - when simplify_constant_constructor -> - intcomp - | [arg1; {exp_desc = Texp_variant(_, None)}] - when simplify_constant_constructor -> - intcomp - | [{exp_desc = Texp_variant(_, None)}; exp2] - when simplify_constant_constructor -> - intcomp - | [arg1; arg2] when has_base_type arg1 Predef.path_int - || has_base_type arg1 Predef.path_char -> - intcomp - | [arg1; arg2] when has_base_type arg1 Predef.path_float -> - floatcomp - | [arg1; arg2] when has_base_type arg1 Predef.path_string -> - stringcomp - | [arg1; arg2] when has_base_type arg1 Predef.path_nativeint -> - nativeintcomp - | [arg1; arg2] when has_base_type arg1 Predef.path_int32 -> - int32comp - | [arg1; arg2] when has_base_type arg1 Predef.path_int64 -> - int64comp - | _ -> - gencomp - end + let table = Hashtbl.find comparisons_table p.prim_name in + let (gencomp, intcomp, _, _, _, _, _, _, simplify_constant_constructor) = + table in + if has_constant_constructor && simplify_constant_constructor then + intcomp + else + match is_function_type env ty with + | Some (lhs,_rhs) -> specialize_comparison table env lhs + | None -> gencomp with Not_found -> - try - let p = find_primitive loc prim_name in + let p = find_primitive p.prim_name in (* Try strength reduction based on the type of the argument *) - begin match (p, args) with - (Psetfield(n, _), [arg1; arg2]) -> Psetfield(n, maybe_pointer arg2) - | (Parraylength Pgenarray, [arg]) -> Parraylength(array_kind arg) - | (Parrayrefu Pgenarray, arg1 :: _) -> Parrayrefu(array_kind arg1) - | (Parraysetu Pgenarray, arg1 :: _) -> Parraysetu(array_kind arg1) - | (Parrayrefs Pgenarray, arg1 :: _) -> Parrayrefs(array_kind arg1) - | (Parraysets Pgenarray, arg1 :: _) -> Parraysets(array_kind arg1) - | (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), - arg1 :: _) -> - let (k, l) = bigarray_kind_and_layout arg1 in - Pbigarrayref(unsafe, n, k, l) - | (Pbigarrayset(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), - arg1 :: _) -> - let (k, l) = bigarray_kind_and_layout arg1 in - Pbigarrayset(unsafe, n, k, l) - | _ -> p - end - with Not_found -> - if String.length prim_name > 0 && prim_name.[0] = '%' then - raise(Error(loc, Unknown_builtin_primitive prim_name)); - Pccall prim - + let params = match is_function_type env ty with + | None -> [] + | Some (p1, rhs) -> match is_function_type env rhs with + | None -> [p1] + | Some (p2, _) -> [p1;p2] + in + match (p, params) with + (Psetfield(n, _, init), [_p1; p2]) -> + Psetfield(n, maybe_pointer_type env p2, init) + | (Parraylength Pgenarray, [p]) -> Parraylength(array_type_kind env p) + | (Parrayrefu Pgenarray, p1 :: _) -> Parrayrefu(array_type_kind env p1) + | (Parraysetu Pgenarray, p1 :: _) -> Parraysetu(array_type_kind env p1) + | (Parrayrefs Pgenarray, p1 :: _) -> Parrayrefs(array_type_kind env p1) + | (Parraysets Pgenarray, p1 :: _) -> Parraysets(array_type_kind env p1) + | (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), + p1 :: _) -> + let (k, l) = bigarray_type_kind_and_layout env p1 in + Pbigarrayref(unsafe, n, k, l) + | (Pbigarrayset(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), + p1 :: _) -> + let (k, l) = bigarray_type_kind_and_layout env p1 in + Pbigarrayset(unsafe, n, k, l) + | (Pmakeblock(tag, mut, None), fields) -> + let shape = List.map (Typeopt.value_kind env) fields in + Pmakeblock(tag, mut, Some shape) + | _ -> p + +(* Eta-expand a primitive *) + +let used_primitives = Hashtbl.create 7 +let add_used_primitive loc env path = + match path with + Some (Path.Pdot _ as path) -> + let path = Env.normalize_path (Some loc) env path in + let unit = Path.head path in + if Ident.global unit && not (Hashtbl.mem used_primitives path) + then Hashtbl.add used_primitives path loc + | _ -> () -(* Eta-expand a primitive without knowing the types of its arguments *) - -let transl_primitive loc p = +let transl_primitive loc p env ty path = let prim = - try - let (gencomp, _, _, _, _, _, _, _) = - Hashtbl.find comparisons_table p.prim_name in - gencomp - with Not_found -> - try - find_primitive loc p.prim_name + try specialize_primitive p env ty ~has_constant_constructor:false with Not_found -> - Pccall p in + add_used_primitive loc env path; + Pccall p + in match prim with - Plazyforce -> + | Plazyforce -> let parm = Ident.create "prim" in - Lfunction(Curried, [parm], - Matching.inline_lazy_force (Lvar parm) Location.none) + Lfunction{kind = Curried; params = [parm]; + body = Matching.inline_lazy_force (Lvar parm) Location.none; + loc = loc; + attr = default_stub_attribute } + | Ploc kind -> + let lam = lam_of_loc kind loc in + begin match p.prim_arity with + | 0 -> lam + | 1 -> (* TODO: we should issue a warning ? *) + let param = Ident.create "prim" in + Lfunction{kind = Curried; params = [param]; + attr = default_stub_attribute; + loc = loc; + body = Lprim(Pmakeblock(0, Immutable, None), + [lam; Lvar param], loc)} + | _ -> assert false + end | _ -> let rec make_params n = if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in let params = make_params p.prim_arity in - Lfunction(Curried, params, - Lprim(prim, List.map (fun id -> Lvar id) params)) + Lfunction{ kind = Curried; params; + attr = default_stub_attribute; + loc = loc; + body = Lprim(prim, List.map (fun id -> Lvar id) params, loc) } + +let transl_primitive_application loc prim env ty path args = + let prim_name = prim.prim_name in + try + let has_constant_constructor = match args with + [_; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}] + | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; _] + | [_; {exp_desc = Texp_variant(_, None)}] + | [{exp_desc = Texp_variant(_, None)}; _] -> true + | _ -> false + in + specialize_primitive prim env ty ~has_constant_constructor + with Not_found -> + if String.length prim_name > 0 && prim_name.[0] = '%' then + raise(Error(loc, Unknown_builtin_primitive prim_name)); + add_used_primitive loc env path; + Pccall prim + (* To check the well-formedness of r.h.s. of "let rec" definitions *) let check_recursive_lambda idlist lam = let rec check_top idlist = function | Lvar v -> not (List.mem v idlist) - | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> + | Llet _ as lam when check_recursive_recordwith idlist lam -> true - | Llet(str, id, arg, body) -> + | Llet(_str, _k, id, arg, body) -> check idlist arg && check_top (add_let id arg idlist) body | Lletrec(bindings, body) -> let idlist' = add_letrec bindings idlist in - List.for_all (fun (id, arg) -> check idlist' arg) bindings && + List.for_all (fun (_id, arg) -> check idlist' arg) bindings && check_top idlist' body - | Lprim (Pmakearray (Pgenarray), args) -> false + | Lprim (Pmakearray (Pgenarray, _), _, _) -> false + | Lprim (Pmakearray (Pfloatarray, _), args, _) -> + List.for_all (check idlist) args | Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2 | Levent (lam, _) -> check_top idlist lam | lam -> check idlist lam and check idlist = function | Lvar _ -> true - | Lfunction(kind, params, body) -> true - | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> + | Lfunction _ -> true + | Llet _ as lam when check_recursive_recordwith idlist lam -> true - | Llet(str, id, arg, body) -> + | Llet(_str, _k, id, arg, body) -> check idlist arg && check (add_let id arg idlist) body | Lletrec(bindings, body) -> let idlist' = add_letrec bindings idlist in - List.for_all (fun (id, arg) -> check idlist' arg) bindings && + List.for_all (fun (_id, arg) -> check idlist' arg) bindings && check idlist' body - | Lprim(Pmakeblock(tag, mut), args) -> + | Lprim(Pmakeblock _, args, _) -> List.for_all (check idlist) args - | Lprim(Pmakearray(_), args) -> + | Lprim (Pmakearray (Pfloatarray, _), _, _) -> false + | Lprim (Pmakearray _, args, _) -> List.for_all (check idlist) args | Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2 | Levent (lam, _) -> check idlist lam @@ -465,13 +542,14 @@ (* reverse-engineering the code generated by transl_record case 2 *) (* If you change this, you probably need to change Bytegen.size_of_lambda. *) and check_recursive_recordwith idlist = function - | Llet (Strict, id1, Lprim (Pduprecord _, [e1]), body) -> + | Llet (Strict, _k, id1, Lprim (Pduprecord _, [e1], _), body) -> check_top idlist e1 && check_recordwith_updates idlist id1 body | _ -> false and check_recordwith_updates idlist id1 = function - | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1]), cont) + | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1], _), + cont) -> id2 = id1 && check idlist e1 && check_recordwith_updates idlist id1 cont | Lvar id2 -> id2 = id1 @@ -491,36 +569,50 @@ Const_base(Const_float f) -> f | _ -> fatal_error "Translcore.extract_float" -(* To find reasonable names for let-bound and lambda-bound idents *) - -let rec name_pattern default = function - [] -> Ident.create default - | (p, e) :: rem -> - match p.pat_desc with - Tpat_var (id, _) -> id - | Tpat_alias(p, id, _) -> id - | _ -> name_pattern default rem - (* Push the default values under the functional abstractions *) +(* Also push bindings of module patterns, since this sound *) -let rec push_defaults loc bindings pat_expr_list partial = - match pat_expr_list with - [pat, ({exp_desc = Texp_function(l, pl,partial)} as exp)] -> - let pl = push_defaults exp.exp_loc bindings pl partial in - [pat, {exp with exp_desc = Texp_function(l, pl, partial)}] - | [pat, {exp_desc = Texp_let - (Default, cases, ({exp_desc = Texp_function _} as e2))}] -> - push_defaults loc (cases :: bindings) [pat, e2] partial - | [pat, exp] -> +type binding = + | Bind_value of value_binding list + | Bind_module of Ident.t * string loc * module_expr + +let rec push_defaults loc bindings cases partial = + match cases with + [{c_lhs=pat; c_guard=None; + c_rhs={exp_desc = Texp_function { arg_label; param; cases; partial; } } + as exp}] -> + let cases = push_defaults exp.exp_loc bindings cases partial in + [{c_lhs=pat; c_guard=None; + c_rhs={exp with exp_desc = Texp_function { arg_label; param; cases; + partial; }}}] + | [{c_lhs=pat; c_guard=None; + c_rhs={exp_attributes=[{txt="#default"},_]; + exp_desc = Texp_let + (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] -> + push_defaults loc (Bind_value binds :: bindings) + [{c_lhs=pat;c_guard=None;c_rhs=e2}] + partial + | [{c_lhs=pat; c_guard=None; + c_rhs={exp_attributes=[{txt="#modulepat"},_]; + exp_desc = Texp_letmodule + (id, name, mexpr, ({exp_desc = Texp_function _} as e2))}}] -> + push_defaults loc (Bind_module (id, name, mexpr) :: bindings) + [{c_lhs=pat;c_guard=None;c_rhs=e2}] + partial + | [case] -> let exp = List.fold_left - (fun exp cases -> - {exp with exp_desc = Texp_let(Nonrecursive, cases, exp)}) - exp bindings + (fun exp binds -> + {exp with exp_desc = + match binds with + | Bind_value binds -> Texp_let(Nonrecursive, binds, exp) + | Bind_module (id, name, mexpr) -> + Texp_letmodule (id, name, mexpr, exp)}) + case.c_rhs bindings in - [pat, exp] - | (pat, exp) :: _ when bindings <> [] -> - let param = name_pattern "param" pat_expr_list in + [{case with c_rhs=exp}] + | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] -> + let param = Typecore.name_pattern "param" cases in let name = Ident.name param in let exp = { exp with exp_loc = loc; exp_desc = @@ -528,21 +620,24 @@ ({exp with exp_type = pat.pat_type; exp_desc = Texp_ident (Path.Pident param, mknoloc (Longident.Lident name), {val_type = pat.pat_type; val_kind = Val_reg; + val_attributes = []; Types.val_loc = Location.none; })}, - pat_expr_list, partial) } + cases, [], partial) } in push_defaults loc bindings - [{pat with pat_desc = Tpat_var (param, mknoloc name)}, exp] Total + [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; + c_guard=None; c_rhs=exp}] + Total | _ -> - pat_expr_list + cases (* Insertion of debugging events *) let event_before exp lam = match lam with | Lstaticraise (_,_) -> lam | _ -> - if !Clflags.debug + if !Clflags.debug && not !Clflags.native_code then Levent(lam, {lev_loc = exp.exp_loc; lev_kind = Lev_before; lev_repr = None; @@ -550,7 +645,7 @@ else lam let event_after exp lam = - if !Clflags.debug + if !Clflags.debug && not !Clflags.native_code then Levent(lam, {lev_loc = exp.exp_loc; lev_kind = Lev_after exp.exp_type; lev_repr = None; @@ -558,7 +653,7 @@ else lam let event_function exp lam = - if !Clflags.debug then + if !Clflags.debug && not !Clflags.native_code then let repr = Some (ref 0) in let (info, body) = lam repr in (info, @@ -572,8 +667,9 @@ let primitive_is_ccall = function (* Determine if a primitive is a Pccall or will be turned later into a C function call that may raise an exception *) - | Pccall _ | Pstringrefs | Pstringsets | Parrayrefs _ | Parraysets _ | - Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ -> true + | Pccall _ | Pstringrefs | Pbytesrefs | Pbytessets | Parrayrefs _ | + Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply | + Prevapply -> true | _ -> false (* Assertions *) @@ -581,13 +677,13 @@ let assert_failed exp = let (fname, line, char) = Location.get_pos_info exp.exp_loc.Location.loc_start in - Lprim(Praise, [event_after exp - (Lprim(Pmakeblock(0, Immutable), - [transl_path Predef.path_assert_failure; + Lprim(Praise Raise_regular, [event_after exp + (Lprim(Pmakeblock(0, Immutable, None), + [transl_normal_path Predef.path_assert_failure; Lconst(Const_block(0, - [Const_base(Const_string fname); + [Const_base(Const_string (fname, None)); Const_base(Const_int line); - Const_base(Const_int char)]))]))]) + Const_base(Const_int char)]))], exp.exp_loc))], exp.exp_loc) ;; let rec cut n l = @@ -597,7 +693,10 @@ (* Translation of expressions *) +let try_ids = Hashtbl.create 8 + let rec transl_exp e = + List.iter (Translattribute.check_attribute e) e.exp_attributes; let eval_once = (* Whether classes for immediate objects must be cached *) match e.exp_desc with @@ -614,47 +713,72 @@ if public_send || p.prim_name = "%sendself" then let kind = if public_send then Public else Self in let obj = Ident.create "obj" and meth = Ident.create "meth" in - Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], - e.exp_loc)) + Lfunction{kind = Curried; params = [obj; meth]; + attr = default_stub_attribute; + loc = e.exp_loc; + body = Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc)} else if p.prim_name = "%sendcache" then let obj = Ident.create "obj" and meth = Ident.create "meth" in let cache = Ident.create "cache" and pos = Ident.create "pos" in - Lfunction(Curried, [obj; meth; cache; pos], - Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], - e.exp_loc)) + Lfunction{kind = Curried; params = [obj; meth; cache; pos]; + attr = default_stub_attribute; + loc = e.exp_loc; + body = Lsend(Cached, Lvar meth, Lvar obj, + [Lvar cache; Lvar pos], e.exp_loc)} else - transl_primitive e.exp_loc p - | Texp_ident(path, _, {val_kind = Val_anc _}) -> + transl_primitive e.exp_loc p e.exp_env e.exp_type (Some path) + | Texp_ident(_, _, {val_kind = Val_anc _}) -> raise(Error(e.exp_loc, Free_super_var)) | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) -> - transl_path path + transl_path ~loc:e.exp_loc e.exp_env path | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident" | Texp_constant cst -> Lconst(Const_base cst) | Texp_let(rec_flag, pat_expr_list, body) -> transl_let rec_flag pat_expr_list (event_before body (transl_exp body)) - | Texp_function (_, pat_expr_list, partial) -> + | Texp_function { arg_label = _; param; cases; partial; } -> let ((kind, params), body) = event_function e (function repr -> - let pl = push_defaults e.exp_loc [] pat_expr_list partial in - transl_function e.exp_loc !Clflags.native_code repr partial pl) + let pl = push_defaults e.exp_loc [] cases partial in + transl_function e.exp_loc !Clflags.native_code repr partial + param pl) in - Lfunction(kind, params, body) - | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})} as fn, - oargs) + let attr = { + default_function_attribute with + inline = Translattribute.get_inline_attribute e.exp_attributes; + specialise = Translattribute.get_specialise_attribute e.exp_attributes; + } + in + let loc = e.exp_loc in + Lfunction{kind; params; body; attr; loc} + | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p}); + exp_type = prim_type } as funct, oargs) when List.length oargs >= p.prim_arity - && List.for_all (fun (_, arg,_) -> arg <> None) oargs -> + && List.for_all (fun (_, arg) -> arg <> None) oargs -> let args, args' = cut p.prim_arity oargs in let wrap f = if args' = [] then event_after e f - else event_after e (transl_apply f args' e.exp_loc) + else + let should_be_tailcall, funct = + Translattribute.get_tailcall_attribute funct + in + let inlined, funct = + Translattribute.get_and_remove_inlined_attribute funct + in + let specialised, funct = + Translattribute.get_and_remove_specialised_attribute funct + in + let e = { e with exp_desc = Texp_apply(funct, oargs) } in + event_after e + (transl_apply ~should_be_tailcall ~inlined ~specialised + f args' e.exp_loc) in let wrap0 f = if args' = [] then f else wrap f in let args = - List.map (function _, Some x, _ -> x | _ -> assert false) args in + List.map (function _, Some x -> x | _ -> assert false) args in let argl = transl_list args in let public_send = p.prim_name = "%send" || not !Clflags.native_code && p.prim_name = "%sendcache"in @@ -666,59 +790,108 @@ match argl with [obj; meth; cache; pos] -> wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc)) | _ -> assert false + else if p.prim_name = "%raise_with_backtrace" then begin + let texn1 = List.hd args (* Should not fail by typing *) in + let texn2,bt = match argl with + | [a;b] -> a,b + | _ -> assert false (* idem *) + in + let vexn = Ident.create "exn" in + Llet(Strict, Pgenval, vexn, texn2, + event_before e begin + Lsequence( + wrap (Lprim (Pccall prim_restore_raw_backtrace, + [Lvar vexn;bt], + e.exp_loc)), + wrap0 (Lprim(Praise Raise_reraise, + [event_after texn1 (Lvar vexn)], + e.exp_loc)) + ) + end + ) + end else begin - if p.prim_name = "%sequand" && Path.last path = "&" then - Location.prerr_warning fn.exp_loc - (Warnings.Deprecated "operator (&); you should use (&&) instead"); - if p.prim_name = "%sequor" && Path.last path = "or" then - Location.prerr_warning fn.exp_loc - (Warnings.Deprecated "operator (or); you should use (||) instead"); - let prim = transl_prim e.exp_loc p args in + let prim = transl_primitive_application + e.exp_loc p e.exp_env prim_type (Some path) args in match (prim, args) with - (Praise, [arg1]) -> - wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)])) + (Praise k, [arg1]) -> + let targ = List.hd argl in + let k = + match k, targ with + | Raise_regular, Lvar id + when Hashtbl.mem try_ids id -> + Raise_reraise + | _ -> + k + in + wrap0 (Lprim(Praise k, [event_after arg1 targ], e.exp_loc)) + | (Ploc kind, []) -> + lam_of_loc kind e.exp_loc + | (Ploc kind, [arg1]) -> + let lam = lam_of_loc kind arg1.exp_loc in + Lprim(Pmakeblock(0, Immutable, None), lam :: argl, e.exp_loc) + | (Ploc _, _) -> assert false | (_, _) -> begin match (prim, argl) with | (Plazyforce, [a]) -> wrap (Matching.inline_lazy_force a e.exp_loc) | (Plazyforce, _) -> assert false - |_ -> let p = Lprim(prim, argl) in + |_ -> let p = Lprim(prim, argl, e.exp_loc) in if primitive_is_ccall prim then wrap p else wrap0 p end end | Texp_apply(funct, oargs) -> - event_after e (transl_apply (transl_exp funct) oargs e.exp_loc) - | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) -> - Matching.for_multiple_match e.exp_loc - (transl_list argl) (transl_cases pat_expr_list) partial - | Texp_match(arg, pat_expr_list, partial) -> - Matching.for_function e.exp_loc None - (transl_exp arg) (transl_cases pat_expr_list) partial + let should_be_tailcall, funct = + Translattribute.get_tailcall_attribute funct + in + let inlined, funct = + Translattribute.get_and_remove_inlined_attribute funct + in + let specialised, funct = + Translattribute.get_and_remove_specialised_attribute funct + in + let e = { e with exp_desc = Texp_apply(funct, oargs) } in + event_after e + (transl_apply ~should_be_tailcall ~inlined ~specialised + (transl_exp funct) oargs e.exp_loc) + | Texp_match(arg, pat_expr_list, exn_pat_expr_list, partial) -> + transl_match e arg pat_expr_list exn_pat_expr_list partial | Texp_try(body, pat_expr_list) -> - let id = name_pattern "exn" pat_expr_list in + let id = Typecore.name_pattern "exn" pat_expr_list in Ltrywith(transl_exp body, id, - Matching.for_trywith (Lvar id) (transl_cases pat_expr_list)) + Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list)) | Texp_tuple el -> - let ll = transl_list el in + let ll, shape = transl_list_with_shape el in begin try Lconst(Const_block(0, List.map extract_constant ll)) with Not_constant -> - Lprim(Pmakeblock(0, Immutable), ll) + Lprim(Pmakeblock(0, Immutable, Some shape), ll, e.exp_loc) end - | Texp_construct(_, cstr, args, _) -> - let ll = transl_list args in - begin match cstr.cstr_tag with + | Texp_construct(_, cstr, args) -> + let ll, shape = transl_list_with_shape args in + if cstr.cstr_inlined <> None then begin match ll with + | [x] -> x + | _ -> assert false + end else begin match cstr.cstr_tag with Cstr_constant n -> Lconst(Const_pointer n) + | Cstr_unboxed -> + (match ll with [v] -> v | _ -> assert false) | Cstr_block n -> begin try Lconst(Const_block(n, List.map extract_constant ll)) with Not_constant -> - Lprim(Pmakeblock(n, Immutable), ll) + Lprim(Pmakeblock(n, Immutable, Some shape), ll, e.exp_loc) end - | Cstr_exception (path, _) -> - Lprim(Pmakeblock(0, Immutable), transl_path path :: ll) + | Cstr_extension(path, is_const) -> + if is_const then + transl_path e.exp_env path + else + Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)), + transl_path e.exp_env path :: ll, e.exp_loc) end + | Texp_extension_constructor (_, path) -> + transl_path e.exp_env path | Texp_variant(l, arg) -> let tag = Btype.hash_variant l in begin match arg with @@ -729,43 +902,78 @@ Lconst(Const_block(0, [Const_base(Const_int tag); extract_constant lam])) with Not_constant -> - Lprim(Pmakeblock(0, Immutable), - [Lconst(Const_base(Const_int tag)); lam]) + Lprim(Pmakeblock(0, Immutable, None), + [Lconst(Const_base(Const_int tag)); lam], e.exp_loc) end - | Texp_record ((_, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) -> - transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr - | Texp_record ([], _) -> - fatal_error "Translcore.transl_exp: bad Texp_record" + | Texp_record {fields; representation; extended_expression} -> + transl_record e.exp_loc e.exp_env fields representation + extended_expression | Texp_field(arg, _, lbl) -> - let access = - match lbl.lbl_repres with - Record_regular -> Pfield lbl.lbl_pos - | Record_float -> Pfloatfield lbl.lbl_pos in - Lprim(access, [transl_exp arg]) + let targ = transl_exp arg in + begin match lbl.lbl_repres with + Record_regular | Record_inlined _ -> + Lprim (Pfield lbl.lbl_pos, [targ], e.exp_loc) + | Record_unboxed _ -> targ + | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [targ], e.exp_loc) + | Record_extension -> + Lprim (Pfield (lbl.lbl_pos + 1), [targ], e.exp_loc) + end | Texp_setfield(arg, _, lbl, newval) -> let access = match lbl.lbl_repres with - Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval) - | Record_float -> Psetfloatfield lbl.lbl_pos in - Lprim(access, [transl_exp arg; transl_exp newval]) + Record_regular + | Record_inlined _ -> + Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment) + | Record_unboxed _ -> assert false + | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) + | Record_extension -> + Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment) + in + Lprim(access, [transl_exp arg; transl_exp newval], e.exp_loc) | Texp_array expr_list -> let kind = array_kind e in let ll = transl_list expr_list in begin try + (* For native code the decision as to which compilation strategy to + use is made later. This enables the Flambda passes to lift certain + kinds of array definitions to symbols. *) (* Deactivate constant optimization if array is small enough *) - if List.length ll <= 4 then raise Not_constant; - let cl = List.map extract_constant ll in - let master = - match kind with - | Paddrarray | Pintarray -> - Lconst(Const_block(0, cl)) - | Pfloatarray -> - Lconst(Const_float_array(List.map extract_float cl)) - | Pgenarray -> - raise Not_constant in (* can this really happen? *) - Lprim(Pccall prim_obj_dup, [master]) + if List.length ll <= use_dup_for_constant_arrays_bigger_than + then begin + raise Not_constant + end; + begin match List.map extract_constant ll with + | exception Not_constant when kind = Pfloatarray -> + (* We cannot currently lift [Pintarray] arrays safely in Flambda + because [caml_modify] might be called upon them (e.g. from + code operating on polymorphic arrays, or functions such as + [caml_array_blit]. + To avoid having different Lambda code for + bytecode/Closure vs. Flambda, we always generate + [Pduparray] here, and deal with it in [Bytegen] (or in + the case of Closure, in [Cmmgen], which already has to + handle [Pduparray Pmakearray Pfloatarray] in the case + where the array turned out to be inconstant). + When not [Pfloatarray], the exception propagates to the handler + below. *) + let imm_array = + Lprim (Pmakearray (kind, Immutable), ll, e.exp_loc) + in + Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) + | cl -> + let imm_array = + match kind with + | Paddrarray | Pintarray -> + Lconst(Const_block(0, cl)) + | Pfloatarray -> + Lconst(Const_float_array(List.map extract_float cl)) + | Pgenarray -> + raise Not_constant (* can this really happen? *) + in + Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) + end with Not_constant -> - Lprim(Pmakearray kind, ll) + Lprim(Pmakearray (kind, Mutable), ll, e.exp_loc) end | Texp_ifthenelse(cond, ifso, Some ifnot) -> Lifthenelse(transl_exp cond, @@ -782,10 +990,6 @@ | Texp_for(param, _, low, high, dir, body) -> Lfor(param, transl_exp low, transl_exp high, dir, event_before body (transl_exp body)) - | Texp_when(cond, body) -> - event_before cond - (Lifthenelse(transl_exp cond, event_before body (transl_exp body), - staticfail)) | Texp_send(_, _, Some exp) -> transl_exp exp | Texp_send(expr, met, None) -> let obj = transl_exp expr in @@ -798,31 +1002,49 @@ Lsend (kind, tag, obj, cache, e.exp_loc) in event_after e lam - | Texp_new (cl, _, _) -> - Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none) + | Texp_new (cl, {Location.loc=loc}, _) -> + Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=Lprim(Pfield 0, [transl_path ~loc e.exp_env cl], loc); + ap_args=[lambda_unit]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} | Texp_instvar(path_self, path, _) -> - Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path]) + Lprim(Pfield_computed, + [transl_normal_path path_self; transl_normal_path path], e.exp_loc) | Texp_setinstvar(path_self, path, _, expr) -> - transl_setinstvar (transl_path path_self) path expr + transl_setinstvar e.exp_loc (transl_normal_path path_self) path expr | Texp_override(path_self, modifs) -> let cpy = Ident.create "copy" in - Llet(Strict, cpy, - Lapply(Translobj.oo_prim "copy", [transl_path path_self], - Location.none), + Llet(Strict, Pgenval, cpy, + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Translobj.oo_prim "copy"; + ap_args=[transl_normal_path path_self]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}, List.fold_right (fun (path, _, expr) rem -> - Lsequence(transl_setinstvar (Lvar cpy) path expr, rem)) + Lsequence(transl_setinstvar Location.none + (Lvar cpy) path expr, rem)) modifs (Lvar cpy)) | Texp_letmodule(id, _, modl, body) -> - Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body) + Llet(Strict, Pgenval, id, + !transl_module Tcoerce_none None modl, + transl_exp body) + | Texp_letexception(cd, body) -> + Llet(Strict, Pgenval, + cd.ext_id, transl_extension_constructor e.exp_env None cd, + transl_exp body) | Texp_pack modl -> !transl_module Tcoerce_none None modl + | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} -> + assert_failed e | Texp_assert (cond) -> if !Clflags.noassert then lambda_unit else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) - | Texp_assertfalse -> assert_failed e | Texp_lazy e -> (* when e needs no computation (constants, identifiers, ...), we optimize the translation just as Lazy.lazy_from_val would @@ -832,46 +1054,35 @@ | Texp_constant ( Const_int _ | Const_char _ | Const_string _ | Const_int32 _ | Const_int64 _ | Const_nativeint _ ) - | Texp_function(_, _, _) - | Texp_construct (_, {cstr_arity = 0}, _, _) + | Texp_function _ + | Texp_construct (_, {cstr_arity = 0}, _) -> transl_exp e | Texp_constant(Const_float _) -> - Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) - | Texp_ident(_, _, _) -> (* according to the type *) - begin match e.exp_type.desc with - (* the following may represent a float/forward/lazy: need a - forward_tag *) - | Tvar _ | Tlink _ | Tsubst _ | Tunivar _ - | Tpoly(_,_) | Tfield(_,_,_,_) -> - Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) - (* the following cannot be represented as float/forward/lazy: - optimize *) - | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil - | Tvariant _ - -> transl_exp e - (* optimize predefined types (excepted float) *) - | Tconstr(_,_,_) -> - if has_base_type e Predef.path_int - || has_base_type e Predef.path_char - || has_base_type e Predef.path_string - || has_base_type e Predef.path_bool - || has_base_type e Predef.path_unit - || has_base_type e Predef.path_exn - || has_base_type e Predef.path_array - || has_base_type e Predef.path_list - || has_base_type e Predef.path_format6 - || has_base_type e Predef.path_option - || has_base_type e Predef.path_nativeint - || has_base_type e Predef.path_int32 - || has_base_type e Predef.path_int64 - then transl_exp e - else - Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) - end + (* We don't need to wrap with Popaque: this forward + block will never be shortcutted since it points to a float. *) + Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), + [transl_exp e], e.exp_loc) + | Texp_ident _ -> + (* CR-someday mshinwell: Consider adding a new primitive + that expresses the construction of forward_tag blocks. + We need to use [Popaque] here to prevent unsound + optimisation in Flambda, but the concept of a mutable + block doesn't really match what is going on here. This + value may subsequently turn into an immediate... *) + if Typeopt.lazy_val_requires_forward e.exp_env e.exp_type + then + Lprim (Popaque, + [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), + [transl_exp e], e.exp_loc)], + e.exp_loc) + else transl_exp e (* other cases compile to a lazy block holding a function *) | _ -> - let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in - Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn]) + let fn = Lfunction {kind = Curried; params = [Ident.create "param"]; + attr = default_function_attribute; + loc = e.exp_loc; + body = transl_exp e} in + Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], e.exp_loc) end | Texp_object (cs, meths) -> let cty = cs.cstr_type in @@ -880,30 +1091,77 @@ { cl_desc = Tcl_structure cs; cl_loc = e.exp_loc; cl_type = Cty_signature cty; - cl_env = e.exp_env } + cl_env = e.exp_env; + cl_attributes = []; + } + | Texp_unreachable -> + raise (Error (e.exp_loc, Unreachable_reached)) and transl_list expr_list = List.map transl_exp expr_list -and transl_cases pat_expr_list = - List.map - (fun (pat, expr) -> (pat, event_before expr (transl_exp expr))) - pat_expr_list +and transl_list_with_shape expr_list = + let transl_with_shape e = + let shape = Typeopt.value_kind e.exp_env e.exp_type in + transl_exp e, shape + in + List.split (List.map transl_with_shape expr_list) + +and transl_guard guard rhs = + let expr = event_before rhs (transl_exp rhs) in + match guard with + | None -> expr + | Some cond -> + event_before cond (Lifthenelse(transl_exp cond, expr, staticfail)) + +and transl_case {c_lhs; c_guard; c_rhs} = + c_lhs, transl_guard c_guard c_rhs + +and transl_cases cases = + let cases = + List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in + List.map transl_case cases + +and transl_case_try {c_lhs; c_guard; c_rhs} = + match c_lhs.pat_desc with + | Tpat_var (id, _) + | Tpat_alias (_, id, _) -> + Hashtbl.replace try_ids id (); + Misc.try_finally + (fun () -> c_lhs, transl_guard c_guard c_rhs) + (fun () -> Hashtbl.remove try_ids id) + | _ -> + c_lhs, transl_guard c_guard c_rhs + +and transl_cases_try cases = + let cases = + List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in + List.map transl_case_try cases and transl_tupled_cases patl_expr_list = - List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list + let patl_expr_list = + List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable) + patl_expr_list in + List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr)) + patl_expr_list -and transl_apply lam sargs loc = +and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline) + ?(specialised = Default_specialise) lam sargs loc = let lapply funct args = match funct with Lsend(k, lmet, lobj, largs, loc) -> Lsend(k, lmet, lobj, largs @ args, loc) | Levent(Lsend(k, lmet, lobj, largs, loc), _) -> Lsend(k, lmet, lobj, largs @ args, loc) - | Lapply(lexp, largs, _) -> - Lapply(lexp, largs @ args, loc) + | Lapply ap -> + Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc} | lexp -> - Lapply(lexp, args, loc) + Lapply {ap_should_be_tailcall=should_be_tailcall; + ap_loc=loc; + ap_func=lexp; + ap_args=args; + ap_inlined=inlined; + ap_specialised=specialised;} in let rec build_apply lam args = function (None, optional) :: l -> @@ -917,7 +1175,7 @@ Lvar id in let args, args' = - if List.for_all (fun (_,opt) -> opt = Optional) args then [], args + if List.for_all (fun (_,opt) -> opt) args then [], args else args, [] in let lam = if args = [] then lam else lapply lam (List.rev_map fst args) in @@ -926,109 +1184,136 @@ and id_arg = Ident.create "param" in let body = match build_apply handle ((Lvar id_arg, optional)::args') l with - Lfunction(Curried, ids, lam) -> - Lfunction(Curried, id_arg::ids, lam) - | Levent(Lfunction(Curried, ids, lam), _) -> - Lfunction(Curried, id_arg::ids, lam) + Lfunction{kind = Curried; params = ids; body = lam; attr; loc} -> + Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr; + loc} + | Levent(Lfunction{kind = Curried; params = ids; + body = lam; attr; loc}, _) -> + Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr; + loc} | lam -> - Lfunction(Curried, [id_arg], lam) + Lfunction{kind = Curried; params = [id_arg]; body = lam; + attr = default_stub_attribute; loc = loc} in List.fold_left - (fun body (id, lam) -> Llet(Strict, id, lam, body)) + (fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body)) body !defs | (Some arg, optional) :: l -> build_apply lam ((arg, optional) :: args) l | [] -> lapply lam (List.rev_map fst args) in - build_apply lam [] (List.map (fun (l, x,o) -> may_map transl_exp x, o) sargs) - -and transl_function loc untuplify_fn repr partial pat_expr_list = - match pat_expr_list with - [pat, ({exp_desc = Texp_function(_, pl,partial')} as exp)] + (build_apply lam [] (List.map (fun (l, x) -> + may_map transl_exp x, Btype.is_optional l) + sargs) + : Lambda.lambda) + +and transl_function loc untuplify_fn repr partial param cases = + match cases with + [{c_lhs=pat; c_guard=None; + c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases; + partial = partial'; }} as exp}] when Parmatch.fluid pat -> - let param = name_pattern "param" pat_expr_list in let ((_, params), body) = - transl_function exp.exp_loc false repr partial' pl in + transl_function exp.exp_loc false repr partial' param' cases in ((Curried, param :: params), Matching.for_function loc None (Lvar param) [pat, body] partial) - | ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn -> + | {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn -> begin try let size = List.length pl in let pats_expr_list = List.map - (fun (pat, expr) -> (Matching.flatten_pattern size pat, expr)) - pat_expr_list in - let params = List.map (fun p -> Ident.create "param") pl in + (fun {c_lhs; c_guard; c_rhs} -> + (Matching.flatten_pattern size c_lhs, c_guard, c_rhs)) + cases in + let params = List.map (fun _ -> Ident.create "param") pl in ((Tupled, params), Matching.for_tupled_function loc params (transl_tupled_cases pats_expr_list) partial) with Matching.Cannot_flatten -> - let param = name_pattern "param" pat_expr_list in ((Curried, [param]), Matching.for_function loc repr (Lvar param) - (transl_cases pat_expr_list) partial) + (transl_cases cases) partial) end | _ -> - let param = name_pattern "param" pat_expr_list in ((Curried, [param]), Matching.for_function loc repr (Lvar param) - (transl_cases pat_expr_list) partial) + (transl_cases cases) partial) and transl_let rec_flag pat_expr_list body = match rec_flag with - Nonrecursive | Default -> + Nonrecursive -> let rec transl = function [] -> body - | (pat, expr) :: rem -> - Matching.for_let pat.pat_loc (transl_exp expr) pat (transl rem) + | {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc} :: rem -> + let lam = transl_exp expr in + let lam = + Translattribute.add_inline_attribute lam vb_loc attr + in + let lam = + Translattribute.add_specialise_attribute lam vb_loc attr + in + Matching.for_let pat.pat_loc lam pat (transl rem) in transl pat_expr_list | Recursive -> let idlist = List.map - (fun (pat, expr) -> match pat.pat_desc with + (fun {vb_pat=pat} -> match pat.pat_desc with Tpat_var (id,_) -> id | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat))) pat_expr_list in - let transl_case (pat, expr) id = + let transl_case {vb_expr=expr; vb_attributes; vb_loc} id = let lam = transl_exp expr in + let lam = + Translattribute.add_inline_attribute lam vb_loc + vb_attributes + in + let lam = + Translattribute.add_specialise_attribute lam vb_loc + vb_attributes + in if not (check_recursive_lambda idlist lam) then raise(Error(expr.exp_loc, Illegal_letrec_expr)); (id, lam) in Lletrec(List.map2 transl_case pat_expr_list idlist, body) -and transl_setinstvar self var expr = - Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray), - [self; transl_path var; transl_exp expr]) - -and transl_record all_labels repres lbl_expr_list opt_init_expr = - let size = Array.length all_labels in - (* Determine if there are "enough" new fields *) - if 3 + 2 * List.length lbl_expr_list >= size +and transl_setinstvar loc self var expr = + Lprim(Psetfield_computed (maybe_pointer expr, Assignment), + [self; transl_normal_path var; transl_exp expr], loc) + +and transl_record loc env fields repres opt_init_expr = + let size = Array.length fields in + (* Determine if there are "enough" fields (only relevant if this is a + functional-style record update *) + let no_init = match opt_init_expr with None -> true | _ -> false in + if no_init || size < Config.max_young_wosize then begin (* Allocate new record with given fields (and remaining fields taken from init_expr if any *) - let lv = Array.create (Array.length all_labels) staticfail in let init_id = Ident.create "init" in - begin match opt_init_expr with - None -> () - | Some init_expr -> - for i = 0 to Array.length all_labels - 1 do - let access = - match all_labels.(i).lbl_repres with - Record_regular -> Pfield i - | Record_float -> Pfloatfield i in - lv.(i) <- Lprim(access, [Lvar init_id]) - done - end; - List.iter - (fun (_, lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr) - lbl_expr_list; - let ll = Array.to_list lv in + let lv = + Array.mapi + (fun i (_, definition) -> + match definition with + | Kept typ -> + let field_kind = value_kind env typ in + let access = + match repres with + Record_regular | Record_inlined _ -> Pfield i + | Record_unboxed _ -> assert false + | Record_extension -> Pfield (i + 1) + | Record_float -> Pfloatfield i in + Lprim(access, [Lvar init_id], loc), field_kind + | Overridden (_lid, expr) -> + let field_kind = value_kind expr.exp_env expr.exp_type in + transl_exp expr, field_kind) + fields + in + let ll, shape = List.split (Array.to_list lv) in let mut = - if List.exists (fun (_, lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list + if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields then Mutable else Immutable in let lam = @@ -1036,16 +1321,36 @@ if mut = Mutable then raise Not_constant; let cl = List.map extract_constant ll in match repres with - Record_regular -> Lconst(Const_block(0, cl)) + | Record_regular -> Lconst(Const_block(0, cl)) + | Record_inlined tag -> Lconst(Const_block(tag, cl)) + | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false) | Record_float -> Lconst(Const_float_array(List.map extract_float cl)) + | Record_extension -> + raise Not_constant with Not_constant -> match repres with - Record_regular -> Lprim(Pmakeblock(0, mut), ll) - | Record_float -> Lprim(Pmakearray Pfloatarray, ll) in + Record_regular -> + Lprim(Pmakeblock(0, mut, Some shape), ll, loc) + | Record_inlined tag -> + Lprim(Pmakeblock(tag, mut, Some shape), ll, loc) + | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false) + | Record_float -> + Lprim(Pmakearray (Pfloatarray, mut), ll, loc) + | Record_extension -> + let path = + let (label, _) = fields.(0) in + match label.lbl_res.desc with + | Tconstr(p, _, _) -> p + | _ -> assert false + in + let slot = transl_path env path in + Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc) + in begin match opt_init_expr with None -> lam - | Some init_expr -> Llet(Strict, init_id, transl_exp init_expr, lam) + | Some init_expr -> Llet(Strict, Pgenval, init_id, + transl_exp init_expr, lam) end end else begin (* Take a shallow copy of the init record, then mutate the fields @@ -1053,21 +1358,59 @@ (* If you change anything here, you will likely have to change [check_recursive_recordwith] in this file. *) let copy_id = Ident.create "newrecord" in - let update_field (_, lbl, expr) cont = - let upd = - match lbl.lbl_repres with - Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr) - | Record_float -> Psetfloatfield lbl.lbl_pos in - Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in + let update_field cont (lbl, definition) = + match definition with + | Kept _type -> cont + | Overridden (_lid, expr) -> + let upd = + match repres with + Record_regular + | Record_inlined _ -> + Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment) + | Record_unboxed _ -> assert false + | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) + | Record_extension -> + Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment) + in + Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont) + in begin match opt_init_expr with None -> assert false | Some init_expr -> - Llet(Strict, copy_id, - Lprim(Pduprecord (repres, size), [transl_exp init_expr]), - List.fold_right update_field lbl_expr_list (Lvar copy_id)) + Llet(Strict, Pgenval, copy_id, + Lprim(Pduprecord (repres, size), [transl_exp init_expr], loc), + Array.fold_left update_field (Lvar copy_id) fields) end end +and transl_match e arg pat_expr_list exn_pat_expr_list partial = + let id = Typecore.name_pattern "exn" exn_pat_expr_list + and cases = transl_cases pat_expr_list + and exn_cases = transl_cases_try exn_pat_expr_list in + let static_catch body val_ids handler = + let static_exception_id = next_negative_raise_count () in + Lstaticcatch + (Ltrywith (Lstaticraise (static_exception_id, body), id, + Matching.for_trywith (Lvar id) exn_cases), + (static_exception_id, val_ids), + handler) + in + match arg, exn_cases with + | {exp_desc = Texp_tuple argl}, [] -> + Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial + | {exp_desc = Texp_tuple argl}, _ :: _ -> + let val_ids = List.map (fun _ -> Typecore.name_pattern "val" []) argl in + let lvars = List.map (fun id -> Lvar id) val_ids in + static_catch (transl_list argl) val_ids + (Matching.for_multiple_match e.exp_loc lvars cases partial) + | arg, [] -> + Matching.for_function e.exp_loc None (transl_exp arg) cases partial + | arg, _ :: _ -> + let val_id = Typecore.name_pattern "val" pat_expr_list in + static_catch [transl_exp arg] [val_id] + (Matching.for_function e.exp_loc None (Lvar val_id) cases partial) + + (* Wrapper for class compilation *) (* @@ -1081,15 +1424,6 @@ (transl_let rec_flag pat_expr_list) body *) -(* Compile an exception definition *) - -let transl_exception id path decl = - let name = - match path with - None -> Ident.name id - | Some p -> Path.name p in - Lprim(Pmakeblock(0, Immutable), [Lconst(Const_base(Const_string name))]) - (* Error report *) open Format @@ -1105,4 +1439,15 @@ fprintf ppf "Ancestor names can only be used to select inherited methods" | Unknown_builtin_primitive prim_name -> - fprintf ppf "Unknown builtin primitive \"%s\"" prim_name + fprintf ppf "Unknown builtin primitive \"%s\"" prim_name + | Unreachable_reached -> + fprintf ppf "Unreachable expression was reached" + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) diff -Nru ocaml-4.01.0/bytecomp/translcore.mli ocaml-4.05.0/bytecomp/translcore.mli --- ocaml-4.01.0/bytecomp/translcore.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/translcore.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Translation from typed abstract syntax to lambda terms, for the core language *) @@ -17,24 +20,29 @@ open Typedtree open Lambda -val name_pattern: string -> (pattern * 'a) list -> Ident.t - val transl_exp: expression -> lambda -val transl_apply: lambda -> (label * expression option * optional) list +val transl_apply: ?should_be_tailcall:bool + -> ?inlined:inline_attribute + -> ?specialised:specialise_attribute + -> lambda -> (arg_label * expression option) list -> Location.t -> lambda -val transl_let: - rec_flag -> (pattern * expression) list -> lambda -> lambda -val transl_primitive: Location.t -> Primitive.description -> lambda -val transl_exception: - Ident.t -> Path.t option -> exception_declaration -> lambda +val transl_let: rec_flag -> value_binding list -> lambda -> lambda +val transl_primitive: Location.t -> Primitive.description -> Env.t + -> Types.type_expr -> Path.t option -> lambda + +val transl_extension_constructor: Env.t -> Path.t option -> + extension_constructor -> lambda val check_recursive_lambda: Ident.t list -> lambda -> bool +val used_primitives: (Path.t, Location.t) Hashtbl.t + type error = Illegal_letrec_pat | Illegal_letrec_expr | Free_super_var | Unknown_builtin_primitive of string + | Unreachable_reached exception Error of Location.t * error diff -Nru ocaml-4.01.0/bytecomp/translmod.ml ocaml-4.05.0/bytecomp/translmod.ml --- ocaml-4.01.0/bytecomp/translmod.ml 2013-07-17 15:20:26.000000000 +0000 +++ ocaml-4.05.0/bytecomp/translmod.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Translation from typed abstract syntax to lambda terms, for the module language *) @@ -27,30 +30,91 @@ type error = Circular_dependency of Ident.t + exception Error of Location.t * error +(* Keep track of the root path (from the root of the namespace to the + currently compiled module expression). Useful for naming extensions. *) + +let global_path glob = Some(Pident glob) +let functor_path path param = + match path with + None -> None + | Some p -> Some(Papply(p, Pident param)) +let field_path path field = + match path with + None -> None + | Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) + +(* Compile type extensions *) + +let transl_type_extension env rootpath tyext body = + List.fold_right + (fun ext body -> + let lam = + transl_extension_constructor env (field_path rootpath ext.ext_id) ext + in + Llet(Strict, Pgenval, ext.ext_id, lam, body)) + tyext.tyext_constructors + body + (* Compile a coercion *) -let rec apply_coercion restr arg = +let rec apply_coercion loc strict restr arg = match restr with Tcoerce_none -> arg - | Tcoerce_structure pos_cc_list -> - name_lambda arg (fun id -> - Lprim(Pmakeblock(0, Immutable), - List.map (apply_coercion_field id) pos_cc_list)) + | Tcoerce_structure(pos_cc_list, id_pos_list) -> + name_lambda strict arg (fun id -> + let get_field pos = Lprim(Pfield pos,[Lvar id], loc) in + let lam = + Lprim(Pmakeblock(0, Immutable, None), + List.map (apply_coercion_field loc get_field) pos_cc_list, + loc) + in + wrap_id_pos_list loc id_pos_list get_field lam) | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create "funarg" in - name_lambda arg (fun id -> - Lfunction(Curried, [param], - apply_coercion cc_res - (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)], - Location.none)))) - | Tcoerce_primitive p -> - transl_primitive Location.none p + name_lambda strict arg (fun id -> + Lfunction{kind = Curried; params = [param]; + attr = { default_function_attribute with + is_a_functor = true }; + loc = loc; + body = apply_coercion + loc Strict cc_res + (Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=Lvar id; + ap_args=[apply_coercion loc Alias cc_arg + (Lvar param)]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise})}) + | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> + transl_primitive pc_loc pc_desc pc_env pc_type None + | Tcoerce_alias (path, cc) -> + name_lambda strict arg + (fun _ -> apply_coercion loc Alias cc (transl_normal_path path)) + +and apply_coercion_field loc get_field (pos, cc) = + apply_coercion loc Alias cc (get_field pos) + +and wrap_id_pos_list loc id_pos_list get_field lam = + let fv = free_variables lam in + (*Format.eprintf "%a@." Printlambda.lambda lam; + IdentSet.iter (fun id -> Format.eprintf "%a " Ident.print id) fv; + Format.eprintf "@.";*) + let (lam,s) = + List.fold_left (fun (lam,s) (id',pos,c) -> + if IdentSet.mem id' fv then + let id'' = Ident.create (Ident.name id') in + (Llet(Alias, Pgenval, id'', + apply_coercion loc Alias c (get_field pos),lam), + Ident.add id' (Lvar id'') s) + else (lam,s)) + (lam, Ident.empty) id_pos_list + in + if s == Ident.empty then lam else subst_lambda s lam -and apply_coercion_field id (pos, cc) = - apply_coercion cc (Lprim(Pfield pos, [Lvar id])) (* Compose two coercions apply_coercion c1 (apply_coercion c2 e) behaves like @@ -60,21 +124,42 @@ match (c1, c2) with (Tcoerce_none, c2) -> c2 | (c1, Tcoerce_none) -> c1 - | (Tcoerce_structure pc1, Tcoerce_structure pc2) -> + | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) -> let v2 = Array.of_list pc2 in + let ids1 = + List.map (fun (id,pos1,c1) -> + let (pos2,c2) = v2.(pos1) in (id, pos2, compose_coercions c1 c2)) + ids1 + in Tcoerce_structure (List.map (function (p1, Tcoerce_primitive p) -> (p1, Tcoerce_primitive p) | (p1, c1) -> let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2)) - pc1) + pc1, + ids1 @ ids2) | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) -> Tcoerce_functor(compose_coercions arg2 arg1, compose_coercions res1 res2) + | (c1, Tcoerce_alias (path, c2)) -> + Tcoerce_alias (path, compose_coercions c1 c2) | (_, _) -> fatal_error "Translmod.compose_coercions" +(* +let apply_coercion a b c = + Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; + apply_coercion a b c + +let compose_coercions c1 c2 = + let c3 = compose_coercions c1 c2 in + let open Includemod in + Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." + print_coercion c1 print_coercion c2 print_coercion c3; + c3 +*) + (* Record the primitive declarations occuring in the module compiled *) let primitive_declarations = ref ([] : Primitive.description list) @@ -83,24 +168,11 @@ primitive_declarations := p :: !primitive_declarations | _ -> () -(* Keep track of the root path (from the root of the namespace to the - currently compiled module expression). Useful for naming exceptions. *) - -let global_path glob = Some(Pident glob) -let functor_path path param = - match path with - None -> None - | Some p -> Some(Papply(p, Pident param)) -let field_path path field = - match path with - None -> None - | Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) - (* Utilities for compiling "module rec" definitions *) let mod_prim name = try - transl_path + transl_normal_path (fst (Env.lookup_value (Ldot (Lident "CamlinternalMod", name)) Env.empty)) with Not_found -> @@ -109,7 +181,7 @@ let undefined_location loc = let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in Lconst(Const_block(0, - [Const_base(Const_string fname); + [Const_base(Const_string (fname, None)); Const_base(Const_int line); Const_base(Const_int char)])) @@ -118,35 +190,42 @@ match Mtype.scrape env mty with Mty_ident _ -> raise Not_found + | Mty_alias _ -> + Const_block (1, [Const_pointer 0]) | Mty_signature sg -> Const_block(0, [Const_block(0, init_shape_struct env sg)]) - | Mty_functor(id, arg, res) -> + | Mty_functor _ -> raise Not_found (* can we do better? *) and init_shape_struct env sg = match sg with [] -> [] - | Sig_value(id, vdesc) :: rem -> + | Sig_value(_id, {val_kind=Val_reg; val_type=ty}) :: rem -> let init_v = - match Ctype.expand_head env vdesc.val_type with + match Ctype.expand_head env ty with {desc = Tarrow(_,_,_,_)} -> Const_pointer 0 (* camlinternalMod.Function *) | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t -> Const_pointer 1 (* camlinternalMod.Lazy *) | _ -> raise Not_found in init_v :: init_shape_struct env rem + | Sig_value(_, {val_kind=Val_prim _}) :: rem -> + init_shape_struct env rem + | Sig_value _ :: _rem -> + assert false | Sig_type(id, tdecl, _) :: rem -> - init_shape_struct (Env.add_type id tdecl env) rem - | Sig_exception(id, edecl) :: rem -> + init_shape_struct (Env.add_type ~check:false id tdecl env) rem + | Sig_typext _ :: _ -> raise Not_found - | Sig_module(id, mty, _) :: rem -> - init_shape_mod env mty :: - init_shape_struct (Env.add_module id mty env) rem + | Sig_module(id, md, _) :: rem -> + init_shape_mod env md.md_type :: + init_shape_struct (Env.add_module_declaration ~check:false + id md env) rem | Sig_modtype(id, minfo) :: rem -> init_shape_struct (Env.add_modtype id minfo env) rem - | Sig_class(id, cdecl, _) :: rem -> + | Sig_class _ :: rem -> Const_pointer 2 (* camlinternalMod.Class *) :: init_shape_struct env rem - | Sig_class_type(id, ctyp, _) :: rem -> + | Sig_class_type _ :: rem -> init_shape_struct env rem in try @@ -166,7 +245,7 @@ and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in let fv = Array.map Lambda.free_variables rhs in let num_bindings = Array.length id in - let status = Array.create num_bindings Undefined in + let status = Array.make num_bindings Undefined in let res = ref [] in let rec emit_binding i = match status.(i) with @@ -195,26 +274,36 @@ let rec bind_inits = function [] -> bind_strict bindings - | (id, None, rhs) :: rem -> + | (_id, None, _rhs) :: rem -> bind_inits rem - | (id, Some(loc, shape), rhs) :: rem -> - Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape], Location.none), + | (id, Some(loc, shape), _rhs) :: rem -> + Llet(Strict, Pgenval, id, + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=mod_prim "init_mod"; + ap_args=[loc; shape]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}, bind_inits rem) and bind_strict = function [] -> patch_forwards bindings | (id, None, rhs) :: rem -> - Llet(Strict, id, rhs, bind_strict rem) - | (id, Some(loc, shape), rhs) :: rem -> + Llet(Strict, Pgenval, id, rhs, bind_strict rem) + | (_id, Some _, _rhs) :: rem -> bind_strict rem and patch_forwards = function [] -> cont - | (id, None, rhs) :: rem -> + | (_id, None, _rhs) :: rem -> patch_forwards rem - | (id, Some(loc, shape), rhs) :: rem -> - Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs], - Location.none), + | (id, Some(_loc, shape), rhs) :: rem -> + Lsequence(Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=mod_prim "update_mod"; + ap_args=[shape; Lvar id; rhs]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}, patch_forwards rem) in bind_inits bindings @@ -222,152 +311,316 @@ let compile_recmodule compile_rhs bindings cont = eval_rec_bindings (reorder_rec_bindings - (List.map - (fun ( id, _, _, modl) -> - (id, modl.mod_loc, init_shape modl, compile_rhs id modl)) - bindings)) + (List.map + (fun {mb_id=id; mb_expr=modl; _} -> + (id, modl.mod_loc, init_shape modl, compile_rhs id modl)) + bindings)) cont (* Extract the list of "value" identifiers bound by a signature. "Value" identifiers are identifiers for signature components that - correspond to a run-time value: values, exceptions, modules, classes. + correspond to a run-time value: values, extensions, modules, classes. Note: manifest primitives do not correspond to a run-time value! *) let rec bound_value_identifiers = function [] -> [] | Sig_value(id, {val_kind = Val_reg}) :: rem -> id :: bound_value_identifiers rem - | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem - | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem - | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem + | Sig_typext(id, _, _) :: rem -> id :: bound_value_identifiers rem + | Sig_module(id, _, _) :: rem -> id :: bound_value_identifiers rem + | Sig_class(id, _, _) :: rem -> id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem + +(* Code to translate class entries in a structure *) + +let transl_class_bindings cl_list = + let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in + (ids, + List.map + (fun ({ci_id_class=id; ci_expr=cl; ci_virt=vf}, meths) -> + (id, transl_class ids id meths cl vf)) + cl_list) + (* Compile a module expression *) let rec transl_module cc rootpath mexp = - match mexp.mod_desc with - Tmod_ident (path,_) -> - apply_coercion cc (transl_path path) - | Tmod_structure str -> - transl_struct [] cc rootpath str - | Tmod_functor( param, _, mty, body) -> - let bodypath = functor_path rootpath param in - oo_wrap mexp.mod_env true - (function - | Tcoerce_none -> - Lfunction(Curried, [param], - transl_module Tcoerce_none bodypath body) - | Tcoerce_functor(ccarg, ccres) -> - let param' = Ident.create "funarg" in - Lfunction(Curried, [param'], - Llet(Alias, param, apply_coercion ccarg (Lvar param'), - transl_module ccres bodypath body)) - | _ -> - fatal_error "Translmod.transl_module") - cc - | Tmod_apply(funct, arg, ccarg) -> - oo_wrap mexp.mod_env true - (apply_coercion cc) - (Lapply(transl_module Tcoerce_none None funct, - [transl_module ccarg None arg], mexp.mod_loc)) - | Tmod_constraint(arg, mty, _, ccarg) -> - transl_module (compose_coercions cc ccarg) rootpath arg - | Tmod_unpack(arg, _) -> - apply_coercion cc (Translcore.transl_exp arg) + List.iter (Translattribute.check_attribute_on_module mexp) + mexp.mod_attributes; + let loc = mexp.mod_loc in + match mexp.mod_type with + Mty_alias _ -> apply_coercion loc Alias cc lambda_unit + | _ -> + match mexp.mod_desc with + Tmod_ident (path,_) -> + apply_coercion loc Strict cc + (transl_path ~loc mexp.mod_env path) + | Tmod_structure str -> + fst (transl_struct loc [] cc rootpath str) + | Tmod_functor(param, _, _, body) -> + let bodypath = functor_path rootpath param in + let inline_attribute = + Translattribute.get_inline_attribute mexp.mod_attributes + in + oo_wrap mexp.mod_env true + (function + | Tcoerce_none -> + Lfunction{kind = Curried; params = [param]; + attr = { inline = inline_attribute; + specialise = Default_specialise; + is_a_functor = true; + stub = false; }; + loc = loc; + body = transl_module Tcoerce_none bodypath body} + | Tcoerce_functor(ccarg, ccres) -> + let param' = Ident.create "funarg" in + Lfunction{kind = Curried; params = [param']; + attr = { inline = inline_attribute; + specialise = Default_specialise; + is_a_functor = true; + stub = false; }; + loc = loc; + body = Llet(Alias, Pgenval, param, + apply_coercion loc Alias ccarg + (Lvar param'), + transl_module ccres bodypath body)} + | _ -> + fatal_error "Translmod.transl_module") + cc + | Tmod_apply(funct, arg, ccarg) -> + let inlined_attribute, funct = + Translattribute.get_and_remove_inlined_attribute_on_module funct + in + oo_wrap mexp.mod_env true + (apply_coercion loc Strict cc) + (Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=transl_module Tcoerce_none None funct; + ap_args=[transl_module ccarg None arg]; + ap_inlined=inlined_attribute; + ap_specialised=Default_specialise}) + | Tmod_constraint(arg, _, _, ccarg) -> + transl_module (compose_coercions cc ccarg) rootpath arg + | Tmod_unpack(arg, _) -> + apply_coercion loc Strict cc (Translcore.transl_exp arg) -and transl_struct fields cc rootpath str = - transl_structure fields cc rootpath str.str_items +and transl_struct loc fields cc rootpath str = + transl_structure loc fields cc rootpath str.str_final_env str.str_items -and transl_structure fields cc rootpath = function +and transl_structure loc fields cc rootpath final_env = function [] -> - begin match cc with - Tcoerce_none -> - Lprim(Pmakeblock(0, Immutable), - List.map (fun id -> Lvar id) (List.rev fields)) - | Tcoerce_structure pos_cc_list -> - let v = Array.of_list (List.rev fields) in - Lprim(Pmakeblock(0, Immutable), - List.map - (fun (pos, cc) -> - match cc with - Tcoerce_primitive p -> transl_primitive Location.none p - | _ -> apply_coercion cc (Lvar v.(pos))) - pos_cc_list) - | _ -> - fatal_error "Translmod.transl_structure" - end + let body, size = + match cc with + Tcoerce_none -> + Lprim(Pmakeblock(0, Immutable, None), + List.map (fun id -> Lvar id) (List.rev fields), loc), + List.length fields + | Tcoerce_structure(pos_cc_list, id_pos_list) -> + (* Do not ignore id_pos_list ! *) + (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; + List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) + fields; + Format.eprintf "@]@.";*) + let v = Array.of_list (List.rev fields) in + let get_field pos = Lvar v.(pos) + and ids = List.fold_right IdentSet.add fields IdentSet.empty in + let lam = + Lprim(Pmakeblock(0, Immutable, None), + List.map + (fun (pos, cc) -> + match cc with + Tcoerce_primitive p -> + transl_primitive p.pc_loc + p.pc_desc p.pc_env p.pc_type None + | _ -> apply_coercion loc Strict cc (get_field pos)) + pos_cc_list, loc) + and id_pos_list = + List.filter (fun (id,_,_) -> not (IdentSet.mem id ids)) + id_pos_list + in + wrap_id_pos_list loc id_pos_list get_field lam, + List.length pos_cc_list + | _ -> + fatal_error "Translmod.transl_structure" + in + (* This debugging event provides information regarding the structure + items. It is ignored by the OCaml debugger but is used by + Js_of_ocaml to preserve variable names. *) + (if !Clflags.debug && not !Clflags.native_code then + Levent(body, + {lev_loc = loc; + lev_kind = Lev_pseudo; + lev_repr = None; + lev_env = Env.summary final_env}) + else + body), + size | item :: rem -> match item.str_desc with - | Tstr_eval expr -> - Lsequence(transl_exp expr, transl_structure fields cc rootpath rem) - | Tstr_value(rec_flag, pat_expr_list) -> - let ext_fields = rev_let_bound_idents pat_expr_list @ fields in - transl_let rec_flag pat_expr_list - (transl_structure ext_fields cc rootpath rem) - | Tstr_primitive(id, _, descr) -> - record_primitive descr.val_val; - transl_structure fields cc rootpath rem - | Tstr_type(decls) -> - transl_structure fields cc rootpath rem - | Tstr_exception( id, _, decl) -> - Llet(Strict, id, transl_exception id (field_path rootpath id) decl, - transl_structure (id :: fields) cc rootpath rem) - | Tstr_exn_rebind( id, _, path, _) -> - Llet(Strict, id, transl_path path, - transl_structure (id :: fields) cc rootpath rem) - | Tstr_module( id, _, modl) -> - Llet(Strict, id, - transl_module Tcoerce_none (field_path rootpath id) modl, - transl_structure (id :: fields) cc rootpath rem) - | Tstr_recmodule bindings -> - let ext_fields = - List.rev_append (List.map (fun (id, _,_,_) -> id) bindings) fields in - compile_recmodule - (fun id modl -> - transl_module Tcoerce_none (field_path rootpath id) modl) - bindings - (transl_structure ext_fields cc rootpath rem) - | Tstr_modtype(id, _, decl) -> - transl_structure fields cc rootpath rem - | Tstr_open _ -> - transl_structure fields cc rootpath rem - | Tstr_class cl_list -> - let ids = List.map (fun (ci,_,_) -> ci.ci_id_class) cl_list in - Lletrec(List.map - (fun (ci, meths, vf) -> - let id = ci.ci_id_class in - let cl = ci.ci_expr in - (id, transl_class ids id meths cl vf )) - cl_list, - transl_structure (List.rev ids @ fields) cc rootpath rem) - | Tstr_class_type cl_list -> - transl_structure fields cc rootpath rem - | Tstr_include(modl, sg) -> - let ids = bound_value_identifiers sg in - let mid = Ident.create "include" in - let rec rebind_idents pos newfields = function - [] -> - transl_structure newfields cc rootpath rem - | id :: ids -> - Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), - rebind_idents (pos + 1) (id :: newfields) ids) in - Llet(Strict, mid, transl_module Tcoerce_none None modl, - rebind_idents 0 fields ids) + | Tstr_eval (expr, _) -> + let body, size = + transl_structure loc fields cc rootpath final_env rem + in + Lsequence(transl_exp expr, body), size + | Tstr_value(rec_flag, pat_expr_list) -> + let ext_fields = rev_let_bound_idents pat_expr_list @ fields in + let body, size = + transl_structure loc ext_fields cc rootpath final_env rem + in + transl_let rec_flag pat_expr_list body, size + | Tstr_primitive descr -> + record_primitive descr.val_val; + transl_structure loc fields cc rootpath final_env rem + | Tstr_type _ -> + transl_structure loc fields cc rootpath final_env rem + | Tstr_typext(tyext) -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + let body, size = + transl_structure loc (List.rev_append ids fields) + cc rootpath final_env rem + in + transl_type_extension item.str_env rootpath tyext body, size + | Tstr_exception ext -> + let id = ext.ext_id in + let path = field_path rootpath id in + let body, size = + transl_structure loc (id :: fields) cc rootpath final_env rem + in + Llet(Strict, Pgenval, id, + transl_extension_constructor item.str_env path ext, body), + size + | Tstr_module mb -> + let id = mb.mb_id in + let body, size = + transl_structure loc (id :: fields) cc rootpath final_env rem + in + let module_body = + transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr + in + let module_body = + Translattribute.add_inline_attribute module_body mb.mb_loc + mb.mb_attributes + in + Llet(pure_module mb.mb_expr, Pgenval, id, + module_body, + body), size + | Tstr_recmodule bindings -> + let ext_fields = + List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields + in + let body, size = + transl_structure loc ext_fields cc rootpath final_env rem + in + let lam = + compile_recmodule + (fun id modl -> + transl_module Tcoerce_none (field_path rootpath id) modl) + bindings + body + in + lam, size + | Tstr_class cl_list -> + let (ids, class_bindings) = transl_class_bindings cl_list in + let body, size = + transl_structure loc (List.rev_append ids fields) + cc rootpath final_env rem + in + Lletrec(class_bindings, body), size + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in + let mid = Ident.create "include" in + let rec rebind_idents pos newfields = function + [] -> + transl_structure loc newfields cc rootpath final_env rem + | id :: ids -> + let body, size = + rebind_idents (pos + 1) (id :: newfields) ids + in + Llet(Alias, Pgenval, id, + Lprim(Pfield pos, [Lvar mid], incl.incl_loc), body), + size + in + let body, size = rebind_idents 0 fields ids in + Llet(pure_module modl, Pgenval, mid, + transl_module Tcoerce_none None modl, body), + size + + | Tstr_modtype _ + | Tstr_open _ + | Tstr_class_type _ + | Tstr_attribute _ -> + transl_structure loc fields cc rootpath final_env rem + +and pure_module m = + match m.mod_desc with + Tmod_ident _ -> Alias + | Tmod_constraint (m,_,_,_) -> pure_module m + | _ -> Strict (* Update forward declaration in Translcore *) let _ = Translcore.transl_module := transl_module +(* Introduce dependencies on modules referenced only by "external". *) + +let scan_used_globals lam = + let globals = ref Ident.Set.empty in + let rec scan lam = + Lambda.iter scan lam; + match lam with + Lprim ((Pgetglobal id | Psetglobal id), _, _) -> + globals := Ident.Set.add id !globals + | _ -> () + in + scan lam; !globals + +let required_globals ~flambda body = + let globals = scan_used_globals body in + let add_global id req = + if not flambda && Ident.Set.mem id globals then + req + else + Ident.Set.add id req + in + let required = + Hashtbl.fold + (fun path _ -> add_global (Path.head path)) used_primitives + (if flambda then globals else Ident.Set.empty) + in + let required = + List.fold_right add_global (Env.get_required_globals ()) required + in + Env.reset_required_globals (); + Hashtbl.clear used_primitives; + required + (* Compile an implementation *) -let transl_implementation module_name (str, cc) = +let transl_implementation_flambda module_name (str, cc) = reset_labels (); primitive_declarations := []; + Hashtbl.clear used_primitives; let module_id = Ident.create_persistent module_name in - Lprim(Psetglobal module_id, - [transl_label_init - (transl_struct [] cc (global_path module_id) str)]) + let body, size = + Translobj.transl_label_init + (fun () -> transl_struct Location.none [] cc + (global_path module_id) str) + in + { module_ident = module_id; + main_module_block_size = size; + required_globals = required_globals ~flambda:true body; + code = body } +let transl_implementation module_name (str, cc) = + let implementation = + transl_implementation_flambda module_name (str, cc) + in + let code = + Lprim (Psetglobal implementation.module_ident, [implementation.code], + Location.none) + in + { implementation with code } (* Build the list of value identifiers defined by a toplevel structure (excluding primitive declarations). *) @@ -376,22 +629,26 @@ [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval expr -> defined_idents rem - | Tstr_value(rec_flag, pat_expr_list) -> + | Tstr_eval _ -> defined_idents rem + | Tstr_value(_rec_flag, pat_expr_list) -> let_bound_idents pat_expr_list @ defined_idents rem - | Tstr_primitive(id, _, descr) -> defined_idents rem - | Tstr_type decls -> defined_idents rem - | Tstr_exception(id, _, decl) -> id :: defined_idents rem - | Tstr_exn_rebind(id, _, path, _) -> id :: defined_idents rem - | Tstr_module(id, _, modl) -> id :: defined_idents rem + | Tstr_primitive _ -> defined_idents rem + | Tstr_type _ -> defined_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ defined_idents rem + | Tstr_exception ext -> ext.ext_id :: defined_idents rem + | Tstr_module mb -> mb.mb_id :: defined_idents rem | Tstr_recmodule decls -> - List.map (fun (id, _, _, _) -> id) decls @ defined_idents rem - | Tstr_modtype(id, _, decl) -> defined_idents rem + List.map (fun mb -> mb.mb_id) decls @ defined_idents rem + | Tstr_modtype _ -> defined_idents rem | Tstr_open _ -> defined_idents rem | Tstr_class cl_list -> - List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem - | Tstr_class_type cl_list -> defined_idents rem - | Tstr_include(modl, sg) -> bound_value_identifiers sg @ defined_idents rem + List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem + | Tstr_class_type _ -> defined_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ defined_idents rem + | Tstr_attribute _ -> defined_idents rem (* second level idents (module M = struct ... let id = ... end), and all sub-levels idents *) @@ -399,44 +656,66 @@ [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval expr -> more_idents rem - | Tstr_value(rec_flag, pat_expr_list) -> more_idents rem - | Tstr_primitive(id, _, descr) -> more_idents rem - | Tstr_type decls -> more_idents rem - | Tstr_exception(id, _, decl) -> more_idents rem - | Tstr_exn_rebind(id, _, path, _) -> more_idents rem - | Tstr_recmodule decls -> more_idents rem - | Tstr_modtype(id, _, decl) -> more_idents rem + | Tstr_eval _ -> more_idents rem + | Tstr_value _ -> more_idents rem + | Tstr_primitive _ -> more_idents rem + | Tstr_type _ -> more_idents rem + | Tstr_typext _ -> more_idents rem + | Tstr_exception _ -> more_idents rem + | Tstr_recmodule _ -> more_idents rem + | Tstr_modtype _ -> more_idents rem | Tstr_open _ -> more_idents rem - | Tstr_class cl_list -> more_idents rem - | Tstr_class_type cl_list -> more_idents rem - | Tstr_include(modl, _) -> more_idents rem - | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> - all_idents str.str_items @ more_idents rem - | Tstr_module(id, _, _) -> more_idents rem + | Tstr_class _ -> more_idents rem + | Tstr_class_type _ -> more_idents rem + | Tstr_include{incl_mod={mod_desc = + Tmod_constraint ({mod_desc = Tmod_structure str}, + _, _, _)}} -> + all_idents str.str_items @ more_idents rem + | Tstr_include _ -> more_idents rem + | Tstr_module {mb_expr={mod_desc = Tmod_structure str}} + | Tstr_module{mb_expr={mod_desc = + Tmod_constraint ({mod_desc = Tmod_structure str}, + _, _, _)}} -> + all_idents str.str_items @ more_idents rem + | Tstr_module _ -> more_idents rem + | Tstr_attribute _ -> more_idents rem and all_idents = function [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval expr -> all_idents rem - | Tstr_value(rec_flag, pat_expr_list) -> + | Tstr_eval _ -> all_idents rem + | Tstr_value(_rec_flag, pat_expr_list) -> let_bound_idents pat_expr_list @ all_idents rem - | Tstr_primitive(id, _, descr) -> all_idents rem - | Tstr_type decls -> all_idents rem - | Tstr_exception(id, _, decl) -> id :: all_idents rem - | Tstr_exn_rebind(id, _, path, _) -> id :: all_idents rem + | Tstr_primitive _ -> all_idents rem + | Tstr_type _ -> all_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ all_idents rem + | Tstr_exception ext -> ext.ext_id :: all_idents rem | Tstr_recmodule decls -> - List.map (fun (id, _, _, _) -> id) decls @ all_idents rem - | Tstr_modtype(id, _, decl) -> all_idents rem + List.map (fun mb -> mb.mb_id) decls @ all_idents rem + | Tstr_modtype _ -> all_idents rem | Tstr_open _ -> all_idents rem | Tstr_class cl_list -> - List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem - | Tstr_class_type cl_list -> all_idents rem - | Tstr_include(modl, sg) -> bound_value_identifiers sg @ all_idents rem - | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> - id :: all_idents str.str_items @ all_idents rem - | Tstr_module(id, _, _) -> id :: all_idents rem + List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem + | Tstr_class_type _ -> all_idents rem + + | Tstr_include{incl_type; incl_mod={mod_desc = + Tmod_constraint ({mod_desc = Tmod_structure str}, + _, _, _)}} -> + bound_value_identifiers incl_type @ all_idents str.str_items @ all_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ all_idents rem + + | Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}} + | Tstr_module{mb_id; + mb_expr={mod_desc = + Tmod_constraint ({mod_desc = Tmod_structure str}, + _, _, _)}} -> + mb_id :: all_idents str.str_items @ all_idents rem + | Tstr_module mb -> mb.mb_id :: all_idents rem + | Tstr_attribute _ -> all_idents rem (* A variant of transl_structure used to compile toplevel structure definitions @@ -454,11 +733,20 @@ let nat_toplevel_name id = try match Ident.find_same id !transl_store_subst with - | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])]) -> (glob,pos) + | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos) | _ -> raise Not_found with Not_found -> fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id) +let field_of_str loc str = + let ids = Array.of_list (defined_idents str.str_items) in + fun (pos, cc) -> + match cc with + | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> + transl_primitive pc_loc pc_desc pc_env pc_type None + | _ -> apply_coercion loc Strict cc (Lvar ids.(pos)) + + let transl_store_structure glob map prims str = let rec transl_store rootpath subst = function [] -> @@ -466,109 +754,198 @@ lambda_unit | item :: rem -> match item.str_desc with - | Tstr_eval expr -> - Lsequence(subst_lambda subst (transl_exp expr), - transl_store rootpath subst rem) - | Tstr_value(rec_flag, pat_expr_list) -> - let ids = let_bound_idents pat_expr_list in - let lam = transl_let rec_flag pat_expr_list (store_idents ids) in - Lsequence(subst_lambda subst lam, - transl_store rootpath (add_idents false ids subst) rem) - | Tstr_primitive(id, _, descr) -> - record_primitive descr.val_val; - transl_store rootpath subst rem - | Tstr_type(decls) -> - transl_store rootpath subst rem - | Tstr_exception( id, _, decl) -> - let lam = transl_exception id (field_path rootpath id) decl in - Lsequence(Llet(Strict, id, lam, store_ident id), - transl_store rootpath (add_ident false id subst) rem) - | Tstr_exn_rebind( id, _, path, _) -> - let lam = subst_lambda subst (transl_path path) in - Lsequence(Llet(Strict, id, lam, store_ident id), - transl_store rootpath (add_ident false id subst) rem) - | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> - let lam = transl_store (field_path rootpath id) subst str.str_items in - (* Careful: see next case *) - let subst = !transl_store_subst in - Lsequence(lam, - Llet(Strict, id, - subst_lambda subst - (Lprim(Pmakeblock(0, Immutable), - List.map (fun id -> Lvar id) - (defined_idents str.str_items))), - Lsequence(store_ident id, - transl_store rootpath (add_ident true id subst) - rem))) - | Tstr_module( id, _, modl) -> - let lam = - transl_module Tcoerce_none (field_path rootpath id) modl in - (* Careful: the module value stored in the global may be different - from the local module value, in case a coercion is applied. - If so, keep using the local module value (id) in the remainder of - the compilation unit (add_ident true returns subst unchanged). - If not, we can use the value from the global - (add_ident true adds id -> Pgetglobal... to subst). *) - Llet(Strict, id, subst_lambda subst lam, - Lsequence(store_ident id, - transl_store rootpath (add_ident true id subst) rem)) - | Tstr_recmodule bindings -> - let ids = List.map fst4 bindings in - compile_recmodule - (fun id modl -> - subst_lambda subst - (transl_module Tcoerce_none - (field_path rootpath id) modl)) - bindings - (Lsequence(store_idents ids, - transl_store rootpath (add_idents true ids subst) rem)) - | Tstr_modtype(id, _, decl) -> - transl_store rootpath subst rem - | Tstr_open _ -> - transl_store rootpath subst rem - | Tstr_class cl_list -> - let ids = List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list in - let lam = - Lletrec(List.map - (fun (ci, meths, vf) -> - let id = ci.ci_id_class in - let cl = ci.ci_expr in - (id, transl_class ids id meths cl vf)) - cl_list, - store_idents ids) in - Lsequence(subst_lambda subst lam, - transl_store rootpath (add_idents false ids subst) rem) - | Tstr_class_type cl_list -> - transl_store rootpath subst rem - | Tstr_include(modl, sg) -> - let ids = bound_value_identifiers sg in - let mid = Ident.create "include" in - let rec store_idents pos = function - [] -> transl_store rootpath (add_idents true ids subst) rem - | id :: idl -> - Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), - Lsequence(store_ident id, store_idents (pos + 1) idl)) in - Llet(Strict, mid, - subst_lambda subst (transl_module Tcoerce_none None modl), - store_idents 0 ids) + | Tstr_eval (expr, _attrs) -> + Lsequence(subst_lambda subst (transl_exp expr), + transl_store rootpath subst rem) + | Tstr_value(rec_flag, pat_expr_list) -> + let ids = let_bound_idents pat_expr_list in + let lam = + transl_let rec_flag pat_expr_list (store_idents Location.none ids) + in + Lsequence(subst_lambda subst lam, + transl_store rootpath (add_idents false ids subst) rem) + | Tstr_primitive descr -> + record_primitive descr.val_val; + transl_store rootpath subst rem + | Tstr_type _ -> + transl_store rootpath subst rem + | Tstr_typext(tyext) -> + let ids = + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + in + let lam = + transl_type_extension item.str_env rootpath tyext + (store_idents Location.none ids) + in + Lsequence(subst_lambda subst lam, + transl_store rootpath (add_idents false ids subst) rem) + | Tstr_exception ext -> + let id = ext.ext_id in + let path = field_path rootpath id in + let lam = transl_extension_constructor item.str_env path ext in + Lsequence(Llet(Strict, Pgenval, id, subst_lambda subst lam, + store_ident ext.ext_loc id), + transl_store rootpath (add_ident false id subst) rem) + | Tstr_module{mb_id=id;mb_loc=loc; + mb_expr={mod_desc = Tmod_structure str} as mexp; + mb_attributes} -> + List.iter (Translattribute.check_attribute_on_module mexp) + mb_attributes; + let lam = + transl_store (field_path rootpath id) subst str.str_items + in + (* Careful: see next case *) + let subst = !transl_store_subst in + Lsequence(lam, + Llet(Strict, Pgenval, id, + subst_lambda subst + (Lprim(Pmakeblock(0, Immutable, None), + List.map (fun id -> Lvar id) + (defined_idents str.str_items), loc)), + Lsequence(store_ident loc id, + transl_store rootpath + (add_ident true id subst) + rem))) + | Tstr_module{ + mb_id=id;mb_loc=loc; + mb_expr= { + mod_desc = Tmod_constraint ( + {mod_desc = Tmod_structure str} as mexp, _, _, + (Tcoerce_structure (map, _) as _cc))}; + mb_attributes + } -> + (* Format.printf "coerc id %s: %a@." (Ident.unique_name id) + Includemod.print_coercion cc; *) + List.iter (Translattribute.check_attribute_on_module mexp) + mb_attributes; + let lam = + transl_store (field_path rootpath id) subst str.str_items + in + (* Careful: see next case *) + let subst = !transl_store_subst in + let field = field_of_str loc str in + Lsequence(lam, + Llet(Strict, Pgenval, id, + subst_lambda subst + (Lprim(Pmakeblock(0, Immutable, None), + List.map field map, loc)), + Lsequence(store_ident loc id, + transl_store rootpath + (add_ident true id subst) + rem))) + | Tstr_module{mb_id=id; mb_expr=modl; mb_loc=loc; mb_attributes} -> + let lam = + Translattribute.add_inline_attribute + (transl_module Tcoerce_none (field_path rootpath id) modl) + loc mb_attributes + in + (* Careful: the module value stored in the global may be different + from the local module value, in case a coercion is applied. + If so, keep using the local module value (id) in the remainder of + the compilation unit (add_ident true returns subst unchanged). + If not, we can use the value from the global + (add_ident true adds id -> Pgetglobal... to subst). *) + Llet(Strict, Pgenval, id, subst_lambda subst lam, + Lsequence(store_ident loc id, + transl_store rootpath (add_ident true id subst) rem)) + | Tstr_recmodule bindings -> + let ids = List.map (fun mb -> mb.mb_id) bindings in + compile_recmodule + (fun id modl -> + subst_lambda subst + (transl_module Tcoerce_none + (field_path rootpath id) modl)) + bindings + (Lsequence(store_idents Location.none ids, + transl_store rootpath (add_idents true ids subst) rem)) + | Tstr_class cl_list -> + let (ids, class_bindings) = transl_class_bindings cl_list in + let lam = + Lletrec(class_bindings, store_idents Location.none ids) + in + Lsequence(subst_lambda subst lam, + transl_store rootpath (add_idents false ids subst) rem) + + | Tstr_include{ + incl_loc=loc; + incl_mod= { + mod_desc = Tmod_constraint ( + ({mod_desc = Tmod_structure str} as mexp), _, _, + (Tcoerce_structure (map, _)))}; + incl_attributes; + incl_type; + } -> + List.iter (Translattribute.check_attribute_on_module mexp) + incl_attributes; + (* Shouldn't we use mod_attributes instead of incl_attributes? + Same question for the Tstr_module cases above, btw. *) + let lam = + transl_store None subst str.str_items + (* It is tempting to pass rootpath instead of None + in order to give a more precise name to exceptions + in the included structured, but this would introduce + a difference of behavior compared to bytecode. *) + in + let subst = !transl_store_subst in + let field = field_of_str loc str in + let ids0 = bound_value_identifiers incl_type in + let rec loop ids args = + match ids, args with + | [], [] -> + transl_store rootpath (add_idents true ids0 subst) rem + | id :: ids, arg :: args -> + Llet(Alias, Pgenval, id, subst_lambda subst (field arg), + Lsequence(store_ident loc id, + loop ids args)) + | _ -> assert false + in + Lsequence(lam, loop ids0 map) + + + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in + let mid = Ident.create "include" in + let loc = incl.incl_loc in + let rec store_idents pos = function + [] -> transl_store rootpath (add_idents true ids subst) rem + | id :: idl -> + Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], loc), + Lsequence(store_ident loc id, + store_idents (pos + 1) idl)) + in + Llet(Strict, Pgenval, mid, + subst_lambda subst (transl_module Tcoerce_none None modl), + store_idents 0 ids) + | Tstr_modtype _ + | Tstr_open _ + | Tstr_class_type _ + | Tstr_attribute _ -> + transl_store rootpath subst rem - and store_ident id = + and store_ident loc id = try let (pos, cc) = Ident.find_same id map in - let init_val = apply_coercion cc (Lvar id) in - Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); init_val]) + let init_val = apply_coercion loc Alias cc (Lvar id) in + Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal glob, [], loc); init_val], + loc) with Not_found -> fatal_error("Translmod.store_ident: " ^ Ident.unique_name id) - and store_idents idlist = - make_sequence store_ident idlist + and store_idents loc idlist = + make_sequence (store_ident loc) idlist and add_ident may_coerce id subst = try let (pos, cc) = Ident.find_same id map in match cc with Tcoerce_none -> - Ident.add id (Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])])) subst + Ident.add id + (Lprim(Pfield pos, + [Lprim(Pgetglobal glob, [], Location.none)], + Location.none)) + subst | _ -> if may_coerce then subst else assert false with Not_found -> @@ -578,9 +955,11 @@ List.fold_right (add_ident may_coerce) idlist subst and store_primitive (pos, prim) cont = - Lsequence(Lprim(Psetfield(pos, false), - [Lprim(Pgetglobal glob, []); - transl_primitive Location.none prim]), + Lsequence(Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal glob, [], Location.none); + transl_primitive Location.none + prim.pc_desc prim.pc_env prim.pc_type None], + Location.none), cont) in List.fold_right store_primitive prims @@ -600,20 +979,21 @@ let build_ident_map restr idlist more_ids = let rec natural_map pos map prims = function - [] -> - (map, prims, pos) - | id :: rem -> - natural_map (pos+1) (Ident.add id (pos, Tcoerce_none) map) prims rem in + [] -> + (map, prims, pos) + | id :: rem -> + natural_map (pos+1) (Ident.add id (pos, Tcoerce_none) map) prims rem in let (map, prims, pos) = match restr with Tcoerce_none -> natural_map 0 Ident.empty [] idlist - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure (pos_cc_list, _id_pos_list) -> + (* ignore _id_pos_list as the ids are already bound *) let idarray = Array.of_list idlist in let rec export_map pos map prims undef = function [] -> natural_map pos map prims undef - | (source_pos, Tcoerce_primitive p) :: rem -> + | (_source_pos, Tcoerce_primitive p) :: rem -> export_map (pos + 1) map ((pos, p) :: prims) undef rem | (source_pos, cc) :: rem -> let id = idarray.(source_pos) in @@ -631,11 +1011,12 @@ let transl_store_gen module_name ({ str_items = str }, restr) topl = reset_labels (); primitive_declarations := []; + Hashtbl.clear used_primitives; let module_id = Ident.create_persistent module_name in let (map, prims, size) = build_ident_map restr (defined_idents str) (more_idents str) in let f = function - | [ { str_desc = Tstr_eval expr } ] when topl -> + | [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl -> assert (size = 0); subst_lambda !transl_store_subst (transl_exp expr) | str -> transl_store_structure module_id map prims str in @@ -648,9 +1029,14 @@ let transl_store_implementation module_name (str, restr) = let s = !transl_store_subst in transl_store_subst := Ident.empty; - let r = transl_store_gen module_name (str, restr) false in + let (i, code) = transl_store_gen module_name (str, restr) false in transl_store_subst := s; - r + { Lambda.main_module_block_size = i; + code; + (* module_ident is not used by closure, but this allow to share + the type with the flambda version *) + module_ident = Ident.create_persistent module_name; + required_globals = required_globals ~flambda:true code } (* Compile a toplevel phrase *) @@ -669,108 +1055,151 @@ with Not_found -> Ident.name id let toploop_getvalue id = - Lapply(Lprim(Pfield toploop_getvalue_pos, - [Lprim(Pgetglobal toploop_ident, [])]), - [Lconst(Const_base(Const_string (toplevel_name id)))], - Location.none) + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lprim(Pfield toploop_getvalue_pos, + [Lprim(Pgetglobal toploop_ident, [], Location.none)], + Location.none); + ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} let toploop_setvalue id lam = - Lapply(Lprim(Pfield toploop_setvalue_pos, - [Lprim(Pgetglobal toploop_ident, [])]), - [Lconst(Const_base(Const_string (toplevel_name id))); lam], - Location.none) + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lprim(Pfield toploop_setvalue_pos, + [Lprim(Pgetglobal toploop_ident, [], Location.none)], + Location.none); + ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None))); + lam]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} let toploop_setvalue_id id = toploop_setvalue id (Lvar id) -let close_toplevel_term lam = - IdentSet.fold (fun id l -> Llet(Strict, id, toploop_getvalue id, l)) +let close_toplevel_term (lam, ()) = + IdentSet.fold (fun id l -> Llet(Strict, Pgenval, id, + toploop_getvalue id, l)) (free_variables lam) lam let transl_toplevel_item item = match item.str_desc with - Tstr_eval expr -> + Tstr_eval (expr, _) + | Tstr_value(Nonrecursive, + [{vb_pat = {pat_desc=Tpat_any};vb_expr = expr}]) -> + (* special compilation for toplevel "let _ = expr", so + that Toploop can display the result of the expression. + Otherwise, the normal compilation would result + in a Lsequence returning unit. *) transl_exp expr | Tstr_value(rec_flag, pat_expr_list) -> let idents = let_bound_idents pat_expr_list in transl_let rec_flag pat_expr_list - (make_sequence toploop_setvalue_id idents) - | Tstr_primitive(id, _, descr) -> - lambda_unit - | Tstr_type(decls) -> - lambda_unit - | Tstr_exception(id, _, decl) -> - toploop_setvalue id (transl_exception id None decl) - | Tstr_exn_rebind(id, _, path, _) -> - toploop_setvalue id (transl_path path) - | Tstr_module(id, _, modl) -> + (make_sequence toploop_setvalue_id idents) + | Tstr_typext(tyext) -> + let idents = + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + in + (* we need to use unique name in case of multiple + definitions of the same extension constructor in the toplevel *) + List.iter set_toplevel_unique_name idents; + transl_type_extension item.str_env None tyext + (make_sequence toploop_setvalue_id idents) + | Tstr_exception ext -> + set_toplevel_unique_name ext.ext_id; + toploop_setvalue ext.ext_id + (transl_extension_constructor item.str_env None ext) + | Tstr_module {mb_id=id; mb_expr=modl} -> (* we need to use the unique name for the module because of issues with "open" (PR#1672) *) set_toplevel_unique_name id; - toploop_setvalue id - (transl_module Tcoerce_none (Some(Pident id)) modl) + let lam = transl_module Tcoerce_none (Some(Pident id)) modl in + toploop_setvalue id lam | Tstr_recmodule bindings -> - let idents = List.map fst4 bindings in + let idents = List.map (fun mb -> mb.mb_id) bindings in compile_recmodule (fun id modl -> transl_module Tcoerce_none (Some(Pident id)) modl) bindings (make_sequence toploop_setvalue_id idents) - | Tstr_modtype(id, _, decl) -> - lambda_unit - | Tstr_open _ -> - lambda_unit | Tstr_class cl_list -> (* we need to use unique names for the classes because there might be a value named identically *) - let ids = List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list in + let (ids, class_bindings) = transl_class_bindings cl_list in List.iter set_toplevel_unique_name ids; - Lletrec(List.map - (fun (ci, meths, vf) -> - let id = ci.ci_id_class in - let cl = ci.ci_expr in - (id, transl_class ids id meths cl vf)) - cl_list, - make_sequence - (fun (ci, _, _) -> toploop_setvalue_id ci.ci_id_class) - cl_list) - | Tstr_class_type cl_list -> - lambda_unit - | Tstr_include(modl, sg) -> - let ids = bound_value_identifiers sg in + Lletrec(class_bindings, make_sequence toploop_setvalue_id ids) + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in let mid = Ident.create "include" in let rec set_idents pos = function [] -> lambda_unit | id :: ids -> - Lsequence(toploop_setvalue id (Lprim(Pfield pos, [Lvar mid])), + Lsequence(toploop_setvalue id + (Lprim(Pfield pos, [Lvar mid], Location.none)), set_idents (pos + 1) ids) in - Llet(Strict, mid, transl_module Tcoerce_none None modl, set_idents 0 ids) + Llet(Strict, Pgenval, mid, + transl_module Tcoerce_none None modl, set_idents 0 ids) + | Tstr_modtype _ + | Tstr_open _ + | Tstr_primitive _ + | Tstr_type _ + | Tstr_class_type _ + | Tstr_attribute _ -> + lambda_unit let transl_toplevel_item_and_close itm = - close_toplevel_term (transl_label_init (transl_toplevel_item itm)) + close_toplevel_term + (transl_label_init (fun () -> transl_toplevel_item itm, ())) let transl_toplevel_definition str = reset_labels (); + Hashtbl.clear used_primitives; make_sequence transl_toplevel_item_and_close str.str_items (* Compile the initialization code for a packed library *) let get_component = function None -> Lconst const_unit - | Some id -> Lprim(Pgetglobal id, []) + | Some id -> Lprim(Pgetglobal id, [], Location.none) + +let transl_package_flambda component_names coercion = + let size = + match coercion with + | Tcoerce_none -> List.length component_names + | Tcoerce_structure (l, _) -> List.length l + | Tcoerce_functor _ + | Tcoerce_primitive _ + | Tcoerce_alias _ -> assert false + in + size, + apply_coercion Location.none Strict coercion + (Lprim(Pmakeblock(0, Immutable, None), + List.map get_component component_names, + Location.none)) let transl_package component_names target_name coercion = let components = + Lprim(Pmakeblock(0, Immutable, None), + List.map get_component component_names, Location.none) in + Lprim(Psetglobal target_name, + [apply_coercion Location.none Strict coercion components], + Location.none) + (* + let components = match coercion with Tcoerce_none -> List.map get_component component_names - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure (pos_cc_list, id_pos_list) -> + (* ignore id_pos_list as the ids are already bound *) let g = Array.of_list component_names in List.map - (fun (pos, cc) -> apply_coercion cc (get_component g.(pos))) + (fun (pos, cc) -> apply_coercion Strict cc (get_component g.(pos))) pos_cc_list | _ -> assert false in Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)]) + *) let transl_store_package component_names target_name coercion = let rec make_sequence fn pos arg = @@ -782,19 +1211,39 @@ (List.length component_names, make_sequence (fun pos id -> - Lprim(Psetfield(pos, false), - [Lprim(Pgetglobal target_name, []); - get_component id])) + Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal target_name, [], Location.none); + get_component id], + Location.none)) 0 component_names) - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure (pos_cc_list, _id_pos_list) -> + let components = + Lprim(Pmakeblock(0, Immutable, None), + List.map get_component component_names, + Location.none) + in + let blk = Ident.create "block" in + (List.length pos_cc_list, + Llet (Strict, Pgenval, blk, + apply_coercion Location.none Strict coercion components, + make_sequence + (fun pos _id -> + Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal target_name, [], Location.none); + Lprim(Pfield pos, [Lvar blk], Location.none)], + Location.none)) + 0 pos_cc_list)) + (* + (* ignore id_pos_list as the ids are already bound *) let id = Array.of_list component_names in (List.length pos_cc_list, make_sequence (fun dst (src, cc) -> Lprim(Psetfield(dst, false), [Lprim(Pgetglobal target_name, []); - apply_coercion cc (get_component id.(src))])) + apply_coercion Strict cc (get_component id.(src))])) 0 pos_cc_list) + *) | _ -> assert false (* Error report *) @@ -807,3 +1256,20 @@ "@[Cannot safely evaluate the definition@ \ of the recursively-defined module %a@]" Printtyp.ident id + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) + +let reset () = + primitive_declarations := []; + transl_store_subst := Ident.empty; + toploop_ident.Ident.flags <- 0; + aliased_idents := Ident.empty; + Env.reset_required_globals (); + Hashtbl.clear used_primitives diff -Nru ocaml-4.01.0/bytecomp/translmod.mli ocaml-4.05.0/bytecomp/translmod.mli --- ocaml-4.01.0/bytecomp/translmod.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/translmod.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Translation from typed abstract syntax to lambda terms, for the module language *) @@ -16,16 +19,24 @@ open Typedtree open Lambda -val transl_implementation: string -> structure * module_coercion -> lambda +val transl_implementation: + string -> structure * module_coercion -> Lambda.program val transl_store_phrases: string -> structure -> int * lambda val transl_store_implementation: - string -> structure * module_coercion -> int * lambda + string -> structure * module_coercion -> Lambda.program + +val transl_implementation_flambda: + string -> structure * module_coercion -> Lambda.program + val transl_toplevel_definition: structure -> lambda val transl_package: Ident.t option list -> Ident.t -> module_coercion -> lambda val transl_store_package: Ident.t option list -> Ident.t -> module_coercion -> int * lambda +val transl_package_flambda: + Ident.t option list -> module_coercion -> int * lambda + val toplevel_name: Ident.t -> string val nat_toplevel_name: Ident.t -> Ident.t * int @@ -37,3 +48,5 @@ exception Error of Location.t * error val report_error: Format.formatter -> error -> unit + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/translobj.ml ocaml-4.05.0/bytecomp/translobj.ml --- ocaml-4.01.0/bytecomp/translobj.ml 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/translobj.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,17 +1,19 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Misc -open Primitive open Asttypes open Longident open Lambda @@ -20,7 +22,7 @@ let oo_prim name = try - transl_path + transl_normal_path (fst (Env.lookup_value (Ldot (Lident "CamlinternalOO", name)) Env.empty)) with Not_found -> fatal_error ("Primitive " ^ name ^ " not found.") @@ -31,7 +33,7 @@ let share c = match c with - Const_block (n, l) when l <> [] -> + Const_block (_n, l) when l <> [] -> begin try Lvar (Hashtbl.find consts c) with Not_found -> @@ -56,9 +58,9 @@ (tag, [!method_cache; Lconst(Const_base(Const_int n))]) let rec is_path = function - Lvar _ | Lprim (Pgetglobal _, []) | Lconst _ -> true - | Lprim (Pfield _, [lam]) -> is_path lam - | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2]) -> + Lvar _ | Lprim (Pgetglobal _, [], _) | Lconst _ -> true + | Lprim (Pfield _, [lam], _) -> is_path lam + | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2], _) -> is_path lam1 && is_path lam2 | _ -> false @@ -86,35 +88,74 @@ (* Insert labels *) -let string s = Lconst (Const_base (Const_string s)) let int n = Lconst (Const_base (Const_int n)) let prim_makearray = - { prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true; - prim_native_name = ""; prim_native_float = false } + Primitive.simple ~name:"caml_make_vect" ~arity:2 ~alloc:true -let transl_label_init expr = +(* Also use it for required globals *) +let transl_label_init_general f = + let expr, size = f () in let expr = Hashtbl.fold - (fun c id expr -> Llet(Alias, id, Lconst c, expr)) + (fun c id expr -> Llet(Alias, Pgenval, id, Lconst c, expr)) consts expr in + (*let expr = + List.fold_right + (fun id expr -> Lsequence(Lprim(Pgetglobal id, [], Location.none), expr)) + (Env.get_required_globals ()) expr + in + Env.reset_required_globals ();*) reset_labels (); - expr + expr, size + +let transl_label_init_flambda f = + assert(Config.flambda); + let method_cache_id = Ident.create "method_cache" in + method_cache := Lvar method_cache_id; + (* Calling f (usualy Translmod.transl_struct) requires the + method_cache variable to be initialised to be able to generate + method accesses. *) + let expr, size = f () in + let expr = + if !method_count = 0 then expr + else + Llet (Strict, Pgenval, method_cache_id, + Lprim (Pccall prim_makearray, + [int !method_count; int 0], + Location.none), + expr) + in + transl_label_init_general (fun () -> expr, size) let transl_store_label_init glob size f arg = - method_cache := Lprim(Pfield size, [Lprim(Pgetglobal glob, [])]); + assert(not Config.flambda); + assert(!Clflags.native_code); + method_cache := Lprim(Pfield size, + [Lprim(Pgetglobal glob, [], Location.none)], + Location.none); let expr = f arg in let (size, expr) = if !method_count = 0 then (size, expr) else (size+1, Lsequence( - Lprim(Psetfield(size, false), - [Lprim(Pgetglobal glob, []); - Lprim (Pccall prim_makearray, [int !method_count; int 0])]), + Lprim(Psetfield(size, Pointer, Root_initialization), + [Lprim(Pgetglobal glob, [], Location.none); + Lprim (Pccall prim_makearray, + [int !method_count; int 0], + Location.none)], + Location.none), expr)) in - (size, transl_label_init expr) + let lam, size = transl_label_init_general (fun () -> (expr, size)) in + size, lam + +let transl_label_init f = + if !Clflags.native_code then + transl_label_init_flambda f + else + transl_label_init_general f (* Share classes *) @@ -142,9 +183,10 @@ let lambda = List.fold_left (fun lambda id -> - Llet(StrictOpt, id, - Lprim(Pmakeblock(0, Mutable), - [lambda_unit; lambda_unit; lambda_unit]), + Llet(StrictOpt, Pgenval, id, + Lprim(Pmakeblock(0, Mutable, None), + [lambda_unit; lambda_unit; lambda_unit], + Location.none), lambda)) lambda !classes in @@ -155,3 +197,14 @@ wrapping := false; top_env := Env.empty; raise exn + +let reset () = + Hashtbl.clear consts; + cache_required := false; + method_cache := lambda_unit; + method_count := 0; + method_table := []; + wrapping := false; + top_env := Env.empty; + classes := []; + method_ids := IdentSet.empty diff -Nru ocaml-4.01.0/bytecomp/translobj.mli ocaml-4.05.0/bytecomp/translobj.mli --- ocaml-4.01.0/bytecomp/translobj.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/translobj.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, 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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) open Lambda @@ -18,7 +21,7 @@ val meth: lambda -> string -> lambda * lambda list val reset_labels: unit -> unit -val transl_label_init: lambda -> lambda +val transl_label_init: (unit -> lambda * 'a) -> lambda * 'a val transl_store_label_init: Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda @@ -26,3 +29,5 @@ val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda val oo_add_class: Ident.t -> Env.t * bool + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/typeopt.ml ocaml-4.05.0/bytecomp/typeopt.ml --- ocaml-4.01.0/bytecomp/typeopt.ml 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/bytecomp/typeopt.ml 2017-07-13 08:56:44.000000000 +0000 @@ -1,14 +1,17 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Auxiliaries for type-based optimizations, e.g. array kinds *) @@ -17,78 +20,100 @@ open Typedtree open Lambda +let scrape_ty env ty = + let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in + match ty.desc with + | Tconstr (p, _, _) -> + begin match Env.find_type p env with + | {type_unboxed = {unboxed = true; _}; _} -> + begin match Typedecl.get_unboxed_type_representation env ty with + | None -> ty + | Some ty2 -> ty2 + end + | _ -> ty + | exception Not_found -> ty + end + | _ -> ty + let scrape env ty = - (Ctype.repr (Ctype.expand_head_opt env (Ctype.correct_levels ty))).desc + (scrape_ty env ty).desc -let has_base_type exp base_ty_path = - match scrape exp.exp_env exp.exp_type with +let is_function_type env ty = + match scrape env ty with + | Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs) + | _ -> None + +let is_base_type env ty base_ty_path = + match scrape env ty with | Tconstr(p, _, _) -> Path.same p base_ty_path | _ -> false -let maybe_pointer exp = - match scrape exp.exp_env exp.exp_type with - | Tconstr(p, args, abbrev) -> - not (Path.same p Predef.path_int) && - not (Path.same p Predef.path_char) && - begin try - match Env.find_type p exp.exp_env with - | {type_kind = Type_variant []} -> true (* type exn *) - | {type_kind = Type_variant cstrs} -> - List.exists (fun (name, args,_) -> args <> []) cstrs - | _ -> true - with Not_found -> true - (* This can happen due to e.g. missing -I options, - causing some .cmi files to be unavailable. - Maybe we should emit a warning. *) - end - | _ -> true - -let array_element_kind env ty = - match scrape env ty with +let maybe_pointer_type env ty = + if Ctype.maybe_pointer_type env ty then + Pointer + else + Immediate + +let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type + +type classification = + | Int + | Float + | Lazy + | Addr (* anything except a float or a lazy *) + | Any + +let classify env ty = + let ty = scrape_ty env ty in + if maybe_pointer_type env ty = Immediate then Int + else match ty.desc with | Tvar _ | Tunivar _ -> - Pgenarray - | Tconstr(p, args, abbrev) -> - if Path.same p Predef.path_int || Path.same p Predef.path_char then - Pintarray - else if Path.same p Predef.path_float then - Pfloatarray + Any + | Tconstr (p, _args, _abbrev) -> + if Path.same p Predef.path_float then Float + else if Path.same p Predef.path_lazy_t then Lazy else if Path.same p Predef.path_string + || Path.same p Predef.path_bytes || Path.same p Predef.path_array || Path.same p Predef.path_nativeint || Path.same p Predef.path_int32 - || Path.same p Predef.path_int64 then - Paddrarray + || Path.same p Predef.path_int64 then Addr else begin try - match Env.find_type p env with - {type_kind = Type_abstract} -> - Pgenarray - | {type_kind = Type_variant cstrs} - when List.for_all (fun (name, args,_) -> args = []) cstrs -> - Pintarray - | {type_kind = _} -> - Paddrarray + match (Env.find_type p env).type_kind with + | Type_abstract -> + Any + | Type_record _ | Type_variant _ | Type_open -> + Addr with Not_found -> (* This can happen due to e.g. missing -I options, causing some .cmi files to be unavailable. Maybe we should emit a warning. *) - Pgenarray + Any end - | _ -> - Paddrarray + | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ -> + Addr + | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ -> + assert false -let array_kind_gen ty env = +let array_type_kind env ty = match scrape env ty with | Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _) when Path.same p Predef.path_array -> - array_element_kind env elt_ty + begin match classify env elt_ty with + | Any -> Pgenarray + | Float -> Pfloatarray + | Addr | Lazy -> Paddrarray + | Int -> Pintarray + end + | _ -> (* This can happen with e.g. Obj.field *) Pgenarray -let array_kind exp = array_kind_gen exp.exp_type exp.exp_env +let array_kind exp = array_type_kind exp.exp_env exp.exp_type -let array_pattern_kind pat = array_kind_gen pat.pat_type pat.pat_env +let array_pattern_kind pat = array_type_kind pat.pat_env pat.pat_type let bigarray_decode_type env ty tbl dfl = match scrape env ty with @@ -116,11 +141,34 @@ ["c_layout", Pbigarray_c_layout; "fortran_layout", Pbigarray_fortran_layout] -let bigarray_kind_and_layout exp = - match scrape exp.exp_env exp.exp_type with - | Tconstr(p, [caml_type; elt_type; layout_type], abbrev) -> - (bigarray_decode_type exp.exp_env elt_type kind_table Pbigarray_unknown, - bigarray_decode_type exp.exp_env layout_type layout_table +let bigarray_type_kind_and_layout env typ = + match scrape env typ with + | Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) -> + (bigarray_decode_type env elt_type kind_table Pbigarray_unknown, + bigarray_decode_type env layout_type layout_table Pbigarray_unknown_layout) | _ -> (Pbigarray_unknown, Pbigarray_unknown_layout) + +let value_kind env ty = + match scrape env ty with + | Tconstr(p, _, _) when Path.same p Predef.path_int -> + Pintval + | Tconstr(p, _, _) when Path.same p Predef.path_char -> + Pintval + | Tconstr(p, _, _) when Path.same p Predef.path_float -> + Pfloatval + | Tconstr(p, _, _) when Path.same p Predef.path_int32 -> + Pboxedintval Pint32 + | Tconstr(p, _, _) when Path.same p Predef.path_int64 -> + Pboxedintval Pint64 + | Tconstr(p, _, _) when Path.same p Predef.path_nativeint -> + Pboxedintval Pnativeint + | _ -> + Pgenval + + +let lazy_val_requires_forward env ty = + match classify env ty with + | Any | Float | Lazy -> true + | Addr | Int -> false diff -Nru ocaml-4.01.0/bytecomp/typeopt.mli ocaml-4.05.0/bytecomp/typeopt.mli --- ocaml-4.01.0/bytecomp/typeopt.mli 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/bytecomp/typeopt.mli 2017-07-13 08:56:44.000000000 +0000 @@ -1,20 +1,35 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* Auxiliaries for type-based optimizations, e.g. array kinds *) -val has_base_type : Typedtree.expression -> Path.t -> bool -val maybe_pointer : Typedtree.expression -> bool +val is_function_type : + Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option +val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool + +val maybe_pointer_type : Env.t -> Types.type_expr + -> Lambda.immediate_or_pointer +val maybe_pointer : Typedtree.expression -> Lambda.immediate_or_pointer + +val array_type_kind : Env.t -> Types.type_expr -> Lambda.array_kind val array_kind : Typedtree.expression -> Lambda.array_kind val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind -val bigarray_kind_and_layout : - Typedtree.expression -> Lambda.bigarray_kind * Lambda.bigarray_layout +val bigarray_type_kind_and_layout : + Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout +val value_kind : Env.t -> Types.type_expr -> Lambda.value_kind + +val lazy_val_requires_forward : Env.t -> Types.type_expr -> bool + (** Whether a forward block is needed for a lazy thunk on a value, i.e. + if the value can be represented as a float/forward/lazy *) diff -Nru ocaml-4.01.0/byterun/afl.c ocaml-4.05.0/byterun/afl.c --- ocaml-4.01.0/byterun/afl.c 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/afl.c 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,162 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Stephen Dolan, University of Cambridge */ +/* */ +/* Copyright 2016 Stephen Dolan. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Runtime support for afl-fuzz */ + +/* Android's libc does not implement System V shared memory. */ +#if defined(_WIN32) || defined(__ANDROID__) + +#include "caml/mlvalues.h" + +CAMLprim value caml_setup_afl (value unit) +{ + return Val_unit; +} + +CAMLprim value caml_reset_afl_instrumentation(value unused) +{ + return Val_unit; +} + +#else + +#include +#include +#include +#include +#include +#include +#include + +#define CAML_INTERNALS +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/osdeps.h" + +static int afl_initialised = 0; + +/* afl uses abnormal termination (SIGABRT) to check whether + to count a testcase as "crashing" */ +extern int caml_abort_on_uncaught_exn; + +/* Values used by the instrumentation logic (see cmmgen.ml) */ +static unsigned char afl_area_initial[1 << 16]; +unsigned char* caml_afl_area_ptr = afl_area_initial; +uintnat caml_afl_prev_loc; + +/* File descriptors used to synchronise with afl-fuzz */ +#define FORKSRV_FD_READ 198 +#define FORKSRV_FD_WRITE 199 + +static void afl_write(uint32_t msg) +{ + if (write(FORKSRV_FD_WRITE, &msg, 4) != 4) + caml_fatal_error("writing to afl-fuzz"); +} + +static uint32_t afl_read() +{ + uint32_t msg; + if (read(FORKSRV_FD_READ, &msg, 4) != 4) + caml_fatal_error("reading from afl-fuzz"); + return msg; +} + +CAMLprim value caml_setup_afl(value unit) +{ + if (afl_initialised) return Val_unit; + afl_initialised = 1; + + char* shm_id_str = caml_secure_getenv("__AFL_SHM_ID"); + if (shm_id_str == NULL) { + /* Not running under afl-fuzz, continue as normal */ + return Val_unit; + } + + /* if afl-fuzz is attached, we want it to know about uncaught exceptions */ + caml_abort_on_uncaught_exn = 1; + + char* shm_id_end; + long int shm_id = strtol(shm_id_str, &shm_id_end, 10); + if (!(*shm_id_str != '\0' && *shm_id_end == '\0')) + caml_fatal_error("afl-fuzz: bad shm id"); + + caml_afl_area_ptr = shmat((int)shm_id, NULL, 0); + if (caml_afl_area_ptr == (void*)-1) + caml_fatal_error("afl-fuzz: could not attach shm area"); + + /* poke the bitmap so that afl-fuzz knows we exist, even if the + application has sparse instrumentation */ + caml_afl_area_ptr[0] = 1; + + /* synchronise with afl-fuzz */ + uint32_t startup_msg = 0; + if (write(FORKSRV_FD_WRITE, &startup_msg, 4) != 4) { + /* initial write failed, so assume we're not meant to fork. + afl-tmin uses this mode. */ + return Val_unit; + } + afl_read(); + + while (1) { + int child_pid = fork(); + if (child_pid < 0) caml_fatal_error("afl-fuzz: could not fork"); + else if (child_pid == 0) { + /* Run the program */ + close(FORKSRV_FD_READ); + close(FORKSRV_FD_WRITE); + return Val_unit; + } + + /* As long as the child keeps raising SIGSTOP, we re-use the same process */ + while (1) { + afl_write((uint32_t)child_pid); + + int status; + /* WUNTRACED means wait until termination or SIGSTOP */ + if (waitpid(child_pid, &status, WUNTRACED) < 0) + caml_fatal_error("afl-fuzz: waitpid failed"); + + afl_write((uint32_t)status); + + uint32_t was_killed = afl_read(); + if (WIFSTOPPED(status)) { + /* child stopped, waiting for another test case */ + if (was_killed) { + /* we saw the child stop, but since then afl-fuzz killed it. + we should wait for it before forking another child */ + if (waitpid(child_pid, &status, 0) < 0) + caml_fatal_error("afl-fuzz: waitpid failed"); + break; + } else { + kill(child_pid, SIGCONT); + } + } else { + /* child died */ + break; + } + } + } +} + +CAMLprim value caml_reset_afl_instrumentation(value full) +{ + if (full != Val_int(0)) { + memset(caml_afl_area_ptr, 0, sizeof(afl_area_initial)); + } + caml_afl_prev_loc = 0; + return Val_unit; +} + +#endif /* _WIN32 */ diff -Nru ocaml-4.01.0/byterun/alloc.c ocaml-4.05.0/byterun/alloc.c --- ocaml-4.01.0/byterun/alloc.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/alloc.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,19 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* 1. Allocation functions doing the same work as the macros in the case where [Setup_for_gc] and [Restore_after_gc] are no-ops. @@ -17,12 +21,12 @@ */ #include -#include "alloc.h" -#include "custom.h" -#include "major_gc.h" -#include "memory.h" -#include "mlvalues.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/stacks.h" #define Setup_for_gc #define Restore_after_gc @@ -39,11 +43,13 @@ }else if (wosize <= Max_young_wosize){ Alloc_small (result, wosize, tag); if (tag < No_scan_tag){ - for (i = 0; i < wosize; i++) Field (result, i) = 0; + for (i = 0; i < wosize; i++) Field (result, i) = Val_unit; } }else{ result = caml_alloc_shr (wosize, tag); - if (tag < No_scan_tag) memset (Bp_val (result), 0, Bsize_wsize (wosize)); + if (tag < No_scan_tag){ + for (i = 0; i < wosize; i++) Field (result, i) = Val_unit; + } result = caml_check_urgent_gc (result); } return result; @@ -60,11 +66,30 @@ return result; } +CAMLexport value caml_alloc_small_with_my_or_given_profinfo (mlsize_t wosize, + tag_t tag, uintnat profinfo) +{ + if (profinfo == 0) { + return caml_alloc_small(wosize, tag); + } + else { + value result; + + Assert (wosize > 0); + Assert (wosize <= Max_young_wosize); + Assert (tag < 256); + Alloc_small_with_profinfo (result, wosize, tag, profinfo); + return result; + } +} + +/* [n] is a number of words (fields) */ CAMLexport value caml_alloc_tuple(mlsize_t n) { return caml_alloc(n, 0); } +/* [len] is a number of bytes (chars) */ CAMLexport value caml_alloc_string (mlsize_t len) { value result; @@ -83,6 +108,9 @@ return result; } +/* [len] is a number of words. + [mem] and [max] are relative (without unit). +*/ CAMLexport value caml_alloc_final (mlsize_t len, final_fun fun, mlsize_t mem, mlsize_t max) { @@ -125,6 +153,26 @@ } } +/* [len] is a number of floats */ +CAMLprim value caml_alloc_float_array(mlsize_t len) +{ + mlsize_t wosize = len * Double_wosize; + value result; + /* For consistency with [caml_make_vect], which can't tell whether it should + create a float array or not when the size is zero, the tag is set to + zero when the size is zero. */ + if (wosize == 0) + return Atom(0); + else if (wosize <= Max_young_wosize){ + Alloc_small (result, wosize, Double_array_tag); + }else { + result = caml_alloc_shr (wosize, Double_array_tag); + result = caml_check_urgent_gc (result); + } + return result; +} + + CAMLexport value caml_copy_string_array(char const ** arr) { return caml_alloc_array(caml_copy_string, arr); @@ -143,17 +191,26 @@ /* For compiling let rec over values */ +/* [size] is a [value] representing number of words (fields) */ CAMLprim value caml_alloc_dummy(value size) { - mlsize_t wosize = Int_val(size); + mlsize_t wosize = Long_val(size); if (wosize == 0) return Atom(0); return caml_alloc (wosize, 0); } +/* [size] is a [value] representing number of words (fields) */ +CAMLprim value caml_alloc_dummy_function(value size,value arity) +{ + /* the arity argument is used by the js_of_ocaml runtime */ + return caml_alloc_dummy(size); +} + +/* [size] is a [value] representing number of floats. */ CAMLprim value caml_alloc_dummy_float (value size) { - mlsize_t wosize = Int_val(size) * Double_wosize; + mlsize_t wosize = Long_val(size) * Double_wosize; if (wosize == 0) return Atom(0); return caml_alloc (wosize, 0); diff -Nru ocaml-4.01.0/byterun/alloc.h ocaml-4.05.0/byterun/alloc.h --- ocaml-4.01.0/byterun/alloc.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/alloc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_ALLOC_H -#define CAML_ALLOC_H - - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "misc.h" -#include "mlvalues.h" - -#ifdef __cplusplus -extern "C" { -#endif - -CAMLextern value caml_alloc (mlsize_t, tag_t); -CAMLextern value caml_alloc_small (mlsize_t, tag_t); -CAMLextern value caml_alloc_tuple (mlsize_t); -CAMLextern value caml_alloc_string (mlsize_t); /* size in bytes */ -CAMLextern value caml_copy_string (char const *); -CAMLextern value caml_copy_string_array (char const **); -CAMLextern value caml_copy_double (double); -CAMLextern value caml_copy_int32 (int32); /* defined in [ints.c] */ -CAMLextern value caml_copy_int64 (int64); /* defined in [ints.c] */ -CAMLextern value caml_copy_nativeint (intnat); /* defined in [ints.c] */ -CAMLextern value caml_alloc_array (value (*funct) (char const *), - char const ** array); - -typedef void (*final_fun)(value); -CAMLextern value caml_alloc_final (mlsize_t, /*size in words*/ - final_fun, /*finalization function*/ - mlsize_t, /*resources consumed*/ - mlsize_t /*max resources*/); - -CAMLextern int caml_convert_flag_list (value, int *); - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_ALLOC_H */ diff -Nru ocaml-4.01.0/byterun/array.c ocaml-4.05.0/byterun/array.c --- ocaml-4.01.0/byterun/array.c 2012-12-06 15:39:30.000000000 +0000 +++ ocaml-4.05.0/byterun/array.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,25 +1,34 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ -/* Operations on arrays */ +#define CAML_INTERNALS +/* Operations on arrays */ #include -#include "alloc.h" -#include "fail.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/signals.h" +/* Why is caml/spacetime.h included conditionnally sometimes and not here ? */ +#include "caml/spacetime.h" +static const mlsize_t mlsize_t_max = -1; + +/* returns number of elements (either fields or floats) */ CAMLexport mlsize_t caml_array_length(value array) { if (Tag_val(array) == Double_array_tag) @@ -135,6 +144,30 @@ return caml_array_unsafe_set_addr(array, index, newval); } +/* [len] is a [value] representing number of floats */ +CAMLprim value caml_make_float_vect(value len) +{ + mlsize_t wosize = Long_val(len) * Double_wosize; + value result; + if (wosize == 0) + return Atom(0); + else if (wosize <= Max_young_wosize){ +#define Setup_for_gc +#define Restore_after_gc + Alloc_small (result, wosize, Double_array_tag); +#undef Setup_for_gc +#undef Restore_after_gc + }else if (wosize > Max_wosize) + caml_invalid_argument("Array.create_float"); + else { + result = caml_alloc_shr (wosize, Double_array_tag); + result = caml_check_urgent_gc (result); + } + return result; +} + +/* [len] is a [value] representing number of words or floats */ +/* Spacetime profiling assumes that this function is only called from OCaml. */ CAMLprim value caml_make_vect(value len, value init) { CAMLparam2 (len, init); @@ -158,12 +191,18 @@ } } else { if (size > Max_wosize) caml_invalid_argument("Array.make"); - if (size < Max_young_wosize) { - res = caml_alloc_small(size, 0); + if (size <= Max_young_wosize) { + uintnat profinfo; + Get_my_profinfo_with_cached_backtrace(profinfo, size); + res = caml_alloc_small_with_my_or_given_profinfo(size, 0, profinfo); for (i = 0; i < size; i++) Field(res, i) = init; } else if (Is_block(init) && Is_young(init)) { - caml_minor_collection(); + /* We don't want to create so many major-to-minor references, + so [init] is moved to the major heap by doing a minor GC. */ + CAML_INSTR_INT ("force_minor/make_vect@", 1); + caml_request_minor_gc (); + caml_gc_dispatch (); res = caml_alloc_shr(size, 0); for (i = 0; i < size; i++) Field(res, i) = init; res = caml_check_urgent_gc (res); @@ -193,9 +232,13 @@ || Tag_val(v) != Double_tag) { CAMLreturn (init); } else { - Assert(size < Max_young_wosize); wsize = size * Double_wosize; - res = caml_alloc_small(wsize, Double_array_tag); + if (wsize <= Max_young_wosize) { + res = caml_alloc_small(wsize, Double_array_tag); + } else { + res = caml_alloc_shr(wsize, Double_array_tag); + res = caml_check_urgent_gc(res); + } for (i = 0; i < size; i++) { Store_double_field(res, i, Double_val(Field(init, i))); } @@ -273,6 +316,7 @@ size = 0; isfloat = 0; for (i = 0; i < num_arrays; i++) { + if (mlsize_t_max - lengths[i] < size) caml_invalid_argument("Array.concat"); size += lengths[i]; if (Tag_val(arrays[i]) == Double_array_tag) isfloat = 1; } @@ -282,8 +326,8 @@ } else if (isfloat) { /* This is an array of floats. We can use memcpy directly. */ + if (size > Max_wosize/Double_wosize) caml_invalid_argument("Array.concat"); wsize = size * Double_wosize; - if (wsize > Max_wosize) caml_invalid_argument("Array.concat"); res = caml_alloc(wsize, Double_array_tag); for (i = 0, pos = 0; i < num_arrays; i++) { memcpy((double *)res + pos, @@ -297,7 +341,7 @@ /* Array of values, too big. */ caml_invalid_argument("Array.concat"); } - else if (size < Max_young_wosize) { + else if (size <= Max_young_wosize) { /* Array of values, small enough to fit in young generation. We can use memcpy directly. */ res = caml_alloc_small(size, 0); @@ -312,7 +356,6 @@ /* Array of values, must be allocated in old generation and filled using caml_initialize. */ res = caml_alloc_shr(size, 0); - pos = 0; for (i = 0, pos = 0; i < num_arrays; i++) { for (src = &Field(arrays[i], offsets[i]), count = lengths[i]; count > 0; @@ -363,8 +406,17 @@ lengths = static_lengths; } else { arrays = caml_stat_alloc(n * sizeof(value)); - offsets = caml_stat_alloc(n * sizeof(intnat)); - lengths = caml_stat_alloc(n * sizeof(value)); + offsets = malloc(n * sizeof(intnat)); + if (offsets == NULL) { + caml_stat_free(arrays); + caml_raise_out_of_memory(); + } + lengths = malloc(n * sizeof(value)); + if (lengths == NULL) { + caml_stat_free(offsets); + caml_stat_free(arrays); + caml_raise_out_of_memory(); + } } /* Build the parameters to caml_array_gather */ for (i = 0, l = al; l != Val_int(0); l = Field(l, 1), i++) { diff -Nru ocaml-4.01.0/byterun/backtrace.c ocaml-4.05.0/byterun/backtrace.c --- ocaml-4.01.0/byterun/backtrace.c 2013-08-02 13:54:22.000000000 +0000 +++ ocaml-4.05.0/byterun/backtrace.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,69 +1,46 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Stack backtrace for uncaught exceptions */ -#include #include #include #include -#include "config.h" -#ifdef HAS_UNISTD -#include -#endif - -#include "mlvalues.h" -#include "alloc.h" -#include "io.h" -#include "instruct.h" -#include "intext.h" -#include "exec.h" -#include "fix_code.h" -#include "memory.h" -#include "startup.h" -#include "stacks.h" -#include "sys.h" -#include "backtrace.h" - -CAMLexport int caml_backtrace_active = 0; -CAMLexport int caml_backtrace_pos = 0; -CAMLexport code_t * caml_backtrace_buffer = NULL; +#include "caml/alloc.h" +#include "caml/memory.h" +#include "caml/backtrace.h" +#include "caml/backtrace_prim.h" +#include "caml/fail.h" + +/* The table of debug information fragments */ +struct ext_table caml_debug_info; + +CAMLexport int32_t caml_backtrace_active = 0; +CAMLexport int32_t caml_backtrace_pos = 0; +CAMLexport backtrace_slot * caml_backtrace_buffer = NULL; CAMLexport value caml_backtrace_last_exn = Val_unit; -CAMLexport char * caml_cds_file = NULL; -#define BACKTRACE_BUFFER_SIZE 1024 -/* Location of fields in the Instruct.debug_event record */ -enum { EV_POS = 0, - EV_MODULE = 1, - EV_LOC = 2, - EV_KIND = 3 }; - -/* Location of fields in the Location.t record. */ -enum { LOC_START = 0, - LOC_END = 1, - LOC_GHOST = 2 }; - -/* Location of fields in the Lexing.position record. */ -enum { - POS_FNAME = 0, - POS_LNUM = 1, - POS_BOL = 2, - POS_CNUM = 3 -}; +void caml_init_backtrace(void) +{ + caml_register_global_root(&caml_backtrace_last_exn); +} /* Start or stop the backtrace machinery */ - CAMLprim value caml_record_backtrace(value vflag) { int flag = Int_val(vflag); @@ -71,339 +48,302 @@ if (flag != caml_backtrace_active) { caml_backtrace_active = flag; caml_backtrace_pos = 0; - if (flag) { - caml_register_global_root(&caml_backtrace_last_exn); - } else { - caml_remove_global_root(&caml_backtrace_last_exn); - } - /* Note: lazy initialization of caml_backtrace_buffer in - caml_stash_backtrace to simplify the interface with the thread - libraries */ + caml_backtrace_last_exn = Val_unit; + /* Note: We do lazy initialization of caml_backtrace_buffer when + needed in order to simplify the interface with the thread + library (thread creation doesn't need to allocate + caml_backtrace_buffer). So we don't have to allocate it here. + */ } return Val_unit; } /* Return the status of the backtrace machinery */ - CAMLprim value caml_backtrace_status(value vunit) { return Val_bool(caml_backtrace_active); } -/* Store the return addresses contained in the given stack fragment - into the backtrace array */ +/* Print location information -- same behavior as in Printexc -void caml_stash_backtrace(value exn, code_t pc, value * sp) + note that the test for compiler-inserted raises is slightly redundant: + (!li->loc_valid && li->loc_is_raise) + caml_debuginfo_location guarantees that when li->loc_valid is + 0, then li->loc_is_raise is always 1, so the latter test is + useless. We kept it to keep code identical to the byterun/ + implementation. */ +static void print_location(struct caml_loc_info * li, int index) { - code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size); - if (pc != NULL) pc = pc - 1; - if (exn != caml_backtrace_last_exn) { - caml_backtrace_pos = 0; - caml_backtrace_last_exn = exn; + char * info; + char * inlined; + + /* Ignore compiler-inserted raise */ + if (!li->loc_valid && li->loc_is_raise) return; + + if (li->loc_is_raise) { + /* Initial raise if index == 0, re-raise otherwise */ + if (index == 0) + info = "Raised at"; + else + info = "Re-raised at"; + } else { + if (index == 0) + info = "Raised by primitive operation at"; + else + info = "Called from"; } - if (caml_backtrace_buffer == NULL) { - caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); - if (caml_backtrace_buffer == NULL) return; - } - if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; - if (pc >= caml_start_code && pc < end_code){ - /* testing the code region is needed: PR#1554 */ - caml_backtrace_buffer[caml_backtrace_pos++] = pc; - } - for (/*nothing*/; sp < caml_trapsp; sp++) { - code_t p = (code_t) *sp; - if (p >= caml_start_code && p < end_code) { - if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break; - caml_backtrace_buffer[caml_backtrace_pos++] = p; - } + if (li->loc_is_inlined) { + inlined = " (inlined)"; + } else { + inlined = ""; + } + if (! li->loc_valid) { + fprintf(stderr, "%s unknown location%s\n", info, inlined); + } else { + fprintf (stderr, "%s file \"%s\"%s, line %d, characters %d-%d\n", + info, li->loc_filename, inlined, li->loc_lnum, + li->loc_startchr, li->loc_endchr); } } -/* returns the next frame pointer (or NULL if none is available); - updates *sp to point to the following one, and *trapsp to the next - trap frame, which we will skip when we reach it */ - -code_t caml_next_frame_pointer(value ** sp, value ** trapsp) -{ - code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size); - - while (*sp < caml_stack_high) { - code_t *p = (code_t*) (*sp)++; - if(&Trap_pc(*trapsp) == p) { - *trapsp = Trap_link(*trapsp); - continue; +/* Print a backtrace */ +CAMLexport void caml_print_exception_backtrace(void) +{ + int i; + struct caml_loc_info li; + debuginfo dbg; + + if (!caml_debug_info_available()) { + fprintf(stderr, "(Cannot print stack backtrace: " + "no debug information available)\n"); + return; + } + + for (i = 0; i < caml_backtrace_pos; i++) { + for (dbg = caml_debuginfo_extract(caml_backtrace_buffer[i]); + dbg != NULL; + dbg = caml_debuginfo_next(dbg)) + { + caml_debuginfo_location(dbg, &li); + print_location(&li, i); } - if (*p >= caml_start_code && *p < end_code) return *p; } - return NULL; } -/* Stores upto [max_frames_value] frames of the current call stack to - return to the user. This is used not in an exception-raising - context, but only when the user requests to save the trace - (hopefully less often). Instead of using a bounded buffer as - [caml_stash_backtrace], we first traverse the stack to compute the - right size, then allocate space for the trace. */ - -CAMLprim value caml_get_current_callstack(value max_frames_value) { - CAMLparam1(max_frames_value); - CAMLlocal1(trace); +/* Get a copy of the latest backtrace */ +CAMLprim value caml_get_exception_raw_backtrace(value unit) +{ + CAMLparam0(); + CAMLlocal1(res); - /* we use `intnat` here because, were it only `int`, passing `max_int` - from the OCaml side would overflow on 64bits machines. */ - intnat max_frames = Long_val(max_frames_value); - intnat trace_size; + /* Beware: the allocations below may cause finalizers to be run, and another + backtrace---possibly of a different length---to be stashed (for example + if the finalizer raises then catches an exception). We choose to ignore + any such finalizer backtraces and return the original one. */ + + if (!caml_backtrace_active || + caml_backtrace_buffer == NULL || + caml_backtrace_pos == 0) { + res = caml_alloc(0, 0); + } + else { + backtrace_slot saved_caml_backtrace_buffer[BACKTRACE_BUFFER_SIZE]; + int saved_caml_backtrace_pos; + intnat i; - /* first compute the size of the trace */ - { - value * sp = caml_extern_sp; - value * trapsp = caml_trapsp; + saved_caml_backtrace_pos = caml_backtrace_pos; - for (trace_size = 0; trace_size < max_frames; trace_size++) { - code_t p = caml_next_frame_pointer(&sp, &trapsp); - if (p == NULL) break; + if (saved_caml_backtrace_pos > BACKTRACE_BUFFER_SIZE) { + saved_caml_backtrace_pos = BACKTRACE_BUFFER_SIZE; } - } - trace = caml_alloc(trace_size, Abstract_tag); + memcpy(saved_caml_backtrace_buffer, caml_backtrace_buffer, + saved_caml_backtrace_pos * sizeof(backtrace_slot)); - /* then collect the trace */ - { - value * sp = caml_extern_sp; - value * trapsp = caml_trapsp; - uintnat trace_pos; - - for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { - code_t p = caml_next_frame_pointer(&sp, &trapsp); - Assert(p != NULL); - /* The assignment below is safe without [caml_initialize], even - if the trace is large and allocated on the old heap, because - we assign values that are outside the OCaml heap. */ - Assert(!(Is_block((value) p) && Is_in_heap((value) p))); - Field(trace, trace_pos) = (value) p; + res = caml_alloc(saved_caml_backtrace_pos, 0); + for (i = 0; i < saved_caml_backtrace_pos; i++) { + Field(res, i) = Val_backtrace_slot(saved_caml_backtrace_buffer[i]); } } - CAMLreturn(trace); + CAMLreturn(res); } -/* Read the debugging info contained in the current bytecode executable. - Return an OCaml array of OCaml lists of debug_event records in "events", - or Val_false on failure. */ - -#ifndef O_BINARY -#define O_BINARY 0 -#endif - -static char *read_debug_info_error = ""; -static value read_debug_info(void) +/* Copy back a backtrace and exception to the global state. + This function should be used only with Printexc.raw_backtrace */ +/* noalloc (caml value): so no CAMLparam* CAMLreturn* */ +CAMLprim value caml_restore_raw_backtrace(value exn, value backtrace) { - CAMLparam0(); - CAMLlocal1(events); - char * exec_name; - int fd; - struct exec_trailer trail; - struct channel * chan; - uint32 num_events, orig, i; - value evl, l; + intnat i; + mlsize_t bt_size; - if (caml_cds_file != NULL) { - exec_name = caml_cds_file; - } else { - exec_name = caml_exe_name; - } - fd = caml_attempt_open(&exec_name, &trail, 1); - if (fd < 0){ - read_debug_info_error = "executable program file not found"; - CAMLreturn(Val_false); - } - caml_read_section_descriptors(fd, &trail); - if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) { - close(fd); - read_debug_info_error = "program not linked with -g"; - CAMLreturn(Val_false); - } - chan = caml_open_descriptor_in(fd); - num_events = caml_getword(chan); - events = caml_alloc(num_events, 0); - for (i = 0; i < num_events; i++) { - orig = caml_getword(chan); - evl = caml_input_val(chan); - /* Relocate events in event list */ - for (l = evl; l != Val_int(0); l = Field(l, 1)) { - value ev = Field(l, 0); - Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig); - } - /* Record event list */ - Store_field(events, i, evl); - } - caml_close_channel(chan); - CAMLreturn(events); -} + caml_backtrace_last_exn = exn; -/* Search the event for the given PC. Return Val_false if not found. */ + bt_size = Wosize_val(backtrace); + if(bt_size > BACKTRACE_BUFFER_SIZE){ + bt_size = BACKTRACE_BUFFER_SIZE; + } -static value event_for_location(value events, code_t pc) -{ - mlsize_t i; - value pos, l, ev, ev_pos, best_ev; - - best_ev = 0; - Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size); - pos = Val_long((char *) pc - (char *) caml_start_code); - for (i = 0; i < Wosize_val(events); i++) { - for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) { - ev = Field(l, 0); - ev_pos = Field(ev, EV_POS); - if (ev_pos == pos) return ev; - /* ocamlc sometimes moves an event past a following PUSH instruction; - allow mismatch by 1 instruction. */ - if (ev_pos == pos + 8) best_ev = ev; - } + /* We don't allocate if the backtrace is empty (no -g or backtrace + not activated) */ + if(bt_size == 0){ + caml_backtrace_pos = 0; + return Val_unit; } - if (best_ev != 0) return best_ev; - return Val_false; -} -/* Extract location information for the given PC */ + /* Allocate if needed and copy the backtrace buffer */ + if (caml_backtrace_buffer == NULL && caml_alloc_backtrace_buffer() == -1){ + return Val_unit; + } -struct loc_info { - int loc_valid; - int loc_is_raise; - char * loc_filename; - int loc_lnum; - int loc_startchr; - int loc_endchr; -}; - -static void extract_location_info(value events, code_t pc, - /*out*/ struct loc_info * li) -{ - value ev, ev_start; - - ev = event_for_location(events, pc); - li->loc_is_raise = caml_is_instruction(*pc, RAISE); - if (ev == Val_false) { - li->loc_valid = 0; - return; + caml_backtrace_pos = bt_size; + for(i=0; i < caml_backtrace_pos; i++){ + caml_backtrace_buffer[i] = Backtrace_slot_val(Field(backtrace, i)); } - li->loc_valid = 1; - ev_start = Field (Field (ev, EV_LOC), LOC_START); - li->loc_filename = String_val (Field (ev_start, POS_FNAME)); - li->loc_lnum = Int_val (Field (ev_start, POS_LNUM)); - li->loc_startchr = - Int_val (Field (ev_start, POS_CNUM)) - - Int_val (Field (ev_start, POS_BOL)); - li->loc_endchr = - Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM)) - - Int_val (Field (ev_start, POS_BOL)); + + return Val_unit; } -/* Print location information -- same behavior as in Printexc */ +#define Val_debuginfo(bslot) (Val_long((uintnat)(bslot)>>1)) +#define Debuginfo_val(vslot) ((debuginfo)(Long_val(vslot) << 1)) -static void print_location(struct loc_info * li, int index) +/* Convert the raw backtrace to a data structure usable from OCaml */ +static value caml_convert_debuginfo(debuginfo dbg) { - char * info; + CAMLparam0(); + CAMLlocal2(p, fname); + struct caml_loc_info li; - /* Ignore compiler-inserted raise */ - if (!li->loc_valid && li->loc_is_raise) return; + caml_debuginfo_location(dbg, &li); - if (li->loc_is_raise) { - /* Initial raise if index == 0, re-raise otherwise */ - if (index == 0) - info = "Raised at"; - else - info = "Re-raised at"; + if (li.loc_valid) { + fname = caml_copy_string(li.loc_filename); + p = caml_alloc_small(6, 0); + Field(p, 0) = Val_bool(li.loc_is_raise); + Field(p, 1) = fname; + Field(p, 2) = Val_int(li.loc_lnum); + Field(p, 3) = Val_int(li.loc_startchr); + Field(p, 4) = Val_int(li.loc_endchr); + Field(p, 5) = Val_bool(li.loc_is_inlined); } else { - if (index == 0) - info = "Raised by primitive operation at"; - else - info = "Called from"; - } - if (! li->loc_valid) { - fprintf(stderr, "%s unknown location\n", info); - } else { - fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", - info, li->loc_filename, li->loc_lnum, - li->loc_startchr, li->loc_endchr); + p = caml_alloc_small(1, 1); + Field(p, 0) = Val_bool(li.loc_is_raise); } + + CAMLreturn(p); } -/* Print a backtrace */ +CAMLprim value caml_convert_raw_backtrace_slot(value slot) +{ + if (!caml_debug_info_available()) + caml_failwith("No debug information available"); -CAMLexport void caml_print_exception_backtrace(void) + return (caml_convert_debuginfo(Debuginfo_val(slot))); +} + +/* Convert the raw backtrace to a data structure usable from OCaml */ +CAMLprim value caml_convert_raw_backtrace(value bt) { - value events; - int i; - struct loc_info li; + CAMLparam1(bt); + CAMLlocal1(array); + intnat i, index; - events = read_debug_info(); - if (events == Val_false) { - fprintf(stderr, "(Cannot print stack backtrace: %s)\n", - read_debug_info_error); - return; + if (!caml_debug_info_available()) + caml_failwith("No debug information available"); + + for (i = 0, index = 0; i < Wosize_val(bt); ++i) + { + debuginfo dbg; + for (dbg = caml_debuginfo_extract(Backtrace_slot_val(Field(bt, i))); + dbg != NULL; + dbg = caml_debuginfo_next(dbg)) + index++; } - for (i = 0; i < caml_backtrace_pos; i++) { - extract_location_info(events, caml_backtrace_buffer[i], &li); - print_location(&li, i); + + array = caml_alloc(index, 0); + + for (i = 0, index = 0; i < Wosize_val(bt); ++i) + { + debuginfo dbg; + for (dbg = caml_debuginfo_extract(Backtrace_slot_val(Field(bt, i))); + dbg != NULL; + dbg = caml_debuginfo_next(dbg)) + { + Store_field(array, index, caml_convert_debuginfo(dbg)); + index++; + } } + + CAMLreturn(array); } -/* Convert the backtrace to a data structure usable from OCaml */ +CAMLprim value caml_raw_backtrace_length(value bt) +{ + return Val_int(Wosize_val(bt)); +} -CAMLprim value caml_convert_raw_backtrace(value backtrace) +CAMLprim value caml_raw_backtrace_slot(value bt, value index) { - CAMLparam1(backtrace); - CAMLlocal5(events, res, arr, p, fname); - int i; - struct loc_info li; + uintnat i; + debuginfo dbg; - events = read_debug_info(); - if (events == Val_false) { - res = Val_int(0); /* None */ - } else { - arr = caml_alloc(Wosize_val(backtrace), 0); - for (i = 0; i < Wosize_val(backtrace); i++) { - extract_location_info(events, (code_t)Field(backtrace, i), &li); - if (li.loc_valid) { - fname = caml_copy_string(li.loc_filename); - p = caml_alloc_small(5, 0); - Field(p, 0) = Val_bool(li.loc_is_raise); - Field(p, 1) = fname; - Field(p, 2) = Val_int(li.loc_lnum); - Field(p, 3) = Val_int(li.loc_startchr); - Field(p, 4) = Val_int(li.loc_endchr); - } else { - p = caml_alloc_small(1, 1); - Field(p, 0) = Val_bool(li.loc_is_raise); - } - caml_modify(&Field(arr, i), p); - } - res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ - } - CAMLreturn(res); + i = Long_val(index); + if (i >= Wosize_val(bt)) + caml_invalid_argument("Printexc.get_raw_backtrace_slot: " + "index out of bounds"); + dbg = caml_debuginfo_extract(Backtrace_slot_val(Field(bt, i))); + return Val_debuginfo(dbg); } -/* Get a copy of the latest backtrace */ - -CAMLprim value caml_get_exception_raw_backtrace(value unit) +CAMLprim value caml_raw_backtrace_next_slot(value slot) { - CAMLparam0(); - CAMLlocal1(res); - res = caml_alloc(caml_backtrace_pos, Abstract_tag); - if(caml_backtrace_buffer != NULL) - memcpy(&Field(res, 0), caml_backtrace_buffer, - caml_backtrace_pos * sizeof(code_t)); - CAMLreturn(res); + debuginfo dbg; + + CAMLparam1(slot); + CAMLlocal1(v); + + dbg = Debuginfo_val(slot); + dbg = caml_debuginfo_next(dbg); + + if (dbg == NULL) + v = Val_int(0); /* None */ + else + { + v = caml_alloc(1, 0); + Field(v, 0) = Val_debuginfo(dbg); + } + + CAMLreturn(v); } -/* the function below is deprecated: see asmrun/backtrace.c */ +/* the function below is deprecated: we previously returned directly + the OCaml-usable representation, instead of the raw backtrace as an + abstract type, but this has a large performance overhead if you + store a lot of backtraces and print only some of them. + It is not used by the Printexc library anymore, or anywhere else in + the compiler, but we have kept it in case some user still depends + on it as an external. */ CAMLprim value caml_get_exception_backtrace(value unit) { CAMLparam0(); - CAMLlocal2(raw, res); - raw = caml_get_exception_raw_backtrace(unit); - res = caml_convert_raw_backtrace(raw); + CAMLlocal3(arr, res, backtrace); + intnat i; + + if (!caml_debug_info_available()) { + res = Val_int(0); /* None */ + } else { + backtrace = caml_get_exception_raw_backtrace(Val_unit); + + arr = caml_alloc(Wosize_val(backtrace), 0); + for (i = 0; i < Wosize_val(backtrace); i++) { + backtrace_slot slot = Backtrace_slot_val(Field(backtrace, i)); + debuginfo dbg = caml_debuginfo_extract(slot); + Store_field(arr, i, caml_convert_debuginfo(dbg)); + } + + res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ + } + CAMLreturn(res); } diff -Nru ocaml-4.01.0/byterun/backtrace.h ocaml-4.05.0/byterun/backtrace.h --- ocaml-4.01.0/byterun/backtrace.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/backtrace.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_BACKTRACE_H -#define CAML_BACKTRACE_H - -#include "mlvalues.h" - -CAMLextern int caml_backtrace_active; -CAMLextern int caml_backtrace_pos; -CAMLextern code_t * caml_backtrace_buffer; -CAMLextern value caml_backtrace_last_exn; -CAMLextern char * caml_cds_file; - -CAMLprim value caml_record_backtrace(value vflag); -#ifndef NATIVE_CODE -extern void caml_stash_backtrace(value exn, code_t pc, value * sp); -#endif -CAMLextern void caml_print_exception_backtrace(void); - -#endif /* CAML_BACKTRACE_H */ diff -Nru ocaml-4.01.0/byterun/backtrace_prim.c ocaml-4.05.0/byterun/backtrace_prim.c --- ocaml-4.01.0/byterun/backtrace_prim.c 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/backtrace_prim.c 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,456 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +/* Stack backtrace for uncaught exceptions */ + +#include +#include +#include +#include + +#include "caml/config.h" +#ifdef HAS_UNISTD +#include +#endif + +#include "caml/mlvalues.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/io.h" +#include "caml/instruct.h" +#include "caml/intext.h" +#include "caml/exec.h" +#include "caml/fix_code.h" +#include "caml/memory.h" +#include "caml/startup.h" +#include "caml/stacks.h" +#include "caml/sys.h" +#include "caml/backtrace.h" +#include "caml/fail.h" +#include "caml/backtrace_prim.h" + +/* The table of debug information fragments */ +struct ext_table caml_debug_info; + +CAMLexport char * caml_cds_file = NULL; + +/* Location of fields in the Instruct.debug_event record */ +enum { + EV_POS = 0, + EV_MODULE = 1, + EV_LOC = 2, + EV_KIND = 3 +}; + +/* Location of fields in the Location.t record. */ +enum { + LOC_START = 0, + LOC_END = 1, + LOC_GHOST = 2 +}; + +/* Location of fields in the Lexing.position record. */ +enum { + POS_FNAME = 0, + POS_LNUM = 1, + POS_BOL = 2, + POS_CNUM = 3 +}; + +/* Runtime representation of the debug information, optimized + for quick lookup */ +struct ev_info { + code_t ev_pc; + char *ev_filename; + int ev_lnum; + int ev_startchr; + int ev_endchr; +}; + +struct debug_info { + code_t start; + code_t end; + mlsize_t num_events; + struct ev_info *events; + int already_read; +}; + +static struct debug_info *find_debug_info(code_t pc) +{ + int i; + for (i = 0; i < caml_debug_info.size; i++) { + struct debug_info *di = caml_debug_info.contents[i]; + if (pc >= di->start && pc < di->end) + return di; + } + return NULL; +} + +static int cmp_ev_info(const void *a, const void *b) +{ + code_t pc_a = ((const struct ev_info*)a)->ev_pc; + code_t pc_b = ((const struct ev_info*)b)->ev_pc; + if (pc_a > pc_b) return 1; + if (pc_a < pc_b) return -1; + return 0; +} + +struct ev_info *process_debug_events(code_t code_start, value events_heap, + mlsize_t *num_events) +{ + CAMLparam1(events_heap); + CAMLlocal3(l, ev, ev_start); + mlsize_t i, j; + struct ev_info *events; + + /* Compute the size of the required event buffer. */ + *num_events = 0; + for (i = 0; i < caml_array_length(events_heap); i++) + for (l = Field(events_heap, i); l != Val_int(0); l = Field(l, 1)) + (*num_events)++; + + if (*num_events == 0) + CAMLreturnT(struct ev_info *, NULL); + + events = malloc(*num_events * sizeof(struct ev_info)); + if(events == NULL) + caml_fatal_error ("caml_add_debug_info: out of memory"); + + j = 0; + for (i = 0; i < caml_array_length(events_heap); i++) { + for (l = Field(events_heap, i); l != Val_int(0); l = Field(l, 1)) { + ev = Field(l, 0); + + events[j].ev_pc = (code_t)((char*)code_start + + Long_val(Field(ev, EV_POS))); + + ev_start = Field(Field(ev, EV_LOC), LOC_START); + + { + uintnat fnsz = caml_string_length(Field(ev_start, POS_FNAME)) + 1; + events[j].ev_filename = (char*)malloc(fnsz); + if(events[j].ev_filename == NULL) + caml_fatal_error ("caml_add_debug_info: out of memory"); + memcpy(events[j].ev_filename, + String_val(Field(ev_start, POS_FNAME)), + fnsz); + } + + events[j].ev_lnum = Int_val(Field(ev_start, POS_LNUM)); + events[j].ev_startchr = + Int_val(Field(ev_start, POS_CNUM)) + - Int_val(Field(ev_start, POS_BOL)); + events[j].ev_endchr = + Int_val(Field(Field(Field(ev, EV_LOC), LOC_END), POS_CNUM)) + - Int_val(Field(ev_start, POS_BOL)); + + j++; + } + } + + Assert(j == *num_events); + + qsort(events, *num_events, sizeof(struct ev_info), cmp_ev_info); + + CAMLreturnT(struct ev_info *, events); +} + +/* Processes a (Instruct.debug_event list array) into a form suitable + for quick lookup and registers it for the (code_start,code_size) pc range. */ +CAMLprim value caml_add_debug_info(code_t code_start, value code_size, + value events_heap) +{ + CAMLparam1(events_heap); + struct debug_info *debug_info; + + /* build the OCaml-side debug_info value */ + debug_info = caml_stat_alloc(sizeof(struct debug_info)); + + debug_info->start = code_start; + debug_info->end = (code_t)((char*) code_start + Long_val(code_size)); + if (events_heap == Val_unit) { + debug_info->events = NULL; + debug_info->num_events = 0; + debug_info->already_read = 0; + } else { + debug_info->events = + process_debug_events(code_start, events_heap, &debug_info->num_events); + debug_info->already_read = 1; + } + + caml_ext_table_add(&caml_debug_info, debug_info); + + CAMLreturn(Val_unit); +} + +CAMLprim value caml_remove_debug_info(code_t start) +{ + CAMLparam0(); + CAMLlocal2(dis, prev); + + int i; + for (i = 0; i < caml_debug_info.size; i++) { + struct debug_info *di = caml_debug_info.contents[i]; + if (di->start == start) { + /* note that caml_ext_table_remove calls caml_stat_free on the + removed resource, bracketing the caml_stat_alloc call in + caml_add_debug_info. */ + caml_ext_table_remove(&caml_debug_info, di); + break; + } + } + + CAMLreturn(Val_unit); +} + +int caml_alloc_backtrace_buffer(void){ + Assert(caml_backtrace_pos == 0); + caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); + if (caml_backtrace_buffer == NULL) return -1; + return 0; +} + +/* Store the return addresses contained in the given stack fragment + into the backtrace array */ + +void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise) +{ + if (pc != NULL) pc = pc - 1; + if (exn != caml_backtrace_last_exn || !reraise) { + caml_backtrace_pos = 0; + caml_backtrace_last_exn = exn; + } + + if (caml_backtrace_buffer == NULL && caml_alloc_backtrace_buffer() == -1) + return; + + if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; + /* testing the code region is needed: PR#1554 */ + if (find_debug_info(pc) != NULL) + caml_backtrace_buffer[caml_backtrace_pos++] = pc; + + /* Traverse the stack and put all values pointing into bytecode + into the backtrace buffer. */ + for (/*nothing*/; sp < caml_trapsp; sp++) { + code_t p = (code_t) *sp; + if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break; + if (find_debug_info(p) != NULL) + caml_backtrace_buffer[caml_backtrace_pos++] = p; + } +} + +/* returns the next frame pointer (or NULL if none is available); + updates *sp to point to the following one, and *trsp to the next + trap frame, which we will skip when we reach it */ + +code_t caml_next_frame_pointer(value ** sp, value ** trsp) +{ + while (*sp < caml_stack_high) { + code_t *p = (code_t*) (*sp)++; + if(&Trap_pc(*trsp) == p) { + *trsp = Trap_link(*trsp); + continue; + } + + if (find_debug_info(*p) != NULL) + return *p; + } + return NULL; +} + +/* Stores upto [max_frames_value] frames of the current call stack to + return to the user. This is used not in an exception-raising + context, but only when the user requests to save the trace + (hopefully less often). Instead of using a bounded buffer as + [caml_stash_backtrace], we first traverse the stack to compute the + right size, then allocate space for the trace. */ + +CAMLprim value caml_get_current_callstack(value max_frames_value) +{ + CAMLparam1(max_frames_value); + CAMLlocal1(trace); + + /* we use `intnat` here because, were it only `int`, passing `max_int` + from the OCaml side would overflow on 64bits machines. */ + intnat max_frames = Long_val(max_frames_value); + intnat trace_size; + + /* first compute the size of the trace */ + { + value * sp = caml_extern_sp; + value * trsp = caml_trapsp; + + for (trace_size = 0; trace_size < max_frames; trace_size++) { + code_t p = caml_next_frame_pointer(&sp, &trsp); + if (p == NULL) break; + } + } + + trace = caml_alloc(trace_size, 0); + + /* then collect the trace */ + { + value * sp = caml_extern_sp; + value * trsp = caml_trapsp; + uintnat trace_pos; + + for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { + code_t p = caml_next_frame_pointer(&sp, &trsp); + Assert(p != NULL); + Field(trace, trace_pos) = Val_backtrace_slot(p); + } + } + + CAMLreturn(trace); +} + +/* Read the debugging info contained in the current bytecode executable. */ + +#ifndef O_BINARY +#define O_BINARY 0 +#endif + +void read_main_debug_info(struct debug_info *di) +{ + CAMLparam0(); + CAMLlocal3(events, evl, l); + char *exec_name; + int fd, num_events, orig, i; + struct channel *chan; + struct exec_trailer trail; + + Assert(di->already_read == 0); + di->already_read = 1; + + if (caml_cds_file != NULL) { + exec_name = caml_cds_file; + } else { + exec_name = caml_exe_name; + } + + fd = caml_attempt_open(&exec_name, &trail, 1); + if (fd < 0){ + caml_fatal_error ("executable program file not found"); + CAMLreturn0; + } + + caml_read_section_descriptors(fd, &trail); + if (caml_seek_optional_section(fd, &trail, "DBUG") != -1) { + chan = caml_open_descriptor_in(fd); + + num_events = caml_getword(chan); + events = caml_alloc(num_events, 0); + + for (i = 0; i < num_events; i++) { + orig = caml_getword(chan); + evl = caml_input_val(chan); + caml_input_val(chan); /* Skip the list of absolute directory names */ + /* Relocate events in event list */ + for (l = evl; l != Val_int(0); l = Field(l, 1)) { + value ev = Field(l, 0); + Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig); + } + /* Record event list */ + Store_field(events, i, evl); + } + + caml_close_channel(chan); + + di->events = process_debug_events(caml_start_code, events, &di->num_events); + } + + CAMLreturn0; +} + +CAMLexport void caml_init_debug_info(void) +{ + caml_ext_table_init(&caml_debug_info, 1); + caml_add_debug_info(caml_start_code, Val_long(caml_code_size), Val_unit); +} + +int caml_debug_info_available(void) +{ + return (caml_debug_info.size != 0); +} + +/* Search the event index for the given PC. Return -1 if not found. */ + +static struct ev_info *event_for_location(code_t pc) +{ + uintnat low, high; + struct debug_info *di = find_debug_info(pc); + + if (di == NULL) + return NULL; + + if (!di->already_read) + read_main_debug_info(di); + + if (di->num_events == 0) + return NULL; + + low = 0; + high = di->num_events; + while (low+1 < high) { + uintnat m = (low+high)/2; + if(pc < di->events[m].ev_pc) high = m; + else low = m; + } + if (di->events[low].ev_pc == pc) + return &di->events[low]; + /* ocamlc sometimes moves an event past a following PUSH instruction; + allow mismatch by 1 instruction. */ + if (di->events[low].ev_pc == pc + 1) + return &di->events[low]; + if (low+1 < di->num_events && di->events[low+1].ev_pc == pc + 1) + return &di->events[low+1]; + + return NULL; +} + +/* Extract location information for the given PC */ + +void caml_debuginfo_location(debuginfo dbg, + /*out*/ struct caml_loc_info * li) +{ + code_t pc = dbg; + struct ev_info *event = event_for_location(pc); + li->loc_is_raise = + caml_is_instruction(*pc, RAISE) || + caml_is_instruction(*pc, RERAISE); + if (event == NULL) { + li->loc_valid = 0; + return; + } + li->loc_valid = 1; + li->loc_is_inlined = 0; + li->loc_filename = event->ev_filename; + li->loc_lnum = event->ev_lnum; + li->loc_startchr = event->ev_startchr; + li->loc_endchr = event->ev_endchr; +} + +debuginfo caml_debuginfo_extract(backtrace_slot slot) +{ + return (debuginfo)slot; +} + +debuginfo caml_debuginfo_next(debuginfo dbg) +{ + /* No inlining in bytecode */ + return NULL; +} diff -Nru ocaml-4.01.0/byterun/callback.c ocaml-4.05.0/byterun/callback.c --- ocaml-4.01.0/byterun/callback.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/callback.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,32 +1,36 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Callbacks from C to OCaml */ #include -#include "callback.h" -#include "fail.h" -#include "memory.h" -#include "mlvalues.h" +#include "caml/callback.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" #ifndef NATIVE_CODE /* Bytecode callbacks */ -#include "interp.h" -#include "instruct.h" -#include "fix_code.h" -#include "stacks.h" +#include "caml/interp.h" +#include "caml/instruct.h" +#include "caml/fix_code.h" +#include "caml/stacks.h" CAMLexport int caml_callback_depth = 0; @@ -216,6 +220,7 @@ { struct named_value * nv; char * name = String_val(vname); + size_t namelen = strlen(name); unsigned int h = hash_value_name(name); for (nv = named_value_table[h]; nv != NULL; nv = nv->next) { @@ -225,8 +230,8 @@ } } nv = (struct named_value *) - caml_stat_alloc(sizeof(struct named_value) + strlen(name)); - strcpy(nv->name, name); + caml_stat_alloc(sizeof(struct named_value) + namelen); + memcpy(nv->name, name, namelen + 1); nv->val = val; nv->next = named_value_table[h]; named_value_table[h] = nv; @@ -244,3 +249,14 @@ } return NULL; } + +CAMLexport void caml_iterate_named_values(caml_named_action f) +{ + int i; + for(i = 0; i < Named_value_size; i++){ + struct named_value * nv; + for (nv = named_value_table[i]; nv != NULL; nv = nv->next) { + f( &nv->val, nv->name ); + } + } +} diff -Nru ocaml-4.01.0/byterun/callback.h ocaml-4.05.0/byterun/callback.h --- ocaml-4.01.0/byterun/callback.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/callback.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* Callbacks from C to OCaml */ - -#ifndef CAML_CALLBACK_H -#define CAML_CALLBACK_H - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "mlvalues.h" - -#ifdef __cplusplus -extern "C" { -#endif - -CAMLextern value caml_callback (value closure, value arg); -CAMLextern value caml_callback2 (value closure, value arg1, value arg2); -CAMLextern value caml_callback3 (value closure, value arg1, value arg2, - value arg3); -CAMLextern value caml_callbackN (value closure, int narg, value args[]); - -CAMLextern value caml_callback_exn (value closure, value arg); -CAMLextern value caml_callback2_exn (value closure, value arg1, value arg2); -CAMLextern value caml_callback3_exn (value closure, - value arg1, value arg2, value arg3); -CAMLextern value caml_callbackN_exn (value closure, int narg, value args[]); - -#define Make_exception_result(v) ((v) | 2) -#define Is_exception_result(v) (((v) & 3) == 2) -#define Extract_exception(v) ((v) & ~3) - -CAMLextern value * caml_named_value (char const * name); - -CAMLextern void caml_main (char ** argv); -CAMLextern void caml_startup (char ** argv); - -CAMLextern int caml_callback_depth; - -#ifdef __cplusplus -} -#endif - -#endif diff -Nru ocaml-4.01.0/byterun/caml/address_class.h ocaml-4.05.0/byterun/caml/address_class.h --- ocaml-4.01.0/byterun/caml/address_class.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/address_class.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,85 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Classification of addresses for GC and runtime purposes. */ + +#ifndef CAML_ADDRESS_CLASS_H +#define CAML_ADDRESS_CLASS_H + +#include "config.h" +#include "misc.h" +#include "mlvalues.h" + +/* Use the following macros to test an address for the different classes + it might belong to. */ + +#define Is_young(val) \ + (Assert (Is_block (val)), \ + (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start) + +#define Is_in_heap(a) (Classify_addr(a) & In_heap) + +#define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young)) + +#define Is_in_value_area(a) \ + (Classify_addr(a) & (In_heap | In_young | In_static_data)) + +#define Is_in_code_area(pc) \ + ( ((char *)(pc) >= caml_code_area_start && \ + (char *)(pc) <= caml_code_area_end) \ + || (Classify_addr(pc) & In_code_area) ) + +#define Is_in_static_data(a) (Classify_addr(a) & In_static_data) + +/***********************************************************************/ +/* The rest of this file is private and may change without notice. */ + +extern value *caml_young_start, *caml_young_end; +extern char * caml_code_area_start, * caml_code_area_end; + +#define Not_in_heap 0 +#define In_heap 1 +#define In_young 2 +#define In_static_data 4 +#define In_code_area 8 + +#ifdef ARCH_SIXTYFOUR + +/* 64 bits: Represent page table as a sparse hash table */ +int caml_page_table_lookup(void * addr); +#define Classify_addr(a) (caml_page_table_lookup((void *)(a))) + +#else + +/* 32 bits: Represent page table as a 2-level array */ +#define Pagetable2_log 11 +#define Pagetable2_size (1 << Pagetable2_log) +#define Pagetable1_log (Page_log + Pagetable2_log) +#define Pagetable1_size (1 << (32 - Pagetable1_log)) +CAMLextern unsigned char * caml_page_table[Pagetable1_size]; + +#define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log) +#define Pagetable_index2(a) \ + ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1)) +#define Classify_addr(a) \ + caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)] + +#endif + +int caml_page_table_add(int kind, void * start, void * end); +int caml_page_table_remove(int kind, void * start, void * end); +int caml_page_table_initialize(mlsize_t bytesize); + +#endif /* CAML_ADDRESS_CLASS_H */ diff -Nru ocaml-4.01.0/byterun/caml/alloc.h ocaml-4.05.0/byterun/caml/alloc.h --- ocaml-4.01.0/byterun/caml/alloc.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/alloc.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,77 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_ALLOC_H +#define CAML_ALLOC_H + + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "misc.h" +#include "mlvalues.h" + +#ifdef __cplusplus +extern "C" { +#endif + +CAMLextern value caml_alloc (mlsize_t wosize, tag_t); +CAMLextern value caml_alloc_small (mlsize_t wosize, tag_t); +CAMLextern value caml_alloc_tuple (mlsize_t wosize); +CAMLextern value caml_alloc_float_array (mlsize_t len); +CAMLextern value caml_alloc_string (mlsize_t len); /* len in bytes (chars) */ +CAMLextern value caml_copy_string (char const *); +CAMLextern value caml_copy_string_array (char const **); +CAMLextern value caml_copy_double (double); +CAMLextern value caml_copy_int32 (int32_t); /* defined in [ints.c] */ +CAMLextern value caml_copy_int64 (int64_t); /* defined in [ints.c] */ +CAMLextern value caml_copy_nativeint (intnat); /* defined in [ints.c] */ +CAMLextern value caml_alloc_array (value (*funct) (char const *), + char const ** array); +CAMLextern value caml_alloc_sprintf(const char * format, ...); + +CAMLextern value caml_alloc_with_profinfo (mlsize_t, tag_t, intnat); +CAMLextern value caml_alloc_small_with_my_or_given_profinfo ( + mlsize_t, tag_t, uintnat); +CAMLextern value caml_alloc_small_with_profinfo (mlsize_t, tag_t, intnat); + +typedef void (*final_fun)(value); +CAMLextern value caml_alloc_final (mlsize_t wosize, + final_fun, /*finalization function*/ + mlsize_t, /*resources consumed*/ + mlsize_t /*max resources*/); + +CAMLextern int caml_convert_flag_list (value, int *); + +/* Convenience functions to deal with unboxable types. */ +static inline value caml_alloc_unboxed (value arg) { return arg; } +static inline value caml_alloc_boxed (value arg) { + value result = caml_alloc_small (1, 0); + Field (result, 0) = arg; + return result; +} +static inline value caml_field_unboxed (value arg) { return arg; } +static inline value caml_field_boxed (value arg) { return Field (arg, 0); } + +/* Unannotated unboxable types are boxed by default. (may change in the + future) */ +#define caml_alloc_unboxable caml_alloc_boxed +#define caml_field_unboxable caml_field_boxed + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_ALLOC_H */ diff -Nru ocaml-4.01.0/byterun/caml/backtrace.h ocaml-4.05.0/byterun/caml/backtrace.h --- ocaml-4.01.0/byterun/caml/backtrace.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/backtrace.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,136 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_BACKTRACE_H +#define CAML_BACKTRACE_H + +#ifdef CAML_INTERNALS + +#include "mlvalues.h" +#include "exec.h" + +/* Runtime support for backtrace generation. + * + * It has two kind of users: + * - high-level API to capture and decode backtraces; + * - low-level runtime routines, to introspect machine state and determine + * whether a backtrace should be generated when using "raise". + * + * Backtrace generation is split in multiple steps. + * The lowest-level one, done by [backtrace_prim.c] just fills the + * [caml_backtrace_buffer] variable each time a frame is unwinded. + * At that point, we don't know whether the backtrace will be useful or not so + * this code should be as fast as possible. + * + * If the backtrace happens to be useful, later passes will read + * [caml_backtrace_buffer] and turn it into a [raw_backtrace] and then a + * [backtrace]. + * This is done in [backtrace.c] and [stdlib/printexc.ml]. + * + * Content of buffers + * ------------------ + * + * [caml_backtrace_buffer] (really cheap) + * Backend and process image dependent, abstracted by C-type backtrace_slot. + * [raw_backtrace] (cheap) + * OCaml values of abstract type [Printexc.raw_backtrace_slot], + * still backend and process image dependent (unsafe to marshal). + * [backtrace] (more expensive) + * OCaml values of algebraic data-type [Printexc.backtrace_slot] + */ + +/* Non zero iff backtraces are recorded. + * One should use to change this variable [caml_record_backtrace]. + */ +CAMLextern int caml_backtrace_active; + +/* The [backtrace_slot] type represents values stored in the + * [caml_backtrace_buffer]. In bytecode, it is the same as a + * [code_t], in native code it as a [frame_descr *]. The difference + * doesn't matter for code outside [backtrace_prim.c], so it is just + * exposed as a [backtrace_slot]. + */ +typedef void * backtrace_slot; + +/* The [caml_backtrace_buffer] and [caml_backtrace_last_exn] + * variables are valid only if [caml_backtrace_active != 0]. + * + * They are part of the state specific to each thread, and threading libraries + * are responsible for copying them on context switch. + * See [otherlibs/systhreads/st_stubs.c] and [otherlibs/threads/scheduler.c]. + */ + +/* [caml_backtrace_buffer] is filled by runtime when unwinding stack. + * It is an array ranging from [0] to [caml_backtrace_pos - 1]. + * [caml_backtrace_pos] is always zero if [!caml_backtrace_active]. + * + * Its maximum size is determined by [BACKTRACE_BUFFER_SIZE] from + * [backtrace_prim.h], but this shouldn't affect users. + */ +CAMLextern backtrace_slot * caml_backtrace_buffer; +CAMLextern int caml_backtrace_pos; + +/* [caml_backtrace_last_exn] stores the last exception value that was raised, + * iff [caml_backtrace_active != 0]. + * It is tested for equality to determine whether a raise is a re-raise of the + * same exception. + * + * FIXME: this shouldn't matter anymore. Since OCaml 4.02, non-parameterized + * exceptions are constant, so physical equality is no longer appropriate. + * raise and re-raise are distinguished by: + * - passing reraise = 1 to [caml_stash_backtrace] (see below) in the bytecode + * interpreter; + * - directly resetting [caml_backtrace_pos] to 0 in native runtimes for raise. + */ +CAMLextern value caml_backtrace_last_exn; + +/* [caml_record_backtrace] toggle backtrace recording on and off. + * This function can be called at runtime by user-code, or during + * initialization if backtraces were requested. + * + * It might be called before GC initialization, so it shouldn't do OCaml + * allocation. + */ +CAMLprim value caml_record_backtrace(value vflag); + + +#ifndef NATIVE_CODE + +/* Path to the file containing debug information, if any, or NULL. */ +CAMLextern char * caml_cds_file; + +/* Primitive called _only_ by runtime to record unwinded frames to + * backtrace. A similar primitive exists for native code, but with a + * different prototype. */ +extern void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise); + +#endif + + +/* Default (C-level) printer for backtraces. It is called if an + * exception causes a termination of the program or of a thread. + * + * [Printexc] provide a higher-level printer mimicking its output but making + * use of registered exception printers, and is used when possible in place of + * this function after [Printexc] initialization. + */ +CAMLextern void caml_print_exception_backtrace(void); + +void caml_init_backtrace(void); +CAMLexport void caml_init_debug_info(void); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_BACKTRACE_H */ diff -Nru ocaml-4.01.0/byterun/caml/backtrace_prim.h ocaml-4.05.0/byterun/caml/backtrace_prim.h --- ocaml-4.01.0/byterun/caml/backtrace_prim.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/backtrace_prim.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,91 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_BACKTRACE_PRIM_H +#define CAML_BACKTRACE_PRIM_H + +#ifdef CAML_INTERNALS + +#include "backtrace.h" + +/* Backtrace generation is split in [backtrace.c] and [backtrace_prim.c]. + * + * [backtrace_prim.c] contains all backend-specific code, and has two different + * implementations in [byterun/backtrace_prim.c] and [asmrun/backtrace_prim.c]. + * + * [backtrace.c] has a unique implementation, and expose a uniform + * higher level API above [backtrace_prim.c]. + */ + +/* Extract location information for the given raw_backtrace_slot */ + +struct caml_loc_info { + int loc_valid; + int loc_is_raise; + char * loc_filename; + int loc_lnum; + int loc_startchr; + int loc_endchr; + int loc_is_inlined; +}; + +/* When compiling with -g, backtrace slots have debug info associated. + * When a call is inlined in native mode, debuginfos form a linked list. + */ +typedef void * debuginfo; + +/* Check availability of debug information before extracting a trace. + * Relevant for bytecode, always true for native code. */ +int caml_debug_info_available(void); + +/* Return debuginfo associated to a slot or NULL. */ +debuginfo caml_debuginfo_extract(backtrace_slot slot); + +/* In case of an inlined call return next debuginfo or NULL otherwise. */ +debuginfo caml_debuginfo_next(debuginfo dbg); + +/* Extract locations from backtrace_slot */ +void caml_debuginfo_location(debuginfo dbg, /*out*/ struct caml_loc_info * li); + +/* In order to prevent the GC from walking through the debug + information (which have no headers), we transform slots to 31/63 bits + ocaml integers by shifting them by 1 to the right. We do not lose + information as slots are aligned. + + In particular, we do not need to use [caml_modify] when setting + an array element with such a value. + */ +#define Val_backtrace_slot(bslot) (Val_long(((uintnat)(bslot))>>1)) +#define Backtrace_slot_val(vslot) ((backtrace_slot)(Long_val(vslot) << 1)) + +/* Allocate the caml_backtrace_buffer. Returns 0 on success, -1 otherwise */ +int caml_alloc_backtrace_buffer(void); + +#define BACKTRACE_BUFFER_SIZE 1024 + +/* Besides decoding backtrace info, [backtrace_prim] has two other + * responsibilities: + * + * It defines the [caml_stash_backtrace] function, which is called to quickly + * fill the backtrace buffer by walking the stack when an exception is raised. + * + * It also defines the [caml_get_current_callstack] OCaml primitive, which also + * walks the stack but directly turns it into a [raw_backtrace] and is called + * explicitly. + */ + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_BACKTRACE_PRIM_H */ diff -Nru ocaml-4.01.0/byterun/caml/callback.h ocaml-4.05.0/byterun/caml/callback.h --- ocaml-4.01.0/byterun/caml/callback.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/callback.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,60 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Callbacks from C to OCaml */ + +#ifndef CAML_CALLBACK_H +#define CAML_CALLBACK_H + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "mlvalues.h" + +#ifdef __cplusplus +extern "C" { +#endif + +CAMLextern value caml_callback (value closure, value arg); +CAMLextern value caml_callback2 (value closure, value arg1, value arg2); +CAMLextern value caml_callback3 (value closure, value arg1, value arg2, + value arg3); +CAMLextern value caml_callbackN (value closure, int narg, value args[]); + +CAMLextern value caml_callback_exn (value closure, value arg); +CAMLextern value caml_callback2_exn (value closure, value arg1, value arg2); +CAMLextern value caml_callback3_exn (value closure, + value arg1, value arg2, value arg3); +CAMLextern value caml_callbackN_exn (value closure, int narg, value args[]); + +#define Make_exception_result(v) ((v) | 2) +#define Is_exception_result(v) (((v) & 3) == 2) +#define Extract_exception(v) ((v) & ~3) + +CAMLextern value * caml_named_value (char const * name); +typedef void (*caml_named_action) (value*, char *); +CAMLextern void caml_iterate_named_values(caml_named_action f); + +CAMLextern void caml_main (char ** argv); +CAMLextern void caml_startup (char ** argv); +CAMLextern value caml_startup_exn (char ** argv); + +CAMLextern int caml_callback_depth; + +#ifdef __cplusplus +} +#endif + +#endif diff -Nru ocaml-4.01.0/byterun/caml/compact.h ocaml-4.05.0/byterun/caml/compact.h --- ocaml-4.01.0/byterun/caml/compact.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/compact.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,31 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_COMPACT_H +#define CAML_COMPACT_H + +#ifdef CAML_INTERNALS + +#include "config.h" +#include "misc.h" +#include "mlvalues.h" + +void caml_compact_heap (void); +void caml_compact_heap_maybe (void); +void invert_root (value v, value *p); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_COMPACT_H */ diff -Nru ocaml-4.01.0/byterun/caml/compare.h ocaml-4.05.0/byterun/caml/compare.h --- ocaml-4.01.0/byterun/caml/compare.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/compare.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,25 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, Projet Moscova, INRIA Rocquencourt */ +/* */ +/* Copyright 2003 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_COMPARE_H +#define CAML_COMPARE_H + +#ifdef CAML_INTERNALS + +CAMLextern int caml_compare_unordered; + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_COMPARE_H */ diff -Nru ocaml-4.01.0/byterun/caml/compatibility.h ocaml-4.05.0/byterun/caml/compatibility.h --- ocaml-4.01.0/byterun/caml/compatibility.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/compatibility.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,375 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ +/* */ +/* Copyright 2003 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* definitions for compatibility with old identifiers */ + +#ifndef CAML_COMPATIBILITY_H +#define CAML_COMPATIBILITY_H + +/* internal global variables renamed between 4.02.1 and 4.03.0 */ +#define caml_stat_top_heap_size Bsize_wsize(caml_stat_top_heap_wsz) +#define caml_stat_heap_size Bsize_wsize(caml_stat_heap_wsz) + +#ifndef CAML_NAME_SPACE + +/* + #define --> CAMLextern (defined with CAMLexport or CAMLprim) + (rien) --> CAMLprim + g --> global C identifier + x --> special case + + SP* signals the special cases: + - when the identifier was not simply prefixed with [caml_] + - when the [caml_] version was already used for something else, and + was renamed out of the way (watch out for [caml_alloc] and + [caml_array_bound_error] in *.s) +*/ + +/* a faire: + - ui_* (reverifier que win32.c n'en depend pas) +*/ + + +/* **** alloc.c */ +#define alloc caml_alloc /*SP*/ +#define alloc_small caml_alloc_small +#define alloc_tuple caml_alloc_tuple +#define alloc_string caml_alloc_string +#define alloc_final caml_alloc_final +#define copy_string caml_copy_string +#define alloc_array caml_alloc_array +#define copy_string_array caml_copy_string_array +#define convert_flag_list caml_convert_flag_list + +/* **** array.c */ + +/* **** backtrace.c */ +#define backtrace_active caml_backtrace_active +#define backtrace_pos caml_backtrace_pos +#define backtrace_buffer caml_backtrace_buffer +#define backtrace_last_exn caml_backtrace_last_exn +#define print_exception_backtrace caml_print_exception_backtrace + +/* **** callback.c */ +#define callback_depth caml_callback_depth +#define callbackN_exn caml_callbackN_exn +#define callback_exn caml_callback_exn +#define callback2_exn caml_callback2_exn +#define callback3_exn caml_callback3_exn +#define callback caml_callback +#define callback2 caml_callback2 +#define callback3 caml_callback3 +#define callbackN caml_callbackN + +/* **** compact.c */ + +/* **** compare.c */ +#define compare_unordered caml_compare_unordered + +/* **** custom.c */ +#define alloc_custom caml_alloc_custom +#define register_custom_operations caml_register_custom_operations + +/* **** debugger.c */ + +/* **** dynlink.c */ + +/* **** extern.c */ +#define output_val caml_output_val +#define output_value_to_malloc caml_output_value_to_malloc +#define output_value_to_block caml_output_value_to_block +#define serialize_int_1 caml_serialize_int_1 +#define serialize_int_2 caml_serialize_int_2 +#define serialize_int_4 caml_serialize_int_4 +#define serialize_int_8 caml_serialize_int_8 +#define serialize_float_4 caml_serialize_float_4 +#define serialize_float_8 caml_serialize_float_8 +#define serialize_block_1 caml_serialize_block_1 +#define serialize_block_2 caml_serialize_block_2 +#define serialize_block_4 caml_serialize_block_4 +#define serialize_block_8 caml_serialize_block_8 +#define serialize_block_float_8 caml_serialize_block_float_8 + +/* **** fail.c */ +#define external_raise caml_external_raise +#define mlraise caml_raise /*SP*/ +#define raise_constant caml_raise_constant +#define raise_with_arg caml_raise_with_arg +#define raise_with_string caml_raise_with_string +#define failwith caml_failwith +#define invalid_argument caml_invalid_argument +#define array_bound_error caml_array_bound_error /*SP*/ +#define raise_out_of_memory caml_raise_out_of_memory +#define raise_stack_overflow caml_raise_stack_overflow +#define raise_sys_error caml_raise_sys_error +#define raise_end_of_file caml_raise_end_of_file +#define raise_zero_divide caml_raise_zero_divide +#define raise_not_found caml_raise_not_found +#define raise_sys_blocked_io caml_raise_sys_blocked_io +/* **** asmrun/fail.c */ +/* **** asmrun/.s */ + +/* **** finalise.c */ + +/* **** fix_code.c */ + +/* **** floats.c */ +/*#define Double_val caml_Double_val done in mlvalues.h as needed */ +/*#define Store_double_val caml_Store_double_val done in mlvalues.h as needed */ +#define copy_double caml_copy_double + +/* **** freelist.c */ + +/* **** gc_ctrl.c */ + +/* **** globroots.c */ +#define register_global_root caml_register_global_root +#define remove_global_root caml_remove_global_root + +/* **** hash.c */ +#define hash_variant caml_hash_variant + +/* **** instrtrace.c */ + +/* **** intern.c */ +#define input_val caml_input_val +#define input_val_from_string caml_input_val_from_string +#define input_value_from_malloc caml_input_value_from_malloc +#define input_value_from_block caml_input_value_from_block +#define deserialize_uint_1 caml_deserialize_uint_1 +#define deserialize_sint_1 caml_deserialize_sint_1 +#define deserialize_uint_2 caml_deserialize_uint_2 +#define deserialize_sint_2 caml_deserialize_sint_2 +#define deserialize_uint_4 caml_deserialize_uint_4 +#define deserialize_sint_4 caml_deserialize_sint_4 +#define deserialize_uint_8 caml_deserialize_uint_8 +#define deserialize_sint_8 caml_deserialize_sint_8 +#define deserialize_float_4 caml_deserialize_float_4 +#define deserialize_float_8 caml_deserialize_float_8 +#define deserialize_block_1 caml_deserialize_block_1 +#define deserialize_block_2 caml_deserialize_block_2 +#define deserialize_block_4 caml_deserialize_block_4 +#define deserialize_block_8 caml_deserialize_block_8 +#define deserialize_block_float_8 caml_deserialize_block_float_8 +#define deserialize_error caml_deserialize_error + +/* **** interp.c */ + +/* **** ints.c */ +#define int32_ops caml_int32_ops +#define copy_int32 caml_copy_int32 +/*#define Int64_val caml_Int64_val *** done in mlvalues.h as needed */ +#define int64_ops caml_int64_ops +#define copy_int64 caml_copy_int64 +#define nativeint_ops caml_nativeint_ops +#define copy_nativeint caml_copy_nativeint + +/* **** io.c */ +#define channel_mutex_free caml_channel_mutex_free +#define channel_mutex_lock caml_channel_mutex_lock +#define channel_mutex_unlock caml_channel_mutex_unlock +#define channel_mutex_unlock_exn caml_channel_mutex_unlock_exn +#define all_opened_channels caml_all_opened_channels +#define open_descriptor_in caml_open_descriptor_in /*SP*/ +#define open_descriptor_out caml_open_descriptor_out /*SP*/ +#define close_channel caml_close_channel /*SP*/ +#define channel_size caml_channel_size /*SP*/ +#define channel_binary_mode caml_channel_binary_mode +#define flush_partial caml_flush_partial /*SP*/ +#define flush caml_flush /*SP*/ +#define putword caml_putword +#define putblock caml_putblock +#define really_putblock caml_really_putblock +#define seek_out caml_seek_out /*SP*/ +#define pos_out caml_pos_out /*SP*/ +#define do_read caml_do_read +#define refill caml_refill +#define getword caml_getword +#define getblock caml_getblock +#define really_getblock caml_really_getblock +#define seek_in caml_seek_in /*SP*/ +#define pos_in caml_pos_in /*SP*/ +#define input_scan_line caml_input_scan_line /*SP*/ +#define finalize_channel caml_finalize_channel +#define alloc_channel caml_alloc_channel +/*#define Val_file_offset caml_Val_file_offset *** done in io.h as needed */ +/*#define File_offset_val caml_File_offset_val *** done in io.h as needed */ + +/* **** lexing.c */ + +/* **** main.c */ +/* *** no change */ + +/* **** major_gc.c */ +#define heap_start caml_heap_start +#define page_table caml_page_table + +/* **** md5.c */ +#define md5_string caml_md5_string +#define md5_chan caml_md5_chan +#define MD5Init caml_MD5Init +#define MD5Update caml_MD5Update +#define MD5Final caml_MD5Final +#define MD5Transform caml_MD5Transform + +/* **** memory.c */ +#define alloc_shr caml_alloc_shr +#define initialize caml_initialize +#define modify caml_modify +#define stat_alloc caml_stat_alloc +#define stat_free caml_stat_free +#define stat_resize caml_stat_resize + +/* **** meta.c */ + +/* **** minor_gc.c */ +#define young_start caml_young_start +#define young_end caml_young_end +#define young_ptr caml_young_ptr +#define young_limit caml_young_limit +#define ref_table caml_ref_table +#define minor_collection caml_minor_collection +#define check_urgent_gc caml_check_urgent_gc + +/* **** misc.c */ + +/* **** obj.c */ + +/* **** parsing.c */ + +/* **** prims.c */ + +/* **** printexc.c */ +#define format_caml_exception caml_format_exception /*SP*/ + +/* **** roots.c */ +#define local_roots caml_local_roots +#define scan_roots_hook caml_scan_roots_hook +#define do_local_roots caml_do_local_roots + +/* **** signals.c */ +#define pending_signals caml_pending_signals +#define something_to_do caml_something_to_do +#define enter_blocking_section_hook caml_enter_blocking_section_hook +#define leave_blocking_section_hook caml_leave_blocking_section_hook +#define try_leave_blocking_section_hook caml_try_leave_blocking_section_hook +#define async_action_hook caml_async_action_hook +#define enter_blocking_section caml_enter_blocking_section +#define leave_blocking_section caml_leave_blocking_section +#define convert_signal_number caml_convert_signal_number +/* **** asmrun/signals.c */ +#define garbage_collection caml_garbage_collection + +/* **** stacks.c */ +#define stack_low caml_stack_low +#define stack_high caml_stack_high +#define stack_threshold caml_stack_threshold +#define extern_sp caml_extern_sp +#define trapsp caml_trapsp +#define trap_barrier caml_trap_barrier + +/* **** startup.c */ +#define atom_table caml_atom_table +/* **** asmrun/startup.c */ +#define static_data_start caml_static_data_start +#define static_data_end caml_static_data_end + +/* **** str.c */ +#define string_length caml_string_length + +/* **** sys.c */ +#define sys_error caml_sys_error +#define sys_exit caml_sys_exit + +/* **** terminfo.c */ + +/* **** unix.c & win32.c */ +#define search_exe_in_path caml_search_exe_in_path + +/* **** weak.c */ + +/* **** asmcomp/asmlink.ml */ + +/* **** asmcomp/cmmgen.ml */ + +/* **** asmcomp/asmlink.ml, asmcomp/cmmgen.ml, asmcomp/compilenv.ml */ + +/* ************************************************************* */ + +/* **** otherlibs/bigarray */ +#define int8 caml_ba_int8 +#define uint8 caml_ba_uint8 +#define int16 caml_ba_int16 +#define uint16 caml_ba_uint16 +#define MAX_NUM_DIMS CAML_BA_MAX_NUM_DIMS +#define caml_bigarray_kind caml_ba_kind +#define BIGARRAY_FLOAT32 CAML_BA_FLOAT32 +#define BIGARRAY_FLOAT64 CAML_BA_FLOAT64 +#define BIGARRAY_SINT8 CAML_BA_SINT8 +#define BIGARRAY_UINT8 CAML_BA_UINT8 +#define BIGARRAY_SINT16 CAML_BA_SINT16 +#define BIGARRAY_UINT16 CAML_BA_UINT16 +#define BIGARRAY_INT32 CAML_BA_INT32 +#define BIGARRAY_INT64 CAML_BA_INT64 +#define BIGARRAY_CAML_INT CAML_BA_CAML_INT +#define BIGARRAY_NATIVE_INT CAML_BA_NATIVE_INT +#define BIGARRAY_COMPLEX32 CAML_BA_COMPLEX32 +#define BIGARRAY_COMPLEX64 CAML_BA_COMPLEX64 +#define BIGARRAY_KIND_MASK CAML_BA_KIND_MASK +#define caml_bigarray_layout caml_ba_layout +#define BIGARRAY_C_LAYOUT CAML_BA_C_LAYOUT +#define BIGARRAY_FORTRAN_LAYOUT CAML_BA_FORTRAN_LAYOUT +#define BIGARRAY_LAYOUT_MASK CAML_BA_LAYOUT_MASK +#define caml_bigarray_managed caml_ba_managed +#define BIGARRAY_EXTERNAL CAML_BA_EXTERNAL +#define BIGARRAY_MANAGED CAML_BA_MANAGED +#define BIGARRAY_MAPPED_FILE CAML_BA_MAPPED_FILE +#define BIGARRAY_MANAGED_MASK CAML_BA_MANAGED_MASK +#define caml_bigarray_proxy caml_ba_proxy +#define caml_bigarray caml_ba_array +#define Bigarray_val Caml_ba_array_val +#define Data_bigarray_val Caml_ba_data_val +#define alloc_bigarray caml_ba_alloc +#define alloc_bigarray_dims caml_ba_alloc_dims +#define bigarray_map_file caml_ba_map_file +#define bigarray_unmap_file caml_ba_unmap_file +#define bigarray_element_size caml_ba_element_size +#define bigarray_byte_size caml_ba_byte_size +#define bigarray_deserialize caml_ba_deserialize +#define MAX_BIGARRAY_MEMORY CAML_BA_MAX_MEMORY +#define bigarray_create caml_ba_create +#define bigarray_get_N caml_ba_get_N +#define bigarray_get_1 caml_ba_get_1 +#define bigarray_get_2 caml_ba_get_2 +#define bigarray_get_3 caml_ba_get_3 +#define bigarray_get_generic caml_ba_get_generic +#define bigarray_set_1 caml_ba_set_1 +#define bigarray_set_2 caml_ba_set_2 +#define bigarray_set_3 caml_ba_set_3 +#define bigarray_set_N caml_ba_set_N +#define bigarray_set_generic caml_ba_set_generic +#define bigarray_num_dims caml_ba_num_dims +#define bigarray_dim caml_ba_dim +#define bigarray_kind caml_ba_kind +#define bigarray_layout caml_ba_layout +#define bigarray_slice caml_ba_slice +#define bigarray_sub caml_ba_sub +#define bigarray_blit caml_ba_blit +#define bigarray_fill caml_ba_fill +#define bigarray_reshape caml_ba_reshape +#define bigarray_init caml_ba_init + +#endif /* CAML_NAME_SPACE */ +#endif /* CAML_COMPATIBILITY_H */ diff -Nru ocaml-4.01.0/byterun/caml/config.h ocaml-4.05.0/byterun/caml/config.h --- ocaml-4.01.0/byterun/caml/config.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/config.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,203 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_CONFIG_H +#define CAML_CONFIG_H + +/* */ +/* */ +/* */ +#include "../../config/m.h" +#include "../../config/s.h" +#ifdef BOOTSTRAPPING_FLEXLINK +#undef SUPPORT_DYNAMIC_LINKING +#endif +/* */ + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif + +#ifdef HAS_STDINT_H +#include +#endif + +/* Types for 32-bit integers, 64-bit integers, and + native integers (as wide as a pointer type) */ + +#ifndef ARCH_INT32_TYPE +#if SIZEOF_INT == 4 +#define ARCH_INT32_TYPE int +#define ARCH_UINT32_TYPE unsigned int +#define ARCH_INT32_PRINTF_FORMAT "" +#elif SIZEOF_LONG == 4 +#define ARCH_INT32_TYPE long +#define ARCH_UINT32_TYPE unsigned long +#define ARCH_INT32_PRINTF_FORMAT "l" +#elif SIZEOF_SHORT == 4 +#define ARCH_INT32_TYPE short +#define ARCH_UINT32_TYPE unsigned short +#define ARCH_INT32_PRINTF_FORMAT "" +#else +#error "No 32-bit integer type available" +#endif +#endif + +#ifndef ARCH_INT64_TYPE +#if SIZEOF_LONGLONG == 8 +#define ARCH_INT64_TYPE long long +#define ARCH_UINT64_TYPE unsigned long long +#define ARCH_INT64_PRINTF_FORMAT "ll" +#elif SIZEOF_LONG == 8 +#define ARCH_INT64_TYPE long +#define ARCH_UINT64_TYPE unsigned long +#define ARCH_INT64_PRINTF_FORMAT "l" +#else +#error "No 64-bit integer type available" +#endif +#endif + +#ifndef HAS_STDINT_H +/* Not a C99 compiler, typically MSVC. Define the C99 types we use. */ +typedef ARCH_INT32_TYPE int32_t; +typedef ARCH_UINT32_TYPE uint32_t; +typedef ARCH_INT64_TYPE int64_t; +typedef ARCH_UINT64_TYPE uint64_t; +#if SIZEOF_SHORT == 2 +typedef short int16_t; +typedef unsigned short uint16_t; +#else +#error "No 16-bit integer type available" +#endif +#endif + +#if SIZEOF_PTR == SIZEOF_LONG +/* Standard models: ILP32 or I32LP64 */ +typedef long intnat; +typedef unsigned long uintnat; +#define ARCH_INTNAT_PRINTF_FORMAT "l" +#elif SIZEOF_PTR == SIZEOF_INT +/* Hypothetical IP32L64 model */ +typedef int intnat; +typedef unsigned int uintnat; +#define ARCH_INTNAT_PRINTF_FORMAT "" +#elif SIZEOF_PTR == 8 +/* Win64 model: IL32P64 */ +typedef int64_t intnat; +typedef uint64_t uintnat; +#define ARCH_INTNAT_PRINTF_FORMAT ARCH_INT64_PRINTF_FORMAT +#else +#error "No integer type available to represent pointers" +#endif + +/* Endianness of floats */ + +/* ARCH_FLOAT_ENDIANNESS encodes the byte order of doubles as follows: + the value [0xabcdefgh] means that the least significant byte of the + float is at byte offset [a], the next lsb at [b], ..., and the + most significant byte at [h]. */ + +#if defined(__arm__) && !defined(__ARM_EABI__) +#define ARCH_FLOAT_ENDIANNESS 0x45670123 +#elif defined(ARCH_BIG_ENDIAN) +#define ARCH_FLOAT_ENDIANNESS 0x76543210 +#else +#define ARCH_FLOAT_ENDIANNESS 0x01234567 +#endif + + +/* We use threaded code interpretation if the compiler provides labels + as first-class values (GCC 2.x). */ + +#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) \ + && !defined (SHRINKED_GNUC) && !defined(CAML_JIT) +#define THREADED_CODE +#endif + + +/* Memory model parameters */ + +/* The size of a page for memory management (in bytes) is [1 << Page_log]. + [Page_size] must be a multiple of [sizeof (value)]. + [Page_log] must be be >= 8 and <= 20. + Do not change the definition of [Page_size]. */ +#define Page_log 12 /* A page is 4 kilobytes. */ +#define Page_size (1 << Page_log) + +/* Initial size of stack (bytes). */ +#define Stack_size (4096 * sizeof(value)) + +/* Minimum free size of stack (bytes); below that, it is reallocated. */ +#define Stack_threshold (256 * sizeof(value)) + +/* Default maximum size of the stack (words). */ +#define Max_stack_def (1024 * 1024) + + +/* Maximum size of a block allocated in the young generation (words). */ +/* Must be > 4 */ +#define Max_young_wosize 256 +#define Max_young_whsize (Whsize_wosize (Max_young_wosize)) + + +/* Minimum size of the minor zone (words). + This must be at least [2 * Max_young_whsize]. */ +#define Minor_heap_min 4096 + +/* Maximum size of the minor zone (words). + Must be greater than or equal to [Minor_heap_min]. +*/ +#define Minor_heap_max (1 << 28) + +/* Default size of the minor zone. (words) */ +#define Minor_heap_def 262144 + + +/* Minimum size increment when growing the heap (words). + Must be a multiple of [Page_size / sizeof (value)]. */ +#define Heap_chunk_min (15 * Page_size) + +/* Default size increment when growing the heap. + If this is <= 1000, it's a percentage of the current heap size. + If it is > 1000, it's a number of words. */ +#define Heap_chunk_def 15 + +/* Default initial size of the major heap (words); + Must be a multiple of [Page_size / sizeof (value)]. */ +#define Init_heap_def (31 * Page_size) +/* (about 512 kB for a 32-bit platform, 1 MB for a 64-bit platform.) */ + + +/* Default speed setting for the major GC. The heap will grow until + the dead objects and the free list represent this percentage of the + total size of live objects. */ +#define Percent_free_def 80 + +/* Default setting for the compacter: 500% + (i.e. trigger the compacter when 5/6 of the heap is free or garbage) + This can be set quite high because the overhead is over-estimated + when fragmentation occurs. + */ +#define Max_percent_free_def 500 + +/* Default setting for the major GC slice smoothing window: 1 + (i.e. no smoothing) +*/ +#define Major_window_def 1 + +/* Maximum size of the major GC slice smoothing window. */ +#define Max_major_window 50 + +#endif /* CAML_CONFIG_H */ diff -Nru ocaml-4.01.0/byterun/caml/custom.h ocaml-4.05.0/byterun/caml/custom.h --- ocaml-4.01.0/byterun/caml/custom.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/custom.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,73 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_CUSTOM_H +#define CAML_CUSTOM_H + + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "mlvalues.h" + +struct custom_operations { + char *identifier; + void (*finalize)(value v); + int (*compare)(value v1, value v2); + intnat (*hash)(value v); + void (*serialize)(value v, + /*out*/ uintnat * bsize_32 /*size in bytes*/, + /*out*/ uintnat * bsize_64 /*size in bytes*/); + uintnat (*deserialize)(void * dst); + int (*compare_ext)(value v1, value v2); +}; + +#define custom_finalize_default NULL +#define custom_compare_default NULL +#define custom_hash_default NULL +#define custom_serialize_default NULL +#define custom_deserialize_default NULL +#define custom_compare_ext_default NULL + +#define Custom_ops_val(v) (*((struct custom_operations **) (v))) + +#ifdef __cplusplus +extern "C" { +#endif + + +CAMLextern value caml_alloc_custom(struct custom_operations * ops, + uintnat size, /*size in bytes*/ + mlsize_t mem, /*resources consumed*/ + mlsize_t max /*max resources*/); + +CAMLextern void caml_register_custom_operations(struct custom_operations * ops); + +CAMLextern int caml_compare_unordered; + /* Used by custom comparison to report unordered NaN-like cases. */ + +#ifdef CAML_INTERNALS +extern struct custom_operations * caml_find_custom_operations(char * ident); +extern struct custom_operations * + caml_final_custom_operations(void (*fn)(value)); + +extern void caml_init_custom_operations(void); +#endif /* CAML_INTERNALS */ + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_CUSTOM_H */ diff -Nru ocaml-4.01.0/byterun/caml/debugger.h ocaml-4.05.0/byterun/caml/debugger.h --- ocaml-4.01.0/byterun/caml/debugger.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/debugger.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,117 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Interface with the debugger */ + +#ifndef CAML_DEBUGGER_H +#define CAML_DEBUGGER_H + +#ifdef CAML_INTERNALS + +#include "misc.h" +#include "mlvalues.h" + +CAMLextern int caml_debugger_in_use; +CAMLextern int caml_debugger_fork_mode; /* non-zero for parent */ +extern uintnat caml_event_count; + +enum event_kind { + EVENT_COUNT, BREAKPOINT, PROGRAM_START, PROGRAM_EXIT, + TRAP_BARRIER, UNCAUGHT_EXC +}; + +void caml_debugger_init (void); +void caml_debugger (enum event_kind event); +void caml_debugger_cleanup_fork (void); + +/* Communication protocol */ + +/* Requests from the debugger to the runtime system */ + +enum debugger_request { + REQ_SET_EVENT = 'e', /* uint32_t pos */ + /* Set an event on the instruction at position pos */ + REQ_SET_BREAKPOINT = 'B', /* uint32_t pos, (char k) */ + /* Set a breakpoint at position pos */ + /* In profiling mode, the breakpoint kind is set to k */ + REQ_RESET_INSTR = 'i', /* uint32_t pos */ + /* Clear an event or breapoint at position pos, restores initial instr. */ + REQ_CHECKPOINT = 'c', /* no args */ + /* Checkpoint the runtime system by forking a child process. + Reply is pid of child process or -1 if checkpoint failed. */ + REQ_GO = 'g', /* uint32_t n */ + /* Run the program for n events. + Reply is one of debugger_reply described below. */ + REQ_STOP = 's', /* no args */ + /* Terminate the runtime system */ + REQ_WAIT = 'w', /* no args */ + /* Reap one dead child (a discarded checkpoint). */ + REQ_INITIAL_FRAME = '0', /* no args */ + /* Set current frame to bottom frame (the one currently executing). + Reply is stack offset and current pc. */ + REQ_GET_FRAME = 'f', /* no args */ + /* Return current frame location (stack offset + current pc). */ + REQ_SET_FRAME = 'S', /* uint32_t stack_offset */ + /* Set current frame to given stack offset. No reply. */ + REQ_UP_FRAME = 'U', /* uint32_t n */ + /* Move one frame up. Argument n is size of current frame (in words). + Reply is stack offset and current pc, or -1 if top of stack reached. */ + REQ_SET_TRAP_BARRIER = 'b', /* uint32_t offset */ + /* Set the trap barrier at the given offset. */ + REQ_GET_LOCAL = 'L', /* uint32_t slot_number */ + /* Return the local variable at the given slot in the current frame. + Reply is one value. */ + REQ_GET_ENVIRONMENT = 'E', /* uint32_t slot_number */ + /* Return the local variable at the given slot in the heap environment + of the current frame. Reply is one value. */ + REQ_GET_GLOBAL = 'G', /* uint32_t global_number */ + /* Return the specified global variable. Reply is one value. */ + REQ_GET_ACCU = 'A', /* no args */ + /* Return the current contents of the accumulator. Reply is one value. */ + REQ_GET_HEADER = 'H', /* mlvalue v */ + /* As REQ_GET_OBJ, but sends only the header. */ + REQ_GET_FIELD = 'F', /* mlvalue v, uint32_t fieldnum */ + /* As REQ_GET_OBJ, but sends only one field. */ + REQ_MARSHAL_OBJ = 'M', /* mlvalue v */ + /* Send a copy of the data structure rooted at v, using the same + format as [caml_output_value]. */ + REQ_GET_CLOSURE_CODE = 'C', /* mlvalue v */ + /* Send the code address of the given closure. + Reply is one uint32_t. */ + REQ_SET_FORK_MODE = 'K' /* uint32_t m */ + /* Set whether to follow the child (m=0) or the parent on fork. */ +}; + +/* Replies to a REQ_GO request. All replies are followed by three uint32_t: + - the value of the event counter + - the position of the stack + - the current pc. */ + +enum debugger_reply { + REP_EVENT = 'e', + /* Event counter reached 0. */ + REP_BREAKPOINT = 'b', + /* Breakpoint hit. */ + REP_EXITED = 'x', + /* Program exited by calling exit or reaching the end of the source. */ + REP_TRAP = 's', + /* Trap barrier crossed. */ + REP_UNCAUGHT_EXC = 'u' + /* Program exited due to a stray exception. */ +}; + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_DEBUGGER_H */ diff -Nru ocaml-4.01.0/byterun/caml/dynlink.h ocaml-4.05.0/byterun/caml/dynlink.h --- ocaml-4.01.0/byterun/caml/dynlink.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/dynlink.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,42 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Dynamic loading of C primitives. */ + +#ifndef CAML_DYNLINK_H +#define CAML_DYNLINK_H + +#ifdef CAML_INTERNALS + +#include "misc.h" + +/* Build the table of primitives, given a search path, a list + of shared libraries, and a list of primitive names + (all three 0-separated in char arrays). + Abort the runtime system on error. */ +extern void caml_build_primitive_table(char * lib_path, + char * libs, + char * req_prims); + +/* The search path for shared libraries */ +extern struct ext_table caml_shared_libs_path; + +/* Build the table of primitives as a copy of the builtin primitive table. + Used for executables generated by ocamlc -output-obj. */ +extern void caml_build_primitive_table_builtin(void); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_DYNLINK_H */ diff -Nru ocaml-4.01.0/byterun/caml/exec.h ocaml-4.05.0/byterun/caml/exec.h --- ocaml-4.01.0/byterun/caml/exec.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/exec.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,65 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* exec.h : format of executable bytecode files */ + +#ifndef CAML_EXEC_H +#define CAML_EXEC_H + +#ifdef CAML_INTERNALS + +/* Executable bytecode files are composed of a number of sections, + identified by 4-character names. A table of contents at the + end of the file lists the section names along with their sizes, + in the order in which they appear in the file: + + offset 0 ---> initial junk + data for section 1 + data for section 2 + ... + data for section N + table of contents: + descriptor for section 1 + ... + descriptor for section N + trailer + end of file ---> +*/ + +/* Structure of t.o.c. entries + Numerical quantities are 32-bit unsigned integers, big endian */ + +struct section_descriptor { + char name[4]; /* Section name */ + uint32_t len; /* Length of data in bytes */ +}; + +/* Structure of the trailer. */ + +struct exec_trailer { + uint32_t num_sections; /* Number of sections */ + char magic[12]; /* The magic number */ + struct section_descriptor * section; /* Not part of file */ +}; + +#define TRAILER_SIZE (4+12) + +/* Magic number for this release */ + +#define EXEC_MAGIC "Caml1999X011" + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_EXEC_H */ diff -Nru ocaml-4.01.0/byterun/caml/fail.h ocaml-4.05.0/byterun/caml/fail.h --- ocaml-4.01.0/byterun/caml/fail.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/fail.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,137 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_FAIL_H +#define CAML_FAIL_H + +#ifdef CAML_INTERNALS +#include +#endif /* CAML_INTERNALS */ + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "misc.h" +#include "mlvalues.h" + +#ifdef CAML_INTERNALS +#define OUT_OF_MEMORY_EXN 0 /* "Out_of_memory" */ +#define SYS_ERROR_EXN 1 /* "Sys_error" */ +#define FAILURE_EXN 2 /* "Failure" */ +#define INVALID_EXN 3 /* "Invalid_argument" */ +#define END_OF_FILE_EXN 4 /* "End_of_file" */ +#define ZERO_DIVIDE_EXN 5 /* "Division_by_zero" */ +#define NOT_FOUND_EXN 6 /* "Not_found" */ +#define MATCH_FAILURE_EXN 7 /* "Match_failure" */ +#define STACK_OVERFLOW_EXN 8 /* "Stack_overflow" */ +#define SYS_BLOCKED_IO 9 /* "Sys_blocked_io" */ +#define ASSERT_FAILURE_EXN 10 /* "Assert_failure" */ +#define UNDEFINED_RECURSIVE_MODULE_EXN 11 /* "Undefined_recursive_module" */ + +#ifdef POSIX_SIGNALS +struct longjmp_buffer { + sigjmp_buf buf; +}; +#else +struct longjmp_buffer { + jmp_buf buf; +}; +#define sigsetjmp(buf,save) setjmp(buf) +#define siglongjmp(buf,val) longjmp(buf,val) +#endif + +CAMLextern struct longjmp_buffer * caml_external_raise; +extern value caml_exn_bucket; +int caml_is_special_exception(value exn); + +#endif /* CAML_INTERNALS */ + +#ifdef __cplusplus +extern "C" { +#endif + +CAMLnoreturn_start +CAMLextern void caml_raise (value bucket) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_raise_constant (value tag) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_raise_with_arg (value tag, value arg) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_raise_with_args (value tag, int nargs, value arg[]) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_raise_with_string (value tag, char const * msg) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_failwith (char const *msg) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_failwith_value (value msg) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_invalid_argument (char const *msg) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_invalid_argument_value (value msg) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_raise_out_of_memory (void) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_raise_stack_overflow (void) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_raise_sys_error (value) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_raise_end_of_file (void) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_raise_zero_divide (void) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_raise_not_found (void) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_array_bound_error (void) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_raise_sys_blocked_io (void) +CAMLnoreturn_end; + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_FAIL_H */ diff -Nru ocaml-4.01.0/byterun/caml/finalise.h ocaml-4.05.0/byterun/caml/finalise.h --- ocaml-4.01.0/byterun/caml/finalise.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/finalise.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,36 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_FINALISE_H +#define CAML_FINALISE_H + +#ifdef CAML_INTERNALS + +#include "roots.h" + +void caml_final_update_mark_phase (void); +void caml_final_update_clean_phase (void); +void caml_final_do_calls (void); +void caml_final_do_roots (scanning_action f); +void caml_final_invert_finalisable_values (); +void caml_final_oldify_young_roots (); +void caml_final_empty_young (void); +void caml_final_update_minor_roots(void); +value caml_final_register (value f, value v); +void caml_final_invariant_check(void); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_FINALISE_H */ diff -Nru ocaml-4.01.0/byterun/caml/fix_code.h ocaml-4.05.0/byterun/caml/fix_code.h --- ocaml-4.01.0/byterun/caml/fix_code.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/fix_code.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,45 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Handling of blocks of bytecode (endianness switch, threading). */ + +#ifndef CAML_FIX_CODE_H +#define CAML_FIX_CODE_H + +#ifdef CAML_INTERNALS + +#include "config.h" +#include "misc.h" +#include "mlvalues.h" + +extern code_t caml_start_code; +extern asize_t caml_code_size; +extern unsigned char * caml_saved_code; + +void caml_init_code_fragments(void); +void caml_load_code (int fd, asize_t len); +void caml_fixup_endianness (code_t code, asize_t len); +void caml_set_instruction (code_t pos, opcode_t instr); +int caml_is_instruction (opcode_t instr1, opcode_t instr2); + +#ifdef THREADED_CODE +extern char ** caml_instr_table; +extern char * caml_instr_base; +void caml_thread_code (code_t code, asize_t len); +#endif + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_FIX_CODE_H */ diff -Nru ocaml-4.01.0/byterun/caml/freelist.h ocaml-4.05.0/byterun/caml/freelist.h --- ocaml-4.01.0/byterun/caml/freelist.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/freelist.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,38 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Free lists of heap blocks. */ + +#ifndef CAML_FREELIST_H +#define CAML_FREELIST_H + +#ifdef CAML_INTERNALS + +#include "misc.h" +#include "mlvalues.h" + +extern asize_t caml_fl_cur_wsz; + +header_t *caml_fl_allocate (mlsize_t wo_sz); +void caml_fl_init_merge (void); +void caml_fl_reset (void); +header_t *caml_fl_merge_block (value); +void caml_fl_add_blocks (value); +void caml_make_free_blocks (value *, mlsize_t wsz, int, int); +void caml_set_allocation_policy (uintnat); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_FREELIST_H */ diff -Nru ocaml-4.01.0/byterun/caml/gc_ctrl.h ocaml-4.05.0/byterun/caml/gc_ctrl.h --- ocaml-4.01.0/byterun/caml/gc_ctrl.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/gc_ctrl.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,58 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_GC_CTRL_H +#define CAML_GC_CTRL_H + +#ifdef CAML_INTERNALS + +#include "misc.h" + +extern double + caml_stat_minor_words, + caml_stat_promoted_words, + caml_stat_major_words; + +extern intnat + caml_stat_minor_collections, + caml_stat_major_collections, + caml_stat_heap_wsz, + caml_stat_top_heap_wsz, + caml_stat_compactions, + caml_stat_heap_chunks; + +uintnat caml_normalize_heap_increment (uintnat); + +/* + minor_size: cf. minor_heap_size in gc.mli + major_size: Size in words of the initial major heap + major_incr: cf. major_heap_increment in gc.mli + percent_fr: cf. space_overhead in gc.mli + percent_m : cf. max_overhead in gc.mli + window : cf. window_size in gc.mli +*/ +void caml_init_gc (uintnat minor_size, uintnat major_size, uintnat major_incr, + uintnat percent_fr, uintnat percent_m, uintnat window); + + +CAMLextern value caml_gc_stat(value v); + +#ifdef DEBUG +void caml_heap_check (void); +#endif + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_GC_CTRL_H */ diff -Nru ocaml-4.01.0/byterun/caml/gc.h ocaml-4.05.0/byterun/caml/gc.h --- ocaml-4.01.0/byterun/caml/gc.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/gc.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,79 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_GC_H +#define CAML_GC_H + + +#include "mlvalues.h" + +#define Caml_white (0 << 8) +#define Caml_gray (1 << 8) +#define Caml_blue (2 << 8) +#define Caml_black (3 << 8) + +#define Color_hd(hd) ((color_t) ((hd) & Caml_black)) +#define Color_hp(hp) (Color_hd (Hd_hp (hp))) +#define Color_val(val) (Color_hd (Hd_val (val))) + +#define Is_white_hd(hd) (Color_hd (hd) == Caml_white) +#define Is_gray_hd(hd) (Color_hd (hd) == Caml_gray) +#define Is_blue_hd(hd) (Color_hd (hd) == Caml_blue) +#define Is_black_hd(hd) (Color_hd (hd) == Caml_black) + +#define Whitehd_hd(hd) (((hd) & ~Caml_black)/*| Caml_white*/) +#define Grayhd_hd(hd) (((hd) & ~Caml_black) | Caml_gray) +#define Blackhd_hd(hd) (((hd)/*& ~Caml_black*/)| Caml_black) +#define Bluehd_hd(hd) (((hd) & ~Caml_black) | Caml_blue) + +/* This depends on the layout of the header. See [mlvalues.h]. */ +#define Make_header(wosize, tag, color) \ + (/*Assert ((wosize) <= Max_wosize),*/ \ + ((header_t) (((header_t) (wosize) << 10) \ + + (color) \ + + (tag_t) (tag))) \ + ) + +#ifdef WITH_PROFINFO +#define Make_header_with_profinfo(wosize, tag, color, profinfo) \ + (Make_header(wosize, tag, color) \ + | ((((intnat) profinfo) & PROFINFO_MASK) << PROFINFO_SHIFT) \ + ) +#else +#define Make_header_with_profinfo(wosize, tag, color, profinfo) \ + Make_header(wosize, tag, color) +#endif + +#ifdef WITH_SPACETIME +struct ext_table; +extern uintnat caml_spacetime_my_profinfo(struct ext_table**, uintnat); +#define Make_header_allocated_here(wosize, tag, color) \ + (Make_header_with_profinfo(wosize, tag, color, \ + caml_spacetime_my_profinfo(NULL, wosize)) \ + ) +#else +#define Make_header_allocated_here Make_header +#endif + +#define Is_white_val(val) (Color_val(val) == Caml_white) +#define Is_gray_val(val) (Color_val(val) == Caml_gray) +#define Is_blue_val(val) (Color_val(val) == Caml_blue) +#define Is_black_val(val) (Color_val(val) == Caml_black) + +/* For extern.c */ +#define Colornum_hd(hd) ((color_t) (((hd) >> 8) & 3)) +#define Coloredhd_hd(hd,colnum) (((hd) & ~Caml_black) | ((colnum) << 8)) + +#endif /* CAML_GC_H */ diff -Nru ocaml-4.01.0/byterun/caml/globroots.h ocaml-4.05.0/byterun/caml/globroots.h --- ocaml-4.01.0/byterun/caml/globroots.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/globroots.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,31 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Registration of global memory roots */ + +#ifndef CAML_GLOBROOTS_H +#define CAML_GLOBROOTS_H + +#ifdef CAML_INTERNALS + +#include "mlvalues.h" +#include "roots.h" + +void caml_scan_global_roots(scanning_action f); +void caml_scan_global_young_roots(scanning_action f); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_GLOBROOTS_H */ diff -Nru ocaml-4.01.0/byterun/caml/hash.h ocaml-4.05.0/byterun/caml/hash.h --- ocaml-4.01.0/byterun/caml/hash.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/hash.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,39 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ +/* */ +/* Copyright 2011 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Auxiliary functions for custom hash functions */ + +#ifndef CAML_HASH_H +#define CAML_HASH_H + +#include "mlvalues.h" + +#ifdef __cplusplus +extern "C" { +#endif + +CAMLextern uint32_t caml_hash_mix_uint32(uint32_t h, uint32_t d); +CAMLextern uint32_t caml_hash_mix_intnat(uint32_t h, intnat d); +CAMLextern uint32_t caml_hash_mix_int64(uint32_t h, int64_t d); +CAMLextern uint32_t caml_hash_mix_double(uint32_t h, double d); +CAMLextern uint32_t caml_hash_mix_float(uint32_t h, float d); +CAMLextern uint32_t caml_hash_mix_string(uint32_t h, value s); + +#ifdef __cplusplus +} +#endif + + +#endif /* CAML_HASH_H */ diff -Nru ocaml-4.01.0/byterun/caml/hooks.h ocaml-4.05.0/byterun/caml/hooks.h --- ocaml-4.01.0/byterun/caml/hooks.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/hooks.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,42 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Fabrice Le Fessant, INRIA de Paris */ +/* */ +/* Copyright 2016 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_HOOKS_H +#define CAML_HOOKS_H + +#include "misc.h" +#include "memory.h" + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef CAML_INTERNALS + +#ifdef NATIVE_CODE + +/* executed just before calling the entry point of a dynamically + loaded native code module. */ +CAMLextern void (*caml_natdynlink_hook)(void* handle, char* unit); + +#endif /* NATIVE_CODE */ + +#endif /* CAML_INTERNALS */ + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_HOOKS_H */ diff -Nru ocaml-4.01.0/byterun/caml/instrtrace.h ocaml-4.05.0/byterun/caml/instrtrace.h --- ocaml-4.01.0/byterun/caml/instrtrace.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/instrtrace.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,35 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Trace the instructions executed */ + +#ifndef _instrtrace_ +#define _instrtrace_ + +#ifdef CAML_INTERNALS + +#include "mlvalues.h" +#include "misc.h" + +extern intnat caml_icount; +void caml_stop_here (void); +void caml_disasm_instr (code_t pc); +void caml_trace_value_file (value v, code_t prog, int proglen, FILE * f); +void caml_trace_accu_sp_file(value accu, value * sp, code_t prog, int proglen, + FILE * f); + +#endif /* CAML_INTERNALS */ + +#endif diff -Nru ocaml-4.01.0/byterun/caml/instruct.h ocaml-4.05.0/byterun/caml/instruct.h --- ocaml-4.01.0/byterun/caml/instruct.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/instruct.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,67 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* The instruction set. */ + +#ifndef CAML_INSTRUCT_H +#define CAML_INSTRUCT_H + +#ifdef CAML_INTERNALS + +enum instructions { + ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, + ACC, PUSH, + PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, + PUSHACC4, PUSHACC5, PUSHACC6, PUSHACC7, + PUSHACC, POP, ASSIGN, + ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC, + PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC, + PUSH_RETADDR, APPLY, APPLY1, APPLY2, APPLY3, + APPTERM, APPTERM1, APPTERM2, APPTERM3, + RETURN, RESTART, GRAB, + CLOSURE, CLOSUREREC, + OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE, + PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, + PUSHOFFSETCLOSURE2, PUSHOFFSETCLOSURE, + GETGLOBAL, PUSHGETGLOBAL, GETGLOBALFIELD, PUSHGETGLOBALFIELD, SETGLOBAL, + ATOM0, ATOM, PUSHATOM0, PUSHATOM, + MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEFLOATBLOCK, + GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD, GETFLOATFIELD, + SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD, SETFLOATFIELD, + VECTLENGTH, GETVECTITEM, SETVECTITEM, + GETSTRINGCHAR, SETSTRINGCHAR, + BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT, + PUSHTRAP, POPTRAP, RAISE, + CHECK_SIGNALS, + C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALL5, C_CALLN, + CONST0, CONST1, CONST2, CONST3, CONSTINT, + PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, + NEGINT, ADDINT, SUBINT, MULINT, DIVINT, MODINT, + ANDINT, ORINT, XORINT, LSLINT, LSRINT, ASRINT, + EQ, NEQ, LTINT, LEINT, GTINT, GEINT, + OFFSETINT, OFFSETREF, ISINT, + GETMETHOD, + BEQ, BNEQ, BLTINT, BLEINT, BGTINT, BGEINT, + ULTINT, UGEINT, + BULTINT, BUGEINT, + GETPUBMET, GETDYNMET, + STOP, + EVENT, BREAK, + RERAISE, RAISE_NOTRACE, +FIRST_UNIMPLEMENTED_OP}; + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_INSTRUCT_H */ diff -Nru ocaml-4.01.0/byterun/caml/int64_emul.h ocaml-4.05.0/byterun/caml/int64_emul.h --- ocaml-4.01.0/byterun/caml/int64_emul.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/int64_emul.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,293 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2002 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Software emulation of 64-bit integer arithmetic, for C compilers + that do not support it. */ + +#ifndef CAML_INT64_EMUL_H +#define CAML_INT64_EMUL_H + +#ifdef CAML_INTERNALS + +#include + +#ifdef ARCH_BIG_ENDIAN +#define I64_literal(hi,lo) { hi, lo } +#else +#define I64_literal(hi,lo) { lo, hi } +#endif + +#define I64_split(x,hi,lo) (hi = (x).h, lo = (x).l) + +/* Unsigned comparison */ +static int I64_ucompare(uint64_t x, uint64_t y) +{ + if (x.h > y.h) return 1; + if (x.h < y.h) return -1; + if (x.l > y.l) return 1; + if (x.l < y.l) return -1; + return 0; +} + +#define I64_ult(x, y) (I64_ucompare(x, y) < 0) + +/* Signed comparison */ +static int I64_compare(int64_t x, int64_t y) +{ + if ((int32_t)x.h > (int32_t)y.h) return 1; + if ((int32_t)x.h < (int32_t)y.h) return -1; + if (x.l > y.l) return 1; + if (x.l < y.l) return -1; + return 0; +} + +/* Negation */ +static int64_t I64_neg(int64_t x) +{ + int64_t res; + res.l = -x.l; + res.h = ~x.h; + if (res.l == 0) res.h++; + return res; +} + +/* Addition */ +static int64_t I64_add(int64_t x, int64_t y) +{ + int64_t res; + res.l = x.l + y.l; + res.h = x.h + y.h; + if (res.l < x.l) res.h++; + return res; +} + +/* Subtraction */ +static int64_t I64_sub(int64_t x, int64_t y) +{ + int64_t res; + res.l = x.l - y.l; + res.h = x.h - y.h; + if (x.l < y.l) res.h--; + return res; +} + +/* Multiplication */ +static int64_t I64_mul(int64_t x, int64_t y) +{ + int64_t res; + uint32_t prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); + uint32_t prod10 = (x.l >> 16) * (y.l & 0xFFFF); + uint32_t prod01 = (x.l & 0xFFFF) * (y.l >> 16); + uint32_t prod11 = (x.l >> 16) * (y.l >> 16); + res.l = prod00; + res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); + prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; + prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++; + res.h += x.l * y.h + x.h * y.l; + return res; +} + +#define I64_is_zero(x) (((x).l | (x).h) == 0) +#define I64_is_negative(x) ((int32_t) (x).h < 0) +#define I64_is_min_int(x) ((x).l == 0 && (x).h == 0x80000000U) +#define I64_is_minus_one(x) (((x).l & (x).h) == 0xFFFFFFFFU) + +/* Bitwise operations */ +static int64_t I64_and(int64_t x, int64_t y) +{ + int64_t res; + res.l = x.l & y.l; + res.h = x.h & y.h; + return res; +} + +static int64_t I64_or(int64_t x, int64_t y) +{ + int64_t res; + res.l = x.l | y.l; + res.h = x.h | y.h; + return res; +} + +static int64_t I64_xor(int64_t x, int64_t y) +{ + int64_t res; + res.l = x.l ^ y.l; + res.h = x.h ^ y.h; + return res; +} + +/* Shifts */ +static int64_t I64_lsl(int64_t x, int s) +{ + int64_t res; + s = s & 63; + if (s == 0) return x; + if (s < 32) { + res.l = x.l << s; + res.h = (x.h << s) | (x.l >> (32 - s)); + } else { + res.l = 0; + res.h = x.l << (s - 32); + } + return res; +} + +static int64_t I64_lsr(int64_t x, int s) +{ + int64_t res; + s = s & 63; + if (s == 0) return x; + if (s < 32) { + res.l = (x.l >> s) | (x.h << (32 - s)); + res.h = x.h >> s; + } else { + res.l = x.h >> (s - 32); + res.h = 0; + } + return res; +} + +static int64_t I64_asr(int64_t x, int s) +{ + int64_t res; + s = s & 63; + if (s == 0) return x; + if (s < 32) { + res.l = (x.l >> s) | (x.h << (32 - s)); + res.h = (int32_t) x.h >> s; + } else { + res.l = (int32_t) x.h >> (s - 32); + res.h = (int32_t) x.h >> 31; + } + return res; +} + +/* Division and modulus */ + +#define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 +#define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 + +static void I64_udivmod(uint64_t modulus, uint64_t divisor, + uint64_t * quo, uint64_t * mod) +{ + int64_t quotient, mask; + int cmp; + + quotient.h = 0; quotient.l = 0; + mask.h = 0; mask.l = 1; + while ((int32_t) divisor.h >= 0) { + cmp = I64_ucompare(divisor, modulus); + I64_SHL1(divisor); + I64_SHL1(mask); + if (cmp >= 0) break; + } + while (mask.l | mask.h) { + if (I64_ucompare(modulus, divisor) >= 0) { + quotient.h |= mask.h; quotient.l |= mask.l; + modulus = I64_sub(modulus, divisor); + } + I64_SHR1(mask); + I64_SHR1(divisor); + } + *quo = quotient; + *mod = modulus; +} + +static int64_t I64_div(int64_t x, int64_t y) +{ + int64_t q, r; + int32_t sign; + + sign = x.h ^ y.h; + if ((int32_t) x.h < 0) x = I64_neg(x); + if ((int32_t) y.h < 0) y = I64_neg(y); + I64_udivmod(x, y, &q, &r); + if (sign < 0) q = I64_neg(q); + return q; +} + +static int64_t I64_mod(int64_t x, int64_t y) +{ + int64_t q, r; + int32_t sign; + + sign = x.h; + if ((int32_t) x.h < 0) x = I64_neg(x); + if ((int32_t) y.h < 0) y = I64_neg(y); + I64_udivmod(x, y, &q, &r); + if (sign < 0) r = I64_neg(r); + return r; +} + +/* Coercions */ + +static int64_t I64_of_int32(int32_t x) +{ + int64_t res; + res.l = x; + res.h = x >> 31; + return res; +} + +#define I64_to_int32(x) ((int32_t) (x).l) + +/* Note: we assume sizeof(intnat) = 4 here, which is true otherwise + autoconfiguration would have selected native 64-bit integers */ +#define I64_of_intnat I64_of_int32 +#define I64_to_intnat I64_to_int32 + +static double I64_to_double(int64_t x) +{ + double res; + int32_t sign = x.h; + if (sign < 0) x = I64_neg(x); + res = ldexp((double) x.h, 32) + x.l; + if (sign < 0) res = -res; + return res; +} + +static int64_t I64_of_double(double f) +{ + int64_t res; + double frac, integ; + int neg; + + neg = (f < 0); + f = fabs(f); + frac = modf(ldexp(f, -32), &integ); + res.h = (uint32_t) integ; + res.l = (uint32_t) ldexp(frac, 32); + if (neg) res = I64_neg(res); + return res; +} + +static int64_t I64_bswap(int64_t x) +{ + int64_t res; + res.h = (((x.l & 0x000000FF) << 24) | + ((x.l & 0x0000FF00) << 8) | + ((x.l & 0x00FF0000) >> 8) | + ((x.l & 0xFF000000) >> 24)); + res.l = (((x.h & 0x000000FF) << 24) | + ((x.h & 0x0000FF00) << 8) | + ((x.h & 0x00FF0000) >> 8) | + ((x.h & 0xFF000000) >> 24)); + return res; +} + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_INT64_EMUL_H */ diff -Nru ocaml-4.01.0/byterun/caml/int64_format.h ocaml-4.05.0/byterun/caml/int64_format.h --- ocaml-4.01.0/byterun/caml/int64_format.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/int64_format.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,111 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2002 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* printf-like formatting of 64-bit integers, in case the C library + printf() function does not support them. */ + +#ifndef CAML_INT64_FORMAT_H +#define CAML_INT64_FORMAT_H + +#ifdef CAML_INTERNALS + +static void I64_format(char * buffer, char * fmt, int64_t x) +{ + static char conv_lower[] = "0123456789abcdef"; + static char conv_upper[] = "0123456789ABCDEF"; + char rawbuffer[24]; + char justify, signstyle, filler, alternate, signedconv; + int base, width, sign, i, rawlen; + char * cvtbl; + char * p, * r; + int64_t wbase, digit; + + /* Parsing of format */ + justify = '+'; + signstyle = '-'; + filler = ' '; + alternate = 0; + base = 0; + signedconv = 0; + width = 0; + cvtbl = conv_lower; + for (p = fmt; *p != 0; p++) { + switch (*p) { + case '-': + justify = '-'; break; + case '+': case ' ': + signstyle = *p; break; + case '0': + filler = '0'; break; + case '#': + alternate = 1; break; + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + width = atoi(p); + while (p[1] >= '0' && p[1] <= '9') p++; + break; + case 'd': case 'i': + signedconv = 1; /* fallthrough */ + case 'u': + base = 10; break; + case 'x': + base = 16; break; + case 'X': + base = 16; cvtbl = conv_upper; break; + case 'o': + base = 8; break; + } + } + if (base == 0) { buffer[0] = 0; return; } + /* Do the conversion */ + sign = 1; + if (signedconv && I64_is_negative(x)) { sign = -1; x = I64_neg(x); } + r = rawbuffer + sizeof(rawbuffer); + wbase = I64_of_int32(base); + do { + I64_udivmod(x, wbase, &x, &digit); + *--r = cvtbl[I64_to_int32(digit)]; + } while (! I64_is_zero(x)); + rawlen = rawbuffer + sizeof(rawbuffer) - r; + /* Adjust rawlen to reflect additional chars (sign, etc) */ + if (signedconv && (sign < 0 || signstyle != '-')) rawlen++; + if (alternate) { + if (base == 8) rawlen += 1; + if (base == 16) rawlen += 2; + } + /* Do the formatting */ + p = buffer; + if (justify == '+' && filler == ' ') { + for (i = rawlen; i < width; i++) *p++ = ' '; + } + if (signedconv) { + if (sign < 0) *p++ = '-'; + else if (signstyle != '-') *p++ = signstyle; + } + if (alternate && base == 8) *p++ = '0'; + if (alternate && base == 16) { *p++ = '0'; *p++ = 'x'; } + if (justify == '+' && filler == '0') { + for (i = rawlen; i < width; i++) *p++ = '0'; + } + while (r < rawbuffer + sizeof(rawbuffer)) *p++ = *r++; + if (justify == '-') { + for (i = rawlen; i < width; i++) *p++ = ' '; + } + *p = 0; +} + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_INT64_FORMAT_H */ diff -Nru ocaml-4.01.0/byterun/caml/int64_native.h ocaml-4.05.0/byterun/caml/int64_native.h --- ocaml-4.01.0/byterun/caml/int64_native.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/int64_native.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,67 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2002 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Wrapper macros around native 64-bit integer arithmetic, + so that it has the same interface as the software emulation + provided in int64_emul.h */ + +#ifndef CAML_INT64_NATIVE_H +#define CAML_INT64_NATIVE_H + +#ifdef CAML_INTERNALS + +#define I64_literal(hi,lo) ((int64_t)(hi) << 32 | (lo)) +#define I64_split(x,hi,lo) (hi = (uint32_t)((x)>>32), lo = (uint32_t)(x)) +#define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) +#define I64_ult(x,y) ((uint64_t)(x) < (uint64_t)(y)) +#define I64_neg(x) (-(x)) +#define I64_add(x,y) ((x) + (y)) +#define I64_sub(x,y) ((x) - (y)) +#define I64_mul(x,y) ((x) * (y)) +#define I64_is_zero(x) ((x) == 0) +#define I64_is_negative(x) ((x) < 0) +#define I64_is_min_int(x) ((x) == ((int64_t)1 << 63)) +#define I64_is_minus_one(x) ((x) == -1) + +#define I64_div(x,y) ((x) / (y)) +#define I64_mod(x,y) ((x) % (y)) +#define I64_udivmod(x,y,quo,rem) \ + (*(rem) = (uint64_t)(x) % (uint64_t)(y), \ + *(quo) = (uint64_t)(x) / (uint64_t)(y)) +#define I64_and(x,y) ((x) & (y)) +#define I64_or(x,y) ((x) | (y)) +#define I64_xor(x,y) ((x) ^ (y)) +#define I64_lsl(x,y) ((x) << (y)) +#define I64_asr(x,y) ((x) >> (y)) +#define I64_lsr(x,y) ((uint64_t)(x) >> (y)) +#define I64_to_intnat(x) ((intnat) (x)) +#define I64_of_intnat(x) ((intnat) (x)) +#define I64_to_int32(x) ((int32_t) (x)) +#define I64_of_int32(x) ((int64_t) (x)) +#define I64_to_double(x) ((double)(x)) +#define I64_of_double(x) ((int64_t)(x)) + +#define I64_bswap(x) ((((x) & 0x00000000000000FFULL) << 56) | \ + (((x) & 0x000000000000FF00ULL) << 40) | \ + (((x) & 0x0000000000FF0000ULL) << 24) | \ + (((x) & 0x00000000FF000000ULL) << 8) | \ + (((x) & 0x000000FF00000000ULL) >> 8) | \ + (((x) & 0x0000FF0000000000ULL) >> 24) | \ + (((x) & 0x00FF000000000000ULL) >> 40) | \ + (((x) & 0xFF00000000000000ULL) >> 56)) + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_INT64_NATIVE_H */ diff -Nru ocaml-4.01.0/byterun/caml/interp.h ocaml-4.05.0/byterun/caml/interp.h --- ocaml-4.01.0/byterun/caml/interp.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/interp.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,37 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* The bytecode interpreter */ + +#ifndef CAML_INTERP_H +#define CAML_INTERP_H + +#ifdef CAML_INTERNALS + +#include "misc.h" +#include "mlvalues.h" + +/* interpret a bytecode */ +value caml_interprete (code_t prog, asize_t prog_size); + +/* tell the runtime that a bytecode program might be needed */ +void caml_prepare_bytecode(code_t prog, asize_t prog_size); + +/* tell the runtime that a bytecode program is no more needed */ +void caml_release_bytecode(code_t prog, asize_t prog_size); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_INTERP_H */ diff -Nru ocaml-4.01.0/byterun/caml/intext.h ocaml-4.05.0/byterun/caml/intext.h --- ocaml-4.01.0/byterun/caml/intext.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/intext.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,207 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Structured input/output */ + +#ifndef CAML_INTEXT_H +#define CAML_INTEXT_H + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "misc.h" +#include "mlvalues.h" + +#ifdef CAML_INTERNALS +#include "io.h" + +/* Magic number */ + +#define Intext_magic_number_small 0x8495A6BE +#define Intext_magic_number_big 0x8495A6BF + +/* Header format for the "small" model: 20 bytes + 0 "small" magic number + 4 length of marshaled data, in bytes + 8 number of shared blocks + 12 size in words when read on a 32-bit platform + 16 size in words when read on a 64-bit platform + The 4 numbers are 32 bits each, in big endian. + + Header format for the "big" model: 32 bytes + 0 "big" magic number + 4 four reserved bytes, currently set to 0 + 8 length of marshaled data, in bytes + 16 number of shared blocks + 24 size in words when read on a 64-bit platform + The 3 numbers are 64 bits each, in big endian. +*/ + +/* Codes for the compact format */ + +#define PREFIX_SMALL_BLOCK 0x80 +#define PREFIX_SMALL_INT 0x40 +#define PREFIX_SMALL_STRING 0x20 +#define CODE_INT8 0x0 +#define CODE_INT16 0x1 +#define CODE_INT32 0x2 +#define CODE_INT64 0x3 +#define CODE_SHARED8 0x4 +#define CODE_SHARED16 0x5 +#define CODE_SHARED32 0x6 +#define CODE_SHARED64 0x14 +#define CODE_BLOCK32 0x8 +#define CODE_BLOCK64 0x13 +#define CODE_STRING8 0x9 +#define CODE_STRING32 0xA +#define CODE_STRING64 0x15 +#define CODE_DOUBLE_BIG 0xB +#define CODE_DOUBLE_LITTLE 0xC +#define CODE_DOUBLE_ARRAY8_BIG 0xD +#define CODE_DOUBLE_ARRAY8_LITTLE 0xE +#define CODE_DOUBLE_ARRAY32_BIG 0xF +#define CODE_DOUBLE_ARRAY32_LITTLE 0x7 +#define CODE_DOUBLE_ARRAY64_BIG 0x16 +#define CODE_DOUBLE_ARRAY64_LITTLE 0x17 +#define CODE_CODEPOINTER 0x10 +#define CODE_INFIXPOINTER 0x11 +#define CODE_CUSTOM 0x12 + +#if ARCH_FLOAT_ENDIANNESS == 0x76543210 +#define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG +#define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_BIG +#define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_BIG +#define CODE_DOUBLE_ARRAY64_NATIVE CODE_DOUBLE_ARRAY64_BIG +#else +#define CODE_DOUBLE_NATIVE CODE_DOUBLE_LITTLE +#define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_LITTLE +#define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_LITTLE +#define CODE_DOUBLE_ARRAY64_NATIVE CODE_DOUBLE_ARRAY64_LITTLE +#endif + +/* Size-ing data structures for extern. Chosen so that + sizeof(struct trail_block) and sizeof(struct output_block) + are slightly below 8Kb. */ + +#define ENTRIES_PER_TRAIL_BLOCK 1025 +#define SIZE_EXTERN_OUTPUT_BLOCK 8100 + +/* The entry points */ + +void caml_output_val (struct channel * chan, value v, value flags); + /* Output [v] with flags [flags] on the channel [chan]. */ + +#endif /* CAML_INTERNALS */ + +#ifdef __cplusplus +extern "C" { +#endif + +CAMLextern void caml_output_value_to_malloc(value v, value flags, + /*out*/ char ** buf, + /*out*/ intnat * len); + /* Output [v] with flags [flags] to a memory buffer allocated with + malloc. On return, [*buf] points to the buffer and [*len] + contains the number of bytes in buffer. */ +CAMLextern intnat caml_output_value_to_block(value v, value flags, + char * data, intnat len); + /* Output [v] with flags [flags] to a user-provided memory buffer. + [data] points to the start of this buffer, and [len] is its size + in bytes. Return the number of bytes actually written in buffer. + Raise [Failure] if buffer is too short. */ + +#ifdef CAML_INTERNALS +value caml_input_val (struct channel * chan); + /* Read a structured value from the channel [chan]. */ + +extern value caml_input_value_to_outside_heap (value channel); + /* As for [caml_input_value], but the value is unmarshalled into + malloc blocks that are not added to the heap. Not for the + casual user. */ + +extern int caml_extern_allow_out_of_heap; + /* Permit the marshaller to traverse structures that look like OCaml + values but do not live in the OCaml heap. */ + +extern value caml_output_value(value vchan, value v, value flags); +#endif /* CAML_INTERNALS */ + +CAMLextern value caml_input_val_from_string (value str, intnat ofs); + /* Read a structured value from the OCaml string [str], starting + at offset [ofs]. */ +CAMLextern value caml_input_value_from_malloc(char * data, intnat ofs); + /* Read a structured value from a malloced buffer. [data] points + to the beginning of the buffer, and [ofs] is the offset of the + beginning of the externed data in this buffer. The buffer is + deallocated with [free] on return, or if an exception is raised. */ +CAMLextern value caml_input_value_from_block(char * data, intnat len); + /* Read a structured value from a user-provided buffer. [data] points + to the beginning of the externed data in this buffer, + and [len] is the length in bytes of valid data in this buffer. + The buffer is never deallocated by this routine. */ + +/* Functions for writing user-defined marshallers */ + +CAMLextern void caml_serialize_int_1(int i); +CAMLextern void caml_serialize_int_2(int i); +CAMLextern void caml_serialize_int_4(int32_t i); +CAMLextern void caml_serialize_int_8(int64_t i); +CAMLextern void caml_serialize_float_4(float f); +CAMLextern void caml_serialize_float_8(double f); +CAMLextern void caml_serialize_block_1(void * data, intnat len); +CAMLextern void caml_serialize_block_2(void * data, intnat len); +CAMLextern void caml_serialize_block_4(void * data, intnat len); +CAMLextern void caml_serialize_block_8(void * data, intnat len); +CAMLextern void caml_serialize_block_float_8(void * data, intnat len); + +CAMLextern int caml_deserialize_uint_1(void); +CAMLextern int caml_deserialize_sint_1(void); +CAMLextern int caml_deserialize_uint_2(void); +CAMLextern int caml_deserialize_sint_2(void); +CAMLextern uint32_t caml_deserialize_uint_4(void); +CAMLextern int32_t caml_deserialize_sint_4(void); +CAMLextern uint64_t caml_deserialize_uint_8(void); +CAMLextern int64_t caml_deserialize_sint_8(void); +CAMLextern float caml_deserialize_float_4(void); +CAMLextern double caml_deserialize_float_8(void); +CAMLextern void caml_deserialize_block_1(void * data, intnat len); +CAMLextern void caml_deserialize_block_2(void * data, intnat len); +CAMLextern void caml_deserialize_block_4(void * data, intnat len); +CAMLextern void caml_deserialize_block_8(void * data, intnat len); +CAMLextern void caml_deserialize_block_float_8(void * data, intnat len); +CAMLextern void caml_deserialize_error(char * msg); + +#ifdef CAML_INTERNALS + +/* Auxiliary stuff for sending code pointers */ + +struct code_fragment { + char * code_start; + char * code_end; + unsigned char digest[16]; + char digest_computed; +}; + +CAMLextern struct code_fragment * caml_extern_find_code(char *addr); + +struct ext_table caml_code_fragments_table; + +#endif /* CAML_INTERNALS */ + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_INTEXT_H */ diff -Nru ocaml-4.01.0/byterun/caml/io.h ocaml-4.05.0/byterun/caml/io.h --- ocaml-4.01.0/byterun/caml/io.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/io.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,125 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Buffered input/output */ + +#ifndef CAML_IO_H +#define CAML_IO_H + +#ifdef CAML_INTERNALS + +#include "misc.h" +#include "mlvalues.h" + +#ifndef IO_BUFFER_SIZE +#define IO_BUFFER_SIZE 65536 +#endif + +#if defined(_WIN32) +typedef __int64 file_offset; +#elif defined(HAS_OFF_T) +#include +typedef off_t file_offset; +#else +typedef long file_offset; +#endif + +struct channel { + int fd; /* Unix file descriptor */ + file_offset offset; /* Absolute position of fd in the file */ + char * end; /* Physical end of the buffer */ + char * curr; /* Current position in the buffer */ + char * max; /* Logical end of the buffer (for input) */ + void * mutex; /* Placeholder for mutex (for systhreads) */ + struct channel * next, * prev;/* Double chaining of channels (flush_all) */ + int revealed; /* For Cash only */ + int old_revealed; /* For Cash only */ + int refcount; /* For flush_all and for Cash */ + int flags; /* Bitfield */ + char buff[IO_BUFFER_SIZE]; /* The buffer itself */ + char * name; /* Optional name (to report fd leaks) */ +}; + +enum { + CHANNEL_FLAG_FROM_SOCKET = 1, /* For Windows */ +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + CHANNEL_FLAG_BLOCKING_WRITE = 2, +#endif +}; + +/* For an output channel: + [offset] is the absolute position of the beginning of the buffer [buff]. + For an input channel: + [offset] is the absolute position of the logical end of the buffer, [max]. +*/ + +/* Functions and macros that can be called from C. Take arguments of + type struct channel *. No locking is performed. */ + +#define caml_putch(channel, ch) do{ \ + if ((channel)->curr >= (channel)->end) caml_flush_partial(channel); \ + *((channel)->curr)++ = (ch); \ +}while(0) + +#define caml_getch(channel) \ + ((channel)->curr >= (channel)->max \ + ? caml_refill(channel) \ + : (unsigned char) *((channel)->curr)++) + +CAMLextern struct channel * caml_open_descriptor_in (int); +CAMLextern struct channel * caml_open_descriptor_out (int); +CAMLextern void caml_close_channel (struct channel *); +CAMLextern int caml_channel_binary_mode (struct channel *); +CAMLextern value caml_alloc_channel(struct channel *chan); + +CAMLextern int caml_flush_partial (struct channel *); +CAMLextern void caml_flush (struct channel *); +CAMLextern void caml_putword (struct channel *, uint32_t); +CAMLextern int caml_putblock (struct channel *, char *, intnat); +CAMLextern void caml_really_putblock (struct channel *, char *, intnat); + +CAMLextern unsigned char caml_refill (struct channel *); +CAMLextern uint32_t caml_getword (struct channel *); +CAMLextern int caml_getblock (struct channel *, char *, intnat); +CAMLextern intnat caml_really_getblock (struct channel *, char *, intnat); + +/* Extract a struct channel * from the heap object representing it */ + +#define Channel(v) (*((struct channel **) (Data_custom_val(v)))) + +/* The locking machinery */ + +CAMLextern void (*caml_channel_mutex_free) (struct channel *); +CAMLextern void (*caml_channel_mutex_lock) (struct channel *); +CAMLextern void (*caml_channel_mutex_unlock) (struct channel *); +CAMLextern void (*caml_channel_mutex_unlock_exn) (void); + +CAMLextern struct channel * caml_all_opened_channels; + +#define Lock(channel) \ + if (caml_channel_mutex_lock != NULL) (*caml_channel_mutex_lock)(channel) +#define Unlock(channel) \ + if (caml_channel_mutex_unlock != NULL) (*caml_channel_mutex_unlock)(channel) +#define Unlock_exn() \ + if (caml_channel_mutex_unlock_exn != NULL) (*caml_channel_mutex_unlock_exn)() + +/* Conversion between file_offset and int64_t */ + +#define Val_file_offset(fofs) caml_copy_int64(fofs) +#define File_offset_val(v) ((file_offset) Int64_val(v)) + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_IO_H */ diff -Nru ocaml-4.01.0/byterun/caml/major_gc.h ocaml-4.05.0/byterun/caml/major_gc.h --- ocaml-4.01.0/byterun/caml/major_gc.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/major_gc.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,86 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_MAJOR_GC_H +#define CAML_MAJOR_GC_H + +#ifdef CAML_INTERNALS + +#include "freelist.h" +#include "misc.h" + +typedef struct { + void *block; /* address of the malloced block this chunk lives in */ + asize_t alloc; /* in bytes, used for compaction */ + asize_t size; /* in bytes */ + char *next; +} heap_chunk_head; + +#define Chunk_size(c) (((heap_chunk_head *) (c)) [-1]).size +#define Chunk_alloc(c) (((heap_chunk_head *) (c)) [-1]).alloc +#define Chunk_next(c) (((heap_chunk_head *) (c)) [-1]).next +#define Chunk_block(c) (((heap_chunk_head *) (c)) [-1]).block + +extern int caml_gc_phase; +extern int caml_gc_subphase; +extern uintnat caml_allocated_words; +extern double caml_extra_heap_resources; +extern uintnat caml_dependent_size, caml_dependent_allocated; +extern uintnat caml_fl_wsz_at_phase_change; + +#define Phase_mark 0 +#define Phase_clean 1 +#define Phase_sweep 2 +#define Phase_idle 3 + +/* Subphase of mark */ +#define Subphase_mark_roots 10 +/* Subphase_mark_roots: At the end of this subphase all the global + roots are marked. */ +#define Subphase_mark_main 11 +/* Subphase_mark_main: At the end of this subphase all the value alive at + the start of this subphase and created during it are marked. */ +#define Subphase_mark_final 12 +/* Subphase_mark_final: At the start of this subphase register which + value with an ocaml finalizer are not marked, the associated + finalizer will be run later. So we mark now these value as alive, + since they must be available for their finalizer. + */ + +CAMLextern char *caml_heap_start; +extern uintnat total_heap_size; +extern char *caml_gc_sweep_hp; + +extern int caml_major_window; +double caml_major_ring[Max_major_window]; +int caml_major_ring_index; +double caml_major_work_credit; +extern double caml_gc_clock; + +/* [caml_major_gc_hook] is called just between the end of the mark + phase and the beginning of the sweep phase of the major GC */ +CAMLextern void (*caml_major_gc_hook)(void); + +void caml_init_major_heap (asize_t); /* size in bytes */ +asize_t caml_clip_heap_chunk_wsz (asize_t wsz); +void caml_darken (value, value *); +void caml_major_collection_slice (intnat); +void major_collection (void); +void caml_finish_major_cycle (void); +void caml_set_major_window (int); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_MAJOR_GC_H */ diff -Nru ocaml-4.01.0/byterun/caml/md5.h ocaml-4.05.0/byterun/caml/md5.h --- ocaml-4.01.0/byterun/caml/md5.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/md5.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,47 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1999 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* MD5 message digest */ + +#ifndef CAML_MD5_H +#define CAML_MD5_H + +#ifdef CAML_INTERNALS + +#include "mlvalues.h" +#include "io.h" + +CAMLextern value caml_md5_string (value str, value ofs, value len); +CAMLextern value caml_md5_chan (value vchan, value len); +CAMLextern void caml_md5_block(unsigned char digest[16], + void * data, uintnat len); + +CAMLextern value caml_md5_channel(struct channel *chan, intnat toread); + +struct MD5Context { + uint32_t buf[4]; + uint32_t bits[2]; + unsigned char in[64]; +}; + +CAMLextern void caml_MD5Init (struct MD5Context *context); +CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf, + uintnat len); +CAMLextern void caml_MD5Final (unsigned char *digest, struct MD5Context *ctx); +CAMLextern void caml_MD5Transform (uint32_t *buf, uint32_t *in); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_MD5_H */ diff -Nru ocaml-4.01.0/byterun/caml/memory.h ocaml-4.05.0/byterun/caml/memory.h --- ocaml-4.01.0/byterun/caml/memory.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/memory.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,484 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Allocation macros and functions */ + +#ifndef CAML_MEMORY_H +#define CAML_MEMORY_H + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "config.h" +#ifdef CAML_INTERNALS +#include "gc.h" +#include "major_gc.h" +#include "minor_gc.h" +#endif /* CAML_INTERNALS */ +#include "misc.h" +#include "mlvalues.h" + +#ifdef __cplusplus +extern "C" { +#endif + + +CAMLextern value caml_alloc_shr (mlsize_t wosize, tag_t); +#ifdef WITH_PROFINFO +CAMLextern value caml_alloc_shr_with_profinfo (mlsize_t, tag_t, intnat); +CAMLextern value caml_alloc_shr_preserving_profinfo (mlsize_t, tag_t, + header_t); +#else +#define caml_alloc_shr_with_profinfo(size, tag, profinfo) \ + caml_alloc_shr(size, tag) +#define caml_alloc_shr_preserving_profinfo(size, tag, header) \ + caml_alloc_shr(size, tag) +#endif /* WITH_PROFINFO */ +CAMLextern value caml_alloc_shr_no_raise (mlsize_t wosize, tag_t); +CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); +CAMLextern void caml_alloc_dependent_memory (mlsize_t bsz); +CAMLextern void caml_free_dependent_memory (mlsize_t bsz); +CAMLextern void caml_modify (value *, value); +CAMLextern void caml_initialize (value *, value); +CAMLextern value caml_check_urgent_gc (value); +CAMLextern void * caml_stat_alloc (asize_t); /* Size in bytes. */ +CAMLextern void caml_stat_free (void *); +CAMLextern void * caml_stat_resize (void *, asize_t); /* Size in bytes. */ +CAMLextern int caml_init_alloc_for_heap (void); +CAMLextern char *caml_alloc_for_heap (asize_t request); /* Size in bytes. */ +CAMLextern void caml_free_for_heap (char *mem); +CAMLextern void caml_disown_for_heap (char *mem); +CAMLextern int caml_add_to_heap (char *mem); +CAMLextern color_t caml_allocation_color (void *hp); + +CAMLextern int caml_huge_fallback_count; + +/* void caml_shrink_heap (char *); Only used in compact.c */ + +#ifdef CAML_INTERNALS + +extern uintnat caml_use_huge_pages; + +#ifdef HAS_HUGE_PAGES +#include +#define Heap_page_size HUGE_PAGE_SIZE +#define Round_mmap_size(x) \ + (((x) + (Heap_page_size - 1)) & ~ (Heap_page_size - 1)) +#endif + + +int caml_page_table_add(int kind, void * start, void * end); +int caml_page_table_remove(int kind, void * start, void * end); +int caml_page_table_initialize(mlsize_t bytesize); + +#ifdef DEBUG +#define DEBUG_clear(result, wosize) do{ \ + uintnat caml__DEBUG_i; \ + for (caml__DEBUG_i = 0; caml__DEBUG_i < (wosize); ++ caml__DEBUG_i){ \ + Field ((result), caml__DEBUG_i) = Debug_uninit_minor; \ + } \ +}while(0) +#else +#define DEBUG_clear(result, wosize) +#endif + +#define Alloc_small_with_profinfo(result, wosize, tag, profinfo) do { \ + CAMLassert ((wosize) >= 1); \ + CAMLassert ((tag_t) (tag) < 256); \ + CAMLassert ((wosize) <= Max_young_wosize); \ + caml_young_ptr -= Whsize_wosize (wosize); \ + if (caml_young_ptr < caml_young_trigger){ \ + caml_young_ptr += Whsize_wosize (wosize); \ + CAML_INSTR_INT ("force_minor/alloc_small@", 1); \ + Setup_for_gc; \ + caml_gc_dispatch (); \ + Restore_after_gc; \ + caml_young_ptr -= Whsize_wosize (wosize); \ + } \ + Hd_hp (caml_young_ptr) = \ + Make_header_with_profinfo ((wosize), (tag), Caml_black, profinfo); \ + (result) = Val_hp (caml_young_ptr); \ + DEBUG_clear ((result), (wosize)); \ +}while(0) + +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) +extern uintnat caml_spacetime_my_profinfo(struct ext_table**, uintnat); +#define Alloc_small(result, wosize, tag) \ + Alloc_small_with_profinfo(result, wosize, tag, \ + caml_spacetime_my_profinfo(NULL, wosize)) +#else +#define Alloc_small(result, wosize, tag) \ + Alloc_small_with_profinfo(result, wosize, tag, (uintnat) 0) +#endif + +/* Deprecated alias for [caml_modify] */ + +#define Modify(fp,val) caml_modify((fp), (val)) + +#endif /* CAML_INTERNALS */ + +struct caml__roots_block { + struct caml__roots_block *next; + intnat ntables; + intnat nitems; + value *tables [5]; +}; + +CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ + +/* The following macros are used to declare C local variables and + function parameters of type [value]. + + The function body must start with one of the [CAMLparam] macros. + If the function has no parameter of type [value], use [CAMLparam0]. + If the function has 1 to 5 [value] parameters, use the corresponding + [CAMLparam] with the parameters as arguments. + If the function has more than 5 [value] parameters, use [CAMLparam5] + for the first 5 parameters, and one or more calls to the [CAMLxparam] + macros for the others. + If the function takes an array of [value]s as argument, use + [CAMLparamN] to declare it (or [CAMLxparamN] if you already have a + call to [CAMLparam] for some other arguments). + + If you need local variables of type [value], declare them with one + or more calls to the [CAMLlocal] macros at the beginning of the + function, after the call to CAMLparam. Use [CAMLlocalN] (at the + beginning of the function) to declare an array of [value]s. + + Your function may raise an exception or return a [value] with the + [CAMLreturn] macro. Its argument is simply the [value] returned by + your function. Do NOT directly return a [value] with the [return] + keyword. If your function returns void, use [CAMLreturn0]. If you + un-register the local roots (i.e. undo the effects of the [CAMLparam*] + and [CAMLlocal] macros) without returning immediately, use [CAMLdrop]. + + All the identifiers beginning with "caml__" are reserved by OCaml. + Do not use them for anything (local or global variables, struct or + union tags, macros, etc.) +*/ + +#define CAMLparam0() \ + struct caml__roots_block *caml__frame = caml_local_roots + +#define CAMLparam1(x) \ + CAMLparam0 (); \ + CAMLxparam1 (x) + +#define CAMLparam2(x, y) \ + CAMLparam0 (); \ + CAMLxparam2 (x, y) + +#define CAMLparam3(x, y, z) \ + CAMLparam0 (); \ + CAMLxparam3 (x, y, z) + +#define CAMLparam4(x, y, z, t) \ + CAMLparam0 (); \ + CAMLxparam4 (x, y, z, t) + +#define CAMLparam5(x, y, z, t, u) \ + CAMLparam0 (); \ + CAMLxparam5 (x, y, z, t, u) + +#define CAMLparamN(x, size) \ + CAMLparam0 (); \ + CAMLxparamN (x, (size)) + +/* CAMLunused is preserved for compatibility reasons. + Instead of the legacy GCC/Clang-only + CAMLunused foo; + you should prefer + CAMLunused_start foo CAMLunused_end; + which supports both GCC/Clang and MSVC. +*/ +#if defined(__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ > 7)) + #define CAMLunused_start __attribute__ ((unused)) + #define CAMLunused_end + #define CAMLunused __attribute__ ((unused)) +#elif _MSC_VER >= 1500 + #define CAMLunused_start __pragma( warning (push) ) \ + __pragma( warning (disable:4189 ) ) + #define CAMLunused_end __pragma( warning (pop)) + #define CAMLunused +#else + #define CAMLunused_start + #define CAMLunused_end + #define CAMLunused +#endif + +#define CAMLxparam1(x) \ + struct caml__roots_block caml__roots_##x; \ + CAMLunused_start int caml__dummy_##x = ( \ + (void) caml__frame, \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 1), \ + (caml__roots_##x.tables [0] = &x), \ + 0) \ + CAMLunused_end + +#define CAMLxparam2(x, y) \ + struct caml__roots_block caml__roots_##x; \ + CAMLunused_start int caml__dummy_##x = ( \ + (void) caml__frame, \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 2), \ + (caml__roots_##x.tables [0] = &x), \ + (caml__roots_##x.tables [1] = &y), \ + 0) \ + CAMLunused_end + +#define CAMLxparam3(x, y, z) \ + struct caml__roots_block caml__roots_##x; \ + CAMLunused_start int caml__dummy_##x = ( \ + (void) caml__frame, \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 3), \ + (caml__roots_##x.tables [0] = &x), \ + (caml__roots_##x.tables [1] = &y), \ + (caml__roots_##x.tables [2] = &z), \ + 0) \ + CAMLunused_end + +#define CAMLxparam4(x, y, z, t) \ + struct caml__roots_block caml__roots_##x; \ + CAMLunused_start int caml__dummy_##x = ( \ + (void) caml__frame, \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 4), \ + (caml__roots_##x.tables [0] = &x), \ + (caml__roots_##x.tables [1] = &y), \ + (caml__roots_##x.tables [2] = &z), \ + (caml__roots_##x.tables [3] = &t), \ + 0) \ + CAMLunused_end + +#define CAMLxparam5(x, y, z, t, u) \ + struct caml__roots_block caml__roots_##x; \ + CAMLunused_start int caml__dummy_##x = ( \ + (void) caml__frame, \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 5), \ + (caml__roots_##x.tables [0] = &x), \ + (caml__roots_##x.tables [1] = &y), \ + (caml__roots_##x.tables [2] = &z), \ + (caml__roots_##x.tables [3] = &t), \ + (caml__roots_##x.tables [4] = &u), \ + 0) \ + CAMLunused_end + +#define CAMLxparamN(x, size) \ + struct caml__roots_block caml__roots_##x; \ + CAMLunused_start int caml__dummy_##x = ( \ + (void) caml__frame, \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = (size)), \ + (caml__roots_##x.ntables = 1), \ + (caml__roots_##x.tables[0] = &(x[0])), \ + 0) \ + CAMLunused_end + +#define CAMLlocal1(x) \ + value x = Val_unit; \ + CAMLxparam1 (x) + +#define CAMLlocal2(x, y) \ + value x = Val_unit, y = Val_unit; \ + CAMLxparam2 (x, y) + +#define CAMLlocal3(x, y, z) \ + value x = Val_unit, y = Val_unit, z = Val_unit; \ + CAMLxparam3 (x, y, z) + +#define CAMLlocal4(x, y, z, t) \ + value x = Val_unit, y = Val_unit, z = Val_unit, t = Val_unit; \ + CAMLxparam4 (x, y, z, t) + +#define CAMLlocal5(x, y, z, t, u) \ + value x = Val_unit, y = Val_unit, z = Val_unit, t = Val_unit, u = Val_unit; \ + CAMLxparam5 (x, y, z, t, u) + +#define CAMLlocalN(x, size) \ + value x [(size)]; \ + int caml__i_##x; \ + for (caml__i_##x = 0; caml__i_##x < size; caml__i_##x ++) { \ + x[caml__i_##x] = Val_unit; \ + } \ + CAMLxparamN (x, (size)) + + +#define CAMLdrop caml_local_roots = caml__frame + +#define CAMLreturn0 do{ \ + CAMLdrop; \ + return; \ +}while (0) + +#define CAMLreturnT(type, result) do{ \ + type caml__temp_result = (result); \ + CAMLdrop; \ + return caml__temp_result; \ +}while(0) + +#define CAMLreturn(result) CAMLreturnT(value, result) + +#define CAMLnoreturn ((void) caml__frame) + + +/* convenience macro */ +#define Store_field(block, offset, val) do{ \ + mlsize_t caml__temp_offset = (offset); \ + value caml__temp_val = (val); \ + caml_modify (&Field ((block), caml__temp_offset), caml__temp_val); \ +}while(0) + +/* + NOTE: [Begin_roots] and [End_roots] are superseded by [CAMLparam]*, + [CAMLxparam]*, [CAMLlocal]*, [CAMLreturn]. + + [Begin_roots] and [End_roots] are used for C variables that are GC roots. + It must contain all values in C local variables and function parameters + at the time the minor GC is called. + Usage: + After initialising your local variables to legal OCaml values, but before + calling allocation functions, insert [Begin_roots_n(v1, ... vn)], where + v1 ... vn are your variables of type [value] that you want to be updated + across allocations. + At the end, insert [End_roots()]. + + Note that [Begin_roots] opens a new block, and [End_roots] closes it. + Thus they must occur in matching pairs at the same brace nesting level. + + You can use [Val_unit] as a dummy initial value for your variables. +*/ + +#define Begin_root Begin_roots1 + +#define Begin_roots1(r0) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 1; \ + caml__roots_block.tables[0] = &(r0); + +#define Begin_roots2(r0, r1) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 2; \ + caml__roots_block.tables[0] = &(r0); \ + caml__roots_block.tables[1] = &(r1); + +#define Begin_roots3(r0, r1, r2) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 3; \ + caml__roots_block.tables[0] = &(r0); \ + caml__roots_block.tables[1] = &(r1); \ + caml__roots_block.tables[2] = &(r2); + +#define Begin_roots4(r0, r1, r2, r3) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 4; \ + caml__roots_block.tables[0] = &(r0); \ + caml__roots_block.tables[1] = &(r1); \ + caml__roots_block.tables[2] = &(r2); \ + caml__roots_block.tables[3] = &(r3); + +#define Begin_roots5(r0, r1, r2, r3, r4) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 5; \ + caml__roots_block.tables[0] = &(r0); \ + caml__roots_block.tables[1] = &(r1); \ + caml__roots_block.tables[2] = &(r2); \ + caml__roots_block.tables[3] = &(r3); \ + caml__roots_block.tables[4] = &(r4); + +#define Begin_roots_block(table, size) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ + caml__roots_block.nitems = (size); \ + caml__roots_block.ntables = 1; \ + caml__roots_block.tables[0] = (table); + +#define End_roots() caml_local_roots = caml__roots_block.next; } + + +/* [caml_register_global_root] registers a global C variable as a memory root + for the duration of the program, or until [caml_remove_global_root] is + called. */ + +CAMLextern void caml_register_global_root (value *); + +/* [caml_remove_global_root] removes a memory root registered on a global C + variable with [caml_register_global_root]. */ + +CAMLextern void caml_remove_global_root (value *); + +/* [caml_register_generational_global_root] registers a global C + variable as a memory root for the duration of the program, or until + [caml_remove_generational_global_root] is called. + The program guarantees that the value contained in this variable + will not be assigned directly. If the program needs to change + the value of this variable, it must do so by calling + [caml_modify_generational_global_root]. The [value *] pointer + passed to [caml_register_generational_global_root] must contain + a valid OCaml value before the call. + In return for these constraints, scanning of memory roots during + minor collection is made more efficient. */ + +CAMLextern void caml_register_generational_global_root (value *); + +/* [caml_remove_generational_global_root] removes a memory root + registered on a global C variable with + [caml_register_generational_global_root]. */ + +CAMLextern void caml_remove_generational_global_root (value *); + +/* [caml_modify_generational_global_root(r, newval)] + modifies the value contained in [r], storing [newval] inside. + In other words, the assignment [*r = newval] is performed, + but in a way that is compatible with the optimized scanning of + generational global roots. [r] must be a global memory root + previously registered with [caml_register_generational_global_root]. */ + +CAMLextern void caml_modify_generational_global_root(value *r, value newval); + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_MEMORY_H */ diff -Nru ocaml-4.01.0/byterun/caml/minor_gc.h ocaml-4.05.0/byterun/caml/minor_gc.h --- ocaml-4.01.0/byterun/caml/minor_gc.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/minor_gc.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,119 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_MINOR_GC_H +#define CAML_MINOR_GC_H + + +#include "address_class.h" +#include "config.h" + +CAMLextern value *caml_young_start, *caml_young_end; +CAMLextern value *caml_young_alloc_start, *caml_young_alloc_end; +CAMLextern value *caml_young_ptr, *caml_young_limit; +CAMLextern value *caml_young_trigger; +extern asize_t caml_minor_heap_wsz; +extern int caml_in_minor_collection; + +#define CAML_TABLE_STRUCT(t) { \ + t *base; \ + t *end; \ + t *threshold; \ + t *ptr; \ + t *limit; \ + asize_t size; \ + asize_t reserve; \ +} + +struct caml_ref_table CAML_TABLE_STRUCT(value *); +CAMLextern struct caml_ref_table caml_ref_table; + +struct caml_ephe_ref_elt { + value ephe; /* an ephemeron in major heap */ + mlsize_t offset; /* the offset that points in the minor heap */ +}; + +struct caml_ephe_ref_table CAML_TABLE_STRUCT(struct caml_ephe_ref_elt); +CAMLextern struct caml_ephe_ref_table caml_ephe_ref_table; + +struct caml_custom_elt { + value block; /* The finalized block in the minor heap. */ + mlsize_t mem; /* The parameters for adjusting GC speed. */ + mlsize_t max; +}; + +struct caml_custom_table CAML_TABLE_STRUCT(struct caml_custom_elt); +CAMLextern struct caml_custom_table caml_custom_table; + +extern void caml_set_minor_heap_size (asize_t); /* size in bytes */ +extern void caml_empty_minor_heap (void); +CAMLextern void caml_gc_dispatch (void); +CAMLextern void garbage_collection (void); /* def in asmrun/signals_asm.c */ +extern void caml_realloc_ref_table (struct caml_ref_table *); +extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t); +extern void caml_realloc_ephe_ref_table (struct caml_ephe_ref_table *); +extern void caml_alloc_ephe_table (struct caml_ephe_ref_table *, + asize_t, asize_t); +extern void caml_realloc_custom_table (struct caml_custom_table *); +extern void caml_alloc_custom_table (struct caml_custom_table *, + asize_t, asize_t); +extern void caml_oldify_one (value, value *); +extern void caml_oldify_mopup (void); + +#define Oldify(p) do{ \ + value __oldify__v__ = *p; \ + if (Is_block (__oldify__v__) && Is_young (__oldify__v__)){ \ + caml_oldify_one (__oldify__v__, (p)); \ + } \ + }while(0) + +static inline void add_to_ref_table (struct caml_ref_table *tbl, value *p) +{ + if (tbl->ptr >= tbl->limit){ + CAMLassert (tbl->ptr == tbl->limit); + caml_realloc_ref_table (tbl); + } + *tbl->ptr++ = p; +} + +static inline void add_to_ephe_ref_table (struct caml_ephe_ref_table *tbl, + value ar, mlsize_t offset) +{ + struct caml_ephe_ref_elt *ephe_ref; + if (tbl->ptr >= tbl->limit){ + CAMLassert (tbl->ptr == tbl->limit); + caml_realloc_ephe_ref_table (tbl); + } + ephe_ref = tbl->ptr++; + ephe_ref->ephe = ar; + ephe_ref->offset = offset; + Assert(ephe_ref->offset < Wosize_val(ephe_ref->ephe)); +} + +static inline void add_to_custom_table (struct caml_custom_table *tbl, value v, + mlsize_t mem, mlsize_t max) +{ + struct caml_custom_elt *elt; + if (tbl->ptr >= tbl->limit){ + CAMLassert (tbl->ptr == tbl->limit); + caml_realloc_custom_table (tbl); + } + elt = tbl->ptr++; + elt->block = v; + elt->mem = mem; + elt->max = max; +} + +#endif /* CAML_MINOR_GC_H */ diff -Nru ocaml-4.01.0/byterun/caml/misc.h ocaml-4.05.0/byterun/caml/misc.h --- ocaml-4.01.0/byterun/caml/misc.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/misc.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,413 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Miscellaneous macros and variables. */ + +#ifndef CAML_MISC_H +#define CAML_MISC_H + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "config.h" + +/* Standard definitions */ + +#include +#include + +/* Basic types and constants */ + +typedef size_t asize_t; + +#ifndef NULL +#define NULL 0 +#endif + +#ifdef CAML_INTERNALS +typedef char * addr; +#endif /* CAML_INTERNALS */ + +/* Noreturn is preserved for compatibility reasons. + Instead of the legacy GCC/Clang-only + foo Noreturn; + you should prefer + CAMLnoreturn_start foo CAMLnoreturn_end; + which supports both GCC/Clang and MSVC. + + Note: CAMLnoreturn is a different macro defined in memory.h, + to be used in function bodies rather than aprototype attribute. +*/ +#ifdef __GNUC__ + /* Works only in GCC 2.5 and later */ + #define CAMLnoreturn_start + #define CAMLnoreturn_end __attribute__ ((noreturn)) + #define Noreturn __attribute__ ((noreturn)) +#elif _MSC_VER >= 1500 + #define CAMLnoreturn_start __declspec(noreturn) + #define CAMLnoreturn_end + #define Noreturn +#else + #define CAMLnoreturn_start + #define CAMLnoreturn_end + #define Noreturn +#endif + + + +/* Export control (to mark primitives and to handle Windows DLL) */ + +#define CAMLexport +#define CAMLprim +#define CAMLextern extern + +/* Weak function definitions that can be overriden by external libs */ +/* Conservatively restricted to ELF and MacOSX platforms */ +#if defined(__GNUC__) && (defined (__ELF__) || defined(__APPLE__)) +#define CAMLweakdef __attribute__((weak)) +#else +#define CAMLweakdef +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +/* GC timing hooks. These can be assigned by the user. + [caml_minor_gc_begin_hook] must not allocate nor change any heap value. + The others can allocate and even call back to OCaml code. +*/ +typedef void (*caml_timing_hook) (void); +extern caml_timing_hook caml_major_slice_begin_hook, caml_major_slice_end_hook; +extern caml_timing_hook caml_minor_gc_begin_hook, caml_minor_gc_end_hook; +extern caml_timing_hook caml_finalise_begin_hook, caml_finalise_end_hook; + +/* Assertions */ + +#ifdef DEBUG +#define CAMLassert(x) \ + ((x) ? (void) 0 : caml_failed_assert ( #x , __FILE__, __LINE__)) +CAMLnoreturn_start +CAMLextern int caml_failed_assert (char *, char *, int) +CAMLnoreturn_end; +#else +#define CAMLassert(x) ((void) 0) +#endif + +CAMLnoreturn_start +CAMLextern void caml_fatal_error (char *msg) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_fatal_error_arg (char *fmt, char *arg) +CAMLnoreturn_end; + +CAMLnoreturn_start +CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1, + char *fmt2, char *arg2) +CAMLnoreturn_end; + +/* Safe string operations */ + +CAMLextern char * caml_strdup(const char * s); +CAMLextern char * caml_strconcat(int n, ...); /* n args of const char * type */ + +/* Use macros for some system calls being called from OCaml itself. + These calls can be either traced for security reasons, or changed to + virtualize the program. */ + + +#ifndef CAML_WITH_CPLUGINS + +#define CAML_SYS_EXIT(retcode) exit(retcode) +#define CAML_SYS_OPEN(filename,flags,perm) open(filename,flags,perm) +#define CAML_SYS_CLOSE(fd) close(fd) +#define CAML_SYS_STAT(filename,st) stat(filename,st) +#define CAML_SYS_UNLINK(filename) unlink(filename) +#define CAML_SYS_RENAME(old_name,new_name) rename(old_name, new_name) +#define CAML_SYS_CHDIR(dirname) chdir(dirname) +#define CAML_SYS_GETENV(varname) getenv(varname) +#define CAML_SYS_SYSTEM(command) system(command) +#define CAML_SYS_READ_DIRECTORY(dirname,tbl) caml_read_directory(dirname,tbl) + +#else + + +#define CAML_CPLUGINS_EXIT 0 +#define CAML_CPLUGINS_OPEN 1 +#define CAML_CPLUGINS_CLOSE 2 +#define CAML_CPLUGINS_STAT 3 +#define CAML_CPLUGINS_UNLINK 4 +#define CAML_CPLUGINS_RENAME 5 +#define CAML_CPLUGINS_CHDIR 6 +#define CAML_CPLUGINS_GETENV 7 +#define CAML_CPLUGINS_SYSTEM 8 +#define CAML_CPLUGINS_READ_DIRECTORY 9 +#define CAML_CPLUGINS_PRIMS_MAX 9 + +#define CAML_CPLUGINS_PRIMS_BITMAP ((1 << CAML_CPLUGINS_PRIMS_MAX)-1) + +extern intnat (*caml_cplugins_prim)(int,intnat,intnat,intnat); + +#define CAML_SYS_PRIM_1(code,prim,arg1) \ + (caml_cplugins_prim == NULL) ? prim(arg1) : \ + caml_cplugins_prim(code,(intnat) (arg1),0,0) +#define CAML_SYS_STRING_PRIM_1(code,prim,arg1) \ + (caml_cplugins_prim == NULL) ? prim(arg1) : \ + (char*)caml_cplugins_prim(code,(intnat) (arg1),0,0) +#define CAML_SYS_VOID_PRIM_1(code,prim,arg1) \ + (caml_cplugins_prim == NULL) ? prim(arg1) : \ + (void)caml_cplugins_prim(code,(intnat) (arg1),0,0) +#define CAML_SYS_PRIM_2(code,prim,arg1,arg2) \ + (caml_cplugins_prim == NULL) ? prim(arg1,arg2) : \ + caml_cplugins_prim(code,(intnat) (arg1), (intnat) (arg2),0) +#define CAML_SYS_PRIM_3(code,prim,arg1,arg2,arg3) \ + (caml_cplugins_prim == NULL) ? prim(arg1,arg2,arg3) : \ + caml_cplugins_prim(code,(intnat) (arg1), (intnat) (arg2),(intnat) (arg3)) + +#define CAML_SYS_EXIT(retcode) \ + CAML_SYS_VOID_PRIM_1(CAML_CPLUGINS_EXIT,exit,retcode) +#define CAML_SYS_OPEN(filename,flags,perm) \ + CAML_SYS_PRIM_3(CAML_CPLUGINS_OPEN,open,filename,flags,perm) +#define CAML_SYS_CLOSE(fd) \ + CAML_SYS_PRIM_1(CAML_CPLUGINS_CLOSE,close,fd) +#define CAML_SYS_STAT(filename,st) \ + CAML_SYS_PRIM_2(CAML_CPLUGINS_STAT,stat,filename,st) +#define CAML_SYS_UNLINK(filename) \ + CAML_SYS_PRIM_1(CAML_CPLUGINS_UNLINK,unlink,filename) +#define CAML_SYS_RENAME(old_name,new_name) \ + CAML_SYS_PRIM_2(CAML_CPLUGINS_RENAME,rename,old_name,new_name) +#define CAML_SYS_CHDIR(dirname) \ + CAML_SYS_PRIM_1(CAML_CPLUGINS_CHDIR,chdir,dirname) +#define CAML_SYS_GETENV(varname) \ + CAML_SYS_STRING_PRIM_1(CAML_CPLUGINS_GETENV,getenv,varname) +#define CAML_SYS_SYSTEM(command) \ + CAML_SYS_PRIM_1(CAML_CPLUGINS_SYSTEM,system,command) +#define CAML_SYS_READ_DIRECTORY(dirname,tbl) \ + CAML_SYS_PRIM_2(CAML_CPLUGINS_READ_DIRECTORY,caml_read_directory, \ + dirname,tbl) + +#define CAML_CPLUGIN_CONTEXT_API 0 + +struct cplugin_context { + int api_version; + int prims_bitmap; + char *exe_name; + char** argv; + char *plugin; /* absolute filename of plugin, do a copy if you need it ! */ + char *ocaml_version; +/* end of CAML_CPLUGIN_CONTEXT_API version 0 */ +}; + +extern void caml_cplugins_init(char * exe_name, char **argv); + +/* A plugin MUST define a symbol "caml_cplugin_init" with the prototype: + +void caml_cplugin_init(struct cplugin_context *ctx) +*/ + +/* to write plugins for CAML_SYS_READ_DIRECTORY, we will need the + definition of struct ext_table to be public. */ + +#endif /* CAML_WITH_CPLUGINS */ + +/* Data structures */ + +struct ext_table { + int size; + int capacity; + void ** contents; +}; + +extern void caml_ext_table_init(struct ext_table * tbl, int init_capa); +extern int caml_ext_table_add(struct ext_table * tbl, void * data); +extern void caml_ext_table_remove(struct ext_table * tbl, void * data); +extern void caml_ext_table_free(struct ext_table * tbl, int free_entries); +extern void caml_ext_table_clear(struct ext_table * tbl, int free_entries); + +CAMLextern int caml_read_directory(char * dirname, struct ext_table * contents); + + +#ifdef CAML_INTERNALS + +/* GC flags and messages */ + +extern uintnat caml_verb_gc; +void caml_gc_message (int, char *, uintnat); + +/* Runtime warnings */ +extern uintnat caml_runtime_warnings; +int caml_runtime_warnings_active(void); + +/* Memory routines */ + +char *caml_aligned_malloc (asize_t bsize, int, void **); + +#ifdef DEBUG +#ifdef ARCH_SIXTYFOUR +#define Debug_tag(x) (0xD700D7D7D700D6D7ul \ + | ((uintnat) (x) << 16) \ + | ((uintnat) (x) << 48)) +#else +#define Debug_tag(x) (0xD700D6D7ul | ((uintnat) (x) << 16)) +#endif /* ARCH_SIXTYFOUR */ + +/* + 00 -> free words in minor heap + 01 -> fields of free list blocks in major heap + 03 -> heap chunks deallocated by heap shrinking + 04 -> fields deallocated by [caml_obj_truncate] + 10 -> uninitialised fields of minor objects + 11 -> uninitialised fields of major objects + 15 -> uninitialised words of [caml_aligned_malloc] blocks + 85 -> filler bytes of [caml_aligned_malloc] + + special case (byte by byte): + D7 -> uninitialised words of [caml_stat_alloc] blocks +*/ +#define Debug_free_minor Debug_tag (0x00) +#define Debug_free_major Debug_tag (0x01) +#define Debug_free_shrink Debug_tag (0x03) +#define Debug_free_truncate Debug_tag (0x04) +#define Debug_uninit_minor Debug_tag (0x10) +#define Debug_uninit_major Debug_tag (0x11) +#define Debug_uninit_align Debug_tag (0x15) +#define Debug_filler_align Debug_tag (0x85) + +#define Debug_uninit_stat 0xD7 + +/* Note: the first argument is in fact a [value] but we don't have this + type available yet because we can't include [mlvalues.h] in this file. +*/ +extern void caml_set_fields (intnat v, unsigned long, unsigned long); +#endif /* DEBUG */ + + +#ifndef CAML_AVOID_CONFLICTS +#define Assert CAMLassert +#endif + +/* snprintf emulation for Win32 */ + +#if defined(_WIN32) && !defined(_UCRT) +extern int caml_snprintf(char * buf, size_t size, const char * format, ...); +#define snprintf caml_snprintf +#endif + +#ifdef CAML_INSTR +/* Timers and counters for GC latency profiling (Linux-only) */ + +#include +#include + +extern intnat caml_stat_minor_collections; +extern intnat CAML_INSTR_STARTTIME, CAML_INSTR_STOPTIME; + +struct CAML_INSTR_BLOCK { + struct timespec ts[10]; + char *tag[10]; + int index; + struct CAML_INSTR_BLOCK *next; +}; + +extern struct CAML_INSTR_BLOCK *CAML_INSTR_LOG; + +/* Declare a timer/counter name. [t] must be a new variable name. */ +#define CAML_INSTR_DECLARE(t) \ + struct CAML_INSTR_BLOCK *t = NULL + +/* Allocate the data block for a given name. + [t] must have been declared with [CAML_INSTR_DECLARE]. */ +#define CAML_INSTR_ALLOC(t) do{ \ + if (caml_stat_minor_collections >= CAML_INSTR_STARTTIME \ + && caml_stat_minor_collections < CAML_INSTR_STOPTIME){ \ + t = malloc (sizeof (struct CAML_INSTR_BLOCK)); \ + t->index = 0; \ + t->tag[0] = ""; \ + t->next = CAML_INSTR_LOG; \ + CAML_INSTR_LOG = t; \ + } \ + }while(0) + +/* Allocate the data block and start the timer. + [t] must have been declared with [CAML_INSTR_DECLARE] + and allocated with [CAML_INSTR_ALLOC]. */ +#define CAML_INSTR_START(t, msg) do{ \ + if (t != NULL){ \ + t->tag[0] = msg; \ + clock_gettime (CLOCK_REALTIME, &(t->ts[0])); \ + } \ + }while(0) + +/* Declare a timer, allocate its data, and start it. + [t] must be a new variable name. */ +#define CAML_INSTR_SETUP(t, msg) \ + CAML_INSTR_DECLARE (t); \ + CAML_INSTR_ALLOC (t); \ + CAML_INSTR_START (t, msg) + +/* Record an intermediate time within a given timer. + [t] must have been declared, allocated, and started. */ +#define CAML_INSTR_TIME(t, msg) do{ \ + if (t != NULL){ \ + ++ t->index; \ + t->tag[t->index] = (msg); \ + clock_gettime (CLOCK_REALTIME, &(t->ts[t->index])); \ + } \ + }while(0) + +/* Record an integer data point. + If [msg] ends with # it will be interpreted as an integer-valued event. + If it ends with @ it will be interpreted as an event counter. +*/ +#define CAML_INSTR_INT(msg, data) do{ \ + CAML_INSTR_SETUP (__caml_tmp, ""); \ + if (__caml_tmp != NULL){ \ + __caml_tmp->index = 1; \ + __caml_tmp->tag[1] = msg; \ + __caml_tmp->ts[1].tv_sec = 0; \ + __caml_tmp->ts[1].tv_nsec = (data); \ + } \ + }while(0) + +/* This function is called at the start of the program to set up + the data for the above macros. +*/ +extern void CAML_INSTR_INIT (void); + +/* This function is automatically called by the runtime to output + the collected data to the dump file. */ +extern void CAML_INSTR_ATEXIT (void); + +#else /* CAML_INSTR */ + +#define CAML_INSTR_DECLARE(t) /**/ +#define CAML_INSTR_ALLOC(t) /**/ +#define CAML_INSTR_START(t, name) /**/ +#define CAML_INSTR_SETUP(t, name) /**/ +#define CAML_INSTR_TIME(t, msg) /**/ +#define CAML_INSTR_INT(msg, c) /**/ +#define CAML_INSTR_INIT() /**/ +#define CAML_INSTR_ATEXIT() /**/ + +#endif /* CAML_INSTR */ + +#endif /* CAML_INTERNALS */ + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_MISC_H */ diff -Nru ocaml-4.01.0/byterun/caml/mlvalues.h ocaml-4.05.0/byterun/caml/mlvalues.h --- ocaml-4.01.0/byterun/caml/mlvalues.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/mlvalues.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,336 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_MLVALUES_H +#define CAML_MLVALUES_H + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "config.h" +#include "misc.h" + +#ifdef __cplusplus +extern "C" { +#endif + +/* Definitions + + word: Four bytes on 32 and 16 bit architectures, + eight bytes on 64 bit architectures. + long: A C integer having the same number of bytes as a word. + val: The ML representation of something. A long or a block or a pointer + outside the heap. If it is a block, it is the (encoded) address + of an object. If it is a long, it is encoded as well. + block: Something allocated. It always has a header and some + fields or some number of bytes (a multiple of the word size). + field: A word-sized val which is part of a block. + bp: Pointer to the first byte of a block. (a char *) + op: Pointer to the first field of a block. (a value *) + hp: Pointer to the header of a block. (a char *) + int32_t: Four bytes on all architectures. + int64_t: Eight bytes on all architectures. + + Remark: A block size is always a multiple of the word size, and at least + one word plus the header. + + bosize: Size (in bytes) of the "bytes" part. + wosize: Size (in words) of the "fields" part. + bhsize: Size (in bytes) of the block with its header. + whsize: Size (in words) of the block with its header. + + hd: A header. + tag: The value of the tag field of the header. + color: The value of the color field of the header. + This is for use only by the GC. +*/ + +typedef intnat value; +typedef uintnat header_t; +typedef uintnat mlsize_t; +typedef unsigned int tag_t; /* Actually, an unsigned char */ +typedef uintnat color_t; +typedef uintnat mark_t; + +/* Longs vs blocks. */ +#define Is_long(x) (((x) & 1) != 0) +#define Is_block(x) (((x) & 1) == 0) + +/* Conversion macro names are always of the form "to_from". */ +/* Example: Val_long as in "Val from long" or "Val of long". */ +#define Val_long(x) ((intnat) (((uintnat)(x) << 1)) + 1) +#define Long_val(x) ((x) >> 1) +#define Max_long (((intnat)1 << (8 * sizeof(value) - 2)) - 1) +#define Min_long (-((intnat)1 << (8 * sizeof(value) - 2))) +#define Val_int(x) Val_long(x) +#define Int_val(x) ((int) Long_val(x)) +#define Unsigned_long_val(x) ((uintnat)(x) >> 1) +#define Unsigned_int_val(x) ((int) Unsigned_long_val(x)) + +/* Structure of the header: + +For 16-bit and 32-bit architectures: + +--------+-------+-----+ + | wosize | color | tag | + +--------+-------+-----+ +bits 31 10 9 8 7 0 + +For 64-bit architectures: + + +--------+-------+-----+ + | wosize | color | tag | + +--------+-------+-----+ +bits 63 10 9 8 7 0 + +For x86-64 with Spacetime profiling: + P = PROFINFO_WIDTH (as set by "configure", currently 26 bits, giving a + maximum block size of just under 4Gb) + +----------------+----------------+-------------+ + | profiling info | wosize | color | tag | + +----------------+----------------+-------------+ +bits 63 (64-P) (63-P) 10 9 8 7 0 + +*/ + +#define PROFINFO_SHIFT (64 - PROFINFO_WIDTH) +#define PROFINFO_MASK ((1ull << PROFINFO_WIDTH) - 1ull) + +#define Tag_hd(hd) ((tag_t) ((hd) & 0xFF)) +#ifdef WITH_PROFINFO +#define Hd_no_profinfo(hd) ((hd) & ~(PROFINFO_MASK << PROFINFO_SHIFT)) +#define Wosize_hd(hd) ((mlsize_t) ((Hd_no_profinfo(hd)) >> 10)) +#else +#define Wosize_hd(hd) ((mlsize_t) ((hd) >> 10)) +#endif /* WITH_PROFINFO */ +#if defined(ARCH_SIXTYFOUR) && defined(WITH_PROFINFO) +/* [Profinfo_hd] is used when the compiler is not configured for Spacetime + (e.g. when decoding profiles). */ +#define Profinfo_hd(hd) (((mlsize_t) ((hd) >> PROFINFO_SHIFT)) & PROFINFO_MASK) +#else +#define Profinfo_hd(hd) ((hd) & 0) +#endif /* ARCH_SIXTYFOUR && WITH_PROFINFO */ + +#define Hd_val(val) (((header_t *) (val)) [-1]) /* Also an l-value. */ +#define Hd_op(op) (Hd_val (op)) /* Also an l-value. */ +#define Hd_bp(bp) (Hd_val (bp)) /* Also an l-value. */ +#define Hd_hp(hp) (* ((header_t *) (hp))) /* Also an l-value. */ +#define Hp_val(val) (((header_t *) (val)) - 1) +#define Hp_op(op) (Hp_val (op)) +#define Hp_bp(bp) (Hp_val (bp)) +#define Val_op(op) ((value) (op)) +#define Val_hp(hp) ((value) (((header_t *) (hp)) + 1)) +#define Op_hp(hp) ((value *) Val_hp (hp)) +#define Bp_hp(hp) ((char *) Val_hp (hp)) + +#define Num_tags (1 << 8) +#ifdef ARCH_SIXTYFOUR +#define Max_wosize (((intnat)1 << (54-PROFINFO_WIDTH)) - 1) +#else +#define Max_wosize ((1 << 22) - 1) +#endif /* ARCH_SIXTYFOUR */ + +#define Wosize_val(val) (Wosize_hd (Hd_val (val))) +#define Wosize_op(op) (Wosize_val (op)) +#define Wosize_bp(bp) (Wosize_val (bp)) +#define Wosize_hp(hp) (Wosize_hd (Hd_hp (hp))) +#define Whsize_wosize(sz) ((sz) + 1) +#define Wosize_whsize(sz) ((sz) - 1) +#define Wosize_bhsize(sz) ((sz) / sizeof (value) - 1) +#define Bsize_wsize(sz) ((sz) * sizeof (value)) +#define Wsize_bsize(sz) ((sz) / sizeof (value)) +#define Bhsize_wosize(sz) (Bsize_wsize (Whsize_wosize (sz))) +#define Bhsize_bosize(sz) ((sz) + sizeof (header_t)) +#define Bosize_val(val) (Bsize_wsize (Wosize_val (val))) +#define Bosize_op(op) (Bosize_val (Val_op (op))) +#define Bosize_bp(bp) (Bosize_val (Val_bp (bp))) +#define Bosize_hd(hd) (Bsize_wsize (Wosize_hd (hd))) +#define Whsize_hp(hp) (Whsize_wosize (Wosize_hp (hp))) +#define Whsize_val(val) (Whsize_hp (Hp_val (val))) +#define Whsize_bp(bp) (Whsize_val (Val_bp (bp))) +#define Whsize_hd(hd) (Whsize_wosize (Wosize_hd (hd))) +#define Bhsize_hp(hp) (Bsize_wsize (Whsize_hp (hp))) +#define Bhsize_hd(hd) (Bsize_wsize (Whsize_hd (hd))) + +#define Profinfo_val(val) (Profinfo_hd (Hd_val (val))) + +#ifdef ARCH_BIG_ENDIAN +#define Tag_val(val) (((unsigned char *) (val)) [-1]) + /* Also an l-value. */ +#define Tag_hp(hp) (((unsigned char *) (hp)) [sizeof(value)-1]) + /* Also an l-value. */ +#else +#define Tag_val(val) (((unsigned char *) (val)) [-sizeof(value)]) + /* Also an l-value. */ +#define Tag_hp(hp) (((unsigned char *) (hp)) [0]) + /* Also an l-value. */ +#endif + +/* The lowest tag for blocks containing no value. */ +#define No_scan_tag 251 + + +/* 1- If tag < No_scan_tag : a tuple of fields. */ + +/* Pointer to the first field. */ +#define Op_val(x) ((value *) (x)) +/* Fields are numbered from 0. */ +#define Field(x, i) (((value *)(x)) [i]) /* Also an l-value. */ + +typedef int32_t opcode_t; +typedef opcode_t * code_t; + +/* NOTE: [Forward_tag] and [Infix_tag] must be just under + [No_scan_tag], with [Infix_tag] the lower one. + See [caml_oldify_one] in minor_gc.c for more details. + + NOTE: Update stdlib/obj.ml whenever you change the tags. + */ + +/* Forward_tag: forwarding pointer that the GC may silently shortcut. + See stdlib/lazy.ml. */ +#define Forward_tag 250 +#define Forward_val(v) Field(v, 0) + +/* If tag == Infix_tag : an infix header inside a closure */ +/* Infix_tag must be odd so that the infix header is scanned as an integer */ +/* Infix_tag must be 1 modulo 4 and infix headers can only occur in blocks + with tag Closure_tag (see compact.c). */ + +#define Infix_tag 249 +#define Infix_offset_hd(hd) (Bosize_hd(hd)) +#define Infix_offset_val(v) Infix_offset_hd(Hd_val(v)) + +/* Another special case: objects */ +#define Object_tag 248 +#define Class_val(val) Field((val), 0) +#define Oid_val(val) Long_val(Field((val), 1)) +CAMLextern value caml_get_public_method (value obj, value tag); +/* Called as: + caml_callback(caml_get_public_method(obj, caml_hash_variant(name)), obj) */ +/* caml_get_public_method returns 0 if tag not in the table. + Note however that tags being hashed, same tag does not necessarily mean + same method name. */ + +/* Special case of tuples of fields: closures */ +#define Closure_tag 247 +#define Code_val(val) (((code_t *) (val)) [0]) /* Also an l-value. */ + +/* This tag is used (with Forward_tag) to implement lazy values. + See major_gc.c and stdlib/lazy.ml. */ +#define Lazy_tag 246 + +/* Another special case: variants */ +CAMLextern value caml_hash_variant(char const * tag); + +/* 2- If tag >= No_scan_tag : a sequence of bytes. */ + +/* Pointer to the first byte */ +#define Bp_val(v) ((char *) (v)) +#define Val_bp(p) ((value) (p)) +/* Bytes are numbered from 0. */ +#define Byte(x, i) (((char *) (x)) [i]) /* Also an l-value. */ +#define Byte_u(x, i) (((unsigned char *) (x)) [i]) /* Also an l-value. */ + +/* Abstract things. Their contents is not traced by the GC; therefore they + must not contain any [value]. Must have odd number so that headers with + this tag cannot be mistaken for pointers (see caml_obj_truncate). +*/ +#define Abstract_tag 251 +#define Data_abstract_val(v) ((void*) Op_val(v)) + +/* Strings. */ +#define String_tag 252 +#define String_val(x) ((char *) Bp_val(x)) +CAMLextern mlsize_t caml_string_length (value); /* size in bytes */ +CAMLextern int caml_string_is_c_safe (value); + /* true if string contains no '\0' null characters */ + +/* Floating-point numbers. */ +#define Double_tag 253 +#define Double_wosize ((sizeof(double) / sizeof(value))) +#ifndef ARCH_ALIGN_DOUBLE +#define Double_val(v) (* (double *)(v)) +#define Store_double_val(v,d) (* (double *)(v) = (d)) +#else +CAMLextern double caml_Double_val (value); +CAMLextern void caml_Store_double_val (value,double); +#define Double_val(v) caml_Double_val(v) +#define Store_double_val(v,d) caml_Store_double_val(v,d) +#endif + +/* Arrays of floating-point numbers. */ +#define Double_array_tag 254 +#define Double_field(v,i) Double_val((value)((double *)(v) + (i))) +#define Store_double_field(v,i,d) do{ \ + mlsize_t caml__temp_i = (i); \ + double caml__temp_d = (d); \ + Store_double_val((value)((double *) (v) + caml__temp_i), caml__temp_d); \ +}while(0) +CAMLextern mlsize_t caml_array_length (value); /* size in items */ +CAMLextern int caml_is_double_array (value); /* 0 is false, 1 is true */ + + +/* Custom blocks. They contain a pointer to a "method suite" + of functions (for finalization, comparison, hashing, etc) + followed by raw data. The contents of custom blocks is not traced by + the GC; therefore, they must not contain any [value]. + See [custom.h] for operations on method suites. */ +#define Custom_tag 255 +#define Data_custom_val(v) ((void *) &Field((v), 1)) +struct custom_operations; /* defined in [custom.h] */ + +/* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */ + +#define Int32_val(v) (*((int32_t *) Data_custom_val(v))) +#define Nativeint_val(v) (*((intnat *) Data_custom_val(v))) +#ifndef ARCH_ALIGN_INT64 +#define Int64_val(v) (*((int64_t *) Data_custom_val(v))) +#else +CAMLextern int64_t caml_Int64_val(value v); +#define Int64_val(v) caml_Int64_val(v) +#endif + +/* 3- Atoms are 0-tuples. They are statically allocated once and for all. */ + +CAMLextern header_t caml_atom_table[]; +#define Atom(tag) (Val_hp (&(caml_atom_table [(tag)]))) + +/* Booleans are integers 0 or 1 */ + +#define Val_bool(x) Val_int((x) != 0) +#define Bool_val(x) Int_val(x) +#define Val_false Val_int(0) +#define Val_true Val_int(1) +#define Val_not(x) (Val_false + Val_true - (x)) + +/* The unit value is 0 (tagged) */ + +#define Val_unit Val_int(0) + +/* List constructors */ +#define Val_emptylist Val_int(0) +#define Tag_cons 0 + +/* The table of global identifiers */ + +extern value caml_global_data; + +CAMLextern value caml_set_oo_id(value obj); + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_MLVALUES_H */ diff -Nru ocaml-4.01.0/byterun/caml/osdeps.h ocaml-4.05.0/byterun/caml/osdeps.h --- ocaml-4.01.0/byterun/caml/osdeps.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/osdeps.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,96 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Operating system - specific stuff */ + +#ifndef CAML_OSDEPS_H +#define CAML_OSDEPS_H + +#ifdef CAML_INTERNALS + +#include "misc.h" + +/* Read at most [n] bytes from file descriptor [fd] into buffer [buf]. + [flags] indicates whether [fd] is a socket + (bit [CHANNEL_FLAG_FROM_SOCKET] is set in this case, see [io.h]). + (This distinction matters for Win32, but not for Unix.) + Return number of bytes read. + In case of error, raises [Sys_error] or [Sys_blocked_io]. */ +extern int caml_read_fd(int fd, int flags, void * buf, int n); + +/* Write at most [n] bytes from buffer [buf] onto file descriptor [fd]. + [flags] indicates whether [fd] is a socket + (bit [CHANNEL_FLAG_FROM_SOCKET] is set in this case, see [io.h]). + (This distinction matters for Win32, but not for Unix.) + Return number of bytes written. + In case of error, raises [Sys_error] or [Sys_blocked_io]. */ +extern int caml_write_fd(int fd, int flags, void * buf, int n); + +/* Decompose the given path into a list of directories, and add them + to the given table. Return the block to be freed later. */ +extern char * caml_decompose_path(struct ext_table * tbl, char * path); + +/* Search the given file in the given list of directories. + If not found, return a copy of [name]. Result is allocated with + [caml_stat_alloc]. */ +extern char * caml_search_in_path(struct ext_table * path, char * name); + +/* Same, but search an executable name in the system path for executables. */ +CAMLextern char * caml_search_exe_in_path(char * name); + +/* Same, but search a shared library in the given path. */ +extern char * caml_search_dll_in_path(struct ext_table * path, char * name); + +/* Open a shared library and return a handle on it. + If [for_execution] is true, perform full symbol resolution and + execute initialization code so that functions from the shared library + can be called. If [for_execution] is false, functions from this + shared library will not be called, but just checked for presence, + so symbol resolution can be skipped. + If [global] is true, symbols from the shared library can be used + to resolve for other libraries to be opened later on. + Return [NULL] on error. */ +extern void * caml_dlopen(char * libname, int for_execution, int global); + +/* Close a shared library handle */ +extern void caml_dlclose(void * handle); + +/* Look up the given symbol in the given shared library. + Return [NULL] if not found, or symbol value if found. */ +extern void * caml_dlsym(void * handle, char * name); + +extern void * caml_globalsym(char * name); + +/* Return an error message describing the most recent dynlink failure. */ +extern char * caml_dlerror(void); + +/* Add to [contents] the (short) names of the files contained in + the directory named [dirname]. No entries are added for [.] and [..]. + Return 0 on success, -1 on error; set errno in the case of error. */ +extern int caml_read_directory(char * dirname, struct ext_table * contents); + +/* Recover executable name if possible (/proc/sef/exe under Linux, + GetModuleFileName under Windows). Return NULL on error, + string allocated with [caml_stat_alloc] on success. */ +extern char * caml_executable_name(void); + +/* Secure version of [getenv]: returns NULL if the process has special + privileges (setuid bit, setgid bit, capabilities). +*/ +extern char *caml_secure_getenv(char const *var); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_OSDEPS_H */ diff -Nru ocaml-4.01.0/byterun/caml/prims.h ocaml-4.05.0/byterun/caml/prims.h --- ocaml-4.01.0/byterun/caml/prims.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/prims.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,40 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Interface with C primitives. */ + +#ifndef CAML_PRIMS_H +#define CAML_PRIMS_H + +#ifdef CAML_INTERNALS + +typedef value (*c_primitive)(); + +extern c_primitive caml_builtin_cprim[]; +extern char * caml_names_of_builtin_cprim[]; + +extern struct ext_table caml_prim_table; +#ifdef DEBUG +extern struct ext_table caml_prim_name_table; +#endif + +#define Primitive(n) ((c_primitive)(caml_prim_table.contents[n])) + +extern char * caml_section_table; +extern asize_t caml_section_table_size; + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_PRIMS_H */ diff -Nru ocaml-4.01.0/byterun/caml/printexc.h ocaml-4.05.0/byterun/caml/printexc.h --- ocaml-4.01.0/byterun/caml/printexc.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/printexc.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,35 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_PRINTEXC_H +#define CAML_PRINTEXC_H + + +#include "misc.h" +#include "mlvalues.h" + +#ifdef __cplusplus +extern "C" { +#endif + + +CAMLextern char * caml_format_exception (value); +CAMLnoreturn_start void caml_fatal_uncaught_exception (value) CAMLnoreturn_end; + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_PRINTEXC_H */ diff -Nru ocaml-4.01.0/byterun/caml/reverse.h ocaml-4.05.0/byterun/caml/reverse.h --- ocaml-4.01.0/byterun/caml/reverse.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/reverse.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,92 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Swap byte-order in 16, 32, and 64-bit integers or floats */ + +#ifndef CAML_REVERSE_H +#define CAML_REVERSE_H + +#ifdef CAML_INTERNALS + +#define Reverse_16(dst,src) { \ + char * _p, * _q; \ + char _a; \ + _p = (char *) (src); \ + _q = (char *) (dst); \ + _a = _p[0]; \ + _q[0] = _p[1]; \ + _q[1] = _a; \ +} + +#define Reverse_32(dst,src) { \ + char * _p, * _q; \ + char _a, _b; \ + _p = (char *) (src); \ + _q = (char *) (dst); \ + _a = _p[0]; \ + _b = _p[1]; \ + _q[0] = _p[3]; \ + _q[1] = _p[2]; \ + _q[3] = _a; \ + _q[2] = _b; \ +} + +#define Reverse_64(dst,src) { \ + char * _p, * _q; \ + char _a, _b; \ + _p = (char *) (src); \ + _q = (char *) (dst); \ + _a = _p[0]; \ + _b = _p[1]; \ + _q[0] = _p[7]; \ + _q[1] = _p[6]; \ + _q[7] = _a; \ + _q[6] = _b; \ + _a = _p[2]; \ + _b = _p[3]; \ + _q[2] = _p[5]; \ + _q[3] = _p[4]; \ + _q[5] = _a; \ + _q[4] = _b; \ +} + +#define Perm_index(perm,i) ((perm >> (i * 4)) & 0xF) + +#define Permute_64(dst,perm_dst,src,perm_src) { \ + char * _p; \ + char _a, _b, _c, _d, _e, _f, _g, _h; \ + _p = (char *) (src); \ + _a = _p[Perm_index(perm_src, 0)]; \ + _b = _p[Perm_index(perm_src, 1)]; \ + _c = _p[Perm_index(perm_src, 2)]; \ + _d = _p[Perm_index(perm_src, 3)]; \ + _e = _p[Perm_index(perm_src, 4)]; \ + _f = _p[Perm_index(perm_src, 5)]; \ + _g = _p[Perm_index(perm_src, 6)]; \ + _h = _p[Perm_index(perm_src, 7)]; \ + _p = (char *) (dst); \ + _p[Perm_index(perm_dst, 0)] = _a; \ + _p[Perm_index(perm_dst, 1)] = _b; \ + _p[Perm_index(perm_dst, 2)] = _c; \ + _p[Perm_index(perm_dst, 3)] = _d; \ + _p[Perm_index(perm_dst, 4)] = _e; \ + _p[Perm_index(perm_dst, 5)] = _f; \ + _p[Perm_index(perm_dst, 6)] = _g; \ + _p[Perm_index(perm_dst, 7)] = _h; \ +} + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_REVERSE_H */ diff -Nru ocaml-4.01.0/byterun/caml/roots.h ocaml-4.05.0/byterun/caml/roots.h --- ocaml-4.01.0/byterun/caml/roots.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/roots.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,44 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_ROOTS_H +#define CAML_ROOTS_H + +#ifdef CAML_INTERNALS + +#include "misc.h" +#include "memory.h" + +typedef void (*scanning_action) (value, value *); + +void caml_oldify_local_roots (void); +void caml_darken_all_roots_start (void); +intnat caml_darken_all_roots_slice (intnat); +void caml_do_roots (scanning_action, int); +extern uintnat caml_incremental_roots_count; +#ifndef NATIVE_CODE +CAMLextern void caml_do_local_roots (scanning_action, value *, value *, + struct caml__roots_block *); +#else +CAMLextern void caml_do_local_roots(scanning_action f, char * bottom_of_stack, + uintnat last_retaddr, value * gc_regs, + struct caml__roots_block * local_roots); +#endif + +CAMLextern void (*caml_scan_roots_hook) (scanning_action); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_ROOTS_H */ diff -Nru ocaml-4.01.0/byterun/caml/signals.h ocaml-4.05.0/byterun/caml/signals.h --- ocaml-4.01.0/byterun/caml/signals.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/signals.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,59 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_SIGNALS_H +#define CAML_SIGNALS_H + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "misc.h" +#include "mlvalues.h" + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef CAML_INTERNALS +CAMLextern intnat volatile caml_signals_are_pending; +CAMLextern intnat volatile caml_pending_signals[]; +CAMLextern int volatile caml_something_to_do; +extern int volatile caml_requested_major_slice; +extern int volatile caml_requested_minor_gc; + +void caml_request_major_slice (void); +void caml_request_minor_gc (void); +CAMLextern int caml_convert_signal_number (int); +CAMLextern int caml_rev_convert_signal_number (int); +void caml_execute_signal(int signal_number, int in_signal_handler); +void caml_record_signal(int signal_number); +void caml_process_pending_signals(void); +void caml_process_event(void); +int caml_set_signal_action(int signo, int action); + +CAMLextern void (*caml_enter_blocking_section_hook)(void); +CAMLextern void (*caml_leave_blocking_section_hook)(void); +CAMLextern int (*caml_try_leave_blocking_section_hook)(void); +CAMLextern void (* volatile caml_async_action_hook)(void); +#endif /* CAML_INTERNALS */ + +CAMLextern void caml_enter_blocking_section (void); +CAMLextern void caml_leave_blocking_section (void); + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_SIGNALS_H */ diff -Nru ocaml-4.01.0/byterun/caml/signals_machdep.h ocaml-4.05.0/byterun/caml/signals_machdep.h --- ocaml-4.01.0/byterun/caml/signals_machdep.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/signals_machdep.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,74 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Processor-specific operation: atomic "read and clear" */ + +#ifndef CAML_SIGNALS_MACHDEP_H +#define CAML_SIGNALS_MACHDEP_H + +#ifdef CAML_INTERNALS + +#if defined(__GNUC__) && defined(__ATOMIC_SEQ_CST) \ + && defined(__GCC_ATOMIC_LONG_LOCK_FREE) + +/* Use the "atomic" builtins of GCC and Clang */ +#define Read_and_clear(dst,src) \ + ((dst) = __atomic_exchange_n(&(src), 0, __ATOMIC_SEQ_CST)) + +#elif defined(__GNUC__) && (defined(__i386__) || (defined(__x86_64__) \ + && defined(__ILP32__))) + +#define Read_and_clear(dst,src) \ + asm("xorl %0, %0; xchgl %0, %1" \ + : "=r" (dst), "=m" (src) \ + : "m" (src)) + +#elif defined(__GNUC__) && defined(__x86_64__) + +#define Read_and_clear(dst,src) \ + asm("xorq %0, %0; xchgq %0, %1" \ + : "=r" (dst), "=m" (src) \ + : "m" (src)) + +#elif defined(__GNUC__) && defined(__ppc__) + +#define Read_and_clear(dst,src) \ + asm("0: lwarx %0, 0, %1\n\t" \ + "stwcx. %2, 0, %1\n\t" \ + "bne- 0b" \ + : "=&r" (dst) \ + : "r" (&(src)), "r" (0) \ + : "cr0", "memory") + +#elif defined(__GNUC__) && defined(__ppc64__) + +#define Read_and_clear(dst,src) \ + asm("0: ldarx %0, 0, %1\n\t" \ + "stdcx. %2, 0, %1\n\t" \ + "bne- 0b" \ + : "=&r" (dst) \ + : "r" (&(src)), "r" (0) \ + : "cr0", "memory") + +#else + +/* Default, non-atomic implementation */ +#define Read_and_clear(dst,src) ((dst) = (src), (src) = 0) + +#endif + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_SIGNALS_MACHDEP_H */ diff -Nru ocaml-4.01.0/byterun/caml/spacetime.h ocaml-4.05.0/byterun/caml/spacetime.h --- ocaml-4.01.0/byterun/caml/spacetime.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/spacetime.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,201 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Mark Shinwell and Leo White, Jane Street Europe */ +/* */ +/* Copyright 2013--2016, Jane Street Group, LLC */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_SPACETIME_H +#define CAML_SPACETIME_H + +#ifdef NATIVE_CODE + +#include "caml/io.h" +#include "caml/misc.h" +#include "caml/stack.h" + +/* Runtime support for Spacetime profiling. + * This header file is not intended for the casual user. + * + * The implementation is split into three files: + * 1. spacetime.c: core management of the instrumentation; + * 2. spacetime_snapshot.c: the taking of heap snapshots; + * 3. spacetime_offline.c: functions that are also used when examining + * saved profiling data. + */ + +typedef enum { + CALL, + ALLOCATION +} c_node_type; + +/* All pointers between nodes point at the word immediately after the + GC headers, and everything is traversable using the normal OCaml rules. + + On entry to an OCaml function: + If the node hole pointer register has the bottom bit set, then the function + is being tail called or called from a self-recursive call site: + - If the node hole is empty, the callee must create a new node and link + it into the tail chain. The node hole pointer will point at the tail + chain. + - Otherwise the node should be used as normal. + Otherwise (not a tail call): + - If the node hole is empty, the callee must create a new node, but the + tail chain is untouched. + - Otherwise the node should be used as normal. +*/ + +/* Classification of nodes (OCaml or C) with corresponding GC tags. */ +#define OCaml_node_tag 0 +#define C_node_tag 1 +#define Is_ocaml_node(node) (Is_block(node) && Tag_val(node) == OCaml_node_tag) +#define Is_c_node(node) (Is_block(node) && Tag_val(node) == C_node_tag) + +/* The header words are: + 1. The node program counter. + 2. The tail link. */ +#define Node_num_header_words 2 + +/* The "node program counter" at the start of an OCaml node. */ +#define Node_pc(node) (Field(node, 0)) +#define Encode_node_pc(pc) (((value) pc) | 1) +#define Decode_node_pc(encoded_pc) ((void*) (encoded_pc & ~1)) + +/* The circular linked list of tail-called functions within OCaml nodes. */ +#define Tail_link(node) (Field(node, 1)) + +/* The convention for pointers from OCaml nodes to other nodes. There are + two special cases: + 1. [Val_unit] means "uninitialized", and further, that this is not a + tail call point. (Tail call points are pre-initialized, as in case 2.) + 2. If the bottom bit is set, and the value is not [Val_unit], this is a + tail call point. */ +#define Encode_tail_caller_node(node) ((node) | 1) +#define Decode_tail_caller_node(node) ((node) & ~1) +#define Is_tail_caller_node_encoded(node) (((node) & 1) == 1) + +/* Allocation points within OCaml nodes. + The "profinfo" value looks exactly like a black Infix_tag header. + This enables us to point just after it and return such pointer as a valid + OCaml value. (Used for the list of all allocation points. We could do + without this and instead just encode the list pointers as integers, but + this would mean that the structure was destroyed on marshalling. This + might not be a great problem since it is intended that the total counts + be obtained via snapshots, but it seems neater and easier to use + Infix_tag. + The "count" is just an OCaml integer giving the total number of words + (including headers) allocated at the point. + The "pointer to next allocation point" points to the "count" word of the + next allocation point in the linked list of all allocation points. + There is no special encoding needed by virtue of the [Infix_tag] trick. */ +#define Alloc_point_profinfo(node, offset) (Field(node, offset)) +#define Alloc_point_count(node, offset) (Field(node, offset + 1)) +#define Alloc_point_next_ptr(node, offset) (Field(node, offset + 2)) + +/* Direct call points (tail or non-tail) within OCaml nodes. + They just hold a pointer to the child node. The call site and callee are + both recorded in the shape. */ +#define Direct_callee_node(node,offset) (Field(node, offset)) +#define Encode_call_point_pc(pc) (((value) pc) | 1) +#define Decode_call_point_pc(pc) ((void*) (((value) pc) & ~((uintnat) 1))) + +/* Indirect call points (tail or non-tail) within OCaml nodes. + They hold a linked list of (PC upon entry to the callee, pointer to + child node) pairs. The linked list is encoded using C nodes and should + be thought of as part of the OCaml node itself. */ +#define Indirect_num_fields 1 +#define Indirect_pc_linked_list(node,offset) (Field(node, offset)) + +/* Encodings of the program counter value within a C node. */ +#define Encode_c_node_pc_for_call(pc) ((((value) pc) << 2) | 3) +#define Encode_c_node_pc_for_alloc_point(pc) ((((value) pc) << 2) | 1) +#define Decode_c_node_pc(pc) ((void*) (((uintnat) (pc)) >> 2)) + +typedef struct { + /* The layout and encoding of this structure must match that of the + allocation points within OCaml nodes, so that the linked list + traversal across all allocation points works correctly. */ + value profinfo; /* encoded using [Infix_tag] (see above) */ + value count; + /* [next] is [Val_unit] for the end of the list. + Otherwise it points at the second word of this [allocation_point] + structure. */ + value next; +} allocation_point; + +typedef struct { + /* CR-soon mshinwell: delete [gc_header], all the offset arithmetic will + then go away */ + uintnat gc_header; + uintnat pc; /* see above for encodings */ + union { + value callee_node; /* for CALL */ + allocation_point allocation; /* for ALLOCATION */ + } data; + value next; /* [Val_unit] for the end of the list */ +} c_node; /* CR-soon mshinwell: rename to dynamic_node */ + +typedef struct shape_table { + uint64_t* table; + struct shape_table* next; +} shape_table; + +extern uint64_t** caml_spacetime_static_shape_tables; +extern shape_table* caml_spacetime_dynamic_shape_tables; + +typedef struct ext_table* spacetime_unwind_info_cache; + +extern value caml_spacetime_trie_root; +extern value* caml_spacetime_trie_node_ptr; +extern value* caml_spacetime_finaliser_trie_root; + +extern allocation_point* caml_all_allocation_points; + +extern void caml_spacetime_initialize(void); +extern uintnat caml_spacetime_my_profinfo( + spacetime_unwind_info_cache*, uintnat); +extern c_node_type caml_spacetime_classify_c_node(c_node* node); +extern c_node* caml_spacetime_c_node_of_stored_pointer(value); +extern c_node* caml_spacetime_c_node_of_stored_pointer_not_null(value); +extern value caml_spacetime_stored_pointer_of_c_node(c_node* node); +extern void caml_spacetime_register_thread(value*, value*); +extern void caml_spacetime_register_shapes(void*); +extern value caml_spacetime_frame_table(void); +extern value caml_spacetime_shape_table(void); +extern void caml_spacetime_save_snapshot (struct channel *chan, + double time_override, + int use_time_override); +extern value caml_spacetime_timestamp(double time_override, + int use_time_override); +extern void caml_spacetime_automatic_snapshot (void); + +/* For use in runtime functions that are executed from OCaml + code, to save the overhead of using libunwind every time. */ +#ifdef WITH_SPACETIME +#define Get_my_profinfo_with_cached_backtrace(profinfo, size) \ + do { \ + static spacetime_unwind_info_cache spacetime_unwind_info = NULL; \ + profinfo = caml_spacetime_my_profinfo(&spacetime_unwind_info, size); \ + } \ + while (0); +#else +#define Get_my_profinfo_with_cached_backtrace(profinfo, size) \ + profinfo = (uintnat) 0; +#endif + +#else + +#define Get_my_profinfo_with_cached_backtrace(profinfo, size) \ + profinfo = (uintnat) 0; + +#endif /* NATIVE_CODE */ + + +#endif diff -Nru ocaml-4.01.0/byterun/caml/stack.h ocaml-4.05.0/byterun/caml/stack.h --- ocaml-4.01.0/byterun/caml/stack.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/stack.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,129 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Machine-dependent interface with the asm code */ + +#ifndef CAML_STACK_H +#define CAML_STACK_H + +#ifdef CAML_INTERNALS + +/* Macros to access the stack frame */ + +#ifdef TARGET_sparc +#define Saved_return_address(sp) *((intnat *)((sp) + 92)) +#define Callback_link(sp) ((struct caml_context *)((sp) + 104)) +#endif + +#ifdef TARGET_i386 +#define Saved_return_address(sp) *((intnat *)((sp) - 4)) +#ifndef SYS_win32 +#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) +#else +#define Callback_link(sp) ((struct caml_context *)((sp) + 8)) +#endif +#endif + +#ifdef TARGET_power +#if defined(MODEL_ppc) +#define Saved_return_address(sp) *((intnat *)((sp) - 4)) +#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) +#elif defined(MODEL_ppc64) +#define Saved_return_address(sp) *((intnat *)((sp) + 16)) +#define Callback_link(sp) ((struct caml_context *)((sp) + (48 + 32))) +#elif defined(MODEL_ppc64le) +#define Saved_return_address(sp) *((intnat *)((sp) + 16)) +#define Callback_link(sp) ((struct caml_context *)((sp) + (32 + 32))) +#else +#error "TARGET_power: wrong MODEL" +#endif +#define Already_scanned(sp, retaddr) ((retaddr) & 1) +#define Mask_already_scanned(retaddr) ((retaddr) & ~1) +#define Mark_scanned(sp, retaddr) Saved_return_address(sp) = (retaddr) | 1 +#endif + +#ifdef TARGET_s390x +#define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR)) +#define Trap_frame_size 16 +#define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size)) +#endif + +#ifdef TARGET_arm +#define Saved_return_address(sp) *((intnat *)((sp) - 4)) +#define Callback_link(sp) ((struct caml_context *)((sp) + 8)) +#endif + +#ifdef TARGET_amd64 +#define Saved_return_address(sp) *((intnat *)((sp) - 8)) +#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) +#endif + +#ifdef TARGET_arm64 +#define Saved_return_address(sp) *((intnat *)((sp) - 8)) +#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) +#endif + +/* Structure of OCaml callback contexts */ + +struct caml_context { + char * bottom_of_stack; /* beginning of OCaml stack chunk */ + uintnat last_retaddr; /* last return address in OCaml code */ + value * gc_regs; /* pointer to register block */ +#ifdef WITH_SPACETIME + void* trie_node; +#endif +}; + +/* Structure of frame descriptors */ + +typedef struct { + uintnat retaddr; + unsigned short frame_size; + unsigned short num_live; + unsigned short live_ofs[1]; +} frame_descr; + +/* Hash table of frame descriptors */ + +extern frame_descr ** caml_frame_descriptors; +extern int caml_frame_descriptors_mask; + +#define Hash_retaddr(addr) \ + (((uintnat)(addr) >> 3) & caml_frame_descriptors_mask) + +extern void caml_init_frame_descriptors(void); +extern void caml_register_frametable(intnat *); +extern void caml_unregister_frametable(intnat *); +extern void caml_register_dyn_global(void *); + +extern uintnat caml_stack_usage (void); +extern uintnat (*caml_stack_usage_hook)(void); + +/* Declaration of variables used in the asm code */ +extern char * caml_top_of_stack; +extern char * caml_bottom_of_stack; +extern uintnat caml_last_return_address; +extern value * caml_gc_regs; +extern char * caml_exception_pointer; +extern value * caml_globals[]; +extern char caml_globals_map[]; +extern intnat caml_globals_inited; +extern intnat * caml_frametable[]; + +CAMLextern frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_STACK_H */ diff -Nru ocaml-4.01.0/byterun/caml/stacks.h ocaml-4.05.0/byterun/caml/stacks.h --- ocaml-4.01.0/byterun/caml/stacks.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/stacks.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,46 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* structure of the stacks */ + +#ifndef CAML_STACKS_H +#define CAML_STACKS_H + +#ifdef CAML_INTERNALS + +#include "misc.h" +#include "mlvalues.h" +#include "memory.h" + +CAMLextern value * caml_stack_low; +CAMLextern value * caml_stack_high; +CAMLextern value * caml_stack_threshold; +CAMLextern value * caml_extern_sp; +CAMLextern value * caml_trapsp; +CAMLextern value * caml_trap_barrier; + +#define Trap_pc(tp) (((code_t *)(tp))[0]) +#define Trap_link(tp) (((value **)(tp))[1]) + +void caml_init_stack (uintnat init_max_size); +void caml_realloc_stack (asize_t required_size); +void caml_change_max_stack_size (uintnat new_max_size); +uintnat caml_stack_usage (void); + +CAMLextern uintnat (*caml_stack_usage_hook)(void); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_STACKS_H */ diff -Nru ocaml-4.01.0/byterun/caml/startup_aux.h ocaml-4.05.0/byterun/caml/startup_aux.h --- ocaml-4.01.0/byterun/caml/startup_aux.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/startup_aux.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,38 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, Jane Street Group, LLC */ +/* */ +/* Copyright 2015 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_STARTUP_AUX_H +#define CAML_STARTUP_AUX_H + +#ifdef CAML_INTERNALS + +#include "config.h" + +extern void caml_init_atom_table (void); + +extern uintnat caml_init_percent_free; +extern uintnat caml_init_max_percent_free; +extern uintnat caml_init_minor_heap_wsz; +extern uintnat caml_init_heap_chunk_sz; +extern uintnat caml_init_heap_wsz; +extern uintnat caml_init_max_stack_wsz; +extern uintnat caml_init_major_window; +extern uintnat caml_trace_level; + +extern void caml_parse_ocamlrunparam (void); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_STARTUP_AUX_H */ diff -Nru ocaml-4.01.0/byterun/caml/startup.h ocaml-4.05.0/byterun/caml/startup.h --- ocaml-4.01.0/byterun/caml/startup.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/startup.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,50 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_STARTUP_H +#define CAML_STARTUP_H + +#ifdef CAML_INTERNALS + +#include "mlvalues.h" +#include "exec.h" + +CAMLextern void caml_main(char **argv); + +CAMLextern void caml_startup_code( + code_t code, asize_t code_size, + char *data, asize_t data_size, + char *section_table, asize_t section_table_size, + char **argv); + +CAMLextern value caml_startup_code_exn( + code_t code, asize_t code_size, + char *data, asize_t data_size, + char *section_table, asize_t section_table_size, + char **argv); + +enum { FILE_NOT_FOUND = -1, BAD_BYTECODE = -2 }; + +extern int caml_attempt_open(char **name, struct exec_trailer *trail, + int do_open_script); +extern void caml_read_section_descriptors(int fd, struct exec_trailer *trail); +extern int32_t caml_seek_optional_section(int fd, struct exec_trailer *trail, + char *name); +extern int32_t caml_seek_section(int fd, struct exec_trailer *trail, + char *name); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_STARTUP_H */ diff -Nru ocaml-4.01.0/byterun/caml/sys.h ocaml-4.05.0/byterun/caml/sys.h --- ocaml-4.01.0/byterun/caml/sys.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/sys.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,45 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_SYS_H +#define CAML_SYS_H + +#ifdef CAML_INTERNALS + +#include "misc.h" + +#ifdef __cplusplus +extern "C" { +#endif + +#define NO_ARG Val_int(0) + +CAMLextern void caml_sys_error (value); +CAMLextern void caml_sys_io_error (value); +CAMLextern double caml_sys_time_unboxed(value); +CAMLextern void caml_sys_init (char * exe_name, char ** argv); +CAMLextern value caml_sys_exit (value); +extern double caml_sys_time_unboxed(value); +CAMLextern value caml_sys_get_argv(value unit); + +extern char * caml_exe_name; + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_SYS_H */ diff -Nru ocaml-4.01.0/byterun/caml/ui.h ocaml-4.05.0/byterun/caml/ui.h --- ocaml-4.01.0/byterun/caml/ui.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/ui.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,32 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Function declarations for non-Unix user interfaces */ + +#ifndef CAML_UI_H +#define CAML_UI_H + +#ifdef CAML_INTERNALS + +#include "config.h" + +void ui_exit (int return_code); +int ui_read (int file_desc, char *buf, unsigned int length); +int ui_write (int file_desc, char *buf, unsigned int length); +void ui_print_stderr (char *format, void *arg); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_UI_H */ diff -Nru ocaml-4.01.0/byterun/caml/weak.h ocaml-4.05.0/byterun/caml/weak.h --- ocaml-4.01.0/byterun/caml/weak.h 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/caml/weak.h 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,93 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, INRIA Rocquencourt */ +/* */ +/* Copyright 1997 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Operations on weak arrays */ + +#ifndef CAML_WEAK_H +#define CAML_WEAK_H + +#ifdef CAML_INTERNALS + +#include "mlvalues.h" + +extern value caml_ephe_list_head; +extern value caml_ephe_none; + + +/** The first field 0: weak list; + second field 1: data; + others 2..: keys; + + A weak pointer is an ephemeron with the data at caml_ephe_none + If fields are added, don't forget to update weak.ml [additional_values]. + */ + +#define CAML_EPHE_LINK_OFFSET 0 +#define CAML_EPHE_DATA_OFFSET 1 +#define CAML_EPHE_FIRST_KEY 2 + + +/* In the header, in order to let major_gc.c + and weak.c see the body of the function */ +static inline void caml_ephe_clean (value v){ + value child; + int release_data = 0; + mlsize_t size, i; + header_t hd; + Assert(caml_gc_phase == Phase_clean); + + hd = Hd_val (v); + size = Wosize_hd (hd); + for (i = 2; i < size; i++){ + child = Field (v, i); + ephemeron_again: + if (child != caml_ephe_none + && Is_block (child) && Is_in_heap_or_young (child)){ + if (Tag_val (child) == Forward_tag){ + value f = Forward_val (child); + if (Is_block (f)) { + if (!Is_in_value_area(f) || Tag_val (f) == Forward_tag + || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag){ + /* Do not short-circuit the pointer. */ + }else{ + Field (v, i) = child = f; + if (Is_block (f) && Is_young (f)) + add_to_ephe_ref_table(&caml_ephe_ref_table, v, i); + goto ephemeron_again; + } + } + } + if (Is_white_val (child) && !Is_young (child)){ + release_data = 1; + Field (v, i) = caml_ephe_none; + } + } + } + + child = Field (v, 1); + if(child != caml_ephe_none){ + if (release_data){ + Field (v, 1) = caml_ephe_none; + } else { + /* The mark phase must have marked it */ + Assert( !(Is_block (child) && Is_in_heap (child) + && Is_white_val (child)) ); + } + } +} + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_WEAK_H */ diff -Nru ocaml-4.01.0/byterun/compact.c ocaml-4.05.0/byterun/compact.c --- ocaml-4.01.0/byterun/compact.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/compact.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,28 +1,34 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS #include -#include "config.h" -#include "finalise.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "memory.h" -#include "mlvalues.h" -#include "roots.h" -#include "weak.h" +#include "caml/address_class.h" +#include "caml/config.h" +#include "caml/finalise.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/weak.h" +#include "caml/compact.h" extern uintnat caml_percent_free; /* major_gc.c */ extern void caml_shrink_heap (char *); /* memory.c */ @@ -40,13 +46,19 @@ XXX Should be fixed: XXX The above assumes that all roots are aligned on a 4-byte boundary, XXX which is not always guaranteed by C. - XXX (see [caml_register_global_roots] and [caml_init_exceptions]) + XXX (see [caml_register_global_roots]) XXX Should be able to fix it to only assume 2-byte alignment. */ -#define Make_ehd(s,t,c) (((s) << 10) | (t) << 2 | (c)) +#ifdef WITH_PROFINFO +#define Make_ehd(s,t,c,p) \ + (((s) << 10) | (t) << 2 | (c) | ((p) << PROFINFO_SHIFT)) +#else +#define Make_ehd(s,t,c,p) (((s) << 10) | (t) << 2 | (c)) +#endif #define Whsize_ehd(h) Whsize_hd (h) #define Wosize_ehd(h) Wosize_hd (h) #define Tag_ehd(h) (((h) >> 2) & 0xFF) +#define Profinfo_ehd(hd) Profinfo_hd(hd) #define Ecolor(w) ((w) & 3) typedef uintnat word; @@ -58,7 +70,7 @@ /* Use Ecolor (q) == 0 instead of Is_block (q) because q could be an inverted pointer for an infix header (with Ecolor == 2). */ - if (Ecolor (q) == 0 && (Classify_addr (q) & In_heap)){ + if (Ecolor (q) == 0 && Is_in_heap (q)){ switch (Ecolor (Hd_val (q))){ case 0: case 3: /* Pointer or header: insert in inverted list. */ @@ -85,7 +97,7 @@ Hd_val (q) = (header_t) ((word) p | 2); /* Change block header's tag to Infix_tag, and change its size to point to the infix list. */ - *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3); + *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3, (uintnat) 0); }else{ Assert (Tag_ehd (*hp) == Infix_tag); /* Point the last of this infix list to the current first infix list of the block. */ @@ -93,7 +105,7 @@ /* Point the head of this infix list to the above. */ Hd_val (q) = (header_t) ((word) p | 2); /* Change block header's size to point to this infix list. */ - *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3); + *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3, (uintnat) 0); } } break; @@ -105,7 +117,7 @@ } } -static void invert_root (value v, value *p) +void invert_root (value v, value *p) { invert_pointer_at ((word *) p); } @@ -122,8 +134,8 @@ compact_fl = caml_heap_start; } +/* [size] is a number of bytes and includes the header size */ static char *compact_allocate (mlsize_t size) - /* in bytes, including header */ { char *chunk, *adr; @@ -165,10 +177,10 @@ if (Is_blue_hd (hd)){ /* Free object. Give it a string tag. */ - Hd_hp (p) = Make_ehd (sz, String_tag, 3); + Hd_hp (p) = Make_ehd (sz, String_tag, 3, (uintnat) 0); }else{ Assert (Is_white_hd (hd)); /* Live object. Keep its tag. */ - Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3); + Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3, Profinfo_hd (hd)); } p += Whsize_wosize (sz); } @@ -184,8 +196,9 @@ /* Invert roots first because the threads library needs some heap data structures to find its roots. Fortunately, it doesn't need the headers (see above). */ - caml_do_roots (invert_root); - caml_final_do_weak_roots (invert_root); + caml_do_roots (invert_root, 1); + /* The values to be finalised are not roots but should still be inverted */ + caml_final_invert_finalisable_values (); ch = caml_heap_start; while (ch != NULL){ @@ -220,7 +233,7 @@ } /* Invert weak pointers. */ { - value *pp = &caml_weak_list_head; + value *pp = &caml_ephe_list_head; value p; word q; size_t sz, i; @@ -232,7 +245,7 @@ while (Ecolor (q) == 0) q = * (word *) q; sz = Wosize_ehd (q); for (i = 1; i < sz; i++){ - if (Field (p,i) != caml_weak_none){ + if (Field (p,i) != caml_ephe_none){ invert_pointer_at ((word *) &(Field (p,i))); } } @@ -260,12 +273,17 @@ size_t sz; tag_t t; char *newadr; +#ifdef WITH_PROFINFO + uintnat profinfo; +#endif word *infixes = NULL; while (Ecolor (q) == 0) q = * (word *) q; sz = Whsize_ehd (q); t = Tag_ehd (q); - +#ifdef WITH_PROFINFO + profinfo = Profinfo_ehd (q); +#endif if (t == Infix_tag){ /* Get the original header of this block. */ infixes = p + sz; @@ -282,7 +300,8 @@ * (word *) q = (word) Val_hp (newadr); q = next; } - *p = Make_header (Wosize_whsize (sz), t, Caml_white); + *p = Make_header_with_profinfo (Wosize_whsize (sz), t, Caml_white, + profinfo); if (infixes != NULL){ /* Rebuild the infix headers and revert the infix pointers. */ @@ -296,6 +315,9 @@ * (word *) q = (word) Val_hp ((word *) newadr + (infixes - p)); q = next; } Assert (Ecolor (q) == 1 || Ecolor (q) == 3); + /* No need to preserve any profinfo value on the [Infix_tag] + headers; the Spacetime profiling heap snapshot code doesn't + look at them. */ *infixes = Make_header (infixes - p, Infix_tag, Caml_white); infixes = (word *) q; } @@ -396,9 +418,16 @@ void caml_compact_heap (void) { - uintnat target_words, target_size, live; + uintnat target_wsz, live; + CAML_INSTR_SETUP(tmr, "compact"); + + CAMLassert (caml_young_ptr == caml_young_alloc_end); + CAMLassert (caml_ref_table.ptr == caml_ref_table.base); + CAMLassert (caml_ephe_ref_table.ptr == caml_ephe_ref_table.base); + CAMLassert (caml_custom_table.ptr == caml_custom_table.base); do_compaction (); + CAML_INSTR_TIME (tmr, "compact/main"); /* Compaction may fail to shrink the heap to a reasonable size because it deals in complete chunks: if a very large chunk is at the beginning of the heap, everything gets moved to @@ -413,28 +442,36 @@ See PR#5389 */ /* We compute: - freewords = caml_fl_cur_size (exact) + freewords = caml_fl_cur_wsz (exact) heapwords = Wsize_bsize (caml_heap_size) (exact) live = heapwords - freewords wanted = caml_percent_free * (live / 100 + 1) (same as in do_compaction) - target_words = live + wanted + target_wsz = live + wanted We add one page to make sure a small difference in counting sizes won't make [do_compaction] keep the second block (and break all sorts of invariants). - We recompact if target_size < heap_size / 2 + We recompact if target_wsz < heap_size / 2 */ - live = Wsize_bsize (caml_stat_heap_size) - caml_fl_cur_size; - target_words = live + caml_percent_free * (live / 100 + 1) + live = caml_stat_heap_wsz - caml_fl_cur_wsz; + target_wsz = live + caml_percent_free * (live / 100 + 1) + Wsize_bsize (Page_size); - target_size = caml_round_heap_chunk_size (Bsize_wsize (target_words)); - if (target_size < caml_stat_heap_size / 2){ + target_wsz = caml_clip_heap_chunk_wsz (target_wsz); + +#ifdef HAS_HUGE_PAGES + if (caml_use_huge_pages + && Bsize_wsize (caml_stat_heap_wsz) <= HUGE_PAGE_SIZE) + return; +#endif + + if (target_wsz < caml_stat_heap_wsz / 2){ + /* Recompact. */ char *chunk; - caml_gc_message (0x10, "Recompacting heap (target=%luk)\n", - target_size / 1024); + caml_gc_message (0x10, "Recompacting heap (target=%luk words)\n", + target_wsz / 1024); - chunk = caml_alloc_for_heap (target_size); + chunk = caml_alloc_for_heap (Bsize_wsize (target_wsz)); if (chunk == NULL) return; /* PR#5757: we need to make the new blocks blue, or they won't be recognized as free by the recompaction. */ @@ -447,24 +484,25 @@ Chunk_next (chunk) = caml_heap_start; caml_heap_start = chunk; ++ caml_stat_heap_chunks; - caml_stat_heap_size += Chunk_size (chunk); - if (caml_stat_heap_size > caml_stat_top_heap_size){ - caml_stat_top_heap_size = caml_stat_heap_size; + caml_stat_heap_wsz += Wsize_bsize (Chunk_size (chunk)); + if (caml_stat_heap_wsz > caml_stat_top_heap_wsz){ + caml_stat_top_heap_wsz = caml_stat_heap_wsz; } do_compaction (); Assert (caml_stat_heap_chunks == 1); Assert (Chunk_next (caml_heap_start) == NULL); - Assert (caml_stat_heap_size == Chunk_size (chunk)); + Assert (caml_stat_heap_wsz == Wsize_bsize (Chunk_size (chunk))); + CAML_INSTR_TIME (tmr, "compact/recompact"); } } void caml_compact_heap_maybe (void) { - /* Estimated free words in the heap: - FW = fl_size_at_change + 3 * (caml_fl_cur_size - - caml_fl_size_at_phase_change) - FW = 3 * caml_fl_cur_size - 2 * caml_fl_size_at_phase_change - Estimated live words: LW = caml_stat_heap_size - FW + /* Estimated free+garbage words in the heap: + FW = fl_size_at_phase_change + 3 * (caml_fl_cur_wsz + - caml_fl_wsz_at_phase_change) + FW = 3 * caml_fl_cur_wsz - 2 * caml_fl_wsz_at_phase_change + Estimated live words: LW = caml_stat_heap_wsz - FW Estimated free percentage: FP = 100 * FW / LW We compact the heap if FP > caml_percent_max */ @@ -472,33 +510,46 @@ Assert (caml_gc_phase == Phase_idle); if (caml_percent_max >= 1000000) return; if (caml_stat_major_collections < 3) return; + if (caml_stat_heap_wsz <= 2 * caml_clip_heap_chunk_wsz (0)) return; + +#ifdef HAS_HUGE_PAGES + if (caml_use_huge_pages + && Bsize_wsize (caml_stat_heap_wsz) <= HUGE_PAGE_SIZE) + return; +#endif - fw = 3.0 * caml_fl_cur_size - 2.0 * caml_fl_size_at_phase_change; - if (fw < 0) fw = caml_fl_cur_size; + fw = 3.0 * caml_fl_cur_wsz - 2.0 * caml_fl_wsz_at_phase_change; + if (fw < 0) fw = caml_fl_cur_wsz; - if (fw >= Wsize_bsize (caml_stat_heap_size)){ + if (fw >= caml_stat_heap_wsz){ fp = 1000000.0; }else{ - fp = 100.0 * fw / (Wsize_bsize (caml_stat_heap_size) - fw); + fp = 100.0 * fw / (caml_stat_heap_wsz - fw); if (fp > 1000000.0) fp = 1000000.0; } caml_gc_message (0x200, "FL size at phase change = %" - ARCH_INTNAT_PRINTF_FORMAT "u\n", - (uintnat) caml_fl_size_at_phase_change); + ARCH_INTNAT_PRINTF_FORMAT "u words\n", + (uintnat) caml_fl_wsz_at_phase_change); + caml_gc_message (0x200, "FL current size = %" + ARCH_INTNAT_PRINTF_FORMAT "u words\n", + (uintnat) caml_fl_cur_wsz); caml_gc_message (0x200, "Estimated overhead = %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", (uintnat) fp); if (fp >= caml_percent_max){ caml_gc_message (0x200, "Automatic compaction triggered.\n", 0); + caml_empty_minor_heap (); /* minor heap must be empty for compaction */ caml_finish_major_cycle (); - /* We just did a complete GC, so we can measure the overhead exactly. */ - fw = caml_fl_cur_size; - fp = 100.0 * fw / (Wsize_bsize (caml_stat_heap_size) - fw); + fw = caml_fl_cur_wsz; + fp = 100.0 * fw / (caml_stat_heap_wsz - fw); caml_gc_message (0x200, "Measured overhead: %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", (uintnat) fp); + if (fp >= caml_percent_max) + caml_compact_heap (); + else + caml_gc_message (0x200, "Automatic compaction aborted.\n", 0); - caml_compact_heap (); } } diff -Nru ocaml-4.01.0/byterun/compact.h ocaml-4.05.0/byterun/compact.h --- ocaml-4.01.0/byterun/compact.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/compact.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_COMPACT_H -#define CAML_COMPACT_H - - -#include "config.h" -#include "misc.h" - -extern void caml_compact_heap (void); -extern void caml_compact_heap_maybe (void); - - -#endif /* CAML_COMPACT_H */ diff -Nru ocaml-4.01.0/byterun/compare.c ocaml-4.05.0/byterun/compare.c --- ocaml-4.01.0/byterun/compare.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/compare.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,23 +1,31 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS #include #include -#include "custom.h" -#include "fail.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" + +#if defined(LACKS_SANE_NAN) && !defined(isnan) +#define isnan _isnan +#endif /* Structural comparison on trees. */ @@ -172,8 +180,19 @@ case Double_tag: { double d1 = Double_val(v1); double d2 = Double_val(v2); +#ifdef LACKS_SANE_NAN + if (isnan(d2)) { + if (! total) return UNORDERED; + if (isnan(d1)) break; + return GREATER; + } else if (isnan(d1)) { + if (! total) return UNORDERED; + return LESS; + } +#endif if (d1 < d2) return LESS; if (d1 > d2) return GREATER; +#ifndef LACKS_SANE_NAN if (d1 != d2) { if (! total) return UNORDERED; /* One or both of d1 and d2 is NaN. Order according to the @@ -182,6 +201,7 @@ if (d2 == d2) return LESS; /* d2 is not NaN, d1 is NaN */ /* d1 and d2 are both NaN, thus equal: continue comparison */ } +#endif break; } case Double_array_tag: { @@ -192,24 +212,36 @@ for (i = 0; i < sz1; i++) { double d1 = Double_field(v1, i); double d2 = Double_field(v2, i); +#ifdef LACKS_SANE_NAN + if (isnan(d2)) { + if (! total) return UNORDERED; + if (isnan(d1)) break; + return GREATER; + } else if (isnan(d1)) { + if (! total) return UNORDERED; + return LESS; + } +#endif if (d1 < d2) return LESS; if (d1 > d2) return GREATER; +#ifndef LACKS_SANE_NAN if (d1 != d2) { if (! total) return UNORDERED; /* See comment for Double_tag case */ if (d1 == d1) return GREATER; if (d2 == d2) return LESS; } +#endif } break; } case Abstract_tag: compare_free_stack(); - caml_invalid_argument("equal: abstract value"); + caml_invalid_argument("compare: abstract value"); case Closure_tag: case Infix_tag: compare_free_stack(); - caml_invalid_argument("equal: functional value"); + caml_invalid_argument("compare: functional value"); case Object_tag: { intnat oid1 = Oid_val(v1); intnat oid2 = Oid_val(v2); @@ -227,7 +259,7 @@ } if (compare == NULL) { compare_free_stack(); - caml_invalid_argument("equal: abstract value"); + caml_invalid_argument("compare: abstract value"); } caml_compare_unordered = 0; res = compare(v1, v2); diff -Nru ocaml-4.01.0/byterun/compare.h ocaml-4.05.0/byterun/compare.h --- ocaml-4.01.0/byterun/compare.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/compare.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, Projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_COMPARE_H -#define CAML_COMPARE_H - -CAMLextern int caml_compare_unordered; - -#endif /* CAML_COMPARE_H */ diff -Nru ocaml-4.01.0/byterun/compatibility.h ocaml-4.05.0/byterun/compatibility.h --- ocaml-4.01.0/byterun/compatibility.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/compatibility.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,370 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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. */ -/* */ -/***********************************************************************/ - -/* definitions for compatibility with old identifiers */ - -#ifndef CAML_COMPATIBILITY_H -#define CAML_COMPATIBILITY_H - -#ifndef CAML_NAME_SPACE - -/* - #define --> CAMLextern (defined with CAMLexport or CAMLprim) - (rien) --> CAMLprim - g --> global C identifier - x --> special case - - SP* signals the special cases: - - when the identifier was not simply prefixed with [caml_] - - when the [caml_] version was already used for something else, and - was renamed out of the way (watch out for [caml_alloc] and - [caml_array_bound_error] in *.s) -*/ - -/* a faire: - - ui_* (reverifier que win32.c n'en depend pas) -*/ - - -/* **** alloc.c */ -#define alloc caml_alloc /*SP*/ -#define alloc_small caml_alloc_small -#define alloc_tuple caml_alloc_tuple -#define alloc_string caml_alloc_string -#define alloc_final caml_alloc_final -#define copy_string caml_copy_string -#define alloc_array caml_alloc_array -#define copy_string_array caml_copy_string_array -#define convert_flag_list caml_convert_flag_list - -/* **** array.c */ - -/* **** backtrace.c */ -#define backtrace_active caml_backtrace_active -#define backtrace_pos caml_backtrace_pos -#define backtrace_buffer caml_backtrace_buffer -#define backtrace_last_exn caml_backtrace_last_exn -#define print_exception_backtrace caml_print_exception_backtrace - -/* **** callback.c */ -#define callback_depth caml_callback_depth -#define callbackN_exn caml_callbackN_exn -#define callback_exn caml_callback_exn -#define callback2_exn caml_callback2_exn -#define callback3_exn caml_callback3_exn -#define callback caml_callback -#define callback2 caml_callback2 -#define callback3 caml_callback3 -#define callbackN caml_callbackN - -/* **** compact.c */ - -/* **** compare.c */ -#define compare_unordered caml_compare_unordered - -/* **** custom.c */ -#define alloc_custom caml_alloc_custom -#define register_custom_operations caml_register_custom_operations - -/* **** debugger.c */ - -/* **** dynlink.c */ - -/* **** extern.c */ -#define output_val caml_output_val -#define output_value_to_malloc caml_output_value_to_malloc -#define output_value_to_block caml_output_value_to_block -#define serialize_int_1 caml_serialize_int_1 -#define serialize_int_2 caml_serialize_int_2 -#define serialize_int_4 caml_serialize_int_4 -#define serialize_int_8 caml_serialize_int_8 -#define serialize_float_4 caml_serialize_float_4 -#define serialize_float_8 caml_serialize_float_8 -#define serialize_block_1 caml_serialize_block_1 -#define serialize_block_2 caml_serialize_block_2 -#define serialize_block_4 caml_serialize_block_4 -#define serialize_block_8 caml_serialize_block_8 -#define serialize_block_float_8 caml_serialize_block_float_8 - -/* **** fail.c */ -#define external_raise caml_external_raise -#define mlraise caml_raise /*SP*/ -#define raise_constant caml_raise_constant -#define raise_with_arg caml_raise_with_arg -#define raise_with_string caml_raise_with_string -#define failwith caml_failwith -#define invalid_argument caml_invalid_argument -#define array_bound_error caml_array_bound_error /*SP*/ -#define raise_out_of_memory caml_raise_out_of_memory -#define raise_stack_overflow caml_raise_stack_overflow -#define raise_sys_error caml_raise_sys_error -#define raise_end_of_file caml_raise_end_of_file -#define raise_zero_divide caml_raise_zero_divide -#define raise_not_found caml_raise_not_found -#define raise_sys_blocked_io caml_raise_sys_blocked_io -#define init_exceptions caml_init_exceptions -/* **** asmrun/fail.c */ -/* **** asmrun/.s */ - -/* **** finalise.c */ - -/* **** fix_code.c */ - -/* **** floats.c */ -/*#define Double_val caml_Double_val done in mlvalues.h as needed */ -/*#define Store_double_val caml_Store_double_val done in mlvalues.h as needed */ -#define copy_double caml_copy_double - -/* **** freelist.c */ - -/* **** gc_ctrl.c */ - -/* **** globroots.c */ -#define register_global_root caml_register_global_root -#define remove_global_root caml_remove_global_root - -/* **** hash.c */ -#define hash_variant caml_hash_variant - -/* **** instrtrace.c */ - -/* **** intern.c */ -#define input_val caml_input_val -#define input_val_from_string caml_input_val_from_string -#define input_value_from_malloc caml_input_value_from_malloc -#define input_value_from_block caml_input_value_from_block -#define deserialize_uint_1 caml_deserialize_uint_1 -#define deserialize_sint_1 caml_deserialize_sint_1 -#define deserialize_uint_2 caml_deserialize_uint_2 -#define deserialize_sint_2 caml_deserialize_sint_2 -#define deserialize_uint_4 caml_deserialize_uint_4 -#define deserialize_sint_4 caml_deserialize_sint_4 -#define deserialize_uint_8 caml_deserialize_uint_8 -#define deserialize_sint_8 caml_deserialize_sint_8 -#define deserialize_float_4 caml_deserialize_float_4 -#define deserialize_float_8 caml_deserialize_float_8 -#define deserialize_block_1 caml_deserialize_block_1 -#define deserialize_block_2 caml_deserialize_block_2 -#define deserialize_block_4 caml_deserialize_block_4 -#define deserialize_block_8 caml_deserialize_block_8 -#define deserialize_block_float_8 caml_deserialize_block_float_8 -#define deserialize_error caml_deserialize_error - -/* **** interp.c */ - -/* **** ints.c */ -#define int32_ops caml_int32_ops -#define copy_int32 caml_copy_int32 -/*#define Int64_val caml_Int64_val *** done in mlvalues.h as needed */ -#define int64_ops caml_int64_ops -#define copy_int64 caml_copy_int64 -#define nativeint_ops caml_nativeint_ops -#define copy_nativeint caml_copy_nativeint - -/* **** io.c */ -#define channel_mutex_free caml_channel_mutex_free -#define channel_mutex_lock caml_channel_mutex_lock -#define channel_mutex_unlock caml_channel_mutex_unlock -#define channel_mutex_unlock_exn caml_channel_mutex_unlock_exn -#define all_opened_channels caml_all_opened_channels -#define open_descriptor_in caml_open_descriptor_in /*SP*/ -#define open_descriptor_out caml_open_descriptor_out /*SP*/ -#define close_channel caml_close_channel /*SP*/ -#define channel_size caml_channel_size /*SP*/ -#define channel_binary_mode caml_channel_binary_mode -#define flush_partial caml_flush_partial /*SP*/ -#define flush caml_flush /*SP*/ -#define putword caml_putword -#define putblock caml_putblock -#define really_putblock caml_really_putblock -#define seek_out caml_seek_out /*SP*/ -#define pos_out caml_pos_out /*SP*/ -#define do_read caml_do_read -#define refill caml_refill -#define getword caml_getword -#define getblock caml_getblock -#define really_getblock caml_really_getblock -#define seek_in caml_seek_in /*SP*/ -#define pos_in caml_pos_in /*SP*/ -#define input_scan_line caml_input_scan_line /*SP*/ -#define finalize_channel caml_finalize_channel -#define alloc_channel caml_alloc_channel -/*#define Val_file_offset caml_Val_file_offset *** done in io.h as needed */ -/*#define File_offset_val caml_File_offset_val *** done in io.h as needed */ - -/* **** lexing.c */ - -/* **** main.c */ -/* *** no change */ - -/* **** major_gc.c */ -#define heap_start caml_heap_start -#define page_table caml_page_table - -/* **** md5.c */ -#define md5_string caml_md5_string -#define md5_chan caml_md5_chan -#define MD5Init caml_MD5Init -#define MD5Update caml_MD5Update -#define MD5Final caml_MD5Final -#define MD5Transform caml_MD5Transform - -/* **** memory.c */ -#define alloc_shr caml_alloc_shr -#define initialize caml_initialize -#define modify caml_modify -#define stat_alloc caml_stat_alloc -#define stat_free caml_stat_free -#define stat_resize caml_stat_resize - -/* **** meta.c */ - -/* **** minor_gc.c */ -#define young_start caml_young_start -#define young_end caml_young_end -#define young_ptr caml_young_ptr -#define young_limit caml_young_limit -#define ref_table caml_ref_table -#define minor_collection caml_minor_collection -#define check_urgent_gc caml_check_urgent_gc - -/* **** misc.c */ - -/* **** obj.c */ - -/* **** parsing.c */ - -/* **** prims.c */ - -/* **** printexc.c */ -#define format_caml_exception caml_format_exception /*SP*/ - -/* **** roots.c */ -#define local_roots caml_local_roots -#define scan_roots_hook caml_scan_roots_hook -#define do_local_roots caml_do_local_roots - -/* **** signals.c */ -#define pending_signals caml_pending_signals -#define something_to_do caml_something_to_do -#define enter_blocking_section_hook caml_enter_blocking_section_hook -#define leave_blocking_section_hook caml_leave_blocking_section_hook -#define try_leave_blocking_section_hook caml_try_leave_blocking_section_hook -#define async_action_hook caml_async_action_hook -#define enter_blocking_section caml_enter_blocking_section -#define leave_blocking_section caml_leave_blocking_section -#define convert_signal_number caml_convert_signal_number -/* **** asmrun/signals.c */ -#define garbage_collection caml_garbage_collection - -/* **** stacks.c */ -#define stack_low caml_stack_low -#define stack_high caml_stack_high -#define stack_threshold caml_stack_threshold -#define extern_sp caml_extern_sp -#define trapsp caml_trapsp -#define trap_barrier caml_trap_barrier - -/* **** startup.c */ -#define atom_table caml_atom_table -/* **** asmrun/startup.c */ -#define static_data_start caml_static_data_start -#define static_data_end caml_static_data_end - -/* **** str.c */ -#define string_length caml_string_length - -/* **** sys.c */ -#define sys_error caml_sys_error -#define sys_exit caml_sys_exit - -/* **** terminfo.c */ - -/* **** unix.c & win32.c */ -#define search_exe_in_path caml_search_exe_in_path - -/* **** weak.c */ - -/* **** asmcomp/asmlink.ml */ - -/* **** asmcomp/cmmgen.ml */ - -/* **** asmcomp/asmlink.ml, asmcomp/cmmgen.ml, asmcomp/compilenv.ml */ - -/* ************************************************************* */ - -/* **** otherlibs/bigarray */ -#define int8 caml_ba_int8 -#define uint8 caml_ba_uint8 -#define int16 caml_ba_int16 -#define uint16 caml_ba_uint16 -#define MAX_NUM_DIMS CAML_BA_MAX_NUM_DIMS -#define caml_bigarray_kind caml_ba_kind -#define BIGARRAY_FLOAT32 CAML_BA_FLOAT32 -#define BIGARRAY_FLOAT64 CAML_BA_FLOAT64 -#define BIGARRAY_SINT8 CAML_BA_SINT8 -#define BIGARRAY_UINT8 CAML_BA_UINT8 -#define BIGARRAY_SINT16 CAML_BA_SINT16 -#define BIGARRAY_UINT16 CAML_BA_UINT16 -#define BIGARRAY_INT32 CAML_BA_INT32 -#define BIGARRAY_INT64 CAML_BA_INT64 -#define BIGARRAY_CAML_INT CAML_BA_CAML_INT -#define BIGARRAY_NATIVE_INT CAML_BA_NATIVE_INT -#define BIGARRAY_COMPLEX32 CAML_BA_COMPLEX32 -#define BIGARRAY_COMPLEX64 CAML_BA_COMPLEX64 -#define BIGARRAY_KIND_MASK CAML_BA_KIND_MASK -#define caml_bigarray_layout caml_ba_layout -#define BIGARRAY_C_LAYOUT CAML_BA_C_LAYOUT -#define BIGARRAY_FORTRAN_LAYOUT CAML_BA_FORTRAN_LAYOUT -#define BIGARRAY_LAYOUT_MASK CAML_BA_LAYOUT_MASK -#define caml_bigarray_managed caml_ba_managed -#define BIGARRAY_EXTERNAL CAML_BA_EXTERNAL -#define BIGARRAY_MANAGED CAML_BA_MANAGED -#define BIGARRAY_MAPPED_FILE CAML_BA_MAPPED_FILE -#define BIGARRAY_MANAGED_MASK CAML_BA_MANAGED_MASK -#define caml_bigarray_proxy caml_ba_proxy -#define caml_bigarray caml_ba_array -#define Bigarray_val Caml_ba_array_val -#define Data_bigarray_val Caml_ba_data_val -#define alloc_bigarray caml_ba_alloc -#define alloc_bigarray_dims caml_ba_alloc_dims -#define bigarray_map_file caml_ba_map_file -#define bigarray_unmap_file caml_ba_unmap_file -#define bigarray_element_size caml_ba_element_size -#define bigarray_byte_size caml_ba_byte_size -#define bigarray_deserialize caml_ba_deserialize -#define MAX_BIGARRAY_MEMORY CAML_BA_MAX_MEMORY -#define bigarray_create caml_ba_create -#define bigarray_get_N caml_ba_get_N -#define bigarray_get_1 caml_ba_get_1 -#define bigarray_get_2 caml_ba_get_2 -#define bigarray_get_3 caml_ba_get_3 -#define bigarray_get_generic caml_ba_get_generic -#define bigarray_set_1 caml_ba_set_1 -#define bigarray_set_2 caml_ba_set_2 -#define bigarray_set_3 caml_ba_set_3 -#define bigarray_set_N caml_ba_set_N -#define bigarray_set_generic caml_ba_set_generic -#define bigarray_num_dims caml_ba_num_dims -#define bigarray_dim caml_ba_dim -#define bigarray_kind caml_ba_kind -#define bigarray_layout caml_ba_layout -#define bigarray_slice caml_ba_slice -#define bigarray_sub caml_ba_sub -#define bigarray_blit caml_ba_blit -#define bigarray_fill caml_ba_fill -#define bigarray_reshape caml_ba_reshape -#define bigarray_init caml_ba_init - -#endif /* CAML_NAME_SPACE */ -#endif /* CAML_COMPATIBILITY_H */ diff -Nru ocaml-4.01.0/byterun/config.h ocaml-4.05.0/byterun/config.h --- ocaml-4.01.0/byterun/config.h 2013-03-22 18:22:51.000000000 +0000 +++ ocaml-4.05.0/byterun/config.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,167 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_CONFIG_H -#define CAML_CONFIG_H - -/* */ -/* */ -/* */ -#include "../config/m.h" -#include "../config/s.h" -/* */ - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif - -/* Types for signed chars, 32-bit integers, 64-bit integers, - native integers (as wide as a pointer type) */ - -typedef signed char schar; - -#if SIZEOF_PTR == SIZEOF_LONG -/* Standard models: ILP32 or I32LP64 */ -typedef long intnat; -typedef unsigned long uintnat; -#define ARCH_INTNAT_PRINTF_FORMAT "l" -#elif SIZEOF_PTR == SIZEOF_INT -/* Hypothetical IP32L64 model */ -typedef int intnat; -typedef unsigned int uintnat; -#define ARCH_INTNAT_PRINTF_FORMAT "" -#elif SIZEOF_PTR == 8 && defined(ARCH_INT64_TYPE) -/* Win64 model: IL32LLP64 */ -typedef ARCH_INT64_TYPE intnat; -typedef ARCH_UINT64_TYPE uintnat; -#define ARCH_INTNAT_PRINTF_FORMAT ARCH_INT64_PRINTF_FORMAT -#else -#error "No integer type available to represent pointers" -#endif - -#if SIZEOF_INT == 4 -typedef int int32; -typedef unsigned int uint32; -#define ARCH_INT32_PRINTF_FORMAT "" -#elif SIZEOF_LONG == 4 -typedef long int32; -typedef unsigned long uint32; -#define ARCH_INT32_PRINTF_FORMAT "l" -#elif SIZEOF_SHORT == 4 -typedef short int32; -typedef unsigned short uint32; -#define ARCH_INT32_PRINTF_FORMAT "" -#else -#error "No 32-bit integer type available" -#endif - -#if defined(ARCH_INT64_TYPE) -typedef ARCH_INT64_TYPE int64; -typedef ARCH_UINT64_TYPE uint64; -#else -# ifdef ARCH_BIG_ENDIAN -typedef struct { uint32 h, l; } uint64, int64; -# else -typedef struct { uint32 l, h; } uint64, int64; -# endif -#endif - -/* Endianness of floats */ - -/* ARCH_FLOAT_ENDIANNESS encodes the byte order of doubles as follows: - the value [0xabcdefgh] means that the least significant byte of the - float is at byte offset [a], the next lsb at [b], ..., and the - most significant byte at [h]. */ - -#if defined(__arm__) && !defined(__ARM_EABI__) -#define ARCH_FLOAT_ENDIANNESS 0x45670123 -#elif defined(ARCH_BIG_ENDIAN) -#define ARCH_FLOAT_ENDIANNESS 0x76543210 -#else -#define ARCH_FLOAT_ENDIANNESS 0x01234567 -#endif - -/* We use threaded code interpretation if the compiler provides labels - as first-class values (GCC 2.x). */ - -#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) \ - && !defined (SHRINKED_GNUC) && !defined(CAML_JIT) -#define THREADED_CODE -#endif - - -/* Do not change this definition. */ -#define Page_size (1 << Page_log) - -/* Memory model parameters */ - -/* The size of a page for memory management (in bytes) is [1 << Page_log]. - It must be a multiple of [sizeof (value)] and >= 8 and <= 20. */ -#define Page_log 12 /* A page is 4 kilobytes. */ - -/* Initial size of stack (bytes). */ -#define Stack_size (4096 * sizeof(value)) - -/* Minimum free size of stack (bytes); below that, it is reallocated. */ -#define Stack_threshold (256 * sizeof(value)) - -/* Default maximum size of the stack (words). */ -#define Max_stack_def (1024 * 1024) - - -/* Maximum size of a block allocated in the young generation (words). */ -/* Must be > 4 */ -#define Max_young_wosize 256 - - -/* Minimum size of the minor zone (words). - This must be at least [Max_young_wosize + 1]. */ -#define Minor_heap_min 4096 - -/* Maximum size of the minor zone (words). - Must be greater than or equal to [Minor_heap_min]. -*/ -#define Minor_heap_max (1 << 28) - -/* Default size of the minor zone. (words) */ -#define Minor_heap_def 262144 - - -/* Minimum size increment when growing the heap (words). - Must be a multiple of [Page_size / sizeof (value)]. */ -#define Heap_chunk_min (2 * Page_size / sizeof (value)) - -/* Default size increment when growing the heap. (words) - Must be a multiple of [Page_size / sizeof (value)]. - (Approx 512 Kb for a 32-bit platform, 1 Mb for a 64-bit platform.) */ -#define Heap_chunk_def (31 * Page_size) - -/* Default initial size of the major heap (words); - same constraints as for Heap_chunk_def. */ -#define Init_heap_def (31 * Page_size) - - -/* Default speed setting for the major GC. The heap will grow until - the dead objects and the free list represent this percentage of the - total size of live objects. */ -#define Percent_free_def 80 - -/* Default setting for the compacter: 500% - (i.e. trigger the compacter when 5/6 of the heap is free or garbage) - This can be set quite high because the overhead is over-estimated - when fragmentation occurs. - */ -#define Max_percent_free_def 500 - - -#endif /* CAML_CONFIG_H */ diff -Nru ocaml-4.01.0/byterun/custom.c ocaml-4.05.0/byterun/custom.c --- ocaml-4.01.0/byterun/custom.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/custom.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,24 +1,29 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS #include -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "memory.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +/* [size] is a number of bytes */ CAMLexport value caml_alloc_custom(struct custom_operations * ops, uintnat size, mlsize_t mem, @@ -28,9 +33,13 @@ value result; wosize = 1 + (size + sizeof(value) - 1) / sizeof(value); - if (ops->finalize == NULL && wosize <= Max_young_wosize) { + if (wosize <= Max_young_wosize) { result = caml_alloc_small(wosize, Custom_tag); Custom_ops_val(result) = ops; + if (ops->finalize != NULL || mem != 0) { + /* Remember that the block needs processing after minor GC. */ + add_to_custom_table (&caml_custom_table, result, mem, max); + } } else { result = caml_alloc_shr(wosize, Custom_tag); Custom_ops_val(result) = ops; diff -Nru ocaml-4.01.0/byterun/custom.h ocaml-4.05.0/byterun/custom.h --- ocaml-4.01.0/byterun/custom.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/custom.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,71 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_CUSTOM_H -#define CAML_CUSTOM_H - - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "mlvalues.h" - -struct custom_operations { - char *identifier; - void (*finalize)(value v); - int (*compare)(value v1, value v2); - intnat (*hash)(value v); - void (*serialize)(value v, - /*out*/ uintnat * wsize_32 /*size in bytes*/, - /*out*/ uintnat * wsize_64 /*size in bytes*/); - uintnat (*deserialize)(void * dst); - int (*compare_ext)(value v1, value v2); -}; - -#define custom_finalize_default NULL -#define custom_compare_default NULL -#define custom_hash_default NULL -#define custom_serialize_default NULL -#define custom_deserialize_default NULL -#define custom_compare_ext_default NULL - -#define Custom_ops_val(v) (*((struct custom_operations **) (v))) - -#ifdef __cplusplus -extern "C" { -#endif - - -CAMLextern value caml_alloc_custom(struct custom_operations * ops, - uintnat size, /*size in bytes*/ - mlsize_t mem, /*resources consumed*/ - mlsize_t max /*max resources*/); - -CAMLextern void caml_register_custom_operations(struct custom_operations * ops); - -CAMLextern int caml_compare_unordered; - /* Used by custom comparison to report unordered NaN-like cases. */ - -/* */ -extern struct custom_operations * caml_find_custom_operations(char * ident); -extern struct custom_operations * - caml_final_custom_operations(void (*fn)(value)); - -extern void caml_init_custom_operations(void); -/* */ - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_CUSTOM_H */ diff -Nru ocaml-4.01.0/byterun/debugger.c ocaml-4.05.0/byterun/debugger.c --- ocaml-4.01.0/byterun/debugger.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/debugger.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,19 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Interface with the byte-code debugger */ @@ -19,15 +23,15 @@ #include -#include "alloc.h" -#include "config.h" -#include "debugger.h" -#include "misc.h" +#include "caml/alloc.h" +#include "caml/config.h" +#include "caml/debugger.h" +#include "caml/misc.h" +#include "caml/osdeps.h" int caml_debugger_in_use = 0; uintnat caml_event_count; int caml_debugger_fork_mode = 1; /* parent by default */ -value marshal_flags = Val_emptylist; #if !defined(HAS_SOCKETS) || defined(NATIVE_CODE) @@ -64,14 +68,16 @@ #include #endif -#include "fail.h" -#include "fix_code.h" -#include "instruct.h" -#include "intext.h" -#include "io.h" -#include "mlvalues.h" -#include "stacks.h" -#include "sys.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/instruct.h" +#include "caml/intext.h" +#include "caml/io.h" +#include "caml/mlvalues.h" +#include "caml/stacks.h" +#include "caml/sys.h" + +static value marshal_flags = Val_emptylist; static int sock_domain; /* Socket domain for the debugger */ static union { /* Socket address for the debugger */ @@ -167,7 +173,7 @@ Store_field(marshal_flags, 0, Val_int(1)); /* Marshal.Closures */ Store_field(marshal_flags, 1, Val_emptylist); - address = getenv("CAML_DEBUG_SOCKET"); + address = caml_secure_getenv("CAML_DEBUG_SOCKET"); if (address == NULL) return; dbg_addr = address; @@ -217,7 +223,7 @@ static value getval(struct channel *chan) { value res; - if (caml_really_getblock(chan, (char *) &res, sizeof(res)) == 0) + if (caml_really_getblock(chan, (char *) &res, sizeof(res)) < sizeof(res)) caml_raise_end_of_file(); /* Bad, but consistent with caml_getword */ return res; } @@ -250,7 +256,6 @@ void caml_debugger(enum event_kind event) { - int frame_number; value * frame; intnat i, pos; value val; @@ -258,7 +263,6 @@ if (dbg_socket == -1) return; /* Not connected to a debugger. */ /* Reset current frame */ - frame_number = 0; frame = caml_extern_sp + 1; /* Report the event to the debugger */ @@ -266,19 +270,19 @@ case PROGRAM_START: /* Nothing to report */ goto command_loop; case EVENT_COUNT: - putch(dbg_out, REP_EVENT); + caml_putch(dbg_out, REP_EVENT); break; case BREAKPOINT: - putch(dbg_out, REP_BREAKPOINT); + caml_putch(dbg_out, REP_BREAKPOINT); break; case PROGRAM_EXIT: - putch(dbg_out, REP_EXITED); + caml_putch(dbg_out, REP_EXITED); break; case TRAP_BARRIER: - putch(dbg_out, REP_TRAP); + caml_putch(dbg_out, REP_TRAP); break; case UNCAUGHT_EXC: - putch(dbg_out, REP_UNCAUGHT_EXC); + caml_putch(dbg_out, REP_UNCAUGHT_EXC); break; } caml_putword(dbg_out, caml_event_count); @@ -296,7 +300,7 @@ /* Read and execute the commands sent by the debugger */ while(1) { - switch(getch(dbg_in)) { + switch(caml_getch(dbg_in)) { case REQ_SET_EVENT: pos = caml_getword(dbg_in); Assert (pos >= 0); @@ -404,11 +408,11 @@ val = getval(dbg_in); i = caml_getword(dbg_in); if (Tag_val(val) != Double_array_tag) { - putch(dbg_out, 0); + caml_putch(dbg_out, 0); putval(dbg_out, Field(val, i)); } else { double d = Double_field(val, i); - putch(dbg_out, 1); + caml_putch(dbg_out, 1); caml_really_putblock(dbg_out, (char *) &d, 8); } caml_flush(dbg_out); diff -Nru ocaml-4.01.0/byterun/debugger.h ocaml-4.05.0/byterun/debugger.h --- ocaml-4.01.0/byterun/debugger.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/debugger.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,111 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* Interface with the debugger */ - -#ifndef CAML_DEBUGGER_H -#define CAML_DEBUGGER_H - -#include "misc.h" -#include "mlvalues.h" - -CAMLextern int caml_debugger_in_use; -CAMLextern int caml_debugger_fork_mode; /* non-zero for parent */ -extern uintnat caml_event_count; - -enum event_kind { - EVENT_COUNT, BREAKPOINT, PROGRAM_START, PROGRAM_EXIT, - TRAP_BARRIER, UNCAUGHT_EXC -}; - -void caml_debugger_init (void); -void caml_debugger (enum event_kind event); -void caml_debugger_cleanup_fork (void); - -/* Communication protocol */ - -/* Requests from the debugger to the runtime system */ - -enum debugger_request { - REQ_SET_EVENT = 'e', /* uint32 pos */ - /* Set an event on the instruction at position pos */ - REQ_SET_BREAKPOINT = 'B', /* uint32 pos, (char k) */ - /* Set a breakpoint at position pos */ - /* In profiling mode, the breakpoint kind is set to k */ - REQ_RESET_INSTR = 'i', /* uint32 pos */ - /* Clear an event or breapoint at position pos, restores initial instr. */ - REQ_CHECKPOINT = 'c', /* no args */ - /* Checkpoint the runtime system by forking a child process. - Reply is pid of child process or -1 if checkpoint failed. */ - REQ_GO = 'g', /* uint32 n */ - /* Run the program for n events. - Reply is one of debugger_reply described below. */ - REQ_STOP = 's', /* no args */ - /* Terminate the runtime system */ - REQ_WAIT = 'w', /* no args */ - /* Reap one dead child (a discarded checkpoint). */ - REQ_INITIAL_FRAME = '0', /* no args */ - /* Set current frame to bottom frame (the one currently executing). - Reply is stack offset and current pc. */ - REQ_GET_FRAME = 'f', /* no args */ - /* Return current frame location (stack offset + current pc). */ - REQ_SET_FRAME = 'S', /* uint32 stack_offset */ - /* Set current frame to given stack offset. No reply. */ - REQ_UP_FRAME = 'U', /* uint32 n */ - /* Move one frame up. Argument n is size of current frame (in words). - Reply is stack offset and current pc, or -1 if top of stack reached. */ - REQ_SET_TRAP_BARRIER = 'b', /* uint32 offset */ - /* Set the trap barrier at the given offset. */ - REQ_GET_LOCAL = 'L', /* uint32 slot_number */ - /* Return the local variable at the given slot in the current frame. - Reply is one value. */ - REQ_GET_ENVIRONMENT = 'E', /* uint32 slot_number */ - /* Return the local variable at the given slot in the heap environment - of the current frame. Reply is one value. */ - REQ_GET_GLOBAL = 'G', /* uint32 global_number */ - /* Return the specified global variable. Reply is one value. */ - REQ_GET_ACCU = 'A', /* no args */ - /* Return the current contents of the accumulator. Reply is one value. */ - REQ_GET_HEADER = 'H', /* mlvalue v */ - /* As REQ_GET_OBJ, but sends only the header. */ - REQ_GET_FIELD = 'F', /* mlvalue v, uint32 fieldnum */ - /* As REQ_GET_OBJ, but sends only one field. */ - REQ_MARSHAL_OBJ = 'M', /* mlvalue v */ - /* Send a copy of the data structure rooted at v, using the same - format as [caml_output_value]. */ - REQ_GET_CLOSURE_CODE = 'C', /* mlvalue v */ - /* Send the code address of the given closure. - Reply is one uint32. */ - REQ_SET_FORK_MODE = 'K' /* uint32 m */ - /* Set whether to follow the child (m=0) or the parent on fork. */ -}; - -/* Replies to a REQ_GO request. All replies are followed by three uint32: - - the value of the event counter - - the position of the stack - - the current pc. */ - -enum debugger_reply { - REP_EVENT = 'e', - /* Event counter reached 0. */ - REP_BREAKPOINT = 'b', - /* Breakpoint hit. */ - REP_EXITED = 'x', - /* Program exited by calling exit or reaching the end of the source. */ - REP_TRAP = 's', - /* Trap barrier crossed. */ - REP_UNCAUGHT_EXC = 'u' - /* Program exited due to a stray exception. */ -}; - -#endif /* CAML_DEBUGGER_H */ diff -Nru ocaml-4.01.0/byterun/.depend ocaml-4.05.0/byterun/.depend --- ocaml-4.01.0/byterun/.depend 2013-08-15 16:13:16.000000000 +0000 +++ ocaml-4.05.0/byterun/.depend 2017-07-13 08:56:44.000000000 +0000 @@ -1,422 +1,856 @@ -alloc.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h stacks.h -array.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h \ - compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h -callback.o: callback.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h -compact.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ - finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h gc_ctrl.h weak.h -compare.o: compare.c custom.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h -custom.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h -debugger.o: debugger.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ - instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h sys.h -dynlink.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h osdeps.h prims.h -extern.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h -fail.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ - freelist.h minor_gc.h printexc.h signals.h stacks.h -finalise.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h signals.h -fix_code.o: fix_code.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - reverse.h -floats.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h reverse.h stacks.h -freelist.o: freelist.c config.h ../config/m.h ../config/s.h \ - compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ - major_gc.h minor_gc.h -gc_ctrl.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ - roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ - stacks.h -globroots.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ - ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - roots.h globroots.h -hash.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h +afl.o: afl.c caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/osdeps.h +alloc.o: alloc.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/stacks.h +array.o: array.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/signals.h caml/spacetime.h +backtrace.o: backtrace.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/backtrace.h caml/exec.h \ + caml/backtrace_prim.h caml/fail.h +backtrace_prim.o: backtrace_prim.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/alloc.h \ + caml/custom.h caml/io.h caml/instruct.h caml/intext.h caml/exec.h \ + caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/startup.h \ + caml/stacks.h caml/sys.h caml/backtrace.h caml/fail.h \ + caml/backtrace_prim.h +callback.o: callback.c caml/callback.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/interp.h caml/instruct.h \ + caml/fix_code.h caml/stacks.h +compact.o: compact.c caml/address_class.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/mlvalues.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/gc_ctrl.h \ + caml/weak.h caml/compact.h +compare.o: compare.c caml/custom.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +custom.o: custom.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h +debugger.o: debugger.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/debugger.h caml/osdeps.h caml/fail.h caml/fix_code.h \ + caml/instruct.h caml/intext.h caml/io.h caml/stacks.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/sys.h +dynlink.o: dynlink.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \ + caml/dynlink.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \ + caml/prims.h caml/signals.h +extern.o: extern.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/gc.h caml/intext.h caml/io.h caml/md5.h \ + caml/memory.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/reverse.h +fail.o: fail.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/printexc.h \ + caml/signals.h caml/stacks.h +finalise.o: finalise.c caml/callback.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/compact.h \ + caml/fail.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/signals.h +fix_code.o: fix_code.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/debugger.h caml/misc.h caml/mlvalues.h \ + caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/md5.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h +floats.o: floats.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h caml/stacks.h +freelist.o: freelist.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/freelist.h caml/misc.h caml/mlvalues.h \ + caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h +gc_ctrl.o: gc_ctrl.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/backtrace.h caml/exec.h caml/compact.h caml/custom.h caml/fail.h \ + caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h \ + caml/signals.h caml/stacks.h caml/startup_aux.h +globroots.o: globroots.c caml/memory.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/roots.h caml/globroots.h +hash.o: hash.c caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/custom.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/hash.h instrtrace.o: instrtrace.c -intern.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ - md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h -interp.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ - fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ - memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h -ints.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h -io.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h signals.h sys.h -lexing.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -main.o: main.c misc.h compatibility.h config.h ../config/m.h \ - ../config/s.h mlvalues.h sys.h -major_gc.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ - compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h -md5.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h reverse.h -memory.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ - minor_gc.h signals.h -meta.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ - major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h -minor_gc.o: minor_gc.c config.h ../config/m.h ../config/s.h \ - compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ - gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h -misc.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ - misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h -obj.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ - memory.h minor_gc.h prims.h -parsing.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ - mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - alloc.h -prims.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h prims.h -printexc.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ - ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ - printexc.h -roots.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ - ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h globroots.h stacks.h -signals.o: signals.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ - sys.h -signals_byt.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h -stacks.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ - fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -startup.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ - dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ - interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ - prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ - version.h -str.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h -sys.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ - stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h -terminfo.o: terminfo.c config.h ../config/m.h ../config/s.h \ - compatibility.h alloc.h misc.h mlvalues.h fail.h io.h -unix.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ - memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h -weak.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h -win32.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h signals.h sys.h -alloc.d.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h stacks.h -array.d.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -backtrace.d.o: backtrace.c config.h ../config/m.h ../config/s.h \ - compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h -callback.d.o: callback.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h -compact.d.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ - finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h gc_ctrl.h weak.h -compare.d.o: compare.c custom.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h -custom.d.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h -debugger.d.o: debugger.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ - instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h sys.h -dynlink.d.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h osdeps.h prims.h -extern.d.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h -fail.d.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ - freelist.h minor_gc.h printexc.h signals.h stacks.h -finalise.d.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h signals.h -fix_code.d.o: fix_code.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - reverse.h -floats.d.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h reverse.h stacks.h -freelist.d.o: freelist.c config.h ../config/m.h ../config/s.h \ - compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ - major_gc.h minor_gc.h -gc_ctrl.d.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ - roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ - stacks.h -globroots.d.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ - ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - roots.h globroots.h -hash.d.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h -instrtrace.d.o: instrtrace.c instruct.h misc.h compatibility.h config.h \ - ../config/m.h ../config/s.h mlvalues.h opnames.h prims.h stacks.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h -intern.d.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ - md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h -interp.d.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ - fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ - memory.h gc.h minor_gc.h prims.h signals.h stacks.h -ints.d.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h -io.d.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h signals.h sys.h -lexing.d.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -main.d.o: main.c misc.h compatibility.h config.h ../config/m.h \ - ../config/s.h mlvalues.h sys.h -major_gc.d.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ - compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h -md5.d.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h reverse.h -memory.d.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ - minor_gc.h signals.h -meta.d.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ - major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h -minor_gc.d.o: minor_gc.c config.h ../config/m.h ../config/s.h \ - compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ - gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h -misc.d.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ - misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h -obj.d.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ - memory.h minor_gc.h prims.h -parsing.d.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ - mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - alloc.h -prims.d.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h prims.h -printexc.d.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ - ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ - printexc.h -roots.d.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ - ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h globroots.h stacks.h -signals.d.o: signals.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ - sys.h -signals_byt.d.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h -stacks.d.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ - fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -startup.d.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ - dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ - interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ - prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ - version.h -str.d.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h -sys.d.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ - stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h -terminfo.d.o: terminfo.c config.h ../config/m.h ../config/s.h \ - compatibility.h alloc.h misc.h mlvalues.h fail.h io.h -unix.d.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ - memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h -weak.d.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h -win32.d.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h signals.h sys.h -alloc.pic.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h stacks.h -array.pic.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -backtrace.pic.o: backtrace.c config.h ../config/m.h ../config/s.h \ - compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h -callback.pic.o: callback.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h -compact.pic.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ - finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h gc_ctrl.h weak.h -compare.pic.o: compare.c custom.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h -custom.pic.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h -debugger.pic.o: debugger.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ - instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h sys.h -dynlink.pic.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h osdeps.h prims.h -extern.pic.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h -fail.pic.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ - freelist.h minor_gc.h printexc.h signals.h stacks.h -finalise.pic.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h signals.h -fix_code.pic.o: fix_code.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - reverse.h -floats.pic.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h reverse.h stacks.h -freelist.pic.o: freelist.c config.h ../config/m.h ../config/s.h \ - compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ - major_gc.h minor_gc.h -gc_ctrl.pic.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ - roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ - stacks.h -globroots.pic.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ - ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - roots.h globroots.h -hash.pic.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h +intern.o: intern.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/callback.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ + caml/io.h caml/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h +interp.o: interp.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/backtrace.h caml/exec.h caml/callback.h caml/debugger.h \ + caml/fail.h caml/fix_code.h caml/instrtrace.h caml/instruct.h \ + caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/prims.h caml/signals.h \ + caml/stacks.h caml/startup_aux.h caml/jumptbl.h +ints.o: ints.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/intext.h caml/io.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h +io.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/alloc.h caml/misc.h caml/mlvalues.h caml/custom.h caml/fail.h \ + caml/io.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/sys.h +lexing.o: lexing.c caml/fail.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +main.o: main.c caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/sys.h +major_gc.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/mlvalues.h caml/custom.h \ + caml/fail.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/gc_ctrl.h caml/signals.h caml/weak.h +md5.o: md5.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/fail.h caml/md5.h caml/io.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h +memory.o: memory.c caml/address_class.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/memory.h caml/minor_gc.h caml/signals.h +meta.o: meta.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/fix_code.h caml/interp.h caml/intext.h caml/io.h \ + caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/prims.h caml/stacks.h +minor_gc.o: minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \ + caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h \ + caml/signals.h caml/weak.h +misc.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \ + caml/version.h +obj.o: obj.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/fail.h caml/gc.h \ + caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/minor_gc.h caml/address_class.h caml/prims.h caml/spacetime.h +parsing.o: parsing.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/alloc.h +prims.o: prims.c caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/prims.h +printexc.o: printexc.c caml/backtrace.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/exec.h \ + caml/callback.h caml/debugger.h caml/fail.h caml/printexc.h +roots.o: roots.c caml/finalise.h caml/roots.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/memory.h caml/gc.h \ + caml/mlvalues.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/globroots.h caml/stacks.h +signals.o: signals.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/callback.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/roots.h \ + caml/signals.h caml/signals_machdep.h caml/sys.h +signals_byt.o: signals_byt.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/signals_machdep.h +spacetime.o: spacetime.c caml/fail.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h +stacks.o: stacks.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/fail.h caml/misc.h caml/mlvalues.h \ + caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +startup.o: startup.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \ + caml/backtrace.h caml/exec.h caml/callback.h caml/custom.h \ + caml/debugger.h caml/dynlink.h caml/fail.h caml/fix_code.h \ + caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h caml/interp.h \ + caml/intext.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/prims.h \ + caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.h caml/sys.h \ + caml/startup.h caml/startup_aux.h caml/version.h +startup_aux.o: startup_aux.c caml/backtrace.h caml/mlvalues.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/exec.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/startup_aux.h +str.o: str.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/fail.h +sys.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/alloc.h caml/misc.h caml/mlvalues.h caml/debugger.h caml/fail.h \ + caml/gc_ctrl.h caml/instruct.h caml/io.h caml/osdeps.h caml/signals.h \ + caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/sys.h caml/version.h +terminfo.o: terminfo.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \ + caml/fail.h caml/io.h +unix.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/fail.h caml/misc.h caml/mlvalues.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/osdeps.h caml/signals.h caml/sys.h caml/io.h +weak.o: weak.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/weak.h +afl.d.o: afl.c caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/osdeps.h +alloc.d.o: alloc.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/stacks.h +array.d.o: array.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/signals.h caml/spacetime.h +backtrace.d.o: backtrace.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/backtrace.h caml/exec.h \ + caml/backtrace_prim.h caml/fail.h +backtrace_prim.d.o: backtrace_prim.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/alloc.h \ + caml/custom.h caml/io.h caml/instruct.h caml/intext.h caml/exec.h \ + caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/startup.h \ + caml/stacks.h caml/sys.h caml/backtrace.h caml/fail.h \ + caml/backtrace_prim.h +callback.d.o: callback.c caml/callback.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/interp.h caml/instruct.h \ + caml/fix_code.h caml/stacks.h +compact.d.o: compact.c caml/address_class.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/mlvalues.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/gc_ctrl.h \ + caml/weak.h caml/compact.h +compare.d.o: compare.c caml/custom.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +custom.d.o: custom.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h +debugger.d.o: debugger.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/debugger.h caml/osdeps.h caml/fail.h caml/fix_code.h \ + caml/instruct.h caml/intext.h caml/io.h caml/stacks.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/sys.h +dynlink.d.o: dynlink.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \ + caml/dynlink.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \ + caml/prims.h caml/signals.h +extern.d.o: extern.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/gc.h caml/intext.h caml/io.h caml/md5.h \ + caml/memory.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/reverse.h +fail.d.o: fail.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/printexc.h \ + caml/signals.h caml/stacks.h +finalise.d.o: finalise.c caml/callback.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/compact.h \ + caml/fail.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/signals.h +fix_code.d.o: fix_code.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/debugger.h caml/misc.h caml/mlvalues.h \ + caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/md5.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h +floats.d.o: floats.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h caml/stacks.h +freelist.d.o: freelist.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/freelist.h caml/misc.h caml/mlvalues.h \ + caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h +gc_ctrl.d.o: gc_ctrl.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/backtrace.h caml/exec.h caml/compact.h caml/custom.h caml/fail.h \ + caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h \ + caml/signals.h caml/stacks.h caml/startup_aux.h +globroots.d.o: globroots.c caml/memory.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/roots.h caml/globroots.h +hash.d.o: hash.c caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/custom.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/hash.h +instrtrace.d.o: instrtrace.c caml/instrtrace.h caml/mlvalues.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/instruct.h caml/opnames.h caml/prims.h caml/stacks.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/startup_aux.h +intern.d.o: intern.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/callback.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ + caml/io.h caml/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h +interp.d.o: interp.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/backtrace.h caml/exec.h caml/callback.h caml/debugger.h \ + caml/fail.h caml/fix_code.h caml/instrtrace.h caml/instruct.h \ + caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/prims.h caml/signals.h \ + caml/stacks.h caml/startup_aux.h +ints.d.o: ints.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/intext.h caml/io.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h +io.d.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/alloc.h caml/misc.h caml/mlvalues.h caml/custom.h caml/fail.h \ + caml/io.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/sys.h +lexing.d.o: lexing.c caml/fail.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +main.d.o: main.c caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/sys.h +major_gc.d.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/mlvalues.h caml/custom.h \ + caml/fail.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/gc_ctrl.h caml/signals.h caml/weak.h +md5.d.o: md5.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/fail.h caml/md5.h caml/io.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h +memory.d.o: memory.c caml/address_class.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/memory.h caml/minor_gc.h caml/signals.h +meta.d.o: meta.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/fix_code.h caml/interp.h caml/intext.h caml/io.h \ + caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/prims.h caml/stacks.h +minor_gc.d.o: minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \ + caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h \ + caml/signals.h caml/weak.h +misc.d.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \ + caml/version.h +obj.d.o: obj.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/fail.h caml/gc.h \ + caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/minor_gc.h caml/address_class.h caml/prims.h caml/spacetime.h +parsing.d.o: parsing.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/alloc.h +prims.d.o: prims.c caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/prims.h +printexc.d.o: printexc.c caml/backtrace.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/exec.h \ + caml/callback.h caml/debugger.h caml/fail.h caml/printexc.h +roots.d.o: roots.c caml/finalise.h caml/roots.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/memory.h caml/gc.h \ + caml/mlvalues.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/globroots.h caml/stacks.h +signals.d.o: signals.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/callback.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/roots.h \ + caml/signals.h caml/signals_machdep.h caml/sys.h +signals_byt.d.o: signals_byt.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/signals_machdep.h +spacetime.d.o: spacetime.c caml/fail.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h +stacks.d.o: stacks.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/fail.h caml/misc.h caml/mlvalues.h \ + caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +startup.d.o: startup.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \ + caml/backtrace.h caml/exec.h caml/callback.h caml/custom.h \ + caml/debugger.h caml/dynlink.h caml/fail.h caml/fix_code.h \ + caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h caml/interp.h \ + caml/intext.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/prims.h \ + caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.h caml/sys.h \ + caml/startup.h caml/startup_aux.h caml/version.h +startup_aux.d.o: startup_aux.c caml/backtrace.h caml/mlvalues.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/exec.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/startup_aux.h +str.d.o: str.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/fail.h +sys.d.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/alloc.h caml/misc.h caml/mlvalues.h caml/debugger.h caml/fail.h \ + caml/gc_ctrl.h caml/instruct.h caml/io.h caml/osdeps.h caml/signals.h \ + caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/sys.h caml/version.h +terminfo.d.o: terminfo.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \ + caml/fail.h caml/io.h +unix.d.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/fail.h caml/misc.h caml/mlvalues.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/osdeps.h caml/signals.h caml/sys.h caml/io.h +weak.d.o: weak.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/weak.h +afl.i.o: afl.c caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/osdeps.h +alloc.i.o: alloc.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/stacks.h +array.i.o: array.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/signals.h caml/spacetime.h +backtrace.i.o: backtrace.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/backtrace.h caml/exec.h \ + caml/backtrace_prim.h caml/fail.h +backtrace_prim.i.o: backtrace_prim.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/alloc.h \ + caml/custom.h caml/io.h caml/instruct.h caml/intext.h caml/exec.h \ + caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/startup.h \ + caml/stacks.h caml/sys.h caml/backtrace.h caml/fail.h \ + caml/backtrace_prim.h +callback.i.o: callback.c caml/callback.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/interp.h caml/instruct.h \ + caml/fix_code.h caml/stacks.h +compact.i.o: compact.c caml/address_class.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/mlvalues.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/gc_ctrl.h \ + caml/weak.h caml/compact.h +compare.i.o: compare.c caml/custom.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +custom.i.o: custom.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h +debugger.i.o: debugger.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/debugger.h caml/osdeps.h caml/fail.h caml/fix_code.h \ + caml/instruct.h caml/intext.h caml/io.h caml/stacks.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/sys.h +dynlink.i.o: dynlink.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \ + caml/dynlink.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \ + caml/prims.h caml/signals.h +extern.i.o: extern.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/gc.h caml/intext.h caml/io.h caml/md5.h \ + caml/memory.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/reverse.h +fail.i.o: fail.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/printexc.h \ + caml/signals.h caml/stacks.h +finalise.i.o: finalise.c caml/callback.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/compact.h \ + caml/fail.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/signals.h +fix_code.i.o: fix_code.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/debugger.h caml/misc.h caml/mlvalues.h \ + caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/md5.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h +floats.i.o: floats.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h caml/stacks.h +freelist.i.o: freelist.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/freelist.h caml/misc.h caml/mlvalues.h \ + caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h +gc_ctrl.i.o: gc_ctrl.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/backtrace.h caml/exec.h caml/compact.h caml/custom.h caml/fail.h \ + caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h \ + caml/signals.h caml/stacks.h caml/startup_aux.h +globroots.i.o: globroots.c caml/memory.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/roots.h caml/globroots.h +hash.i.o: hash.c caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/custom.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/hash.h +instrtrace.i.o: instrtrace.c +intern.i.o: intern.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/callback.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ + caml/io.h caml/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h +interp.i.o: interp.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/backtrace.h caml/exec.h caml/callback.h caml/debugger.h \ + caml/fail.h caml/fix_code.h caml/instrtrace.h caml/instruct.h \ + caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/prims.h caml/signals.h \ + caml/stacks.h caml/startup_aux.h caml/jumptbl.h +ints.i.o: ints.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/intext.h caml/io.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h +io.i.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/alloc.h caml/misc.h caml/mlvalues.h caml/custom.h caml/fail.h \ + caml/io.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/sys.h +lexing.i.o: lexing.c caml/fail.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +main.i.o: main.c caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/sys.h +major_gc.i.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/mlvalues.h caml/custom.h \ + caml/fail.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/gc_ctrl.h caml/signals.h caml/weak.h +md5.i.o: md5.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/fail.h caml/md5.h caml/io.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h +memory.i.o: memory.c caml/address_class.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/memory.h caml/minor_gc.h caml/signals.h +meta.i.o: meta.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/fix_code.h caml/interp.h caml/intext.h caml/io.h \ + caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/prims.h caml/stacks.h +minor_gc.i.o: minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \ + caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h \ + caml/signals.h caml/weak.h +misc.i.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \ + caml/version.h +obj.i.o: obj.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/fail.h caml/gc.h \ + caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/minor_gc.h caml/address_class.h caml/prims.h caml/spacetime.h +parsing.i.o: parsing.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/alloc.h +prims.i.o: prims.c caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/prims.h +printexc.i.o: printexc.c caml/backtrace.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/exec.h \ + caml/callback.h caml/debugger.h caml/fail.h caml/printexc.h +roots.i.o: roots.c caml/finalise.h caml/roots.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/memory.h caml/gc.h \ + caml/mlvalues.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/globroots.h caml/stacks.h +signals.i.o: signals.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/callback.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/roots.h \ + caml/signals.h caml/signals_machdep.h caml/sys.h +signals_byt.i.o: signals_byt.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/signals_machdep.h +spacetime.i.o: spacetime.c caml/fail.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h +stacks.i.o: stacks.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/fail.h caml/misc.h caml/mlvalues.h \ + caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +startup.i.o: startup.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \ + caml/backtrace.h caml/exec.h caml/callback.h caml/custom.h \ + caml/debugger.h caml/dynlink.h caml/fail.h caml/fix_code.h \ + caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h caml/interp.h \ + caml/intext.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/prims.h \ + caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.h caml/sys.h \ + caml/startup.h caml/startup_aux.h caml/version.h +startup_aux.i.o: startup_aux.c caml/backtrace.h caml/mlvalues.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/exec.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/startup_aux.h +str.i.o: str.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/fail.h +sys.i.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/alloc.h caml/misc.h caml/mlvalues.h caml/debugger.h caml/fail.h \ + caml/gc_ctrl.h caml/instruct.h caml/io.h caml/osdeps.h caml/signals.h \ + caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/sys.h caml/version.h +terminfo.i.o: terminfo.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \ + caml/fail.h caml/io.h +unix.i.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/fail.h caml/misc.h caml/mlvalues.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/osdeps.h caml/signals.h caml/sys.h caml/io.h +weak.i.o: weak.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/weak.h +afl.pic.o: afl.c caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/osdeps.h +alloc.pic.o: alloc.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/stacks.h +array.pic.o: array.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/signals.h caml/spacetime.h +backtrace.pic.o: backtrace.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/backtrace.h caml/exec.h \ + caml/backtrace_prim.h caml/fail.h +backtrace_prim.pic.o: backtrace_prim.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/alloc.h \ + caml/custom.h caml/io.h caml/instruct.h caml/intext.h caml/exec.h \ + caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/startup.h \ + caml/stacks.h caml/sys.h caml/backtrace.h caml/fail.h \ + caml/backtrace_prim.h +callback.pic.o: callback.c caml/callback.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/interp.h caml/instruct.h \ + caml/fix_code.h caml/stacks.h +compact.pic.o: compact.c caml/address_class.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/mlvalues.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/gc_ctrl.h \ + caml/weak.h caml/compact.h +compare.pic.o: compare.c caml/custom.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +custom.pic.o: custom.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h +debugger.pic.o: debugger.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/debugger.h caml/osdeps.h caml/fail.h caml/fix_code.h \ + caml/instruct.h caml/intext.h caml/io.h caml/stacks.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/sys.h +dynlink.pic.o: dynlink.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \ + caml/dynlink.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \ + caml/prims.h caml/signals.h +extern.pic.o: extern.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/gc.h caml/intext.h caml/io.h caml/md5.h \ + caml/memory.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/reverse.h +fail.pic.o: fail.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/printexc.h \ + caml/signals.h caml/stacks.h +finalise.pic.o: finalise.c caml/callback.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/compact.h \ + caml/fail.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/signals.h +fix_code.pic.o: fix_code.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/debugger.h caml/misc.h caml/mlvalues.h \ + caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/md5.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h +floats.pic.o: floats.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h caml/stacks.h +freelist.pic.o: freelist.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/freelist.h caml/misc.h caml/mlvalues.h \ + caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h +gc_ctrl.pic.o: gc_ctrl.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/backtrace.h caml/exec.h caml/compact.h caml/custom.h caml/fail.h \ + caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h \ + caml/signals.h caml/stacks.h caml/startup_aux.h +globroots.pic.o: globroots.c caml/memory.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/roots.h caml/globroots.h +hash.pic.o: hash.c caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/custom.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/hash.h instrtrace.pic.o: instrtrace.c -intern.pic.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ - md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h -interp.pic.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ - fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ - memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h -ints.pic.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h -io.pic.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h signals.h sys.h -lexing.pic.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -main.pic.o: main.c misc.h compatibility.h config.h ../config/m.h \ - ../config/s.h mlvalues.h sys.h -major_gc.pic.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ - compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h -md5.pic.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h reverse.h -memory.pic.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ - minor_gc.h signals.h -meta.pic.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ - major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h -minor_gc.pic.o: minor_gc.c config.h ../config/m.h ../config/s.h \ - compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ - gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h -misc.pic.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ - misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h -obj.pic.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ - memory.h minor_gc.h prims.h -parsing.pic.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ - mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - alloc.h -prims.pic.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h prims.h -printexc.pic.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ - ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ - printexc.h -roots.pic.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ - ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h globroots.h stacks.h -signals.pic.o: signals.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ - sys.h -signals_byt.pic.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h -stacks.pic.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ - fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -startup.pic.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ - dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ - interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ - prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ - version.h -str.pic.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h -sys.pic.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ - stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h -terminfo.pic.o: terminfo.c config.h ../config/m.h ../config/s.h \ - compatibility.h alloc.h misc.h mlvalues.h fail.h io.h -unix.pic.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ - memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h -weak.pic.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h -win32.pic.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h signals.h sys.h +intern.pic.o: intern.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/callback.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ + caml/io.h caml/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h +interp.pic.o: interp.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/backtrace.h caml/exec.h caml/callback.h caml/debugger.h \ + caml/fail.h caml/fix_code.h caml/instrtrace.h caml/instruct.h \ + caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/prims.h caml/signals.h \ + caml/stacks.h caml/startup_aux.h caml/jumptbl.h +ints.pic.o: ints.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/intext.h caml/io.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h +io.pic.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/alloc.h caml/misc.h caml/mlvalues.h caml/custom.h caml/fail.h \ + caml/io.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/sys.h +lexing.pic.o: lexing.c caml/fail.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +main.pic.o: main.c caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/sys.h +major_gc.pic.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/mlvalues.h caml/custom.h \ + caml/fail.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/gc_ctrl.h caml/signals.h caml/weak.h +md5.pic.o: md5.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/fail.h caml/md5.h caml/io.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/reverse.h +memory.pic.o: memory.c caml/address_class.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/memory.h caml/minor_gc.h caml/signals.h +meta.pic.o: meta.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/fix_code.h caml/interp.h caml/intext.h caml/io.h \ + caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/prims.h caml/stacks.h +minor_gc.pic.o: minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \ + caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h \ + caml/signals.h caml/weak.h +misc.pic.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \ + caml/version.h +obj.pic.o: obj.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/fail.h caml/gc.h \ + caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/minor_gc.h caml/address_class.h caml/prims.h caml/spacetime.h +parsing.pic.o: parsing.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/alloc.h +prims.pic.o: prims.c caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/prims.h +printexc.pic.o: printexc.c caml/backtrace.h caml/mlvalues.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/exec.h \ + caml/callback.h caml/debugger.h caml/fail.h caml/printexc.h +roots.pic.o: roots.c caml/finalise.h caml/roots.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/memory.h caml/gc.h \ + caml/mlvalues.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/globroots.h caml/stacks.h +signals.pic.o: signals.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/callback.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/roots.h \ + caml/signals.h caml/signals_machdep.h caml/sys.h +signals_byt.pic.o: signals_byt.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/signals_machdep.h +spacetime.pic.o: spacetime.c caml/fail.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h +stacks.pic.o: stacks.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/fail.h caml/misc.h caml/mlvalues.h \ + caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +startup.pic.o: startup.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \ + caml/backtrace.h caml/exec.h caml/callback.h caml/custom.h \ + caml/debugger.h caml/dynlink.h caml/fail.h caml/fix_code.h \ + caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h caml/interp.h \ + caml/intext.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/prims.h \ + caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.h caml/sys.h \ + caml/startup.h caml/startup_aux.h caml/version.h +startup_aux.pic.o: startup_aux.c caml/backtrace.h caml/mlvalues.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/exec.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/startup_aux.h +str.pic.o: str.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/fail.h +sys.pic.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/alloc.h caml/misc.h caml/mlvalues.h caml/debugger.h caml/fail.h \ + caml/gc_ctrl.h caml/instruct.h caml/io.h caml/osdeps.h caml/signals.h \ + caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/sys.h caml/version.h +terminfo.pic.o: terminfo.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \ + caml/fail.h caml/io.h +unix.pic.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/fail.h caml/misc.h caml/mlvalues.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/osdeps.h caml/signals.h caml/sys.h caml/io.h +weak.pic.o: weak.c caml/alloc.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ + caml/fail.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/minor_gc.h caml/address_class.h caml/weak.h diff -Nru ocaml-4.01.0/byterun/dynlink.c ocaml-4.05.0/byterun/dynlink.c --- ocaml-4.01.0/byterun/dynlink.c 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/byterun/dynlink.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,19 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Dynamic loading of C primitives. */ @@ -18,18 +22,19 @@ #include #include #include -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include #endif -#include "alloc.h" -#include "dynlink.h" -#include "fail.h" -#include "mlvalues.h" -#include "memory.h" -#include "misc.h" -#include "osdeps.h" -#include "prims.h" +#include "caml/alloc.h" +#include "caml/dynlink.h" +#include "caml/fail.h" +#include "caml/mlvalues.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/osdeps.h" +#include "caml/prims.h" +#include "caml/signals.h" #ifndef NATIVE_CODE @@ -76,12 +81,10 @@ struct stat st; int ldconf, nread; - stdlib = getenv("OCAMLLIB"); - if (stdlib == NULL) stdlib = getenv("CAMLLIB"); + stdlib = caml_secure_getenv("OCAMLLIB"); + if (stdlib == NULL) stdlib = caml_secure_getenv("CAMLLIB"); if (stdlib == NULL) stdlib = OCAML_STDLIB_DIR; - ldconfname = caml_stat_alloc(strlen(stdlib) + 2 + sizeof(LD_CONF_NAME)); - strcpy(ldconfname, stdlib); - strcat(ldconfname, "/" LD_CONF_NAME); + ldconfname = caml_strconcat(3, stdlib, "/", LD_CONF_NAME); if (stat(ldconfname, &st) == -1) { caml_stat_free(ldconfname); return NULL; @@ -121,7 +124,9 @@ realname = caml_search_dll_in_path(&caml_shared_libs_path, name); caml_gc_message(0x100, "Loading shared library %s\n", (uintnat) realname); + caml_enter_blocking_section(); handle = caml_dlopen(realname, 1, 1); + caml_leave_blocking_section(); if (handle == NULL) caml_fatal_error_arg2("Fatal error: cannot load shared library %s\n", name, "Reason: %s\n", caml_dlerror()); @@ -145,7 +150,7 @@ - directories specified in the executable - directories specified in the file /ld.conf */ tofree1 = caml_decompose_path(&caml_shared_libs_path, - getenv("CAML_LD_LIBRARY_PATH")); + caml_secure_getenv("CAML_LD_LIBRARY_PATH")); if (lib_path != NULL) for (p = lib_path; *p != 0; p += strlen(p) + 1) caml_ext_table_add(&caml_shared_libs_path, p); @@ -191,7 +196,7 @@ caml_ext_table_add(&caml_prim_name_table, strdup(caml_names_of_builtin_cprim[i])); #endif -} + } } #endif /* NATIVE_CODE */ @@ -204,10 +209,15 @@ { void * handle; value result; + char * p; caml_gc_message(0x100, "Opening shared library %s\n", (uintnat) String_val(filename)); - handle = caml_dlopen(String_val(filename), Int_val(mode), 1); + p = caml_strdup(String_val(filename)); + caml_enter_blocking_section(); + handle = caml_dlopen(p, Int_val(mode), 1); + caml_leave_blocking_section(); + caml_stat_free(p); if (handle == NULL) caml_failwith(caml_dlerror()); result = caml_alloc_small(1, Abstract_tag); Handle_val(result) = handle; diff -Nru ocaml-4.01.0/byterun/dynlink.h ocaml-4.05.0/byterun/dynlink.h --- ocaml-4.01.0/byterun/dynlink.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/dynlink.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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. */ -/* */ -/***********************************************************************/ - -/* Dynamic loading of C primitives. */ - -#ifndef CAML_DYNLINK_H -#define CAML_DYNLINK_H - -#include "misc.h" - -/* Build the table of primitives, given a search path, a list - of shared libraries, and a list of primitive names - (all three 0-separated in char arrays). - Abort the runtime system on error. */ -extern void caml_build_primitive_table(char * lib_path, - char * libs, - char * req_prims); - -/* The search path for shared libraries */ -extern struct ext_table caml_shared_libs_path; - -/* Build the table of primitives as a copy of the builtin primitive table. - Used for executables generated by ocamlc -output-obj. */ -extern void caml_build_primitive_table_builtin(void); - -#endif /* CAML_DYNLINK_H */ diff -Nru ocaml-4.01.0/byterun/exec.h ocaml-4.05.0/byterun/exec.h --- ocaml-4.01.0/byterun/exec.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/exec.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,60 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* exec.h : format of executable bytecode files */ - -#ifndef CAML_EXEC_H -#define CAML_EXEC_H - -/* Executable bytecode files are composed of a number of sections, - identified by 4-character names. A table of contents at the - end of the file lists the section names along with their sizes, - in the order in which they appear in the file: - - offset 0 ---> initial junk - data for section 1 - data for section 2 - ... - data for section N - table of contents: - descriptor for section 1 - ... - descriptor for section N - trailer - end of file ---> -*/ - -/* Structure of t.o.c. entries - Numerical quantities are 32-bit unsigned integers, big endian */ - -struct section_descriptor { - char name[4]; /* Section name */ - uint32 len; /* Length of data in bytes */ -}; - -/* Structure of the trailer. */ - -struct exec_trailer { - uint32 num_sections; /* Number of sections */ - char magic[12]; /* The magic number */ - struct section_descriptor * section; /* Not part of file */ -}; - -#define TRAILER_SIZE (4+12) - -/* Magic number for this release */ - -#define EXEC_MAGIC "Caml1999X008" - - -#endif /* CAML_EXEC_H */ diff -Nru ocaml-4.01.0/byterun/extern.c ocaml-4.05.0/byterun/extern.c --- ocaml-4.01.0/byterun/extern.c 2013-07-23 14:48:47.000000000 +0000 +++ ocaml-4.05.0/byterun/extern.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,32 +1,37 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Structured output */ -/* The interface of this file is "intext.h" */ +/* The interface of this file is "caml/intext.h" */ #include -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "gc.h" -#include "intext.h" -#include "io.h" -#include "md5.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "reverse.h" +#include "caml/alloc.h" +#include "caml/config.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/intext.h" +#include "caml/io.h" +#include "caml/md5.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/reverse.h" static uintnat obj_counter; /* Number of objects emitted so far */ static uintnat size_32; /* Size in words of 32-bit block for struct. */ @@ -75,11 +80,22 @@ /* Forward declarations */ -static void extern_out_of_memory(void); -static void extern_invalid_argument(char *msg); -static void extern_failwith(char *msg); -static void extern_stack_overflow(void); -static struct code_fragment * extern_find_code(char *addr); +CAMLnoreturn_start +static void extern_out_of_memory(void) +CAMLnoreturn_end; + +CAMLnoreturn_start +static void extern_invalid_argument(char *msg) +CAMLnoreturn_end; + +CAMLnoreturn_start +static void extern_failwith(char *msg) +CAMLnoreturn_end; + +CAMLnoreturn_start +static void extern_stack_overflow(void) +CAMLnoreturn_end; + static void extern_replay_trail(void); static void free_extern_output(void); @@ -290,26 +306,47 @@ caml_raise_out_of_memory(); } +/* Conversion to big-endian */ + +static inline void store16(char * dst, int n) +{ + dst[0] = n >> 8; dst[1] = n; +} + +static inline void store32(char * dst, intnat n) +{ + dst[0] = n >> 24; dst[1] = n >> 16; dst[2] = n >> 8; dst[3] = n; +} + +static inline void store64(char * dst, int64_t n) +{ + dst[0] = n >> 56; dst[1] = n >> 48; dst[2] = n >> 40; dst[3] = n >> 32; + dst[4] = n >> 24; dst[5] = n >> 16; dst[6] = n >> 8; dst[7] = n; +} + /* Write characters, integers, and blocks in the output buffer */ -#define Write(c) \ - if (extern_ptr >= extern_limit) grow_extern_output(1); \ - *extern_ptr++ = (c) +static inline void write(int c) +{ + if (extern_ptr >= extern_limit) grow_extern_output(1); + *extern_ptr++ = c; +} -static void writeblock(char *data, intnat len) +static void writeblock(char * data, intnat len) { if (extern_ptr + len > extern_limit) grow_extern_output(len); - memmove(extern_ptr, data, len); + memcpy(extern_ptr, data, len); extern_ptr += len; } +static inline void writeblock_float8(double * data, intnat ndoubles) +{ #if ARCH_FLOAT_ENDIANNESS == 0x01234567 || ARCH_FLOAT_ENDIANNESS == 0x76543210 -#define writeblock_float8(data,ndoubles) \ - writeblock((char *)(data), (ndoubles) * 8) + writeblock((char *) data, ndoubles * 8); #else -#define writeblock_float8(data,ndoubles) \ - caml_serialize_block_float_8((data), (ndoubles)) + caml_serialize_block_float_8(data, ndoubles); #endif +} static void writecode8(int code, intnat val) { @@ -323,44 +360,32 @@ { if (extern_ptr + 3 > extern_limit) grow_extern_output(3); extern_ptr[0] = code; - extern_ptr[1] = val >> 8; - extern_ptr[2] = val; + store16(extern_ptr + 1, val); extern_ptr += 3; } -static void write32(intnat val) -{ - if (extern_ptr + 4 > extern_limit) grow_extern_output(4); - extern_ptr[0] = val >> 24; - extern_ptr[1] = val >> 16; - extern_ptr[2] = val >> 8; - extern_ptr[3] = val; - extern_ptr += 4; -} - static void writecode32(int code, intnat val) { if (extern_ptr + 5 > extern_limit) grow_extern_output(5); extern_ptr[0] = code; - extern_ptr[1] = val >> 24; - extern_ptr[2] = val >> 16; - extern_ptr[3] = val >> 8; - extern_ptr[4] = val; + store32(extern_ptr + 1, val); extern_ptr += 5; } #ifdef ARCH_SIXTYFOUR static void writecode64(int code, intnat val) { - int i; if (extern_ptr + 9 > extern_limit) grow_extern_output(9); - *extern_ptr ++ = code; - for (i = 64 - 8; i >= 0; i -= 8) *extern_ptr++ = val >> i; + extern_ptr[0] = code; + store64(extern_ptr + 1, val); + extern_ptr += 9; } #endif /* Marshal the given value in the output buffer */ +int caml_extern_allow_out_of_heap = 0; + static void extern_rec(value v) { struct code_fragment * cf; @@ -371,7 +396,7 @@ if (Is_long(v)) { intnat n = Long_val(v); if (n >= 0 && n < 0x40) { - Write(PREFIX_SMALL_INT + n); + write(PREFIX_SMALL_INT + n); } else if (n >= -(1 << 7) && n < (1 << 7)) { writecode8(CODE_INT8, n); } else if (n >= -(1 << 15) && n < (1 << 15)) { @@ -387,7 +412,7 @@ writecode32(CODE_INT32, n); goto next_item; } - if (Is_in_value_area(v)) { + if (Is_in_value_area(v) || caml_extern_allow_out_of_heap) { header_t hd = Hd_val(v); tag_t tag = Tag_hd(hd); mlsize_t sz = Wosize_hd(hd); @@ -407,9 +432,13 @@ in the externed block, and they are automatically shared. */ if (sz == 0) { if (tag < 16) { - Write(PREFIX_SMALL_BLOCK + tag); + write(PREFIX_SMALL_BLOCK + tag); } else { +#ifdef WITH_PROFINFO + writecode32(CODE_BLOCK32, Hd_no_profinfo(hd)); +#else writecode32(CODE_BLOCK32, hd); +#endif } goto next_item; } @@ -420,6 +449,10 @@ writecode8(CODE_SHARED8, d); } else if (d < 0x10000) { writecode16(CODE_SHARED16, d); +#ifdef ARCH_SIXTYFOUR + } else if (d >= (uintnat)1 << 32) { + writecode64(CODE_SHARED64, d); +#endif } else { writecode32(CODE_SHARED32, d); } @@ -431,7 +464,7 @@ case String_tag: { mlsize_t len = caml_string_length(v); if (len < 0x20) { - Write(PREFIX_SMALL_STRING + len); + write(PREFIX_SMALL_STRING + len); } else if (len < 0x100) { writecode8(CODE_STRING8, len); } else { @@ -439,8 +472,13 @@ if (len > 0xFFFFFB && (extern_flags & COMPAT_32)) extern_failwith("output_value: string cannot be read back on " "32-bit platform"); -#endif + if (len < (uintnat)1 << 32) + writecode32(CODE_STRING32, len); + else + writecode64(CODE_STRING64, len); +#else writecode32(CODE_STRING32, len); +#endif } writeblock(String_val(v), len); size_32 += 1 + (len + 4) / 4; @@ -451,7 +489,7 @@ case Double_tag: { if (sizeof(double) != 8) extern_invalid_argument("output_value: non-standard floats"); - Write(CODE_DOUBLE_NATIVE); + write(CODE_DOUBLE_NATIVE); writeblock_float8((double *) v, 1); size_32 += 1 + 2; size_64 += 1 + 1; @@ -470,8 +508,13 @@ if (nfloats > 0x1FFFFF && (extern_flags & COMPAT_32)) extern_failwith("output_value: float array cannot be read back on " "32-bit platform"); -#endif + if (nfloats < (uintnat) 1 << 32) + writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats); + else + writecode64(CODE_DOUBLE_ARRAY64_NATIVE, nfloats); +#else writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats); +#endif } writeblock_float8((double *) v, nfloats); size_32 += 1 + nfloats * 2; @@ -489,12 +532,12 @@ case Custom_tag: { uintnat sz_32, sz_64; char * ident = Custom_ops_val(v)->identifier; - void (*serialize)(value v, uintnat * wsize_32, - uintnat * wsize_64) + void (*serialize)(value v, uintnat * bsize_32, + uintnat * bsize_64) = Custom_ops_val(v)->serialize; if (serialize == NULL) extern_invalid_argument("output_value: abstract value (Custom)"); - Write(CODE_CUSTOM); + write(CODE_CUSTOM); writeblock(ident, strlen(ident) + 1); Custom_ops_val(v)->serialize(v, &sz_32, &sz_64); size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */ @@ -505,19 +548,24 @@ default: { value field0; if (tag < 16 && sz < 8) { - Write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); -#ifdef ARCH_SIXTYFOUR - } else if (hd >= ((uintnat)1 << 32)) { - /* Is this case useful? The overflow check in extern_value will fail.*/ - writecode64(CODE_BLOCK64, Whitehd_hd (hd)); -#endif + write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); } else { #ifdef ARCH_SIXTYFOUR +#ifdef WITH_PROFINFO + header_t hd_erased = Hd_no_profinfo(hd); +#else + header_t hd_erased = hd; +#endif if (sz > 0x3FFFFF && (extern_flags & COMPAT_32)) extern_failwith("output_value: array cannot be read back on " "32-bit platform"); -#endif + if (hd_erased < (uintnat)1 << 32) + writecode32(CODE_BLOCK32, Whitehd_hd (hd_erased)); + else + writecode64(CODE_BLOCK64, Whitehd_hd (hd_erased)); +#else writecode32(CODE_BLOCK32, Whitehd_hd (hd)); +#endif } size_32 += 1 + sz; size_64 += 1 + sz; @@ -536,7 +584,7 @@ } } } - else if ((cf = extern_find_code((char *) v)) != NULL) { + else if ((cf = caml_extern_find_code((char *) v)) != NULL) { if ((extern_flags & CLOSURES) == 0) extern_invalid_argument("output_value: functional value"); writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start); @@ -559,7 +607,9 @@ static int extern_flag_values[] = { NO_SHARING, CLOSURES, COMPAT_32 }; -static intnat extern_value(value v, value flags) +static intnat extern_value(value v, value flags, + /*out*/ char header[32], + /*out*/ int * header_len) { intnat res_len; /* Parse flag list */ @@ -569,53 +619,58 @@ obj_counter = 0; size_32 = 0; size_64 = 0; - /* Write magic number */ - write32(Intext_magic_number); - /* Set aside space for the sizes */ - extern_ptr += 4*4; /* Marshal the object */ extern_rec(v); /* Record end of output */ close_extern_output(); /* Undo the modifications done on externed blocks */ extern_replay_trail(); - /* Write the sizes */ + /* Write the header */ res_len = extern_output_length(); #ifdef ARCH_SIXTYFOUR if (res_len >= ((intnat)1 << 32) || size_32 >= ((intnat)1 << 32) || size_64 >= ((intnat)1 << 32)) { - /* The object is so big its size cannot be written in the header. - Besides, some of the array lengths or string lengths or shared offsets - it contains may have overflowed the 32 bits used to write them. */ - free_extern_output(); - caml_failwith("output_value: object too big"); - } -#endif - if (extern_userprovided_output != NULL) - extern_ptr = extern_userprovided_output + 4; - else { - extern_ptr = extern_output_first->data + 4; - extern_limit = extern_output_first->data + SIZE_EXTERN_OUTPUT_BLOCK; - } - write32(res_len - 5*4); - write32(obj_counter); - write32(size_32); - write32(size_64); + /* The object is too big for the small header format. + Fail if we are in compat32 mode, or use big header. */ + if (extern_flags & COMPAT_32) { + free_extern_output(); + caml_failwith("output_value: object too big to be read back on " + "32-bit platform"); + } + store32(header, Intext_magic_number_big); + store32(header + 4, 0); + store64(header + 8, res_len); + store64(header + 16, obj_counter); + store64(header + 24, size_64); + *header_len = 32; + return res_len; + } +#endif + /* Use the small header format */ + store32(header, Intext_magic_number_small); + store32(header + 4, res_len); + store32(header + 8, obj_counter); + store32(header + 12, size_32); + store32(header + 16, size_64); + *header_len = 20; return res_len; } void caml_output_val(struct channel *chan, value v, value flags) { + char header[32]; + int header_len; struct output_block * blk, * nextblk; if (! caml_channel_binary_mode(chan)) caml_failwith("output_value: not a binary channel"); init_extern_output(); - extern_value(v, flags); + extern_value(v, flags, header, &header_len); /* During [caml_really_putblock], concurrent [caml_output_val] operations can take place (via signal handlers or context switching in systhreads), and [extern_output_first] may change. So, save it in a local variable. */ blk = extern_output_first; + caml_really_putblock(chan, header, header_len); while (blk != NULL) { caml_really_putblock(chan, blk->data, blk->end - blk->data); nextblk = blk->next; @@ -637,20 +692,24 @@ CAMLprim value caml_output_value_to_string(value v, value flags) { - intnat len, ofs; + char header[32]; + int header_len; + intnat data_len, ofs; value res; struct output_block * blk, * nextblk; init_extern_output(); - len = extern_value(v, flags); + data_len = extern_value(v, flags, header, &header_len); /* PR#4030: it is prudent to save extern_output_first before allocating the result, as in caml_output_val */ blk = extern_output_first; - res = caml_alloc_string(len); + res = caml_alloc_string(header_len + data_len); ofs = 0; + memcpy(&Byte(res, ofs), header, header_len); + ofs += header_len; while (blk != NULL) { int n = blk->end - blk->data; - memmove(&Byte(res, ofs), blk->data, n); + memcpy(&Byte(res, ofs), blk->data, n); ofs += n; nextblk = blk->next; free(blk); @@ -659,50 +718,64 @@ return res; } +CAMLexport intnat caml_output_value_to_block(value v, value flags, + char * buf, intnat len) +{ + char header[32]; + int header_len; + intnat data_len; + /* At this point we don't know the size of the header. + Guess that it is small, and fix up later if not. */ + extern_userprovided_output = buf + 20; + extern_ptr = extern_userprovided_output; + extern_limit = buf + len; + data_len = extern_value(v, flags, header, &header_len); + if (header_len != 20) { + /* Bad guess! Need to shift the output to make room for big header. + Make sure there is room. */ + if (header_len + data_len > len) + caml_failwith("Marshal.to_buffer: buffer overflow"); + memmove(buf + header_len, buf + 20, data_len); + } + memcpy(buf, header, header_len); + return header_len + data_len; +} + CAMLprim value caml_output_value_to_buffer(value buf, value ofs, value len, value v, value flags) { - intnat len_res; - extern_userprovided_output = &Byte(buf, Long_val(ofs)); - extern_ptr = extern_userprovided_output; - extern_limit = extern_userprovided_output + Long_val(len); - len_res = extern_value(v, flags); - return Val_long(len_res); + intnat l = + caml_output_value_to_block(v, flags, + &Byte(buf, Long_val(ofs)), Long_val(len)); + return Val_long(l); } CAMLexport void caml_output_value_to_malloc(value v, value flags, /*out*/ char ** buf, /*out*/ intnat * len) { - intnat len_res; + char header[32]; + int header_len; + intnat data_len; char * res; struct output_block * blk; init_extern_output(); - len_res = extern_value(v, flags); - res = malloc(len_res); + data_len = extern_value(v, flags, header, &header_len); + res = malloc(header_len + data_len); if (res == NULL) extern_out_of_memory(); *buf = res; - *len = len_res; + *len = header_len + data_len; + memcpy(res, header, header_len); + res += header_len; for (blk = extern_output_first; blk != NULL; blk = blk->next) { int n = blk->end - blk->data; - memmove(res, blk->data, n); + memcpy(res, blk->data, n); res += n; } free_extern_output(); } -CAMLexport intnat caml_output_value_to_block(value v, value flags, - char * buf, intnat len) -{ - intnat len_res; - extern_userprovided_output = buf; - extern_ptr = extern_userprovided_output; - extern_limit = extern_userprovided_output + len; - len_res = extern_value(v, flags); - return len_res; -} - /* Functions for writing user-defined marshallers */ CAMLexport void caml_serialize_int_1(int i) @@ -715,24 +788,22 @@ CAMLexport void caml_serialize_int_2(int i) { if (extern_ptr + 2 > extern_limit) grow_extern_output(2); - extern_ptr[0] = i >> 8; - extern_ptr[1] = i; + store16(extern_ptr, i); extern_ptr += 2; } -CAMLexport void caml_serialize_int_4(int32 i) +CAMLexport void caml_serialize_int_4(int32_t i) { if (extern_ptr + 4 > extern_limit) grow_extern_output(4); - extern_ptr[0] = i >> 24; - extern_ptr[1] = i >> 16; - extern_ptr[2] = i >> 8; - extern_ptr[3] = i; + store32(extern_ptr, i); extern_ptr += 4; } -CAMLexport void caml_serialize_int_8(int64 i) +CAMLexport void caml_serialize_int_8(int64_t i) { - caml_serialize_block_8(&i, 1); + if (extern_ptr + 8 > extern_limit) grow_extern_output(8); + store64(extern_ptr, i); + extern_ptr += 8; } CAMLexport void caml_serialize_float_4(float f) @@ -748,7 +819,7 @@ CAMLexport void caml_serialize_block_1(void * data, intnat len) { if (extern_ptr + len > extern_limit) grow_extern_output(len); - memmove(extern_ptr, data, len); + memcpy(extern_ptr, data, len); extern_ptr += len; } @@ -764,7 +835,7 @@ extern_ptr = q; } #else - memmove(extern_ptr, data, len * 2); + memcpy(extern_ptr, data, len * 2); extern_ptr += len * 2; #endif } @@ -781,7 +852,7 @@ extern_ptr = q; } #else - memmove(extern_ptr, data, len * 4); + memcpy(extern_ptr, data, len * 4); extern_ptr += len * 4; #endif } @@ -798,7 +869,7 @@ extern_ptr = q; } #else - memmove(extern_ptr, data, len * 8); + memcpy(extern_ptr, data, len * 8); extern_ptr += len * 8; #endif } @@ -807,7 +878,7 @@ { if (extern_ptr + 8 * len > extern_limit) grow_extern_output(8 * len); #if ARCH_FLOAT_ENDIANNESS == 0x01234567 - memmove(extern_ptr, data, len * 8); + memcpy(extern_ptr, data, len * 8); extern_ptr += len * 8; #elif ARCH_FLOAT_ENDIANNESS == 0x76543210 { @@ -830,7 +901,7 @@ /* Find where a code pointer comes from */ -static struct code_fragment * extern_find_code(char *addr) +CAMLexport struct code_fragment * caml_extern_find_code(char *addr) { int i; for (i = caml_code_fragments_table.size - 1; i >= 0; i--) { diff -Nru ocaml-4.01.0/byterun/fail.c ocaml-4.05.0/byterun/fail.c --- ocaml-4.01.0/byterun/fail.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/fail.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,30 +1,34 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Raising exceptions from C. */ #include #include -#include "alloc.h" -#include "fail.h" -#include "io.h" -#include "gc.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "printexc.h" -#include "signals.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/gc.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/printexc.h" +#include "caml/signals.h" +#include "caml/stacks.h" CAMLexport struct longjmp_buffer * caml_external_raise = NULL; value caml_exn_bucket; @@ -39,13 +43,7 @@ CAMLexport void caml_raise_constant(value tag) { - CAMLparam1 (tag); - CAMLlocal1 (bucket); - - bucket = caml_alloc_small (1, 0); - Field(bucket, 0) = tag; - caml_raise(bucket); - CAMLnoreturn; + caml_raise(tag); } CAMLexport void caml_raise_with_arg(value tag, value arg) @@ -77,33 +75,74 @@ CAMLexport void caml_raise_with_string(value tag, char const *msg) { - CAMLparam1 (tag); - CAMLlocal1 (vmsg); - - vmsg = caml_copy_string(msg); - caml_raise_with_arg(tag, vmsg); + CAMLparam1(tag); + value v_msg = caml_copy_string(msg); + caml_raise_with_arg(tag, v_msg); CAMLnoreturn; } -/* PR#5115: Failure and Invalid_argument can be triggered by - input_value while reading the initial value of [caml_global_data]. */ +/* PR#5115: Built-in exceptions can be triggered by input_value + while reading the initial value of [caml_global_data]. -CAMLexport void caml_failwith (char const *msg) + We check against this issue here in byterun/fail.c instead of + byterun/intern.c. Having the check here means that these calls will + be slightly slower for all bytecode programs (not just the calls + coming from intern). Because intern.c is shared between byterun/ + and asmrun/, putting checks there would slow do input_value for + natively-compiled programs that do not need these checks. +*/ +static void check_global_data(char const *exception_name) { if (caml_global_data == 0) { - fprintf(stderr, "Fatal error: exception Failure(\"%s\")\n", msg); + fprintf(stderr, "Fatal error: exception %s\n", exception_name); exit(2); } - caml_raise_with_string(Field(caml_global_data, FAILURE_EXN), msg); } -CAMLexport void caml_invalid_argument (char const *msg) +static void check_global_data_param(char const *exception_name, char const *msg) { if (caml_global_data == 0) { - fprintf(stderr, "Fatal error: exception Invalid_argument(\"%s\")\n", msg); + fprintf(stderr, "Fatal error: exception %s(\"%s\")\n", exception_name, msg); exit(2); } - caml_raise_with_string(Field(caml_global_data, INVALID_EXN), msg); +} + +static inline value caml_get_failwith_tag (char const *msg) +{ + check_global_data_param("Failure", msg); + return Field(caml_global_data, FAILURE_EXN); +} + +CAMLexport void caml_failwith (char const *msg) +{ + caml_raise_with_string(caml_get_failwith_tag(msg), msg); +} + +CAMLexport void caml_failwith_value (value msg) +{ + CAMLparam1(msg); + value tag = caml_get_failwith_tag(String_val(msg)); + caml_raise_with_arg(tag, msg); + CAMLnoreturn; +} + +static inline value caml_get_invalid_argument_tag (char const *msg) +{ + check_global_data_param("Invalid_argument", msg); + return Field(caml_global_data, INVALID_EXN); +} + +CAMLexport void caml_invalid_argument (char const *msg) +{ + caml_raise_with_string(caml_get_invalid_argument_tag(msg), msg); +} + +CAMLexport void caml_invalid_argument_value (value msg) +{ + CAMLparam1(msg); + value tag = caml_get_invalid_argument_tag(String_val(msg)); + caml_raise_with_arg(tag, msg); + CAMLnoreturn; } CAMLexport void caml_array_bound_error(void) @@ -111,63 +150,54 @@ caml_invalid_argument("index out of bounds"); } -/* Problem: we can't use [caml_raise_constant], because it allocates and - we're out of memory... Here, we allocate statically the exn bucket - for [Out_of_memory]. */ - -static struct { - header_t hdr; - value exn; -} out_of_memory_bucket = { 0, 0 }; - CAMLexport void caml_raise_out_of_memory(void) { - if (out_of_memory_bucket.exn == 0) - caml_fatal_error - ("Fatal error: out of memory while raising Out_of_memory\n"); - caml_raise((value) &(out_of_memory_bucket.exn)); + check_global_data("Out_of_memory"); + caml_raise_constant(Field(caml_global_data, OUT_OF_MEMORY_EXN)); } CAMLexport void caml_raise_stack_overflow(void) { + check_global_data("Stack_overflow"); caml_raise_constant(Field(caml_global_data, STACK_OVERFLOW_EXN)); } CAMLexport void caml_raise_sys_error(value msg) { + check_global_data_param("Sys_error", String_val(msg)); caml_raise_with_arg(Field(caml_global_data, SYS_ERROR_EXN), msg); } CAMLexport void caml_raise_end_of_file(void) { + check_global_data("End_of_file"); caml_raise_constant(Field(caml_global_data, END_OF_FILE_EXN)); } CAMLexport void caml_raise_zero_divide(void) { + check_global_data("Division_by_zero"); caml_raise_constant(Field(caml_global_data, ZERO_DIVIDE_EXN)); } CAMLexport void caml_raise_not_found(void) { + check_global_data("Not_found"); caml_raise_constant(Field(caml_global_data, NOT_FOUND_EXN)); } CAMLexport void caml_raise_sys_blocked_io(void) { + check_global_data("Sys_blocked_io"); caml_raise_constant(Field(caml_global_data, SYS_BLOCKED_IO)); } -/* Initialization of statically-allocated exception buckets */ - -void caml_init_exceptions(void) -{ - out_of_memory_bucket.hdr = Make_header(1, 0, Caml_white); - out_of_memory_bucket.exn = Field(caml_global_data, OUT_OF_MEMORY_EXN); - caml_register_global_root(&out_of_memory_bucket.exn); -} - int caml_is_special_exception(value exn) { + /* this function is only used in caml_format_exception to produce + a more readable textual representation of some exceptions. It is + better to fall back to the general, less readable representation + than to abort with a fatal error as above. */ + if (caml_global_data == 0) return 0; return exn == Field(caml_global_data, MATCH_FAILURE_EXN) || exn == Field(caml_global_data, ASSERT_FAILURE_EXN) || exn == Field(caml_global_data, UNDEFINED_RECURSIVE_MODULE_EXN); diff -Nru ocaml-4.01.0/byterun/fail.h ocaml-4.05.0/byterun/fail.h --- ocaml-4.01.0/byterun/fail.h 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/byterun/fail.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,85 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_FAIL_H -#define CAML_FAIL_H - -/* */ -#include -/* */ - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "misc.h" -#include "mlvalues.h" - -/* */ -#define OUT_OF_MEMORY_EXN 0 /* "Out_of_memory" */ -#define SYS_ERROR_EXN 1 /* "Sys_error" */ -#define FAILURE_EXN 2 /* "Failure" */ -#define INVALID_EXN 3 /* "Invalid_argument" */ -#define END_OF_FILE_EXN 4 /* "End_of_file" */ -#define ZERO_DIVIDE_EXN 5 /* "Division_by_zero" */ -#define NOT_FOUND_EXN 6 /* "Not_found" */ -#define MATCH_FAILURE_EXN 7 /* "Match_failure" */ -#define STACK_OVERFLOW_EXN 8 /* "Stack_overflow" */ -#define SYS_BLOCKED_IO 9 /* "Sys_blocked_io" */ -#define ASSERT_FAILURE_EXN 10 /* "Assert_failure" */ -#define UNDEFINED_RECURSIVE_MODULE_EXN 11 /* "Undefined_recursive_module" */ - -#ifdef POSIX_SIGNALS -struct longjmp_buffer { - sigjmp_buf buf; -}; -#else -struct longjmp_buffer { - jmp_buf buf; -}; -#define sigsetjmp(buf,save) setjmp(buf) -#define siglongjmp(buf,val) longjmp(buf,val) -#endif - -CAMLextern struct longjmp_buffer * caml_external_raise; -extern value caml_exn_bucket; -int caml_is_special_exception(value exn); - -/* */ - -#ifdef __cplusplus -extern "C" { -#endif - -CAMLextern void caml_raise (value bucket) Noreturn; -CAMLextern void caml_raise_constant (value tag) Noreturn; -CAMLextern void caml_raise_with_arg (value tag, value arg) Noreturn; -CAMLextern void caml_raise_with_args (value tag, int nargs, value arg[]) - Noreturn; -CAMLextern void caml_raise_with_string (value tag, char const * msg) Noreturn; -CAMLextern void caml_failwith (char const *) Noreturn; -CAMLextern void caml_invalid_argument (char const *) Noreturn; -CAMLextern void caml_raise_out_of_memory (void) Noreturn; -CAMLextern void caml_raise_stack_overflow (void) Noreturn; -CAMLextern void caml_raise_sys_error (value) Noreturn; -CAMLextern void caml_raise_end_of_file (void) Noreturn; -CAMLextern void caml_raise_zero_divide (void) Noreturn; -CAMLextern void caml_raise_not_found (void) Noreturn; -CAMLextern void caml_init_exceptions (void); -CAMLextern void caml_array_bound_error (void) Noreturn; -CAMLextern void caml_raise_sys_blocked_io (void) Noreturn; - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_FAIL_H */ diff -Nru ocaml-4.01.0/byterun/finalise.c ocaml-4.05.0/byterun/finalise.c --- ocaml-4.01.0/byterun/finalise.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/finalise.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,23 +1,33 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Handling of finalised values. */ -#include "callback.h" -#include "fail.h" -#include "mlvalues.h" -#include "roots.h" -#include "signals.h" +#include "caml/callback.h" +#include "caml/compact.h" +#include "caml/fail.h" +#include "caml/finalise.h" +#include "caml/minor_gc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) +#include "caml/spacetime.h" +#endif struct final { value fun; @@ -25,13 +35,24 @@ int offset; }; -static struct final *final_table = NULL; -static uintnat old = 0, young = 0, size = 0; -/* [0..old) : finalisable set - [old..young) : recent set +struct finalisable { + struct final *table; + uintnat old; + uintnat young; + uintnat size; +}; +/* [0..old) : finalisable set, the values are in the major heap + [old..young) : recent set, the values could be in the minor heap [young..size) : free space + + The element of the finalisable set are moved to the finalising set + below when the value are unreachable (for the first or last time). + */ +static struct finalisable finalisable_first = {NULL,0,0,0}; +static struct finalisable finalisable_last = {NULL,0,0,0}; + struct to_do { struct to_do *next; int size; @@ -40,7 +61,15 @@ static struct to_do *to_do_hd = NULL; static struct to_do *to_do_tl = NULL; +/* + to_do_hd: head of the list of finalisation functions that can be run. + to_do_tl: tail of the list of finalisation functions that can be run. + + It is the finalising set. +*/ + +/* [size] is a number of elements for the [to_do.item] array */ static void alloc_to_do (int size) { struct to_do *result = malloc (sizeof (struct to_do) @@ -58,60 +87,81 @@ } } -/* Find white finalisable values, put them in the finalising set, and - darken them. - The recent set is empty. +/* Find white finalisable values, move them to the finalising set, and + darken them (if darken_value is true). */ -void caml_final_update (void) +static void generic_final_update (struct finalisable * final, int darken_value) { uintnat i, j, k; uintnat todo_count = 0; - Assert (young == old); - for (i = 0; i < old; i++){ - Assert (Is_block (final_table[i].val)); - Assert (Is_in_heap (final_table[i].val)); - if (Is_white_val (final_table[i].val)) ++ todo_count; + Assert (final->old <= final->young); + for (i = 0; i < final->old; i++){ + Assert (Is_block (final->table[i].val)); + Assert (Is_in_heap (final->table[i].val)); + if (Is_white_val (final->table[i].val)){ + ++ todo_count; + } } + /** invariant: + - 0 <= j <= i /\ 0 <= k <= i /\ 0 <= k <= todo_count + - i : index in final_table, before i all the values are black + (alive or in the minor heap) or the finalizer have been copied + in to_do_tl. + - j : index in final_table, before j all the values are black + (alive or in the minor heap), next available slot. + - k : index in to_do_tl, next available slot. + */ if (todo_count > 0){ alloc_to_do (todo_count); j = k = 0; - for (i = 0; i < old; i++){ - again: - Assert (Is_block (final_table[i].val)); - Assert (Is_in_heap (final_table[i].val)); - if (Is_white_val (final_table[i].val)){ - if (Tag_val (final_table[i].val) == Forward_tag){ - value fv; - Assert (final_table[i].offset == 0); - fv = Forward_val (final_table[i].val); - if (Is_block (fv) - && (!Is_in_value_area(fv) || Tag_val (fv) == Forward_tag - || Tag_val (fv) == Lazy_tag || Tag_val (fv) == Double_tag)){ - /* Do not short-circuit the pointer. */ - }else{ - final_table[i].val = fv; - if (Is_block (final_table[i].val) - && Is_in_heap (final_table[i].val)){ - goto again; - } - } - } - to_do_tl->item[k++] = final_table[i]; + for (i = 0; i < final->old; i++){ + Assert (Is_block (final->table[i].val)); + Assert (Is_in_heap (final->table[i].val)); + Assert (Tag_val (final->table[i].val) != Forward_tag); + if(Is_white_val (final->table[i].val)){ + /** dead */ + to_do_tl->item[k] = final->table[i]; + if(!darken_value){ + /* The value is not darken so the finalisation function + is called with unit not with the value */ + to_do_tl->item[k].val = Val_unit; + to_do_tl->item[k].offset = 0; + }; + k++; }else{ - final_table[j++] = final_table[i]; + /** alive */ + final->table[j++] = final->table[i]; } } - young = old = j; + CAMLassert (i == final->old); + CAMLassert (k == todo_count); + final->old = j; + for(;i < final->young; i++){ + final->table[j++] = final->table[i]; + } + final->young = j; to_do_tl->size = k; - for (i = 0; i < k; i++){ - CAMLassert (Is_white_val (to_do_tl->item[i].val)); - caml_darken (to_do_tl->item[i].val, NULL); + if(darken_value){ + for (i = 0; i < k; i++){ + /* Note that item may already be dark due to multiple entries in + the final table. */ + caml_darken (to_do_tl->item[i].val, NULL); + } } } } +void caml_final_update_mark_phase (){ + generic_final_update(&finalisable_first, /* darken_value */ 1); +} + +void caml_final_update_clean_phase (){ + generic_final_update(&finalisable_last, /* darken_value */ 0); +} + + static int running_finalisation_function = 0; /* Call the finalisation functions for the finalising set. @@ -121,10 +171,13 @@ { struct final f; value res; +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + void* saved_spacetime_trie_node_ptr; +#endif if (running_finalisation_function) return; - if (to_do_hd != NULL){ + if (caml_finalise_begin_hook != NULL) (*caml_finalise_begin_hook) (); caml_gc_message (0x80, "Calling finalisation functions.\n", 0); while (1){ while (to_do_hd != NULL && to_do_hd->size == 0){ @@ -138,11 +191,22 @@ -- to_do_hd->size; f = to_do_hd->item[to_do_hd->size]; running_finalisation_function = 1; +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + /* We record the finaliser's execution separately. + (The code of [caml_callback_exn] will do the hard work of finding + the correct place in the trie.) */ + saved_spacetime_trie_node_ptr = caml_spacetime_trie_node_ptr; + caml_spacetime_trie_node_ptr = caml_spacetime_finaliser_trie_root; +#endif res = caml_callback_exn (f.fun, f.val + f.offset); +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + caml_spacetime_trie_node_ptr = saved_spacetime_trie_node_ptr; +#endif running_finalisation_function = 0; if (Is_exception_result (res)) caml_raise (Extract_exception (res)); } caml_gc_message (0x80, "Done calling finalisation functions.\n", 0); + if (caml_finalise_end_hook != NULL) (*caml_finalise_end_hook) (); } } @@ -151,17 +215,23 @@ /* Call [*f] on the closures of the finalisable set and the closures and values of the finalising set. - The recent set is empty. - This is called by the major GC and the compactor - through [caml_darken_all_roots]. + This is called by the major GC [caml_darken_all_roots] + and by the compactor through [caml_do_roots] */ -void caml_final_do_strong_roots (scanning_action f) +void caml_final_do_roots (scanning_action f) { uintnat i; struct to_do *todo; - Assert (old == young); - for (i = 0; i < old; i++) Call_action (f, final_table[i].fun); + Assert (finalisable_first.old <= finalisable_first.young); + for (i = 0; i < finalisable_first.young; i++){ + Call_action (f, finalisable_first.table[i].fun); + }; + + Assert (finalisable_last.old <= finalisable_last.young); + for (i = 0; i < finalisable_last.young; i++){ + Call_action (f, finalisable_last.table[i].fun); + }; for (todo = to_do_hd; todo != NULL; todo = todo->next){ for (i = 0; i < todo->size; i++){ @@ -171,30 +241,122 @@ } } -/* Call [*f] on the values of the finalisable set. - The recent set is empty. - This is called directly by the compactor. +/* Call invert_root on the values of the finalisable set. This is called + directly by the compactor. */ -void caml_final_do_weak_roots (scanning_action f) +void caml_final_invert_finalisable_values () { uintnat i; - Assert (old == young); - for (i = 0; i < old; i++) Call_action (f, final_table[i].val); + CAMLassert (finalisable_first.old <= finalisable_first.young); + for (i = 0; i < finalisable_first.young; i++){ + invert_root(finalisable_first.table[i].val, + &finalisable_first.table[i].val); + }; + + CAMLassert (finalisable_last.old <= finalisable_last.young); + for (i = 0; i < finalisable_last.young; i++){ + invert_root(finalisable_last.table[i].val, + &finalisable_last.table[i].val); + }; } -/* Call [*f] on the closures and values of the recent set. +/* Call [caml_oldify_one] on the closures and values of the recent set. This is called by the minor GC through [caml_oldify_local_roots]. */ -void caml_final_do_young_roots (scanning_action f) +void caml_final_oldify_young_roots () { uintnat i; - Assert (old <= young); - for (i = old; i < young; i++){ - Call_action (f, final_table[i].fun); - Call_action (f, final_table[i].val); + Assert (finalisable_first.old <= finalisable_first.young); + for (i = finalisable_first.old; i < finalisable_first.young; i++){ + caml_oldify_one(finalisable_first.table[i].fun, + &finalisable_first.table[i].fun); + caml_oldify_one(finalisable_first.table[i].val, + &finalisable_first.table[i].val); + } + + Assert (finalisable_last.old <= finalisable_last.young); + for (i = finalisable_last.old; i < finalisable_last.young; i++){ + caml_oldify_one(finalisable_last.table[i].fun, + &finalisable_last.table[i].fun); + } + +} + +static void generic_final_minor_update (struct finalisable * final) +{ + uintnat i, j, k; + uintnat todo_count = 0; + + Assert (final->old <= final->young); + for (i = final->old; i < final->young; i++){ + Assert (Is_block (final->table[i].val)); + Assert (Is_in_heap_or_young (final->table[i].val)); + if (Is_young(final->table[i].val) && Hd_val(final->table[i].val) != 0){ + ++ todo_count; + } + } + + /** invariant: + - final->old <= j <= i /\ final->old <= k <= i /\ 0 <= k <= todo_count + - i : index in final_table, before i all the values are alive + or the finalizer have been copied in to_do_tl. + - j : index in final_table, before j all the values are alive, + next available slot. + - k : index in to_do_tl, next available slot. + */ + if (todo_count > 0){ + alloc_to_do (todo_count); + k = 0; + j = final->old; + for (i = final->old; i < final->young; i++){ + Assert (Is_block (final->table[i].val)); + Assert (Is_in_heap_or_young (final->table[i].val)); + Assert (Tag_val (final->table[i].val) != Forward_tag); + if(Is_young(final->table[j].val) && Hd_val(final->table[i].val) != 0){ + /** dead */ + to_do_tl->item[k] = final->table[i]; + /* The finalisation function is called with unit not with the value */ + to_do_tl->item[k].val = Val_unit; + to_do_tl->item[k].offset = 0; + k++; + }else{ + /** alive */ + final->table[j++] = final->table[i]; + } + } + CAMLassert (i == final->young); + CAMLassert (k == todo_count); + final->young = j; + to_do_tl->size = todo_count; + } + + /** update the minor value to the copied major value */ + for (i = final->old; i < final->young; i++){ + Assert (Is_block (final->table[i].val)); + Assert (Is_in_heap_or_young (final->table[i].val)); + if (Is_young(final->table[i].val)) { + CAMLassert (Hd_val(final->table[i].val) == 0); + final->table[i].val = Field(final->table[i].val,0); + } } + + /** check invariant */ + Assert (final->old <= final->young); + for (i = 0; i < final->young; i++){ + CAMLassert( Is_in_heap(final->table[i].val) ); + }; + +} + +/* At the end of minor collection update the finalise_last roots in + minor heap when moved to major heap or moved them to the finalising + set when dead. +*/ +void caml_final_update_minor_roots () +{ + generic_final_minor_update(&finalisable_last); } /* Empty the recent set into the finalisable set. @@ -203,47 +365,79 @@ */ void caml_final_empty_young (void) { - old = young; + finalisable_first.old = finalisable_first.young; + finalisable_last.old = finalisable_last.young; } /* Put (f,v) in the recent set. */ -CAMLprim value caml_final_register (value f, value v) +static void generic_final_register (struct finalisable *final, value f, value v) { - if (!(Is_block (v) && Is_in_heap_or_young(v))) { + if (!Is_block (v) + || !Is_in_heap_or_young(v) + || Tag_val (v) == Lazy_tag + || Tag_val (v) == Double_tag + || Tag_val (v) == Forward_tag) { caml_invalid_argument ("Gc.finalise"); } - Assert (old <= young); + Assert (final->old <= final->young); - if (young >= size){ - if (final_table == NULL){ + if (final->young >= final->size){ + if (final->table == NULL){ uintnat new_size = 30; - final_table = caml_stat_alloc (new_size * sizeof (struct final)); - Assert (old == 0); - Assert (young == 0); - size = new_size; + final->table = caml_stat_alloc (new_size * sizeof (struct final)); + Assert (final->old == 0); + Assert (final->young == 0); + final->size = new_size; }else{ - uintnat new_size = size * 2; - final_table = caml_stat_resize (final_table, + uintnat new_size = final->size * 2; + final->table = caml_stat_resize (final->table, new_size * sizeof (struct final)); - size = new_size; + final->size = new_size; } } - Assert (young < size); - final_table[young].fun = f; + Assert (final->young < final->size); + final->table[final->young].fun = f; if (Tag_val (v) == Infix_tag){ - final_table[young].offset = Infix_offset_val (v); - final_table[young].val = v - Infix_offset_val (v); + final->table[final->young].offset = Infix_offset_val (v); + final->table[final->young].val = v - Infix_offset_val (v); }else{ - final_table[young].offset = 0; - final_table[young].val = v; + final->table[final->young].offset = 0; + final->table[final->young].val = v; } - ++ young; + ++ final->young; + +} + +CAMLprim value caml_final_register (value f, value v){ + generic_final_register(&finalisable_first, f, v); + return Val_unit; +} +CAMLprim value caml_final_register_called_without_value (value f, value v){ + generic_final_register(&finalisable_last, f, v); return Val_unit; } + CAMLprim value caml_final_release (value unit) { running_finalisation_function = 0; return Val_unit; } + +static void gen_final_invariant_check(struct finalisable *final){ + uintnat i; + + CAMLassert (final->old <= final->young); + for (i = 0; i < final->old; i++){ + CAMLassert( Is_in_heap(final->table[i].val) ); + }; + for (i = final->old; i < final->young; i++){ + CAMLassert( Is_in_heap_or_young(final->table[i].val) ); + }; +} + +void caml_final_invariant_check(void){ + gen_final_invariant_check(&finalisable_first); + gen_final_invariant_check(&finalisable_last); +} diff -Nru ocaml-4.01.0/byterun/finalise.h ocaml-4.05.0/byterun/finalise.h --- ocaml-4.01.0/byterun/finalise.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/finalise.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_FINALISE_H -#define CAML_FINALISE_H - -#include "roots.h" - -void caml_final_update (void); -void caml_final_do_calls (void); -void caml_final_do_strong_roots (scanning_action f); -void caml_final_do_weak_roots (scanning_action f); -void caml_final_do_young_roots (scanning_action f); -void caml_final_empty_young (void); -value caml_final_register (value f, value v); - -#endif /* CAML_FINALISE_H */ diff -Nru ocaml-4.01.0/byterun/fix_code.c ocaml-4.05.0/byterun/fix_code.c --- ocaml-4.01.0/byterun/fix_code.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/fix_code.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,33 +1,39 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Handling of blocks of bytecode (endianness switch, threading). */ -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include +#else +#include #endif -#include "debugger.h" -#include "fix_code.h" -#include "instruct.h" -#include "intext.h" -#include "md5.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "reverse.h" +#include "caml/debugger.h" +#include "caml/fix_code.h" +#include "caml/instruct.h" +#include "caml/intext.h" +#include "caml/md5.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/reverse.h" code_t caml_start_code; asize_t caml_code_size; @@ -35,7 +41,7 @@ /* Read the main bytecode block from a file */ -void caml_init_code_fragments() { +void caml_init_code_fragments(void) { struct code_fragment * cf; /* Register the code in the table of code fragments */ cf = caml_stat_alloc(sizeof(struct code_fragment)); @@ -95,37 +101,48 @@ char ** caml_instr_table; char * caml_instr_base; -void caml_thread_code (code_t code, asize_t len) +static int* opcode_nargs = NULL; +int* caml_init_opcode_nargs(void) { - code_t p; - int l [STOP + 1]; - int i; + if( opcode_nargs == NULL ){ + int* l = (int*)caml_stat_alloc(sizeof(int) * FIRST_UNIMPLEMENTED_OP); + int i; - for (i = 0; i <= STOP; i++) { - l [i] = 0; + for (i = 0; i < FIRST_UNIMPLEMENTED_OP; i++) { + l [i] = 0; + } + /* Instructions with one operand */ + l[PUSHACC] = l[ACC] = l[POP] = l[ASSIGN] = + l[PUSHENVACC] = l[ENVACC] = l[PUSH_RETADDR] = l[APPLY] = + l[APPTERM1] = l[APPTERM2] = l[APPTERM3] = l[RETURN] = + l[GRAB] = l[PUSHGETGLOBAL] = l[GETGLOBAL] = l[SETGLOBAL] = + l[PUSHATOM] = l[ATOM] = l[MAKEBLOCK1] = l[MAKEBLOCK2] = + l[MAKEBLOCK3] = l[MAKEFLOATBLOCK] = l[GETFIELD] = + l[GETFLOATFIELD] = l[SETFIELD] = l[SETFLOATFIELD] = + l[BRANCH] = l[BRANCHIF] = l[BRANCHIFNOT] = l[PUSHTRAP] = + l[C_CALL1] = l[C_CALL2] = l[C_CALL3] = l[C_CALL4] = l[C_CALL5] = + l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] = + l[OFFSETREF] = l[OFFSETCLOSURE] = l[PUSHOFFSETCLOSURE] = 1; + + /* Instructions with two operands */ + l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] = + l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = + l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] = + l[BULTINT] = l[BUGEINT] = l[GETPUBMET] = 2; + + opcode_nargs = l; } - /* Instructions with one operand */ - l[PUSHACC] = l[ACC] = l[POP] = l[ASSIGN] = - l[PUSHENVACC] = l[ENVACC] = l[PUSH_RETADDR] = l[APPLY] = - l[APPTERM1] = l[APPTERM2] = l[APPTERM3] = l[RETURN] = - l[GRAB] = l[PUSHGETGLOBAL] = l[GETGLOBAL] = l[SETGLOBAL] = - l[PUSHATOM] = l[ATOM] = l[MAKEBLOCK1] = l[MAKEBLOCK2] = - l[MAKEBLOCK3] = l[MAKEFLOATBLOCK] = l[GETFIELD] = - l[GETFLOATFIELD] = l[SETFIELD] = l[SETFLOATFIELD] = - l[BRANCH] = l[BRANCHIF] = l[BRANCHIFNOT] = l[PUSHTRAP] = - l[C_CALL1] = l[C_CALL2] = l[C_CALL3] = l[C_CALL4] = l[C_CALL5] = - l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] = - l[OFFSETREF] = l[OFFSETCLOSURE] = l[PUSHOFFSETCLOSURE] = 1; - - /* Instructions with two operands */ - l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] = - l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = - l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] = - l[BULTINT] = l[BUGEINT] = l[GETPUBMET] = 2; + return opcode_nargs; +} + +void caml_thread_code (code_t code, asize_t len) +{ + code_t p; + int* l = caml_init_opcode_nargs(); len /= sizeof(opcode_t); for (p = code; p < code + len; /*nothing*/) { opcode_t instr = *p; - if (instr < 0 || instr > STOP){ + if (instr < 0 || instr >= FIRST_UNIMPLEMENTED_OP){ /* FIXME -- should Assert(false) ? caml_fatal_error_arg ("Fatal error in fix_code: bad opcode (%lx)\n", (char *)(long)instr); @@ -134,12 +151,12 @@ } *p++ = (opcode_t)(caml_instr_table[instr] - caml_instr_base); if (instr == SWITCH) { - uint32 sizes = *p++; - uint32 const_size = sizes & 0xFFFF; - uint32 block_size = sizes >> 16; + uint32_t sizes = *p++; + uint32_t const_size = sizes & 0xFFFF; + uint32_t block_size = sizes >> 16; p += const_size + block_size; } else if (instr == CLOSUREREC) { - uint32 nfuncs = *p++; + uint32_t nfuncs = *p++; p++; /* skip nvars */ p += nfuncs; } else { @@ -149,6 +166,13 @@ Assert(p == code + len); } +#else + +int* caml_init_opcode_nargs() +{ + return NULL; +} + #endif /* THREADED_CODE */ void caml_set_instruction(code_t pos, opcode_t instr) diff -Nru ocaml-4.01.0/byterun/fix_code.h ocaml-4.05.0/byterun/fix_code.h --- ocaml-4.01.0/byterun/fix_code.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/fix_code.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* Handling of blocks of bytecode (endianness switch, threading). */ - -#ifndef CAML_FIX_CODE_H -#define CAML_FIX_CODE_H - - -#include "config.h" -#include "misc.h" -#include "mlvalues.h" - -extern code_t caml_start_code; -extern asize_t caml_code_size; -extern unsigned char * caml_saved_code; - -void caml_init_code_fragments(); -void caml_load_code (int fd, asize_t len); -void caml_fixup_endianness (code_t code, asize_t len); -void caml_set_instruction (code_t pos, opcode_t instr); -int caml_is_instruction (opcode_t instr1, opcode_t instr2); - -#ifdef THREADED_CODE -extern char ** caml_instr_table; -extern char * caml_instr_base; -void caml_thread_code (code_t code, asize_t len); -#endif - -#endif /* CAML_FIX_CODE_H */ diff -Nru ocaml-4.01.0/byterun/floats.c ocaml-4.05.0/byterun/floats.c --- ocaml-4.01.0/byterun/floats.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/floats.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,36 +1,46 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ -/* The interface of this file is in "mlvalues.h" and "alloc.h" */ +#define CAML_INTERNALS + +/* The interface of this file is in "caml/mlvalues.h" and "caml/alloc.h" */ #include #include #include #include +#include +#include -#include "alloc.h" -#include "fail.h" -#include "memory.h" -#include "mlvalues.h" -#include "misc.h" -#include "reverse.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/misc.h" +#include "caml/reverse.h" +#include "caml/stacks.h" #ifdef _MSC_VER #include +#ifndef isnan #define isnan _isnan +#endif +#ifndef isfinite #define isfinite _finite #endif +#endif #ifdef ARCH_ALIGN_DOUBLE @@ -71,97 +81,181 @@ CAMLprim value caml_format_float(value fmt, value arg) { -#define MAX_DIGITS 350 -/* Max number of decimal digits in a "natural" (not artificially padded) - representation of a float. Can be quite big for %f format. - Max exponent for IEEE format is 308 decimal digits. - Rounded up for good measure. */ - char format_buffer[MAX_DIGITS + 20]; - int prec, i; - char * p; - char * dest; value res; double d = Double_val(arg); #ifdef HAS_BROKEN_PRINTF if (isfinite(d)) { #endif - prec = MAX_DIGITS; - for (p = String_val(fmt); *p != 0; p++) { - if (*p >= '0' && *p <= '9') { - i = atoi(p) + MAX_DIGITS; - if (i > prec) prec = i; - break; - } - } - for( ; *p != 0; p++) { - if (*p == '.') { - i = atoi(p+1) + MAX_DIGITS; - if (i > prec) prec = i; - break; - } - } - if (prec < sizeof(format_buffer)) { - dest = format_buffer; - } else { - dest = caml_stat_alloc(prec); - } - sprintf(dest, String_val(fmt), d); - res = caml_copy_string(dest); - if (dest != format_buffer) { - caml_stat_free(dest); - } + res = caml_alloc_sprintf(String_val(fmt), d); #ifdef HAS_BROKEN_PRINTF } else { - if (isnan(d)) - { + if (isnan(d)) { res = caml_copy_string("nan"); - } - else - { + } else { if (d > 0) - { res = caml_copy_string("inf"); - } else - { res = caml_copy_string("-inf"); - } } } #endif return res; } -/*CAMLprim*/ value caml_float_of_substring(value vs, value idx, value l) +CAMLprim value caml_hexstring_of_float(value arg, value vprec, value vstyle) { - char parse_buffer[64]; - char * buf, * src, * dst, * end; - mlsize_t len, lenvs; - double d; - intnat flen = Long_val(l); - intnat fidx = Long_val(idx); + union { uint64_t i; double d; } u; + int sign, exp; + uint64_t m; + char buffer[64]; + char * buf, * p; + intnat prec; + int d; + value res; - lenvs = caml_string_length(vs); - len = - fidx >= 0 && fidx < lenvs && flen > 0 && flen <= lenvs - fidx - ? flen : 0; - buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1); - src = String_val(vs) + fidx; - dst = buf; - while (len--) { - char c = *src++; - if (c != '_') *dst++ = c; + /* Allocate output buffer */ + prec = Long_val(vprec); + /* 12 chars for sign, 0x, decimal point, exponent */ + buf = (prec + 12 <= 64 ? buffer : caml_stat_alloc(prec + 12)); + /* Extract sign, mantissa, and exponent */ + u.d = Double_val(arg); + sign = u.i >> 63; + exp = (u.i >> 52) & 0x7FF; + m = u.i & (((uint64_t) 1 << 52) - 1); + /* Put sign */ + p = buf; + if (sign) { + *p++ = '-'; + } else { + switch (Int_val(vstyle)) { + case '+': *p++ = '+'; break; + case ' ': *p++ = ' '; break; + } } - *dst = 0; - if (dst == buf) goto error; - d = strtod((const char *) buf, &end); - if (end != dst) goto error; - if (buf != parse_buffer) caml_stat_free(buf); - return caml_copy_double(d); - error: - if (buf != parse_buffer) caml_stat_free(buf); - caml_failwith("float_of_string"); + /* Treat special cases */ + if (exp == 0x7FF) { + char * txt; + if (m == 0) txt = "infinity"; else txt = "nan"; + memcpy(p, txt, strlen(txt)); + p[strlen(txt)] = 0; + res = caml_copy_string(buf); + } else { + /* Output "0x" prefix */ + *p++ = '0'; *p++ = 'x'; + /* Normalize exponent and mantissa */ + if (exp == 0) { + if (m != 0) exp = -1022; /* denormal */ + } else { + exp = exp - 1023; + m = m | ((uint64_t) 1 << 52); + } + /* If a precision is given, and is small, round mantissa accordingly */ + prec = Long_val(vprec); + if (prec >= 0 && prec < 13) { + int i = 52 - prec * 4; + uint64_t unit = (uint64_t) 1 << i; + uint64_t half = unit >> 1; + uint64_t mask = unit - 1; + uint64_t frac = m & mask; + m = m & ~mask; + /* Round to nearest, ties to even */ + if (frac > half || (frac == half && (m & unit) != 0)) { + m += unit; + } + } + /* Leading digit */ + d = m >> 52; + *p++ = (d < 10 ? d + '0' : d - 10 + 'a'); + m = (m << 4) & (((uint64_t) 1 << 56) - 1); + /* Fractional digits. If a precision is given, print that number of + digits. Otherwise, print as many digits as needed to represent + the mantissa exactly. */ + if (prec >= 0 ? prec > 0 : m != 0) { + *p++ = '.'; + while (prec >= 0 ? prec > 0 : m != 0) { + d = m >> 52; + *p++ = (d < 10 ? d + '0' : d - 10 + 'a'); + m = (m << 4) & (((uint64_t) 1 << 56) - 1); + prec--; + } + } + *p = 0; + /* Add exponent */ + res = caml_alloc_sprintf("%sp%+d", buf, exp); + } + if (buf != buffer) caml_stat_free(buf); + return res; +} + +static int caml_float_of_hex(const char * s, double * res) +{ + int64_t m = 0; /* the mantissa - top 60 bits at most */ + int n_bits = 0; /* total number of bits read */ + int m_bits = 0; /* number of bits in mantissa */ + int x_bits = 0; /* number of bits after mantissa */ + int dec_point = -1; /* bit count corresponding to decimal point */ + /* -1 if no decimal point seen */ + int exp = 0; /* exponent */ + char * p; /* for converting the exponent */ + double f; + + while (*s != 0) { + char c = *s++; + switch (c) { + case '_': + break; + case '.': + if (dec_point >= 0) return -1; /* multiple decimal points */ + dec_point = n_bits; + break; + case 'p': case 'P': { + long e; + if (*s == 0) return -1; /* nothing after exponent mark */ + e = strtol(s, &p, 10); + if (*p != 0) return -1; /* ill-formed exponent */ + if (e < INT_MIN || e > INT_MAX) return -1; /* unreasonable exponent */ + exp = e; + s = p; /* stop at next loop iteration */ + break; + } + default: { /* Nonzero digit */ + int d; + if (c >= '0' && c <= '9') d = c - '0'; + else if (c >= 'A' && c <= 'F') d = c - 'A' + 10; + else if (c >= 'a' && c <= 'f') d = c - 'a' + 10; + else return -1; /* bad digit */ + n_bits += 4; + if (d == 0 && m == 0) break; /* leading zeros are skipped */ + if (m_bits < 60) { + /* There is still room in m. Add this digit to the mantissa. */ + m = (m << 4) + d; + m_bits += 4; + } else { + /* We've already collected 60 significant bits in m. + Now all we care about is whether there is a nonzero bit + after. In this case, round m to odd so that the later + rounding of m to FP produces the correct result. */ + if (d != 0) m |= 1; /* round to odd */ + x_bits += 4; + } + break; + } + } + } + if (n_bits == 0) return -1; + /* Convert mantissa to FP. We use a signed conversion because we can + (m has 60 bits at most) and because it is faster + on several architectures. */ + f = (double) (int64_t) m; + /* Adjust exponent to take decimal point and extra digits into account */ + if (dec_point >= 0) exp = exp + (dec_point - n_bits); + exp = exp + x_bits; + /* Apply exponent if needed */ + if (exp != 0) f = ldexp(f, exp); + /* Done! */ + *res = f; + return 0; } CAMLprim value caml_float_of_string(value vs) @@ -169,8 +263,20 @@ char parse_buffer[64]; char * buf, * src, * dst, * end; mlsize_t len; + int sign; double d; + /* Check for hexadecimal FP constant */ + src = String_val(vs); + sign = 1; + if (*src == '-') { sign = -1; src++; } + else if (*src == '+') { src++; }; + if (src[0] == '0' && (src[1] == 'x' || src[1] == 'X')) { + if (caml_float_of_hex(src + 2, &d) == -1) + caml_failwith("float_of_string"); + return caml_copy_double(sign < 0 ? -d : d); + } + /* Remove '_' characters before calling strtod () */ len = caml_string_length(vs); buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1); src = String_val(vs); @@ -181,6 +287,7 @@ } *dst = 0; if (dst == buf) goto error; + /* Convert using strtod */ d = strtod((const char *) buf, &end); if (end != dst) goto error; if (buf != parse_buffer) caml_stat_free(buf); @@ -188,6 +295,7 @@ error: if (buf != parse_buffer) caml_stat_free(buf); caml_failwith("float_of_string"); + return Val_unit; /* not reached */ } CAMLprim value caml_int_of_float(value f) @@ -258,6 +366,13 @@ CAMLreturn (res); } +// Seems dumb but intnat could not correspond to int type. +double caml_ldexp_float_unboxed(double f, intnat i) +{ + return ldexp(f, i); +} + + CAMLprim value caml_ldexp_float(value f, value i) { return caml_copy_double(ldexp(Double_val(f), Int_val(i))); @@ -359,9 +474,11 @@ return hypot(x, y); #else double tmp, ratio; - if (x != x) return x; /* NaN */ - if (y != y) return y; /* NaN */ x = fabs(x); y = fabs(y); + if (x != x) /* x is NaN */ + return y > DBL_MAX ? y : x; /* PR#6321 */ + if (y != y) /* y is NaN */ + return x > DBL_MAX ? x : y; /* PR#6321 */ if (x < y) { tmp = x; x = y; y = tmp; } if (x == 0.0) return 0.0; ratio = y / x; @@ -416,9 +533,9 @@ union double_as_two_int32 { double d; #if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) - struct { uint32 h; uint32 l; } i; + struct { uint32_t h; uint32_t l; } i; #else - struct { uint32 l; uint32 h; } i; + struct { uint32_t l; uint32_t h; } i; #endif }; @@ -441,73 +558,91 @@ return caml_copy_double(caml_copysign(Double_val(f), Double_val(g))); } -CAMLprim value caml_eq_float(value f, value g) +#ifdef LACKS_SANE_NAN + +CAMLprim value caml_neq_float(value vf, value vg) { - return Val_bool(Double_val(f) == Double_val(g)); + double f = Double_val(vf); + double g = Double_val(vg); + return Val_bool(isnan(f) || isnan(g) || f != g); } -CAMLprim value caml_neq_float(value f, value g) -{ - return Val_bool(Double_val(f) != Double_val(g)); +#define DEFINE_NAN_CMP(op) (value vf, value vg) \ +{ \ + double f = Double_val(vf); \ + double g = Double_val(vg); \ + return Val_bool(!isnan(f) && !isnan(g) && f op g); \ } -CAMLprim value caml_le_float(value f, value g) +intnat caml_float_compare_unboxed(double f, double g) { - return Val_bool(Double_val(f) <= Double_val(g)); + /* Insane => nan == everything && nan < everything && nan > everything */ + if (isnan(f) && isnan(g)) return 0; + if (!isnan(g) && f < g) return -1; + if (f != g) return 1; + return 0; } -CAMLprim value caml_lt_float(value f, value g) +#else + +CAMLprim value caml_neq_float(value f, value g) { - return Val_bool(Double_val(f) < Double_val(g)); + return Val_bool(Double_val(f) != Double_val(g)); } -CAMLprim value caml_ge_float(value f, value g) -{ - return Val_bool(Double_val(f) >= Double_val(g)); +#define DEFINE_NAN_CMP(op) (value f, value g) \ +{ \ + return Val_bool(Double_val(f) op Double_val(g)); \ } -CAMLprim value caml_gt_float(value f, value g) -{ - return Val_bool(Double_val(f) > Double_val(g)); +intnat caml_float_compare_unboxed(double f, double g) +{ + /* If one or both of f and g is NaN, order according to the convention + NaN = NaN and NaN < x for all other floats x. */ + /* This branchless implementation is from GPR#164. + Note that [f == f] if and only if f is not NaN. */ + return (f > g) - (f < g) + (f == f) - (g == g); } +#endif + +CAMLprim value caml_eq_float DEFINE_NAN_CMP(==) +CAMLprim value caml_le_float DEFINE_NAN_CMP(<=) +CAMLprim value caml_lt_float DEFINE_NAN_CMP(<) +CAMLprim value caml_ge_float DEFINE_NAN_CMP(>=) +CAMLprim value caml_gt_float DEFINE_NAN_CMP(>) + CAMLprim value caml_float_compare(value vf, value vg) { - double f = Double_val(vf); - double g = Double_val(vg); - if (f == g) return Val_int(0); - if (f < g) return Val_int(-1); - if (f > g) return Val_int(1); - /* One or both of f and g is NaN. Order according to the - convention NaN = NaN and NaN < x for all other floats x. */ - if (f == f) return Val_int(1); /* f is not NaN, g is NaN */ - if (g == g) return Val_int(-1); /* g is not NaN, f is NaN */ - return Val_int(0); /* both f and g are NaN */ + return Val_int(caml_float_compare_unboxed(Double_val(vf),Double_val(vg))); } enum { FP_normal, FP_subnormal, FP_zero, FP_infinite, FP_nan }; -CAMLprim value caml_classify_float(value vd) +value caml_classify_float_unboxed(double vd) { - /* Cygwin 1.3 has problems with fpclassify (PR#1293), so don't use it */ -#if defined(fpclassify) && !defined(__CYGWIN32__) && !defined(__MINGW32__) - switch (fpclassify(Double_val(vd))) { - case FP_NAN: - return Val_int(FP_nan); - case FP_INFINITE: - return Val_int(FP_infinite); - case FP_ZERO: - return Val_int(FP_zero); - case FP_SUBNORMAL: - return Val_int(FP_subnormal); - default: /* case FP_NORMAL */ - return Val_int(FP_normal); +#ifdef ARCH_SIXTYFOUR + union { double d; uint64_t i; } u; + uint64_t n; + uint32_t e; + + u.d = vd; + n = u.i << 1; /* shift sign bit off */ + if (n == 0) return Val_int(FP_zero); + e = n >> 53; /* extract exponent */ + if (e == 0) return Val_int(FP_subnormal); + if (e == 0x7FF) { + if (n << 11 == 0) /* shift exponent off */ + return Val_int(FP_infinite); + else + return Val_int(FP_nan); } + return Val_int(FP_normal); #else union double_as_two_int32 u; - uint32 h, l; + uint32_t h, l; - u.d = Double_val(vd); + u.d = vd; h = u.i.h; l = u.i.l; l = l | (h & 0xFFFFF); h = h & 0x7FF00000; @@ -525,6 +660,11 @@ #endif } +CAMLprim value caml_classify_float(value vd) +{ + return caml_classify_float_unboxed(Double_val(vd)); +} + /* The [caml_init_ieee_float] function should initialize floating-point hardware so that it behaves as much as possible like the IEEE standard. In particular, return special numbers like Infinity and NaN instead diff -Nru ocaml-4.01.0/byterun/freelist.c ocaml-4.05.0/byterun/freelist.c --- ocaml-4.01.0/byterun/freelist.c 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/byterun/freelist.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,19 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS #define FREELIST_DEBUG 0 #if FREELIST_DEBUG @@ -18,48 +22,48 @@ #include -#include "config.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "memory.h" -#include "major_gc.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/config.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/memory.h" +#include "caml/major_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" /* The free-list is kept sorted by increasing addresses. This makes the merging of adjacent free blocks possible. (See [caml_fl_merge_block].) */ -typedef struct { - char *next_bp; /* Pointer to the first byte of the next block. */ -} block; +/* A free list block is a [value] (integer representing a pointer to the + first word after the block's header). The end of the list is NULL. */ +#define Val_NULL ((value) NULL) /* The sentinel can be located anywhere in memory, but it must not be adjacent to any heap object. */ static struct { value filler1; /* Make sure the sentinel is never adjacent to any block. */ header_t h; - value first_bp; + value first_field; value filler2; /* Make sure the sentinel is never adjacent to any block. */ -} sentinel = {0, Make_header (0, 0, Caml_blue), 0, 0}; +} sentinel = {0, Make_header (0, 0, Caml_blue), Val_NULL, 0}; -#define Fl_head ((char *) (&(sentinel.first_bp))) -static char *fl_prev = Fl_head; /* Current allocation pointer. */ -static char *fl_last = NULL; /* Last block in the list. Only valid - just after [caml_fl_allocate] returns NULL. */ -char *caml_fl_merge = Fl_head; /* Current insertion pointer. Managed +#define Fl_head (Val_bp (&(sentinel.first_field))) +static value fl_prev = Fl_head; /* Current allocation pointer. */ +static value fl_last = Val_NULL; /* Last block in the list. Only valid + just after [caml_fl_allocate] returns NULL. */ +value caml_fl_merge = Fl_head; /* Current insertion pointer. Managed jointly with [sweep_slice]. */ -asize_t caml_fl_cur_size = 0; /* Number of words in the free list, +asize_t caml_fl_cur_wsz = 0; /* Number of words in the free list, including headers but not fragments. */ #define FLP_MAX 1000 -static char *flp [FLP_MAX]; +static value flp [FLP_MAX]; static int flp_size = 0; -static char *beyond = NULL; +static value beyond = Val_NULL; -#define Next(b) (((block *) (b))->next_bp) +#define Next(b) (Field (b, 0)) #define Policy_next_fit 0 #define Policy_first_fit 1 @@ -69,14 +73,14 @@ #ifdef DEBUG static void fl_check (void) { - char *cur, *prev; + value cur, prev; int prev_found = 0, flp_found = 0, merge_found = 0; uintnat size_found = 0; int sz = 0; prev = Fl_head; cur = Next (prev); - while (cur != NULL){ + while (cur != Val_NULL){ size_found += Whsize_bp (cur); Assert (Is_in_heap (cur)); if (cur == fl_prev) prev_found = 1; @@ -86,7 +90,7 @@ Assert (Next (flp[flp_found]) == cur); ++ flp_found; }else{ - Assert (beyond == NULL || cur >= Next (beyond)); + Assert (beyond == Val_NULL || cur >= Next (beyond)); } } if (cur == caml_fl_merge) merge_found = 1; @@ -96,36 +100,37 @@ if (policy == Policy_next_fit) Assert (prev_found || fl_prev == Fl_head); if (policy == Policy_first_fit) Assert (flp_found == flp_size); Assert (merge_found || caml_fl_merge == Fl_head); - Assert (size_found == caml_fl_cur_size); + Assert (size_found == caml_fl_cur_wsz); } #endif /* [allocate_block] is called by [caml_fl_allocate]. Given a suitable free - block and the desired size, it allocates a new block from the free + block and the requested size, it allocates a new block from the free block. There are three cases: - 0. The free block has the desired size. Detach the block from the + 0. The free block has the requested size. Detach the block from the free-list and return it. - 1. The free block is 1 word longer than the desired size. Detach + 1. The free block is 1 word longer than the requested size. Detach the block from the free list. The remaining word cannot be linked: turn it into an empty block (header only), and return the rest. - 2. The free block is big enough. Split it in two and return the right + 2. The free block is large enough. Split it in two and return the right block. In all cases, the allocated block is right-justified in the free block: - it is located in the high-address words of the free block. This way, + it is located in the high-address words of the free block, so that the linking of the free-list does not change in case 2. */ -static char *allocate_block (mlsize_t wh_sz, int flpi, char *prev, char *cur) +static header_t *allocate_block (mlsize_t wh_sz, int flpi, value prev, + value cur) { header_t h = Hd_bp (cur); Assert (Whsize_hd (h) >= wh_sz); if (Wosize_hd (h) < wh_sz + 1){ /* Cases 0 and 1. */ - caml_fl_cur_size -= Whsize_hd (h); + caml_fl_cur_wsz -= Whsize_hd (h); Next (prev) = Next (cur); - Assert (Is_in_heap (Next (prev)) || Next (prev) == NULL); + Assert (Is_in_heap (Next (prev)) || Next (prev) == Val_NULL); if (caml_fl_merge == cur) caml_fl_merge = prev; #ifdef DEBUG - fl_last = NULL; + fl_last = Val_NULL; #endif /* In case 1, the following creates the empty block correctly. In case 0, it gives an invalid header to the block. The function @@ -135,41 +140,84 @@ if (flpi + 1 < flp_size && flp[flpi + 1] == cur){ flp[flpi + 1] = prev; }else if (flpi == flp_size - 1){ - beyond = (prev == Fl_head) ? NULL : prev; + beyond = (prev == Fl_head) ? Val_NULL : prev; -- flp_size; } } }else{ /* Case 2. */ - caml_fl_cur_size -= wh_sz; + caml_fl_cur_wsz -= wh_sz; Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue); } if (policy == Policy_next_fit) fl_prev = prev; - return cur + Bosize_hd (h) - Bsize_wsize (wh_sz); + return (header_t *) &Field (cur, Wosize_hd (h) - wh_sz); } +#ifdef CAML_INSTR +static uintnat instr_size [20] = + {0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0}; +static char *instr_name [20] = { + NULL, + "alloc01@", + "alloc02@", + "alloc03@", + "alloc04@", + "alloc05@", + "alloc06@", + "alloc07@", + "alloc08@", + "alloc09@", + "alloc10-19@", + "alloc20-29@", + "alloc30-39@", + "alloc40-49@", + "alloc50-59@", + "alloc60-69@", + "alloc70-79@", + "alloc80-89@", + "alloc90-99@", + "alloc_large@", +}; +uintnat caml_instr_alloc_jump = 0; +/* number of pointers followed to allocate from the free list */ +#endif /*CAML_INSTR*/ + /* [caml_fl_allocate] does not set the header of the newly allocated block. The calling function must do it before any GC function gets called. [caml_fl_allocate] returns a head pointer. */ -char *caml_fl_allocate (mlsize_t wo_sz) +header_t *caml_fl_allocate (mlsize_t wo_sz) { - char *cur = NULL, *prev, *result; + value cur = Val_NULL, prev; + header_t *result; int i; mlsize_t sz, prevsz; Assert (sizeof (char *) == sizeof (value)); Assert (wo_sz >= 1); +#ifdef CAML_INSTR + if (wo_sz < 10){ + ++instr_size[wo_sz]; + }else if (wo_sz < 100){ + ++instr_size[wo_sz/10 + 9]; + }else{ + ++instr_size[19]; + } +#endif /* CAML_INSTR */ + switch (policy){ case Policy_next_fit: - Assert (fl_prev != NULL); + Assert (fl_prev != Val_NULL); /* Search from [fl_prev] to the end of the list. */ prev = fl_prev; cur = Next (prev); - while (cur != NULL){ Assert (Is_in_heap (cur)); + while (cur != Val_NULL){ Assert (Is_in_heap (cur)); if (Wosize_bp (cur) >= wo_sz){ return allocate_block (Whsize_wosize (wo_sz), 0, prev, cur); } prev = cur; cur = Next (prev); +#ifdef CAML_INSTR + ++ caml_instr_alloc_jump; +#endif } fl_last = prev; /* Search from the start of the list to [fl_prev]. */ @@ -181,6 +229,9 @@ } prev = cur; cur = Next (prev); +#ifdef CAML_INSTR + ++ caml_instr_alloc_jump; +#endif } /* No suitable block was found. */ return NULL; @@ -206,13 +257,13 @@ }else{ prev = Next (flp[flp_size - 1]); prevsz = Wosize_bp (prev); - if (beyond != NULL) prev = beyond; + if (beyond != Val_NULL) prev = beyond; } while (flp_size < FLP_MAX){ cur = Next (prev); - if (cur == NULL){ + if (cur == Val_NULL){ fl_last = prev; - beyond = (prev == Fl_head) ? NULL : prev; + beyond = (prev == Fl_head) ? Val_NULL : prev; return NULL; }else{ sz = Wosize_bp (cur); @@ -242,7 +293,7 @@ #if FREELIST_DEBUG fprintf (stderr, "FLP: table is full -- slow first-fit\n"); #endif - if (beyond != NULL){ + if (beyond != Val_NULL){ prev = beyond; }else{ prev = flp[flp_size - 1]; @@ -250,7 +301,7 @@ prevsz = Wosize_bp (Next (flp[FLP_MAX-1])); Assert (prevsz < wo_sz); cur = Next (prev); - while (cur != NULL){ + while (cur != Val_NULL){ Assert (Is_in_heap (cur)); sz = Wosize_bp (cur); if (sz < prevsz){ @@ -278,10 +329,10 @@ beyond = Next (flp[i]); -- flp_size; }else{ - beyond = NULL; + beyond = Val_NULL; } }else{ - char *buf [FLP_MAX]; + value buf [FLP_MAX]; int j = 0; mlsize_t oldsz = sz; @@ -304,19 +355,19 @@ #endif if (FLP_MAX >= flp_size + j - 1){ if (j != 1){ - memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (flp_size-i-1)); + memmove (&flp[i+j], &flp[i+1], sizeof (value) * (flp_size-i-1)); } - if (j > 0) memmove (&flp[i], &buf[0], sizeof (block *) * j); + if (j > 0) memmove (&flp[i], &buf[0], sizeof (value) * j); flp_size += j - 1; }else{ if (FLP_MAX > i + j){ if (j != 1){ - memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (FLP_MAX-i-j)); + memmove (&flp[i+j], &flp[i+1], sizeof (value) * (FLP_MAX-i-j)); } - if (j > 0) memmove (&flp[i], &buf[0], sizeof (block *) * j); + if (j > 0) memmove (&flp[i], &buf[0], sizeof (value) * j); }else{ if (i != FLP_MAX){ - memmove (&flp[i], &buf[0], sizeof (block *) * (FLP_MAX - i)); + memmove (&flp[i], &buf[0], sizeof (value) * (FLP_MAX - i)); } } flp_size = FLP_MAX - 1; @@ -335,10 +386,23 @@ return NULL; /* NOT REACHED */ } -static char *last_fragment; +/* Location of the last fragment seen by the sweeping code. + This is a pointer to the first word after the fragment, which is + the header of the next block. + Note that [last_fragment] doesn't point to the fragment itself, + but to the block after it. +*/ +static header_t *last_fragment; void caml_fl_init_merge (void) { +#ifdef CAML_INSTR + int i; + for (i = 1; i < 20; i++){ + CAML_INSTR_INT (instr_name[i], instr_size[i]); + instr_size[i] = 0; + } +#endif /* CAML_INSTR */ last_fragment = NULL; caml_fl_merge = Fl_head; #ifdef DEBUG @@ -346,21 +410,22 @@ #endif } -static void truncate_flp (char *changed) +static void truncate_flp (value changed) { if (changed == Fl_head){ flp_size = 0; - beyond = NULL; + beyond = Val_NULL; }else{ - while (flp_size > 0 && Next (flp[flp_size - 1]) >= changed) -- flp_size; - if (beyond >= changed) beyond = NULL; + while (flp_size > 0 && Next (flp[flp_size - 1]) >= changed) + -- flp_size; + if (beyond >= changed) beyond = Val_NULL; } } /* This is called by caml_compact_heap. */ void caml_fl_reset (void) { - Next (Fl_head) = NULL; + Next (Fl_head) = Val_NULL; switch (policy){ case Policy_next_fit: fl_prev = Fl_head; @@ -372,19 +437,20 @@ Assert (0); break; } - caml_fl_cur_size = 0; + caml_fl_cur_wsz = 0; caml_fl_init_merge (); } /* [caml_fl_merge_block] returns the head pointer of the next block after [bp], because merging blocks may change the size of [bp]. */ -char *caml_fl_merge_block (char *bp) +header_t *caml_fl_merge_block (value bp) { - char *prev, *cur, *adj; - header_t hd = Hd_bp (bp); + value prev, cur; + header_t *adj; + header_t hd = Hd_val (bp); mlsize_t prev_wosz; - caml_fl_cur_size += Whsize_hd (hd); + caml_fl_cur_wsz += Whsize_hd (hd); #ifdef DEBUG caml_set_fields (bp, 0, Debug_free_major); @@ -394,62 +460,62 @@ /* The sweep code makes sure that this is the right place to insert this block: */ Assert (prev < bp || prev == Fl_head); - Assert (cur > bp || cur == NULL); + Assert (cur > bp || cur == Val_NULL); if (policy == Policy_first_fit) truncate_flp (prev); /* If [last_fragment] and [bp] are adjacent, merge them. */ if (last_fragment == Hp_bp (bp)){ - mlsize_t bp_whsz = Whsize_bp (bp); + mlsize_t bp_whsz = Whsize_val (bp); if (bp_whsz <= Max_wosize){ hd = Make_header (bp_whsz, 0, Caml_white); - bp = last_fragment; - Hd_bp (bp) = hd; - caml_fl_cur_size += Whsize_wosize (0); + bp = (value) last_fragment; + Hd_val (bp) = hd; + caml_fl_cur_wsz += Whsize_wosize (0); } } /* If [bp] and [cur] are adjacent, remove [cur] from the free-list and merge them. */ - adj = bp + Bosize_hd (hd); - if (adj == Hp_bp (cur)){ - char *next_cur = Next (cur); - mlsize_t cur_whsz = Whsize_bp (cur); + adj = (header_t *) &Field (bp, Wosize_hd (hd)); + if (adj == Hp_val (cur)){ + value next_cur = Next (cur); + mlsize_t cur_whsz = Whsize_val (cur); if (Wosize_hd (hd) + cur_whsz <= Max_wosize){ Next (prev) = next_cur; if (policy == Policy_next_fit && fl_prev == cur) fl_prev = prev; hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue); - Hd_bp (bp) = hd; - adj = bp + Bosize_hd (hd); + Hd_val (bp) = hd; + adj = (header_t *) &Field (bp, Wosize_hd (hd)); #ifdef DEBUG - fl_last = NULL; - Next (cur) = (char *) Debug_free_major; - Hd_bp (cur) = Debug_free_major; + fl_last = Val_NULL; + Next (cur) = (value) Debug_free_major; + Hd_val (cur) = Debug_free_major; #endif cur = next_cur; } } /* If [prev] and [bp] are adjacent merge them, else insert [bp] into the free-list if it is big enough. */ - prev_wosz = Wosize_bp (prev); - if (prev + Bsize_wsize (prev_wosz) == Hp_bp (bp) + prev_wosz = Wosize_val (prev); + if ((header_t *) &Field (prev, prev_wosz) == Hp_val (bp) && prev_wosz + Whsize_hd (hd) < Max_wosize){ - Hd_bp (prev) = Make_header (prev_wosz + Whsize_hd (hd), 0,Caml_blue); + Hd_val (prev) = Make_header (prev_wosz + Whsize_hd (hd), 0,Caml_blue); #ifdef DEBUG - Hd_bp (bp) = Debug_free_major; + Hd_val (bp) = Debug_free_major; #endif Assert (caml_fl_merge == prev); }else if (Wosize_hd (hd) != 0){ - Hd_bp (bp) = Bluehd_hd (hd); + Hd_val (bp) = Bluehd_hd (hd); Next (bp) = cur; Next (prev) = bp; caml_fl_merge = bp; }else{ /* This is a fragment. Leave it in white but remember it for eventual merging with the next block. */ - last_fragment = bp; - caml_fl_cur_size -= Whsize_wosize (0); + last_fragment = (header_t *) bp; + caml_fl_cur_wsz -= Whsize_wosize (0); } return adj; } @@ -457,46 +523,47 @@ /* This is a heap extension. We have to insert it in the right place in the free-list. [caml_fl_add_blocks] can only be called right after a call to - [caml_fl_allocate] that returned NULL. + [caml_fl_allocate] that returned Val_NULL. Most of the heap extensions are expected to be at the end of the free list. (This depends on the implementation of [malloc].) [bp] must point to a list of blocks chained by their field 0, - terminated by NULL, and field 1 of the first block must point to + terminated by Val_NULL, and field 1 of the first block must point to the last block. */ -void caml_fl_add_blocks (char *bp) +void caml_fl_add_blocks (value bp) { - Assert (fl_last != NULL); - Assert (Next (fl_last) == NULL); - caml_fl_cur_size += Whsize_bp (bp); + Assert (fl_last != Val_NULL); + Assert (Next (fl_last) == Val_NULL); + caml_fl_cur_wsz += Whsize_bp (bp); if (bp > fl_last){ Next (fl_last) = bp; - if (fl_last == caml_fl_merge && bp < caml_gc_sweep_hp){ - caml_fl_merge = (char *) Field (bp, 1); + if (fl_last == caml_fl_merge && (char *) bp < caml_gc_sweep_hp){ + caml_fl_merge = Field (bp, 1); } if (policy == Policy_first_fit && flp_size < FLP_MAX){ flp [flp_size++] = fl_last; } }else{ - char *cur, *prev; + value cur, prev; prev = Fl_head; cur = Next (prev); - while (cur != NULL && cur < bp){ Assert (prev < bp || prev == Fl_head); + while (cur != Val_NULL && cur < bp){ + Assert (prev < bp || prev == Fl_head); /* XXX TODO: extend flp on the fly */ prev = cur; cur = Next (prev); } Assert (prev < bp || prev == Fl_head); - Assert (cur > bp || cur == NULL); + Assert (cur > bp || cur == Val_NULL); Next (Field (bp, 1)) = cur; Next (prev) = bp; /* When inserting blocks between [caml_fl_merge] and [caml_gc_sweep_hp], we must advance [caml_fl_merge] to the new block, so that [caml_fl_merge] is always the last free-list block before [caml_gc_sweep_hp]. */ - if (prev == caml_fl_merge && bp < caml_gc_sweep_hp){ - caml_fl_merge = (char *) Field (bp, 1); + if (prev == caml_fl_merge && (char *) bp < caml_gc_sweep_hp){ + caml_fl_merge = Field (bp, 1); } if (policy == Policy_first_fit) truncate_flp (bp); } @@ -522,8 +589,9 @@ }else{ sz = size; } - *(header_t *)p = Make_header (Wosize_whsize (sz), 0, color); - if (do_merge) caml_fl_merge_block (Bp_hp (p)); + *(header_t *)p = + Make_header (Wosize_whsize (sz), 0, color); + if (do_merge) caml_fl_merge_block (Val_hp (p)); size -= sz; p += sz; } @@ -538,7 +606,7 @@ break; case Policy_first_fit: flp_size = 0; - beyond = NULL; + beyond = Val_NULL; policy = p; break; default: diff -Nru ocaml-4.01.0/byterun/freelist.h ocaml-4.05.0/byterun/freelist.h --- ocaml-4.01.0/byterun/freelist.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/freelist.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ - -/* Free lists of heap blocks. */ - -#ifndef CAML_FREELIST_H -#define CAML_FREELIST_H - - -#include "misc.h" -#include "mlvalues.h" - -extern asize_t caml_fl_cur_size; /* size in words */ - -char *caml_fl_allocate (mlsize_t); -void caml_fl_init_merge (void); -void caml_fl_reset (void); -char *caml_fl_merge_block (char *); -void caml_fl_add_blocks (char *); -void caml_make_free_blocks (value *, mlsize_t, int, int); -void caml_set_allocation_policy (uintnat); - - -#endif /* CAML_FREELIST_H */ diff -Nru ocaml-4.01.0/byterun/gc_ctrl.c ocaml-4.05.0/byterun/gc_ctrl.c --- ocaml-4.01.0/byterun/gc_ctrl.c 2013-07-17 11:50:53.000000000 +0000 +++ ocaml-4.05.0/byterun/gc_ctrl.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,32 +1,41 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ - -#include "alloc.h" -#include "compact.h" -#include "custom.h" -#include "finalise.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/compact.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/finalise.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/signals.h" #ifdef NATIVE_CODE -#include "stack.h" +#include "caml/stack.h" #else -#include "stacks.h" +#include "caml/stacks.h" #endif +#include "caml/startup_aux.h" #ifndef NATIVE_CODE extern uintnat caml_max_stack_size; /* defined in stacks.c */ @@ -38,17 +47,17 @@ intnat caml_stat_minor_collections = 0, caml_stat_major_collections = 0, - caml_stat_heap_size = 0, /* bytes */ - caml_stat_top_heap_size = 0, /* bytes */ + caml_stat_heap_wsz = 0, + caml_stat_top_heap_wsz = 0, caml_stat_compactions = 0, caml_stat_heap_chunks = 0; -extern uintnat caml_major_heap_increment; /* bytes; see major_gc.c */ -extern uintnat caml_percent_free; /* see major_gc.c */ -extern uintnat caml_percent_max; /* see compact.c */ -extern uintnat caml_allocation_policy; /* see freelist.c */ +extern uintnat caml_major_heap_increment; /* percent or words; see major_gc.c */ +extern uintnat caml_percent_free; /* see major_gc.c */ +extern uintnat caml_percent_max; /* see compact.c */ +extern uintnat caml_allocation_policy; /* see freelist.c */ -#define Next(hp) ((hp) + Bhsize_hp (hp)) +#define Next(hp) ((hp) + Whsize_hp (hp)) #ifdef DEBUG @@ -77,7 +86,7 @@ } } -static void check_block (char *hp) +static void check_block (header_t *hp) { mlsize_t i; value v = Val_hp (hp); @@ -127,9 +136,9 @@ free_words = 0, free_blocks = 0, largest_free = 0, fragments = 0, heap_chunks = 0; char *chunk = caml_heap_start, *chunk_end; - char *cur_hp; + header_t *cur_hp; #ifdef DEBUG - char *prev_hp; + header_t *prev_hp; #endif header_t cur_hd; @@ -143,19 +152,20 @@ #ifdef DEBUG prev_hp = NULL; #endif - cur_hp = chunk; - while (cur_hp < chunk_end){ + cur_hp = (header_t *) chunk; + while (cur_hp < (header_t *) chunk_end){ cur_hd = Hd_hp (cur_hp); - Assert (Next (cur_hp) <= chunk_end); + Assert (Next (cur_hp) <= (header_t *) chunk_end); switch (Color_hd (cur_hd)){ case Caml_white: if (Wosize_hd (cur_hd) == 0){ ++ fragments; Assert (prev_hp == NULL || Color_hp (prev_hp) != Caml_blue - || cur_hp == caml_gc_sweep_hp); + || cur_hp == (header_t *) caml_gc_sweep_hp); }else{ - if (caml_gc_phase == Phase_sweep && cur_hp >= caml_gc_sweep_hp){ + if (caml_gc_phase == Phase_sweep + && cur_hp >= (header_t *) caml_gc_sweep_hp){ ++ free_blocks; free_words += Whsize_hd (cur_hd); if (Whsize_hd (cur_hd) > largest_free){ @@ -201,27 +211,30 @@ prev_hp = cur_hp; #endif cur_hp = Next (cur_hp); - } Assert (cur_hp == chunk_end); + } Assert (cur_hp == (header_t *) chunk_end); chunk = Chunk_next (chunk); } +#ifdef DEBUG + caml_final_invariant_check(); +#endif + Assert (heap_chunks == caml_stat_heap_chunks); - Assert (live_words + free_words + fragments - == Wsize_bsize (caml_stat_heap_size)); + Assert (live_words + free_words + fragments == caml_stat_heap_wsz); if (returnstats){ CAMLlocal1 (res); /* get a copy of these before allocating anything... */ double minwords = caml_stat_minor_words - + (double) Wsize_bsize (caml_young_end - caml_young_ptr); + + (double) (caml_young_alloc_end - caml_young_ptr); double prowords = caml_stat_promoted_words; double majwords = caml_stat_major_words + (double) caml_allocated_words; intnat mincoll = caml_stat_minor_collections; intnat majcoll = caml_stat_major_collections; - intnat heap_words = Wsize_bsize (caml_stat_heap_size); + intnat heap_words = caml_stat_heap_wsz; intnat cpct = caml_stat_compactions; - intnat top_heap_words = Wsize_bsize (caml_stat_top_heap_size); + intnat top_heap_words = caml_stat_top_heap_wsz; res = caml_alloc_tuple (16); Store_field (res, 0, caml_copy_double (minwords)); @@ -255,8 +268,12 @@ CAMLprim value caml_gc_stat(value v) { + value result; + CAML_INSTR_SETUP (tmr, ""); Assert (v == Val_unit); - return heap_stats (1); + result = heap_stats (1); + CAML_INSTR_TIME (tmr, "explicit/gc_stat"); + return result; } CAMLprim value caml_gc_quick_stat(value v) @@ -266,13 +283,13 @@ /* get a copy of these before allocating anything... */ double minwords = caml_stat_minor_words - + (double) Wsize_bsize (caml_young_end - caml_young_ptr); + + (double) (caml_young_alloc_end - caml_young_ptr); double prowords = caml_stat_promoted_words; double majwords = caml_stat_major_words + (double) caml_allocated_words; intnat mincoll = caml_stat_minor_collections; intnat majcoll = caml_stat_major_collections; - intnat heap_words = caml_stat_heap_size / sizeof (value); - intnat top_heap_words = caml_stat_top_heap_size / sizeof (value); + intnat heap_words = caml_stat_heap_wsz; + intnat top_heap_words = caml_stat_top_heap_wsz; intnat cpct = caml_stat_compactions; intnat heap_chunks = caml_stat_heap_chunks; @@ -296,6 +313,18 @@ CAMLreturn (res); } +double caml_gc_minor_words_unboxed() +{ + return (caml_stat_minor_words + + (double) (caml_young_alloc_end - caml_young_ptr)); +} + +CAMLprim value caml_gc_minor_words(value v) +{ + CAMLparam0 (); /* v is ignored */ + CAMLreturn(caml_copy_double(caml_gc_minor_words_unboxed())); +} + CAMLprim value caml_gc_counters(value v) { CAMLparam0 (); /* v is ignored */ @@ -303,7 +332,7 @@ /* get a copy of these before allocating anything... */ double minwords = caml_stat_minor_words - + (double) Wsize_bsize (caml_young_end - caml_young_ptr); + + (double) (caml_young_alloc_end - caml_young_ptr); double prowords = caml_stat_promoted_words; double majwords = caml_stat_major_words + (double) caml_allocated_words; @@ -314,14 +343,19 @@ CAMLreturn (res); } +CAMLprim value caml_gc_huge_fallback_count (value v) +{ + return Val_long (caml_huge_fallback_count); +} + CAMLprim value caml_gc_get(value v) { CAMLparam0 (); /* v is ignored */ CAMLlocal1 (res); - res = caml_alloc_tuple (7); - Store_field (res, 0, Val_long (Wsize_bsize (caml_minor_heap_size))); /* s */ - Store_field (res, 1,Val_long(Wsize_bsize(caml_major_heap_increment)));/* i */ + res = caml_alloc_tuple (8); + Store_field (res, 0, Val_long (caml_minor_heap_wsz)); /* s */ + Store_field (res, 1, Val_long (caml_major_heap_increment)); /* i */ Store_field (res, 2, Val_long (caml_percent_free)); /* o */ Store_field (res, 3, Val_long (caml_verb_gc)); /* v */ Store_field (res, 4, Val_long (caml_percent_max)); /* O */ @@ -331,6 +365,7 @@ Store_field (res, 5, Val_long (0)); #endif Store_field (res, 6, Val_long (caml_allocation_policy)); /* a */ + Store_field (res, 7, Val_long (caml_major_window)); /* w */ CAMLreturn (res); } @@ -346,14 +381,6 @@ return p; } -static intnat norm_heapincr (uintnat i) -{ -#define Psv (Wsize_bsize (Page_size)) - i = ((i + Psv - 1) / Psv) * Psv; - if (i < Heap_chunk_min) i = Heap_chunk_min; - return i; -} - static intnat norm_minsize (intnat s) { if (s < Minor_heap_min) s = Minor_heap_min; @@ -361,12 +388,20 @@ return s; } +static uintnat norm_window (intnat w) +{ + if (w < 1) w = 1; + if (w > Max_major_window) w = Max_major_window; + return w; +} + CAMLprim value caml_gc_set(value v) { uintnat newpf, newpm; asize_t newheapincr; - asize_t newminsize; + asize_t newminwsz; uintnat oldpolicy; + CAML_INSTR_SETUP (tmr, ""); caml_verb_gc = Long_val (Field (v, 3)); @@ -386,11 +421,16 @@ caml_gc_message (0x20, "New max overhead: %d%%\n", caml_percent_max); } - newheapincr = Bsize_wsize (norm_heapincr (Long_val (Field (v, 1)))); + newheapincr = Long_val (Field (v, 1)); if (newheapincr != caml_major_heap_increment){ caml_major_heap_increment = newheapincr; - caml_gc_message (0x20, "New heap increment size: %luk bytes\n", - caml_major_heap_increment/1024); + if (newheapincr > 1000){ + caml_gc_message (0x20, "New heap increment size: %luk words\n", + caml_major_heap_increment/1024); + }else{ + caml_gc_message (0x20, "New heap increment size: %lu%%\n", + caml_major_heap_increment); + } } oldpolicy = caml_allocation_policy; caml_set_allocation_policy (Long_val (Field (v, 6))); @@ -399,20 +439,35 @@ caml_allocation_policy); } + /* This field was added in 4.03.0. */ + if (Wosize_val (v) >= 8){ + int old_window = caml_major_window; + caml_set_major_window (norm_window (Long_val (Field (v, 7)))); + if (old_window != caml_major_window){ + caml_gc_message (0x20, "New smoothing window size: %d\n", + caml_major_window); + } + } + /* Minor heap size comes last because it will trigger a minor collection (thus invalidating [v]) and it can raise [Out_of_memory]. */ - newminsize = Bsize_wsize (norm_minsize (Long_val (Field (v, 0)))); - if (newminsize != caml_minor_heap_size){ - caml_gc_message (0x20, "New minor heap size: %luk bytes\n", - newminsize/1024); - caml_set_minor_heap_size (newminsize); + newminwsz = norm_minsize (Long_val (Field (v, 0))); + if (newminwsz != caml_minor_heap_wsz){ + caml_gc_message (0x20, "New minor heap size: %luk words\n", + newminwsz / 1024); + caml_set_minor_heap_size (Bsize_wsize (newminwsz)); } + CAML_INSTR_TIME (tmr, "explicit/gc_set"); return Val_unit; } CAMLprim value caml_gc_minor(value v) -{ Assert (v == Val_unit); - caml_minor_collection (); +{ + CAML_INSTR_SETUP (tmr, ""); + Assert (v == Val_unit); + caml_request_minor_gc (); + caml_gc_dispatch (); + CAML_INSTR_TIME (tmr, "explicit/gc_minor"); return Val_unit; } @@ -420,30 +475,34 @@ { float fp; - fp = 100.0 * caml_fl_cur_size - / (Wsize_bsize (caml_stat_heap_size) - caml_fl_cur_size); + fp = 100.0 * caml_fl_cur_wsz / (caml_stat_heap_wsz - caml_fl_cur_wsz); if (fp > 999999.0) fp = 999999.0; caml_gc_message (0x200, "Estimated overhead (lower bound) = %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", (uintnat) fp); - if (fp >= caml_percent_max && caml_stat_heap_chunks > 1){ + if (fp >= caml_percent_max){ caml_gc_message (0x200, "Automatic compaction triggered.\n", 0); caml_compact_heap (); } } CAMLprim value caml_gc_major(value v) -{ Assert (v == Val_unit); +{ + CAML_INSTR_SETUP (tmr, ""); + Assert (v == Val_unit); caml_gc_message (0x1, "Major GC cycle requested\n", 0); caml_empty_minor_heap (); caml_finish_major_cycle (); test_and_compact (); caml_final_do_calls (); + CAML_INSTR_TIME (tmr, "explicit/gc_major"); return Val_unit; } CAMLprim value caml_gc_full_major(value v) -{ Assert (v == Val_unit); +{ + CAML_INSTR_SETUP (tmr, ""); + Assert (v == Val_unit); caml_gc_message (0x1, "Full major GC cycle requested\n", 0); caml_empty_minor_heap (); caml_finish_major_cycle (); @@ -452,18 +511,23 @@ caml_finish_major_cycle (); test_and_compact (); caml_final_do_calls (); + CAML_INSTR_TIME (tmr, "explicit/gc_full_major"); return Val_unit; } CAMLprim value caml_gc_major_slice (value v) { + CAML_INSTR_SETUP (tmr, ""); Assert (Is_long (v)); - caml_empty_minor_heap (); - return Val_long (caml_major_collection_slice (Long_val (v))); + caml_major_collection_slice (Long_val (v)); + CAML_INSTR_TIME (tmr, "explicit/gc_major_slice"); + return Val_long (0); } CAMLprim value caml_gc_compaction(value v) -{ Assert (v == Val_unit); +{ + CAML_INSTR_SETUP (tmr, ""); + Assert (v == Val_unit); caml_gc_message (0x10, "Heap compaction requested\n", 0); caml_empty_minor_heap (); caml_finish_major_cycle (); @@ -472,31 +536,138 @@ caml_finish_major_cycle (); caml_compact_heap (); caml_final_do_calls (); + CAML_INSTR_TIME (tmr, "explicit/gc_compact"); return Val_unit; } +CAMLprim value caml_get_minor_free (value v) +{ + return Val_int (caml_young_ptr - caml_young_alloc_start); +} + +CAMLprim value caml_get_major_bucket (value v) +{ + long i = Long_val (v); + if (i < 0) caml_invalid_argument ("Gc.get_bucket"); + if (i < caml_major_window){ + i += caml_major_ring_index; + if (i >= caml_major_window) i -= caml_major_window; + CAMLassert (0 <= i && i < caml_major_window); + return Val_long ((long) (caml_major_ring[i] * 1e6)); + }else{ + return Val_long (0); + } +} + +CAMLprim value caml_get_major_credit (value v) +{ + CAMLassert (v == Val_unit); + return Val_long ((long) (caml_major_work_credit * 1e6)); +} + +uintnat caml_normalize_heap_increment (uintnat i) +{ + if (i < Bsize_wsize (Heap_chunk_min)){ + i = Bsize_wsize (Heap_chunk_min); + } + return ((i + Page_size - 1) >> Page_log) << Page_log; +} + +/* [minor_size] and [major_size] are numbers of words + [major_incr] is either a percentage or a number of words */ void caml_init_gc (uintnat minor_size, uintnat major_size, uintnat major_incr, uintnat percent_fr, - uintnat percent_m) + uintnat percent_m, uintnat window) { - uintnat major_heap_size = Bsize_wsize (norm_heapincr (major_size)); + uintnat major_heap_size = + Bsize_wsize (caml_normalize_heap_increment (major_size)); + CAML_INSTR_INIT (); + if (caml_init_alloc_for_heap () != 0){ + caml_fatal_error ("cannot initialize heap: mmap failed\n"); + } if (caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size)){ caml_fatal_error ("OCaml runtime error: cannot initialize page table\n"); } caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size))); - caml_major_heap_increment = Bsize_wsize (norm_heapincr (major_incr)); + caml_major_heap_increment = major_incr; caml_percent_free = norm_pfree (percent_fr); caml_percent_max = norm_pmax (percent_m); caml_init_major_heap (major_heap_size); - caml_gc_message (0x20, "Initial minor heap size: %luk bytes\n", - caml_minor_heap_size / 1024); + caml_major_window = norm_window (window); + caml_gc_message (0x20, "Initial minor heap size: %luk words\n", + caml_minor_heap_wsz / 1024); caml_gc_message (0x20, "Initial major heap size: %luk bytes\n", major_heap_size / 1024); caml_gc_message (0x20, "Initial space overhead: %lu%%\n", caml_percent_free); caml_gc_message (0x20, "Initial max overhead: %lu%%\n", caml_percent_max); - caml_gc_message (0x20, "Initial heap increment: %luk bytes\n", - caml_major_heap_increment / 1024); + if (caml_major_heap_increment > 1000){ + caml_gc_message (0x20, "Initial heap increment: %luk words\n", + caml_major_heap_increment / 1024); + }else{ + caml_gc_message (0x20, "Initial heap increment: %lu%%\n", + caml_major_heap_increment); + } caml_gc_message (0x20, "Initial allocation policy: %d\n", caml_allocation_policy); + caml_gc_message (0x20, "Initial smoothing window: %d\n", + caml_major_window); +} + + +/* FIXME After the startup_aux.c unification, move these functions there. */ + +CAMLprim value caml_runtime_variant (value unit) +{ + CAMLassert (unit == Val_unit); +#if defined (DEBUG) + return caml_copy_string ("d"); +#elif defined (CAML_INSTR) + return caml_copy_string ("i"); +#else + return caml_copy_string (""); +#endif +} + +extern int caml_parser_trace; + +CAMLprim value caml_runtime_parameters (value unit) +{ + CAMLassert (unit == Val_unit); + return caml_alloc_sprintf + ("a=%d,b=%d,H=%lu,i=%lu,l=%lu,o=%lu,O=%lu,p=%d,s=%lu,t=%lu,v=%lu,w=%d,W=%lu", + /* a */ (int) caml_allocation_policy, + /* b */ caml_backtrace_active, + /* h */ /* missing */ /* FIXME add when changed to min_heap_size */ + /* H */ caml_use_huge_pages, + /* i */ caml_major_heap_increment, +#ifdef NATIVE_CODE + /* l */ 0UL, +#else + /* l */ caml_max_stack_size, +#endif + /* o */ caml_percent_free, + /* O */ caml_percent_max, + /* p */ caml_parser_trace, + /* R */ /* missing */ + /* s */ caml_minor_heap_wsz, + /* t */ caml_trace_level, + /* v */ caml_verb_gc, + /* w */ caml_major_window, + /* W */ caml_runtime_warnings + ); +} + +/* Control runtime warnings */ + +CAMLprim value caml_ml_enable_runtime_warnings(value vbool) +{ + caml_runtime_warnings = Bool_val(vbool); + return Val_unit; +} + +CAMLprim value caml_ml_runtime_warnings_enabled(value unit) +{ + CAMLassert (unit == Val_unit); + return Val_bool(caml_runtime_warnings); } diff -Nru ocaml-4.01.0/byterun/gc_ctrl.h ocaml-4.05.0/byterun/gc_ctrl.h --- ocaml-4.01.0/byterun/gc_ctrl.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/gc_ctrl.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_GC_CTRL_H -#define CAML_GC_CTRL_H - -#include "misc.h" - -extern double - caml_stat_minor_words, - caml_stat_promoted_words, - caml_stat_major_words; - -extern intnat - caml_stat_minor_collections, - caml_stat_major_collections, - caml_stat_heap_size, - caml_stat_top_heap_size, - caml_stat_compactions, - caml_stat_heap_chunks; - -void caml_init_gc (uintnat, uintnat, uintnat, - uintnat, uintnat); - - -#ifdef DEBUG -void caml_heap_check (void); -#endif - -#endif /* CAML_GC_CTRL_H */ diff -Nru ocaml-4.01.0/byterun/gc.h ocaml-4.05.0/byterun/gc.h --- ocaml-4.01.0/byterun/gc.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/gc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_GC_H -#define CAML_GC_H - - -#include "mlvalues.h" - -#define Caml_white (0 << 8) -#define Caml_gray (1 << 8) -#define Caml_blue (2 << 8) -#define Caml_black (3 << 8) - -#define Color_hd(hd) ((color_t) ((hd) & Caml_black)) -#define Color_hp(hp) (Color_hd (Hd_hp (hp))) -#define Color_val(val) (Color_hd (Hd_val (val))) - -#define Is_white_hd(hd) (Color_hd (hd) == Caml_white) -#define Is_gray_hd(hd) (Color_hd (hd) == Caml_gray) -#define Is_blue_hd(hd) (Color_hd (hd) == Caml_blue) -#define Is_black_hd(hd) (Color_hd (hd) == Caml_black) - -#define Whitehd_hd(hd) (((hd) & ~Caml_black)/*| Caml_white*/) -#define Grayhd_hd(hd) (((hd) & ~Caml_black) | Caml_gray) -#define Blackhd_hd(hd) (((hd)/*& ~Caml_black*/)| Caml_black) -#define Bluehd_hd(hd) (((hd) & ~Caml_black) | Caml_blue) - -/* This depends on the layout of the header. See [mlvalues.h]. */ -#define Make_header(wosize, tag, color) \ - (/*Assert ((wosize) <= Max_wosize),*/ \ - ((header_t) (((header_t) (wosize) << 10) \ - + (color) \ - + (tag_t) (tag))) \ - ) - -#define Is_white_val(val) (Color_val(val) == Caml_white) -#define Is_gray_val(val) (Color_val(val) == Caml_gray) -#define Is_blue_val(val) (Color_val(val) == Caml_blue) -#define Is_black_val(val) (Color_val(val) == Caml_black) - -/* For extern.c */ -#define Colornum_hd(hd) ((color_t) (((hd) >> 8) & 3)) -#define Coloredhd_hd(hd,colnum) (((hd) & ~Caml_black) | ((colnum) << 8)) - -#endif /* CAML_GC_H */ diff -Nru ocaml-4.01.0/byterun/globroots.c ocaml-4.05.0/byterun/globroots.c --- ocaml-4.01.0/byterun/globroots.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/globroots.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,23 +1,27 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Registration of global memory roots */ -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "globroots.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/globroots.h" /* The sets of global memory roots are represented as skip lists (see William Pugh, "Skip lists: a probabilistic alternative to @@ -43,11 +47,11 @@ (i.e. 2 * (NUM_LEVELS - 1)). Moreover, the congruential PRNG is faster and guaranteed to be deterministic (to reproduce bugs). */ -static uint32 random_seed = 0; +static uint32_t random_seed = 0; static int random_level(void) { - uint32 r; + uint32_t r; int level = 0; /* Linear congruence with modulus = 2^32, multiplier = 69069 @@ -70,6 +74,8 @@ struct global_root * e, * f; int i, new_level; + Assert(0 <= rootlist->level && rootlist->level < NUM_LEVELS); + /* Init "cursor" to list head */ e = (struct global_root *) rootlist; /* Find place to insert new node */ @@ -109,6 +115,8 @@ struct global_root * e, * f; int i; + Assert(0 <= rootlist->level && rootlist->level < NUM_LEVELS); + /* Init "cursor" to list head */ e = (struct global_root *) rootlist; /* Find element in list */ @@ -155,6 +163,8 @@ struct global_root * gr, * next; int i; + Assert(0 <= rootlist->level && rootlist->level < NUM_LEVELS); + for (gr = rootlist->forward[0]; gr != NULL; /**/) { next = gr->forward[0]; caml_stat_free(gr); @@ -208,9 +218,9 @@ { value v = *r; if (Is_block(v)) { - if (Is_young(v)) + if (Is_in_heap_or_young(v)) caml_delete_global_root(&caml_global_roots_young, r); - else if (Is_in_heap(v)) + if (Is_in_heap(v)) caml_delete_global_root(&caml_global_roots_old, r); } } @@ -246,9 +256,9 @@ the root should be removed. If [oldval] is young, this will happen anyway at the next minor collection, but it is safer to delete it here. */ - if (Is_young(oldval)) + if (Is_in_heap_or_young(oldval)) caml_delete_global_root(&caml_global_roots_young, r); - else if (Is_in_heap(oldval)) + if (Is_in_heap(oldval)) caml_delete_global_root(&caml_global_roots_old, r); } /* end PR#4704 */ diff -Nru ocaml-4.01.0/byterun/globroots.h ocaml-4.05.0/byterun/globroots.h --- ocaml-4.01.0/byterun/globroots.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/globroots.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 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. */ -/* */ -/***********************************************************************/ - -/* Registration of global memory roots */ - -#ifndef CAML_GLOBROOTS_H -#define CAML_GLOBROOTS_H - -#include "mlvalues.h" -#include "roots.h" - -void caml_scan_global_roots(scanning_action f); -void caml_scan_global_young_roots(scanning_action f); - -#endif /* CAML_GLOBROOTS_H */ diff -Nru ocaml-4.01.0/byterun/hash.c ocaml-4.05.0/byterun/hash.c --- ocaml-4.01.0/byterun/hash.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/hash.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,31 +1,29 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* The generic hashing primitive */ /* The interface of this file is in "mlvalues.h" (for [caml_hash_variant]) and in "hash.h" (for the other exported functions). */ -#include "mlvalues.h" -#include "custom.h" -#include "memory.h" -#include "hash.h" - -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif +#include "caml/mlvalues.h" +#include "caml/custom.h" +#include "caml/memory.h" +#include "caml/hash.h" /* The new implementation, based on MurmurHash 3, http://code.google.com/p/smhasher/ */ @@ -47,7 +45,7 @@ h *= 0xc2b2ae35; \ h ^= h >> 16; -CAMLexport uint32 caml_hash_mix_uint32(uint32 h, uint32 d) +CAMLexport uint32_t caml_hash_mix_uint32(uint32_t h, uint32_t d) { MIX(h, d); return h; @@ -55,17 +53,17 @@ /* Mix a platform-native integer. */ -CAMLexport uint32 caml_hash_mix_intnat(uint32 h, intnat d) +CAMLexport uint32_t caml_hash_mix_intnat(uint32_t h, intnat d) { - uint32 n; + uint32_t n; #ifdef ARCH_SIXTYFOUR /* Mix the low 32 bits and the high 32 bits, in a way that preserves - 32/64 compatibility: we want n = (uint32) d + 32/64 compatibility: we want n = (uint32_t) d if d is in the range [-2^31, 2^31-1]. */ n = (d >> 32) ^ (d >> 63) ^ d; /* If 0 <= d < 2^31: d >> 32 = 0 d >> 63 = 0 If -2^31 <= d < 0: d >> 32 = -1 d >> 63 = -1 - In both cases, n = (uint32) d. */ + In both cases, n = (uint32_t) d. */ #else n = d; #endif @@ -75,11 +73,9 @@ /* Mix a 64-bit integer. */ -CAMLexport uint32 caml_hash_mix_int64(uint32 h, int64 d) +CAMLexport uint32_t caml_hash_mix_int64(uint32_t h, int64_t d) { - uint32 hi, lo; - - I64_split(d, hi, lo); + uint32_t hi = (uint32_t) (d >> 32), lo = (uint32_t) d; MIX(h, lo); MIX(h, hi); return h; @@ -90,17 +86,17 @@ Treats all NaNs identically. */ -CAMLexport uint32 caml_hash_mix_double(uint32 hash, double d) +CAMLexport uint32_t caml_hash_mix_double(uint32_t hash, double d) { union { double d; #if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) - struct { uint32 h; uint32 l; } i; + struct { uint32_t h; uint32_t l; } i; #else - struct { uint32 l; uint32 h; } i; + struct { uint32_t l; uint32_t h; } i; #endif } u; - uint32 h, l; + uint32_t h, l; /* Convert to two 32-bit halves */ u.d = d; h = u.i.h; l = u.i.l; @@ -123,14 +119,14 @@ Treats all NaNs identically. */ -CAMLexport uint32 caml_hash_mix_float(uint32 hash, float d) +CAMLexport uint32_t caml_hash_mix_float(uint32_t hash, float d) { union { float f; - uint32 i; + uint32_t i; } u; - uint32 n; - /* Convert to int32 */ + uint32_t n; + /* Convert to int32_t */ u.f = d; n = u.i; /* Normalize NaNs */ if ((n & 0x7F800000) == 0x7F800000 && (n & 0x007FFFFF) != 0) { @@ -146,11 +142,11 @@ /* Mix an OCaml string */ -CAMLexport uint32 caml_hash_mix_string(uint32 h, value s) +CAMLexport uint32_t caml_hash_mix_string(uint32_t h, value s) { mlsize_t len = caml_string_length(s); mlsize_t i; - uint32 w; + uint32_t w; /* Mix by 32-bit blocks (little-endian) */ for (i = 0; i + 4 <= len; i += 4) { @@ -160,7 +156,7 @@ | (Byte_u(s, i+2) << 16) | (Byte_u(s, i+3) << 24); #else - w = *((uint32 *) &Byte_u(s, i)); + w = *((uint32_t *) &Byte_u(s, i)); #endif MIX(h, w); } @@ -174,12 +170,14 @@ default: /*skip*/; /* len & 3 == 0, no extra bytes, do nothing */ } /* Finally, mix in the length. Ignore the upper 32 bits, generally 0. */ - h ^= (uint32) len; + h ^= (uint32_t) len; return h; } /* Maximal size of the queue used for breadth-first traversal. */ #define HASH_QUEUE_SIZE 256 +/* Maximal number of Forward_tag links followed in one step */ +#define MAX_FORWARD_DEREFERENCE 1000 /* The generic hash function */ @@ -190,7 +188,7 @@ intnat wr; /* One past position of last value in queue */ intnat sz; /* Max number of values to put in queue */ intnat num; /* Max number of meaningful values to see */ - uint32 h; /* Rolling hash */ + uint32_t h; /* Rolling hash */ value v; mlsize_t i, len; @@ -221,7 +219,7 @@ for (i = 0, len = Wosize_val(v) / Double_wosize; i < len; i++) { h = caml_hash_mix_double(h, Double_field(v, i)); num--; - if (num < 0) break; + if (num <= 0) break; } break; case Abstract_tag: @@ -234,8 +232,15 @@ v = v - Infix_offset_val(v); goto again; case Forward_tag: - v = Forward_val(v); - goto again; + /* PR#6361: we can have a loop here, so limit the number of + Forward_tag links being followed */ + for (i = MAX_FORWARD_DEREFERENCE; i > 0; i--) { + v = Forward_val(v); + if (Is_long(v) || !Is_in_value_area(v) || Tag_val(v) != Forward_tag) + goto again; + } + /* Give up on this object and move to the next */ + break; case Object_tag: h = caml_hash_mix_intnat(h, Oid_val(v)); num--; @@ -244,7 +249,7 @@ /* If no hashing function provided, do nothing. */ /* Only use low 32 bits of custom hash, for 32/64 compatibility */ if (Custom_ops_val(v)->hash != NULL) { - uint32 n = (uint32) Custom_ops_val(v)->hash(v); + uint32_t n = (uint32_t) Custom_ops_val(v)->hash(v); h = caml_hash_mix_uint32(h, n); num--; } @@ -407,5 +412,5 @@ #endif /* Force sign extension of bit 31 for compatibility between 32 and 64-bit platforms */ - return (int32) accu; + return (int32_t) accu; } diff -Nru ocaml-4.01.0/byterun/hash.h ocaml-4.05.0/byterun/hash.h --- ocaml-4.01.0/byterun/hash.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/hash.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ -/* */ -/* Copyright 2011 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. */ -/* */ -/***********************************************************************/ - -/* Auxiliary functions for custom hash functions */ - -#ifndef CAML_HASH_H -#define CAML_HASH_H - -#include "mlvalues.h" - -CAMLextern uint32 caml_hash_mix_uint32(uint32 h, uint32 d); -CAMLextern uint32 caml_hash_mix_intnat(uint32 h, intnat d); -CAMLextern uint32 caml_hash_mix_int64(uint32 h, int64 d); -CAMLextern uint32 caml_hash_mix_double(uint32 h, double d); -CAMLextern uint32 caml_hash_mix_float(uint32 h, float d); -CAMLextern uint32 caml_hash_mix_string(uint32 h, value s); - - -#endif diff -Nru ocaml-4.01.0/byterun/.ignore ocaml-4.05.0/byterun/.ignore --- ocaml-4.01.0/byterun/.ignore 2012-07-26 19:21:54.000000000 +0000 +++ ocaml-4.05.0/byterun/.ignore 1970-01-01 00:00:00.000000000 +0000 @@ -1,16 +0,0 @@ -jumptbl.h -primitives -prims.c -opnames.h -version.h -ocamlrun -ocamlrun.exe -ocamlrund -ocamlrund.exe -ld.conf -interp.a.lst -*.[sd]obj -*.lib -.gdb_history -*.d.c -*.pic.c diff -Nru ocaml-4.01.0/byterun/instrtrace.c ocaml-4.05.0/byterun/instrtrace.c --- ocaml-4.01.0/byterun/instrtrace.c 2013-03-22 18:36:22.000000000 +0000 +++ ocaml-4.05.0/byterun/instrtrace.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,19 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Trace the instructions executed */ @@ -19,12 +23,14 @@ #include #include -#include "instruct.h" -#include "misc.h" -#include "mlvalues.h" -#include "opnames.h" -#include "prims.h" -#include "stacks.h" +#include "caml/instrtrace.h" +#include "caml/instruct.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/opnames.h" +#include "caml/prims.h" +#include "caml/stacks.h" +#include "caml/startup_aux.h" extern code_t caml_start_code; @@ -32,8 +38,6 @@ void caml_stop_here () {} -int caml_trace_flag = 0; - void caml_disasm_instr(pc) code_t pc; { @@ -84,7 +88,7 @@ char *nam; nam = (instr < 0 || instr > STOP) - ? (sprintf (nambuf, "???%d", instr), nambuf) + ? (snprintf (nambuf, sizeof(nambuf), "???%d", instr), nambuf) : names_of_instructions[instr]; pc++; switch (instr) { @@ -125,7 +129,7 @@ case OFFSETREF: case OFFSETCLOSURE: case PUSHOFFSETCLOSURE: - sprintf(buf, "%s %d", nam, pc[0]); + snprintf(buf, sizeof(buf), "%s %d", nam, pc[0]); break; /* Instructions with two operands */ case APPTERM: @@ -142,16 +146,16 @@ case BGEINT: case BULTINT: case BUGEINT: - sprintf(buf, "%s %d, %d", nam, pc[0], pc[1]); + snprintf(buf, sizeof(buf), "%s %d, %d", nam, pc[0], pc[1]); break; case SWITCH: - sprintf(buf, "SWITCH sz%#lx=%ld::ntag%ld nint%ld", + snprintf(buf, sizeof(buf), "SWITCH sz%#lx=%ld::ntag%ld nint%ld", (long) pc[0], (long) pc[0], (unsigned long) pc[0] >> 16, (unsigned long) pc[0] & 0xffff); break; /* Instructions with a C primitive as operand */ case C_CALLN: - sprintf(buf, "%s %d,", nam, pc[0]); + snprintf(buf, sizeof(buf), "%s %d,", nam, pc[0]); pc++; /* fallthrough */ case C_CALL1: @@ -160,12 +164,13 @@ case C_CALL4: case C_CALL5: if (pc[0] < 0 || pc[0] >= caml_prim_name_table.size) - sprintf(buf, "%s unknown primitive %d", nam, pc[0]); + snprintf(buf, sizeof(buf), "%s unknown primitive %d", nam, pc[0]); else - sprintf(buf, "%s %s", nam, (char *) caml_prim_name_table.contents[pc[0]]); + snprintf(buf, sizeof(buf), "%s %s", + nam, (char *) caml_prim_name_table.contents[pc[0]]); break; default: - sprintf(buf, "%s", nam); + snprintf(buf, sizeof(buf), "%s", nam); break; }; return buf; @@ -182,25 +187,26 @@ if (prog && v % sizeof (int) == 0 && (code_t) v >= prog && (code_t) v < (code_t) ((char *) prog + proglen)) - fprintf (f, "=code@%ld", (code_t) v - prog); + fprintf (f, "=code@%ld", (long) ((code_t) v - prog)); else if (Is_long (v)) fprintf (f, "=long%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val (v)); else if ((void*)v >= (void*)caml_stack_low && (void*)v < (void*)caml_stack_high) - fprintf (f, "=stack_%ld", (intnat*)caml_stack_high - (intnat*)v); + fprintf (f, "=stack_%ld", (long) ((intnat*)caml_stack_high - (intnat*)v)); else if (Is_block (v)) { int s = Wosize_val (v); int tg = Tag_val (v); int l = 0; switch (tg) { case Closure_tag: - fprintf (f, "=closure[s%d,cod%ld]", s, (code_t) (Code_val (v)) - prog); + fprintf (f, "=closure[s%d,cod%ld]", + s, (long) ((code_t) (Code_val (v)) - prog)); goto displayfields; case String_tag: l = caml_string_length (v); fprintf (f, "=string[s%dL%d]'", s, l); for (i = 0; i < ((l>0x1f)?0x1f:l) ; i++) { - if (isprint (Byte (v, i))) + if (isprint ((int) Byte (v, i))) putc (Byte (v, i), f); else putc ('?', f); @@ -250,10 +256,10 @@ fprintf (f, "accu="); caml_trace_value_file (accu, prog, proglen, f); fprintf (f, "\n sp=%#" ARCH_INTNAT_PRINTF_FORMAT "x @%ld:", - (intnat) sp, caml_stack_high - sp); - for (p = sp, i = 0; i < 12 + (1 << caml_trace_flag) && p < caml_stack_high; + (intnat) sp, (long) (caml_stack_high - sp)); + for (p = sp, i = 0; i < 12 + (1 << caml_trace_level) && p < caml_stack_high; p++, i++) { - fprintf (f, "\n[%ld] ", caml_stack_high - p); + fprintf (f, "\n[%ld] ", (long) (caml_stack_high - p)); caml_trace_value_file (*p, prog, proglen, f); }; putc ('\n', f); diff -Nru ocaml-4.01.0/byterun/instrtrace.h ocaml-4.05.0/byterun/instrtrace.h --- ocaml-4.01.0/byterun/instrtrace.h 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/byterun/instrtrace.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* Trace the instructions executed */ - -#ifndef _instrtrace_ -#define _instrtrace_ - - -#include "mlvalues.h" -#include "misc.h" - -extern int caml_trace_flag; -extern intnat caml_icount; -void caml_stop_here (void); -void caml_disasm_instr (code_t pc); -void caml_trace_value_file (value v, code_t prog, int proglen, FILE * f); -void caml_trace_accu_sp_file(value accu, value * sp, code_t prog, int proglen, - FILE * f); -#endif diff -Nru ocaml-4.01.0/byterun/instruct.h ocaml-4.05.0/byterun/instruct.h --- ocaml-4.01.0/byterun/instruct.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/instruct.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* The instruction set. */ - -#ifndef CAML_INSTRUCT_H -#define CAML_INSTRUCT_H - -enum instructions { - ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, - ACC, PUSH, - PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, - PUSHACC4, PUSHACC5, PUSHACC6, PUSHACC7, - PUSHACC, POP, ASSIGN, - ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC, - PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC, - PUSH_RETADDR, APPLY, APPLY1, APPLY2, APPLY3, - APPTERM, APPTERM1, APPTERM2, APPTERM3, - RETURN, RESTART, GRAB, - CLOSURE, CLOSUREREC, - OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE, - PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, - PUSHOFFSETCLOSURE2, PUSHOFFSETCLOSURE, - GETGLOBAL, PUSHGETGLOBAL, GETGLOBALFIELD, PUSHGETGLOBALFIELD, SETGLOBAL, - ATOM0, ATOM, PUSHATOM0, PUSHATOM, - MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEFLOATBLOCK, - GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD, GETFLOATFIELD, - SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD, SETFLOATFIELD, - VECTLENGTH, GETVECTITEM, SETVECTITEM, - GETSTRINGCHAR, SETSTRINGCHAR, - BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT, - PUSHTRAP, POPTRAP, RAISE, CHECK_SIGNALS, - C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALL5, C_CALLN, - CONST0, CONST1, CONST2, CONST3, CONSTINT, - PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, - NEGINT, ADDINT, SUBINT, MULINT, DIVINT, MODINT, - ANDINT, ORINT, XORINT, LSLINT, LSRINT, ASRINT, - EQ, NEQ, LTINT, LEINT, GTINT, GEINT, - OFFSETINT, OFFSETREF, ISINT, - GETMETHOD, - BEQ, BNEQ, BLTINT, BLEINT, BGTINT, BGEINT, - ULTINT, UGEINT, - BULTINT, BUGEINT, - GETPUBMET, GETDYNMET, - STOP, - EVENT, BREAK -}; - -#endif /* CAML_INSTRUCT_H */ diff -Nru ocaml-4.01.0/byterun/int64_emul.h ocaml-4.05.0/byterun/int64_emul.h --- ocaml-4.01.0/byterun/int64_emul.h 2012-11-29 09:55:00.000000000 +0000 +++ ocaml-4.05.0/byterun/int64_emul.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,287 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 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. */ -/* */ -/***********************************************************************/ - -/* Software emulation of 64-bit integer arithmetic, for C compilers - that do not support it. */ - -#ifndef CAML_INT64_EMUL_H -#define CAML_INT64_EMUL_H - -#include - -#ifdef ARCH_BIG_ENDIAN -#define I64_literal(hi,lo) { hi, lo } -#else -#define I64_literal(hi,lo) { lo, hi } -#endif - -#define I64_split(x,hi,lo) (hi = (x).h, lo = (x).l) - -/* Unsigned comparison */ -static int I64_ucompare(uint64 x, uint64 y) -{ - if (x.h > y.h) return 1; - if (x.h < y.h) return -1; - if (x.l > y.l) return 1; - if (x.l < y.l) return -1; - return 0; -} - -#define I64_ult(x, y) (I64_ucompare(x, y) < 0) - -/* Signed comparison */ -static int I64_compare(int64 x, int64 y) -{ - if ((int32)x.h > (int32)y.h) return 1; - if ((int32)x.h < (int32)y.h) return -1; - if (x.l > y.l) return 1; - if (x.l < y.l) return -1; - return 0; -} - -/* Negation */ -static int64 I64_neg(int64 x) -{ - int64 res; - res.l = -x.l; - res.h = ~x.h; - if (res.l == 0) res.h++; - return res; -} - -/* Addition */ -static int64 I64_add(int64 x, int64 y) -{ - int64 res; - res.l = x.l + y.l; - res.h = x.h + y.h; - if (res.l < x.l) res.h++; - return res; -} - -/* Subtraction */ -static int64 I64_sub(int64 x, int64 y) -{ - int64 res; - res.l = x.l - y.l; - res.h = x.h - y.h; - if (x.l < y.l) res.h--; - return res; -} - -/* Multiplication */ -static int64 I64_mul(int64 x, int64 y) -{ - int64 res; - uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); - uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF); - uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16); - uint32 prod11 = (x.l >> 16) * (y.l >> 16); - res.l = prod00; - res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); - prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; - prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++; - res.h += x.l * y.h + x.h * y.l; - return res; -} - -#define I64_is_zero(x) (((x).l | (x).h) == 0) -#define I64_is_negative(x) ((int32) (x).h < 0) -#define I64_is_min_int(x) ((x).l == 0 && (x).h == 0x80000000U) -#define I64_is_minus_one(x) (((x).l & (x).h) == 0xFFFFFFFFU) - -/* Bitwise operations */ -static int64 I64_and(int64 x, int64 y) -{ - int64 res; - res.l = x.l & y.l; - res.h = x.h & y.h; - return res; -} - -static int64 I64_or(int64 x, int64 y) -{ - int64 res; - res.l = x.l | y.l; - res.h = x.h | y.h; - return res; -} - -static int64 I64_xor(int64 x, int64 y) -{ - int64 res; - res.l = x.l ^ y.l; - res.h = x.h ^ y.h; - return res; -} - -/* Shifts */ -static int64 I64_lsl(int64 x, int s) -{ - int64 res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = x.l << s; - res.h = (x.h << s) | (x.l >> (32 - s)); - } else { - res.l = 0; - res.h = x.l << (s - 32); - } - return res; -} - -static int64 I64_lsr(int64 x, int s) -{ - int64 res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = (x.l >> s) | (x.h << (32 - s)); - res.h = x.h >> s; - } else { - res.l = x.h >> (s - 32); - res.h = 0; - } - return res; -} - -static int64 I64_asr(int64 x, int s) -{ - int64 res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = (x.l >> s) | (x.h << (32 - s)); - res.h = (int32) x.h >> s; - } else { - res.l = (int32) x.h >> (s - 32); - res.h = (int32) x.h >> 31; - } - return res; -} - -/* Division and modulus */ - -#define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 -#define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 - -static void I64_udivmod(uint64 modulus, uint64 divisor, - uint64 * quo, uint64 * mod) -{ - int64 quotient, mask; - int cmp; - - quotient.h = 0; quotient.l = 0; - mask.h = 0; mask.l = 1; - while ((int32) divisor.h >= 0) { - cmp = I64_ucompare(divisor, modulus); - I64_SHL1(divisor); - I64_SHL1(mask); - if (cmp >= 0) break; - } - while (mask.l | mask.h) { - if (I64_ucompare(modulus, divisor) >= 0) { - quotient.h |= mask.h; quotient.l |= mask.l; - modulus = I64_sub(modulus, divisor); - } - I64_SHR1(mask); - I64_SHR1(divisor); - } - *quo = quotient; - *mod = modulus; -} - -static int64 I64_div(int64 x, int64 y) -{ - int64 q, r; - int32 sign; - - sign = x.h ^ y.h; - if ((int32) x.h < 0) x = I64_neg(x); - if ((int32) y.h < 0) y = I64_neg(y); - I64_udivmod(x, y, &q, &r); - if (sign < 0) q = I64_neg(q); - return q; -} - -static int64 I64_mod(int64 x, int64 y) -{ - int64 q, r; - int32 sign; - - sign = x.h; - if ((int32) x.h < 0) x = I64_neg(x); - if ((int32) y.h < 0) y = I64_neg(y); - I64_udivmod(x, y, &q, &r); - if (sign < 0) r = I64_neg(r); - return r; -} - -/* Coercions */ - -static int64 I64_of_int32(int32 x) -{ - int64 res; - res.l = x; - res.h = x >> 31; - return res; -} - -#define I64_to_int32(x) ((int32) (x).l) - -/* Note: we assume sizeof(intnat) = 4 here, which is true otherwise - autoconfiguration would have selected native 64-bit integers */ -#define I64_of_intnat I64_of_int32 -#define I64_to_intnat I64_to_int32 - -static double I64_to_double(int64 x) -{ - double res; - int32 sign = x.h; - if (sign < 0) x = I64_neg(x); - res = ldexp((double) x.h, 32) + x.l; - if (sign < 0) res = -res; - return res; -} - -static int64 I64_of_double(double f) -{ - int64 res; - double frac, integ; - int neg; - - neg = (f < 0); - f = fabs(f); - frac = modf(ldexp(f, -32), &integ); - res.h = (uint32) integ; - res.l = (uint32) ldexp(frac, 32); - if (neg) res = I64_neg(res); - return res; -} - -static int64 I64_bswap(int64 x) -{ - int64 res; - res.h = (((x.l & 0x000000FF) << 24) | - ((x.l & 0x0000FF00) << 8) | - ((x.l & 0x00FF0000) >> 8) | - ((x.l & 0xFF000000) >> 24)); - res.l = (((x.h & 0x000000FF) << 24) | - ((x.h & 0x0000FF00) << 8) | - ((x.h & 0x00FF0000) >> 8) | - ((x.h & 0xFF000000) >> 24)); - return res; -} - -#endif /* CAML_INT64_EMUL_H */ diff -Nru ocaml-4.01.0/byterun/int64_format.h ocaml-4.05.0/byterun/int64_format.h --- ocaml-4.01.0/byterun/int64_format.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/int64_format.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,105 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 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. */ -/* */ -/***********************************************************************/ - -/* printf-like formatting of 64-bit integers, in case the C library - printf() function does not support them. */ - -#ifndef CAML_INT64_FORMAT_H -#define CAML_INT64_FORMAT_H - -static void I64_format(char * buffer, char * fmt, int64 x) -{ - static char conv_lower[] = "0123456789abcdef"; - static char conv_upper[] = "0123456789ABCDEF"; - char rawbuffer[24]; - char justify, signstyle, filler, alternate, signedconv; - int base, width, sign, i, rawlen; - char * cvtbl; - char * p, * r; - int64 wbase, digit; - - /* Parsing of format */ - justify = '+'; - signstyle = '-'; - filler = ' '; - alternate = 0; - base = 0; - signedconv = 0; - width = 0; - cvtbl = conv_lower; - for (p = fmt; *p != 0; p++) { - switch (*p) { - case '-': - justify = '-'; break; - case '+': case ' ': - signstyle = *p; break; - case '0': - filler = '0'; break; - case '#': - alternate = 1; break; - case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - width = atoi(p); - while (p[1] >= '0' && p[1] <= '9') p++; - break; - case 'd': case 'i': - signedconv = 1; /* fallthrough */ - case 'u': - base = 10; break; - case 'x': - base = 16; break; - case 'X': - base = 16; cvtbl = conv_upper; break; - case 'o': - base = 8; break; - } - } - if (base == 0) { buffer[0] = 0; return; } - /* Do the conversion */ - sign = 1; - if (signedconv && I64_is_negative(x)) { sign = -1; x = I64_neg(x); } - r = rawbuffer + sizeof(rawbuffer); - wbase = I64_of_int32(base); - do { - I64_udivmod(x, wbase, &x, &digit); - *--r = cvtbl[I64_to_int32(digit)]; - } while (! I64_is_zero(x)); - rawlen = rawbuffer + sizeof(rawbuffer) - r; - /* Adjust rawlen to reflect additional chars (sign, etc) */ - if (signedconv && (sign < 0 || signstyle != '-')) rawlen++; - if (alternate) { - if (base == 8) rawlen += 1; - if (base == 16) rawlen += 2; - } - /* Do the formatting */ - p = buffer; - if (justify == '+' && filler == ' ') { - for (i = rawlen; i < width; i++) *p++ = ' '; - } - if (signedconv) { - if (sign < 0) *p++ = '-'; - else if (signstyle != '-') *p++ = signstyle; - } - if (alternate && base == 8) *p++ = '0'; - if (alternate && base == 16) { *p++ = '0'; *p++ = 'x'; } - if (justify == '+' && filler == '0') { - for (i = rawlen; i < width; i++) *p++ = '0'; - } - while (r < rawbuffer + sizeof(rawbuffer)) *p++ = *r++; - if (justify == '-') { - for (i = rawlen; i < width; i++) *p++ = ' '; - } - *p = 0; -} - -#endif /* CAML_INT64_FORMAT_H */ diff -Nru ocaml-4.01.0/byterun/int64_native.h ocaml-4.05.0/byterun/int64_native.h --- ocaml-4.01.0/byterun/int64_native.h 2013-04-18 13:52:32.000000000 +0000 +++ ocaml-4.05.0/byterun/int64_native.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 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. */ -/* */ -/***********************************************************************/ - -/* Wrapper macros around native 64-bit integer arithmetic, - so that it has the same interface as the software emulation - provided in int64_emul.h */ - -#ifndef CAML_INT64_NATIVE_H -#define CAML_INT64_NATIVE_H - -#define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo)) -#define I64_split(x,hi,lo) (hi = (uint32)((x)>>32), lo = (uint32)(x)) -#define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) -#define I64_ult(x,y) ((uint64)(x) < (uint64)(y)) -#define I64_neg(x) (-(x)) -#define I64_add(x,y) ((x) + (y)) -#define I64_sub(x,y) ((x) - (y)) -#define I64_mul(x,y) ((x) * (y)) -#define I64_is_zero(x) ((x) == 0) -#define I64_is_negative(x) ((x) < 0) -#define I64_is_min_int(x) ((x) == ((int64)1 << 63)) -#define I64_is_minus_one(x) ((x) == -1) - -#define I64_div(x,y) ((x) / (y)) -#define I64_mod(x,y) ((x) % (y)) -#define I64_udivmod(x,y,quo,rem) \ - (*(rem) = (uint64)(x) % (uint64)(y), \ - *(quo) = (uint64)(x) / (uint64)(y)) -#define I64_and(x,y) ((x) & (y)) -#define I64_or(x,y) ((x) | (y)) -#define I64_xor(x,y) ((x) ^ (y)) -#define I64_lsl(x,y) ((x) << (y)) -#define I64_asr(x,y) ((x) >> (y)) -#define I64_lsr(x,y) ((uint64)(x) >> (y)) -#define I64_to_intnat(x) ((intnat) (x)) -#define I64_of_intnat(x) ((intnat) (x)) -#define I64_to_int32(x) ((int32) (x)) -#define I64_of_int32(x) ((int64) (x)) -#define I64_to_double(x) ((double)(x)) -#define I64_of_double(x) ((int64)(x)) - -#define I64_bswap(x) ((((x) & 0x00000000000000FFULL) << 56) | \ - (((x) & 0x000000000000FF00ULL) << 40) | \ - (((x) & 0x0000000000FF0000ULL) << 24) | \ - (((x) & 0x00000000FF000000ULL) << 8) | \ - (((x) & 0x000000FF00000000ULL) >> 8) | \ - (((x) & 0x0000FF0000000000ULL) >> 24) | \ - (((x) & 0x00FF000000000000ULL) >> 40) | \ - (((x) & 0xFF00000000000000ULL) >> 56)) - -#endif /* CAML_INT64_NATIVE_H */ diff -Nru ocaml-4.01.0/byterun/intern.c ocaml-4.05.0/byterun/intern.c --- ocaml-4.01.0/byterun/intern.c 2013-06-07 14:06:30.000000000 +0000 +++ ocaml-4.05.0/byterun/intern.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,56 +1,57 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Structured input, compact format */ -/* The interface of this file is "intext.h" */ +/* The interface of this file is "caml/intext.h" */ #include #include -#include "alloc.h" -#include "callback.h" -#include "custom.h" -#include "fail.h" -#include "gc.h" -#include "intext.h" -#include "io.h" -#include "md5.h" -#include "memory.h" -#include "mlvalues.h" -#include "misc.h" -#include "reverse.h" +#include "caml/alloc.h" +#include "caml/callback.h" +#include "caml/config.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/intext.h" +#include "caml/io.h" +#include "caml/md5.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/misc.h" +#include "caml/reverse.h" static unsigned char * intern_src; /* Reading pointer in block holding input data. */ -static unsigned char * intern_input; -/* Pointer to beginning of block holding input data. - Meaningful only if intern_input_malloced = 1. */ - -static int intern_input_malloced; -/* 1 if intern_input was allocated by caml_stat_alloc() - and needs caml_stat_free() on error, 0 otherwise. */ +static unsigned char * intern_input = NULL; +/* Pointer to beginning of block holding input data, + if non-NULL this pointer will be freed by the cleanup function. */ static header_t * intern_dest; /* Writing pointer in destination block */ -static char * intern_extra_block; +static char * intern_extra_block = NULL; /* If non-NULL, point to new heap chunk allocated with caml_alloc_for_heap. */ static asize_t obj_counter; /* Count how many objects seen so far */ -static value * intern_obj_table; +static value * intern_obj_table = NULL; /* The pointers to objects already seen */ static unsigned int intern_color; @@ -60,65 +61,109 @@ /* Original header of the destination block. Meaningful only if intern_extra_block is NULL. */ -static value intern_block; +static value intern_block = 0; /* Point to the heap block allocated as destination block. Meaningful only if intern_extra_block is NULL. */ -static value * camlinternaloo_last_id = NULL; -/* Pointer to a reference holding the last object id. - -1 means not available (CamlinternalOO not loaded). */ - static char * intern_resolve_code_pointer(unsigned char digest[16], asize_t offset); -static void intern_bad_code_pointer(unsigned char digest[16]) Noreturn; + +CAMLnoreturn_start +static void intern_bad_code_pointer(unsigned char digest[16]) +CAMLnoreturn_end; static void intern_free_stack(void); -#define Sign_extend_shift ((sizeof(intnat) - 1) * 8) -#define Sign_extend(x) (((intnat)(x) << Sign_extend_shift) >> Sign_extend_shift) +static inline unsigned char read8u(void) +{ return *intern_src++; } + +static inline signed char read8s(void) +{ return *intern_src++; } + +static inline uint16_t read16u(void) +{ + uint16_t res = (intern_src[0] << 8) + intern_src[1]; + intern_src += 2; + return res; +} + +static inline int16_t read16s(void) +{ + int16_t res = (intern_src[0] << 8) + intern_src[1]; + intern_src += 2; + return res; +} + +static inline uint32_t read32u(void) +{ + uint32_t res = + ((uint32_t)(intern_src[0]) << 24) + (intern_src[1] << 16) + + (intern_src[2] << 8) + intern_src[3]; + intern_src += 4; + return res; +} -#define read8u() (*intern_src++) -#define read8s() Sign_extend(*intern_src++) -#define read16u() \ - (intern_src += 2, \ - (intern_src[-2] << 8) + intern_src[-1]) -#define read16s() \ - (intern_src += 2, \ - (Sign_extend(intern_src[-2]) << 8) + intern_src[-1]) -#define read32u() \ - (intern_src += 4, \ - ((uintnat)(intern_src[-4]) << 24) + (intern_src[-3] << 16) + \ - (intern_src[-2] << 8) + intern_src[-1]) -#define read32s() \ - (intern_src += 4, \ - (Sign_extend(intern_src[-4]) << 24) + (intern_src[-3] << 16) + \ - (intern_src[-2] << 8) + intern_src[-1]) +static inline int32_t read32s(void) +{ + int32_t res = + ((uint32_t)(intern_src[0]) << 24) + (intern_src[1] << 16) + + (intern_src[2] << 8) + intern_src[3]; + intern_src += 4; + return res; +} #ifdef ARCH_SIXTYFOUR -static intnat read64s(void) +static uintnat read64u(void) { - intnat res; - int i; - res = 0; - for (i = 0; i < 8; i++) res = (res << 8) + intern_src[i]; + uintnat res = + ((uintnat) (intern_src[0]) << 56) + + ((uintnat) (intern_src[1]) << 48) + + ((uintnat) (intern_src[2]) << 40) + + ((uintnat) (intern_src[3]) << 32) + + ((uintnat) (intern_src[4]) << 24) + + ((uintnat) (intern_src[5]) << 16) + + ((uintnat) (intern_src[6]) << 8) + + (uintnat) (intern_src[7]); intern_src += 8; return res; } #endif -#define readblock(dest,len) \ - (memmove((dest), intern_src, (len)), intern_src += (len)) +static inline void readblock(void * dest, intnat len) +{ + memcpy(dest, intern_src, len); + intern_src += len; +} + +static void intern_init(void * src, void * input) +{ + /* This is asserted at the beginning of demarshaling primitives. + If it fails, it probably means that an exception was raised + without calling intern_cleanup() during the previous demarshaling. */ + Assert (intern_input == NULL && intern_obj_table == NULL \ + && intern_extra_block == NULL && intern_block == 0); + intern_src = src; + intern_input = input; +} static void intern_cleanup(void) { - if (intern_input_malloced) caml_stat_free(intern_input); - if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); + if (intern_input != NULL) { + caml_stat_free(intern_input); + intern_input = NULL; + } + if (intern_obj_table != NULL) { + caml_stat_free(intern_obj_table); + intern_obj_table = NULL; + } if (intern_extra_block != NULL) { /* free newly allocated heap chunk */ caml_free_for_heap(intern_extra_block); + intern_extra_block = NULL; } else if (intern_block != 0) { /* restore original header for heap block, otherwise GC is confused */ Hd_val(intern_block) = intern_header; + intern_block = 0; } /* free the recursion stack */ intern_free_stack(); @@ -147,6 +192,7 @@ #endif } +/* [len] is a number of floats */ static void readfloats(double * dest, mlsize_t len, unsigned int code) { mlsize_t i; @@ -290,16 +336,9 @@ switch (sp->op) { case OFreshOID: /* Refresh the object ID */ - if (camlinternaloo_last_id == NULL) { - camlinternaloo_last_id = caml_named_value("CamlinternalOO.last_id"); - if (camlinternaloo_last_id == NULL) - camlinternaloo_last_id = (value*) (-1); - } - if (camlinternaloo_last_id != (value*) (-1)) { - value id = Field(*camlinternaloo_last_id,0); - Field(dest, 0) = id; - Field(*camlinternaloo_last_id,0) = id + 2; - } + /* but do not do it for predefined exception slots */ + if (Long_val(Field((value)dest, 1)) >= 0) + caml_set_oo_id((value)dest); /* Pop item and iterate */ sp--; break; @@ -326,7 +365,7 @@ } else { v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; - *intern_dest = Make_header(size, tag, intern_color); + *intern_dest = Make_header_allocated_here(size, tag, intern_color); intern_dest += 1 + size; /* For objects, we need to freshen the oid */ if (tag == Object_tag) { @@ -336,7 +375,7 @@ /* Request freshing OID */ PushItem(); sp->op = OFreshOID; - sp->dest = &Field(v, 1); + sp->dest = (value*) v; sp->arg = 1; /* Finally read first two block elements: method table and old OID */ ReadItems(&Field(v, 0), 2); @@ -356,7 +395,7 @@ size = (len + sizeof(value)) / sizeof(value); v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; - *intern_dest = Make_header(size, String_tag, intern_color); + *intern_dest = Make_header_allocated_here(size, String_tag, intern_color); intern_dest += 1 + size; Field(v, size - 1) = 0; ofs_ind = Bsize_wsize(size) - 1; @@ -375,7 +414,7 @@ break; case CODE_INT64: #ifdef ARCH_SIXTYFOUR - v = Val_long(read64s()); + v = Val_long((intnat) (read64u())); break; #else intern_cleanup(); @@ -396,21 +435,22 @@ case CODE_SHARED32: ofs = read32u(); goto read_shared; +#ifdef ARCH_SIXTYFOUR + case CODE_SHARED64: + ofs = read64u(); + goto read_shared; +#endif case CODE_BLOCK32: header = (header_t) read32u(); tag = Tag_hd(header); size = Wosize_hd(header); goto read_block; - case CODE_BLOCK64: #ifdef ARCH_SIXTYFOUR - header = (header_t) read64s(); + case CODE_BLOCK64: + header = (header_t) read64u(); tag = Tag_hd(header); size = Wosize_hd(header); goto read_block; -#else - intern_cleanup(); - caml_failwith("input_value: data block too large"); - break; #endif case CODE_STRING8: len = read8u(); @@ -418,11 +458,17 @@ case CODE_STRING32: len = read32u(); goto read_string; +#ifdef ARCH_SIXTYFOUR + case CODE_STRING64: + len = read64u(); + goto read_string; +#endif case CODE_DOUBLE_LITTLE: case CODE_DOUBLE_BIG: v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; - *intern_dest = Make_header(Double_wosize, Double_tag, intern_color); + *intern_dest = Make_header_allocated_here(Double_wosize, Double_tag, + intern_color); intern_dest += 1 + Double_wosize; readfloat((double *) v, code); break; @@ -433,7 +479,8 @@ size = len * Double_wosize; v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; - *intern_dest = Make_header(size, Double_array_tag, intern_color); + *intern_dest = Make_header_allocated_here(size, Double_array_tag, + intern_color); intern_dest += 1 + size; readfloats((double *) v, len, code); break; @@ -441,6 +488,12 @@ case CODE_DOUBLE_ARRAY32_BIG: len = read32u(); goto read_double_array; +#ifdef ARCH_SIXTYFOUR + case CODE_DOUBLE_ARRAY64_LITTLE: + case CODE_DOUBLE_ARRAY64_BIG: + len = read64u(); + goto read_double_array; +#endif case CODE_CODEPOINTER: ofs = read32u(); readblock(digest, 16); @@ -478,8 +531,15 @@ size = 1 + (size + sizeof(value) - 1) / sizeof(value); v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; - *intern_dest = Make_header(size, Custom_tag, intern_color); + *intern_dest = Make_header_allocated_here(size, Custom_tag, + intern_color); Custom_ops_val(v) = ops; + + if (ops->finalize != NULL && Is_young(v)) { + /* Remember that the block has a finalizer. */ + add_to_custom_table (&caml_custom_table, v, 0, 1); + } + intern_dest += 1 + size; break; default: @@ -499,27 +559,30 @@ intern_free_stack(); } -static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) +static void intern_alloc(mlsize_t whsize, mlsize_t num_objects, + int outside_heap) { mlsize_t wosize; - if (camlinternaloo_last_id == (value*)-1) - camlinternaloo_last_id = NULL; /* Reset ignore flag */ if (whsize == 0) { - intern_obj_table = NULL; - intern_extra_block = NULL; - intern_block = 0; + Assert (intern_extra_block == NULL && intern_block == 0 + && intern_obj_table == NULL); return; } wosize = Wosize_whsize(whsize); - if (wosize > Max_wosize) { + if (wosize > Max_wosize || outside_heap) { /* Round desired size up to next page */ asize_t request = ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log; intern_extra_block = caml_alloc_for_heap(request); - if (intern_extra_block == NULL) caml_raise_out_of_memory(); - intern_color = caml_allocation_color(intern_extra_block); + if (intern_extra_block == NULL) { + intern_cleanup(); + caml_raise_out_of_memory(); + } + intern_color = + outside_heap ? Caml_black : caml_allocation_color(intern_extra_block); intern_dest = (header_t *) intern_extra_block; + Assert (intern_block == 0); } else { /* this is a specialised version of caml_alloc from alloc.c */ if (wosize == 0){ @@ -527,21 +590,29 @@ }else if (wosize <= Max_young_wosize){ intern_block = caml_alloc_small (wosize, String_tag); }else{ - intern_block = caml_alloc_shr (wosize, String_tag); + intern_block = caml_alloc_shr_no_raise (wosize, String_tag); /* do not do the urgent_gc check here because it might darken intern_block into gray and break the Assert 3 lines down */ + if (intern_block == 0) { + intern_cleanup(); + caml_raise_out_of_memory(); + } } intern_header = Hd_val(intern_block); intern_color = Color_hd(intern_header); Assert (intern_color == Caml_white || intern_color == Caml_black); intern_dest = (header_t *) Hp_val(intern_block); - intern_extra_block = NULL; + Assert (intern_extra_block == NULL); } obj_counter = 0; - if (num_objects > 0) - intern_obj_table = (value *) caml_stat_alloc(num_objects * sizeof(value)); - else - intern_obj_table = NULL; + if (num_objects > 0) { + intern_obj_table = (value *) malloc(num_objects * sizeof(value)); + if (intern_obj_table == NULL) { + intern_cleanup(); + caml_raise_out_of_memory(); + } + } else + Assert(intern_obj_table == NULL); } static void intern_add_to_heap(mlsize_t whsize) @@ -549,10 +620,10 @@ /* Add new heap chunk to heap if needed */ if (intern_extra_block != NULL) { /* If heap chunk not filled totally, build free block at end */ - asize_t request = - ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log; + asize_t request = Chunk_size (intern_extra_block); header_t * end_extra_block = (header_t *) intern_extra_block + Wsize_bsize(request); + Assert(intern_block == 0); Assert(intern_dest <= end_extra_block); if (intern_dest < end_extra_block){ caml_make_free_blocks ((value *) intern_dest, @@ -561,52 +632,123 @@ caml_allocated_words += Wsize_bsize ((char *) intern_dest - intern_extra_block); caml_add_to_heap(intern_extra_block); + intern_extra_block = NULL; // To prevent intern_cleanup freeing it + } else { + intern_block = 0; // To prevent intern_cleanup rewriting its header } } -value caml_input_val(struct channel *chan) +/* Parsing the header */ + +struct marshal_header { + uint32_t magic; + int header_len; + uintnat data_len; + uintnat num_objects; + uintnat whsize; +}; + +static void caml_parse_header(char * fun_name, + /*out*/ struct marshal_header * h) { - uint32 magic; - mlsize_t block_len, num_objects, whsize; + char errmsg[100]; + + h->magic = read32u(); + switch(h->magic) { + case Intext_magic_number_small: + h->header_len = 20; + h->data_len = read32u(); + h->num_objects = read32u(); +#ifdef ARCH_SIXTYFOUR + read32u(); + h->whsize = read32u(); +#else + h->whsize = read32u(); + read32u(); +#endif + break; + case Intext_magic_number_big: +#ifdef ARCH_SIXTYFOUR + h->header_len = 32; + read32u(); + h->data_len = read64u(); + h->num_objects = read64u(); + h->whsize = read64u(); +#else + errmsg[sizeof(errmsg) - 1] = 0; + snprintf(errmsg, sizeof(errmsg) - 1, + "%s: object too large to be read back on a 32-bit platform", + fun_name); + caml_failwith(errmsg); +#endif + break; + default: + errmsg[sizeof(errmsg) - 1] = 0; + snprintf(errmsg, sizeof(errmsg) - 1, + "%s: bad object", + fun_name); + caml_failwith(errmsg); + } +} + +/* Reading from a channel */ + +static value caml_input_val_core(struct channel *chan, int outside_heap) +{ + intnat r; + char header[32]; + struct marshal_header h; char * block; value res; if (! caml_channel_binary_mode(chan)) caml_failwith("input_value: not a binary channel"); - magic = caml_getword(chan); - if (magic != Intext_magic_number) caml_failwith("input_value: bad object"); - block_len = caml_getword(chan); - num_objects = caml_getword(chan); -#ifdef ARCH_SIXTYFOUR - caml_getword(chan); /* skip size_32 */ - whsize = caml_getword(chan); -#else - whsize = caml_getword(chan); - caml_getword(chan); /* skip size_64 */ -#endif + /* Read and parse the header */ + r = caml_really_getblock(chan, header, 20); + if (r == 0) + caml_raise_end_of_file(); + else if (r < 20) + caml_failwith("input_value: truncated object"); + intern_src = (unsigned char *) header; + if (read32u() == Intext_magic_number_big) { + /* Finish reading the header */ + if (caml_really_getblock(chan, header + 20, 32 - 20) < 32 - 20) + caml_failwith("input_value: truncated object"); + } + intern_src = (unsigned char *) header; + caml_parse_header("input_value", &h); /* Read block from channel */ - block = caml_stat_alloc(block_len); + block = caml_stat_alloc(h.data_len); /* During [caml_really_getblock], concurrent [caml_input_val] operations can take place (via signal handlers or context switching in systhreads), and [intern_input] may change. So, wait until [caml_really_getblock] is over before using [intern_input] and the other global vars. */ - if (caml_really_getblock(chan, block, block_len) == 0) { + if (caml_really_getblock(chan, block, h.data_len) < h.data_len) { caml_stat_free(block); caml_failwith("input_value: truncated object"); } - intern_input = (unsigned char *) block; - intern_input_malloced = 1; - intern_src = intern_input; - intern_alloc(whsize, num_objects); + /* Initialize global state */ + intern_init(block, block); + intern_alloc(h.whsize, h.num_objects, outside_heap); /* Fill it in */ intern_rec(&res); - intern_add_to_heap(whsize); + if (!outside_heap) { + intern_add_to_heap(h.whsize); + } else { + caml_disown_for_heap(intern_extra_block); + intern_extra_block = NULL; + intern_block = 0; + } /* Free everything */ - caml_stat_free(intern_input); - if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); + intern_cleanup(); return caml_check_urgent_gc(res); } +value caml_input_val(struct channel* chan) +{ + return caml_input_val_core(chan, 0); +} + CAMLprim value caml_input_value(value vchan) { CAMLparam1 (vchan); @@ -619,30 +761,39 @@ CAMLreturn (res); } +/* Reading from memory-resident blocks */ + +CAMLprim value caml_input_value_to_outside_heap(value vchan) +{ + CAMLparam1 (vchan); + struct channel * chan = Channel(vchan); + CAMLlocal1 (res); + + Lock(chan); + res = caml_input_val_core(chan, 1); + Unlock(chan); + CAMLreturn (res); +} + CAMLexport value caml_input_val_from_string(value str, intnat ofs) { CAMLparam1 (str); - mlsize_t num_objects, whsize; CAMLlocal1 (obj); + struct marshal_header h; - intern_src = &Byte_u(str, ofs + 2*4); - intern_input_malloced = 0; - num_objects = read32u(); -#ifdef ARCH_SIXTYFOUR - intern_src += 4; /* skip size_32 */ - whsize = read32u(); -#else - whsize = read32u(); - intern_src += 4; /* skip size_64 */ -#endif + /* Initialize global state */ + intern_init(&Byte_u(str, ofs), NULL); + caml_parse_header("input_val_from_string", &h); + if (ofs + h.header_len + h.data_len > caml_string_length(str)) + caml_failwith("input_val_from_string: bad length"); /* Allocate result */ - intern_alloc(whsize, num_objects); - intern_src = &Byte_u(str, ofs + 5*4); /* If a GC occurred */ + intern_alloc(h.whsize, h.num_objects, 0); + intern_src = &Byte_u(str, ofs + h.header_len); /* If a GC occurred */ /* Fill it in */ intern_rec(&obj); - intern_add_to_heap(whsize); + intern_add_to_heap(h.whsize); /* Free everything */ - if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); + intern_cleanup(); CAMLreturn (caml_check_urgent_gc(obj)); } @@ -651,79 +802,77 @@ return caml_input_val_from_string(str, Long_val(ofs)); } -static value input_val_from_block(void) +static value input_val_from_block(struct marshal_header * h) { - mlsize_t num_objects, whsize; value obj; - - num_objects = read32u(); -#ifdef ARCH_SIXTYFOUR - intern_src += 4; /* skip size_32 */ - whsize = read32u(); -#else - whsize = read32u(); - intern_src += 4; /* skip size_64 */ -#endif /* Allocate result */ - intern_alloc(whsize, num_objects); + intern_alloc(h->whsize, h->num_objects, 0); /* Fill it in */ intern_rec(&obj); - intern_add_to_heap(whsize); + intern_add_to_heap(h->whsize); /* Free internal data structures */ - if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); + intern_cleanup(); return caml_check_urgent_gc(obj); } CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs) { - uint32 magic; - value obj; + struct marshal_header h; - intern_input = (unsigned char *) data; - intern_src = intern_input + ofs; - intern_input_malloced = 1; - magic = read32u(); - if (magic != Intext_magic_number) - caml_failwith("input_value_from_malloc: bad object"); - intern_src += 4; /* Skip block_len */ - obj = input_val_from_block(); - /* Free the input */ - caml_stat_free(intern_input); - return obj; + intern_init(data + ofs, data); + + caml_parse_header("input_value_from_malloc", &h); + + return input_val_from_block(&h); } +/* [len] is a number of bytes */ CAMLexport value caml_input_value_from_block(char * data, intnat len) { - uint32 magic; - mlsize_t block_len; - value obj; + struct marshal_header h; - intern_input = (unsigned char *) data; - intern_src = intern_input; - intern_input_malloced = 0; - magic = read32u(); - if (magic != Intext_magic_number) - caml_failwith("input_value_from_block: bad object"); - block_len = read32u(); - if (5*4 + block_len > len) - caml_failwith("input_value_from_block: bad block length"); - obj = input_val_from_block(); - return obj; -} + /* Initialize global state */ + intern_init(data, NULL); + caml_parse_header("input_value_from_block", &h); + if (h.header_len + h.data_len > len) + caml_failwith("input_val_from_block: bad length"); + return input_val_from_block(&h); +} + +/* [ofs] is a [value] that represents a number of bytes + result is a [value] that represents a number of bytes + To handle both the small and the big format, + we assume 20 bytes are available at [buff + ofs], + and we return the data size + the length of the part of the header + that remains to be read. */ CAMLprim value caml_marshal_data_size(value buff, value ofs) { - uint32 magic; - mlsize_t block_len; + uint32_t magic; + int header_len; + uintnat data_len; intern_src = &Byte_u(buff, Long_val(ofs)); - intern_input_malloced = 0; magic = read32u(); - if (magic != Intext_magic_number){ + switch(magic) { + case Intext_magic_number_small: + header_len = 20; + data_len = read32u(); + break; + case Intext_magic_number_big: +#ifdef ARCH_SIXTYFOUR + header_len = 32; + read32u(); + data_len = read64u(); +#else + caml_failwith("Marshal.data_size: " + "object too large to be read back on a 32-bit platform"); +#endif + break; + default: caml_failwith("Marshal.data_size: bad object"); } - block_len = read32u(); - return Val_long(block_len); + return Val_long((header_len - 20) + data_len); } /* Resolution of code pointers */ @@ -751,7 +900,8 @@ static void intern_bad_code_pointer(unsigned char digest[16]) { char msg[256]; - sprintf(msg, "input_value: unknown code module " + snprintf(msg, sizeof(msg), + "input_value: unknown code module " "%02X%02X%02X%02X%02X%02X%02X%02X" "%02X%02X%02X%02X%02X%02X%02X%02X", digest[0], digest[1], digest[2], digest[3], @@ -783,26 +933,26 @@ return read16s(); } -CAMLexport uint32 caml_deserialize_uint_4(void) +CAMLexport uint32_t caml_deserialize_uint_4(void) { return read32u(); } -CAMLexport int32 caml_deserialize_sint_4(void) +CAMLexport int32_t caml_deserialize_sint_4(void) { return read32s(); } -CAMLexport uint64 caml_deserialize_uint_8(void) +CAMLexport uint64_t caml_deserialize_uint_8(void) { - uint64 i; + uint64_t i; caml_deserialize_block_8(&i, 1); return i; } -CAMLexport int64 caml_deserialize_sint_8(void) +CAMLexport int64_t caml_deserialize_sint_8(void) { - int64 i; + int64_t i; caml_deserialize_block_8(&i, 1); return i; } @@ -823,7 +973,7 @@ CAMLexport void caml_deserialize_block_1(void * data, intnat len) { - memmove(data, intern_src, len); + memcpy(data, intern_src, len); intern_src += len; } @@ -835,7 +985,7 @@ Reverse_16(q, p); intern_src = p; #else - memmove(data, intern_src, len * 2); + memcpy(data, intern_src, len * 2); intern_src += len * 2; #endif } @@ -848,7 +998,7 @@ Reverse_32(q, p); intern_src = p; #else - memmove(data, intern_src, len * 4); + memcpy(data, intern_src, len * 4); intern_src += len * 4; #endif } @@ -861,7 +1011,7 @@ Reverse_64(q, p); intern_src = p; #else - memmove(data, intern_src, len * 8); + memcpy(data, intern_src, len * 8); intern_src += len * 8; #endif } @@ -869,7 +1019,7 @@ CAMLexport void caml_deserialize_block_float_8(void * data, intnat len) { #if ARCH_FLOAT_ENDIANNESS == 0x01234567 - memmove(data, intern_src, len * 8); + memcpy(data, intern_src, len * 8); intern_src += len * 8; #elif ARCH_FLOAT_ENDIANNESS == 0x76543210 unsigned char * p, * q; diff -Nru ocaml-4.01.0/byterun/interp.c ocaml-4.05.0/byterun/interp.c --- ocaml-4.01.0/byterun/interp.c 2013-06-01 07:43:45.000000000 +0000 +++ ocaml-4.05.0/byterun/interp.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,34 +1,39 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* The bytecode interpreter */ #include -#include "alloc.h" -#include "backtrace.h" -#include "callback.h" -#include "debugger.h" -#include "fail.h" -#include "fix_code.h" -#include "instrtrace.h" -#include "instruct.h" -#include "interp.h" -#include "major_gc.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "prims.h" -#include "signals.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/callback.h" +#include "caml/debugger.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/instrtrace.h" +#include "caml/instruct.h" +#include "caml/interp.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/prims.h" +#include "caml/signals.h" +#include "caml/stacks.h" +#include "caml/startup_aux.h" /* Registers for the abstract machine: pc the code pointer @@ -173,16 +178,14 @@ #define SP_REG asm("%r14") #define ACCU_REG asm("%r13") #endif +#ifdef __aarch64__ +#define PC_REG asm("%x19") +#define SP_REG asm("%x20") +#define ACCU_REG asm("%x21") +#define JUMPTBL_BASE_REG asm("%x22") #endif - -/* Division and modulus madness */ - -#ifdef NONSTANDARD_DIV_MOD -extern intnat caml_safe_div(intnat p, intnat q); -extern intnat caml_safe_mod(intnat p, intnat q); #endif - #ifdef DEBUG static intnat caml_bcodcount; #endif @@ -222,7 +225,7 @@ #ifdef THREADED_CODE static void * jumptable[] = { -# include "jumptbl.h" +# include "caml/jumptbl.h" }; #endif @@ -273,9 +276,9 @@ #ifdef DEBUG caml_bcodcount++; if (caml_icount-- == 0) caml_stop_here (); - if (caml_trace_flag>1) printf("\n##%ld\n", caml_bcodcount); - if (caml_trace_flag) caml_disasm_instr(pc); - if (caml_trace_flag>1) { + if (caml_trace_level>1) printf("\n##%ld\n", caml_bcodcount); + if (caml_trace_level>0) caml_disasm_instr(pc); + if (caml_trace_level>1) { printf("env="); caml_trace_value_file(env,prog,prog_size,stdout); putchar('\n'); @@ -525,10 +528,21 @@ int nvars = *pc++; int i; if (nvars > 0) *--sp = accu; - Alloc_small(accu, 1 + nvars, Closure_tag); + if (nvars < Max_young_wosize) { + /* nvars + 1 <= Max_young_wosize, can allocate in minor heap */ + Alloc_small(accu, 1 + nvars, Closure_tag); + for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; + } else { + /* PR#6385: must allocate in major heap */ + /* caml_alloc_shr and caml_initialize never trigger a GC, + so no need to Setup_for_gc */ + accu = caml_alloc_shr(1 + nvars, Closure_tag); + for (i = 0; i < nvars; i++) caml_initialize(&Field(accu, i + 1), sp[i]); + } + /* The code pointer is not in the heap, so no need to go through + caml_initialize. */ Code_val(accu) = pc + *pc; pc++; - for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; sp += nvars; Next; } @@ -536,15 +550,25 @@ Instruct(CLOSUREREC): { int nfuncs = *pc++; int nvars = *pc++; + mlsize_t blksize = nfuncs * 2 - 1 + nvars; int i; value * p; if (nvars > 0) *--sp = accu; - Alloc_small(accu, nfuncs * 2 - 1 + nvars, Closure_tag); - p = &Field(accu, nfuncs * 2 - 1); - for (i = 0; i < nvars; i++) { - *p++ = sp[i]; + if (blksize <= Max_young_wosize) { + Alloc_small(accu, blksize, Closure_tag); + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++, p++) *p = sp[i]; + } else { + /* PR#6385: must allocate in major heap */ + /* caml_alloc_shr and caml_initialize never trigger a GC, + so no need to Setup_for_gc */ + accu = caml_alloc_shr(blksize, Closure_tag); + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++, p++) caml_initialize(p, sp[i]); } sp += nvars; + /* The code pointers and infix headers are not in the heap, + so no need to go through caml_initialize. */ p = &Field(accu, 0); *p = (value) (pc + pc[0]); *--sp = accu; @@ -774,7 +798,7 @@ if (accu == Val_false) pc += *pc; else pc++; Next; Instruct(SWITCH): { - uint32 sizes = *pc++; + uint32_t sizes = *pc++; if (Is_block(accu)) { intnat index = Tag_val(accu); Assert ((uintnat) index < (sizes >> 16)); @@ -814,10 +838,20 @@ sp += 4; Next; + Instruct(RAISE_NOTRACE): + if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); + goto raise_notrace; + + Instruct(RERAISE): + if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); + if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 1); + goto raise_notrace; + Instruct(RAISE): raise_exception: if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); - if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp); + if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 0); + raise_notrace: if ((char *) caml_trapsp >= (char *) caml_stack_high - initial_sp_offset) { caml_external_raise = initial_external_raise; @@ -946,21 +980,13 @@ Instruct(DIVINT): { intnat divisor = Long_val(*sp++); if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } -#ifdef NONSTANDARD_DIV_MOD - accu = Val_long(caml_safe_div(Long_val(accu), divisor)); -#else accu = Val_long(Long_val(accu) / divisor); -#endif Next; } Instruct(MODINT): { intnat divisor = Long_val(*sp++); if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } -#ifdef NONSTANDARD_DIV_MOD - accu = Val_long(caml_safe_mod(Long_val(accu), divisor)); -#else accu = Val_long(Long_val(accu) % divisor); -#endif Next; } Instruct(ANDINT): diff -Nru ocaml-4.01.0/byterun/interp.h ocaml-4.05.0/byterun/interp.h --- ocaml-4.01.0/byterun/interp.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/interp.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* The bytecode interpreter */ - -#ifndef CAML_INTERP_H -#define CAML_INTERP_H - -#include "misc.h" -#include "mlvalues.h" - -/* interpret a bytecode */ -value caml_interprete (code_t prog, asize_t prog_size); - -/* tell the runtime that a bytecode program might be needed */ -void caml_prepare_bytecode(code_t prog, asize_t prog_size); - -/* tell the runtime that a bytecode program is no more needed */ -void caml_release_bytecode(code_t prog, asize_t prog_size); - -#endif /* CAML_INTERP_H */ diff -Nru ocaml-4.01.0/byterun/intext.h ocaml-4.05.0/byterun/intext.h --- ocaml-4.01.0/byterun/intext.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/intext.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,168 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* Structured input/output */ - -#ifndef CAML_INTEXT_H -#define CAML_INTEXT_H - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "misc.h" -#include "mlvalues.h" - -/* */ -#include "io.h" - -/* Magic number */ - -#define Intext_magic_number 0x8495A6BE - -/* Codes for the compact format */ - -#define PREFIX_SMALL_BLOCK 0x80 -#define PREFIX_SMALL_INT 0x40 -#define PREFIX_SMALL_STRING 0x20 -#define CODE_INT8 0x0 -#define CODE_INT16 0x1 -#define CODE_INT32 0x2 -#define CODE_INT64 0x3 -#define CODE_SHARED8 0x4 -#define CODE_SHARED16 0x5 -#define CODE_SHARED32 0x6 -#define CODE_BLOCK32 0x8 -#define CODE_BLOCK64 0x13 -#define CODE_STRING8 0x9 -#define CODE_STRING32 0xA -#define CODE_DOUBLE_BIG 0xB -#define CODE_DOUBLE_LITTLE 0xC -#define CODE_DOUBLE_ARRAY8_BIG 0xD -#define CODE_DOUBLE_ARRAY8_LITTLE 0xE -#define CODE_DOUBLE_ARRAY32_BIG 0xF -#define CODE_DOUBLE_ARRAY32_LITTLE 0x7 -#define CODE_CODEPOINTER 0x10 -#define CODE_INFIXPOINTER 0x11 -#define CODE_CUSTOM 0x12 - -#if ARCH_FLOAT_ENDIANNESS == 0x76543210 -#define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG -#define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_BIG -#define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_BIG -#else -#define CODE_DOUBLE_NATIVE CODE_DOUBLE_LITTLE -#define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_LITTLE -#define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_LITTLE -#endif - -/* Size-ing data structures for extern. Chosen so that - sizeof(struct trail_block) and sizeof(struct output_block) - are slightly below 8Kb. */ - -#define ENTRIES_PER_TRAIL_BLOCK 1025 -#define SIZE_EXTERN_OUTPUT_BLOCK 8100 - -/* The entry points */ - -void caml_output_val (struct channel * chan, value v, value flags); - /* Output [v] with flags [flags] on the channel [chan]. */ - -/* */ - -#ifdef __cplusplus -extern "C" { -#endif - -CAMLextern void caml_output_value_to_malloc(value v, value flags, - /*out*/ char ** buf, - /*out*/ intnat * len); - /* Output [v] with flags [flags] to a memory buffer allocated with - malloc. On return, [*buf] points to the buffer and [*len] - contains the number of bytes in buffer. */ -CAMLextern intnat caml_output_value_to_block(value v, value flags, - char * data, intnat len); - /* Output [v] with flags [flags] to a user-provided memory buffer. - [data] points to the start of this buffer, and [len] is its size - in bytes. Return the number of bytes actually written in buffer. - Raise [Failure] if buffer is too short. */ - -/* */ -value caml_input_val (struct channel * chan); - /* Read a structured value from the channel [chan]. */ -/* */ - -CAMLextern value caml_input_val_from_string (value str, intnat ofs); - /* Read a structured value from the OCaml string [str], starting - at offset [ofs]. */ -CAMLextern value caml_input_value_from_malloc(char * data, intnat ofs); - /* Read a structured value from a malloced buffer. [data] points - to the beginning of the buffer, and [ofs] is the offset of the - beginning of the externed data in this buffer. The buffer is - deallocated with [free] on return, or if an exception is raised. */ -CAMLextern value caml_input_value_from_block(char * data, intnat len); - /* Read a structured value from a user-provided buffer. [data] points - to the beginning of the externed data in this buffer, - and [len] is the length in bytes of valid data in this buffer. - The buffer is never deallocated by this routine. */ - -/* Functions for writing user-defined marshallers */ - -CAMLextern void caml_serialize_int_1(int i); -CAMLextern void caml_serialize_int_2(int i); -CAMLextern void caml_serialize_int_4(int32 i); -CAMLextern void caml_serialize_int_8(int64 i); -CAMLextern void caml_serialize_float_4(float f); -CAMLextern void caml_serialize_float_8(double f); -CAMLextern void caml_serialize_block_1(void * data, intnat len); -CAMLextern void caml_serialize_block_2(void * data, intnat len); -CAMLextern void caml_serialize_block_4(void * data, intnat len); -CAMLextern void caml_serialize_block_8(void * data, intnat len); -CAMLextern void caml_serialize_block_float_8(void * data, intnat len); - -CAMLextern int caml_deserialize_uint_1(void); -CAMLextern int caml_deserialize_sint_1(void); -CAMLextern int caml_deserialize_uint_2(void); -CAMLextern int caml_deserialize_sint_2(void); -CAMLextern uint32 caml_deserialize_uint_4(void); -CAMLextern int32 caml_deserialize_sint_4(void); -CAMLextern uint64 caml_deserialize_uint_8(void); -CAMLextern int64 caml_deserialize_sint_8(void); -CAMLextern float caml_deserialize_float_4(void); -CAMLextern double caml_deserialize_float_8(void); -CAMLextern void caml_deserialize_block_1(void * data, intnat len); -CAMLextern void caml_deserialize_block_2(void * data, intnat len); -CAMLextern void caml_deserialize_block_4(void * data, intnat len); -CAMLextern void caml_deserialize_block_8(void * data, intnat len); -CAMLextern void caml_deserialize_block_float_8(void * data, intnat len); -CAMLextern void caml_deserialize_error(char * msg); - -/* */ - -/* Auxiliary stuff for sending code pointers */ - -struct code_fragment { - char * code_start; - char * code_end; - unsigned char digest[16]; - char digest_computed; -}; - -struct ext_table caml_code_fragments_table; - -/* */ - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_INTEXT_H */ diff -Nru ocaml-4.01.0/byterun/ints.c ocaml-4.05.0/byterun/ints.c --- ocaml-4.01.0/byterun/ints.c 2013-04-18 13:59:50.000000000 +0000 +++ ocaml-4.05.0/byterun/ints.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,44 +1,52 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS #include #include -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "intext.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/intext.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" static char * parse_sign_and_base(char * p, /*out*/ int * base, + /*out*/ int * signedness, /*out*/ int * sign) { *sign = 1; if (*p == '-') { *sign = -1; p++; - } - *base = 10; + } else if (*p == '+') + p++; + *base = 10; *signedness = 1; if (*p == '0') { switch (p[1]) { case 'x': case 'X': - *base = 16; p += 2; break; + *base = 16; *signedness = 0; p += 2; break; case 'o': case 'O': - *base = 8; p += 2; break; + *base = 8; *signedness = 0; p += 2; break; case 'b': case 'B': - *base = 2; p += 2; break; + *base = 2; *signedness = 0; p += 2; break; + case 'u': case 'U': + *signedness = 0; p += 2; break; } } return p; @@ -56,64 +64,51 @@ return -1; } -static intnat parse_intnat(value s, int nbits) +#define INT_ERRMSG "int_of_string" +#define INT32_ERRMSG "Int32.of_string" +#define INT64_ERRMSG "Int64.of_string" +#define INTNAT_ERRMSG "Nativeint.of_string" + +static intnat parse_intnat(value s, int nbits, const char *errmsg) { char * p; uintnat res, threshold; - int sign, base, d; + int sign, base, signedness, d; - p = parse_sign_and_base(String_val(s), &base, &sign); + p = parse_sign_and_base(String_val(s), &base, &signedness, &sign); threshold = ((uintnat) -1) / base; d = parse_digit(*p); - if (d < 0 || d >= base) caml_failwith("int_of_string"); + if (d < 0 || d >= base) caml_failwith(errmsg); for (p++, res = d; /*nothing*/; p++) { char c = *p; if (c == '_') continue; d = parse_digit(c); if (d < 0 || d >= base) break; /* Detect overflow in multiplication base * res */ - if (res > threshold) caml_failwith("int_of_string"); + if (res > threshold) caml_failwith(errmsg); res = base * res + d; /* Detect overflow in addition (base * res) + d */ - if (res < (uintnat) d) caml_failwith("int_of_string"); + if (res < (uintnat) d) caml_failwith(errmsg); } if (p != String_val(s) + caml_string_length(s)){ - caml_failwith("int_of_string"); + caml_failwith(errmsg); } - if (base == 10) { + if (signedness) { /* Signed representation expected, allow -2^(nbits-1) to 2^(nbits-1) - 1 */ if (sign >= 0) { - if (res >= (uintnat)1 << (nbits - 1)) caml_failwith("int_of_string"); + if (res >= (uintnat)1 << (nbits - 1)) caml_failwith(errmsg); } else { - if (res > (uintnat)1 << (nbits - 1)) caml_failwith("int_of_string"); + if (res > (uintnat)1 << (nbits - 1)) caml_failwith(errmsg); } } else { /* Unsigned representation expected, allow 0 to 2^nbits - 1 and tolerate -(2^nbits - 1) to 0 */ if (nbits < sizeof(uintnat) * 8 && res >= (uintnat)1 << nbits) - caml_failwith("int_of_string"); + caml_failwith(errmsg); } return sign < 0 ? -((intnat) res) : (intnat) res; } -#ifdef NONSTANDARD_DIV_MOD -intnat caml_safe_div(intnat p, intnat q) -{ - uintnat ap = p >= 0 ? p : -p; - uintnat aq = q >= 0 ? q : -q; - uintnat ar = ap / aq; - return (p ^ q) >= 0 ? ar : -ar; -} - -intnat caml_safe_mod(intnat p, intnat q) -{ - uintnat ap = p >= 0 ? p : -p; - uintnat aq = q >= 0 ? q : -q; - uintnat ar = ap % aq; - return p >= 0 ? ar : -ar; -} -#endif - value caml_bswap16_direct(value x) { return ((((x & 0x00FF) << 8) | @@ -137,18 +132,15 @@ CAMLprim value caml_int_of_string(value s) { - return Val_long(parse_intnat(s, 8 * sizeof(value) - 1)); + return Val_long(parse_intnat(s, 8 * sizeof(value) - 1, INT_ERRMSG)); } #define FORMAT_BUFFER_SIZE 32 -static char * parse_format(value fmt, - char * suffix, - char format_string[], - char default_format_buffer[], - char *conv) +static char parse_format(value fmt, + char * suffix, + char format_string[FORMAT_BUFFER_SIZE]) { - int prec; char * p; char lastletter; mlsize_t len, len_suffix; @@ -167,41 +159,25 @@ memmove(p, suffix, len_suffix); p += len_suffix; *p++ = lastletter; *p = 0; - /* Determine space needed for result and allocate it dynamically if needed */ - prec = 22 + 5; /* 22 digits for 64-bit number in octal + 5 extra */ - for (p = String_val(fmt); *p != 0; p++) { - if (*p >= '0' && *p <= '9') { - prec = atoi(p) + 5; - break; - } - } - *conv = lastletter; - if (prec < FORMAT_BUFFER_SIZE) - return default_format_buffer; - else - return caml_stat_alloc(prec + 1); + /* Return the conversion type (last letter) */ + return lastletter; } CAMLprim value caml_format_int(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; char conv; value res; - buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); + conv = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, format_string); switch (conv) { case 'u': case 'x': case 'X': case 'o': - sprintf(buffer, format_string, Unsigned_long_val(arg)); + res = caml_alloc_sprintf(format_string, Unsigned_long_val(arg)); break; default: - sprintf(buffer, format_string, Long_val(arg)); + res = caml_alloc_sprintf(format_string, Long_val(arg)); break; } - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); return res; } @@ -209,8 +185,8 @@ static int int32_cmp(value v1, value v2) { - int32 i1 = Int32_val(v1); - int32 i2 = Int32_val(v2); + int32_t i1 = Int32_val(v1); + int32_t i2 = Int32_val(v2); return (i1 > i2) - (i1 < i2); } @@ -219,16 +195,16 @@ return Int32_val(v); } -static void int32_serialize(value v, uintnat * wsize_32, - uintnat * wsize_64) +static void int32_serialize(value v, uintnat * bsize_32, + uintnat * bsize_64) { caml_serialize_int_4(Int32_val(v)); - *wsize_32 = *wsize_64 = 4; + *bsize_32 = *bsize_64 = 4; } static uintnat int32_deserialize(void * dst) { - *((int32 *) dst) = caml_deserialize_sint_4(); + *((int32_t *) dst) = caml_deserialize_sint_4(); return 4; } @@ -242,7 +218,7 @@ custom_compare_ext_default }; -CAMLexport value caml_copy_int32(int32 i) +CAMLexport value caml_copy_int32(int32_t i) { value res = caml_alloc_custom(&caml_int32_ops, 4, 0, 1); Int32_val(res) = i; @@ -263,32 +239,24 @@ CAMLprim value caml_int32_div(value v1, value v2) { - int32 dividend = Int32_val(v1); - int32 divisor = Int32_val(v2); + int32_t dividend = Int32_val(v1); + int32_t divisor = Int32_val(v2); if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ if (dividend == (1<<31) && divisor == -1) return v1; -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_int32(caml_safe_div(dividend, divisor)); -#else return caml_copy_int32(dividend / divisor); -#endif } CAMLprim value caml_int32_mod(value v1, value v2) { - int32 dividend = Int32_val(v1); - int32 divisor = Int32_val(v2); + int32_t dividend = Int32_val(v1); + int32_t divisor = Int32_val(v2); if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, modulus crashes if division overflows. Implement the same behavior as for type "int". */ if (dividend == (1<<31) && divisor == -1) return caml_copy_int32(0); -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_int32(caml_safe_mod(dividend, divisor)); -#else return caml_copy_int32(dividend % divisor); -#endif } CAMLprim value caml_int32_and(value v1, value v2) @@ -307,9 +275,9 @@ { return caml_copy_int32(Int32_val(v1) >> Int_val(v2)); } CAMLprim value caml_int32_shift_right_unsigned(value v1, value v2) -{ return caml_copy_int32((uint32)Int32_val(v1) >> Int_val(v2)); } +{ return caml_copy_int32((uint32_t)Int32_val(v1) >> Int_val(v2)); } -static int32 caml_swap32(int32 x) +static int32_t caml_swap32(int32_t x) { return (((x & 0x000000FF) << 24) | ((x & 0x0000FF00) << 8) | @@ -329,70 +297,74 @@ CAMLprim value caml_int32_to_int(value v) { return Val_long(Int32_val(v)); } +int32_t caml_int32_of_float_unboxed(double x) +{ return x; } + CAMLprim value caml_int32_of_float(value v) -{ return caml_copy_int32((int32)(Double_val(v))); } +{ return caml_copy_int32((int32_t)(Double_val(v))); } + +double caml_int32_to_float_unboxed(int32_t x) +{ return x; } CAMLprim value caml_int32_to_float(value v) { return caml_copy_double((double)(Int32_val(v))); } +intnat caml_int32_compare_unboxed(int32_t i1, int32_t i2) +{ + return (i1 > i2) - (i1 < i2); +} + CAMLprim value caml_int32_compare(value v1, value v2) { - int32 i1 = Int32_val(v1); - int32 i2 = Int32_val(v2); - int res = (i1 > i2) - (i1 < i2); - return Val_int(res); + return Val_int(caml_int32_compare_unboxed(Int32_val(v1),Int32_val(v2))); } CAMLprim value caml_int32_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; - char conv; - value res; - buffer = parse_format(fmt, ARCH_INT32_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); - sprintf(buffer, format_string, Int32_val(arg)); - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); - return res; + parse_format(fmt, ARCH_INT32_PRINTF_FORMAT, format_string); + return caml_alloc_sprintf(format_string, Int32_val(arg)); } CAMLprim value caml_int32_of_string(value s) { - return caml_copy_int32(parse_intnat(s, 32)); + return caml_copy_int32(parse_intnat(s, 32, INT32_ERRMSG)); +} + +int32_t caml_int32_bits_of_float_unboxed(double d) +{ + union { float d; int32_t i; } u; + u.d = d; + return u.i; +} + +double caml_int32_float_of_bits_unboxed(int32_t i) +{ + union { float d; int32_t i; } u; + u.i = i; + return u.d; } CAMLprim value caml_int32_bits_of_float(value vd) { - union { float d; int32 i; } u; - u.d = Double_val(vd); - return caml_copy_int32(u.i); + return caml_copy_int32(caml_int32_bits_of_float_unboxed(Double_val(vd))); } CAMLprim value caml_int32_float_of_bits(value vi) { - union { float d; int32 i; } u; - u.i = Int32_val(vi); - return caml_copy_double(u.d); + return caml_copy_double(caml_int32_float_of_bits_unboxed(Int32_val(vi))); } /* 64-bit integers */ -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif - #ifdef ARCH_ALIGN_INT64 -CAMLexport int64 caml_Int64_val(value v) +CAMLexport int64_t caml_Int64_val(value v) { - union { int32 i[2]; int64 j; } buffer; - buffer.i[0] = ((int32 *) Data_custom_val(v))[0]; - buffer.i[1] = ((int32 *) Data_custom_val(v))[1]; + union { int32_t i[2]; int64_t j; } buffer; + buffer.i[0] = ((int32_t *) Data_custom_val(v))[0]; + buffer.i[1] = ((int32_t *) Data_custom_val(v))[1]; return buffer.j; } @@ -400,36 +372,34 @@ static int int64_cmp(value v1, value v2) { - int64 i1 = Int64_val(v1); - int64 i2 = Int64_val(v2); - return I64_compare(i1, i2); + int64_t i1 = Int64_val(v1); + int64_t i2 = Int64_val(v2); + return (i1 > i2) - (i1 < i2); } static intnat int64_hash(value v) { - int64 x = Int64_val(v); - uint32 lo, hi; - - I64_split(x, hi, lo); + int64_t x = Int64_val(v); + uint32_t lo = (uint32_t) x, hi = (uint32_t) (x >> 32); return hi ^ lo; } -static void int64_serialize(value v, uintnat * wsize_32, - uintnat * wsize_64) +static void int64_serialize(value v, uintnat * bsize_32, + uintnat * bsize_64) { caml_serialize_int_8(Int64_val(v)); - *wsize_32 = *wsize_64 = 8; + *bsize_32 = *bsize_64 = 8; } static uintnat int64_deserialize(void * dst) { #ifndef ARCH_ALIGN_INT64 - *((int64 *) dst) = caml_deserialize_sint_8(); + *((int64_t *) dst) = caml_deserialize_sint_8(); #else - union { int32 i[2]; int64 j; } buffer; + union { int32_t i[2]; int64_t j; } buffer; buffer.j = caml_deserialize_sint_8(); - ((int32 *) dst)[0] = buffer.i[0]; - ((int32 *) dst)[1] = buffer.i[1]; + ((int32_t *) dst)[0] = buffer.i[0]; + ((int32_t *) dst)[1] = buffer.i[1]; #endif return 8; } @@ -444,74 +414,75 @@ custom_compare_ext_default }; -CAMLexport value caml_copy_int64(int64 i) +CAMLexport value caml_copy_int64(int64_t i) { value res = caml_alloc_custom(&caml_int64_ops, 8, 0, 1); #ifndef ARCH_ALIGN_INT64 Int64_val(res) = i; #else - union { int32 i[2]; int64 j; } buffer; + union { int32_t i[2]; int64_t j; } buffer; buffer.j = i; - ((int32 *) Data_custom_val(res))[0] = buffer.i[0]; - ((int32 *) Data_custom_val(res))[1] = buffer.i[1]; + ((int32_t *) Data_custom_val(res))[0] = buffer.i[0]; + ((int32_t *) Data_custom_val(res))[1] = buffer.i[1]; #endif return res; } CAMLprim value caml_int64_neg(value v) -{ return caml_copy_int64(I64_neg(Int64_val(v))); } +{ return caml_copy_int64(- Int64_val(v)); } CAMLprim value caml_int64_add(value v1, value v2) -{ return caml_copy_int64(I64_add(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) + Int64_val(v2)); } CAMLprim value caml_int64_sub(value v1, value v2) -{ return caml_copy_int64(I64_sub(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) - Int64_val(v2)); } CAMLprim value caml_int64_mul(value v1, value v2) -{ return caml_copy_int64(I64_mul(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) * Int64_val(v2)); } + +#define Int64_min_int ((intnat) 1 << (sizeof(intnat) * 8 - 1)) CAMLprim value caml_int64_div(value v1, value v2) { - int64 dividend = Int64_val(v1); - int64 divisor = Int64_val(v2); - if (I64_is_zero(divisor)) caml_raise_zero_divide(); + int64_t dividend = Int64_val(v1); + int64_t divisor = Int64_val(v2); + if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ - if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) return v1; - return caml_copy_int64(I64_div(Int64_val(v1), divisor)); + if (dividend == ((int64_t)1 << 63) && divisor == -1) return v1; + return caml_copy_int64(Int64_val(v1) / divisor); } CAMLprim value caml_int64_mod(value v1, value v2) { - int64 dividend = Int64_val(v1); - int64 divisor = Int64_val(v2); - if (I64_is_zero(divisor)) caml_raise_zero_divide(); + int64_t dividend = Int64_val(v1); + int64_t divisor = Int64_val(v2); + if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ - if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) { - int64 zero = I64_literal(0,0); - return caml_copy_int64(zero); + if (dividend == ((int64_t)1 << 63) && divisor == -1){ + return caml_copy_int64(0); } - return caml_copy_int64(I64_mod(Int64_val(v1), divisor)); + return caml_copy_int64(Int64_val(v1) % divisor); } CAMLprim value caml_int64_and(value v1, value v2) -{ return caml_copy_int64(I64_and(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) & Int64_val(v2)); } CAMLprim value caml_int64_or(value v1, value v2) -{ return caml_copy_int64(I64_or(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) | Int64_val(v2)); } CAMLprim value caml_int64_xor(value v1, value v2) -{ return caml_copy_int64(I64_xor(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) ^ Int64_val(v2)); } CAMLprim value caml_int64_shift_left(value v1, value v2) -{ return caml_copy_int64(I64_lsl(Int64_val(v1), Int_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) << Int_val(v2)); } CAMLprim value caml_int64_shift_right(value v1, value v2) -{ return caml_copy_int64(I64_asr(Int64_val(v1), Int_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) >> Int_val(v2)); } CAMLprim value caml_int64_shift_right_unsigned(value v1, value v2) -{ return caml_copy_int64(I64_lsr(Int64_val(v1), Int_val(v2))); } +{ return caml_copy_int64((uint64_t) (Int64_val(v1)) >> Int_val(v2)); } #ifdef ARCH_SIXTYFOUR static value caml_swap64(value x) @@ -531,119 +502,132 @@ #endif CAMLprim value caml_int64_bswap(value v) -{ return caml_copy_int64(I64_bswap(Int64_val(v))); } +{ + int64_t x = Int64_val(v); + return caml_copy_int64 + (((x & INT64_LITERAL(0x00000000000000FFU)) << 56) | + ((x & INT64_LITERAL(0x000000000000FF00U)) << 40) | + ((x & INT64_LITERAL(0x0000000000FF0000U)) << 24) | + ((x & INT64_LITERAL(0x00000000FF000000U)) << 8) | + ((x & INT64_LITERAL(0x000000FF00000000U)) >> 8) | + ((x & INT64_LITERAL(0x0000FF0000000000U)) >> 24) | + ((x & INT64_LITERAL(0x00FF000000000000U)) >> 40) | + ((x & INT64_LITERAL(0xFF00000000000000U)) >> 56)); +} CAMLprim value caml_int64_of_int(value v) -{ return caml_copy_int64(I64_of_intnat(Long_val(v))); } +{ return caml_copy_int64((int64_t) (Long_val(v))); } CAMLprim value caml_int64_to_int(value v) -{ return Val_long(I64_to_intnat(Int64_val(v))); } +{ return Val_long((intnat) (Int64_val(v))); } + +int64_t caml_int64_of_float_unboxed(double x) +{ return x; } CAMLprim value caml_int64_of_float(value v) -{ return caml_copy_int64(I64_of_double(Double_val(v))); } +{ return caml_copy_int64((int64_t) (Double_val(v))); } + +double caml_int64_to_float_unboxed(int64_t x) +{ return x; } CAMLprim value caml_int64_to_float(value v) -{ - int64 i = Int64_val(v); - return caml_copy_double(I64_to_double(i)); -} +{ return caml_copy_double((double) (Int64_val(v))); } CAMLprim value caml_int64_of_int32(value v) -{ return caml_copy_int64(I64_of_int32(Int32_val(v))); } +{ return caml_copy_int64((int64_t) (Int32_val(v))); } CAMLprim value caml_int64_to_int32(value v) -{ return caml_copy_int32(I64_to_int32(Int64_val(v))); } +{ return caml_copy_int32((int32_t) (Int64_val(v))); } CAMLprim value caml_int64_of_nativeint(value v) -{ return caml_copy_int64(I64_of_intnat(Nativeint_val(v))); } +{ return caml_copy_int64((int64_t) (Nativeint_val(v))); } CAMLprim value caml_int64_to_nativeint(value v) -{ return caml_copy_nativeint(I64_to_intnat(Int64_val(v))); } +{ return caml_copy_nativeint((intnat) (Int64_val(v))); } -CAMLprim value caml_int64_compare(value v1, value v2) +intnat caml_int64_compare_unboxed(int64_t i1, int64_t i2) { - int64 i1 = Int64_val(v1); - int64 i2 = Int64_val(v2); - return Val_int(I64_compare(i1, i2)); + return (i1 > i2) - (i1 < i2); } -#ifdef ARCH_INT64_PRINTF_FORMAT -#define I64_format(buf,fmt,x) sprintf(buf,fmt,x) -#else -#include "int64_format.h" -#define ARCH_INT64_PRINTF_FORMAT "" -#endif +CAMLprim value caml_int64_compare(value v1, value v2) +{ + return Val_int(caml_int64_compare_unboxed(Int64_val(v1),Int64_val(v2))); +} CAMLprim value caml_int64_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; - char conv; - value res; - buffer = parse_format(fmt, ARCH_INT64_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); - I64_format(buffer, format_string, Int64_val(arg)); - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); - return res; + parse_format(fmt, ARCH_INT64_PRINTF_FORMAT, format_string); + return caml_alloc_sprintf(format_string, Int64_val(arg)); } CAMLprim value caml_int64_of_string(value s) { char * p; - uint64 max_uint64 = I64_literal(0xFFFFFFFF, 0xFFFFFFFF); - uint64 max_int64_pos = I64_literal(0x7FFFFFFF, 0xFFFFFFFF); - uint64 max_int64_neg = I64_literal(0x80000000, 0x00000000); - uint64 res, threshold; - int sign, base, d; + uint64_t res, threshold; + int sign, base, signedness, d; - p = parse_sign_and_base(String_val(s), &base, &sign); - I64_udivmod(max_uint64, I64_of_int32(base), &threshold, &res); + p = parse_sign_and_base(String_val(s), &base, &signedness, &sign); + threshold = ((uint64_t) -1) / base; d = parse_digit(*p); - if (d < 0 || d >= base) caml_failwith("int_of_string"); - res = I64_of_int32(d); + if (d < 0 || d >= base) caml_failwith(INT64_ERRMSG); + res = d; for (p++; /*nothing*/; p++) { char c = *p; if (c == '_') continue; d = parse_digit(c); if (d < 0 || d >= base) break; /* Detect overflow in multiplication base * res */ - if (I64_ult(threshold, res)) caml_failwith("int_of_string"); - res = I64_add(I64_mul(I64_of_int32(base), res), I64_of_int32(d)); + if (res > threshold) caml_failwith(INT64_ERRMSG); + res = base * res + d; /* Detect overflow in addition (base * res) + d */ - if (I64_ult(res, I64_of_int32(d))) caml_failwith("int_of_string"); + if (res < (uint64_t) d) caml_failwith(INT64_ERRMSG); } if (p != String_val(s) + caml_string_length(s)){ - caml_failwith("int_of_string"); + caml_failwith(INT64_ERRMSG); } - if (base == 10) { - if (I64_ult((sign >= 0 ? max_int64_pos : max_int64_neg), res)) - caml_failwith("int_of_string"); + if (signedness) { + /* Signed representation expected, allow -2^63 to 2^63 - 1 only */ + if (sign >= 0) { + if (res >= (uint64_t)1 << 63) caml_failwith(INT64_ERRMSG); + } else { + if (res > (uint64_t)1 << 63) caml_failwith(INT64_ERRMSG); + } } - if (sign < 0) res = I64_neg(res); + if (sign < 0) res = - res; return caml_copy_int64(res); } -CAMLprim value caml_int64_bits_of_float(value vd) +int64_t caml_int64_bits_of_float_unboxed(double d) { - union { double d; int64 i; int32 h[2]; } u; - u.d = Double_val(vd); + union { double d; int64_t i; int32_t h[2]; } u; + u.d = d; #if defined(__arm__) && !defined(__ARM_EABI__) - { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } + { int32_t t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } #endif - return caml_copy_int64(u.i); + return u.i; } -CAMLprim value caml_int64_float_of_bits(value vi) +double caml_int64_float_of_bits_unboxed(int64_t i) { - union { double d; int64 i; int32 h[2]; } u; - u.i = Int64_val(vi); + union { double d; int64_t i; int32_t h[2]; } u; + u.i = i; #if defined(__arm__) && !defined(__ARM_EABI__) - { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } + { int32_t t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } #endif - return caml_copy_double(u.d); + return u.d; +} + +CAMLprim value caml_int64_bits_of_float(value vd) +{ + return caml_copy_int64(caml_int64_bits_of_float_unboxed(Double_val(vd))); +} + +CAMLprim value caml_int64_float_of_bits(value vi) +{ + return caml_copy_double(caml_int64_float_of_bits_unboxed(Int64_val(vi))); } /* Native integers */ @@ -667,14 +651,14 @@ #endif } -static void nativeint_serialize(value v, uintnat * wsize_32, - uintnat * wsize_64) +static void nativeint_serialize(value v, uintnat * bsize_32, + uintnat * bsize_64) { intnat l = Nativeint_val(v); #ifdef ARCH_SIXTYFOUR if (l >= -((intnat)1 << 31) && l < ((intnat)1 << 31)) { caml_serialize_int_1(1); - caml_serialize_int_4((int32) l); + caml_serialize_int_4((int32_t) l); } else { caml_serialize_int_1(2); caml_serialize_int_8(l); @@ -683,8 +667,8 @@ caml_serialize_int_1(1); caml_serialize_int_4(l); #endif - *wsize_32 = 4; - *wsize_64 = 8; + *bsize_32 = 4; + *bsize_64 = 8; } static uintnat nativeint_deserialize(void * dst) @@ -745,11 +729,7 @@ /* PR#4740: on some processors, modulus crashes if division overflows. Implement the same behavior as for type "int". */ if (dividend == Nativeint_min_int && divisor == -1) return v1; -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_nativeint(caml_safe_div(dividend, divisor)); -#else return caml_copy_nativeint(dividend / divisor); -#endif } CAMLprim value caml_nativeint_mod(value v1, value v2) @@ -762,11 +742,7 @@ if (dividend == Nativeint_min_int && divisor == -1){ return caml_copy_nativeint(0); } -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_nativeint(caml_safe_mod(dividend, divisor)); -#else return caml_copy_nativeint(dividend % divisor); -#endif } CAMLprim value caml_nativeint_and(value v1, value v2) @@ -811,9 +787,15 @@ CAMLprim value caml_nativeint_to_int(value v) { return Val_long(Nativeint_val(v)); } +intnat caml_nativeint_of_float_unboxed(double x) +{ return x; } + CAMLprim value caml_nativeint_of_float(value v) { return caml_copy_nativeint((intnat)(Double_val(v))); } +double caml_nativeint_to_float_unboxed(intnat x) +{ return x; } + CAMLprim value caml_nativeint_to_float(value v) { return caml_copy_double((double)(Nativeint_val(v))); } @@ -823,31 +805,26 @@ CAMLprim value caml_nativeint_to_int32(value v) { return caml_copy_int32(Nativeint_val(v)); } +intnat caml_nativeint_compare_unboxed(intnat i1, intnat i2) +{ + return (i1 > i2) - (i1 < i2); +} + CAMLprim value caml_nativeint_compare(value v1, value v2) { - intnat i1 = Nativeint_val(v1); - intnat i2 = Nativeint_val(v2); - int res = (i1 > i2) - (i1 < i2); - return Val_int(res); + return Val_int(caml_nativeint_compare_unboxed(Nativeint_val(v1), + Nativeint_val(v2))); } CAMLprim value caml_nativeint_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; - char conv; - value res; - buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); - sprintf(buffer, format_string, Nativeint_val(arg)); - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); - return res; + parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, format_string); + return caml_alloc_sprintf(format_string, Nativeint_val(arg)); } CAMLprim value caml_nativeint_of_string(value s) { - return caml_copy_nativeint(parse_intnat(s, 8 * sizeof(value))); + return caml_copy_nativeint(parse_intnat(s, 8 * sizeof(value), INTNAT_ERRMSG)); } diff -Nru ocaml-4.01.0/byterun/io.c ocaml-4.05.0/byterun/io.c --- ocaml-4.01.0/byterun/io.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/io.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,19 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Buffered input/output. */ @@ -17,20 +21,25 @@ #include #include #include +#include #include -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include #endif -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "io.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "signals.h" -#include "sys.h" +#ifdef __CYGWIN__ +#include +#endif +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/sys.h" #ifndef SEEK_SET #define SEEK_SET 0 @@ -72,6 +81,7 @@ channel->flags = 0; channel->next = caml_all_opened_channels; channel->prev = NULL; + channel->name = NULL; if (caml_all_opened_channels != NULL) caml_all_opened_channels->prev = channel; caml_all_opened_channels = channel; @@ -102,10 +112,11 @@ CAMLexport void caml_close_channel(struct channel *channel) { - close(channel->fd); + CAML_SYS_CLOSE(channel->fd); if (channel->refcount > 0) return; if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(channel); unlink_channel(channel); + caml_stat_free(channel->name); caml_stat_free(channel); } @@ -142,39 +153,6 @@ /* Output */ -#ifndef EINTR -#define EINTR (-1) -#endif -#ifndef EAGAIN -#define EAGAIN (-1) -#endif -#ifndef EWOULDBLOCK -#define EWOULDBLOCK (-1) -#endif - -static int do_write(int fd, char *p, int n) -{ - int retcode; - -again: - caml_enter_blocking_section(); - retcode = write(fd, p, n); - caml_leave_blocking_section(); - if (retcode == -1) { - if (errno == EINTR) goto again; - if ((errno == EAGAIN || errno == EWOULDBLOCK) && n > 1) { - /* We couldn't do a partial write here, probably because - n <= PIPE_BUF and POSIX says that writes of less than - PIPE_BUF characters must be atomic. - We first try again with a partial write of 1 character. - If that fails too, we'll raise Sys_blocked_io below. */ - n = 1; goto again; - } - } - if (retcode == -1) caml_sys_io_error(NO_ARG); - return retcode; -} - /* Attempt to flush the buffer. This will make room in the buffer for at least one character. Returns true if the buffer is empty at the end of the flush, or false if some data remains in the buffer. @@ -185,8 +163,10 @@ int towrite, written; towrite = channel->curr - channel->buff; + CAMLassert (towrite >= 0); if (towrite > 0) { - written = do_write(channel->fd, channel->buff, towrite); + written = caml_write_fd(channel->fd, channel->flags, + channel->buff, towrite); channel->offset += written; if (written < towrite) memmove(channel->buff, channel->buff + written, towrite - written); @@ -204,14 +184,14 @@ /* Output data */ -CAMLexport void caml_putword(struct channel *channel, uint32 w) +CAMLexport void caml_putword(struct channel *channel, uint32_t w) { if (! caml_channel_binary_mode(channel)) caml_failwith("output_binary_int: not a binary channel"); - putch(channel, w >> 24); - putch(channel, w >> 16); - putch(channel, w >> 8); - putch(channel, w); + caml_putch(channel, w >> 24); + caml_putch(channel, w >> 16); + caml_putch(channel, w >> 8); + caml_putch(channel, w); } CAMLexport int caml_putblock(struct channel *channel, char *p, intnat len) @@ -230,7 +210,8 @@ fits to buffer and write the buffer */ memmove(channel->curr, p, free); towrite = channel->end - channel->buff; - written = do_write(channel->fd, channel->buff, towrite); + written = caml_write_fd(channel->fd, channel->flags, + channel->buff, towrite); if (written < towrite) memmove(channel->buff, channel->buff + written, towrite - written); channel->offset += written; @@ -272,27 +253,15 @@ /* caml_do_read is exported for Cash */ CAMLexport int caml_do_read(int fd, char *p, unsigned int n) { - int retcode; - - do { - caml_enter_blocking_section(); - retcode = read(fd, p, n); -#if defined(_WIN32) - if (retcode == -1 && errno == ENOMEM && n > 16384){ - retcode = read(fd, p, 16384); - } -#endif - caml_leave_blocking_section(); - } while (retcode == -1 && errno == EINTR); - if (retcode == -1) caml_sys_io_error(NO_ARG); - return retcode; + return caml_read_fd(fd, 0, p, n); } CAMLexport unsigned char caml_refill(struct channel *channel) { int n; - n = caml_do_read(channel->fd, channel->buff, channel->end - channel->buff); + n = caml_read_fd(channel->fd, channel->flags, + channel->buff, channel->end - channel->buff); if (n == 0) caml_raise_end_of_file(); channel->offset += n; channel->max = channel->buff + n; @@ -300,16 +269,16 @@ return (unsigned char)(channel->buff[0]); } -CAMLexport uint32 caml_getword(struct channel *channel) +CAMLexport uint32_t caml_getword(struct channel *channel) { int i; - uint32 res; + uint32_t res; if (! caml_channel_binary_mode(channel)) caml_failwith("input_binary_int: not a binary channel"); res = 0; for(i = 0; i < 4; i++) { - res = (res << 8) + getch(channel); + res = (res << 8) + caml_getch(channel); } return res; } @@ -329,7 +298,7 @@ channel->curr += avail; return avail; } else { - nread = caml_do_read(channel->fd, channel->buff, + nread = caml_read_fd(channel->fd, channel->flags, channel->buff, channel->end - channel->buff); channel->offset += nread; channel->max = channel->buff + nread; @@ -340,16 +309,18 @@ } } -CAMLexport int caml_really_getblock(struct channel *chan, char *p, intnat n) +/* Returns the number of bytes read. */ +CAMLexport intnat caml_really_getblock(struct channel *chan, char *p, intnat n) { + intnat k = n; int r; - while (n > 0) { - r = caml_getblock(chan, p, n); + while (k > 0) { + r = caml_getblock(chan, p, k); if (r == 0) break; p += r; - n -= r; + k -= r; } - return (n == 0); + return n - k; } CAMLexport void caml_seek_in(struct channel *channel, file_offset dest) @@ -399,7 +370,8 @@ return -(channel->max - channel->curr); } /* Fill the buffer as much as possible */ - n = caml_do_read(channel->fd, channel->max, channel->end - channel->max); + n = caml_read_fd(channel->fd, channel->flags, + channel->max, channel->end - channel->max); if (n == 0) { /* End-of-file encountered. Return the number of characters in the buffer, with negative sign since we haven't encountered @@ -417,14 +389,42 @@ /* OCaml entry points for the I/O functions. Wrap struct channel * objects into a heap-allocated object. Perform locking and unlocking around the I/O operations. */ + /* FIXME CAMLexport, but not in io.h exported for Cash ? */ CAMLexport void caml_finalize_channel(value vchan) { struct channel * chan = Channel(vchan); if (--chan->refcount > 0) return; if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(chan); - unlink_channel(chan); - caml_stat_free(chan); + + if (chan->fd != -1 && chan->name && caml_runtime_warnings_active()) + fprintf(stderr, + "[ocaml] channel opened on file '%s' dies without being closed\n", + chan->name + ); + + if (chan->max == NULL && chan->curr != chan->buff){ + /* + This is an unclosed out channel (chan->max == NULL) with a + non-empty buffer: keep it around so the OCaml [at_exit] function + gets a chance to flush it. We would want to simply flush the + channel now, but (i) flushing can raise exceptions, and (ii) it + is potentially a blocking operation. Both are forbidden in a + finalization function. + + Refs: + http://caml.inria.fr/mantis/view.php?id=6902 + https://github.com/ocaml/ocaml/pull/210 + */ + if (chan->name && caml_runtime_warnings_active()) + fprintf(stderr, + "[ocaml] (moreover, it has unflushed data)\n" + ); + } else { + unlink_channel(chan); + caml_stat_free(chan->name); + caml_stat_free(chan); + } } static int compare_channel(value vchan1, value vchan2) @@ -469,6 +469,17 @@ return caml_alloc_channel(caml_open_descriptor_out(Int_val(fd))); } +CAMLprim value caml_ml_set_channel_name(value vchannel, value vname) +{ + struct channel * channel = Channel(vchannel); + caml_stat_free(channel->name); + if (caml_string_length(vname) > 0) + channel->name = caml_strdup(String_val(vname)); + else + channel->name = NULL; + return Val_unit; +} + #define Pair_tag 0 CAMLprim value caml_ml_out_channels_list (value unit) @@ -523,7 +534,7 @@ if (do_syscall) { caml_enter_blocking_section(); - result = close(fd); + result = CAML_SYS_CLOSE(fd); caml_leave_blocking_section(); } @@ -556,6 +567,15 @@ { #if defined(_WIN32) || defined(__CYGWIN__) struct channel * channel = Channel(vchannel); +#if defined(_WIN32) + /* The implementation of [caml_read_fd] and [caml_write_fd] in win32.c + doesn't support socket I/O with CRLF conversion. */ + if ((channel->flags & CHANNEL_FLAG_FROM_SOCKET) != 0 + && ! Bool_val(mode)) { + errno = EINVAL; + caml_sys_error(NO_ARG); + } +#endif if (setmode(channel->fd, Bool_val(mode) ? O_BINARY : O_TEXT) == -1) caml_sys_error(NO_ARG); #endif @@ -600,7 +620,7 @@ struct channel * channel = Channel(vchannel); Lock(channel); - putch(channel, Long_val(ch)); + caml_putch(channel, Long_val(ch)); Unlock(channel); CAMLreturn (Val_unit); } @@ -629,7 +649,7 @@ CAMLreturn (Val_int(res)); } -CAMLprim value caml_ml_output(value vchannel, value buff, value start, +CAMLprim value caml_ml_output_bytes(value vchannel, value buff, value start, value length) { CAMLparam4 (vchannel, buff, start, length); @@ -638,6 +658,8 @@ intnat len = Long_val(length); Lock(channel); + /* We cannot call caml_really_putblock here because buff may move + during caml_write_fd */ while (len > 0) { int written = caml_putblock(channel, &Byte(buff, pos), len); pos += written; @@ -647,6 +669,12 @@ CAMLreturn (Val_unit); } +CAMLprim value caml_ml_output(value vchannel, value buff, value start, + value length) +{ + return caml_ml_output_bytes (vchannel, buff, start, length); +} + CAMLprim value caml_ml_seek_out(value vchannel, value pos) { CAMLparam2 (vchannel, pos); @@ -688,7 +716,7 @@ unsigned char c; Lock(channel); - c = getch(channel); + c = caml_getch(channel); Unlock(channel); CAMLreturn (Val_long(c)); } @@ -718,7 +746,7 @@ Lock(channel); /* We cannot call caml_getblock here because buff may move during - caml_do_read */ + caml_read_fd */ start = Long_val(vstart); len = Long_val(vlength); n = len >= INT_MAX ? INT_MAX : (int) len; @@ -731,7 +759,7 @@ channel->curr += avail; n = avail; } else { - nread = caml_do_read(channel->fd, channel->buff, + nread = caml_read_fd(channel->fd, channel->flags, channel->buff, channel->end - channel->buff); channel->offset += nread; channel->max = channel->buff + nread; @@ -788,21 +816,3 @@ Unlock(channel); CAMLreturn (Val_long(res)); } - -/* Conversion between file_offset and int64 */ - -#ifndef ARCH_INT64_TYPE -CAMLexport value caml_Val_file_offset(file_offset fofs) -{ - int64 ofs; - ofs.l = fofs; - ofs.h = 0; - return caml_copy_int64(ofs); -} - -CAMLexport file_offset caml_File_offset_val(value v) -{ - int64 ofs = Int64_val(v); - return (file_offset) ofs.l; -} -#endif diff -Nru ocaml-4.01.0/byterun/io.h ocaml-4.05.0/byterun/io.h --- ocaml-4.01.0/byterun/io.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/io.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,124 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* Buffered input/output */ - -#ifndef CAML_IO_H -#define CAML_IO_H - -#include "misc.h" -#include "mlvalues.h" - -#ifndef IO_BUFFER_SIZE -#define IO_BUFFER_SIZE 65536 -#endif - -#if defined(_WIN32) -typedef __int64 file_offset; -extern __int64 _lseeki64(int, __int64, int); -#define lseek(fd,d,m) _lseeki64(fd,d,m) -#elif defined(HAS_OFF_T) -#include -typedef off_t file_offset; -#else -typedef long file_offset; -#endif - -struct channel { - int fd; /* Unix file descriptor */ - file_offset offset; /* Absolute position of fd in the file */ - char * end; /* Physical end of the buffer */ - char * curr; /* Current position in the buffer */ - char * max; /* Logical end of the buffer (for input) */ - void * mutex; /* Placeholder for mutex (for systhreads) */ - struct channel * next, * prev;/* Double chaining of channels (flush_all) */ - int revealed; /* For Cash only */ - int old_revealed; /* For Cash only */ - int refcount; /* For flush_all and for Cash */ - int flags; /* Bitfield */ - char buff[IO_BUFFER_SIZE]; /* The buffer itself */ -}; - -enum { - CHANNEL_FLAG_FROM_SOCKET = 1 /* For Windows */ -}; - -/* For an output channel: - [offset] is the absolute position of the beginning of the buffer [buff]. - For an input channel: - [offset] is the absolute position of the logical end of the buffer, [max]. -*/ - -/* Functions and macros that can be called from C. Take arguments of - type struct channel *. No locking is performed. */ - -#define putch(channel, ch) do{ \ - if ((channel)->curr >= (channel)->end) caml_flush_partial(channel); \ - *((channel)->curr)++ = (ch); \ -}while(0) - -#define getch(channel) \ - ((channel)->curr >= (channel)->max \ - ? caml_refill(channel) \ - : (unsigned char) *((channel)->curr)++) - -CAMLextern struct channel * caml_open_descriptor_in (int); -CAMLextern struct channel * caml_open_descriptor_out (int); -CAMLextern void caml_close_channel (struct channel *); -CAMLextern int caml_channel_binary_mode (struct channel *); -CAMLextern value caml_alloc_channel(struct channel *chan); - -CAMLextern int caml_flush_partial (struct channel *); -CAMLextern void caml_flush (struct channel *); -CAMLextern void caml_putword (struct channel *, uint32); -CAMLextern int caml_putblock (struct channel *, char *, intnat); -CAMLextern void caml_really_putblock (struct channel *, char *, intnat); - -CAMLextern unsigned char caml_refill (struct channel *); -CAMLextern uint32 caml_getword (struct channel *); -CAMLextern int caml_getblock (struct channel *, char *, intnat); -CAMLextern int caml_really_getblock (struct channel *, char *, intnat); - -/* Extract a struct channel * from the heap object representing it */ - -#define Channel(v) (*((struct channel **) (Data_custom_val(v)))) - -/* The locking machinery */ - -CAMLextern void (*caml_channel_mutex_free) (struct channel *); -CAMLextern void (*caml_channel_mutex_lock) (struct channel *); -CAMLextern void (*caml_channel_mutex_unlock) (struct channel *); -CAMLextern void (*caml_channel_mutex_unlock_exn) (void); - -CAMLextern struct channel * caml_all_opened_channels; - -#define Lock(channel) \ - if (caml_channel_mutex_lock != NULL) (*caml_channel_mutex_lock)(channel) -#define Unlock(channel) \ - if (caml_channel_mutex_unlock != NULL) (*caml_channel_mutex_unlock)(channel) -#define Unlock_exn() \ - if (caml_channel_mutex_unlock_exn != NULL) (*caml_channel_mutex_unlock_exn)() - -/* Conversion between file_offset and int64 */ - -#ifdef ARCH_INT64_TYPE -#define Val_file_offset(fofs) caml_copy_int64(fofs) -#define File_offset_val(v) ((file_offset) Int64_val(v)) -#else -CAMLextern value caml_Val_file_offset(file_offset fofs); -CAMLextern file_offset caml_File_offset_val(value v); -#define Val_file_offset caml_Val_file_offset -#define File_offset_val caml_File_offset_val -#endif - -#endif /* CAML_IO_H */ diff -Nru ocaml-4.01.0/byterun/lexing.c ocaml-4.05.0/byterun/lexing.c --- ocaml-4.01.0/byterun/lexing.c 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/byterun/lexing.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,21 +1,25 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* The table-driven automaton for lexers generated by camllex. */ -#include "fail.h" -#include "mlvalues.h" -#include "stacks.h" +#include "caml/fail.h" +#include "caml/mlvalues.h" +#include "caml/stacks.h" struct lexer_buffer { value refill_buff; @@ -49,7 +53,7 @@ #if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2 #define Short(tbl,n) \ (*((unsigned char *)((tbl) + (n) * 2)) + \ - (*((schar *)((tbl) + (n) * 2 + 1)) << 8)) + (*((signed char *)((tbl) + (n) * 2 + 1)) << 8)) #else #define Short(tbl,n) (((short *)(tbl))[(n)]) #endif diff -Nru ocaml-4.01.0/byterun/main.c ocaml-4.05.0/byterun/main.c --- ocaml-4.01.0/byterun/main.c 2013-02-26 12:47:13.000000000 +0000 +++ ocaml-4.05.0/byterun/main.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,22 +1,26 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Main entry point (can be overridden by a user-provided main() function that calls caml_main() later). */ -#include "misc.h" -#include "mlvalues.h" -#include "sys.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/sys.h" CAMLextern void caml_main (char **); @@ -26,27 +30,6 @@ int main(int argc, char **argv) { -#ifdef DEBUG - caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0); -#if 0 - { - int i; - char *ocp; - char *cp; - - caml_gc_message (-1, "### command line:", 0); - for (i = 0; i < argc; i++){ - caml_gc_message (-1, " %s", argv[i]); - } - caml_gc_message (-1, "\n", 0); - ocp = getenv ("OCAMLRUNPARAM"); - caml_gc_message (-1, "### OCAMLRUNPARAM=%s\n", ocp == NULL ? "" : ocp); - cp = getenv ("CAMLRUNPARAM"); - caml_gc_message (-1, "### CAMLRUNPARAM=%s\n", cp == NULL ? "" : cp); - caml_gc_message (-1, "### working dir: %s\n", getcwd (NULL, 0)); - } -#endif -#endif #ifdef _WIN32 /* Expand wildcards and diversions in command line */ caml_expand_command_line(&argc, &argv); diff -Nru ocaml-4.01.0/byterun/major_gc.c ocaml-4.05.0/byterun/major_gc.c --- ocaml-4.01.0/byterun/major_gc.c 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/byterun/major_gc.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,37 +1,56 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS #include +#include + +#include "caml/compact.h" +#include "caml/custom.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/finalise.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/weak.h" + +#if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS) +#define NATIVE_CODE_AND_NO_NAKED_POINTERS +#else +#undef NATIVE_CODE_AND_NO_NAKED_POINTERS +#endif -#include "compact.h" -#include "custom.h" -#include "config.h" -#include "fail.h" -#include "finalise.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "weak.h" +#ifdef _MSC_VER +static inline double fmin(double a, double b) { + return (a < b) ? a : b; +} +#endif uintnat caml_percent_free; uintnat caml_major_heap_increment; CAMLexport char *caml_heap_start; char *caml_gc_sweep_hp; -int caml_gc_phase; /* always Phase_mark, Phase_sweep, or Phase_idle */ +int caml_gc_phase; /* always Phase_mark, Pase_clean, + Phase_sweep, or Phase_idle */ static value *gray_vals; static value *gray_vals_cur, *gray_vals_end; static asize_t gray_vals_size; @@ -40,25 +59,72 @@ uintnat caml_allocated_words; uintnat caml_dependent_size, caml_dependent_allocated; double caml_extra_heap_resources; -uintnat caml_fl_size_at_phase_change = 0; +uintnat caml_fl_wsz_at_phase_change = 0; extern char *caml_fl_merge; /* Defined in freelist.c. */ static char *markhp, *chunk, *limit; -int caml_gc_subphase; /* Subphase_{main,weak1,weak2,final} */ -static value *weak_prev; +int caml_gc_subphase; /* Subphase_{mark_roots,mark_main,mark_final} */ + +/** + Ephemerons: + During mark phase the list caml_ephe_list_head of ephemerons + is iterated by different pointers that follow the invariants: + caml_ephe_list_head ->* ephes_checked_if_pure ->* ephes_to_check ->* null + | | | + (1) (2) (3) + + At the start of mark phase, (1) and (2) are empty. + + In mark phase: + - the ephemerons in (1) have a data alive or none + (nb: new ephemerons are added in this part by weak.c) + - the ephemerons in (2) have at least a white key or are white + if ephe_list_pure is true, otherwise they are in an unknown state and + must be checked again. + - the ephemerons in (3) are in an unknown state and must be checked + + At the end of mark phase, (3) is empty and ephe_list_pure is true. + The ephemeron in (1) and (2) will be cleaned (white keys and datas + replaced by none or the ephemeron is removed from the list if it is white) + in clean phase. + + In clean phase: + caml_ephe_list_head ->* ephes_to_check ->* null + | | + (1) (3) + + In clean phase, (2) is not used, ephes_to_check is initialized at + caml_ephe_list_head: + - the ephemerons in (1) are clean. + - the ephemerons in (3) should be cleaned or removed if white. + + */ +static int ephe_list_pure; +/** The ephemerons is pure if since the start of its iteration + no value have been darken. */ +static value *ephes_checked_if_pure; +static value *ephes_to_check; + +int caml_major_window = 1; +double caml_major_ring[Max_major_window] = { 0. }; +int caml_major_ring_index = 0; +double caml_major_work_credit = 0.0; +double caml_gc_clock = 0.0; #ifdef DEBUG static unsigned long major_gc_counter = 0; #endif +void (*caml_major_gc_hook)(void) = NULL; + static void realloc_gray_vals (void) { value *new; Assert (gray_vals_cur == gray_vals_end); - if (gray_vals_size < caml_stat_heap_size / 128){ + if (gray_vals_size < caml_stat_heap_wsz / 32){ caml_gc_message (0x08, "Growing gray_vals to %" ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n", (intnat) gray_vals_size * sizeof (value) / 512); @@ -82,7 +148,11 @@ void caml_darken (value v, value *p /* not used */) { +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + if (Is_block (v) && !Is_young (v) && Wosize_val (v) > 0) { +#else if (Is_block (v) && Is_in_heap (v)) { +#endif header_t h = Hd_val (v); tag_t t = Tag_hd (h); if (t == Infix_tag){ @@ -90,8 +160,18 @@ h = Hd_val (v); t = Tag_hd (h); } +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + /* We insist that naked pointers to outside the heap point to things that + look like values with headers coloured black. This isn't always + strictly necessary but is essential in certain cases---in particular + when the value is allocated in a read-only section. (For the values + where it would be safe it is a performance improvement since we avoid + putting them on the grey list.) */ + CAMLassert (Is_in_heap (v) || Is_black_hd (h)); +#endif CAMLassert (!Is_blue_hd (h)); if (Is_white_hd (h)){ + ephe_list_pure = 0; if (t < No_scan_tag){ Hd_val (v) = Grayhd_hd (h); *gray_vals_cur++ = v; @@ -108,65 +188,247 @@ Assert (caml_gc_phase == Phase_idle); Assert (gray_vals_cur == gray_vals); caml_gc_message (0x01, "Starting new major GC cycle\n", 0); - caml_darken_all_roots(); + caml_darken_all_roots_start (); caml_gc_phase = Phase_mark; - caml_gc_subphase = Subphase_main; + caml_gc_subphase = Subphase_mark_roots; markhp = NULL; + ephe_list_pure = 1; + ephes_checked_if_pure = &caml_ephe_list_head; + ephes_to_check = &caml_ephe_list_head; #ifdef DEBUG ++ major_gc_counter; caml_heap_check (); #endif } -static void mark_slice (intnat work) +/* We may stop the slice inside values, in order to avoid large latencies + on large arrays. In this case, [current_value] is the partially-marked + value and [current_index] is the index of the next field to be marked. +*/ +static value current_value = 0; +static mlsize_t current_index = 0; + +/* For instrumentation */ +#ifdef CAML_INSTR +#define INSTR(x) x +#else +#define INSTR(x) /**/ +#endif + +static void init_sweep_phase(void) +{ + /* Phase_clean is done. */ + /* Initialise the sweep phase. */ + caml_gc_sweep_hp = caml_heap_start; + caml_fl_init_merge (); + caml_gc_phase = Phase_sweep; + chunk = caml_heap_start; + caml_gc_sweep_hp = chunk; + limit = chunk + Chunk_size (chunk); + caml_fl_wsz_at_phase_change = caml_fl_cur_wsz; + if (caml_major_gc_hook) (*caml_major_gc_hook)(); +} + +/* auxillary function of mark_slice */ +static inline value* mark_slice_darken(value *gray_vals_ptr, value v, int i, + int in_ephemeron, int *slice_pointers) +{ + value child; + header_t chd; + + child = Field (v, i); + +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + if (Is_block (child) + && ! Is_young (child) + && Wosize_val (child) > 0 /* Atoms never need to be marked. */ + /* Closure blocks contain code pointers at offsets that cannot + be reliably determined, so we always use the page table when + marking such values. */ + && (!(Tag_val (v) == Closure_tag || Tag_val (v) == Infix_tag) || + Is_in_heap (child))) { +#else + if (Is_block (child) && Is_in_heap (child)) { +#endif + INSTR (++ *slice_pointers;) + chd = Hd_val (child); + if (Tag_hd (chd) == Forward_tag){ + value f = Forward_val (child); + if ((in_ephemeron && Is_long(f)) || + (Is_block (f) + && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag + || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag))){ + /* Do not short-circuit the pointer. */ + }else{ + /* The variable child is not changed because it must be mark alive */ + Field (v, i) = f; + if (Is_block (f) && Is_young (f) && !Is_young (child)){ + if(in_ephemeron){ + add_to_ephe_ref_table (&caml_ephe_ref_table, v, i); + }else{ + add_to_ref_table (&caml_ref_table, &Field (v, i)); + } + } + } + } + else if (Tag_hd(chd) == Infix_tag) { + child -= Infix_offset_val(child); + chd = Hd_val(child); + } +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + /* See [caml_darken] for a description of this assertion. */ + CAMLassert (Is_in_heap (child) || Is_black_hd (chd)); +#endif + if (Is_white_hd (chd)){ + ephe_list_pure = 0; + Hd_val (child) = Grayhd_hd (chd); + *gray_vals_ptr++ = child; + if (gray_vals_ptr >= gray_vals_end) { + gray_vals_cur = gray_vals_ptr; + realloc_gray_vals (); + gray_vals_ptr = gray_vals_cur; + } + } + } + + return gray_vals_ptr; +} + +static value* mark_ephe_aux (value *gray_vals_ptr, intnat *work, + int *slice_pointers) { - value *gray_vals_ptr; /* Local copy of gray_vals_cur */ - value v, child; + value v, data, key; header_t hd; mlsize_t size, i; + v = *ephes_to_check; + hd = Hd_val(v); + Assert(Tag_val (v) == Abstract_tag); + data = Field(v,CAML_EPHE_DATA_OFFSET); + if ( data != caml_ephe_none && + Is_block (data) && Is_in_heap (data) && Is_white_val (data)){ + + int alive_data = 1; + + /* The liveness of the ephemeron is one of the condition */ + if (Is_white_hd (hd)) alive_data = 0; + + /* The liveness of the keys not caml_ephe_none is the other condition */ + size = Wosize_hd (hd); + for (i = CAML_EPHE_FIRST_KEY; alive_data && i < size; i++){ + key = Field (v, i); + ephemeron_again: + if (key != caml_ephe_none && + Is_block (key) && Is_in_heap (key)){ + if (Tag_val (key) == Forward_tag){ + value f = Forward_val (key); + if (Is_long (f) || + (Is_block (f) && + (!Is_in_value_area(f) || Tag_val (f) == Forward_tag + || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag))){ + /* Do not short-circuit the pointer. */ + }else{ + Field (v, i) = key = f; + goto ephemeron_again; + } + } + if (Is_white_val (key)){ + alive_data = 0; + } + } + } + *work -= Whsize_wosize(i); + + if (alive_data){ + gray_vals_ptr = mark_slice_darken(gray_vals_ptr,v, + CAML_EPHE_DATA_OFFSET, + /*in_ephemeron=*/1, + slice_pointers); + } else { /* not triggered move to the next one */ + ephes_to_check = &Field(v,CAML_EPHE_LINK_OFFSET); + return gray_vals_ptr; + } + } else { /* a simily weak pointer or an already alive data */ + *work -= 1; + } + + /* all keys black or data none or black + move the ephemerons from (3) to the end of (1) */ + if ( ephes_checked_if_pure == ephes_to_check ) { + /* corner case and optim */ + ephes_checked_if_pure = &Field(v,CAML_EPHE_LINK_OFFSET); + ephes_to_check = ephes_checked_if_pure; + } else { + /* - remove v from the list (3) */ + *ephes_to_check = Field(v,CAML_EPHE_LINK_OFFSET); + /* - insert it at the end of (1) */ + Field(v,CAML_EPHE_LINK_OFFSET) = *ephes_checked_if_pure; + *ephes_checked_if_pure = v; + ephes_checked_if_pure = &Field(v,CAML_EPHE_LINK_OFFSET); + } + return gray_vals_ptr; +} + + + +static void mark_slice (intnat work) +{ + value *gray_vals_ptr; /* Local copy of [gray_vals_cur] */ + value v; + header_t hd; + mlsize_t size, i, start, end; /* [start] is a local copy of [current_index] */ +#ifdef CAML_INSTR + int slice_fields = 0; +#endif + int slice_pointers = 0; /** gcc removes it when not in CAML_INSTR */ + caml_gc_message (0x40, "Marking %ld words\n", work); caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase); gray_vals_ptr = gray_vals_cur; + v = current_value; + start = current_index; while (work > 0){ - if (gray_vals_ptr > gray_vals){ + if (v == 0 && gray_vals_ptr > gray_vals){ + CAMLassert (start == 0); v = *--gray_vals_ptr; + CAMLassert (Is_gray_val (v)); + } + if (v != 0){ hd = Hd_val(v); Assert (Is_gray_hd (hd)); - Hd_val (v) = Blackhd_hd (hd); size = Wosize_hd (hd); + end = start + work; if (Tag_hd (hd) < No_scan_tag){ - for (i = 0; i < size; i++){ - child = Field (v, i); - if (Is_block (child) && Is_in_heap (child)) { - hd = Hd_val (child); - if (Tag_hd (hd) == Forward_tag){ - value f = Forward_val (child); - if (Is_block (f) - && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag - || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){ - /* Do not short-circuit the pointer. */ - }else{ - Field (v, i) = f; - } - } - else if (Tag_hd(hd) == Infix_tag) { - child -= Infix_offset_val(child); - hd = Hd_val(child); - } - if (Is_white_hd (hd)){ - Hd_val (child) = Grayhd_hd (hd); - *gray_vals_ptr++ = child; - if (gray_vals_ptr >= gray_vals_end) { - gray_vals_cur = gray_vals_ptr; - realloc_gray_vals (); - gray_vals_ptr = gray_vals_cur; - } - } - } + start = size < start ? size : start; + end = size < end ? size : end; + CAMLassert (end >= start); + INSTR (slice_fields += end - start;) + INSTR (if (size > end) + CAML_INSTR_INT ("major/mark/slice/remain", size - end);) + for (i = start; i < end; i++){ + gray_vals_ptr = mark_slice_darken(gray_vals_ptr,v,i, + /*in_ephemeron=*/ 0, + &slice_pointers); + } + if (end < size){ + work = 0; + start = end; + /* [v] doesn't change. */ + CAMLassert (Is_gray_val (v)); + }else{ + CAMLassert (end == size); + Hd_val (v) = Blackhd_hd (hd); + work -= Whsize_wosize(end - start); + start = 0; + v = 0; } + }else{ + /* The block doesn't contain any pointers. */ + CAMLassert (start == 0); + Hd_val (v) = Blackhd_hd (hd); + work -= Whsize_wosize(size); + v = 0; } - work -= Whsize_wosize(size); }else if (markhp != NULL){ if (markhp == limit){ chunk = Chunk_next (chunk); @@ -179,7 +441,8 @@ }else{ if (Is_gray_val (Val_hp (markhp))){ Assert (gray_vals_ptr == gray_vals); - *gray_vals_ptr++ = Val_hp (markhp); + CAMLassert (v == 0 && start == 0); + v = Val_hp (markhp); } markhp += Bhsize_hp (markhp); } @@ -188,90 +451,50 @@ chunk = caml_heap_start; markhp = chunk; limit = chunk + Chunk_size (chunk); + } else if (caml_gc_subphase == Subphase_mark_roots) { + gray_vals_cur = gray_vals_ptr; + work = caml_darken_all_roots_slice (work); + gray_vals_ptr = gray_vals_cur; + if (work > 0){ + caml_gc_subphase = Subphase_mark_main; + } + } else if (*ephes_to_check != (value) NULL) { + /* Continue to scan the list of ephe */ + gray_vals_ptr = mark_ephe_aux(gray_vals_ptr,&work,&slice_pointers); + } else if (!ephe_list_pure){ + /* We must scan again the list because some value have been darken */ + ephe_list_pure = 1; + ephes_to_check = ephes_checked_if_pure; }else{ switch (caml_gc_subphase){ - case Subphase_main: { - /* The main marking phase is over. Start removing weak pointers to - dead values. */ - caml_gc_subphase = Subphase_weak1; - weak_prev = &caml_weak_list_head; - } - break; - case Subphase_weak1: { - value cur, curfield; - mlsize_t sz, i; - header_t hd; - - cur = *weak_prev; - if (cur != (value) NULL){ - hd = Hd_val (cur); - sz = Wosize_hd (hd); - for (i = 1; i < sz; i++){ - curfield = Field (cur, i); - weak_again: - if (curfield != caml_weak_none - && Is_block (curfield) && Is_in_heap (curfield)){ - if (Tag_val (curfield) == Forward_tag){ - value f = Forward_val (curfield); - if (Is_block (f)) { - if (!Is_in_value_area(f) || Tag_val (f) == Forward_tag - || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag){ - /* Do not short-circuit the pointer. */ - }else{ - Field (cur, i) = curfield = f; - goto weak_again; - } - } - } - if (Is_white_val (curfield)){ - Field (cur, i) = caml_weak_none; - } - } - } - weak_prev = &Field (cur, 0); - work -= Whsize_hd (hd); - }else{ - /* Subphase_weak1 is done. - Handle finalised values and start removing dead weak arrays. */ + case Subphase_mark_main: { + /* Subphase_mark_main is done. + Mark finalised values. */ gray_vals_cur = gray_vals_ptr; - caml_final_update (); + caml_final_update_mark_phase (); gray_vals_ptr = gray_vals_cur; - caml_gc_subphase = Subphase_weak2; - weak_prev = &caml_weak_list_head; - } - } - break; - case Subphase_weak2: { - value cur; - header_t hd; - - cur = *weak_prev; - if (cur != (value) NULL){ - hd = Hd_val (cur); - if (Color_hd (hd) == Caml_white){ - /* The whole array is dead, remove it from the list. */ - *weak_prev = Field (cur, 0); - }else{ - weak_prev = &Field (cur, 0); + if (gray_vals_ptr > gray_vals){ + v = *--gray_vals_ptr; + CAMLassert (start == 0); } - work -= 1; - }else{ - /* Subphase_weak2 is done. Go to Subphase_final. */ - caml_gc_subphase = Subphase_final; - } + /* Complete the marking */ + ephes_to_check = ephes_checked_if_pure; + caml_gc_subphase = Subphase_mark_final; } break; - case Subphase_final: { - /* Initialise the sweep phase. */ - gray_vals_cur = gray_vals_ptr; - caml_gc_sweep_hp = caml_heap_start; - caml_fl_init_merge (); - caml_gc_phase = Phase_sweep; - chunk = caml_heap_start; - caml_gc_sweep_hp = chunk; - limit = chunk + Chunk_size (chunk); - work = 0; - caml_fl_size_at_phase_change = caml_fl_cur_size; + case Subphase_mark_final: { + /** The set of unreachable value will not change anymore for + this cycle. Start clean phase. */ + caml_gc_phase = Phase_clean; + caml_final_update_clean_phase (); + if (caml_ephe_list_head != (value) NULL){ + /* Initialise the clean phase. */ + ephes_to_check = &caml_ephe_list_head; + } else { + /* Initialise the sweep phase. */ + init_sweep_phase(); + } + work = 0; } break; default: Assert (0); @@ -279,6 +502,37 @@ } } gray_vals_cur = gray_vals_ptr; + current_value = v; + current_index = start; + INSTR (CAML_INSTR_INT ("major/mark/slice/fields#", slice_fields);) + INSTR (CAML_INSTR_INT ("major/mark/slice/pointers#", slice_pointers);) +} + +/* Clean ephemerons */ +static void clean_slice (intnat work) +{ + value v; + + caml_gc_message (0x40, "Cleaning %ld words\n", work); + while (work > 0){ + v = *ephes_to_check; + if (v != (value) NULL){ + if (Is_white_val (v)){ + /* The whole array is dead, remove it from the list. */ + *ephes_to_check = Field (v, CAML_EPHE_LINK_OFFSET); + work -= 1; + }else{ + caml_ephe_clean(v); + ephes_to_check = &Field (v, CAML_EPHE_LINK_OFFSET); + work -= Whsize_val (v); + } + }else{ /* End of list reached */ + /* Phase_clean is done. */ + /* Initialise the sweep phase. */ + init_sweep_phase(); + work = 0; + } + } } static void sweep_slice (intnat work) @@ -299,7 +553,7 @@ void (*final_fun)(value) = Custom_ops_val(Val_hp(hp))->finalize; if (final_fun != NULL) final_fun(Val_hp(hp)); } - caml_gc_sweep_hp = caml_fl_merge_block (Bp_hp (hp)); + caml_gc_sweep_hp = (char *) caml_fl_merge_block (Val_hp (hp)); break; case Caml_blue: /* Only the blocks of the free-list are blue. See [freelist.c]. */ @@ -318,6 +572,7 @@ ++ caml_stat_major_collections; work = 0; caml_gc_phase = Phase_idle; + caml_request_minor_gc (); }else{ caml_gc_sweep_hp = chunk; limit = chunk + Chunk_size (chunk); @@ -326,17 +581,40 @@ } } -/* The main entry point for the GC. Called after each minor GC. - [howmuch] is the amount of work to do, 0 to let the GC compute it. - Return the computed amount of work to do. +#ifdef CAML_INSTR +static char *mark_slice_name[] = { + /* 0 */ NULL, + /* 1 */ NULL, + /* 2 */ NULL, + /* 3 */ NULL, + /* 4 */ NULL, + /* 5 */ NULL, + /* 6 */ NULL, + /* 7 */ NULL, + /* 8 */ NULL, + /* 9 */ NULL, + /* 10 */ "major/mark_roots", + /* 11 */ "major/mark_main", + /* 12 */ "major/mark_weak1", + /* 13 */ "major/mark_weak2", + /* 14 */ "major/mark_final", +}; +#endif + +/* The main entry point for the major GC. Called about once for each + minor GC. [howmuch] is the amount of work to do: + -1 if the GC is triggered automatically + 0 to let the GC compute the amount of work + [n] to make the GC do enough work to (on average) free [n] words */ -intnat caml_major_collection_slice (intnat howmuch) +void caml_major_collection_slice (intnat howmuch) { - double p, dp; + double p, dp, filt_p, spend; intnat computed_work; + int i; /* Free memory at the start of the GC cycle (garbage + free list) (assumed): - FM = caml_stat_heap_size * caml_percent_free + FM = caml_stat_heap_wsz * caml_percent_free / (100 + caml_percent_free) Assuming steady state and enforcing a constant allocation rate, then @@ -348,40 +626,54 @@ Proportion of G consumed since the previous slice: PH = caml_allocated_words / G = caml_allocated_words * 3 * (100 + caml_percent_free) - / (2 * caml_stat_heap_size * caml_percent_free) + / (2 * caml_stat_heap_wsz * caml_percent_free) Proportion of extra-heap resources consumed since the previous slice: PE = caml_extra_heap_resources Proportion of total work to do in this slice: P = max (PH, PE) + + Here, we insert a time-based filter on the P variable to avoid large + latency spikes in the GC, so the P below is a smoothed-out version of + the P above. + Amount of marking work for the GC cycle: - MW = caml_stat_heap_size * 100 / (100 + caml_percent_free) + MW = caml_stat_heap_wsz * 100 / (100 + caml_percent_free) + + caml_incremental_roots_count Amount of sweeping work for the GC cycle: - SW = caml_stat_heap_size + SW = caml_stat_heap_wsz In order to finish marking with a non-empty free list, we will use 40% of the time for marking, and 60% for sweeping. - If TW is the total work for this cycle, - MW = 40/100 * TW - SW = 60/100 * TW - - Amount of work to do for this slice: - W = P * TW + Let MT be the time spent marking, ST the time spent sweeping, and TT + the total time for this cycle. We have: + MT = 40/100 * TT + ST = 60/100 * TT + + Amount of time to spend on this slice: + T = P * TT = P * MT / (40/100) = P * ST / (60/100) + + Since we must do MW work in MT time or SW work in ST time, the amount + of work for this slice is: + MS = P * MW / (40/100) if marking + SS = P * SW / (60/100) if sweeping Amount of marking work for a marking slice: MS = P * MW / (40/100) - MS = P * caml_stat_heap_size * 250 / (100 + caml_percent_free) + MS = P * (caml_stat_heap_wsz * 250 / (100 + caml_percent_free) + + 2.5 * caml_incremental_roots_count) Amount of sweeping work for a sweeping slice: SS = P * SW / (60/100) - SS = P * caml_stat_heap_size * 5 / 3 + SS = P * caml_stat_heap_wsz * 5 / 3 This slice will either mark MS words or sweep SS words. */ - if (caml_gc_phase == Phase_idle) start_cycle (); + if (caml_major_slice_begin_hook != NULL) (*caml_major_slice_begin_hook) (); + CAML_INSTR_SETUP (tmr, "major"); p = (double) caml_allocated_words * 3.0 * (100 + caml_percent_free) - / Wsize_bsize (caml_stat_heap_size) / caml_percent_free / 2.0; + / caml_stat_heap_wsz / caml_percent_free / 2.0; if (caml_dependent_size > 0){ dp = (double) caml_dependent_allocated * (100 + caml_percent_free) / caml_dependent_size / caml_percent_free; @@ -390,55 +682,142 @@ } if (p < dp) p = dp; if (p < caml_extra_heap_resources) p = caml_extra_heap_resources; + if (p > 0.3) p = 0.3; + CAML_INSTR_INT ("major/work/extra#", + (uintnat) (caml_extra_heap_resources * 1000000)); + caml_gc_message (0x40, "ordered work = %ld words\n", howmuch); caml_gc_message (0x40, "allocated_words = %" ARCH_INTNAT_PRINTF_FORMAT "u\n", caml_allocated_words); caml_gc_message (0x40, "extra_heap_resources = %" ARCH_INTNAT_PRINTF_FORMAT "uu\n", (uintnat) (caml_extra_heap_resources * 1000000)); - caml_gc_message (0x40, "amount of work to do = %" - ARCH_INTNAT_PRINTF_FORMAT "uu\n", - (uintnat) (p * 1000000)); + caml_gc_message (0x40, "raw work-to-do = %" + ARCH_INTNAT_PRINTF_FORMAT "du\n", + (intnat) (p * 1000000)); + + for (i = 0; i < caml_major_window; i++){ + caml_major_ring[i] += p / caml_major_window; + } - if (caml_gc_phase == Phase_mark){ - computed_work = (intnat) (p * Wsize_bsize (caml_stat_heap_size) * 250 - / (100 + caml_percent_free)); + if (caml_gc_clock >= 1.0){ + caml_gc_clock -= 1.0; + ++caml_major_ring_index; + if (caml_major_ring_index >= caml_major_window){ + caml_major_ring_index = 0; + } + } + if (howmuch == -1){ + /* auto-triggered GC slice: spend work credit on the current bucket, + then do the remaining work, if any */ + /* Note that the minor GC guarantees that the major slice is called in + automatic mode (with [howmuch] = -1) at least once per clock tick. + This means we never leave a non-empty bucket behind. */ + spend = fmin (caml_major_work_credit, + caml_major_ring[caml_major_ring_index]); + caml_major_work_credit -= spend; + filt_p = caml_major_ring[caml_major_ring_index] - spend; + caml_major_ring[caml_major_ring_index] = 0.0; }else{ - computed_work = (intnat) (p * Wsize_bsize (caml_stat_heap_size) * 5 / 3); + /* forced GC slice: do work and add it to the credit */ + if (howmuch == 0){ + /* automatic setting: size of next bucket + we do not use the current bucket, as it may be empty */ + int i = caml_major_ring_index + 1; + if (i >= caml_major_window) i = 0; + filt_p = caml_major_ring[i]; + }else{ + /* manual setting */ + filt_p = (double) howmuch * 3.0 * (100 + caml_percent_free) + / caml_stat_heap_wsz / caml_percent_free / 2.0; + } + caml_major_work_credit += filt_p; + } + + p = filt_p; + + caml_gc_message (0x40, "filtered work-to-do = %" + ARCH_INTNAT_PRINTF_FORMAT "du\n", + (intnat) (p * 1000000)); + + if (caml_gc_phase == Phase_idle){ + if (caml_young_ptr == caml_young_alloc_end){ + /* We can only start a major GC cycle if the minor allocation arena + is empty, otherwise we'd have to treat it as a set of roots. */ + start_cycle (); + CAML_INSTR_TIME (tmr, "major/roots"); + } + p = 0; + goto finished; + } + + if (p < 0){ + p = 0; + goto finished; + } + + if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean){ + computed_work = (intnat) (p * ((double) caml_stat_heap_wsz * 250 + / (100 + caml_percent_free) + + caml_incremental_roots_count)); + }else{ + computed_work = (intnat) (p * caml_stat_heap_wsz * 5 / 3); } - caml_gc_message (0x40, "ordered work = %ld words\n", howmuch); caml_gc_message (0x40, "computed work = %ld words\n", computed_work); - if (howmuch == 0) howmuch = computed_work; if (caml_gc_phase == Phase_mark){ - mark_slice (howmuch); + CAML_INSTR_INT ("major/work/mark#", computed_work); + mark_slice (computed_work); + CAML_INSTR_TIME (tmr, mark_slice_name[caml_gc_subphase]); caml_gc_message (0x02, "!", 0); + }else if (caml_gc_phase == Phase_clean){ + clean_slice (computed_work); + caml_gc_message (0x02, "%%", 0); }else{ Assert (caml_gc_phase == Phase_sweep); - sweep_slice (howmuch); + CAML_INSTR_INT ("major/work/sweep#", computed_work); + sweep_slice (computed_work); + CAML_INSTR_TIME (tmr, "major/sweep"); caml_gc_message (0x02, "$", 0); } - if (caml_gc_phase == Phase_idle) caml_compact_heap_maybe (); + if (caml_gc_phase == Phase_idle){ + caml_compact_heap_maybe (); + CAML_INSTR_TIME (tmr, "major/check_and_compact"); + } + + finished: + caml_gc_message (0x40, "work-done = %" + ARCH_INTNAT_PRINTF_FORMAT "du\n", + (intnat) (p * 1000000)); + + /* if some of the work was not done, take it back from the credit + or spread it over the buckets. */ + p = filt_p - p; + spend = fmin (p, caml_major_work_credit); + caml_major_work_credit -= spend; + if (p > spend){ + p -= spend; + p /= caml_major_window; + for (i = 0; i < caml_major_window; i++) caml_major_ring[i] += p; + } caml_stat_major_words += caml_allocated_words; caml_allocated_words = 0; caml_dependent_allocated = 0; caml_extra_heap_resources = 0.0; - return computed_work; + if (caml_major_slice_end_hook != NULL) (*caml_major_slice_end_hook) (); } -/* The minor heap must be empty when this function is called; - the minor heap is empty when this function returns. -*/ -/* This does not call caml_compact_heap_maybe because the estimations of +/* This does not call [caml_compact_heap_maybe] because the estimates of free and live memory are only valid for a cycle done incrementally. - Besides, this function is called by caml_compact_heap_maybe. + Besides, this function itself is called by [caml_compact_heap_maybe]. */ void caml_finish_major_cycle (void) { if (caml_gc_phase == Phase_idle) start_cycle (); while (caml_gc_phase == Phase_mark) mark_slice (LONG_MAX); + while (caml_gc_phase == Phase_clean) clean_slice (LONG_MAX); Assert (caml_gc_phase == Phase_sweep); while (caml_gc_phase == Phase_sweep) sweep_slice (LONG_MAX); Assert (caml_gc_phase == Phase_idle); @@ -446,56 +825,57 @@ caml_allocated_words = 0; } -/* Make sure the request is at least Heap_chunk_min and round it up - to a multiple of the page size. +/* Call this function to make sure [bsz] is greater than or equal + to both [Heap_chunk_min] and the current heap increment. */ -static asize_t clip_heap_chunk_size (asize_t request) +asize_t caml_clip_heap_chunk_wsz (asize_t wsz) { - if (request < Bsize_wsize (Heap_chunk_min)){ - request = Bsize_wsize (Heap_chunk_min); - } - return ((request + Page_size - 1) >> Page_log) << Page_log; -} + asize_t result = wsz; + uintnat incr; -/* Make sure the request is >= caml_major_heap_increment, then call - clip_heap_chunk_size, then make sure the result is >= request. -*/ -asize_t caml_round_heap_chunk_size (asize_t request) -{ - asize_t result = request; - - if (result < caml_major_heap_increment){ - result = caml_major_heap_increment; + /* Compute the heap increment as a word size. */ + if (caml_major_heap_increment > 1000){ + incr = caml_major_heap_increment; + }else{ + incr = caml_stat_heap_wsz / 100 * caml_major_heap_increment; } - result = clip_heap_chunk_size (result); - if (result < request){ - caml_raise_out_of_memory (); - return 0; /* not reached */ + if (result < incr){ + result = incr; + } + if (result < Heap_chunk_min){ + result = Heap_chunk_min; } return result; } +/* [heap_size] is a number of bytes */ void caml_init_major_heap (asize_t heap_size) { - caml_stat_heap_size = clip_heap_chunk_size (heap_size); - caml_stat_top_heap_size = caml_stat_heap_size; - Assert (caml_stat_heap_size % Page_size == 0); - caml_heap_start = (char *) caml_alloc_for_heap (caml_stat_heap_size); + int i; + + caml_stat_heap_wsz = caml_clip_heap_chunk_wsz (Wsize_bsize (heap_size)); + caml_stat_top_heap_wsz = caml_stat_heap_wsz; + Assert (Bsize_wsize (caml_stat_heap_wsz) % Page_size == 0); + caml_heap_start = + (char *) caml_alloc_for_heap (Bsize_wsize (caml_stat_heap_wsz)); if (caml_heap_start == NULL) - caml_fatal_error ("Fatal error: not enough memory for the initial heap.\n"); + caml_fatal_error ("Fatal error: cannot allocate initial major heap.\n"); Chunk_next (caml_heap_start) = NULL; + caml_stat_heap_wsz = Wsize_bsize (Chunk_size (caml_heap_start)); caml_stat_heap_chunks = 1; + caml_stat_top_heap_wsz = caml_stat_heap_wsz; if (caml_page_table_add(In_heap, caml_heap_start, - caml_heap_start + caml_stat_heap_size) != 0) { - caml_fatal_error ("Fatal error: not enough memory " - "for the initial page table.\n"); + caml_heap_start + Bsize_wsize (caml_stat_heap_wsz)) + != 0) { + caml_fatal_error ("Fatal error: cannot allocate " + "initial page table.\n"); } caml_fl_init_merge (); caml_make_free_blocks ((value *) caml_heap_start, - Wsize_bsize (caml_stat_heap_size), 1, Caml_white); + caml_stat_heap_wsz, 1, Caml_white); caml_gc_phase = Phase_idle; gray_vals_size = 2048; gray_vals = (value *) malloc (gray_vals_size * sizeof (value)); @@ -506,4 +886,21 @@ heap_is_pure = 1; caml_allocated_words = 0; caml_extra_heap_resources = 0.0; + for (i = 0; i < Max_major_window; i++) caml_major_ring[i] = 0.0; +} + +void caml_set_major_window (int w){ + uintnat total = 0; + int i; + if (w == caml_major_window) return; + CAMLassert (w <= Max_major_window); + /* Collect the current work-to-do from the buckets. */ + for (i = 0; i < caml_major_window; i++){ + total += caml_major_ring[i]; + } + /* Redistribute to the new buckets. */ + for (i = 0; i < w; i++){ + caml_major_ring[i] = total / w; + } + caml_major_window = w; } diff -Nru ocaml-4.01.0/byterun/major_gc.h ocaml-4.05.0/byterun/major_gc.h --- ocaml-4.01.0/byterun/major_gc.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/major_gc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,60 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_MAJOR_GC_H -#define CAML_MAJOR_GC_H - - -#include "freelist.h" -#include "misc.h" - -typedef struct { - void *block; /* address of the malloced block this chunk live in */ - asize_t alloc; /* in bytes, used for compaction */ - asize_t size; /* in bytes */ - char *next; -} heap_chunk_head; - -#define Chunk_size(c) (((heap_chunk_head *) (c)) [-1]).size -#define Chunk_alloc(c) (((heap_chunk_head *) (c)) [-1]).alloc -#define Chunk_next(c) (((heap_chunk_head *) (c)) [-1]).next -#define Chunk_block(c) (((heap_chunk_head *) (c)) [-1]).block - -extern int caml_gc_phase; -extern int caml_gc_subphase; -extern uintnat caml_allocated_words; -extern double caml_extra_heap_resources; -extern uintnat caml_dependent_size, caml_dependent_allocated; -extern uintnat caml_fl_size_at_phase_change; - -#define Phase_mark 0 -#define Phase_sweep 1 -#define Phase_idle 2 -#define Subphase_main 10 -#define Subphase_weak1 11 -#define Subphase_weak2 12 -#define Subphase_final 13 - -CAMLextern char *caml_heap_start; -extern uintnat total_heap_size; -extern char *caml_gc_sweep_hp; - -void caml_init_major_heap (asize_t); /* size in bytes */ -asize_t caml_round_heap_chunk_size (asize_t); /* size in bytes */ -void caml_darken (value, value *); -intnat caml_major_collection_slice (intnat); -void major_collection (void); -void caml_finish_major_cycle (void); - - -#endif /* CAML_MAJOR_GC_H */ diff -Nru ocaml-4.01.0/byterun/Makefile ocaml-4.05.0/byterun/Makefile --- ocaml-4.01.0/byterun/Makefile 2013-03-28 16:10:24.000000000 +0000 +++ ocaml-4.05.0/byterun/Makefile 2017-07-13 08:56:44.000000000 +0000 @@ -1,75 +1,251 @@ -######################################################################### -# # -# OCaml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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. # -# # -######################################################################### - -include Makefile.common - -CFLAGS=-DCAML_NAME_SPACE -O $(BYTECCCOMPOPTS) $(IFLEXDIR) -DFLAGS=-DCAML_NAME_SPACE -g -DDEBUG $(BYTECCCOMPOPTS) $(IFLEXDIR) - -OBJS=$(COMMONOBJS) unix.o main.o -DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o -PICOBJS=$(OBJS:.o=.pic.o) - -SHARED_LIBS_TMP=$(SUPPORTS_SHARED_LIBRARIES:%false=) -SHARED_LIBS_DEPS=$(SHARED_LIBS_TMP:%true=libcamlrun_shared.so) - -all:: $(SHARED_LIBS_DEPS) - -ocamlrun$(EXE): libcamlrun.a prims.o - $(MKEXE) $(BYTECCLINKOPTS) -o ocamlrun$(EXE) \ - prims.o libcamlrun.a $(BYTECCLIBS) - -ocamlrund$(EXE): libcamlrund.a prims.o - $(MKEXE) $(MKEXEDEBUGFLAG) $(BYTECCLINKOPTS) -o ocamlrund$(EXE) \ - prims.o libcamlrund.a $(BYTECCLIBS) - -libcamlrun.a: $(OBJS) - ar rc libcamlrun.a $(OBJS) - $(RANLIB) libcamlrun.a - -libcamlrund.a: $(DOBJS) - ar rc libcamlrund.a $(DOBJS) - $(RANLIB) libcamlrund.a - -libcamlrun_shared.so: $(PICOBJS) - $(MKDLL) -o libcamlrun_shared.so $(PICOBJS) $(BYTECCLIBS) - -install:: - if test -f libcamlrun_shared.so; then \ - cp libcamlrun_shared.so $(LIBDIR)/libcamlrun_shared.so; fi - -clean:: - rm -f libcamlrun_shared.so - -.SUFFIXES: .d.o .pic.o - -.c.d.o: - ln -s -f $*.c $*.d.c - $(CC) -c $(DFLAGS) $*.d.c - rm $*.d.c - -.c.pic.o: - ln -s -f $*.c $*.pic.c - $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $*.pic.c - rm $*.pic.c - -clean:: - rm -f *.pic.c *.d.c - -depend : prims.c opnames.h jumptbl.h version.h - -gcc -MM $(BYTECCCOMPOPTS) *.c > .depend - -gcc -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend - -gcc -MM $(BYTECCCOMPOPTS) *.c | sed -e 's/\.o/.pic.o/' >> .depend +#************************************************************************** +#* * +#* OCaml * +#* * +#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * +#* * +#* Copyright 1999 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +include ../config/Makefile + +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + +# The PROGRAMS (resp. LIBRARIES) variable list the files to build and +# install as programs in $(INSTALL_BINDIR) (resp. libraries in +# $(INSTALL_LIBDIR)) + +PROGRAMS = ocamlrun$(EXE) +LIBRARIES = ld.conf libcamlrun.$(A) + +ifeq "$(RUNTIMED)" "true" +PROGRAMS += ocamlrund$(EXE) +LIBRARIES += libcamlrund.$(A) +endif + +ifeq "$(RUNTIMEI)" "true" +PROGRAMS += ocamlruni$(EXE) +LIBRARIES += libcamlruni.$(A) +endif + +ifeq "$(UNIX_OR_WIN32)" "unix" +ifeq "$(SUPPORTS_SHARED_LIBRARIES)" "true" +LIBRARIES += libcamlrun_pic.$(A) libcamlrun_shared.$(SO) +endif +endif + +CC=$(BYTECC) + +ifdef BOOTSTRAPPING_FLEXLINK +CFLAGS=-DBOOTSTRAPPING_FLEXLINK +else +CFLAGS= +endif + +# On Windows, OCAML_STDLIB_DIR needs to be defined dynamically + +ifeq "$(UNIX_OR_WIN32)" "win32" +CFLAGS += -DOCAML_STDLIB_DIR='"$(LIBDIR)"' +endif + +CFLAGS += $(IFLEXDIR) $(BYTECCCOMPOPTS) + +DFLAGS=$(CFLAGS) -DDEBUG +IFLAGS=$(CFLAGS) -DCAML_INSTR +PICFLAGS=$(CFLAGS) $(SHAREDCCCOMPOPTS) + +ifneq "$(CCOMPTYPE)" "msvc" +DFLAGS += -g +endif + +ifeq "$(CCOMPTYPE)" "msvc" +OUTPUTOBJ=-Fo +else +OUTPUTOBJ=-o +endif +DBGO=d.$(O) + +ifeq "$(UNIX_OR_WIN32)" "win32" +LIBS = $(call SYSLIB,ws2_32) $(EXTRALIBS) +ifdef BOOTSTRAPPING_FLEXLINK +MAKE_OCAMLRUN=$(MKEXE_BOOT) +else +MAKE_OCAMLRUN = $(MKEXE) -o $(1) $(2) +endif +else +LIBS = $(BYTECCLIBS) +MAKE_OCAMLRUN = $(MKEXE) $(BYTECCLINKOPTS) -o $(1) $(2) +endif + +PRIMS=\ + alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ + intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \ + signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \ + dynlink.c backtrace_prim.c backtrace.c spacetime.c afl.c + +OBJS=$(addsuffix .$(O), \ + interp misc stacks fix_code startup_aux startup \ + freelist major_gc minor_gc memory alloc roots globroots \ + fail signals signals_byt printexc backtrace_prim backtrace \ + compare ints floats str array io extern intern \ + hash sys meta parsing gc_ctrl terminfo md5 obj \ + lexing callback debugger weak compact finalise custom \ + dynlink spacetime afl $(UNIX_OR_WIN32) main) + +DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO) +IOBJS=$(OBJS:.$(O)=.i.$(O)) +PICOBJS=$(OBJS:.$(O)=.pic.$(O)) + +.PHONY: all +all: $(LIBRARIES) $(PROGRAMS) + +ld.conf: ../config/Makefile + echo "$(STUBLIBDIR)" > $@ + echo "$(LIBDIR)" >> $@ + +.PHONY: install +install: + cp $(PROGRAMS) "$(INSTALL_BINDIR)" + cp $(LIBRARIES) "$(INSTALL_LIBDIR)" + mkdir -p "$(INSTALL_LIBDIR)/caml" + for i in caml/*.h; do \ + sed -f ../tools/cleanup-header $$i \ + > "$(INSTALL_LIBDIR)/$$i"; \ + done + +# If primitives contain duplicated lines (e.g. because the code is defined +# like +# #ifdef X +# CAMLprim value caml_foo() ... +# #else +# CAMLprim value caml_foo() ... +# end), horrible things will happen (duplicated entries in Runtimedef -> +# double registration in Symtable -> empty entry in the PRIM table -> +# the bytecode interpreter is confused). +# We sort the primitive file and remove duplicates to avoid this problem. + +# Warning: we use "sort | uniq" instead of "sort -u" because in the MSVC +# port, the "sort" program in the path is Microsoft's and not cygwin's + +# Warning: POSIX sort is locale dependent, that's why we set LC_ALL explicitly. +# Sort is unstable for "is_directory" and "isatty" +# see http://pubs.opengroup.org/onlinepubs/9699919799/utilities/sort.html: +# "using sort to process pathnames, it is recommended that LC_ALL .. set to C" + + +primitives : $(PRIMS) + sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" $(PRIMS) \ + | LC_ALL=C sort | uniq > primitives + +prims.c : primitives + (echo '#define CAML_INTERNALS'; \ + echo '#include "caml/mlvalues.h"'; \ + echo '#include "caml/prims.h"'; \ + sed -e 's/.*/extern value &();/' primitives; \ + echo 'c_primitive caml_builtin_cprim[] = {'; \ + sed -e 's/.*/ &,/' primitives; \ + echo ' 0 };'; \ + echo 'char * caml_names_of_builtin_cprim[] = {'; \ + sed -e 's/.*/ "&",/' primitives; \ + echo ' 0 };') > prims.c + +caml/opnames.h : caml/instruct.h + sed -e '/\/\*/d' \ + -e '/^#/d' \ + -e 's/enum /char * names_of_/' \ + -e 's/{$$/[] = {/' \ + -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' caml/instruct.h \ + > caml/opnames.h + +# caml/jumptbl.h is required only if you have GCC 2.0 or later +caml/jumptbl.h : caml/instruct.h + sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \ + -e '/^}/q' caml/instruct.h > caml/jumptbl.h + +caml/version.h : ../VERSION ../tools/make-version-header.sh + ../tools/make-version-header.sh ../VERSION > caml/version.h + +.PHONY: clean +clean: + rm -f $(LIBRARIES) $(PROGRAMS) *.$(O) *.$(A) *.$(SO) + rm -f primitives prims.c caml/opnames.h caml/jumptbl.h + rm -f caml/version.h + +ocamlrun$(EXE): prims.$(O) libcamlrun.$(A) + $(call MAKE_OCAMLRUN,$@,$^ $(LIBS)) + +libcamlrun.$(A): $(OBJS) + $(call MKLIB,$@, $^) + +ocamlrund$(EXE): prims.$(O) libcamlrund.$(A) + $(MKEXE) $(MKEXEDEBUGFLAG) $(BYTECCLINKOPTS) -o $@ $^ $(LIBS) + +libcamlrund.$(A): $(DOBJS) + $(call MKLIB,$@, $^) + +ocamlruni$(EXE): prims.$(O) libcamlruni.$(A) + $(MKEXE) $(BYTECCLINKOPTS) -o $@ $^ $(LIBS) + +libcamlruni.$(A): $(IOBJS) + $(call MKLIB,$@, $^) + +libcamlrun_pic.$(A): $(PICOBJS) + $(call MKLIB,$@, $^) + +libcamlrun_shared.$(SO): $(PICOBJS) + $(MKDLL) -o $@ $^ $(BYTECCLIBS) + +%.$(O): %.c + $(CC) $(CFLAGS) -c $< + +%.$(DBGO): %.c + $(CC) $(DFLAGS) -c $(OUTPUTOBJ)$@ $< + +%.i.$(O): %.c + $(CC) $(IFLAGS) -c $(OUTPUTOBJ)$@ $< + +%.pic.$(O): %.c + $(CC) $(PICFLAGS) -c $(OUTPUTOBJ)$@ $< + +ifneq "$(TOOLCHAIN)" "msvc" .PHONY: depend +depend : prims.c caml/opnames.h caml/jumptbl.h caml/version.h + -$(CC) -MM $(BYTECCCOMPOPTS) *.c > .depend + -$(CC) -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' \ + >> .depend + -$(CC) -MM $(BYTECCCOMPOPTS) -DCAML_INSTR *.c | sed -e 's/\.o/.i.o/' \ + >> .depend + -$(CC) -MM $(BYTECCCOMPOPTS) *.c | sed -e 's/\.o/.pic.o/' >> .depend +endif + +ifeq "$(UNIX_OR_WIN32)" "win32" +.depend.nt: .depend + rm -f .depend.win32 + echo "win32.o: win32.c caml/fail.h caml/compatibility.h \\"\ + >> .depend.win32 + echo " caml/misc.h caml/config.h ../config/m.h ../config/s.h \\"\ + >> .depend.win32 + echo " caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \\"\ + >> .depend.win32 + echo " caml/freelist.h caml/minor_gc.h caml/osdeps.h caml/signals.h"\ + >> .depend.win32 + cat .depend >> .depend.win32 + sed -ne '/\.pic\.o/q' \ + -e 's/^\(.*\)\.d\.o:/\1.$$(DBGO):/' \ + -e 's/^\(.*\)\.o:/\1.$$(O):/' \ + -e p \ + .depend.win32 > .depend.nt + rm -f .depend.win32 + +include .depend.nt +else include .depend +endif diff -Nru ocaml-4.01.0/byterun/Makefile.common ocaml-4.05.0/byterun/Makefile.common --- ocaml-4.01.0/byterun/Makefile.common 2013-08-19 18:21:47.000000000 +0000 +++ ocaml-4.05.0/byterun/Makefile.common 1970-01-01 00:00:00.000000000 +0000 @@ -1,120 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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. # -# # -######################################################################### - -include ../config/Makefile - -CC=$(BYTECC) - -COMMONOBJS=\ - interp.o misc.o stacks.o fix_code.o startup.o \ - freelist.o major_gc.o minor_gc.o memory.o alloc.o roots.o globroots.o \ - fail.o signals.o signals_byt.o printexc.o backtrace.o \ - compare.o ints.o floats.o str.o array.o io.o extern.o intern.o \ - hash.o sys.o meta.o parsing.o gc_ctrl.o terminfo.o md5.o obj.o \ - lexing.o callback.o debugger.o weak.o compact.o finalise.o custom.o \ - dynlink.o - -PRIMS=\ - alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ - intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \ - signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \ - dynlink.c backtrace.c - -PUBLIC_INCLUDES=\ - alloc.h callback.h config.h custom.h fail.h hash.h intext.h \ - memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h - - -all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) all-$(RUNTIMED) -.PHONY: all - -all-noruntimed: -.PHONY: all-noruntimed - -all-runtimed: ocamlrund$(EXE) libcamlrund.$(A) -.PHONY: all-runtimed - -ld.conf: ../config/Makefile - echo "$(STUBLIBDIR)" > ld.conf - echo "$(LIBDIR)" >> ld.conf - -install:: - cp ocamlrun$(EXE) $(BINDIR)/ocamlrun$(EXE) - cp libcamlrun.$(A) $(LIBDIR)/libcamlrun.$(A) - cd $(LIBDIR); $(RANLIB) libcamlrun.$(A) - if test -d $(LIBDIR)/caml; then : ; else mkdir $(LIBDIR)/caml; fi - for i in $(PUBLIC_INCLUDES); do \ - sed -f ../tools/cleanup-header $$i > $(LIBDIR)/caml/$$i; \ - done - cp ld.conf $(LIBDIR)/ld.conf -.PHONY: install - -install:: install-$(RUNTIMED) - -install-noruntimed: -.PHONY: install-noruntimed - -install-runtimed: - cp ocamlrund$(EXE) $(BINDIR)/ocamlrund$(EXE) - cp libcamlrund.$(A) $(LIBDIR)/libcamlrund.$(A) -.PHONY: install-runtimed - -# If primitives contain duplicated lines (e.g. because the code is defined -# like -# #ifdef X -# CAMLprim value caml_foo() ... -# #else -# CAMLprim value caml_foo() ... -# end), horrible things will happen (duplicated entries in Runtimedef -> -# double registration in Symtable -> empty entry in the PRIM table -> -# the bytecode interpreter is confused). -# We sort the primitive file and remove duplicates to avoid this problem. - -# Warning: we use "sort | uniq" instead of "sort -u" because in the MSVC -# port, the "sort" program in the path is Microsoft's and not cygwin's - -primitives : $(PRIMS) - sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" $(PRIMS) \ - | sort | uniq > primitives - -prims.c : primitives - (echo '#include "mlvalues.h"'; \ - echo '#include "prims.h"'; \ - sed -e 's/.*/extern value &();/' primitives; \ - echo 'c_primitive caml_builtin_cprim[] = {'; \ - sed -e 's/.*/ &,/' primitives; \ - echo ' 0 };'; \ - echo 'char * caml_names_of_builtin_cprim[] = {'; \ - sed -e 's/.*/ "&",/' primitives; \ - echo ' 0 };') > prims.c - -opnames.h : instruct.h - sed -e '/\/\*/d' \ - -e '/^#/d' \ - -e 's/enum /char * names_of_/' \ - -e 's/{$$/[] = {/' \ - -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' instruct.h > opnames.h - -# jumptbl.h is required only if you have GCC 2.0 or later -jumptbl.h : instruct.h - sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \ - -e '/^}/q' instruct.h > jumptbl.h - -version.h : ../VERSION - echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" > version.h - -clean :: - rm -f ocamlrun$(EXE) ocamlrund$(EXE) *.$(O) *.$(A) *.$(SO) - rm -f primitives prims.c opnames.h jumptbl.h ld.conf - rm -f version.h -.PHONY: clean diff -Nru ocaml-4.01.0/byterun/Makefile.nt ocaml-4.05.0/byterun/Makefile.nt --- ocaml-4.01.0/byterun/Makefile.nt 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/byterun/Makefile.nt 2017-07-13 08:56:44.000000000 +0000 @@ -1,56 +1,16 @@ -######################################################################### -# # -# OCaml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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. # -# # -######################################################################### +#************************************************************************** +#* * +#* OCaml * +#* * +#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * +#* * +#* Copyright 1999 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** -include Makefile.common - -CFLAGS=-DOCAML_STDLIB_DIR='"$(LIBDIR)"' $(IFLEXDIR) - -DBGO=d.$(O) -OBJS=$(COMMONOBJS:.o=.$(O)) win32.$(O) main.$(O) -DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO) - -ocamlrun$(EXE): libcamlrun.$(A) prims.$(O) - $(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) \ - $(EXTRALIBS) libcamlrun.$(A) - -ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O) - $(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) \ - $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A) - -libcamlrun.$(A): $(OBJS) - $(call MKLIB,libcamlrun.$(A),$(OBJS)) - -libcamlrund.$(A): $(DOBJS) - $(call MKLIB,libcamlrund.$(A),$(DOBJS)) - -.SUFFIXES: .$(O) .$(DBGO) - -.c.$(O): - $(CC) $(CFLAGS) $(BYTECCCOMPOPTS) -c $< - -.c.$(DBGO): - $(CC) $(CFLAGS) $(BYTECCDBGCOMPOPTS) -c $< - mv $*.$(O) $*.$(DBGO) - -.depend.nt: .depend - rm -f .depend.win32 - echo "win32.o: win32.c fail.h compatibility.h \\" >> .depend.win32 - echo " misc.h config.h ../config/m.h ../config/s.h \\" >> .depend.win32 - echo " mlvalues.h memory.h gc.h major_gc.h \\" >> .depend.win32 - echo " freelist.h minor_gc.h osdeps.h signals.h" >> .depend.win32 - cat .depend >> .depend.win32 - sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(O) \1.$$(DBGO):/' \ - .depend.win32 > .depend.nt - rm -f .depend.win32 - -include .depend.nt +include Makefile diff -Nru ocaml-4.01.0/byterun/md5.c ocaml-4.05.0/byterun/md5.c --- ocaml-4.01.0/byterun/md5.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/md5.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,24 +1,28 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS #include -#include "alloc.h" -#include "fail.h" -#include "md5.h" -#include "memory.h" -#include "mlvalues.h" -#include "io.h" -#include "reverse.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/md5.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/io.h" +#include "caml/reverse.h" /* MD5 message digest */ @@ -33,18 +37,16 @@ return res; } -CAMLprim value caml_md5_chan(value vchan, value len) +CAMLexport value caml_md5_channel(struct channel *chan, intnat toread) { - CAMLparam2 (vchan, len); - struct channel * chan = Channel(vchan); + CAMLparam0(); struct MD5Context ctx; value res; - intnat toread, read; + intnat read; char buffer[4096]; Lock(chan); caml_MD5Init(&ctx); - toread = Long_val(len); if (toread < 0){ while (1){ read = caml_getblock (chan, buffer, sizeof(buffer)); @@ -66,6 +68,12 @@ CAMLreturn (res); } +CAMLprim value caml_md5_chan(value vchan, value len) +{ + CAMLparam2 (vchan, len); + CAMLreturn (caml_md5_channel(Channel(vchan), Long_val(len))); +} + CAMLexport void caml_md5_block(unsigned char digest[16], void * data, uintnat len) { @@ -97,11 +105,11 @@ #else static void byteReverse(unsigned char * buf, unsigned longs) { - uint32 t; + uint32_t t; do { - t = (uint32) ((unsigned) buf[3] << 8 | buf[2]) << 16 | + t = (uint32_t) ((unsigned) buf[3] << 8 | buf[2]) << 16 | ((unsigned) buf[1] << 8 | buf[0]); - *(uint32 *) buf = t; + *(uint32_t *) buf = t; buf += 4; } while (--longs); } @@ -129,12 +137,12 @@ CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf, uintnat len) { - uint32 t; + uint32_t t; /* Update bitcount */ t = ctx->bits[0]; - if ((ctx->bits[0] = t + ((uint32) len << 3)) < t) + if ((ctx->bits[0] = t + ((uint32_t) len << 3)) < t) ctx->bits[1]++; /* Carry from low to high */ ctx->bits[1] += len >> 29; @@ -152,7 +160,7 @@ } memcpy(p, buf, t); byteReverse(ctx->in, 16); - caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in); buf += t; len -= t; } @@ -161,7 +169,7 @@ while (len >= 64) { memcpy(ctx->in, buf, 64); byteReverse(ctx->in, 16); - caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in); buf += 64; len -= 64; } @@ -196,7 +204,7 @@ /* Two lots of padding: Pad the first block to 64 bytes */ memset(p, 0, count); byteReverse(ctx->in, 16); - caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in); /* Now fill the next block with 56 bytes */ memset(ctx->in, 0, 56); @@ -207,10 +215,10 @@ byteReverse(ctx->in, 14); /* Append length in bits and transform */ - ((uint32 *) ctx->in)[14] = ctx->bits[0]; - ((uint32 *) ctx->in)[15] = ctx->bits[1]; + ((uint32_t *) ctx->in)[14] = ctx->bits[0]; + ((uint32_t *) ctx->in)[15] = ctx->bits[1]; - caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in); byteReverse((unsigned char *) ctx->buf, 4); memcpy(digest, ctx->buf, 16); memset(ctx, 0, sizeof(*ctx)); /* In case it's sensitive */ @@ -233,9 +241,9 @@ * reflect the addition of 16 longwords of new data. caml_MD5Update blocks * the data and converts bytes into longwords for this routine. */ -CAMLexport void caml_MD5Transform(uint32 *buf, uint32 *in) +CAMLexport void caml_MD5Transform(uint32_t *buf, uint32_t *in) { - register uint32 a, b, c, d; + register uint32_t a, b, c, d; a = buf[0]; b = buf[1]; diff -Nru ocaml-4.01.0/byterun/md5.h ocaml-4.05.0/byterun/md5.h --- ocaml-4.01.0/byterun/md5.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/md5.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1999 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. */ -/* */ -/***********************************************************************/ - -/* MD5 message digest */ - -#ifndef CAML_MD5_H -#define CAML_MD5_H - - -#include "mlvalues.h" -#include "io.h" - -CAMLextern value caml_md5_string (value str, value ofs, value len); -CAMLextern value caml_md5_chan (value vchan, value len); -CAMLextern void caml_md5_block(unsigned char digest[16], - void * data, uintnat len); - -struct MD5Context { - uint32 buf[4]; - uint32 bits[2]; - unsigned char in[64]; -}; - -CAMLextern void caml_MD5Init (struct MD5Context *context); -CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf, - uintnat len); -CAMLextern void caml_MD5Final (unsigned char *digest, struct MD5Context *ctx); -CAMLextern void caml_MD5Transform (uint32 *buf, uint32 *in); - - -#endif /* CAML_MD5_H */ diff -Nru ocaml-4.01.0/byterun/memory.c ocaml-4.05.0/byterun/memory.c --- ocaml-4.01.0/byterun/memory.c 2013-08-01 08:12:41.000000000 +0000 +++ ocaml-4.05.0/byterun/memory.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,29 +1,47 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS #include #include -#include "fail.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "memory.h" -#include "major_gc.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "signals.h" +#include "caml/address_class.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/major_gc.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/signals.h" + +int caml_huge_fallback_count = 0; +/* Number of times that mmapping big pages fails and we fell back to small + pages. This counter is available to the program through + [Gc.huge_fallback_count]. +*/ + +uintnat caml_use_huge_pages = 0; +/* True iff the program allocates heap chunks by mmapping huge pages. + This is set when parsing [OCAMLRUNPARAM] and must stay constant + after that. +*/ extern uintnat caml_percent_free; /* major_gc.c */ @@ -216,25 +234,65 @@ return 0; } + +/* Initialize the [alloc_for_heap] system. + This function must be called exactly once, and it must be called + before the first call to [alloc_for_heap]. + It returns 0 on success and -1 on failure. +*/ +int caml_init_alloc_for_heap (void) +{ + return 0; +} + /* Allocate a block of the requested size, to be passed to [caml_add_to_heap] later. - [request] must be a multiple of [Page_size]. - [caml_alloc_for_heap] returns NULL if the request cannot be satisfied. - The returned pointer is a hp, but the header must be initialized by - the caller. + [request] will be rounded up to some implementation-dependent size. + The caller must use [Chunk_size] on the result to recover the actual + size. + Return NULL if the request cannot be satisfied. The returned pointer + is a hp, but the header (and the contents) must be initialized by the + caller. */ char *caml_alloc_for_heap (asize_t request) { - char *mem; - void *block; - Assert (request % Page_size == 0); - mem = caml_aligned_malloc (request + sizeof (heap_chunk_head), - sizeof (heap_chunk_head), &block); - if (mem == NULL) return NULL; - mem += sizeof (heap_chunk_head); - Chunk_size (mem) = request; - Chunk_block (mem) = block; - return mem; + if (caml_use_huge_pages){ +#ifdef HAS_HUGE_PAGES + uintnat size = Round_mmap_size (sizeof (heap_chunk_head) + request); + void *block; + char *mem; + block = mmap (NULL, size, PROT_READ | PROT_WRITE, + MAP_PRIVATE | MAP_ANONYMOUS | MAP_HUGETLB, -1, 0); + if (block == MAP_FAILED) return NULL; + mem = (char *) block + sizeof (heap_chunk_head); + Chunk_size (mem) = size - sizeof (heap_chunk_head); + Chunk_block (mem) = block; + return mem; +#else + return NULL; +#endif + }else{ + char *mem; + void *block; + + request = ((request + Page_size - 1) >> Page_log) << Page_log; + mem = caml_aligned_malloc (request + sizeof (heap_chunk_head), + sizeof (heap_chunk_head), &block); + if (mem == NULL) return NULL; + mem += sizeof (heap_chunk_head); + Chunk_size (mem) = request; + Chunk_block (mem) = block; + return mem; + } +} + +/* Use this function if a block allocated with [caml_alloc_for_heap] is + not actually going to be added to the heap. The caller is responsible + for freeing it. */ +void caml_disown_for_heap (char* mem) +{ + /* Currently a no-op. */ + (void)mem; /* can CAMLunused_{start,end} be used here? */ } /* Use this function to free a block allocated with [caml_alloc_for_heap] @@ -242,7 +300,15 @@ */ void caml_free_for_heap (char *mem) { - free (Chunk_block (mem)); + if (caml_use_huge_pages){ +#ifdef HAS_HUGE_PAGES + munmap (Chunk_block (mem), Chunk_size (mem) + sizeof (heap_chunk_head)); +#else + CAMLassert (0); +#endif + }else{ + free (Chunk_block (mem)); + } } /* Take a chunk of memory as argument, which must be the result of a @@ -258,13 +324,12 @@ */ int caml_add_to_heap (char *m) { - Assert (Chunk_size (m) % Page_size == 0); #ifdef DEBUG /* Should check the contents of the block. */ -#endif /* debug */ +#endif /* DEBUG */ caml_gc_message (0x04, "Growing heap to %luk bytes\n", - (caml_stat_heap_size + Chunk_size (m)) / 1024); + (Bsize_wsize (caml_stat_heap_wsz) + Chunk_size (m)) / 1024); /* Register block in page table */ if (caml_page_table_add(In_heap, m, m + Chunk_size(m)) != 0) @@ -285,9 +350,9 @@ ++ caml_stat_heap_chunks; } - caml_stat_heap_size += Chunk_size (m); - if (caml_stat_heap_size > caml_stat_top_heap_size){ - caml_stat_top_heap_size = caml_stat_heap_size; + caml_stat_heap_wsz += Wsize_bsize (Chunk_size (m)); + if (caml_stat_heap_wsz > caml_stat_top_heap_wsz){ + caml_stat_top_heap_wsz = caml_stat_heap_wsz; } return 0; } @@ -298,52 +363,56 @@ field 0); the last block of the chain is pointed by field 1 of the first. There may be a fragment after the last block. The caller must insert the blocks into the free list. - The request must be less than or equal to Max_wosize. + [request] is a number of words and must be less than or equal + to [Max_wosize]. Return NULL when out of memory. */ -static char *expand_heap (mlsize_t request) +static value *expand_heap (mlsize_t request) { - char *mem, *hp, *prev; + /* these point to headers, but we do arithmetic on them, hence [value *]. */ + value *mem, *hp, *prev; asize_t over_request, malloc_request, remain; Assert (request <= Max_wosize); over_request = request + request / 100 * caml_percent_free; - malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (over_request)); - mem = caml_alloc_for_heap (malloc_request); + malloc_request = caml_clip_heap_chunk_wsz (over_request); + mem = (value *) caml_alloc_for_heap (Bsize_wsize (malloc_request)); if (mem == NULL){ caml_gc_message (0x04, "No room for growing heap\n", 0); return NULL; } - remain = malloc_request; + remain = Wsize_bsize (Chunk_size (mem)); prev = hp = mem; /* FIXME find a way to do this with a call to caml_make_free_blocks */ - while (Wosize_bhsize (remain) > Max_wosize){ + while (Wosize_whsize (remain) > Max_wosize){ Hd_hp (hp) = Make_header (Max_wosize, 0, Caml_blue); #ifdef DEBUG - caml_set_fields (Bp_hp (hp), 0, Debug_free_major); + caml_set_fields (Val_hp (hp), 0, Debug_free_major); #endif - hp += Bhsize_wosize (Max_wosize); - remain -= Bhsize_wosize (Max_wosize); - Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp); + hp += Whsize_wosize (Max_wosize); + remain -= Whsize_wosize (Max_wosize); + Field (Val_hp (mem), 1) = Field (Val_hp (prev), 0) = Val_hp (hp); prev = hp; } if (remain > 1){ - Hd_hp (hp) = Make_header (Wosize_bhsize (remain), 0, Caml_blue); + Hd_hp (hp) = Make_header (Wosize_whsize (remain), 0, Caml_blue); #ifdef DEBUG - caml_set_fields (Bp_hp (hp), 0, Debug_free_major); + caml_set_fields (Val_hp (hp), 0, Debug_free_major); #endif - Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp); - Field (Op_hp (hp), 0) = (value) NULL; + Field (Val_hp (mem), 1) = Field (Val_hp (prev), 0) = Val_hp (hp); + Field (Val_hp (hp), 0) = (value) NULL; }else{ - Field (Op_hp (prev), 0) = (value) NULL; - if (remain == 1) Hd_hp (hp) = Make_header (0, 0, Caml_white); + Field (Val_hp (prev), 0) = (value) NULL; + if (remain == 1) { + Hd_hp (hp) = Make_header_allocated_here (0, 0, Caml_white); + } } Assert (Wosize_hp (mem) >= request); - if (caml_add_to_heap (mem) != 0){ - caml_free_for_heap (mem); + if (caml_add_to_heap ((char *) mem) != 0){ + caml_free_for_heap ((char *) mem); return NULL; } - return Bp_hp (mem); + return Op_hp (mem); } /* Remove the heap chunk [chunk] from the heap and give the memory back @@ -358,12 +427,13 @@ want to shift the page table, it's too messy (see above). It will never happen anyway, because of the way compaction works. (see compact.c) + XXX FIXME this has become false with the fix to PR#5389 (see compact.c) */ if (chunk == caml_heap_start) return; - caml_stat_heap_size -= Chunk_size (chunk); - caml_gc_message (0x04, "Shrinking heap to %luk bytes\n", - (unsigned long) caml_stat_heap_size / 1024); + caml_stat_heap_wsz -= Wsize_bsize (Chunk_size (chunk)); + caml_gc_message (0x04, "Shrinking heap to %luk words\n", + (unsigned long) caml_stat_heap_wsz / 1024); #ifdef DEBUG { @@ -390,7 +460,7 @@ color_t caml_allocation_color (void *hp) { - if (caml_gc_phase == Phase_mark + if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean || (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){ return Caml_black; }else{ @@ -401,40 +471,52 @@ } } -CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) +static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag, + int raise_oom, uintnat profinfo) { - char *hp, *new_block; + header_t *hp; + value *new_block; - if (wosize > Max_wosize) caml_raise_out_of_memory (); + if (wosize > Max_wosize) { + if (raise_oom) + caml_raise_out_of_memory (); + else + return 0; + } hp = caml_fl_allocate (wosize); if (hp == NULL){ new_block = expand_heap (wosize); if (new_block == NULL) { - if (caml_in_minor_collection) + if (!raise_oom) + return 0; + else if (caml_in_minor_collection) caml_fatal_error ("Fatal error: out of memory.\n"); else caml_raise_out_of_memory (); } - caml_fl_add_blocks (new_block); + caml_fl_add_blocks ((value) new_block); hp = caml_fl_allocate (wosize); } Assert (Is_in_heap (Val_hp (hp))); /* Inline expansion of caml_allocation_color. */ - if (caml_gc_phase == Phase_mark + if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean || (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){ - Hd_hp (hp) = Make_header (wosize, tag, Caml_black); + Hd_hp (hp) = Make_header_with_profinfo (wosize, tag, Caml_black, profinfo); }else{ Assert (caml_gc_phase == Phase_idle || (caml_gc_phase == Phase_sweep && (addr)hp < (addr)caml_gc_sweep_hp)); - Hd_hp (hp) = Make_header (wosize, tag, Caml_white); + Hd_hp (hp) = Make_header_with_profinfo (wosize, tag, Caml_white, profinfo); } - Assert (Hd_hp (hp) == Make_header (wosize, tag, caml_allocation_color (hp))); + Assert (Hd_hp (hp) + == Make_header_with_profinfo (wosize, tag, caml_allocation_color (hp), + profinfo)); caml_allocated_words += Whsize_wosize (wosize); - if (caml_allocated_words > Wsize_bsize (caml_minor_heap_size)){ - caml_urge_major_slice (); + if (caml_allocated_words > caml_minor_heap_wsz){ + CAML_INSTR_INT ("request_major/alloc_shr@", 1); + caml_request_major_slice (); } #ifdef DEBUG { @@ -447,6 +529,47 @@ return Val_hp (hp); } +CAMLexport value caml_alloc_shr_no_raise (mlsize_t wosize, tag_t tag) +{ + return caml_alloc_shr_aux(wosize, tag, 0, 0); +} + +#ifdef WITH_PROFINFO + +/* Use this to debug problems with macros... */ +#define NO_PROFINFO 0xff + +CAMLexport value caml_alloc_shr_with_profinfo (mlsize_t wosize, tag_t tag, + intnat profinfo) +{ + return caml_alloc_shr_aux(wosize, tag, 1, profinfo); +} + +CAMLexport value caml_alloc_shr_preserving_profinfo (mlsize_t wosize, + tag_t tag, header_t old_header) +{ + return caml_alloc_shr_with_profinfo (wosize, tag, Profinfo_hd(old_header)); +} + +#else +#define NO_PROFINFO 0 +#endif /* WITH_PROFINFO */ + +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) +#include "caml/spacetime.h" + +CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) +{ + return caml_alloc_shr_with_profinfo (wosize, tag, + caml_spacetime_my_profinfo (NULL, wosize)); +} +#else +CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) +{ + return caml_alloc_shr_aux (wosize, tag, 1, NO_PROFINFO); +} +#endif + /* Dependent memory is all memory blocks allocated out of the heap that depend on the GC (and finalizers) for deallocation. For the GC to take dependent memory into account when computing @@ -485,13 +608,15 @@ if (res > max) res = max; caml_extra_heap_resources += (double) res / (double) max; if (caml_extra_heap_resources > 1.0){ + CAML_INSTR_INT ("request_major/adjust_gc_speed_1@", 1); caml_extra_heap_resources = 1.0; - caml_urge_major_slice (); + caml_request_major_slice (); } if (caml_extra_heap_resources - > (double) Wsize_bsize (caml_minor_heap_size) / 2.0 - / (double) Wsize_bsize (caml_stat_heap_size)) { - caml_urge_major_slice (); + > (double) caml_minor_heap_wsz / 2.0 + / (double) caml_stat_heap_wsz) { + CAML_INSTR_INT ("request_major/adjust_gc_speed_2@", 1); + caml_request_major_slice (); } } @@ -505,13 +630,10 @@ /* PR#6084 workaround: define it as a weak symbol */ CAMLexport CAMLweakdef void caml_initialize (value *fp, value val) { - CAMLassert(Is_in_heap(fp)); + CAMLassert(Is_in_heap_or_young(fp)); *fp = val; - if (Is_block (val) && Is_young (val)) { - if (caml_ref_table.ptr >= caml_ref_table.limit){ - caml_realloc_ref_table (&caml_ref_table); - } - *caml_ref_table.ptr++ = fp; + if (!Is_young((value)fp) && Is_block (val) && Is_young (val)) { + add_to_ref_table (&caml_ref_table, fp); } } @@ -559,16 +681,12 @@ } /* Check for condition 1. */ if (Is_block(val) && Is_young(val)) { - /* Add [fp] to remembered set */ - if (caml_ref_table.ptr >= caml_ref_table.limit){ - CAMLassert (caml_ref_table.ptr == caml_ref_table.limit); - caml_realloc_ref_table (&caml_ref_table); - } - *caml_ref_table.ptr++ = fp; + add_to_ref_table (&caml_ref_table, fp); } } } +/* [sz] is a number of bytes */ CAMLexport void * caml_stat_alloc (asize_t sz) { void * result = malloc (sz); @@ -586,6 +704,7 @@ free (blk); } +/* [sz] is a number of bytes */ CAMLexport void * caml_stat_resize (void * blk, asize_t sz) { void * result = realloc (blk, sz); diff -Nru ocaml-4.01.0/byterun/memory.h ocaml-4.05.0/byterun/memory.h --- ocaml-4.01.0/byterun/memory.h 2013-06-01 07:43:45.000000000 +0000 +++ ocaml-4.05.0/byterun/memory.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,443 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ - -/* Allocation macros and functions */ - -#ifndef CAML_MEMORY_H -#define CAML_MEMORY_H - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "config.h" -/* */ -#include "gc.h" -#include "major_gc.h" -#include "minor_gc.h" -/* */ -#include "misc.h" -#include "mlvalues.h" - -#ifdef __cplusplus -extern "C" { -#endif - - -CAMLextern value caml_alloc_shr (mlsize_t, tag_t); -CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); -CAMLextern void caml_alloc_dependent_memory (mlsize_t); -CAMLextern void caml_free_dependent_memory (mlsize_t); -CAMLextern void caml_modify (value *, value); -CAMLextern void caml_initialize (value *, value); -CAMLextern value caml_check_urgent_gc (value); -CAMLextern void * caml_stat_alloc (asize_t); /* Size in bytes. */ -CAMLextern void caml_stat_free (void *); -CAMLextern void * caml_stat_resize (void *, asize_t); /* Size in bytes. */ -char *caml_alloc_for_heap (asize_t request); /* Size in bytes. */ -void caml_free_for_heap (char *mem); -int caml_add_to_heap (char *mem); -color_t caml_allocation_color (void *hp); - -/* void caml_shrink_heap (char *); Only used in compact.c */ - -/* */ - -#define Not_in_heap 0 -#define In_heap 1 -#define In_young 2 -#define In_static_data 4 -#define In_code_area 8 - -#ifdef ARCH_SIXTYFOUR - -/* 64 bits: Represent page table as a sparse hash table */ -int caml_page_table_lookup(void * addr); -#define Classify_addr(a) (caml_page_table_lookup((void *)(a))) - -#else - -/* 32 bits: Represent page table as a 2-level array */ -#define Pagetable2_log 11 -#define Pagetable2_size (1 << Pagetable2_log) -#define Pagetable1_log (Page_log + Pagetable2_log) -#define Pagetable1_size (1 << (32 - Pagetable1_log)) -CAMLextern unsigned char * caml_page_table[Pagetable1_size]; - -#define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log) -#define Pagetable_index2(a) \ - ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1)) -#define Classify_addr(a) \ - caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)] - -#endif - -#define Is_in_value_area(a) \ - (Classify_addr(a) & (In_heap | In_young | In_static_data)) -#define Is_in_heap(a) (Classify_addr(a) & In_heap) -#define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young)) - -int caml_page_table_add(int kind, void * start, void * end); -int caml_page_table_remove(int kind, void * start, void * end); -int caml_page_table_initialize(mlsize_t bytesize); - -#ifdef DEBUG -#define DEBUG_clear(result, wosize) do{ \ - uintnat caml__DEBUG_i; \ - for (caml__DEBUG_i = 0; caml__DEBUG_i < (wosize); ++ caml__DEBUG_i){ \ - Field ((result), caml__DEBUG_i) = Debug_uninit_minor; \ - } \ -}while(0) -#else -#define DEBUG_clear(result, wosize) -#endif - -#define Alloc_small(result, wosize, tag) do{ CAMLassert ((wosize) >= 1); \ - CAMLassert ((tag_t) (tag) < 256); \ - CAMLassert ((wosize) <= Max_young_wosize); \ - caml_young_ptr -= Bhsize_wosize (wosize); \ - if (caml_young_ptr < caml_young_start){ \ - caml_young_ptr += Bhsize_wosize (wosize); \ - Setup_for_gc; \ - caml_minor_collection (); \ - Restore_after_gc; \ - caml_young_ptr -= Bhsize_wosize (wosize); \ - } \ - Hd_hp (caml_young_ptr) = Make_header ((wosize), (tag), Caml_black); \ - (result) = Val_hp (caml_young_ptr); \ - DEBUG_clear ((result), (wosize)); \ -}while(0) - -/* Deprecated alias for [caml_modify] */ - -#define Modify(fp,val) caml_modify((fp), (val)) - -/* */ - -struct caml__roots_block { - struct caml__roots_block *next; - intnat ntables; - intnat nitems; - value *tables [5]; -}; - -CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ - -/* The following macros are used to declare C local variables and - function parameters of type [value]. - - The function body must start with one of the [CAMLparam] macros. - If the function has no parameter of type [value], use [CAMLparam0]. - If the function has 1 to 5 [value] parameters, use the corresponding - [CAMLparam] with the parameters as arguments. - If the function has more than 5 [value] parameters, use [CAMLparam5] - for the first 5 parameters, and one or more calls to the [CAMLxparam] - macros for the others. - If the function takes an array of [value]s as argument, use - [CAMLparamN] to declare it (or [CAMLxparamN] if you already have a - call to [CAMLparam] for some other arguments). - - If you need local variables of type [value], declare them with one - or more calls to the [CAMLlocal] macros at the beginning of the - function, after the call to CAMLparam. Use [CAMLlocalN] (at the - beginning of the function) to declare an array of [value]s. - - Your function may raise an exception or return a [value] with the - [CAMLreturn] macro. Its argument is simply the [value] returned by - your function. Do NOT directly return a [value] with the [return] - keyword. If your function returns void, use [CAMLreturn0]. - - All the identifiers beginning with "caml__" are reserved by OCaml. - Do not use them for anything (local or global variables, struct or - union tags, macros, etc.) -*/ - -#define CAMLparam0() \ - struct caml__roots_block *caml__frame = caml_local_roots - -#define CAMLparam1(x) \ - CAMLparam0 (); \ - CAMLxparam1 (x) - -#define CAMLparam2(x, y) \ - CAMLparam0 (); \ - CAMLxparam2 (x, y) - -#define CAMLparam3(x, y, z) \ - CAMLparam0 (); \ - CAMLxparam3 (x, y, z) - -#define CAMLparam4(x, y, z, t) \ - CAMLparam0 (); \ - CAMLxparam4 (x, y, z, t) - -#define CAMLparam5(x, y, z, t, u) \ - CAMLparam0 (); \ - CAMLxparam5 (x, y, z, t, u) - -#define CAMLparamN(x, size) \ - CAMLparam0 (); \ - CAMLxparamN (x, (size)) - - -#if defined(__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ > 7)) - #define CAMLunused __attribute__ ((unused)) -#else - #define CAMLunused -#endif - -#define CAMLxparam1(x) \ - struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ - (caml__roots_##x.next = caml_local_roots), \ - (caml_local_roots = &caml__roots_##x), \ - (caml__roots_##x.nitems = 1), \ - (caml__roots_##x.ntables = 1), \ - (caml__roots_##x.tables [0] = &x), \ - 0) - -#define CAMLxparam2(x, y) \ - struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ - (caml__roots_##x.next = caml_local_roots), \ - (caml_local_roots = &caml__roots_##x), \ - (caml__roots_##x.nitems = 1), \ - (caml__roots_##x.ntables = 2), \ - (caml__roots_##x.tables [0] = &x), \ - (caml__roots_##x.tables [1] = &y), \ - 0) - -#define CAMLxparam3(x, y, z) \ - struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ - (caml__roots_##x.next = caml_local_roots), \ - (caml_local_roots = &caml__roots_##x), \ - (caml__roots_##x.nitems = 1), \ - (caml__roots_##x.ntables = 3), \ - (caml__roots_##x.tables [0] = &x), \ - (caml__roots_##x.tables [1] = &y), \ - (caml__roots_##x.tables [2] = &z), \ - 0) - -#define CAMLxparam4(x, y, z, t) \ - struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ - (caml__roots_##x.next = caml_local_roots), \ - (caml_local_roots = &caml__roots_##x), \ - (caml__roots_##x.nitems = 1), \ - (caml__roots_##x.ntables = 4), \ - (caml__roots_##x.tables [0] = &x), \ - (caml__roots_##x.tables [1] = &y), \ - (caml__roots_##x.tables [2] = &z), \ - (caml__roots_##x.tables [3] = &t), \ - 0) - -#define CAMLxparam5(x, y, z, t, u) \ - struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ - (caml__roots_##x.next = caml_local_roots), \ - (caml_local_roots = &caml__roots_##x), \ - (caml__roots_##x.nitems = 1), \ - (caml__roots_##x.ntables = 5), \ - (caml__roots_##x.tables [0] = &x), \ - (caml__roots_##x.tables [1] = &y), \ - (caml__roots_##x.tables [2] = &z), \ - (caml__roots_##x.tables [3] = &t), \ - (caml__roots_##x.tables [4] = &u), \ - 0) - -#define CAMLxparamN(x, size) \ - struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ - (caml__roots_##x.next = caml_local_roots), \ - (caml_local_roots = &caml__roots_##x), \ - (caml__roots_##x.nitems = (size)), \ - (caml__roots_##x.ntables = 1), \ - (caml__roots_##x.tables[0] = &(x[0])), \ - 0) - -#define CAMLlocal1(x) \ - value x = 0; \ - CAMLxparam1 (x) - -#define CAMLlocal2(x, y) \ - value x = 0, y = 0; \ - CAMLxparam2 (x, y) - -#define CAMLlocal3(x, y, z) \ - value x = 0, y = 0, z = 0; \ - CAMLxparam3 (x, y, z) - -#define CAMLlocal4(x, y, z, t) \ - value x = 0, y = 0, z = 0, t = 0; \ - CAMLxparam4 (x, y, z, t) - -#define CAMLlocal5(x, y, z, t, u) \ - value x = 0, y = 0, z = 0, t = 0, u = 0; \ - CAMLxparam5 (x, y, z, t, u) - -#define CAMLlocalN(x, size) \ - value x [(size)] = { 0, /* 0, 0, ... */ }; \ - CAMLxparamN (x, (size)) - - -#define CAMLreturn0 do{ \ - caml_local_roots = caml__frame; \ - return; \ -}while (0) - -#define CAMLreturnT(type, result) do{ \ - type caml__temp_result = (result); \ - caml_local_roots = caml__frame; \ - return (caml__temp_result); \ -}while(0) - -#define CAMLreturn(result) CAMLreturnT(value, result) - -#define CAMLnoreturn ((void) caml__frame) - - -/* convenience macro */ -#define Store_field(block, offset, val) do{ \ - mlsize_t caml__temp_offset = (offset); \ - value caml__temp_val = (val); \ - caml_modify (&Field ((block), caml__temp_offset), caml__temp_val); \ -}while(0) - -/* - NOTE: [Begin_roots] and [End_roots] are superseded by [CAMLparam]*, - [CAMLxparam]*, [CAMLlocal]*, [CAMLreturn]. - - [Begin_roots] and [End_roots] are used for C variables that are GC roots. - It must contain all values in C local variables and function parameters - at the time the minor GC is called. - Usage: - After initialising your local variables to legal OCaml values, but before - calling allocation functions, insert [Begin_roots_n(v1, ... vn)], where - v1 ... vn are your variables of type [value] that you want to be updated - across allocations. - At the end, insert [End_roots()]. - - Note that [Begin_roots] opens a new block, and [End_roots] closes it. - Thus they must occur in matching pairs at the same brace nesting level. - - You can use [Val_unit] as a dummy initial value for your variables. -*/ - -#define Begin_root Begin_roots1 - -#define Begin_roots1(r0) { \ - struct caml__roots_block caml__roots_block; \ - caml__roots_block.next = caml_local_roots; \ - caml_local_roots = &caml__roots_block; \ - caml__roots_block.nitems = 1; \ - caml__roots_block.ntables = 1; \ - caml__roots_block.tables[0] = &(r0); - -#define Begin_roots2(r0, r1) { \ - struct caml__roots_block caml__roots_block; \ - caml__roots_block.next = caml_local_roots; \ - caml_local_roots = &caml__roots_block; \ - caml__roots_block.nitems = 1; \ - caml__roots_block.ntables = 2; \ - caml__roots_block.tables[0] = &(r0); \ - caml__roots_block.tables[1] = &(r1); - -#define Begin_roots3(r0, r1, r2) { \ - struct caml__roots_block caml__roots_block; \ - caml__roots_block.next = caml_local_roots; \ - caml_local_roots = &caml__roots_block; \ - caml__roots_block.nitems = 1; \ - caml__roots_block.ntables = 3; \ - caml__roots_block.tables[0] = &(r0); \ - caml__roots_block.tables[1] = &(r1); \ - caml__roots_block.tables[2] = &(r2); - -#define Begin_roots4(r0, r1, r2, r3) { \ - struct caml__roots_block caml__roots_block; \ - caml__roots_block.next = caml_local_roots; \ - caml_local_roots = &caml__roots_block; \ - caml__roots_block.nitems = 1; \ - caml__roots_block.ntables = 4; \ - caml__roots_block.tables[0] = &(r0); \ - caml__roots_block.tables[1] = &(r1); \ - caml__roots_block.tables[2] = &(r2); \ - caml__roots_block.tables[3] = &(r3); - -#define Begin_roots5(r0, r1, r2, r3, r4) { \ - struct caml__roots_block caml__roots_block; \ - caml__roots_block.next = caml_local_roots; \ - caml_local_roots = &caml__roots_block; \ - caml__roots_block.nitems = 1; \ - caml__roots_block.ntables = 5; \ - caml__roots_block.tables[0] = &(r0); \ - caml__roots_block.tables[1] = &(r1); \ - caml__roots_block.tables[2] = &(r2); \ - caml__roots_block.tables[3] = &(r3); \ - caml__roots_block.tables[4] = &(r4); - -#define Begin_roots_block(table, size) { \ - struct caml__roots_block caml__roots_block; \ - caml__roots_block.next = caml_local_roots; \ - caml_local_roots = &caml__roots_block; \ - caml__roots_block.nitems = (size); \ - caml__roots_block.ntables = 1; \ - caml__roots_block.tables[0] = (table); - -#define End_roots() caml_local_roots = caml__roots_block.next; } - - -/* [caml_register_global_root] registers a global C variable as a memory root - for the duration of the program, or until [caml_remove_global_root] is - called. */ - -CAMLextern void caml_register_global_root (value *); - -/* [caml_remove_global_root] removes a memory root registered on a global C - variable with [caml_register_global_root]. */ - -CAMLextern void caml_remove_global_root (value *); - -/* [caml_register_generational_global_root] registers a global C - variable as a memory root for the duration of the program, or until - [caml_remove_generational_global_root] is called. - The program guarantees that the value contained in this variable - will not be assigned directly. If the program needs to change - the value of this variable, it must do so by calling - [caml_modify_generational_global_root]. The [value *] pointer - passed to [caml_register_generational_global_root] must contain - a valid OCaml value before the call. - In return for these constraints, scanning of memory roots during - minor collection is made more efficient. */ - -CAMLextern void caml_register_generational_global_root (value *); - -/* [caml_remove_generational_global_root] removes a memory root - registered on a global C variable with - [caml_register_generational_global_root]. */ - -CAMLextern void caml_remove_generational_global_root (value *); - -/* [caml_modify_generational_global_root(r, newval)] - modifies the value contained in [r], storing [newval] inside. - In other words, the assignment [*r = newval] is performed, - but in a way that is compatible with the optimized scanning of - generational global roots. [r] must be a global memory root - previously registered with [caml_register_generational_global_root]. */ - -CAMLextern void caml_modify_generational_global_root(value *r, value newval); - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_MEMORY_H */ diff -Nru ocaml-4.01.0/byterun/meta.c ocaml-4.05.0/byterun/meta.c --- ocaml-4.01.0/byterun/meta.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/meta.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,32 +1,36 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Primitives for the toplevel */ #include -#include "alloc.h" -#include "config.h" -#include "fail.h" -#include "fix_code.h" -#include "interp.h" -#include "intext.h" -#include "major_gc.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "prims.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/interp.h" +#include "caml/intext.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/prims.h" +#include "caml/stacks.h" #ifndef NATIVE_CODE @@ -47,7 +51,14 @@ CAMLprim value caml_reify_bytecode(value prog, value len) { + struct code_fragment * cf = caml_stat_alloc(sizeof(struct code_fragment)); value clos; + + cf->code_start = (char *) prog; + cf->code_end = (char *) prog + Long_val(len); + cf->digest_computed = 0; + caml_ext_table_add(&caml_code_fragments_table, cf); + #ifdef ARCH_BIG_ENDIAN caml_fixup_endianness((code_t) prog, (asize_t) Long_val(len)); #endif @@ -60,6 +71,38 @@ return clos; } +/* signal to the interpreter machinery that a bytecode is no more + needed (before freeing it) - this might be useful for a JIT + implementation */ + +CAMLprim value caml_static_release_bytecode(value prog, value len) +{ + struct code_fragment * cf = NULL, * cfi; + int i; + for (i = 0; i < caml_code_fragments_table.size; i++) { + cfi = (struct code_fragment *) caml_code_fragments_table.contents[i]; + if (cfi->code_start == (char *) prog && + cfi->code_end == (char *) prog + Long_val(len)) { + cf = cfi; + break; + } + } + + if (!cf) { + /* [cf] Not matched with a caml_reify_bytecode call; impossible. */ + Assert (0); + } else { + caml_ext_table_remove(&caml_code_fragments_table, cf); + } + +#ifndef NATIVE_CODE + caml_release_bytecode((code_t) prog, (asize_t) Long_val(len)); +#else + caml_failwith("Meta.static_release_bytecode impossible with native code"); +#endif + return Val_unit; +} + CAMLprim value caml_register_code_fragment(value prog, value len, value digest) { struct code_fragment * cf = caml_stat_alloc(sizeof(struct code_fragment)); @@ -171,6 +214,12 @@ return Val_unit; /* not reached */ } +value caml_static_release_bytecode(value prog, value len) +{ + caml_invalid_argument("Meta.static_release_bytecode"); + return Val_unit; /* not reached */ +} + value * caml_stack_low; value * caml_stack_high; value * caml_stack_threshold; diff -Nru ocaml-4.01.0/byterun/minor_gc.c ocaml-4.05.0/byterun/minor_gc.c --- ocaml-4.01.0/byterun/minor_gc.c 2013-07-17 11:50:53.000000000 +0000 +++ ocaml-4.05.0/byterun/minor_gc.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,63 +1,120 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS #include -#include "config.h" -#include "fail.h" -#include "finalise.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "signals.h" -#include "weak.h" +#include "caml/custom.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/finalise.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/weak.h" + +/* Pointers into the minor heap. + [caml_young_base] + The [malloc] block that contains the heap. + [caml_young_start] ... [caml_young_end] + The whole range of the minor heap: all young blocks are inside + this interval. + [caml_young_alloc_start]...[caml_young_alloc_end] + The allocation arena: newly-allocated blocks are carved from + this interval, starting at [caml_young_alloc_end]. + [caml_young_alloc_mid] is the mid-point of this interval. + [caml_young_ptr], [caml_young_trigger], [caml_young_limit] + These pointers are all inside the allocation arena. + - [caml_young_ptr] is where the next allocation will take place. + - [caml_young_trigger] is how far we can allocate before triggering + [caml_gc_dispatch]. Currently, it is either [caml_young_alloc_start] + or the mid-point of the allocation arena. + - [caml_young_limit] is the pointer that is compared to + [caml_young_ptr] for allocation. It is either + [caml_young_alloc_end] if a signal is pending and we are in + native code, or [caml_young_trigger]. +*/ + +struct generic_table CAML_TABLE_STRUCT(char); -asize_t caml_minor_heap_size; +asize_t caml_minor_heap_wsz; static void *caml_young_base = NULL; -CAMLexport char *caml_young_start = NULL, *caml_young_end = NULL; -CAMLexport char *caml_young_ptr = NULL, *caml_young_limit = NULL; +CAMLexport value *caml_young_start = NULL, *caml_young_end = NULL; +CAMLexport value *caml_young_alloc_start = NULL, + *caml_young_alloc_mid = NULL, + *caml_young_alloc_end = NULL; +CAMLexport value *caml_young_ptr = NULL, *caml_young_limit = NULL; +CAMLexport value *caml_young_trigger = NULL; CAMLexport struct caml_ref_table - caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}, - caml_weak_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}; + caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}; -int caml_in_minor_collection = 0; +CAMLexport struct caml_ephe_ref_table + caml_ephe_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}; -#ifdef DEBUG -static unsigned long minor_gc_counter = 0; -#endif +CAMLexport struct caml_custom_table + caml_custom_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}; +/* Table of custom blocks in the minor heap that contain finalizers + or GC speed parameters. */ -void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv) +int caml_in_minor_collection = 0; + +/* [sz] and [rsv] are numbers of entries */ +static void alloc_generic_table (struct generic_table *tbl, asize_t sz, + asize_t rsv, asize_t element_size) { - value **new_table; + void *new_table; tbl->size = sz; tbl->reserve = rsv; - new_table = (value **) caml_stat_alloc ((tbl->size + tbl->reserve) - * sizeof (value *)); + new_table = (void *) malloc((tbl->size + tbl->reserve) * element_size); + if (new_table == NULL) caml_fatal_error ("Fatal error: not enough memory\n"); if (tbl->base != NULL) caml_stat_free (tbl->base); tbl->base = new_table; tbl->ptr = tbl->base; - tbl->threshold = tbl->base + tbl->size; + tbl->threshold = tbl->base + tbl->size * element_size; tbl->limit = tbl->threshold; - tbl->end = tbl->base + tbl->size + tbl->reserve; + tbl->end = tbl->base + (tbl->size + tbl->reserve) * element_size; +} + +void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv) +{ + alloc_generic_table ((struct generic_table *) tbl, sz, rsv, sizeof (value *)); +} + +void caml_alloc_ephe_table (struct caml_ephe_ref_table *tbl, asize_t sz, + asize_t rsv) +{ + alloc_generic_table ((struct generic_table *) tbl, sz, rsv, + sizeof (struct caml_ephe_ref_elt)); +} + +void caml_alloc_custom_table (struct caml_custom_table *tbl, asize_t sz, + asize_t rsv) +{ + alloc_generic_table ((struct generic_table *) tbl, sz, rsv, + sizeof (struct caml_custom_elt)); } -static void reset_table (struct caml_ref_table *tbl) +static void reset_table (struct generic_table *tbl) { tbl->size = 0; tbl->reserve = 0; @@ -65,26 +122,31 @@ tbl->base = tbl->ptr = tbl->threshold = tbl->limit = tbl->end = NULL; } -static void clear_table (struct caml_ref_table *tbl) +static void clear_table (struct generic_table *tbl) { tbl->ptr = tbl->base; tbl->limit = tbl->threshold; } -/* size in bytes */ -void caml_set_minor_heap_size (asize_t size) +void caml_set_minor_heap_size (asize_t bsz) { char *new_heap; void *new_heap_base; - Assert (size >= Bsize_wsize(Minor_heap_min)); - Assert (size <= Bsize_wsize(Minor_heap_max)); - Assert (size % sizeof (value) == 0); - if (caml_young_ptr != caml_young_end) caml_minor_collection (); - Assert (caml_young_ptr == caml_young_end); - new_heap = caml_aligned_malloc(size, 0, &new_heap_base); + Assert (bsz >= Bsize_wsize(Minor_heap_min)); + Assert (bsz <= Bsize_wsize(Minor_heap_max)); + Assert (bsz % sizeof (value) == 0); + if (caml_young_ptr != caml_young_alloc_end){ + CAML_INSTR_INT ("force_minor/set_minor_heap_size@", 1); + caml_requested_minor_gc = 0; + caml_young_trigger = caml_young_alloc_mid; + caml_young_limit = caml_young_trigger; + caml_empty_minor_heap (); + } + CAMLassert (caml_young_ptr == caml_young_alloc_end); + new_heap = caml_aligned_malloc(bsz, 0, &new_heap_base); if (new_heap == NULL) caml_raise_out_of_memory(); - if (caml_page_table_add(In_young, new_heap, new_heap + size) != 0) + if (caml_page_table_add(In_young, new_heap, new_heap + bsz) != 0) caml_raise_out_of_memory(); if (caml_young_start != NULL){ @@ -92,14 +154,19 @@ free (caml_young_base); } caml_young_base = new_heap_base; - caml_young_start = new_heap; - caml_young_end = new_heap + size; - caml_young_limit = caml_young_start; - caml_young_ptr = caml_young_end; - caml_minor_heap_size = size; - - reset_table (&caml_ref_table); - reset_table (&caml_weak_ref_table); + caml_young_start = (value *) new_heap; + caml_young_end = (value *) (new_heap + bsz); + caml_young_alloc_start = caml_young_start; + caml_young_alloc_mid = caml_young_alloc_start + Wsize_bsize (bsz) / 2; + caml_young_alloc_end = caml_young_end; + caml_young_trigger = caml_young_alloc_start; + caml_young_limit = caml_young_trigger; + caml_young_ptr = caml_young_alloc_end; + caml_minor_heap_wsz = Wsize_bsize (bsz); + + reset_table ((struct generic_table *) &caml_ref_table); + reset_table ((struct generic_table *) &caml_ephe_ref_table); + reset_table ((struct generic_table *) &caml_custom_table); } static value oldify_todo_list = 0; @@ -116,7 +183,7 @@ tail_call: if (Is_block (v) && Is_young (v)){ - Assert (Hp_val (v) >= caml_young_ptr); + Assert ((value *) Hp_val (v) >= caml_young_ptr); hd = Hd_val (v); if (hd == 0){ /* If already forwarded */ *p = Field (v, 0); /* then forward pointer is first field. */ @@ -126,7 +193,7 @@ value field0; sz = Wosize_hd (hd); - result = caml_alloc_shr (sz, tag); + result = caml_alloc_shr_preserving_profinfo (sz, tag, hd); *p = result; field0 = Field (v, 0); Hd_val (v) = 0; /* Set forward flag */ @@ -143,7 +210,7 @@ } }else if (tag >= No_scan_tag){ sz = Wosize_hd (hd); - result = caml_alloc_shr (sz, tag); + result = caml_alloc_shr_preserving_profinfo (sz, tag, hd); for (i = 0; i < sz; i++) Field (result, i) = Field (v, i); Hd_val (v) = 0; /* Set forward flag */ Field (v, 0) = result; /* and forward pointer. */ @@ -172,7 +239,7 @@ if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){ /* Do not short-circuit the pointer. Copy as a normal block. */ Assert (Wosize_hd (hd) == 1); - result = caml_alloc_shr (1, Forward_tag); + result = caml_alloc_shr_preserving_profinfo (1, Forward_tag, hd); *p = result; Hd_val (v) = 0; /* Set (GC) forward flag */ Field (v, 0) = result; /* and forward pointer. */ @@ -190,6 +257,21 @@ } } +/* Test if the ephemeron is alive, everything outside minor heap is alive */ +static inline int ephe_check_alive_data(struct caml_ephe_ref_elt *re){ + mlsize_t i; + value child; + for (i = CAML_EPHE_FIRST_KEY; i < Wosize_val(re->ephe); i++){ + child = Field (re->ephe, i); + if(child != caml_ephe_none + && Is_block (child) && Is_young (child) + && Hd_val (child) != 0){ /* Value not copied to major heap */ + return 0; + } + } + return 1; +} + /* Finish the work that was put off by [caml_oldify_one]. Note that [caml_oldify_one] itself is called by oldify_mopup, so we have to be careful to remove the first entry from the list before @@ -198,6 +280,8 @@ { value v, new_v, f; mlsize_t i; + struct caml_ephe_ref_elt *re; + int redo = 0; while (oldify_todo_list != 0){ v = oldify_todo_list; /* Get the head. */ @@ -218,6 +302,28 @@ } } } + + /* Oldify the data in the minor heap of alive ephemeron + During minor collection keys outside the minor heap are considered alive */ + for (re = caml_ephe_ref_table.base; + re < caml_ephe_ref_table.ptr; re++){ + /* look only at ephemeron with data in the minor heap */ + if (re->offset == 1){ + value *data = &Field(re->ephe,1); + if (*data != caml_ephe_none && Is_block (*data) && Is_young (*data)){ + if (Hd_val (*data) == 0){ /* Value copied to major heap */ + *data = Field (*data, 0); + } else { + if (ephe_check_alive_data(re)){ + caml_oldify_one(*data,data); + redo = 1; /* oldify_todo_list can still be 0 */ + } + } + } + } + } + + if (redo) caml_oldify_mopup (); } /* Make sure the minor heap is empty by performing a minor collection @@ -226,100 +332,219 @@ void caml_empty_minor_heap (void) { value **r; - - if (caml_young_ptr != caml_young_end){ + struct caml_custom_elt *elt; + uintnat prev_alloc_words; + struct caml_ephe_ref_elt *re; + + if (caml_young_ptr != caml_young_alloc_end){ + if (caml_minor_gc_begin_hook != NULL) (*caml_minor_gc_begin_hook) (); + CAML_INSTR_SETUP (tmr, "minor"); + prev_alloc_words = caml_allocated_words; caml_in_minor_collection = 1; caml_gc_message (0x02, "<", 0); caml_oldify_local_roots(); + CAML_INSTR_TIME (tmr, "minor/local_roots"); for (r = caml_ref_table.base; r < caml_ref_table.ptr; r++){ caml_oldify_one (**r, *r); } + CAML_INSTR_TIME (tmr, "minor/ref_table"); caml_oldify_mopup (); - for (r = caml_weak_ref_table.base; r < caml_weak_ref_table.ptr; r++){ - if (Is_block (**r) && Is_young (**r)){ - if (Hd_val (**r) == 0){ - **r = Field (**r, 0); - }else{ - **r = caml_weak_none; + CAML_INSTR_TIME (tmr, "minor/copy"); + /* Update the ephemerons */ + for (re = caml_ephe_ref_table.base; + re < caml_ephe_ref_table.ptr; re++){ + if(re->offset < Wosize_val(re->ephe)){ + /* If it is not the case, the ephemeron has been truncated */ + value *key = &Field(re->ephe,re->offset); + if (*key != caml_ephe_none && Is_block (*key) && Is_young (*key)){ + if (Hd_val (*key) == 0){ /* Value copied to major heap */ + *key = Field (*key, 0); + }else{ /* Value not copied so it's dead */ + Assert(!ephe_check_alive_data(re)); + *key = caml_ephe_none; + Field(re->ephe,1) = caml_ephe_none; + } } } } - if (caml_young_ptr < caml_young_start) caml_young_ptr = caml_young_start; - caml_stat_minor_words += Wsize_bsize (caml_young_end - caml_young_ptr); - caml_young_ptr = caml_young_end; - caml_young_limit = caml_young_start; - clear_table (&caml_ref_table); - clear_table (&caml_weak_ref_table); + /* Update the OCaml finalise_last values */ + caml_final_update_minor_roots(); + /* Run custom block finalisation of dead minor values */ + for (elt = caml_custom_table.base; elt < caml_custom_table.ptr; elt++){ + value v = elt->block; + if (Hd_val (v) == 0){ + /* Block was copied to the major heap: adjust GC speed numbers. */ + caml_adjust_gc_speed(elt->mem, elt->max); + }else{ + /* Block will be freed: call finalization function, if any. */ + void (*final_fun)(value) = Custom_ops_val(v)->finalize; + if (final_fun != NULL) final_fun(v); + } + } + CAML_INSTR_TIME (tmr, "minor/update_weak"); + caml_stat_minor_words += caml_young_alloc_end - caml_young_ptr; + caml_gc_clock += (double) (caml_young_alloc_end - caml_young_ptr) + / caml_minor_heap_wsz; + caml_young_ptr = caml_young_alloc_end; + clear_table ((struct generic_table *) &caml_ref_table); + clear_table ((struct generic_table *) &caml_ephe_ref_table); + clear_table ((struct generic_table *) &caml_custom_table); caml_gc_message (0x02, ">", 0); caml_in_minor_collection = 0; + caml_final_empty_young (); + CAML_INSTR_TIME (tmr, "minor/finalized"); + caml_stat_promoted_words += caml_allocated_words - prev_alloc_words; + CAML_INSTR_INT ("minor/promoted#", caml_allocated_words - prev_alloc_words); + ++ caml_stat_minor_collections; + if (caml_minor_gc_end_hook != NULL) (*caml_minor_gc_end_hook) (); + }else{ + /* The minor heap is empty nothing to do. */ + caml_final_empty_young (); } - caml_final_empty_young (); #ifdef DEBUG { value *p; - for (p = (value *) caml_young_start; p < (value *) caml_young_end; ++p){ + for (p = caml_young_alloc_start; p < caml_young_alloc_end; ++p){ *p = Debug_free_minor; } - ++ minor_gc_counter; } #endif } -/* Do a minor collection and a slice of major collection, call finalisation +#ifdef CAML_INSTR +extern uintnat caml_instr_alloc_jump; +#endif + +/* Do a minor collection or a slice of major collection, call finalisation functions, etc. - Leave the minor heap empty. + Leave enough room in the minor heap to allocate at least one object. */ -CAMLexport void caml_minor_collection (void) +CAMLexport void caml_gc_dispatch (void) { - intnat prev_alloc_words = caml_allocated_words; - - caml_empty_minor_heap (); - - caml_stat_promoted_words += caml_allocated_words - prev_alloc_words; - ++ caml_stat_minor_collections; - caml_major_collection_slice (0); - caml_force_major_slice = 0; + value *trigger = caml_young_trigger; /* save old value of trigger */ +#ifdef CAML_INSTR + CAML_INSTR_SETUP(tmr, "dispatch"); + CAML_INSTR_TIME (tmr, "overhead"); + CAML_INSTR_INT ("alloc/jump#", caml_instr_alloc_jump); + caml_instr_alloc_jump = 0; +#endif - caml_final_do_calls (); + if (trigger == caml_young_alloc_start || caml_requested_minor_gc){ + /* The minor heap is full, we must do a minor collection. */ + /* reset the pointers first because the end hooks might allocate */ + caml_requested_minor_gc = 0; + caml_young_trigger = caml_young_alloc_mid; + caml_young_limit = caml_young_trigger; + caml_empty_minor_heap (); + /* The minor heap is empty, we can start a major collection. */ + if (caml_gc_phase == Phase_idle) caml_major_collection_slice (-1); + CAML_INSTR_TIME (tmr, "dispatch/minor"); + + caml_final_do_calls (); + CAML_INSTR_TIME (tmr, "dispatch/finalizers"); + + while (caml_young_ptr - caml_young_alloc_start < Max_young_whsize){ + /* The finalizers or the hooks have filled up the minor heap, we must + repeat the minor collection. */ + caml_requested_minor_gc = 0; + caml_young_trigger = caml_young_alloc_mid; + caml_young_limit = caml_young_trigger; + caml_empty_minor_heap (); + /* The minor heap is empty, we can start a major collection. */ + if (caml_gc_phase == Phase_idle) caml_major_collection_slice (-1); + CAML_INSTR_TIME (tmr, "dispatch/finalizers_minor"); + } + } + if (trigger != caml_young_alloc_start || caml_requested_major_slice){ + /* The minor heap is half-full, do a major GC slice. */ + caml_requested_major_slice = 0; + caml_young_trigger = caml_young_alloc_start; + caml_young_limit = caml_young_trigger; + caml_major_collection_slice (-1); + CAML_INSTR_TIME (tmr, "dispatch/major"); + } +} - caml_empty_minor_heap (); +/* For backward compatibility with Lablgtk: do a minor collection to + ensure that the minor heap is empty. +*/ +CAMLexport void caml_minor_collection (void) +{ + caml_requested_minor_gc = 1; + caml_gc_dispatch (); } CAMLexport value caml_check_urgent_gc (value extra_root) { CAMLparam1 (extra_root); - if (caml_force_major_slice) caml_minor_collection(); + if (caml_requested_major_slice || caml_requested_minor_gc){ + CAML_INSTR_INT ("force_minor/check_urgent_gc@", 1); + caml_gc_dispatch(); + } CAMLreturn (extra_root); } -void caml_realloc_ref_table (struct caml_ref_table *tbl) -{ Assert (tbl->ptr == tbl->limit); +static void realloc_generic_table +(struct generic_table *tbl, asize_t element_size, + char * msg_intr_int, char *msg_threshold, char *msg_growing, char *msg_error) +{ + Assert (tbl->ptr == tbl->limit); Assert (tbl->limit <= tbl->end); Assert (tbl->limit >= tbl->threshold); if (tbl->base == NULL){ - caml_alloc_table (tbl, caml_minor_heap_size / sizeof (value) / 8, 256); + alloc_generic_table (tbl, caml_minor_heap_wsz / 8, 256, + element_size); }else if (tbl->limit == tbl->threshold){ - caml_gc_message (0x08, "ref_table threshold crossed\n", 0); + CAML_INSTR_INT (msg_intr_int, 1); + caml_gc_message (0x08, msg_threshold, 0); tbl->limit = tbl->end; - caml_urge_major_slice (); - }else{ /* This will almost never happen with the bytecode interpreter. */ + caml_request_minor_gc (); + }else{ asize_t sz; asize_t cur_ptr = tbl->ptr - tbl->base; - Assert (caml_force_major_slice); + CAMLassert (caml_requested_minor_gc); tbl->size *= 2; - sz = (tbl->size + tbl->reserve) * sizeof (value *); - caml_gc_message (0x08, "Growing ref_table to %" - ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", - (intnat) sz/1024); - tbl->base = (value **) realloc ((char *) tbl->base, sz); + sz = (tbl->size + tbl->reserve) * element_size; + caml_gc_message (0x08, msg_growing, (intnat) sz/1024); + tbl->base = (void *) realloc ((char *) tbl->base, sz); if (tbl->base == NULL){ - caml_fatal_error ("Fatal error: ref_table overflow\n"); + caml_fatal_error (msg_error); } - tbl->end = tbl->base + tbl->size + tbl->reserve; - tbl->threshold = tbl->base + tbl->size; + tbl->end = tbl->base + (tbl->size + tbl->reserve) * element_size; + tbl->threshold = tbl->base + tbl->size * element_size; tbl->ptr = tbl->base + cur_ptr; tbl->limit = tbl->end; } } + +void caml_realloc_ref_table (struct caml_ref_table *tbl) +{ + realloc_generic_table + ((struct generic_table *) tbl, sizeof (value *), + "request_minor/realloc_ref_table@", + "ref_table threshold crossed\n", + "Growing ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", + "Fatal error: ref_table overflow\n"); +} + +void caml_realloc_ephe_ref_table (struct caml_ephe_ref_table *tbl) +{ + realloc_generic_table + ((struct generic_table *) tbl, sizeof (struct caml_ephe_ref_elt), + "request_minor/realloc_ephe_ref_table@", + "ephe_ref_table threshold crossed\n", + "Growing ephe_ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", + "Fatal error: ephe_ref_table overflow\n"); +} + +void caml_realloc_custom_table (struct caml_custom_table *tbl) +{ + realloc_generic_table + ((struct generic_table *) tbl, sizeof (struct caml_custom_elt), + "request_minor/realloc_custom_table@", + "custom_table threshold crossed\n", + "Growing custom_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", + "Fatal error: custom_table overflow\n"); +} diff -Nru ocaml-4.01.0/byterun/minor_gc.h ocaml-4.05.0/byterun/minor_gc.h --- ocaml-4.01.0/byterun/minor_gc.h 2013-07-17 11:50:53.000000000 +0000 +++ ocaml-4.05.0/byterun/minor_gc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_MINOR_GC_H -#define CAML_MINOR_GC_H - - -#include "misc.h" - -CAMLextern char *caml_young_start, *caml_young_ptr; -CAMLextern char *caml_young_end, *caml_young_limit; -extern asize_t caml_minor_heap_size; -extern int caml_in_minor_collection; - -struct caml_ref_table { - value **base; - value **end; - value **threshold; - value **ptr; - value **limit; - asize_t size; - asize_t reserve; -}; -CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table; - -#define Is_young(val) \ - (Assert (Is_block (val)), \ - (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start) - -extern void caml_set_minor_heap_size (asize_t); /* size in bytes */ -extern void caml_empty_minor_heap (void); -CAMLextern void caml_minor_collection (void); -CAMLextern void garbage_collection (void); /* def in asmrun/signals.c */ -extern void caml_realloc_ref_table (struct caml_ref_table *); -extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t); -extern void caml_oldify_one (value, value *); -extern void caml_oldify_mopup (void); - -#define Oldify(p) do{ \ - value __oldify__v__ = *p; \ - if (Is_block (__oldify__v__) && Is_young (__oldify__v__)){ \ - caml_oldify_one (__oldify__v__, (p)); \ - } \ - }while(0) - -#endif /* CAML_MINOR_GC_H */ diff -Nru ocaml-4.01.0/byterun/misc.c ocaml-4.05.0/byterun/misc.c --- ocaml-4.01.0/byterun/misc.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/misc.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,20 +1,35 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS #include -#include "config.h" -#include "misc.h" -#include "memory.h" +#include +#include +#include "caml/config.h" +#include "caml/misc.h" +#include "caml/memory.h" +#include "caml/osdeps.h" +#include "caml/version.h" + +caml_timing_hook caml_major_slice_begin_hook = NULL; +caml_timing_hook caml_major_slice_end_hook = NULL; +caml_timing_hook caml_minor_gc_begin_hook = NULL; +caml_timing_hook caml_minor_gc_end_hook = NULL; +caml_timing_hook caml_finalise_begin_hook = NULL; +caml_timing_hook caml_finalise_end_hook = NULL; #ifdef DEBUG @@ -23,15 +38,14 @@ fprintf (stderr, "file %s; line %d ### Assertion failed: %s\n", file, line, expr); fflush (stderr); - exit (100); - return 1; /* not reached */ + abort(); } -void caml_set_fields (char *bp, unsigned long start, unsigned long filler) +void caml_set_fields (value v, unsigned long start, unsigned long filler) { mlsize_t i; - for (i = start; i < Wosize_bp (bp); i++){ - Field (Val_bp (bp), i) = (value) filler; + for (i = start; i < Wosize_val (v); i++){ + Field (v, i) = (value) filler; } } @@ -41,7 +55,7 @@ void caml_gc_message (int level, char *msg, uintnat arg) { - if (level < 0 || (caml_verb_gc & level) != 0){ + if ((caml_verb_gc & level) != 0){ fprintf (stderr, msg, arg); fflush (stderr); } @@ -67,6 +81,7 @@ exit(2); } +/* [size] and [modulo] are numbers of bytes */ char *caml_aligned_malloc (asize_t size, int modulo, void **block) { char *raw_mem; @@ -93,6 +108,9 @@ return (char *) (aligned_mem - modulo); } +/* If you change the caml_ext_table* functions, also update + asmrun/spacetime.c:find_trie_node_from_libunwind. */ + void caml_ext_table_init(struct ext_table * tbl, int init_capa) { tbl->size = 0; @@ -114,10 +132,160 @@ return res; } -void caml_ext_table_free(struct ext_table * tbl, int free_entries) +void caml_ext_table_remove(struct ext_table * tbl, void * data) +{ + int i; + for (i = 0; i < tbl->size; i++) { + if (tbl->contents[i] == data) { + caml_stat_free(tbl->contents[i]); + memmove(&tbl->contents[i], &tbl->contents[i + 1], + (tbl->size - i - 1) * sizeof(void *)); + tbl->size--; + } + } +} + +void caml_ext_table_clear(struct ext_table * tbl, int free_entries) { int i; - if (free_entries) + if (free_entries) { for (i = 0; i < tbl->size; i++) caml_stat_free(tbl->contents[i]); + } + tbl->size = 0; +} + +void caml_ext_table_free(struct ext_table * tbl, int free_entries) +{ + caml_ext_table_clear(tbl, free_entries); caml_stat_free(tbl->contents); } + +CAMLexport char * caml_strdup(const char * s) +{ + size_t slen = strlen(s); + char * res = caml_stat_alloc(slen + 1); + memcpy(res, s, slen + 1); + return res; +} + +CAMLexport char * caml_strconcat(int n, ...) +{ + va_list args; + char * res, * p; + size_t len; + int i; + + len = 0; + va_start(args, n); + for (i = 0; i < n; i++) { + const char * s = va_arg(args, const char *); + len += strlen(s); + } + va_end(args); + res = caml_stat_alloc(len + 1); + va_start(args, n); + p = res; + for (i = 0; i < n; i++) { + const char * s = va_arg(args, const char *); + size_t l = strlen(s); + memcpy(p, s, l); + p += l; + } + va_end(args); + *p = 0; + return res; +} + +/* Runtime warnings */ + +uintnat caml_runtime_warnings = 0; +static int caml_runtime_warnings_first = 1; + +int caml_runtime_warnings_active(void) +{ + if (!caml_runtime_warnings) return 0; + if (caml_runtime_warnings_first) { + fprintf(stderr, "[ocaml] (use Sys.enable_runtime_warnings to control " + "these warnings)\n"); + caml_runtime_warnings_first = 0; + } + return 1; +} + +#ifdef CAML_INSTR +/* Timers for profiling GC and allocation (experimental, Linux-only) */ + +#include +#include +#include + +struct CAML_INSTR_BLOCK *CAML_INSTR_LOG = NULL; +intnat CAML_INSTR_STARTTIME, CAML_INSTR_STOPTIME; + +#define Get_time(p,i) ((p)->ts[(i)].tv_nsec + 1000000000 * (p)->ts[(i)].tv_sec) + +void CAML_INSTR_INIT (void) +{ + char *s; + + CAML_INSTR_STARTTIME = 0; + s = caml_secure_getenv ("OCAML_INSTR_START"); + if (s != NULL) CAML_INSTR_STARTTIME = atol (s); + CAML_INSTR_STOPTIME = LONG_MAX; + s = caml_secure_getenv ("OCAML_INSTR_STOP"); + if (s != NULL) CAML_INSTR_STOPTIME = atol (s); +} + +void CAML_INSTR_ATEXIT (void) +{ + int i; + struct CAML_INSTR_BLOCK *p, *prev, *next; + FILE *f = NULL; + char *fname; + + fname = caml_secure_getenv ("OCAML_INSTR_FILE"); + if (fname != NULL){ + char *mode = "a"; + char buf [1000]; + char *name = fname; + + if (name[0] == '@'){ + snprintf (buf, sizeof(buf), "%s.%d", name + 1, getpid ()); + name = buf; + } + if (name[0] == '+'){ + mode = "a"; + name = name + 1; + }else if (name [0] == '>' || name[0] == '-'){ + mode = "w"; + name = name + 1; + } + f = fopen (name, mode); + } + + if (f != NULL){ + /* reverse the list */ + prev = NULL; + p = CAML_INSTR_LOG; + while (p != NULL){ + next = p->next; + p->next = prev; + prev = p; + p = next; + } + CAML_INSTR_LOG = prev; + fprintf (f, "==== OCAML INSTRUMENTATION DATA %s\n", OCAML_VERSION_STRING); + for (p = CAML_INSTR_LOG; p != NULL; p = p->next){ + for (i = 0; i < p->index; i++){ + fprintf (f, "@@ %19ld %19ld %s\n", + Get_time (p, i), Get_time(p, i+1), p->tag[i+1]); + } + if (p->tag[0][0] != '\000'){ + fprintf (f, "@@ %19ld %19ld %s\n", + Get_time (p, 0), Get_time(p, p->index), p->tag[0]); + } + } + fclose (f); + } +} +#endif /* CAML_INSTR */ diff -Nru ocaml-4.01.0/byterun/misc.h ocaml-4.05.0/byterun/misc.h --- ocaml-4.01.0/byterun/misc.h 2013-08-01 08:12:41.000000000 +0000 +++ ocaml-4.05.0/byterun/misc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,143 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ - -/* Miscellaneous macros and variables. */ - -#ifndef CAML_MISC_H -#define CAML_MISC_H - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "config.h" - -/* Standard definitions */ - -#include -#include - -/* Basic types and constants */ - -typedef size_t asize_t; - -#ifndef NULL -#define NULL 0 -#endif - -/* */ -typedef char * addr; -/* */ - -#ifdef __GNUC__ - /* Works only in GCC 2.5 and later */ - #define Noreturn __attribute__ ((noreturn)) -#else - #define Noreturn -#endif - -/* Export control (to mark primitives and to handle Windows DLL) */ - -#define CAMLexport -#define CAMLprim -#define CAMLextern extern - -/* Weak function definitions that can be overriden by external libs */ -/* Conservatively restricted to ELF and MacOSX platforms */ -#if defined(__GNUC__) && (defined (__ELF__) || defined(__APPLE__)) -#define CAMLweakdef __attribute__((weak)) -#else -#define CAMLweakdef -#endif - -/* Assertions */ - -/* */ - -#ifdef DEBUG -#define CAMLassert(x) \ - ((x) ? (void) 0 : caml_failed_assert ( #x , __FILE__, __LINE__)) -CAMLextern int caml_failed_assert (char *, char *, int); -#else -#define CAMLassert(x) ((void) 0) -#endif - -CAMLextern void caml_fatal_error (char *msg) Noreturn; -CAMLextern void caml_fatal_error_arg (char *fmt, char *arg) Noreturn; -CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1, - char *fmt2, char *arg2) Noreturn; - -/* Data structures */ - -struct ext_table { - int size; - int capacity; - void ** contents; -}; - -extern void caml_ext_table_init(struct ext_table * tbl, int init_capa); -extern int caml_ext_table_add(struct ext_table * tbl, void * data); -extern void caml_ext_table_free(struct ext_table * tbl, int free_entries); - -/* GC flags and messages */ - -extern uintnat caml_verb_gc; -void caml_gc_message (int, char *, uintnat); - -/* Memory routines */ - -char *caml_aligned_malloc (asize_t, int, void **); - -#ifdef DEBUG -#ifdef ARCH_SIXTYFOUR -#define Debug_tag(x) (0xD700D7D7D700D6D7ul \ - | ((uintnat) (x) << 16) \ - | ((uintnat) (x) << 48)) -#else -#define Debug_tag(x) (0xD700D6D7ul | ((uintnat) (x) << 16)) -#endif /* ARCH_SIXTYFOUR */ - -/* - 00 -> free words in minor heap - 01 -> fields of free list blocks in major heap - 03 -> heap chunks deallocated by heap shrinking - 04 -> fields deallocated by [caml_obj_truncate] - 10 -> uninitialised fields of minor objects - 11 -> uninitialised fields of major objects - 15 -> uninitialised words of [caml_aligned_malloc] blocks - 85 -> filler bytes of [caml_aligned_malloc] - - special case (byte by byte): - D7 -> uninitialised words of [caml_stat_alloc] blocks -*/ -#define Debug_free_minor Debug_tag (0x00) -#define Debug_free_major Debug_tag (0x01) -#define Debug_free_shrink Debug_tag (0x03) -#define Debug_free_truncate Debug_tag (0x04) -#define Debug_uninit_minor Debug_tag (0x10) -#define Debug_uninit_major Debug_tag (0x11) -#define Debug_uninit_align Debug_tag (0x15) -#define Debug_filler_align Debug_tag (0x85) - -#define Debug_uninit_stat 0xD7 - -extern void caml_set_fields (char *, unsigned long, unsigned long); -#endif /* DEBUG */ - - -#ifndef CAML_AVOID_CONFLICTS -#define Assert CAMLassert -#endif - -/* */ - -#endif /* CAML_MISC_H */ diff -Nru ocaml-4.01.0/byterun/mlvalues.h ocaml-4.05.0/byterun/mlvalues.h --- ocaml-4.01.0/byterun/mlvalues.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/mlvalues.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,304 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_MLVALUES_H -#define CAML_MLVALUES_H - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "config.h" -#include "misc.h" - -#ifdef __cplusplus -extern "C" { -#endif - -/* Definitions - - word: Four bytes on 32 and 16 bit architectures, - eight bytes on 64 bit architectures. - long: A C integer having the same number of bytes as a word. - val: The ML representation of something. A long or a block or a pointer - outside the heap. If it is a block, it is the (encoded) address - of an object. If it is a long, it is encoded as well. - block: Something allocated. It always has a header and some - fields or some number of bytes (a multiple of the word size). - field: A word-sized val which is part of a block. - bp: Pointer to the first byte of a block. (a char *) - op: Pointer to the first field of a block. (a value *) - hp: Pointer to the header of a block. (a char *) - int32: Four bytes on all architectures. - int64: Eight bytes on all architectures. - - Remark: A block size is always a multiple of the word size, and at least - one word plus the header. - - bosize: Size (in bytes) of the "bytes" part. - wosize: Size (in words) of the "fields" part. - bhsize: Size (in bytes) of the block with its header. - whsize: Size (in words) of the block with its header. - - hd: A header. - tag: The value of the tag field of the header. - color: The value of the color field of the header. - This is for use only by the GC. -*/ - -typedef intnat value; -typedef uintnat header_t; -typedef uintnat mlsize_t; -typedef unsigned int tag_t; /* Actually, an unsigned char */ -typedef uintnat color_t; -typedef uintnat mark_t; - -/* Longs vs blocks. */ -#define Is_long(x) (((x) & 1) != 0) -#define Is_block(x) (((x) & 1) == 0) - -/* Conversion macro names are always of the form "to_from". */ -/* Example: Val_long as in "Val from long" or "Val of long". */ -#define Val_long(x) (((intnat)(x) << 1) + 1) -#define Long_val(x) ((x) >> 1) -#define Max_long (((intnat)1 << (8 * sizeof(value) - 2)) - 1) -#define Min_long (-((intnat)1 << (8 * sizeof(value) - 2))) -#define Val_int(x) Val_long(x) -#define Int_val(x) ((int) Long_val(x)) -#define Unsigned_long_val(x) ((uintnat)(x) >> 1) -#define Unsigned_int_val(x) ((int) Unsigned_long_val(x)) - -/* Structure of the header: - -For 16-bit and 32-bit architectures: - +--------+-------+-----+ - | wosize | color | tag | - +--------+-------+-----+ -bits 31 10 9 8 7 0 - -For 64-bit architectures: - - +--------+-------+-----+ - | wosize | color | tag | - +--------+-------+-----+ -bits 63 10 9 8 7 0 - -*/ - -#define Tag_hd(hd) ((tag_t) ((hd) & 0xFF)) -#define Wosize_hd(hd) ((mlsize_t) ((hd) >> 10)) - -#define Hd_val(val) (((header_t *) (val)) [-1]) /* Also an l-value. */ -#define Hd_op(op) (Hd_val (op)) /* Also an l-value. */ -#define Hd_bp(bp) (Hd_val (bp)) /* Also an l-value. */ -#define Hd_hp(hp) (* ((header_t *) (hp))) /* Also an l-value. */ -#define Hp_val(val) ((char *) (((header_t *) (val)) - 1)) -#define Hp_op(op) (Hp_val (op)) -#define Hp_bp(bp) (Hp_val (bp)) -#define Val_op(op) ((value) (op)) -#define Val_hp(hp) ((value) (((header_t *) (hp)) + 1)) -#define Op_hp(hp) ((value *) Val_hp (hp)) -#define Bp_hp(hp) ((char *) Val_hp (hp)) - -#define Num_tags (1 << 8) -#ifdef ARCH_SIXTYFOUR -#define Max_wosize (((intnat)1 << 54) - 1) -#else -#define Max_wosize ((1 << 22) - 1) -#endif - -#define Wosize_val(val) (Wosize_hd (Hd_val (val))) -#define Wosize_op(op) (Wosize_val (op)) -#define Wosize_bp(bp) (Wosize_val (bp)) -#define Wosize_hp(hp) (Wosize_hd (Hd_hp (hp))) -#define Whsize_wosize(sz) ((sz) + 1) -#define Wosize_whsize(sz) ((sz) - 1) -#define Wosize_bhsize(sz) ((sz) / sizeof (value) - 1) -#define Bsize_wsize(sz) ((sz) * sizeof (value)) -#define Wsize_bsize(sz) ((sz) / sizeof (value)) -#define Bhsize_wosize(sz) (Bsize_wsize (Whsize_wosize (sz))) -#define Bhsize_bosize(sz) ((sz) + sizeof (header_t)) -#define Bosize_val(val) (Bsize_wsize (Wosize_val (val))) -#define Bosize_op(op) (Bosize_val (Val_op (op))) -#define Bosize_bp(bp) (Bosize_val (Val_bp (bp))) -#define Bosize_hd(hd) (Bsize_wsize (Wosize_hd (hd))) -#define Whsize_hp(hp) (Whsize_wosize (Wosize_hp (hp))) -#define Whsize_val(val) (Whsize_hp (Hp_val (val))) -#define Whsize_bp(bp) (Whsize_val (Val_bp (bp))) -#define Whsize_hd(hd) (Whsize_wosize (Wosize_hd (hd))) -#define Bhsize_hp(hp) (Bsize_wsize (Whsize_hp (hp))) -#define Bhsize_hd(hd) (Bsize_wsize (Whsize_hd (hd))) - -#ifdef ARCH_BIG_ENDIAN -#define Tag_val(val) (((unsigned char *) (val)) [-1]) - /* Also an l-value. */ -#define Tag_hp(hp) (((unsigned char *) (hp)) [sizeof(value)-1]) - /* Also an l-value. */ -#else -#define Tag_val(val) (((unsigned char *) (val)) [-sizeof(value)]) - /* Also an l-value. */ -#define Tag_hp(hp) (((unsigned char *) (hp)) [0]) - /* Also an l-value. */ -#endif - -/* The lowest tag for blocks containing no value. */ -#define No_scan_tag 251 - - -/* 1- If tag < No_scan_tag : a tuple of fields. */ - -/* Pointer to the first field. */ -#define Op_val(x) ((value *) (x)) -/* Fields are numbered from 0. */ -#define Field(x, i) (((value *)(x)) [i]) /* Also an l-value. */ - -typedef int32 opcode_t; -typedef opcode_t * code_t; - -/* NOTE: [Forward_tag] and [Infix_tag] must be just under - [No_scan_tag], with [Infix_tag] the lower one. - See [caml_oldify_one] in minor_gc.c for more details. - - NOTE: Update stdlib/obj.ml whenever you change the tags. - */ - -/* Forward_tag: forwarding pointer that the GC may silently shortcut. - See stdlib/lazy.ml. */ -#define Forward_tag 250 -#define Forward_val(v) Field(v, 0) - -/* If tag == Infix_tag : an infix header inside a closure */ -/* Infix_tag must be odd so that the infix header is scanned as an integer */ -/* Infix_tag must be 1 modulo 4 and infix headers can only occur in blocks - with tag Closure_tag (see compact.c). */ - -#define Infix_tag 249 -#define Infix_offset_hd(hd) (Bosize_hd(hd)) -#define Infix_offset_val(v) Infix_offset_hd(Hd_val(v)) - -/* Another special case: objects */ -#define Object_tag 248 -#define Class_val(val) Field((val), 0) -#define Oid_val(val) Long_val(Field((val), 1)) -CAMLextern value caml_get_public_method (value obj, value tag); -/* Called as: - caml_callback(caml_get_public_method(obj, caml_hash_variant(name)), obj) */ -/* caml_get_public_method returns 0 if tag not in the table. - Note however that tags being hashed, same tag does not necessarily mean - same method name. */ - -/* Special case of tuples of fields: closures */ -#define Closure_tag 247 -#define Code_val(val) (((code_t *) (val)) [0]) /* Also an l-value. */ - -/* This tag is used (with Forward_tag) to implement lazy values. - See major_gc.c and stdlib/lazy.ml. */ -#define Lazy_tag 246 - -/* Another special case: variants */ -CAMLextern value caml_hash_variant(char const * tag); - -/* 2- If tag >= No_scan_tag : a sequence of bytes. */ - -/* Pointer to the first byte */ -#define Bp_val(v) ((char *) (v)) -#define Val_bp(p) ((value) (p)) -/* Bytes are numbered from 0. */ -#define Byte(x, i) (((char *) (x)) [i]) /* Also an l-value. */ -#define Byte_u(x, i) (((unsigned char *) (x)) [i]) /* Also an l-value. */ - -/* Abstract things. Their contents is not traced by the GC; therefore they - must not contain any [value]. -*/ -#define Abstract_tag 251 - -/* Strings. */ -#define String_tag 252 -#define String_val(x) ((char *) Bp_val(x)) -CAMLextern mlsize_t caml_string_length (value); /* size in bytes */ - -/* Floating-point numbers. */ -#define Double_tag 253 -#define Double_wosize ((sizeof(double) / sizeof(value))) -#ifndef ARCH_ALIGN_DOUBLE -#define Double_val(v) (* (double *)(v)) -#define Store_double_val(v,d) (* (double *)(v) = (d)) -#else -CAMLextern double caml_Double_val (value); -CAMLextern void caml_Store_double_val (value,double); -#define Double_val(v) caml_Double_val(v) -#define Store_double_val(v,d) caml_Store_double_val(v,d) -#endif - -/* Arrays of floating-point numbers. */ -#define Double_array_tag 254 -#define Double_field(v,i) Double_val((value)((double *)(v) + (i))) -#define Store_double_field(v,i,d) do{ \ - mlsize_t caml__temp_i = (i); \ - double caml__temp_d = (d); \ - Store_double_val((value)((double *) (v) + caml__temp_i), caml__temp_d); \ -}while(0) -CAMLextern mlsize_t caml_array_length (value); /* size in items */ -CAMLextern int caml_is_double_array (value); /* 0 is false, 1 is true */ - - -/* Custom blocks. They contain a pointer to a "method suite" - of functions (for finalization, comparison, hashing, etc) - followed by raw data. The contents of custom blocks is not traced by - the GC; therefore, they must not contain any [value]. - See [custom.h] for operations on method suites. */ -#define Custom_tag 255 -#define Data_custom_val(v) ((void *) &Field((v), 1)) -struct custom_operations; /* defined in [custom.h] */ - -/* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */ - -#define Int32_val(v) (*((int32 *) Data_custom_val(v))) -#define Nativeint_val(v) (*((intnat *) Data_custom_val(v))) -#ifndef ARCH_ALIGN_INT64 -#define Int64_val(v) (*((int64 *) Data_custom_val(v))) -#else -CAMLextern int64 caml_Int64_val(value v); -#define Int64_val(v) caml_Int64_val(v) -#endif - -/* 3- Atoms are 0-tuples. They are statically allocated once and for all. */ - -CAMLextern header_t caml_atom_table[]; -#define Atom(tag) (Val_hp (&(caml_atom_table [(tag)]))) - -/* Booleans are integers 0 or 1 */ - -#define Val_bool(x) Val_int((x) != 0) -#define Bool_val(x) Int_val(x) -#define Val_false Val_int(0) -#define Val_true Val_int(1) -#define Val_not(x) (Val_false + Val_true - (x)) - -/* The unit value is 0 (tagged) */ - -#define Val_unit Val_int(0) - -/* List constructors */ -#define Val_emptylist Val_int(0) -#define Tag_cons 0 - -/* The table of global identifiers */ - -extern value caml_global_data; - -#ifdef __cplusplus -} -#endif - - -#endif /* CAML_MLVALUES_H */ diff -Nru ocaml-4.01.0/byterun/obj.c ocaml-4.05.0/byterun/obj.c --- ocaml-4.01.0/byterun/obj.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/obj.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,30 +1,36 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Operations on objects */ #include -#include "alloc.h" -#include "fail.h" -#include "gc.h" -#include "interp.h" -#include "major_gc.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "prims.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/interp.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/prims.h" +#include "caml/spacetime.h" +/* [size] is a value encoding a number of bytes */ CAMLprim value caml_static_alloc(value size) { return (value) caml_stat_alloc((asize_t) Long_val(size)); @@ -36,26 +42,12 @@ return Val_unit; } -/* signal to the interpreter machinery that a bytecode is no more - needed (before freeing it) - this might be useful for a JIT - implementation */ - -CAMLprim value caml_static_release_bytecode(value blk, value size) -{ -#ifndef NATIVE_CODE - caml_release_bytecode((code_t) blk, (asize_t) Long_val(size)); -#else - caml_failwith("Meta.static_release_bytecode impossible with native code"); -#endif - return Val_unit; -} - - CAMLprim value caml_static_resize(value blk, value new_size) { return (value) caml_stat_resize((char *) blk, (asize_t) Long_val(new_size)); } +/* unused since GPR#427 */ CAMLprim value caml_obj_is_block(value arg) { return Val_bool(Is_block(arg)); @@ -80,6 +72,7 @@ return Val_unit; } +/* [size] is a value encoding a number of blocks */ CAMLprim value caml_obj_block(value tag, value size) { value res; @@ -96,6 +89,7 @@ return res; } +/* Spacetime profiling assumes that this function is only called from OCaml. */ CAMLprim value caml_obj_dup(value arg) { CAMLparam1 (arg); @@ -110,7 +104,9 @@ res = caml_alloc(sz, tg); memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value)); } else if (sz <= Max_young_wosize) { - res = caml_alloc_small(sz, tg); + uintnat profinfo; + Get_my_profinfo_with_cached_backtrace(profinfo, sz); + res = caml_alloc_small_with_my_or_given_profinfo(sz, tg, profinfo); for (i = 0; i < sz; i++) Field(res, i) = Field(arg, i); } else { res = caml_alloc_shr(sz, tg); @@ -124,9 +120,15 @@ to 0 or greater than the current size. algorithm: - Change the length field of the header. Make up a white object + Change the length field of the header. Make up a black object with the leftover part of the object: this is needed in the major - heap and harmless in the minor heap. + heap and harmless in the minor heap. The object cannot be white + because there may still be references to it in the ref table. By + using a black object we ensure that the ref table will be emptied + before the block is reallocated (since there must be a minor + collection within each major cycle). + + [newsize] is a value encoding a number of words. */ CAMLprim value caml_obj_truncate (value v, value newsize) { @@ -158,8 +160,9 @@ look like a pointer because there may be some references to it in ref_table. */ Field (v, new_wosize) = - Make_header (Wosize_whsize (wosize-new_wosize), 1, Caml_white); - Hd_val (v) = Make_header (new_wosize, tag, color); + Make_header (Wosize_whsize (wosize-new_wosize), Abstract_tag, Caml_black); + Hd_val (v) = + Make_header_with_profinfo (new_wosize, tag, color, Profinfo_val(v)); return Val_unit; } @@ -247,3 +250,140 @@ } } #endif /*CAML_JIT*/ + +static value oo_last_id = Val_int(0); + +CAMLprim value caml_set_oo_id (value obj) { + Field(obj, 1) = oo_last_id; + oo_last_id += 2; + return obj; +} + +CAMLprim value caml_fresh_oo_id (value v) { + v = oo_last_id; + oo_last_id += 2; + return v; +} + +CAMLprim value caml_int_as_pointer (value n) { + return n - 1; +} + +/* Compute how many words in the heap are occupied by blocks accessible + from a given value */ + +#define ENTRIES_PER_QUEUE_CHUNK 4096 +struct queue_chunk { + struct queue_chunk *next; + value entries[ENTRIES_PER_QUEUE_CHUNK]; +}; + + +CAMLprim value caml_obj_reachable_words(value v) +{ + static struct queue_chunk first_chunk; + struct queue_chunk *read_chunk, *write_chunk; + int write_pos, read_pos, i; + + intnat size = 0; + header_t hd; + mlsize_t sz; + + if (Is_long(v) || !Is_in_heap_or_young(v)) return Val_int(0); + if (Tag_hd(Hd_val(v)) == Infix_tag) v -= Infix_offset_hd(Hd_val(v)); + hd = Hd_val(v); + sz = Wosize_hd(hd); + + read_chunk = write_chunk = &first_chunk; + read_pos = 0; + write_pos = 1; + write_chunk->entries[0] = v | Colornum_hd(hd); + Hd_val(v) = Bluehd_hd(hd); + + /* We maintain a queue of "interesting" blocks that have been seen. + An interesting block is a block in the heap which does not + represent an infix pointer. Infix pointers are normalized to the + beginning of their block. Blocks in the static data area are excluded. + + The function maintains a queue of block pointers. Concretely, + the queue is stored as a linked list of chunks, each chunk + holding a number of pointers to interesting blocks. Initially, + it contains only the "root" value. The first chunk of the queue + is allocated statically. More chunks can be allocated as needed + and released before this function exits. + + When a block is inserted in the queue, it is marked as blue. + This mark is used to avoid a second visit of the same block. + The real color is stored in the last 2 bits of the pointer in the + queue. (Same technique as in extern.c.) + + Note: we make the assumption that there is no pointer + from the static data area to the heap. + */ + + /* First pass: mark accessible blocks and compute their total size */ + while (read_pos != write_pos || read_chunk != write_chunk) { + /* Pop the next element from the queue */ + if (read_pos == ENTRIES_PER_QUEUE_CHUNK) { + read_pos = 0; + read_chunk = read_chunk->next; + } + v = read_chunk->entries[read_pos++] & ~3; + + hd = Hd_val(v); + sz = Wosize_hd(hd); + + size += Whsize_wosize(sz); + + if (Tag_hd(hd) < No_scan_tag) { + /* Push the interesting fields on the queue */ + for (i = 0; i < sz; i++) { + value v2 = Field(v, i); + if (Is_block(v2) && Is_in_heap_or_young(v2)) { + if (Tag_hd(Hd_val(v2)) == Infix_tag){ + v2 -= Infix_offset_hd(Hd_val(v2)); + } + hd = Hd_val(v2); + if (Color_hd(hd) != Caml_blue) { + if (write_pos == ENTRIES_PER_QUEUE_CHUNK) { + struct queue_chunk *new_chunk = + malloc(sizeof(struct queue_chunk)); + if (new_chunk == NULL) { + size = (-1); + goto release; + } + write_chunk->next = new_chunk; + write_pos = 0; + write_chunk = new_chunk; + } + write_chunk->entries[write_pos++] = v2 | Colornum_hd(hd); + Hd_val(v2) = Bluehd_hd(hd); + } + } + } + } + } + + /* Second pass: restore colors and free extra queue chunks */ + release: + read_pos = 0; + read_chunk = &first_chunk; + while (read_pos != write_pos || read_chunk != write_chunk) { + color_t colornum; + if (read_pos == ENTRIES_PER_QUEUE_CHUNK) { + struct queue_chunk *prev = read_chunk; + read_pos = 0; + read_chunk = read_chunk->next; + if (prev != &first_chunk) free(prev); + } + v = read_chunk->entries[read_pos++]; + colornum = v & 3; + v &= ~3; + Hd_val(v) = Coloredhd_hd(Hd_val(v), colornum); + } + if (read_chunk != &first_chunk) free(read_chunk); + + if (size < 0) + caml_raise_out_of_memory(); + return Val_int(size); +} diff -Nru ocaml-4.01.0/byterun/osdeps.h ocaml-4.05.0/byterun/osdeps.h --- ocaml-4.01.0/byterun/osdeps.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/osdeps.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 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. */ -/* */ -/***********************************************************************/ - -/* Operating system - specific stuff */ - -#ifndef CAML_OSDEPS_H -#define CAML_OSDEPS_H - -#include "misc.h" - -/* Decompose the given path into a list of directories, and add them - to the given table. Return the block to be freed later. */ -extern char * caml_decompose_path(struct ext_table * tbl, char * path); - -/* Search the given file in the given list of directories. - If not found, return a copy of [name]. Result is allocated with - [caml_stat_alloc]. */ -extern char * caml_search_in_path(struct ext_table * path, char * name); - -/* Same, but search an executable name in the system path for executables. */ -CAMLextern char * caml_search_exe_in_path(char * name); - -/* Same, but search a shared library in the given path. */ -extern char * caml_search_dll_in_path(struct ext_table * path, char * name); - -/* Open a shared library and return a handle on it. - If [for_execution] is true, perform full symbol resolution and - execute initialization code so that functions from the shared library - can be called. If [for_execution] is false, functions from this - shared library will not be called, but just checked for presence, - so symbol resolution can be skipped. - If [global] is true, symbols from the shared library can be used - to resolve for other libraries to be opened later on. - Return [NULL] on error. */ -extern void * caml_dlopen(char * libname, int for_execution, int global); - -/* Close a shared library handle */ -extern void caml_dlclose(void * handle); - -/* Look up the given symbol in the given shared library. - Return [NULL] if not found, or symbol value if found. */ -extern void * caml_dlsym(void * handle, char * name); - -extern void * caml_globalsym(char * name); - -/* Return an error message describing the most recent dynlink failure. */ -extern char * caml_dlerror(void); - -/* Add to [contents] the (short) names of the files contained in - the directory named [dirname]. No entries are added for [.] and [..]. - Return 0 on success, -1 on error; set errno in the case of error. */ -extern int caml_read_directory(char * dirname, struct ext_table * contents); - -#ifdef __linux__ -/* Recover executable name from /proc/self/exe if possible */ -extern int caml_executable_name(char * name, int name_len); -#endif - -#endif /* CAML_OSDEPS_H */ diff -Nru ocaml-4.01.0/byterun/parsing.c ocaml-4.05.0/byterun/parsing.c --- ocaml-4.01.0/byterun/parsing.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/parsing.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,24 +1,28 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* The PDA automaton for parsers generated by camlyacc */ #include #include -#include "config.h" -#include "mlvalues.h" -#include "memory.h" -#include "alloc.h" +#include "caml/config.h" +#include "caml/mlvalues.h" +#include "caml/memory.h" +#include "caml/alloc.h" #define ERRCODE 256 @@ -63,7 +67,7 @@ #if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2 #define Short(tbl,n) \ (*((unsigned char *)((tbl) + (n) * 2)) + \ - (*((schar *)((tbl) + (n) * 2 + 1)) << 8)) + (*((signed char *)((tbl) + (n) * 2 + 1)) << 8)) #else #define Short(tbl,n) (((short *)(tbl))[n]) #endif diff -Nru ocaml-4.01.0/byterun/prims.h ocaml-4.05.0/byterun/prims.h --- ocaml-4.01.0/byterun/prims.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/prims.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* Interface with C primitives. */ - -#ifndef CAML_PRIMS_H -#define CAML_PRIMS_H - -typedef value (*c_primitive)(); - -extern c_primitive caml_builtin_cprim[]; -extern char * caml_names_of_builtin_cprim[]; - -extern struct ext_table caml_prim_table; -#ifdef DEBUG -extern struct ext_table caml_prim_name_table; -#endif - -#define Primitive(n) ((c_primitive)(caml_prim_table.contents[n])) - -extern char * caml_section_table; -extern asize_t caml_section_table_size; - -#endif /* CAML_PRIMS_H */ diff -Nru ocaml-4.01.0/byterun/printexc.c ocaml-4.05.0/byterun/printexc.c --- ocaml-4.01.0/byterun/printexc.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/printexc.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,28 +1,32 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Print an uncaught exception and abort */ #include #include #include -#include "backtrace.h" -#include "callback.h" -#include "debugger.h" -#include "fail.h" -#include "misc.h" -#include "mlvalues.h" -#include "printexc.h" +#include "caml/backtrace.h" +#include "caml/callback.h" +#include "caml/debugger.h" +#include "caml/fail.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/printexc.h" struct stringbuf { char * ptr; @@ -53,8 +57,8 @@ buf.ptr = buf.data; buf.end = buf.data + sizeof(buf.data) - 1; - add_string(&buf, String_val(Field(Field(exn, 0), 0))); - if (Wosize_val(exn) >= 2) { + if (Tag_val(exn) == 0) { + add_string(&buf, String_val(Field(Field(exn, 0), 0))); /* Check for exceptions in the style of Match_failure and Assert_failure */ if (Wosize_val(exn) == 2 && Is_block(Field(exn, 1)) && @@ -71,7 +75,8 @@ if (i > start) add_string(&buf, ", "); v = Field(bucket, i); if (Is_long(v)) { - sprintf(intbuf, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); + snprintf(intbuf, sizeof(intbuf), + "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); add_string(&buf, intbuf); } else if (Tag_val(v) == String_tag) { add_char(&buf, '"'); @@ -82,7 +87,9 @@ } } add_char(&buf, ')'); - } + } else + add_string(&buf, String_val(Field(exn, 0))); + *buf.ptr = 0; /* Terminate string */ i = buf.ptr - buf.data + 1; res = malloc(i); @@ -92,7 +99,14 @@ } -void caml_fatal_uncaught_exception(value exn) +#ifdef NATIVE_CODE +# define DEBUGGER_IN_USE 0 +#else +# define DEBUGGER_IN_USE caml_debugger_in_use +#endif + +/* Default C implementation in case the OCaml one is not registered. */ +static void default_fatal_uncaught_exception(value exn) { char * msg; value * at_exit; @@ -113,13 +127,28 @@ fprintf(stderr, "Fatal error: exception %s\n", msg); free(msg); /* Display the backtrace if available */ - if (caml_backtrace_active -#ifndef NATIVE_CODE - && !caml_debugger_in_use -#endif - ) { + if (caml_backtrace_active && !DEBUGGER_IN_USE) caml_print_exception_backtrace(); - } +} + +int caml_abort_on_uncaught_exn = 0; /* see afl.c */ + +void caml_fatal_uncaught_exception(value exn) +{ + value *handle_uncaught_exception; + + handle_uncaught_exception = + caml_named_value("Printexc.handle_uncaught_exception"); + if (handle_uncaught_exception != NULL) + /* [Printexc.handle_uncaught_exception] does not raise exception. */ + caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE)); + else + default_fatal_uncaught_exception(exn); /* Terminate the process */ - exit(2); + if (caml_abort_on_uncaught_exn) { + abort(); + } else { + CAML_SYS_EXIT(2); + exit(2); /* Second exit needed for the Noreturn flag */ + } } diff -Nru ocaml-4.01.0/byterun/printexc.h ocaml-4.05.0/byterun/printexc.h --- ocaml-4.01.0/byterun/printexc.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/printexc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_PRINTEXC_H -#define CAML_PRINTEXC_H - - -#include "misc.h" -#include "mlvalues.h" - -#ifdef __cplusplus -extern "C" { -#endif - - -CAMLextern char * caml_format_exception (value); -void caml_fatal_uncaught_exception (value) Noreturn; - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_PRINTEXC_H */ diff -Nru ocaml-4.01.0/byterun/reverse.h ocaml-4.05.0/byterun/reverse.h --- ocaml-4.01.0/byterun/reverse.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/reverse.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,86 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* Swap byte-order in 16, 32, and 64-bit integers or floats */ - -#ifndef CAML_REVERSE_H -#define CAML_REVERSE_H - -#define Reverse_16(dst,src) { \ - char * _p, * _q; \ - char _a; \ - _p = (char *) (src); \ - _q = (char *) (dst); \ - _a = _p[0]; \ - _q[0] = _p[1]; \ - _q[1] = _a; \ -} - -#define Reverse_32(dst,src) { \ - char * _p, * _q; \ - char _a, _b; \ - _p = (char *) (src); \ - _q = (char *) (dst); \ - _a = _p[0]; \ - _b = _p[1]; \ - _q[0] = _p[3]; \ - _q[1] = _p[2]; \ - _q[3] = _a; \ - _q[2] = _b; \ -} - -#define Reverse_64(dst,src) { \ - char * _p, * _q; \ - char _a, _b; \ - _p = (char *) (src); \ - _q = (char *) (dst); \ - _a = _p[0]; \ - _b = _p[1]; \ - _q[0] = _p[7]; \ - _q[1] = _p[6]; \ - _q[7] = _a; \ - _q[6] = _b; \ - _a = _p[2]; \ - _b = _p[3]; \ - _q[2] = _p[5]; \ - _q[3] = _p[4]; \ - _q[5] = _a; \ - _q[4] = _b; \ -} - -#define Perm_index(perm,i) ((perm >> (i * 4)) & 0xF) - -#define Permute_64(dst,perm_dst,src,perm_src) { \ - char * _p; \ - char _a, _b, _c, _d, _e, _f, _g, _h; \ - _p = (char *) (src); \ - _a = _p[Perm_index(perm_src, 0)]; \ - _b = _p[Perm_index(perm_src, 1)]; \ - _c = _p[Perm_index(perm_src, 2)]; \ - _d = _p[Perm_index(perm_src, 3)]; \ - _e = _p[Perm_index(perm_src, 4)]; \ - _f = _p[Perm_index(perm_src, 5)]; \ - _g = _p[Perm_index(perm_src, 6)]; \ - _h = _p[Perm_index(perm_src, 7)]; \ - _p = (char *) (dst); \ - _p[Perm_index(perm_dst, 0)] = _a; \ - _p[Perm_index(perm_dst, 1)] = _b; \ - _p[Perm_index(perm_dst, 2)] = _c; \ - _p[Perm_index(perm_dst, 3)] = _d; \ - _p[Perm_index(perm_dst, 4)] = _e; \ - _p[Perm_index(perm_dst, 5)] = _f; \ - _p[Perm_index(perm_dst, 6)] = _g; \ - _p[Perm_index(perm_dst, 7)] = _h; \ -} - -#endif /* CAML_REVERSE_H */ diff -Nru ocaml-4.01.0/byterun/roots.c ocaml-4.05.0/byterun/roots.c --- ocaml-4.01.0/byterun/roots.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/roots.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,33 +1,37 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* To walk the memory roots for garbage collection */ -#include "finalise.h" -#include "globroots.h" -#include "major_gc.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "stacks.h" +#include "caml/finalise.h" +#include "caml/globroots.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/stacks.h" CAMLexport struct caml__roots_block *caml_local_roots = NULL; CAMLexport void (*caml_scan_roots_hook) (scanning_action f) = NULL; -/* FIXME should rename to [caml_oldify_young_roots] and synchronise with +/* FIXME should rename to [caml_oldify_minor_roots] and synchronise with asmrun/roots.c */ /* Call [caml_oldify_one] on (at least) all the roots that point to the minor heap. */ @@ -53,30 +57,45 @@ /* Global C roots */ caml_scan_global_young_roots(&caml_oldify_one); /* Finalised values */ - caml_final_do_young_roots (&caml_oldify_one); + caml_final_oldify_young_roots (); /* Hook */ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one); } /* Call [caml_darken] on all roots */ -void caml_darken_all_roots (void) +void caml_darken_all_roots_start (void) +{ + caml_do_roots (caml_darken, 1); +} + +uintnat caml_incremental_roots_count = 1; + +intnat caml_darken_all_roots_slice (intnat work) { - caml_do_roots (caml_darken); + return work; } -void caml_do_roots (scanning_action f) +/* Note, in byte-code there is only one global root, so [do_globals] is + ignored and [caml_darken_all_roots_slice] does nothing. */ +void caml_do_roots (scanning_action f, int do_globals) { + CAML_INSTR_SETUP (tmr, "major_roots"); /* Global variables */ f(caml_global_data, &caml_global_data); + CAML_INSTR_TIME (tmr, "major_roots/global"); /* The stack and the local C roots */ caml_do_local_roots(f, caml_extern_sp, caml_stack_high, caml_local_roots); + CAML_INSTR_TIME (tmr, "major_roots/local"); /* Global C roots */ caml_scan_global_roots(f); + CAML_INSTR_TIME (tmr, "major_roots/C"); /* Finalised values */ - caml_final_do_strong_roots (f); + caml_final_do_roots (f); + CAML_INSTR_TIME (tmr, "major_roots/finalised"); /* Hook */ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f); + CAML_INSTR_TIME (tmr, "major_roots/hook"); } CAMLexport void caml_do_local_roots (scanning_action f, value *stack_low, diff -Nru ocaml-4.01.0/byterun/roots.h ocaml-4.05.0/byterun/roots.h --- ocaml-4.01.0/byterun/roots.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/roots.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_ROOTS_H -#define CAML_ROOTS_H - -#include "misc.h" -#include "memory.h" - -typedef void (*scanning_action) (value, value *); - -void caml_oldify_local_roots (void); -void caml_darken_all_roots (void); -void caml_do_roots (scanning_action); -#ifndef NATIVE_CODE -CAMLextern void caml_do_local_roots (scanning_action, value *, value *, - struct caml__roots_block *); -#else -CAMLextern void caml_do_local_roots(scanning_action f, char * bottom_of_stack, - uintnat last_retaddr, value * gc_regs, - struct caml__roots_block * local_roots); -#endif - -CAMLextern void (*caml_scan_roots_hook) (scanning_action); - -#endif /* CAML_ROOTS_H */ diff -Nru ocaml-4.01.0/byterun/signals_byt.c ocaml-4.05.0/byterun/signals_byt.c --- ocaml-4.01.0/byterun/signals_byt.c 2013-05-14 15:37:48.000000000 +0000 +++ ocaml-4.05.0/byterun/signals_byt.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,25 +1,29 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ -/* */ -/* Copyright 2007 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ +/* */ +/* Copyright 2007 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Signal handling, code specific to the bytecode interpreter */ #include #include -#include "config.h" -#include "memory.h" -#include "osdeps.h" -#include "signals.h" -#include "signals_machdep.h" +#include "caml/config.h" +#include "caml/memory.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/signals_machdep.h" #ifndef NSIG #define NSIG 64 @@ -38,8 +42,7 @@ { void (*async_action)(void); - if (caml_force_major_slice) caml_minor_collection (); - /* FIXME should be [caml_check_urgent_gc] */ + caml_check_urgent_gc (Val_unit); caml_process_pending_signals(); async_action = caml_async_action_hook; if (async_action != NULL) { diff -Nru ocaml-4.01.0/byterun/signals.c ocaml-4.05.0/byterun/signals.c --- ocaml-4.01.0/byterun/signals.c 2013-05-14 15:48:50.000000000 +0000 +++ ocaml-4.05.0/byterun/signals.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,31 +1,39 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Signal handling, code common to the bytecode and native systems */ #include #include -#include "alloc.h" -#include "callback.h" -#include "config.h" -#include "fail.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "signals.h" -#include "signals_machdep.h" -#include "sys.h" +#include "caml/alloc.h" +#include "caml/callback.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/signals_machdep.h" +#include "caml/sys.h" + +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) +#include "caml/spacetime.h" +#endif #ifndef NSIG #define NSIG 64 @@ -67,7 +75,7 @@ #ifndef NATIVE_CODE caml_something_to_do = 1; #else - caml_young_limit = caml_young_end; + caml_young_limit = caml_young_alloc_end; #endif } @@ -131,6 +139,10 @@ void caml_execute_signal(int signal_number, int in_signal_handler) { value res; + value handler; +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + void* saved_spacetime_trie_node_ptr; +#endif #ifdef POSIX_SIGNALS sigset_t sigs; /* Block the signal before executing the handler, and record in sigs @@ -139,9 +151,36 @@ sigaddset(&sigs, signal_number); sigprocmask(SIG_BLOCK, &sigs, &sigs); #endif - res = caml_callback_exn( - Field(caml_signal_handlers, signal_number), - Val_int(caml_rev_convert_signal_number(signal_number))); +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + /* We record the signal handler's execution separately, in the same + trie used for finalisers. */ + saved_spacetime_trie_node_ptr + = caml_spacetime_trie_node_ptr; + caml_spacetime_trie_node_ptr + = caml_spacetime_finaliser_trie_root; +#endif +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + /* Handled action may have no associated handler, which we interpret + as meaning the signal should be handled by a call to exit. This is + is used to allow spacetime profiles to be completed on interrupt */ + if (caml_signal_handlers == 0) { + res = caml_sys_exit(Val_int(2)); + } else { + handler = Field(caml_signal_handlers, signal_number); + if (!Is_block(handler)) { + res = caml_sys_exit(Val_int(2)); + } else { +#else + handler = Field(caml_signal_handlers, signal_number); +#endif + res = caml_callback_exn( + handler, + Val_int(caml_rev_convert_signal_number(signal_number))); +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + } + } + caml_spacetime_trie_node_ptr = saved_spacetime_trie_node_ptr; +#endif #ifdef POSIX_SIGNALS if (! in_signal_handler) { /* Restore the original signal mask */ @@ -157,15 +196,16 @@ /* Arrange for a garbage collection to be performed as soon as possible */ -int volatile caml_force_major_slice = 0; +int volatile caml_requested_major_slice = 0; +int volatile caml_requested_minor_gc = 0; -void caml_urge_major_slice (void) +void caml_request_major_slice (void) { - caml_force_major_slice = 1; + caml_requested_major_slice = 1; #ifndef NATIVE_CODE caml_something_to_do = 1; #else - caml_young_limit = caml_young_end; + caml_young_limit = caml_young_alloc_end; /* This is only moderately effective on ports that cache [caml_young_limit] in a register, since [caml_modify] is called directly, not through [caml_c_call], so it may take a while before the register is reloaded @@ -173,6 +213,17 @@ #endif } +void caml_request_minor_gc (void) +{ + caml_requested_minor_gc = 1; +#ifndef NATIVE_CODE + caml_something_to_do = 1; +#else + caml_young_limit = caml_young_alloc_end; + /* Same remark as above in [caml_request_major_slice]. */ +#endif +} + /* OS-independent numbering of signals */ #ifndef SIGABRT @@ -238,11 +289,33 @@ #ifndef SIGPROF #define SIGPROF -1 #endif +#ifndef SIGBUS +#define SIGBUS -1 +#endif +#ifndef SIGPOLL +#define SIGPOLL -1 +#endif +#ifndef SIGSYS +#define SIGSYS -1 +#endif +#ifndef SIGTRAP +#define SIGTRAP -1 +#endif +#ifndef SIGURG +#define SIGURG -1 +#endif +#ifndef SIGXCPU +#define SIGXCPU -1 +#endif +#ifndef SIGXFSZ +#define SIGXFSZ -1 +#endif static int posix_signals[] = { SIGABRT, SIGALRM, SIGFPE, SIGHUP, SIGILL, SIGINT, SIGKILL, SIGPIPE, SIGQUIT, SIGSEGV, SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT, - SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGVTALRM, SIGPROF + SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGVTALRM, SIGPROF, SIGBUS, + SIGPOLL, SIGSYS, SIGTRAP, SIGURG, SIGXCPU, SIGXFSZ }; CAMLexport int caml_convert_signal_number(int signo) @@ -292,8 +365,23 @@ res = Val_int(1); break; case 2: /* was Signal_handle */ + #if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + /* Handled action may have no associated handler + which we treat as Signal_default */ + if (caml_signal_handlers == 0) { + res = Val_int(0); + } else { + if (!Is_block(Field(caml_signal_handlers, sig))) { + res = Val_int(0); + } else { + res = caml_alloc_small (1, 0); + Field(res, 0) = Field(caml_signal_handlers, sig); + } + } + #else res = caml_alloc_small (1, 0); Field(res, 0) = Field(caml_signal_handlers, sig); + #endif break; default: /* error in caml_set_signal_action */ caml_sys_error(NO_ARG); diff -Nru ocaml-4.01.0/byterun/signals.h ocaml-4.05.0/byterun/signals.h --- ocaml-4.01.0/byterun/signals.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/signals.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_SIGNALS_H -#define CAML_SIGNALS_H - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "misc.h" -#include "mlvalues.h" - -#ifdef __cplusplus -extern "C" { -#endif - -/* */ -CAMLextern intnat volatile caml_signals_are_pending; -CAMLextern intnat volatile caml_pending_signals[]; -CAMLextern int volatile caml_something_to_do; -extern int volatile caml_force_major_slice; -/* */ - -CAMLextern void caml_enter_blocking_section (void); -CAMLextern void caml_leave_blocking_section (void); - -/* */ -void caml_urge_major_slice (void); -CAMLextern int caml_convert_signal_number (int); -CAMLextern int caml_rev_convert_signal_number (int); -void caml_execute_signal(int signal_number, int in_signal_handler); -void caml_record_signal(int signal_number); -void caml_process_pending_signals(void); -void caml_process_event(void); -int caml_set_signal_action(int signo, int action); - -CAMLextern void (*caml_enter_blocking_section_hook)(void); -CAMLextern void (*caml_leave_blocking_section_hook)(void); -CAMLextern int (*caml_try_leave_blocking_section_hook)(void); -CAMLextern void (* volatile caml_async_action_hook)(void); -/* */ - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_SIGNALS_H */ diff -Nru ocaml-4.01.0/byterun/signals_machdep.h ocaml-4.05.0/byterun/signals_machdep.h --- ocaml-4.01.0/byterun/signals_machdep.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/signals_machdep.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,60 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ - -/* Processor-specific operation: atomic "read and clear" */ - -#ifndef CAML_SIGNALS_MACHDEP_H -#define CAML_SIGNALS_MACHDEP_H - -#if defined(__GNUC__) && defined(__i386__) - -#define Read_and_clear(dst,src) \ - asm("xorl %0, %0; xchgl %0, %1" \ - : "=r" (dst), "=m" (src) \ - : "m" (src)) - -#elif defined(__GNUC__) && defined(__x86_64__) - -#define Read_and_clear(dst,src) \ - asm("xorq %0, %0; xchgq %0, %1" \ - : "=r" (dst), "=m" (src) \ - : "m" (src)) - -#elif defined(__GNUC__) && defined(__ppc__) - -#define Read_and_clear(dst,src) \ - asm("0: lwarx %0, 0, %1\n\t" \ - "stwcx. %2, 0, %1\n\t" \ - "bne- 0b" \ - : "=&r" (dst) \ - : "r" (&(src)), "r" (0) \ - : "cr0", "memory") - -#elif defined(__GNUC__) && defined(__ppc64__) - -#define Read_and_clear(dst,src) \ - asm("0: ldarx %0, 0, %1\n\t" \ - "stdcx. %2, 0, %1\n\t" \ - "bne- 0b" \ - : "=&r" (dst) \ - : "r" (&(src)), "r" (0) \ - : "cr0", "memory") - -#else - -/* Default, non-atomic implementation */ -#define Read_and_clear(dst,src) ((dst) = (src), (src) = 0) - -#endif - -#endif /* CAML_SIGNALS_MACHDEP_H */ diff -Nru ocaml-4.01.0/byterun/spacetime.c ocaml-4.05.0/byterun/spacetime.c --- ocaml-4.01.0/byterun/spacetime.c 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/spacetime.c 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,40 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Mark Shinwell and Leo White, Jane Street Europe */ +/* */ +/* Copyright 2013--2016, Jane Street Group, LLC */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#include +#include "caml/fail.h" +#include "caml/mlvalues.h" + +int ensure_spacetime_dot_o_is_included = 42; + +CAMLprim value caml_spacetime_only_works_for_native_code(value foo, ...) +{ + caml_failwith("Spacetime profiling only works for native code"); + assert(0); /* unreachable */ +} + +uintnat caml_spacetime_my_profinfo (void) +{ + return 0; +} + +CAMLprim value caml_spacetime_enabled (value v_unit) +{ + return Val_false; /* running in bytecode */ +} + +CAMLprim value caml_register_channel_for_spacetime (value v_channel) +{ + return Val_unit; +} diff -Nru ocaml-4.01.0/byterun/stacks.c ocaml-4.05.0/byterun/stacks.c --- ocaml-4.01.0/byterun/stacks.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/stacks.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,24 +1,28 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* To initialize and resize the stacks */ #include -#include "config.h" -#include "fail.h" -#include "misc.h" -#include "mlvalues.h" -#include "stacks.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/stacks.h" CAMLexport value * caml_stack_low; CAMLexport value * caml_stack_high; diff -Nru ocaml-4.01.0/byterun/stacks.h ocaml-4.05.0/byterun/stacks.h --- ocaml-4.01.0/byterun/stacks.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/stacks.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* structure of the stacks */ - -#ifndef CAML_STACKS_H -#define CAML_STACKS_H - - -#include "misc.h" -#include "mlvalues.h" -#include "memory.h" - -CAMLextern value * caml_stack_low; -CAMLextern value * caml_stack_high; -CAMLextern value * caml_stack_threshold; -CAMLextern value * caml_extern_sp; -CAMLextern value * caml_trapsp; -CAMLextern value * caml_trap_barrier; - -#define Trap_pc(tp) (((code_t *)(tp))[0]) -#define Trap_link(tp) (((value **)(tp))[1]) - -void caml_init_stack (uintnat init_max_size); -void caml_realloc_stack (asize_t required_size); -void caml_change_max_stack_size (uintnat new_max_size); -uintnat caml_stack_usage (void); - -CAMLextern uintnat (*caml_stack_usage_hook)(void); - -#endif /* CAML_STACKS_H */ diff -Nru ocaml-4.01.0/byterun/startup_aux.c ocaml-4.05.0/byterun/startup_aux.c --- ocaml-4.01.0/byterun/startup_aux.c 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-4.05.0/byterun/startup_aux.c 2017-07-13 08:56:44.000000000 +0000 @@ -0,0 +1,106 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +/* Some runtime initialization functions that are common to bytecode + and native code. */ + +#include +#include "caml/backtrace.h" +#include "caml/memory.h" +#include "caml/osdeps.h" +#include "caml/startup_aux.h" + + +/* Initialize the atom table */ + +CAMLexport header_t caml_atom_table[256]; +void caml_init_atom_table(void) +{ + int i; + for(i = 0; i < 256; i++) { +#ifdef NATIVE_CODE + caml_atom_table[i] = Make_header_allocated_here(0, i, Caml_white); +#else + caml_atom_table[i] = Make_header(0, i, Caml_white); +#endif + } + if (caml_page_table_add(In_static_data, + caml_atom_table, caml_atom_table + 256) != 0) { + caml_fatal_error("Fatal error: not enough memory for initial page table"); + } +} + + +/* Parse the OCAMLRUNPARAM environment variable. */ + +uintnat caml_init_percent_free = Percent_free_def; +uintnat caml_init_max_percent_free = Max_percent_free_def; +uintnat caml_init_minor_heap_wsz = Minor_heap_def; +uintnat caml_init_heap_chunk_sz = Heap_chunk_def; +uintnat caml_init_heap_wsz = Init_heap_def; +uintnat caml_init_max_stack_wsz = Max_stack_def; +uintnat caml_init_major_window = Major_window_def; +extern int caml_parser_trace; +uintnat caml_trace_level = 0; + + +static void scanmult (char *opt, uintnat *var) +{ + char mult = ' '; + unsigned int val = 1; + sscanf (opt, "=%u%c", &val, &mult); + sscanf (opt, "=0x%x%c", &val, &mult); + switch (mult) { + case 'k': *var = (uintnat) val * 1024; break; + case 'M': *var = (uintnat) val * (1024 * 1024); break; + case 'G': *var = (uintnat) val * (1024 * 1024 * 1024); break; + default: *var = (uintnat) val; break; + } +} + +void caml_parse_ocamlrunparam(void) +{ + char *opt = caml_secure_getenv ("OCAMLRUNPARAM"); + uintnat p; + + if (opt == NULL) opt = caml_secure_getenv ("CAMLRUNPARAM"); + + if (opt != NULL){ + while (*opt != '\0'){ + switch (*opt++){ + case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; + case 'b': scanmult (opt, &p); caml_record_backtrace(Val_bool (p)); break; + case 'h': scanmult (opt, &caml_init_heap_wsz); break; + case 'H': scanmult (opt, &caml_use_huge_pages); break; + case 'i': scanmult (opt, &caml_init_heap_chunk_sz); break; + case 'l': scanmult (opt, &caml_init_max_stack_wsz); break; + case 'o': scanmult (opt, &caml_init_percent_free); break; + case 'O': scanmult (opt, &caml_init_max_percent_free); break; + case 'p': scanmult (opt, &p); caml_parser_trace = p; break; + case 'R': break; /* see stdlib/hashtbl.mli */ + case 's': scanmult (opt, &caml_init_minor_heap_wsz); break; + case 't': scanmult (opt, &caml_trace_level); break; + case 'v': scanmult (opt, &caml_verb_gc); break; + case 'w': scanmult (opt, &caml_init_major_window); break; + case 'W': scanmult (opt, &caml_runtime_warnings); break; + } + while (*opt != '\0'){ + if (*opt++ == ',') break; + } + } + } +} diff -Nru ocaml-4.01.0/byterun/startup.c ocaml-4.05.0/byterun/startup.c --- ocaml-4.01.0/byterun/startup.c 2013-08-01 09:18:15.000000000 +0000 +++ ocaml-4.05.0/byterun/startup.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,19 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Start-up code */ @@ -17,41 +21,42 @@ #include #include #include -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include #endif #ifdef _WIN32 #include #endif -#include "alloc.h" -#include "backtrace.h" -#include "callback.h" -#include "custom.h" -#include "debugger.h" -#include "dynlink.h" -#include "exec.h" -#include "fail.h" -#include "fix_code.h" -#include "freelist.h" -#include "gc_ctrl.h" -#include "instrtrace.h" -#include "interp.h" -#include "intext.h" -#include "io.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "osdeps.h" -#include "prims.h" -#include "printexc.h" -#include "reverse.h" -#include "signals.h" -#include "stacks.h" -#include "sys.h" -#include "startup.h" -#include "version.h" +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/callback.h" +#include "caml/custom.h" +#include "caml/debugger.h" +#include "caml/dynlink.h" +#include "caml/exec.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/freelist.h" +#include "caml/gc_ctrl.h" +#include "caml/instrtrace.h" +#include "caml/interp.h" +#include "caml/intext.h" +#include "caml/io.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/osdeps.h" +#include "caml/prims.h" +#include "caml/printexc.h" +#include "caml/reverse.h" +#include "caml/signals.h" +#include "caml/stacks.h" +#include "caml/sys.h" +#include "caml/startup.h" +#include "caml/startup_aux.h" +#include "caml/version.h" #ifndef O_BINARY #define O_BINARY 0 @@ -61,25 +66,9 @@ #define SEEK_END 2 #endif -extern int caml_parser_trace; - -CAMLexport header_t caml_atom_table[256]; - -/* Initialize the atom table */ - -static void init_atoms(void) -{ - int i; - for(i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white); - if (caml_page_table_add(In_static_data, - caml_atom_table, caml_atom_table + 256) != 0) { - caml_fatal_error("Fatal error: not enough memory for initial page table"); - } -} - /* Read the trailer of a bytecode file */ -static void fixup_endianness_trailer(uint32 * p) +static void fixup_endianness_trailer(uint32_t * p) { #ifndef ARCH_BIG_ENDIAN Reverse_32(p, p); @@ -108,11 +97,11 @@ char buf [2]; truename = caml_search_exe_in_path(*name); - *name = truename; caml_gc_message(0x100, "Opening bytecode executable %s\n", (uintnat) truename); fd = open(truename, O_RDONLY | O_BINARY); if (fd == -1) { + caml_stat_free(truename); caml_gc_message(0x100, "Cannot open file\n", 0); return FILE_NOT_FOUND; } @@ -120,6 +109,7 @@ err = read (fd, buf, 2); if (err < 2 || (buf [0] == '#' && buf [1] == '!')) { close(fd); + caml_stat_free(truename); caml_gc_message(0x100, "Rejected #! script\n", 0); return BAD_BYTECODE; } @@ -127,9 +117,11 @@ err = read_trailer(fd, trail); if (err != 0) { close(fd); + caml_stat_free(truename); caml_gc_message(0x100, "Not a bytecode executable\n", 0); return err; } + *name = truename; return fd; } @@ -153,7 +145,8 @@ Return the length of the section data in bytes, or -1 if no section found with that name. */ -int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name) +int32_t caml_seek_optional_section(int fd, struct exec_trailer *trail, + char *name) { long ofs; int i; @@ -172,9 +165,9 @@ /* Position fd at the beginning of the section having the given name. Return the length of the section data in bytes. */ -int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name) +int32_t caml_seek_section(int fd, struct exec_trailer *trail, char *name) { - int32 len = caml_seek_optional_section(fd, trail, name); + int32_t len = caml_seek_optional_section(fd, trail, name); if (len == -1) caml_fatal_error_arg("Fatal_error: section `%s' is missing\n", name); return len; @@ -185,7 +178,7 @@ static char * read_section(int fd, struct exec_trailer *trail, char *name) { - int32 len; + int32_t len; char * data; len = caml_seek_optional_section(fd, trail, name); @@ -222,15 +215,6 @@ */ -/* Configuration parameters and flags */ - -static uintnat percent_free_init = Percent_free_def; -static uintnat max_percent_free_init = Max_percent_free_def; -static uintnat minor_heap_init = Minor_heap_def; -static uintnat heap_chunk_init = Heap_chunk_def; -static uintnat heap_size_init = Init_heap_def; -static uintnat max_stack_init = Max_stack_def; - /* Parse options on the command line */ static int parse_command_line(char **argv) @@ -239,17 +223,15 @@ for(i = 1; argv[i] != NULL && argv[i][0] == '-'; i++) { switch(argv[i][1]) { -#ifdef DEBUG case 't': - caml_trace_flag++; + ++ caml_trace_level; /* ignored unless DEBUG mode */ break; -#endif case 'v': if (!strcmp (argv[i], "-version")){ - printf ("The OCaml runtime, version " OCAML_VERSION "\n"); + printf ("The OCaml runtime, version " OCAML_VERSION_STRING "\n"); exit (0); }else if (!strcmp (argv[i], "-vnum")){ - printf (OCAML_VERSION "\n"); + printf (OCAML_VERSION_STRING "\n"); exit (0); }else{ caml_verb_gc = 0x001+0x004+0x008+0x010+0x020; @@ -276,70 +258,21 @@ return i; } -/* Parse the OCAMLRUNPARAM variable */ -/* The option letter for each runtime option is the first letter of the - last word of the ML name of the option (see [stdlib/gc.mli]). - Except for l (maximum stack size) and h (initial heap size). -*/ - -/* If you change these functions, see also their copy in asmrun/startup.c */ - -static void scanmult (char *opt, uintnat *var) -{ - char mult = ' '; - unsigned int val; - sscanf (opt, "=%u%c", &val, &mult); - sscanf (opt, "=0x%x%c", &val, &mult); - switch (mult) { - case 'k': *var = (uintnat) val * 1024; break; - case 'M': *var = (uintnat) val * 1024 * 1024; break; - case 'G': *var = (uintnat) val * 1024 * 1024 * 1024; break; - default: *var = (uintnat) val; break; - } -} - -static void parse_camlrunparam(void) -{ - char *opt = getenv ("OCAMLRUNPARAM"); - uintnat p; - - if (opt == NULL) opt = getenv ("CAMLRUNPARAM"); - - if (opt != NULL){ - while (*opt != '\0'){ - switch (*opt++){ - case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; - case 'b': caml_record_backtrace(Val_true); break; - case 'h': scanmult (opt, &heap_size_init); break; - case 'i': scanmult (opt, &heap_chunk_init); break; - case 'l': scanmult (opt, &max_stack_init); break; - case 'o': scanmult (opt, &percent_free_init); break; - case 'O': scanmult (opt, &max_percent_free_init); break; - case 'p': caml_parser_trace = 1; break; - /* case 'R': see stdlib/hashtbl.mli */ - case 's': scanmult (opt, &minor_heap_init); break; -#ifdef DEBUG - case 't': caml_trace_flag = 1; break; -#endif - case 'v': scanmult (opt, &caml_verb_gc); break; - } - } - } -} - extern void caml_init_ieee_floats (void); #ifdef _WIN32 extern void caml_signal_thread(void * lpParam); #endif -#ifdef _MSC_VER +#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L /* PR 4887: avoid crash box of windows runtime on some system calls */ extern void caml_install_invalid_parameter_handler(); #endif +extern int ensure_spacetime_dot_o_is_included; + /* Main entry point when loading code from a file */ CAMLexport void caml_main(char **argv) @@ -349,15 +282,14 @@ struct channel * chan; value res; char * shared_lib_path, * shared_libs, * req_prims; - char * exe_name; -#ifdef __linux__ - static char proc_self_exe[256]; -#endif + char * exe_name, * proc_self_exe; + + ensure_spacetime_dot_o_is_included++; /* Machine-dependent initialization of the floating-point hardware so that it behaves as much as possible as specified in IEEE */ caml_init_ieee_floats(); -#ifdef _MSC_VER +#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L caml_install_invalid_parameter_handler(); #endif caml_init_custom_operations(); @@ -365,16 +297,30 @@ caml_external_raise = NULL; /* Determine options and position of bytecode file */ #ifdef DEBUG - caml_verb_gc = 0xBF; + caml_verb_gc = 0x3F; #endif - parse_camlrunparam(); + caml_parse_ocamlrunparam(); +#ifdef DEBUG + caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0); +#endif + pos = 0; + + /* First, try argv[0] (when ocamlrun is called by a bytecode program) */ exe_name = argv[0]; -#ifdef __linux__ - if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) - exe_name = proc_self_exe; -#endif fd = caml_attempt_open(&exe_name, &trail, 0); + + /* Little grasshopper wonders why we do that at all, since + "The current executable is ocamlrun itself, it's never a bytecode + program". Little grasshopper "ocamlc -custom" in mind should keep. + With -custom, we have an executable that is ocamlrun itself + concatenated with the bytecode. So, if the attempt with argv[0] + failed, it is worth trying again with executable_name. */ + if (fd < 0 && (proc_self_exe = caml_executable_name()) != NULL) { + exe_name = proc_self_exe; + fd = caml_attempt_open(&exe_name, &trail, 0); + } + if (fd < 0) { pos = parse_command_line(argv); if (argv[pos] == 0) @@ -395,10 +341,12 @@ /* Read the table of contents (section descriptors) */ caml_read_section_descriptors(fd, &trail); /* Initialize the abstract machine */ - caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, - percent_free_init, max_percent_free_init); - caml_init_stack (max_stack_init); - init_atoms(); + caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz, + caml_init_heap_chunk_sz, caml_init_percent_free, + caml_init_max_percent_free, caml_init_major_window); + caml_init_stack (caml_init_max_stack_wsz); + caml_init_atom_table(); + caml_init_backtrace(); /* Initialize the interpreter */ caml_interprete(NULL, 0); /* Initialize the debugger, if needed */ @@ -406,6 +354,7 @@ /* Load the code */ caml_code_size = caml_seek_section(fd, &trail, "CODE"); caml_load_code(fd, caml_code_size); + caml_init_debug_info(); /* Build the table of primitives */ shared_lib_path = read_section(fd, &trail, "DLPT"); shared_libs = read_section(fd, &trail, "DLLS"); @@ -425,11 +374,10 @@ caml_oldify_one (caml_global_data, &caml_global_data); caml_oldify_mopup (); /* Initialize system libraries */ - caml_init_exceptions(); caml_sys_init(exe_name, argv + pos); #ifdef _WIN32 /* Start a thread to handle signals */ - if (getenv("CAMLSIGPIPE")) + if (caml_secure_getenv("CAMLSIGPIPE")) _beginthread(caml_signal_thread, 4096, NULL); #endif /* Execute the program */ @@ -448,44 +396,38 @@ /* Main entry point when code is linked in as initialized data */ -CAMLexport void caml_startup_code( +CAMLexport value caml_startup_code_exn( code_t code, asize_t code_size, char *data, asize_t data_size, char *section_table, asize_t section_table_size, char **argv) { - value res; - char* cds_file; + char * cds_file; char * exe_name; -#ifdef __linux__ - static char proc_self_exe[256]; -#endif caml_init_ieee_floats(); -#ifdef _MSC_VER +#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L caml_install_invalid_parameter_handler(); #endif caml_init_custom_operations(); #ifdef DEBUG caml_verb_gc = 63; #endif - cds_file = getenv("CAML_DEBUG_FILE"); + cds_file = caml_secure_getenv("CAML_DEBUG_FILE"); if (cds_file != NULL) { - caml_cds_file = caml_stat_alloc(strlen(cds_file) + 1); - strcpy(caml_cds_file, cds_file); + caml_cds_file = caml_strdup(cds_file); } - parse_camlrunparam(); - exe_name = argv[0]; -#ifdef __linux__ - if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) - exe_name = proc_self_exe; -#endif + caml_parse_ocamlrunparam(); + exe_name = caml_executable_name(); + if (exe_name == NULL) exe_name = caml_search_exe_in_path(argv[0]); caml_external_raise = NULL; /* Initialize the abstract machine */ - caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, - percent_free_init, max_percent_free_init); - caml_init_stack (max_stack_init); - init_atoms(); + caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz, + caml_init_heap_chunk_sz, caml_init_percent_free, + caml_init_max_percent_free, caml_init_major_window); + caml_init_stack (caml_init_max_stack_wsz); + caml_init_atom_table(); + caml_init_backtrace(); /* Initialize the interpreter */ caml_interprete(NULL, 0); /* Initialize the debugger, if needed */ @@ -494,6 +436,7 @@ caml_start_code = code; caml_code_size = code_size; caml_init_code_fragments(); + caml_init_debug_info(); if (caml_debugger_in_use) { int len, i; len = code_size / sizeof(opcode_t); @@ -514,11 +457,23 @@ caml_section_table = section_table; caml_section_table_size = section_table_size; /* Initialize system libraries */ - caml_init_exceptions(); caml_sys_init(exe_name, argv); /* Execute the program */ caml_debugger(PROGRAM_START); - res = caml_interprete(caml_start_code, caml_code_size); + return caml_interprete(caml_start_code, caml_code_size); +} + +CAMLexport void caml_startup_code( + code_t code, asize_t code_size, + char *data, asize_t data_size, + char *section_table, asize_t section_table_size, + char **argv) +{ + value res; + + res = caml_startup_code_exn(code, code_size, data, data_size, + section_table, section_table_size, + argv); if (Is_exception_result(res)) { caml_exn_bucket = Extract_exception(res); if (caml_debugger_in_use) { diff -Nru ocaml-4.01.0/byterun/startup.h ocaml-4.05.0/byterun/startup.h --- ocaml-4.01.0/byterun/startup.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/startup.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,38 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_STARTUP_H -#define CAML_STARTUP_H - -#include "mlvalues.h" -#include "exec.h" - -CAMLextern void caml_main(char **argv); - -CAMLextern void caml_startup_code( - code_t code, asize_t code_size, - char *data, asize_t data_size, - char *section_table, asize_t section_table_size, - char **argv); - -enum { FILE_NOT_FOUND = -1, BAD_BYTECODE = -2 }; - -extern int caml_attempt_open(char **name, struct exec_trailer *trail, - int do_open_script); -extern void caml_read_section_descriptors(int fd, struct exec_trailer *trail); -extern int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, - char *name); -extern int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name); - - -#endif /* CAML_STARTUP_H */ diff -Nru ocaml-4.01.0/byterun/str.c ocaml-4.05.0/byterun/str.c --- ocaml-4.01.0/byterun/str.c 2012-12-19 16:22:30.000000000 +0000 +++ ocaml-4.05.0/byterun/str.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,28 +1,32 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Operations on strings */ #include #include -#include "alloc.h" -#include "fail.h" -#include "mlvalues.h" -#include "misc.h" -#ifdef HAS_LOCALE -#include -#endif +#include +#include +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/mlvalues.h" +#include "caml/misc.h" +/* returns a number of bytes (chars) */ CAMLexport mlsize_t caml_string_length(value s) { mlsize_t temp; @@ -31,6 +35,7 @@ return temp - Byte (s, temp); } +/* returns a value that represents a number of bytes (chars) */ CAMLprim value caml_ml_string_length(value s) { mlsize_t temp; @@ -39,6 +44,20 @@ return Val_long(temp - Byte (s, temp)); } +CAMLprim value caml_ml_bytes_length(value s) +{ + return caml_ml_string_length(s); +} + +CAMLexport int caml_string_is_c_safe (value s) +{ + return strlen(String_val(s)) == caml_string_length(s); +} + +/** + * [caml_create_string] is deprecated, + * use [caml_create_bytes] instead + */ CAMLprim value caml_create_string(value len) { mlsize_t size = Long_val(len); @@ -48,6 +67,18 @@ return caml_alloc_string(size); } +/* [len] is a value that represents a number of bytes (chars) */ +CAMLprim value caml_create_bytes(value len) +{ + mlsize_t size = Long_val(len); + if (size > Bsize_wsize (Max_wosize) - 1){ + caml_invalid_argument("Bytes.create"); + } + return caml_alloc_string(size); +} + + + CAMLprim value caml_string_get(value str, value index) { intnat idx = Long_val(index); @@ -55,7 +86,12 @@ return Val_int(Byte_u(str, idx)); } -CAMLprim value caml_string_set(value str, value index, value newval) +CAMLprim value caml_bytes_get(value str, value index) +{ + return caml_string_get(str, index); +} + +CAMLprim value caml_bytes_set(value str, value index, value newval) { intnat idx = Long_val(index); if (idx < 0 || idx >= caml_string_length(str)) caml_array_bound_error(); @@ -63,12 +99,22 @@ return Val_unit; } +/** + * [caml_string_set] is deprecated, + * use [caml_bytes_set] instead + */ +CAMLprim value caml_string_set(value str, value index, value newval) +{ + return caml_bytes_set(str,index,newval); +} + + CAMLprim value caml_string_get16(value str, value index) { intnat res; unsigned char b1, b2; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 1) caml_array_bound_error(); + if (idx < 0 || idx + 1 >= caml_string_length(str)) caml_array_bound_error(); b1 = Byte_u(str, idx); b2 = Byte_u(str, idx + 1); #ifdef ARCH_BIG_ENDIAN @@ -84,7 +130,7 @@ intnat res; unsigned char b1, b2, b3, b4; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 3) caml_array_bound_error(); + if (idx < 0 || idx + 3 >= caml_string_length(str)) caml_array_bound_error(); b1 = Byte_u(str, idx); b2 = Byte_u(str, idx + 1); b3 = Byte_u(str, idx + 2); @@ -97,19 +143,12 @@ return caml_copy_int32(res); } -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif - CAMLprim value caml_string_get64(value str, value index) { - uint32 reshi; - uint32 reslo; + uint64_t res; unsigned char b1, b2, b3, b4, b5, b6, b7, b8; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 7) caml_array_bound_error(); + if (idx < 0 || idx + 7 >= caml_string_length(str)) caml_array_bound_error(); b1 = Byte_u(str, idx); b2 = Byte_u(str, idx + 1); b3 = Byte_u(str, idx + 2); @@ -119,13 +158,17 @@ b7 = Byte_u(str, idx + 6); b8 = Byte_u(str, idx + 7); #ifdef ARCH_BIG_ENDIAN - reshi = b1 << 24 | b2 << 16 | b3 << 8 | b4; - reslo = b5 << 24 | b6 << 16 | b7 << 8 | b8; + res = (uint64_t) b1 << 56 | (uint64_t) b2 << 48 + | (uint64_t) b3 << 40 | (uint64_t) b4 << 32 + | (uint64_t) b5 << 24 | (uint64_t) b6 << 16 + | (uint64_t) b7 << 8 | (uint64_t) b8; #else - reshi = b8 << 24 | b7 << 16 | b6 << 8 | b5; - reslo = b4 << 24 | b3 << 16 | b2 << 8 | b1; + res = (uint64_t) b8 << 56 | (uint64_t) b7 << 48 + | (uint64_t) b6 << 40 | (uint64_t) b5 << 32 + | (uint64_t) b4 << 24 | (uint64_t) b3 << 16 + | (uint64_t) b2 << 8 | (uint64_t) b1; #endif - return caml_copy_int64(I64_literal(reshi,reslo)); + return caml_copy_int64(res); } CAMLprim value caml_string_set16(value str, value index, value newval) @@ -133,7 +176,7 @@ unsigned char b1, b2; intnat val; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 1) caml_array_bound_error(); + if (idx < 0 || idx + 1 >= caml_string_length(str)) caml_array_bound_error(); val = Long_val(newval); #ifdef ARCH_BIG_ENDIAN b1 = 0xFF & val >> 8; @@ -152,7 +195,7 @@ unsigned char b1, b2, b3, b4; intnat val; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 3) caml_array_bound_error(); + if (idx < 0 || idx + 3 >= caml_string_length(str)) caml_array_bound_error(); val = Int32_val(newval); #ifdef ARCH_BIG_ENDIAN b1 = 0xFF & val >> 24; @@ -175,30 +218,28 @@ CAMLprim value caml_string_set64(value str, value index, value newval) { unsigned char b1, b2, b3, b4, b5, b6, b7, b8; - uint32 lo,hi; - int64 val; + int64_t val; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 7) caml_array_bound_error(); + if (idx < 0 || idx + 7 >= caml_string_length(str)) caml_array_bound_error(); val = Int64_val(newval); - I64_split(val,hi,lo); #ifdef ARCH_BIG_ENDIAN - b1 = 0xFF & hi >> 24; - b2 = 0xFF & hi >> 16; - b3 = 0xFF & hi >> 8; - b4 = 0xFF & hi; - b5 = 0xFF & lo >> 24; - b6 = 0xFF & lo >> 16; - b7 = 0xFF & lo >> 8; - b8 = 0xFF & lo; + b1 = 0xFF & val >> 56; + b2 = 0xFF & val >> 48; + b3 = 0xFF & val >> 40; + b4 = 0xFF & val >> 32; + b5 = 0xFF & val >> 24; + b6 = 0xFF & val >> 16; + b7 = 0xFF & val >> 8; + b8 = 0xFF & val; #else - b8 = 0xFF & hi >> 24; - b7 = 0xFF & hi >> 16; - b6 = 0xFF & hi >> 8; - b5 = 0xFF & hi; - b4 = 0xFF & lo >> 24; - b3 = 0xFF & lo >> 16; - b2 = 0xFF & lo >> 8; - b1 = 0xFF & lo; + b8 = 0xFF & val >> 56; + b7 = 0xFF & val >> 48; + b6 = 0xFF & val >> 40; + b5 = 0xFF & val >> 32; + b4 = 0xFF & val >> 24; + b3 = 0xFF & val >> 16; + b2 = 0xFF & val >> 8; + b1 = 0xFF & val; #endif Byte_u(str, idx) = b1; Byte_u(str, idx + 1) = b2; @@ -225,11 +266,21 @@ return Val_true; } +CAMLprim value caml_bytes_equal(value s1, value s2) +{ + return caml_string_equal(s1,s2); +} + CAMLprim value caml_string_notequal(value s1, value s2) { return Val_not(caml_string_equal(s1, s2)); } +CAMLprim value caml_bytes_notequal(value s1, value s2) +{ + return caml_string_notequal(s1,s2); +} + CAMLprim value caml_string_compare(value s1, value s2) { mlsize_t len1, len2; @@ -246,56 +297,147 @@ return Val_int(0); } +CAMLprim value caml_bytes_compare(value s1, value s2) +{ + return caml_string_compare(s1,s2); +} + CAMLprim value caml_string_lessthan(value s1, value s2) { return caml_string_compare(s1, s2) < Val_int(0) ? Val_true : Val_false; } +CAMLprim value caml_bytes_lessthan(value s1, value s2) +{ + return caml_string_lessthan(s1,s2); +} + + CAMLprim value caml_string_lessequal(value s1, value s2) { return caml_string_compare(s1, s2) <= Val_int(0) ? Val_true : Val_false; } +CAMLprim value caml_bytes_lessequal(value s1, value s2) +{ + return caml_string_lessequal(s1,s2); +} + + CAMLprim value caml_string_greaterthan(value s1, value s2) { return caml_string_compare(s1, s2) > Val_int(0) ? Val_true : Val_false; } +CAMLprim value caml_bytes_greaterthan(value s1, value s2) +{ + return caml_string_greaterthan(s1,s2); +} + CAMLprim value caml_string_greaterequal(value s1, value s2) { return caml_string_compare(s1, s2) >= Val_int(0) ? Val_true : Val_false; } -CAMLprim value caml_blit_string(value s1, value ofs1, value s2, value ofs2, +CAMLprim value caml_bytes_greaterequal(value s1, value s2) +{ + return caml_string_greaterequal(s1,s2); +} + +CAMLprim value caml_blit_bytes(value s1, value ofs1, value s2, value ofs2, value n) { - memmove(&Byte(s2, Long_val(ofs2)), &Byte(s1, Long_val(ofs1)), Int_val(n)); + memmove(&Byte(s2, Long_val(ofs2)), &Byte(s1, Long_val(ofs1)), Long_val(n)); return Val_unit; } -CAMLprim value caml_fill_string(value s, value offset, value len, value init) +CAMLprim value caml_blit_string(value s1, value ofs1, value s2, value ofs2, + value n) +{ + return caml_blit_bytes (s1, ofs1, s2, ofs2, n); +} + +CAMLprim value caml_fill_bytes(value s, value offset, value len, value init) { memset(&Byte(s, Long_val(offset)), Int_val(init), Long_val(len)); return Val_unit; } -CAMLprim value caml_is_printable(value chr) +/** + * [caml_fill_string] is deprecated, use [caml_fill_bytes] instead + */ +CAMLprim value caml_fill_string(value s, value offset, value len, value init) { - int c; - -#ifdef HAS_LOCALE - static int locale_is_set = 0; - if (! locale_is_set) { - setlocale(LC_CTYPE, ""); - locale_is_set = 1; - } -#endif - c = Int_val(chr); - return Val_bool(isprint(c)); + return caml_fill_bytes (s, offset, len, init); } CAMLprim value caml_bitvect_test(value bv, value n) { - int pos = Int_val(n); + intnat pos = Long_val(n); return Val_int(Byte_u(bv, pos >> 3) & (1 << (pos & 7))); } + +CAMLexport value caml_alloc_sprintf(const char * format, ...) +{ + va_list args; + char buf[64]; + int n; + value res; + +#if !defined(_WIN32) || defined(_UCRT) + /* C99-compliant implementation */ + va_start(args, format); + /* "vsnprintf(dest, sz, format, args)" writes at most "sz" characters + into "dest", including the terminating '\0'. + It returns the number of characters of the formatted string, + excluding the terminating '\0'. */ + n = vsnprintf(buf, sizeof(buf), format, args); + va_end(args); + /* Allocate a Caml string with length "n" as computed by vsnprintf. */ + res = caml_alloc_string(n); + if (n < sizeof(buf)) { + /* All output characters were written to buf, including the + terminating '\0'. Just copy them to the result. */ + memcpy(String_val(res), buf, n); + } else { + /* Re-do the formatting, outputting directly in the Caml string. + Note that caml_alloc_string left room for a '\0' at position n, + so the size passed to vsnprintf is n+1. */ + va_start(args, format); + vsnprintf(String_val(res), n + 1, format, args); + va_end(args); + } + return res; +#else + /* Implementation specific to the Microsoft CRT library */ + va_start(args, format); + /* "_vsnprintf(dest, sz, format, args)" writes at most "sz" characters + into "dest". Let "len" be the number of characters of the formatted + string. + If "len" < "sz", a null terminator was appended, and "len" is returned. + If "len" == "sz", no null termination, and "len" is returned. + If "len" > "sz", a negative value is returned. */ + n = _vsnprintf(buf, sizeof(buf), format, args); + va_end(args); + if (n >= 0 && n <= sizeof(buf)) { + /* All output characters were written to buf. + "n" is the actual length of the output. + Copy the characters to a Caml string of length n. */ + res = caml_alloc_string(n); + memcpy(String_val(res), buf, n); + } else { + /* Determine actual length of output, excluding final '\0' */ + va_start(args, format); + n = _vscprintf(format, args); + va_end(args); + res = caml_alloc_string(n); + /* Re-do the formatting, outputting directly in the Caml string. + Note that caml_alloc_string left room for a '\0' at position n, + so the size passed to _vsnprintf is n+1. */ + va_start(args, format); + _vsnprintf(String_val(res), n + 1, format, args); + va_end(args); + } + return res; +#endif +} diff -Nru ocaml-4.01.0/byterun/sys.c ocaml-4.05.0/byterun/sys.c --- ocaml-4.01.0/byterun/sys.c 2012-11-29 09:55:00.000000000 +0000 +++ ocaml-4.05.0/byterun/sys.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,15 +1,19 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Basic system calls */ @@ -22,10 +26,12 @@ #include #include #include -#if !_WIN32 +#ifdef _WIN32 +#include /* for isatty */ +#else #include #endif -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include #endif @@ -39,15 +45,19 @@ #ifdef HAS_GETTIMEOFDAY #include #endif -#include "alloc.h" -#include "debugger.h" -#include "fail.h" -#include "instruct.h" -#include "mlvalues.h" -#include "osdeps.h" -#include "signals.h" -#include "stacks.h" -#include "sys.h" +#include "caml/alloc.h" +#include "caml/debugger.h" +#include "caml/fail.h" +#include "caml/gc_ctrl.h" +#include "caml/instruct.h" +#include "caml/io.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/stacks.h" +#include "caml/sys.h" +#include "caml/version.h" static char * error_message(void) { @@ -91,12 +101,50 @@ } } -CAMLprim value caml_sys_exit(value retcode) +/* Check that [name] can safely be used as a file path */ + +static void caml_sys_check_path(value name) +{ + if (! caml_string_is_c_safe(name)) { + errno = ENOENT; + caml_sys_error(name); + } +} + +CAMLprim value caml_sys_exit(value retcode_v) { + int retcode = Int_val(retcode_v); + + if ((caml_verb_gc & 0x400) != 0) { + /* cf caml_gc_counters */ + double minwords = caml_stat_minor_words + + (double) (caml_young_end - caml_young_ptr); + double prowords = caml_stat_promoted_words; + double majwords = caml_stat_major_words + (double) caml_allocated_words; + double allocated_words = minwords + majwords - prowords; + intnat mincoll = caml_stat_minor_collections; + intnat majcoll = caml_stat_major_collections; + intnat heap_words = caml_stat_heap_wsz; + intnat heap_chunks = caml_stat_heap_chunks; + intnat top_heap_words = caml_stat_top_heap_wsz; + intnat cpct = caml_stat_compactions; + caml_gc_message(0x400, "allocated_words: %ld\n", (long)allocated_words); + caml_gc_message(0x400, "minor_words: %ld\n", (long) minwords); + caml_gc_message(0x400, "promoted_words: %ld\n", (long) prowords); + caml_gc_message(0x400, "major_words: %ld\n", (long) majwords); + caml_gc_message(0x400, "minor_collections: %d\n", mincoll); + caml_gc_message(0x400, "major_collections: %d\n", majcoll); + caml_gc_message(0x400, "heap_words: %d\n", heap_words); + caml_gc_message(0x400, "heap_chunks: %d\n", heap_chunks); + caml_gc_message(0x400, "top_heap_words: %d\n", top_heap_words); + caml_gc_message(0x400, "compactions: %d\n", cpct); + } + #ifndef NATIVE_CODE caml_debugger(PROGRAM_EXIT); #endif - exit(Int_val(retcode)); + CAML_INSTR_ATEXIT (); + CAML_SYS_EXIT(retcode); return Val_unit; } @@ -125,13 +173,13 @@ int fd, flags, perm; char * p; - p = caml_stat_alloc(caml_string_length(path) + 1); - strcpy(p, String_val(path)); + caml_sys_check_path(path); + p = caml_strdup(String_val(path)); flags = caml_convert_flag_list(vflags, sys_open_flags); perm = Int_val(vperm); /* open on a named FIFO can block (PR#1533) */ caml_enter_blocking_section(); - fd = open(p, flags, perm); + fd = CAML_SYS_OPEN(p, flags, perm); /* fcntl on a fd can block (PR#5069)*/ #if defined(F_SETFD) && defined(FD_CLOEXEC) if (fd != -1) @@ -143,48 +191,116 @@ CAMLreturn(Val_long(fd)); } -CAMLprim value caml_sys_close(value fd) +CAMLprim value caml_sys_close(value fd_v) { - close(Int_val(fd)); + int fd = Int_val(fd_v); + caml_enter_blocking_section(); + CAML_SYS_CLOSE(fd); + caml_leave_blocking_section(); return Val_unit; } CAMLprim value caml_sys_file_exists(value name) { +#ifdef _WIN32 + struct _stati64 st; +#else struct stat st; - return Val_bool(stat(String_val(name), &st) == 0); +#endif + char * p; + int ret; + + if (! caml_string_is_c_safe(name)) return Val_false; + p = caml_strdup(String_val(name)); + caml_enter_blocking_section(); +#ifdef _WIN32 + ret = _stati64(p, &st); +#else + ret = CAML_SYS_STAT(p, &st); +#endif + caml_leave_blocking_section(); + caml_stat_free(p); + + return Val_bool(ret == 0); } CAMLprim value caml_sys_is_directory(value name) { + CAMLparam1(name); +#ifdef _WIN32 + struct _stati64 st; +#else struct stat st; - if (stat(String_val(name), &st) == -1) caml_sys_error(name); +#endif + char * p; + int ret; + + caml_sys_check_path(name); + p = caml_strdup(String_val(name)); + caml_enter_blocking_section(); +#ifdef _WIN32 + ret = _stati64(p, &st); +#else + ret = CAML_SYS_STAT(p, &st); +#endif + caml_leave_blocking_section(); + caml_stat_free(p); + + if (ret == -1) caml_sys_error(name); #ifdef S_ISDIR - return Val_bool(S_ISDIR(st.st_mode)); + CAMLreturn(Val_bool(S_ISDIR(st.st_mode))); #else - return Val_bool(st.st_mode & S_IFDIR); + CAMLreturn(Val_bool(st.st_mode & S_IFDIR)); #endif } CAMLprim value caml_sys_remove(value name) { + CAMLparam1(name); + char * p; int ret; - ret = unlink(String_val(name)); + caml_sys_check_path(name); + p = caml_strdup(String_val(name)); + caml_enter_blocking_section(); + ret = CAML_SYS_UNLINK(p); + caml_leave_blocking_section(); + caml_stat_free(p); if (ret != 0) caml_sys_error(name); - return Val_unit; + CAMLreturn(Val_unit); } CAMLprim value caml_sys_rename(value oldname, value newname) { - if (rename(String_val(oldname), String_val(newname)) != 0) + char * p_old; + char * p_new; + int ret; + caml_sys_check_path(oldname); + caml_sys_check_path(newname); + p_old = caml_strdup(String_val(oldname)); + p_new = caml_strdup(String_val(newname)); + caml_enter_blocking_section(); + ret = CAML_SYS_RENAME(p_old, p_new); + caml_leave_blocking_section(); + caml_stat_free(p_new); + caml_stat_free(p_old); + if (ret != 0) caml_sys_error(NO_ARG); return Val_unit; } CAMLprim value caml_sys_chdir(value dirname) { - if (chdir(String_val(dirname)) != 0) caml_sys_error(dirname); - return Val_unit; + CAMLparam1(dirname); + char * p; + int ret; + caml_sys_check_path(dirname); + p = caml_strdup(String_val(dirname)); + caml_enter_blocking_section(); + ret = CAML_SYS_CHDIR(p); + caml_leave_blocking_section(); + caml_stat_free(p); + if (ret != 0) caml_sys_error(dirname); + CAMLreturn(Val_unit); } CAMLprim value caml_sys_getcwd(value unit) @@ -198,17 +314,28 @@ return caml_copy_string(buff); } +CAMLprim value caml_sys_unsafe_getenv(value var) +{ + char * res; + + if (! caml_string_is_c_safe(var)) caml_raise_not_found(); + res = CAML_SYS_GETENV(String_val(var)); + if (res == 0) caml_raise_not_found(); + return caml_copy_string(res); +} + CAMLprim value caml_sys_getenv(value var) { char * res; - res = getenv(String_val(var)); + if (! caml_string_is_c_safe(var)) caml_raise_not_found(); + res = caml_secure_getenv(String_val(var)); if (res == 0) caml_raise_not_found(); return caml_copy_string(res); } char * caml_exe_name; -static char ** caml_main_argv; +char ** caml_main_argv; CAMLprim value caml_sys_get_argv(value unit) { @@ -224,6 +351,9 @@ void caml_sys_init(char * exe_name, char **argv) { +#ifdef CAML_WITH_CPLUGINS + caml_cplugins_init(exe_name, argv); +#endif caml_exe_name = exe_name; caml_main_argv = argv; } @@ -244,13 +374,14 @@ CAMLparam1 (command); int status, retcode; char *buf; - intnat len; - len = caml_string_length (command); - buf = caml_stat_alloc (len + 1); - memmove (buf, String_val (command), len + 1); + if (! caml_string_is_c_safe (command)) { + errno = EINVAL; + caml_sys_error(command); + } + buf = caml_strdup(String_val(command)); caml_enter_blocking_section (); - status = system(buf); + status = CAML_SYS_SYSTEM(buf); caml_leave_blocking_section (); caml_stat_free(buf); if (status == -1) caml_sys_error(command); @@ -261,14 +392,23 @@ CAMLreturn (Val_int(retcode)); } -CAMLprim value caml_sys_time(value unit) +double caml_sys_time_include_children_unboxed(value include_children) { #ifdef HAS_GETRUSAGE struct rusage ru; + double acc = 0.; getrusage (RUSAGE_SELF, &ru); - return caml_copy_double (ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6 - + ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6); + acc += ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6 + + ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6; + + if (Bool_val(include_children)) { + getrusage (RUSAGE_CHILDREN, &ru); + acc += ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6 + + ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6; + } + + return acc; #else #ifdef HAS_TIMES #ifndef CLK_TCK @@ -279,15 +419,35 @@ #endif #endif struct tms t; + clock_t acc = 0; times(&t); - return caml_copy_double((double)(t.tms_utime + t.tms_stime) / CLK_TCK); + acc += t.tms_utime + t.tms_stime; + if (Bool_val(include_children)) { + acc += t.tms_cutime + t.tms_cstime; + } + return (double)acc / CLK_TCK; #else - /* clock() is standard ANSI C */ - return caml_copy_double((double)clock() / CLOCKS_PER_SEC); + /* clock() is standard ANSI C. We have no way of getting + subprocess times in this branch. */ + return (double)clock() / CLOCKS_PER_SEC; #endif #endif } +CAMLprim value caml_sys_time_include_children(value include_children) +{ + return caml_copy_double(caml_sys_time_include_children_unboxed(include_children)); +} + +double caml_sys_time_unboxed(value unit) { + return caml_sys_time_include_children_unboxed(Val_false); +} + +CAMLprim value caml_sys_time(value unit) +{ + return caml_copy_double(caml_sys_time_unboxed(unit)); +} + #ifdef _WIN32 extern int caml_win32_random_seed (intnat data[16]); #endif @@ -343,26 +503,43 @@ #endif } +/* returns a value that represents a number of bits */ CAMLprim value caml_sys_const_word_size(value unit) { return Val_long(8 * sizeof(value)); } +/* returns a value that represents a number of bits */ +CAMLprim value caml_sys_const_int_size(value unit) +{ + return Val_long(8 * sizeof(value) - 1) ; +} + +/* returns a value that represents a number of words */ +CAMLprim value caml_sys_const_max_wosize(value unit) +{ + return Val_long(Max_wosize) ; +} + CAMLprim value caml_sys_const_ostype_unix(value unit) { - return Val_long(0 == strcmp(OCAML_OS_TYPE,"Unix")); + return Val_bool(0 == strcmp(OCAML_OS_TYPE,"Unix")); } CAMLprim value caml_sys_const_ostype_win32(value unit) { - return Val_long(0 == strcmp(OCAML_OS_TYPE,"Win32")); + return Val_bool(0 == strcmp(OCAML_OS_TYPE,"Win32")); } CAMLprim value caml_sys_const_ostype_cygwin(value unit) { - return Val_long(0 == strcmp(OCAML_OS_TYPE,"Cygwin")); + return Val_bool(0 == strcmp(OCAML_OS_TYPE,"Cygwin")); } +CAMLprim value caml_sys_const_backend_type(value unit) +{ + return Val_int(1); /* Bytecode backed */ +} CAMLprim value caml_sys_get_config(value unit) { CAMLparam0 (); /* unit is unused */ @@ -385,9 +562,17 @@ CAMLparam1(path); CAMLlocal1(result); struct ext_table tbl; + char * p; + int ret; + caml_sys_check_path(path); caml_ext_table_init(&tbl, 50); - if (caml_read_directory(String_val(path), &tbl) == -1){ + p = caml_strdup(String_val(path)); + caml_enter_blocking_section(); + ret = CAML_SYS_READ_DIRECTORY(p, &tbl); + caml_leave_blocking_section(); + caml_stat_free(p); + if (ret == -1){ caml_ext_table_free(&tbl, 1); caml_sys_error(path); } @@ -396,3 +581,91 @@ caml_ext_table_free(&tbl, 1); CAMLreturn(result); } + +/* Return true if the value is a filedescriptor (int) that is + * (presumably) open on an interactive terminal */ +CAMLprim value caml_sys_isatty(value chan) +{ + int fd; + value ret; + + fd = (Channel(chan))->fd; +#ifdef _WIN32 + ret = Val_bool(_isatty(fd)); + /* https://msdn.microsoft.com/en-us/library/f4s0ddew.aspx */ +#else + ret = Val_bool(isatty(fd)); +#endif + + return ret; +} + +/* Load dynamic plugins indicated in the CAML_CPLUGINS environment + variable. These plugins can be used to set currently existing + hooks, such as GC hooks and system calls tracing (see misc.h). + */ + +#ifdef CAML_WITH_CPLUGINS + +value (*caml_cplugins_prim)(int,value,value,value) = NULL; + +#define DLL_EXECUTABLE 1 +#define DLL_NOT_GLOBAL 0 + +static struct cplugin_context cplugin_context; + +void caml_load_plugin(char *plugin) +{ + void* dll_handle = NULL; + + dll_handle = caml_dlopen(plugin, DLL_EXECUTABLE, DLL_NOT_GLOBAL); + if( dll_handle != NULL ){ + void (* dll_init)(struct cplugin_context*) = + caml_dlsym(dll_handle, "caml_cplugin_init"); + if( dll_init != NULL ){ + cplugin_context.plugin=plugin; + dll_init(&cplugin_context); + } else { + caml_dlclose(dll_handle); + } + } else { + fprintf(stderr, "Cannot load C plugin %s\nReason: %s\n", + plugin, caml_dlerror()); + } +} + +void caml_cplugins_load(char *env_variable) +{ + char *plugins = caml_secure_getenv(env_variable); + if(plugins != NULL){ + char* curs = plugins; + while(*curs != 0){ + if(*curs == ','){ + if(curs > plugins){ + *curs = 0; + caml_load_plugin(plugins); + } + plugins = curs+1; + } + curs++; + } + if(curs > plugins) caml_load_plugin(plugins); + } +} + +void caml_cplugins_init(char * exe_name, char **argv) +{ + cplugin_context.api_version = CAML_CPLUGIN_CONTEXT_API; + cplugin_context.prims_bitmap = CAML_CPLUGINS_PRIMS_BITMAP; + cplugin_context.exe_name = exe_name; + cplugin_context.argv = argv; + cplugin_context.ocaml_version = OCAML_VERSION_STRING; + caml_cplugins_load("CAML_CPLUGINS"); +#ifdef NATIVE_CODE + caml_cplugins_load("CAML_NATIVE_CPLUGINS"); +#else + caml_cplugins_load("CAML_BYTE_CPLUGINS"); +#endif +} + +#endif /* CAML_WITH_CPLUGINS */ diff -Nru ocaml-4.01.0/byterun/sys.h ocaml-4.05.0/byterun/sys.h --- ocaml-4.01.0/byterun/sys.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/sys.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_SYS_H -#define CAML_SYS_H - -#include "misc.h" - -#define NO_ARG Val_int(0) - -CAMLextern void caml_sys_error (value); -CAMLextern void caml_sys_io_error (value); -extern void caml_sys_init (char * exe_name, char ** argv); -CAMLextern value caml_sys_exit (value); - -extern char * caml_exe_name; - -#endif /* CAML_SYS_H */ diff -Nru ocaml-4.01.0/byterun/terminfo.c ocaml-4.05.0/byterun/terminfo.c --- ocaml-4.01.0/byterun/terminfo.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/terminfo.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,23 +1,27 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Read and output terminal commands */ -#include "config.h" -#include "alloc.h" -#include "fail.h" -#include "io.h" -#include "mlvalues.h" +#include "caml/config.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/mlvalues.h" #define Uninitialised (Val_int(0)) #define Bad_term (Val_int(1)) @@ -72,7 +76,7 @@ static int terminfo_putc (int c) { - putch (chan, c); + caml_putch (chan, c); return c; } diff -Nru ocaml-4.01.0/byterun/ui.h ocaml-4.05.0/byterun/ui.h --- ocaml-4.01.0/byterun/ui.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/ui.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, 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. */ -/* */ -/***********************************************************************/ - -/* Function declarations for non-Unix user interfaces */ - -#ifndef CAML_UI_H -#define CAML_UI_H - -#include "config.h" - -void ui_exit (int return_code); -int ui_read (int file_desc, char *buf, unsigned int length); -int ui_write (int file_desc, char *buf, unsigned int length); -void ui_print_stderr (char *format, void *arg); - -#endif /* CAML_UI_H */ diff -Nru ocaml-4.01.0/byterun/unix.c ocaml-4.05.0/byterun/unix.c --- ocaml-4.01.0/byterun/unix.c 2013-03-09 22:38:52.000000000 +0000 +++ ocaml-4.05.0/byterun/unix.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,30 +1,36 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Unix-specific stuff */ #define _GNU_SOURCE /* Helps finding RTLD_DEFAULT in glibc */ + /* also secure_getenv */ #include #include #include #include #include +#include #include -#include "config.h" +#include "caml/config.h" #ifdef SUPPORT_DYNAMIC_LINKING -#ifdef __CYGWIN32__ +#ifdef __CYGWIN__ #include "flexdll.h" #else #include @@ -38,22 +44,81 @@ #else #include #endif -#include "memory.h" -#include "misc.h" -#include "osdeps.h" +#ifdef __APPLE__ +#include +#endif +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/sys.h" +#include "caml/io.h" #ifndef S_ISREG #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) #endif +#ifndef EINTR +#define EINTR (-1) +#endif +#ifndef EAGAIN +#define EAGAIN (-1) +#endif +#ifndef EWOULDBLOCK +#define EWOULDBLOCK (-1) +#endif + +int caml_read_fd(int fd, int flags, void * buf, int n) +{ + int retcode; + do { + caml_enter_blocking_section(); + retcode = read(fd, buf, n); + caml_leave_blocking_section(); + } while (retcode == -1 && errno == EINTR); + if (retcode == -1) caml_sys_io_error(NO_ARG); + return retcode; +} + +int caml_write_fd(int fd, int flags, void * buf, int n) +{ + int retcode; + again: +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + if (flags & CHANNEL_FLAG_BLOCKING_WRITE) { + retcode = write(fd, buf, n); + } else { +#endif + caml_enter_blocking_section(); + retcode = write(fd, buf, n); + caml_leave_blocking_section(); +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + } +#endif + if (retcode == -1) { + if (errno == EINTR) goto again; + if ((errno == EAGAIN || errno == EWOULDBLOCK) && n > 1) { + /* We couldn't do a partial write here, probably because + n <= PIPE_BUF and POSIX says that writes of less than + PIPE_BUF characters must be atomic. + We first try again with a partial write of 1 character. + If that fails too, we'll return an error code. */ + n = 1; goto again; + } + } + if (retcode == -1) caml_sys_io_error(NO_ARG); + CAMLassert (retcode > 0); + return retcode; +} + char * caml_decompose_path(struct ext_table * tbl, char * path) { char * p, * q; - int n; + size_t n; if (path == NULL) return NULL; - p = caml_stat_alloc(strlen(path) + 1); - strcpy(p, path); + p = caml_strdup(path); q = p; while (1) { for (n = 0; q[n] != 0 && q[n] != ':'; n++) /*nothing*/; @@ -68,7 +133,7 @@ char * caml_search_in_path(struct ext_table * path, char * name) { - char * p, * fullname; + char * p, * dir, * fullname; int i; struct stat st; @@ -76,21 +141,18 @@ if (*p == '/') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 2); - strcpy(fullname, (char *)(path->contents[i])); - if (fullname[0] != 0) strcat(fullname, "/"); - strcat(fullname, name); - if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; + dir = path->contents[i]; + if (dir[0] == 0) dir = "."; /* empty path component = current dir */ + fullname = caml_strconcat(3, dir, "/", name); + if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) + return fullname; caml_stat_free(fullname); } not_found: - fullname = caml_stat_alloc(strlen(name) + 1); - strcpy(fullname, name); - return fullname; + return caml_strdup(name); } -#ifdef __CYGWIN32__ +#ifdef __CYGWIN__ /* Cygwin needs special treatment because of the implicit ".exe" at the end of executable file names */ @@ -107,31 +169,28 @@ static char * cygwin_search_exe_in_path(struct ext_table * path, char * name) { - char * p, * fullname; + char * p, * dir, * fullname; int i; for (p = name; *p != 0; p++) { if (*p == '/' || *p == '\\') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 6); - strcpy(fullname, (char *)(path->contents[i])); - strcat(fullname, "/"); - strcat(fullname, name); + dir = path->contents[i]; + if (dir[0] == 0) dir = "."; /* empty path component = current dir */ + fullname = caml_strconcat(3, dir, "/", name); if (cygwin_file_exists(fullname)) return fullname; - strcat(fullname, ".exe"); + caml_stat_free(fullname); + fullname = caml_strconcat(4, dir, "/", name, ".exe"); if (cygwin_file_exists(fullname)) return fullname; caml_stat_free(fullname); } not_found: - fullname = caml_stat_alloc(strlen(name) + 5); - strcpy(fullname, name); + if (cygwin_file_exists(name)) return caml_strdup(name); + fullname = caml_strconcat(2, name, ".exe"); if (cygwin_file_exists(fullname)) return fullname; - strcat(fullname, ".exe"); - if (cygwin_file_exists(fullname)) return fullname; - strcpy(fullname, name); - return fullname; + caml_stat_free(fullname); + return caml_strdup(name); } #endif @@ -144,7 +203,7 @@ caml_ext_table_init(&path, 8); tofree = caml_decompose_path(&path, getenv("PATH")); -#ifndef __CYGWIN32__ +#ifndef __CYGWIN__ res = caml_search_in_path(&path, name); #else res = cygwin_search_exe_in_path(&path, name); @@ -156,17 +215,17 @@ char * caml_search_dll_in_path(struct ext_table * path, char * name) { - char * dllname = caml_stat_alloc(strlen(name) + 4); + char * dllname; char * res; - strcpy(dllname, name); - strcat(dllname, ".so"); + + dllname = caml_strconcat(2, name, ".so"); res = caml_search_in_path(path, dllname); caml_stat_free(dllname); return res; } #ifdef SUPPORT_DYNAMIC_LINKING -#ifdef __CYGWIN32__ +#ifdef __CYGWIN__ /* Use flexdll */ void * caml_dlopen(char * libname, int for_execution, int global) @@ -278,7 +337,7 @@ the directory named [dirname]. No entries are added for [.] and [..]. Return 0 on success, -1 on error; set errno in the case of error. */ -int caml_read_directory(char * dirname, struct ext_table * contents) +CAMLexport int caml_read_directory(char * dirname, struct ext_table * contents) { DIR * d; #ifdef HAS_DIRENT @@ -286,7 +345,6 @@ #else struct direct * e; #endif - char * p; d = opendir(dirname); if (d == NULL) return -1; @@ -294,9 +352,7 @@ e = readdir(d); if (e == NULL) break; if (strcmp(e->d_name, ".") == 0 || strcmp(e->d_name, "..") == 0) continue; - p = caml_stat_alloc(strlen(e->d_name) + 1); - strcpy(p, e->d_name); - caml_ext_table_add(contents, p); + caml_ext_table_add(contents, caml_strdup(e->d_name)); } closedir(d); return 0; @@ -304,21 +360,69 @@ /* Recover executable name from /proc/self/exe if possible */ -#ifdef __linux__ - -int caml_executable_name(char * name, int name_len) +char * caml_executable_name(void) { - int retcode; +#if defined(__linux__) + int namelen, retcode; + char * name; struct stat st; - retcode = readlink("/proc/self/exe", name, name_len); - if (retcode == -1 || retcode >= name_len) return -1; + /* lstat("/proc/self/exe") returns st_size == 0 so we cannot use it + to determine the size of the buffer. Instead, we guess and adjust. */ + namelen = 256; + while (1) { + name = caml_stat_alloc(namelen + 1); + retcode = readlink("/proc/self/exe", name, namelen); + if (retcode == -1) { caml_stat_free(name); return NULL; } + if (retcode <= namelen) break; + caml_stat_free(name); + if (namelen >= 1024*1024) return NULL; /* avoid runaway and overflow */ + namelen *= 2; + } + /* readlink() does not zero-terminate its result */ name[retcode] = 0; /* Make sure that the contents of /proc/self/exe is a regular file. (Old Linux kernels return an inode number instead.) */ - if (stat(name, &st) != 0) return -1; - if (! S_ISREG(st.st_mode)) return -1; - return 0; + if (stat(name, &st) == -1 || ! S_ISREG(st.st_mode)) { + caml_stat_free(name); return NULL; + } + return name; + +#elif defined(__APPLE__) + unsigned int namelen; + char * name; + + namelen = 256; + name = caml_stat_alloc(namelen); + if (_NSGetExecutablePath(name, &namelen) == 0) return name; + caml_stat_free(name); + /* Buffer is too small, but namelen now contains the size needed */ + name = caml_stat_alloc(namelen); + if (_NSGetExecutablePath(name, &namelen) == 0) return name; + caml_stat_free(name); + return NULL; + +#else + return NULL; + +#endif } +char *caml_secure_getenv (char const *var) +{ +#ifdef HAS_SECURE_GETENV + return secure_getenv (var); +#elif defined (HAS___SECURE_GETENV) + return __secure_getenv (var); +#elif defined(HAS_ISSETUGID) + if (!issetugid ()) + return CAML_SYS_GETENV (var); + else + return NULL; +#else + if (geteuid () == getuid () && getegid () == getgid ()) + return CAML_SYS_GETENV (var); + else + return NULL; #endif +} diff -Nru ocaml-4.01.0/byterun/weak.c ocaml-4.05.0/byterun/weak.c --- ocaml-4.01.0/byterun/weak.c 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/weak.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,48 +1,146 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, INRIA Rocquencourt */ +/* */ +/* Copyright 1997 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ -/* Operations on weak arrays */ +#define CAML_INTERNALS -#include +/* Operations on weak arrays and ephemerons (named ephe here)*/ -#include "alloc.h" -#include "fail.h" -#include "major_gc.h" -#include "memory.h" -#include "mlvalues.h" +#include -value caml_weak_list_head = 0; +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/weak.h" + +value caml_ephe_list_head = 0; + +static value ephe_dummy = 0; +value caml_ephe_none = (value) &ephe_dummy; + +#if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS) +/** The minor heap is considered alive. + Outside minor and major heap, x must be black. +*/ +static inline int Is_Dead_during_clean(value x){ + Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_clean); + return Is_block (x) && !Is_young (x) && Is_white_val(x); +} +/** The minor heap doesn't have to be marked, outside they should + already be black +*/ +static inline int Must_be_Marked_during_mark(value x){ + Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_mark); + return Is_block (x) && !Is_young (x); +} +#else +static inline int Is_Dead_during_clean(value x){ + Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_clean); + return Is_block (x) && Is_in_heap (x) && Is_white_val(x); +} +static inline int Must_be_Marked_during_mark(value x){ + Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_mark); + return Is_block (x) && Is_in_heap (x); +} +#endif -static value weak_dummy = 0; -value caml_weak_none = (value) &weak_dummy; -CAMLprim value caml_weak_create (value len) +/* [len] is a value that represents a number of words (fields) */ +CAMLprim value caml_ephe_create (value len) { mlsize_t size, i; value res; - size = Long_val (len) + 1; + size = Long_val (len) + 1 /* weak_list */ + 1 /* the value */; if (size <= 0 || size > Max_wosize) caml_invalid_argument ("Weak.create"); res = caml_alloc_shr (size, Abstract_tag); - for (i = 1; i < size; i++) Field (res, i) = caml_weak_none; - Field (res, 0) = caml_weak_list_head; - caml_weak_list_head = res; + for (i = 1; i < size; i++) Field (res, i) = caml_ephe_none; + Field (res, CAML_EPHE_LINK_OFFSET) = caml_ephe_list_head; + caml_ephe_list_head = res; return res; } +CAMLprim value caml_weak_create (value len) +{ + return caml_ephe_create(len); +} + +/** + Specificity of the cleaning phase (Phase_clean): + + The dead keys must be removed from the ephemerons and data removed + when one the keys is dead. Here we call it cleaning the ephemerons. + A specific phase of the GC is dedicated to this, Phase_clean. This + phase is just after the mark phase, so the white values are dead + values. It iterates the function caml_ephe_clean through all the + ephemerons. + + However the GC is incremental and ocaml code can run on the middle + of this cleaning phase. In order to respect the semantic of the + ephemerons concerning dead values, the getter and setter must work + as if the cleaning of all the ephemerons have been done at once. + + - key getter: Even if a dead key have not yet been replaced by + caml_ephe_none, getting it should return none. + - key setter: If we replace a dead key we need to set the data to + caml_ephe_none and clean the ephemeron. + + This two cases are dealt by a call to do_check_key_clean that + trigger the cleaning of the ephemerons when the accessed key is + dead. This test is fast. + + In the case of value getter and value setter, there is no fast + test because the removing of the data depend of the deadliness of the keys. + We must always try to clean the ephemerons. + + */ + #define None_val (Val_int(0)) #define Some_tag 0 +/* If we are in Phase_clean we need to check if the key + that is going to disappear is dead and so should trigger a cleaning + */ +static void do_check_key_clean(value ar, mlsize_t offset){ + Assert ( offset >= 2); + if (caml_gc_phase == Phase_clean){ + value elt = Field (ar, offset); + if (elt != caml_ephe_none && Is_Dead_during_clean(elt)){ + Field(ar,offset) = caml_ephe_none; + Field(ar,CAML_EPHE_DATA_OFFSET) = caml_ephe_none; + }; + }; +} + +/* If we are in Phase_clean we need to do as if the key is empty when + it will be cleaned during this phase */ +static inline int is_ephe_key_none(value ar, mlsize_t offset){ + value elt = Field (ar, offset); + if (elt == caml_ephe_none){ + return 1; + }else if (caml_gc_phase == Phase_clean && Is_Dead_during_clean(elt)){ + Field(ar,offset) = caml_ephe_none; + Field(ar,CAML_EPHE_DATA_OFFSET) = caml_ephe_none; + return 1; + } else { + return 0; + } +} + + static void do_set (value ar, mlsize_t offset, value v) { if (Is_block (v) && Is_young (v)){ @@ -50,50 +148,119 @@ value old = Field (ar, offset); Field (ar, offset) = v; if (!(Is_block (old) && Is_young (old))){ - if (caml_weak_ref_table.ptr >= caml_weak_ref_table.limit){ - CAMLassert (caml_weak_ref_table.ptr == caml_weak_ref_table.limit); - caml_realloc_ref_table (&caml_weak_ref_table); - } - *caml_weak_ref_table.ptr++ = &Field (ar, offset); + add_to_ephe_ref_table (&caml_ephe_ref_table, ar, offset); } }else{ Field (ar, offset) = v; } } -CAMLprim value caml_weak_set (value ar, value n, value el) +CAMLprim value caml_ephe_set_key (value ar, value n, value el) { - mlsize_t offset = Long_val (n) + 1; + mlsize_t offset = Long_val (n) + 2; Assert (Is_in_heap (ar)); - if (offset < 1 || offset >= Wosize_val (ar)){ + if (offset < 2 || offset >= Wosize_val (ar)){ caml_invalid_argument ("Weak.set"); } + do_check_key_clean(ar,offset); + do_set (ar, offset, el); + return Val_unit; +} + +CAMLprim value caml_ephe_unset_key (value ar, value n) +{ + mlsize_t offset = Long_val (n) + 2; + Assert (Is_in_heap (ar)); + if (offset < 2 || offset >= Wosize_val (ar)){ + caml_invalid_argument ("Weak.set"); + } + do_check_key_clean(ar,offset); + Field (ar, offset) = caml_ephe_none; + return Val_unit; +} + +value caml_ephe_set_key_option (value ar, value n, value el) +{ + mlsize_t offset = Long_val (n) + 2; + Assert (Is_in_heap (ar)); + if (offset < 2 || offset >= Wosize_val (ar)){ + caml_invalid_argument ("Weak.set"); + } + do_check_key_clean(ar,offset); if (el != None_val && Is_block (el)){ Assert (Wosize_val (el) == 1); do_set (ar, offset, Field (el, 0)); }else{ - Field (ar, offset) = caml_weak_none; + Field (ar, offset) = caml_ephe_none; } return Val_unit; } +CAMLprim value caml_weak_set (value ar, value n, value el){ + return caml_ephe_set_key_option(ar,n,el); +} + +CAMLprim value caml_ephe_set_data (value ar, value el) +{ + Assert (Is_in_heap (ar)); + if (caml_gc_phase == Phase_clean){ + /* During this phase since we don't know which ephemeron have been + cleaned we always need to check it. */ + caml_ephe_clean(ar); + }; + do_set (ar, 1, el); + return Val_unit; +} + +CAMLprim value caml_ephe_unset_data (value ar) +{ + Assert (Is_in_heap (ar)); + Field (ar, CAML_EPHE_DATA_OFFSET) = caml_ephe_none; + return Val_unit; +} + + #define Setup_for_gc #define Restore_after_gc -CAMLprim value caml_weak_get (value ar, value n) +CAMLprim value caml_ephe_get_key (value ar, value n) { CAMLparam2 (ar, n); - mlsize_t offset = Long_val (n) + 1; + mlsize_t offset = Long_val (n) + 2; CAMLlocal2 (res, elt); Assert (Is_in_heap (ar)); - if (offset < 1 || offset >= Wosize_val (ar)){ - caml_invalid_argument ("Weak.get"); + if (offset < 2 || offset >= Wosize_val (ar)){ + caml_invalid_argument ("Weak.get_key"); } - if (Field (ar, offset) == caml_weak_none){ + if (is_ephe_key_none(ar, offset)){ res = None_val; }else{ elt = Field (ar, offset); - if (caml_gc_phase == Phase_mark && Is_block (elt) && Is_in_heap (elt)){ + if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(elt)){ + caml_darken (elt, NULL); + } + res = caml_alloc_small (1, Some_tag); + Field (res, 0) = elt; + } + CAMLreturn (res); +} + +CAMLprim value caml_weak_get (value ar, value n){ + return caml_ephe_get_key(ar, n); +} + +CAMLprim value caml_ephe_get_data (value ar) +{ + CAMLparam1 (ar); + mlsize_t offset = 1; + CAMLlocal2 (res, elt); + Assert (Is_in_heap (ar)); + elt = Field (ar, offset); + if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar); + if (elt == caml_ephe_none){ + res = None_val; + }else{ + if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(elt)){ caml_darken (elt, NULL); } res = caml_alloc_small (1, Some_tag); @@ -105,29 +272,30 @@ #undef Setup_for_gc #undef Restore_after_gc -CAMLprim value caml_weak_get_copy (value ar, value n) +CAMLprim value caml_ephe_get_key_copy (value ar, value n) { CAMLparam2 (ar, n); - mlsize_t offset = Long_val (n) + 1; + mlsize_t offset = Long_val (n) + 2; CAMLlocal2 (res, elt); value v; /* Caution: this is NOT a local root. */ Assert (Is_in_heap (ar)); if (offset < 1 || offset >= Wosize_val (ar)){ - caml_invalid_argument ("Weak.get"); + caml_invalid_argument ("Weak.get_copy"); } + if (is_ephe_key_none(ar, offset)) CAMLreturn (None_val); v = Field (ar, offset); - if (v == caml_weak_none) CAMLreturn (None_val); - if (Is_block (v) && Is_in_heap_or_young(v)) { + /** Don't copy custom_block #7279 */ + if (Is_block (v) && Is_in_heap_or_young(v) && Tag_val(v) != Custom_tag ) { elt = caml_alloc (Wosize_val (v), Tag_val (v)); /* The GC may erase or move v during this call to caml_alloc. */ v = Field (ar, offset); - if (v == caml_weak_none) CAMLreturn (None_val); + if (is_ephe_key_none(ar, offset)) CAMLreturn (None_val); if (Tag_val (v) < No_scan_tag){ mlsize_t i; for (i = 0; i < Wosize_val (v); i++){ value f = Field (v, i); - if (caml_gc_phase == Phase_mark && Is_block (f) && Is_in_heap (f)){ + if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(f)){ caml_darken (f, NULL); } Modify (&Field (elt, i), f); @@ -136,6 +304,9 @@ memmove (Bp_val (elt), Bp_val (v), Bosize_val (v)); } }else{ + if ( caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(v) ){ + caml_darken (v, NULL); + }; elt = v; } res = caml_alloc_small (1, Some_tag); @@ -144,21 +315,78 @@ CAMLreturn (res); } -CAMLprim value caml_weak_check (value ar, value n) +CAMLprim value caml_weak_get_copy (value ar, value n){ + return caml_ephe_get_key_copy(ar,n); +} + +CAMLprim value caml_ephe_get_data_copy (value ar) { - mlsize_t offset = Long_val (n) + 1; + CAMLparam1 (ar); + mlsize_t offset = 1; + CAMLlocal2 (res, elt); + value v; /* Caution: this is NOT a local root. */ Assert (Is_in_heap (ar)); - if (offset < 1 || offset >= Wosize_val (ar)){ - caml_invalid_argument ("Weak.get"); + + v = Field (ar, offset); + if (caml_gc_phase == Phase_clean) caml_ephe_clean(ar); + if (v == caml_ephe_none) CAMLreturn (None_val); + /** Don't copy custom_block #7279 */ + if (Is_block (v) && Is_in_heap_or_young(v) && Tag_val(v) != Custom_tag ) { + elt = caml_alloc (Wosize_val (v), Tag_val (v)); + /* The GC may erase or move v during this call to caml_alloc. */ + v = Field (ar, offset); + if (caml_gc_phase == Phase_clean) caml_ephe_clean(ar); + if (v == caml_ephe_none) CAMLreturn (None_val); + if (Tag_val (v) < No_scan_tag){ + mlsize_t i; + for (i = 0; i < Wosize_val (v); i++){ + value f = Field (v, i); + if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(f)){ + caml_darken (f, NULL); + } + Modify (&Field (elt, i), f); + } + }else{ + memmove (Bp_val (elt), Bp_val (v), Bosize_val (v)); + } + }else{ + if ( caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(v) ){ + caml_darken (v, NULL); + }; + elt = v; } - return Val_bool (Field (ar, offset) != caml_weak_none); + res = caml_alloc_small (1, Some_tag); + Field (res, 0) = elt; + + CAMLreturn (res); } -CAMLprim value caml_weak_blit (value ars, value ofs, +CAMLprim value caml_ephe_check_key (value ar, value n) +{ + mlsize_t offset = Long_val (n) + 2; + Assert (Is_in_heap (ar)); + if (offset < 2 || offset >= Wosize_val (ar)){ + caml_invalid_argument ("Weak.check"); + } + return Val_bool (!is_ephe_key_none(ar, offset)); +} + +CAMLprim value caml_weak_check (value ar, value n) +{ + return caml_ephe_check_key(ar,n); +} + +CAMLprim value caml_ephe_check_data (value ar) +{ + if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar); + return Val_bool (Field (ar, CAML_EPHE_DATA_OFFSET) != caml_ephe_none); +} + +CAMLprim value caml_ephe_blit_key (value ars, value ofs, value ard, value ofd, value len) { - mlsize_t offset_s = Long_val (ofs) + 1; - mlsize_t offset_d = Long_val (ofd) + 1; + mlsize_t offset_s = Long_val (ofs) + 2; + mlsize_t offset_d = Long_val (ofd) + 2; mlsize_t length = Long_val (len); long i; Assert (Is_in_heap (ars)); @@ -169,14 +397,9 @@ if (offset_d < 1 || offset_d + length > Wosize_val (ard)){ caml_invalid_argument ("Weak.blit"); } - if (caml_gc_phase == Phase_mark && caml_gc_subphase == Subphase_weak1){ - for (i = 0; i < length; i++){ - value v = Field (ars, offset_s + i); - if (v != caml_weak_none && Is_block (v) && Is_in_heap (v) - && Is_white_val (v)){ - Field (ars, offset_s + i) = caml_weak_none; - } - } + if (caml_gc_phase == Phase_clean){ + caml_ephe_clean(ars); + caml_ephe_clean(ard); } if (offset_d < offset_s){ for (i = 0; i < length; i++){ @@ -189,3 +412,19 @@ } return Val_unit; } + +CAMLprim value caml_ephe_blit_data (value ars, value ard) +{ + if(caml_gc_phase == Phase_clean) { + caml_ephe_clean(ars); + caml_ephe_clean(ard); + }; + do_set (ard, CAML_EPHE_DATA_OFFSET, Field (ars, CAML_EPHE_DATA_OFFSET)); + return Val_unit; +} + +CAMLprim value caml_weak_blit (value ars, value ofs, + value ard, value ofd, value len) +{ + return caml_ephe_blit_key (ars, ofs, ard, ofd, len); +} diff -Nru ocaml-4.01.0/byterun/weak.h ocaml-4.05.0/byterun/weak.h --- ocaml-4.01.0/byterun/weak.h 2012-10-15 17:50:56.000000000 +0000 +++ ocaml-4.05.0/byterun/weak.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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. */ -/* */ -/***********************************************************************/ - -/* Operations on weak arrays */ - -#ifndef CAML_WEAK_H -#define CAML_WEAK_H - -#include "mlvalues.h" - -extern value caml_weak_list_head; -extern value caml_weak_none; - -#endif /* CAML_WEAK_H */ diff -Nru ocaml-4.01.0/byterun/win32.c ocaml-4.05.0/byterun/win32.c --- ocaml-4.01.0/byterun/win32.c 2013-06-06 11:39:51.000000000 +0000 +++ ocaml-4.05.0/byterun/win32.c 2017-07-13 08:56:44.000000000 +0000 @@ -1,21 +1,29 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS /* Win32-specific stuff */ -#include +#define WIN32_LEAN_AND_MEAN +#include +#include +#include #include #include +#include #include #include #include @@ -24,27 +32,108 @@ #include #include #include -#include "fail.h" -#include "memory.h" -#include "misc.h" -#include "osdeps.h" -#include "signals.h" -#include "sys.h" +#include "caml/alloc.h" +#include "caml/address_class.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/sys.h" +#include "caml/config.h" +#ifdef SUPPORT_DYNAMIC_LINKING #include +#endif #ifndef S_ISREG #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) #endif +/* Very old Microsoft headers don't include intptr_t */ +#if defined(_MSC_VER) && !defined(_UINTPTR_T_DEFINED) +typedef unsigned int uintptr_t; +#define _UINTPTR_T_DEFINED +#endif + +CAMLnoreturn_start +static void caml_win32_sys_error (int errnum) +CAMLnoreturn_end; + +static void caml_win32_sys_error(int errnum) +{ + char buffer[512]; + value msg; + if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, + errnum, + 0, + buffer, + sizeof(buffer), + NULL)) { + msg = caml_copy_string(buffer); + } else { + msg = caml_alloc_sprintf("unknown error #%d", errnum); + } + caml_raise_sys_error(msg); +} + +int caml_read_fd(int fd, int flags, void * buf, int n) +{ + int retcode; + if ((flags & CHANNEL_FLAG_FROM_SOCKET) == 0) { + caml_enter_blocking_section(); + retcode = read(fd, buf, n); + /* Large reads from console can fail with ENOMEM. Reduce requested size + and try again. */ + if (retcode == -1 && errno == ENOMEM && n > 16384) { + retcode = read(fd, buf, 16384); + } + caml_leave_blocking_section(); + if (retcode == -1) caml_sys_io_error(NO_ARG); + } else { + caml_enter_blocking_section(); + retcode = recv((SOCKET) _get_osfhandle(fd), buf, n, 0); + caml_leave_blocking_section(); + if (retcode == -1) caml_win32_sys_error(WSAGetLastError()); + } + return retcode; +} + +int caml_write_fd(int fd, int flags, void * buf, int n) +{ + int retcode; + if ((flags & CHANNEL_FLAG_FROM_SOCKET) == 0) { +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + if (flags & CHANNEL_FLAG_BLOCKING_WRITE) { + retcode = write(fd, buf, n); + } else { +#endif + caml_enter_blocking_section(); + retcode = write(fd, buf, n); + caml_leave_blocking_section(); +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + } +#endif + if (retcode == -1) caml_sys_io_error(NO_ARG); + } else { + caml_enter_blocking_section(); + retcode = send((SOCKET) _get_osfhandle(fd), buf, n, 0); + caml_leave_blocking_section(); + if (retcode == -1) caml_win32_sys_error(WSAGetLastError()); + } + CAMLassert (retcode > 0); + return retcode; +} + char * caml_decompose_path(struct ext_table * tbl, char * path) { char * p, * q; int n; if (path == NULL) return NULL; - p = caml_stat_alloc(strlen(path) + 1); - strcpy(p, path); + p = caml_strdup(path); q = p; while (1) { for (n = 0; q[n] != 0 && q[n] != ';'; n++) /*nothing*/; @@ -59,7 +148,7 @@ char * caml_search_in_path(struct ext_table * path, char * name) { - char * p, * fullname; + char * p, * dir, * fullname; int i; struct stat st; @@ -67,61 +156,62 @@ if (*p == '/' || *p == '\\') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 2); - strcpy(fullname, (char *)(path->contents[i])); - strcat(fullname, "\\"); - strcat(fullname, name); + dir = path->contents[i]; + if (dir[0] == 0) continue; + /* not sure what empty path components mean under Windows */ + fullname = caml_strconcat(3, dir, "\\", name); caml_gc_message(0x100, "Searching %s\n", (uintnat) fullname); - if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; + if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) + return fullname; caml_stat_free(fullname); } not_found: caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name); - fullname = caml_stat_alloc(strlen(name) + 1); - strcpy(fullname, name); - return fullname; + return caml_strdup(name); } CAMLexport char * caml_search_exe_in_path(char * name) { char * fullname, * filepart; - DWORD pathlen, retcode; + size_t fullnamelen; + DWORD retcode; - pathlen = strlen(name) + 1; - if (pathlen < 256) pathlen = 256; + fullnamelen = strlen(name) + 1; + if (fullnamelen < 256) fullnamelen = 256; while (1) { - fullname = caml_stat_alloc(pathlen); + fullname = caml_stat_alloc(fullnamelen); retcode = SearchPath(NULL, /* use system search path */ name, ".exe", /* add .exe extension if needed */ - pathlen, + fullnamelen, fullname, &filepart); if (retcode == 0) { caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name); - strcpy(fullname, name); - break; + caml_stat_free(fullname); + return caml_strdup(name); } - if (retcode < pathlen) break; + if (retcode < fullnamelen) + return fullname; caml_stat_free(fullname); - pathlen = retcode + 1; + fullnamelen = retcode + 1; } - return fullname; } char * caml_search_dll_in_path(struct ext_table * path, char * name) { - char * dllname = caml_stat_alloc(strlen(name) + 5); + char * dllname; char * res; - strcpy(dllname, name); - strcat(dllname, ".dll"); + + dllname = caml_strconcat(2, name, ".dll"); res = caml_search_in_path(path, dllname); caml_stat_free(dllname); return res; } +#ifdef SUPPORT_DYNAMIC_LINKING + void * caml_dlopen(char * libname, int for_execution, int global) { void *handle; @@ -155,6 +245,34 @@ return flexdll_dlerror(); } +#else + +void * caml_dlopen(char * libname, int for_execution, int global) +{ + return NULL; +} + +void caml_dlclose(void * handle) +{ +} + +void * caml_dlsym(void * handle, char * name) +{ + return NULL; +} + +void * caml_globalsym(char * name) +{ + return NULL; +} + +char * caml_dlerror(void) +{ + return "dynamic loading not supported on this platform"; +} + +#endif + /* Proper emulation of signal(), including ctrl-C and ctrl-break */ typedef void (*sighandler)(int sig); @@ -235,27 +353,32 @@ static void expand_pattern(char * pat) { + char * prefix, * p, * name; int handle; struct _finddata_t ffblk; - int preflen; + size_t i; handle = _findfirst(pat, &ffblk); if (handle == -1) { store_argument(pat); /* a la Bourne shell */ return; } - for (preflen = strlen(pat); preflen > 0; preflen--) { - char c = pat[preflen - 1]; - if (c == '\\' || c == '/' || c == ':') break; - } + prefix = caml_strdup(pat); + /* We need to stop at the first directory or drive boundary, because the + * _findata_t structure contains the filename, not the leading directory. */ + for (i = strlen(prefix); i > 0; i--) { + char c = prefix[i - 1]; + if (c == '\\' || c == '/' || c == ':') { prefix[i] = 0; break; } + } + /* No separator was found, it's a filename pattern without a leading directory. */ + if (i == 0) + prefix[0] = 0; do { - char * name = malloc(preflen + strlen(ffblk.name) + 1); - if (name == NULL) out_of_memory(); - memcpy(name, pat, preflen); - strcpy(name + preflen, ffblk.name); + name = caml_strconcat(2, prefix, ffblk.name); store_argument(name); } while (_findnext(handle, &ffblk) != -1); _findclose(handle); + caml_stat_free(prefix); } @@ -278,7 +401,7 @@ int caml_read_directory(char * dirname, struct ext_table * contents) { - int dirnamelen; + size_t dirnamelen; char * template; #if _MSC_VER <= 1200 int h; @@ -286,28 +409,27 @@ intptr_t h; #endif struct _finddata_t fileinfo; - char * p; dirnamelen = strlen(dirname); - template = caml_stat_alloc(dirnamelen + 5); - strcpy(template, dirname); - switch (dirname[dirnamelen - 1]) { - case '/': case '\\': case ':': - strcat(template, "*.*"); break; - default: - strcat(template, "\\*.*"); - } + if (dirnamelen > 0 && + (dirname[dirnamelen - 1] == '/' + || dirname[dirnamelen - 1] == '\\' + || dirname[dirnamelen - 1] == ':')) + template = caml_strconcat(2, dirname, "*.*"); + else + template = caml_strconcat(2, dirname, "\\*.*"); h = _findfirst(template, &fileinfo); - caml_stat_free(template); - if (h == -1) return errno == ENOENT ? 0 : -1; + if (h == -1) { + caml_stat_free(template); + return errno == ENOENT ? 0 : -1; + } do { if (strcmp(fileinfo.name, ".") != 0 && strcmp(fileinfo.name, "..") != 0) { - p = caml_stat_alloc(strlen(fileinfo.name) + 1); - strcpy(p, fileinfo.name); - caml_ext_table_add(contents, p); + caml_ext_table_add(contents, caml_strdup(fileinfo.name)); } } while (_findnext(h, &fileinfo) == 0); _findclose(h); + caml_stat_free(template); return 0; } @@ -320,7 +442,8 @@ char *endptr; HANDLE h; /* Get an hexa-code raw handle through the environment */ - h = (HANDLE) strtol(getenv("CAMLSIGPIPE"), &endptr, 16); + h = (HANDLE) (uintptr_t) + strtol(caml_secure_getenv("CAMLSIGPIPE"), &endptr, 16); while (1) { DWORD numread; BOOL ret; @@ -420,14 +543,8 @@ caml_raise_stack_overflow(); } -extern char * caml_code_area_start, * caml_code_area_end; CAMLextern int caml_is_in_code(void *); -#define Is_in_code_area(pc) \ - ( ((char *)(pc) >= caml_code_area_start && \ - (char *)(pc) <= caml_code_area_end) \ - || (Classify_addr(pc) & In_code_area) ) - static LONG CALLBACK caml_UnhandledExceptionFilter (EXCEPTION_POINTERS* exn_info) { @@ -484,7 +601,7 @@ } -#ifdef _MSC_VER +#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L static void invalid_parameter_handler(const wchar_t* expression, const wchar_t* function, @@ -502,3 +619,79 @@ } #endif + + +/* Recover executable name */ + +char * caml_executable_name(void) +{ + char * name; + DWORD namelen, ret; + + namelen = 256; + while (1) { + name = caml_stat_alloc(namelen); + ret = GetModuleFileName(NULL, name, namelen); + if (ret == 0) { caml_stat_free(name); return NULL; } + if (ret < namelen) break; + caml_stat_free(name); + if (namelen >= 1024*1024) return NULL; /* avoid runaway and overflow */ + namelen *= 2; + } + return name; +} + +/* snprintf emulation */ + +#ifdef LACKS_VSCPRINTF +/* No _vscprintf until Visual Studio .NET 2002 and sadly no version number + in the CRT headers until Visual Studio 2005 so forced to predicate this + on the compiler version instead */ +int _vscprintf(const char * format, va_list args) +{ + int n; + int sz = 5; + char* buf = (char*)malloc(sz); + n = _vsnprintf(buf, sz, format, args); + while (n < 0 || n > sz) { + sz += 512; + buf = (char*)realloc(buf, sz); + n = _vsnprintf(buf, sz, format, args); + } + free(buf); + return n; +} +#endif + +#if defined(_WIN32) && !defined(_UCRT) +int caml_snprintf(char * buf, size_t size, const char * format, ...) +{ + int len; + va_list args; + + if (size > 0) { + va_start(args, format); + len = _vsnprintf(buf, size, format, args); + va_end(args); + if (len >= 0 && len < size) { + /* [len] characters were stored in [buf], + a null-terminator was appended. */ + return len; + } + /* [size] characters were stored in [buf], without null termination. + Put a null terminator, truncating the output. */ + buf[size - 1] = 0; + } + /* Compute the actual length of output, excluding null terminator */ + va_start(args, format); + len = _vscprintf(format, args); + va_end(args); + return len; +} +#endif + +char *caml_secure_getenv (char const *var) +{ + /* Win32 doesn't have a notion of setuid bit, so getenv is safe. */ + return CAML_SYS_GETENV (var); +} diff -Nru ocaml-4.01.0/camlp4/boot/Camlp4Ast.ml ocaml-4.05.0/camlp4/boot/Camlp4Ast.ml --- ocaml-4.01.0/camlp4/boot/Camlp4Ast.ml 2013-08-30 11:39:33.000000000 +0000 +++ ocaml-4.05.0/camlp4/boot/Camlp4Ast.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,6219 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = - struct - module Loc = Loc; - module Ast = - struct - include (Sig.MakeCamlp4Ast Loc); - value safe_string_escaped s = - if ((String.length s) > 2) && ((s.[0] = '\\') && (s.[1] = '$')) - then s - else String.escaped s; - end; - include Ast; - external loc_of_ctyp : ctyp -> Loc.t = "%field0"; - external loc_of_patt : patt -> Loc.t = "%field0"; - external loc_of_expr : expr -> Loc.t = "%field0"; - external loc_of_module_type : module_type -> Loc.t = "%field0"; - external loc_of_module_expr : module_expr -> Loc.t = "%field0"; - external loc_of_sig_item : sig_item -> Loc.t = "%field0"; - external loc_of_str_item : str_item -> Loc.t = "%field0"; - external loc_of_class_type : class_type -> Loc.t = "%field0"; - external loc_of_class_sig_item : class_sig_item -> Loc.t = "%field0"; - external loc_of_class_expr : class_expr -> Loc.t = "%field0"; - external loc_of_class_str_item : class_str_item -> Loc.t = "%field0"; - external loc_of_with_constr : with_constr -> Loc.t = "%field0"; - external loc_of_binding : binding -> Loc.t = "%field0"; - external loc_of_rec_binding : rec_binding -> Loc.t = "%field0"; - external loc_of_module_binding : module_binding -> Loc.t = "%field0"; - external loc_of_match_case : match_case -> Loc.t = "%field0"; - external loc_of_ident : ident -> Loc.t = "%field0"; - value ghost = Loc.ghost; - value rec is_module_longident = - fun - [ Ast.IdAcc _ _ i -> is_module_longident i - | Ast.IdApp _ i1 i2 -> - (is_module_longident i1) && (is_module_longident i2) - | Ast.IdUid _ _ -> True - | _ -> False ]; - value ident_of_expr = - let error () = - invalid_arg "ident_of_expr: this expression is not an identifier" in - let rec self = - fun - [ Ast.ExApp _loc e1 e2 -> Ast.IdApp _loc (self e1) (self e2) - | Ast.ExAcc _loc e1 e2 -> Ast.IdAcc _loc (self e1) (self e2) - | Ast.ExId _ (Ast.IdLid _ _) -> error () - | Ast.ExId _ i -> if is_module_longident i then i else error () - | _ -> error () ] - in - fun [ Ast.ExId _ i -> i | Ast.ExApp _ _ _ -> error () | t -> self t ]; - value ident_of_ctyp = - let error () = - invalid_arg "ident_of_ctyp: this type is not an identifier" in - let rec self = - fun - [ Ast.TyApp _loc t1 t2 -> Ast.IdApp _loc (self t1) (self t2) - | Ast.TyId _ (Ast.IdLid _ _) -> error () - | Ast.TyId _ i -> if is_module_longident i then i else error () - | _ -> error () ] - in fun [ Ast.TyId _ i -> i | t -> self t ]; - value ident_of_patt = - let error () = - invalid_arg "ident_of_patt: this pattern is not an identifier" in - let rec self = - fun - [ Ast.PaApp _loc p1 p2 -> Ast.IdApp _loc (self p1) (self p2) - | Ast.PaId _ (Ast.IdLid _ _) -> error () - | Ast.PaId _ i -> if is_module_longident i then i else error () - | _ -> error () ] - in fun [ Ast.PaId _ i -> i | p -> self p ]; - value rec is_irrefut_patt = - fun - [ Ast.PaId _ (Ast.IdLid _ _) -> True - | Ast.PaId _ (Ast.IdUid _ "()") -> True - | Ast.PaAny _ -> True - | Ast.PaNil _ -> True - | (* why not *) Ast.PaAli _ x y -> - (is_irrefut_patt x) && (is_irrefut_patt y) - | Ast.PaRec _ p -> is_irrefut_patt p - | Ast.PaEq _ _ p -> is_irrefut_patt p - | Ast.PaSem _ p1 p2 -> (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaCom _ p1 p2 -> (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaOrp _ p1 p2 -> (is_irrefut_patt p1) && (is_irrefut_patt p2) - | (* could be more fine grained *) Ast.PaApp _ p1 p2 -> - (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaTyc _ p _ -> is_irrefut_patt p - | Ast.PaTup _ pl -> is_irrefut_patt pl - | Ast.PaOlb _ _ (Ast.PaNil _) -> True - | Ast.PaOlb _ _ p -> is_irrefut_patt p - | Ast.PaOlbi _ _ p _ -> is_irrefut_patt p - | Ast.PaLab _ _ (Ast.PaNil _) -> True - | Ast.PaLab _ _ p -> is_irrefut_patt p - | Ast.PaLaz _ p -> is_irrefut_patt p - | Ast.PaId _ _ -> False - | (* here one need to know the arity of constructors *) Ast.PaMod _ _ - -> True - | Ast.PaVrn _ _ | Ast.PaStr _ _ | Ast.PaRng _ _ _ | Ast.PaFlo _ _ | - Ast.PaNativeInt _ _ | Ast.PaInt64 _ _ | Ast.PaInt32 _ _ | - Ast.PaInt _ _ | Ast.PaChr _ _ | Ast.PaTyp _ _ | Ast.PaArr _ _ | - Ast.PaAnt _ _ -> False ]; - value rec is_constructor = - fun - [ Ast.IdAcc _ _ i -> is_constructor i - | Ast.IdUid _ _ -> True - | Ast.IdLid _ _ | Ast.IdApp _ _ _ -> False - | Ast.IdAnt _ _ -> assert False ]; - value is_patt_constructor = - fun - [ Ast.PaId _ i -> is_constructor i - | Ast.PaVrn _ _ -> True - | _ -> False ]; - value rec is_expr_constructor = - fun - [ Ast.ExId _ i -> is_constructor i - | Ast.ExAcc _ e1 e2 -> - (is_expr_constructor e1) && (is_expr_constructor e2) - | Ast.ExVrn _ _ -> True - | _ -> False ]; - value rec tyOr_of_list = - fun - [ [] -> Ast.TyNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_ctyp t in Ast.TyOr _loc t (tyOr_of_list ts) ]; - value rec tyAnd_of_list = - fun - [ [] -> Ast.TyNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_ctyp t in Ast.TyAnd _loc t (tyAnd_of_list ts) ]; - value rec tySem_of_list = - fun - [ [] -> Ast.TyNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_ctyp t in Ast.TySem _loc t (tySem_of_list ts) ]; - value rec tyCom_of_list = - fun - [ [] -> Ast.TyNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_ctyp t in Ast.TyCom _loc t (tyCom_of_list ts) ]; - value rec tyAmp_of_list = - fun - [ [] -> Ast.TyNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_ctyp t in Ast.TyAmp _loc t (tyAmp_of_list ts) ]; - value rec tySta_of_list = - fun - [ [] -> Ast.TyNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_ctyp t in Ast.TySta _loc t (tySta_of_list ts) ]; - value rec stSem_of_list = - fun - [ [] -> Ast.StNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_str_item t in Ast.StSem _loc t (stSem_of_list ts) ]; - value rec sgSem_of_list = - fun - [ [] -> Ast.SgNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_sig_item t in Ast.SgSem _loc t (sgSem_of_list ts) ]; - value rec biAnd_of_list = - fun - [ [] -> Ast.BiNil ghost - | [ b ] -> b - | [ b :: bs ] -> - let _loc = loc_of_binding b in Ast.BiAnd _loc b (biAnd_of_list bs) ]; - value rec rbSem_of_list = - fun - [ [] -> Ast.RbNil ghost - | [ b ] -> b - | [ b :: bs ] -> - let _loc = loc_of_rec_binding b - in Ast.RbSem _loc b (rbSem_of_list bs) ]; - value rec wcAnd_of_list = - fun - [ [] -> Ast.WcNil ghost - | [ w ] -> w - | [ w :: ws ] -> - let _loc = loc_of_with_constr w - in Ast.WcAnd _loc w (wcAnd_of_list ws) ]; - value rec idAcc_of_list = - fun - [ [] -> assert False - | [ i ] -> i - | [ i :: is ] -> - let _loc = loc_of_ident i in Ast.IdAcc _loc i (idAcc_of_list is) ]; - value rec idApp_of_list = - fun - [ [] -> assert False - | [ i ] -> i - | [ i :: is ] -> - let _loc = loc_of_ident i in Ast.IdApp _loc i (idApp_of_list is) ]; - value rec mcOr_of_list = - fun - [ [] -> Ast.McNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_match_case x in Ast.McOr _loc x (mcOr_of_list xs) ]; - value rec mbAnd_of_list = - fun - [ [] -> Ast.MbNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_module_binding x - in Ast.MbAnd _loc x (mbAnd_of_list xs) ]; - value rec meApp_of_list = - fun - [ [] -> assert False - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_module_expr x - in Ast.MeApp _loc x (meApp_of_list xs) ]; - value rec ceAnd_of_list = - fun - [ [] -> Ast.CeNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_class_expr x - in Ast.CeAnd _loc x (ceAnd_of_list xs) ]; - value rec ctAnd_of_list = - fun - [ [] -> Ast.CtNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_class_type x - in Ast.CtAnd _loc x (ctAnd_of_list xs) ]; - value rec cgSem_of_list = - fun - [ [] -> Ast.CgNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_class_sig_item x - in Ast.CgSem _loc x (cgSem_of_list xs) ]; - value rec crSem_of_list = - fun - [ [] -> Ast.CrNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_class_str_item x - in Ast.CrSem _loc x (crSem_of_list xs) ]; - value rec paSem_of_list = - fun - [ [] -> Ast.PaNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_patt x in Ast.PaSem _loc x (paSem_of_list xs) ]; - value rec paCom_of_list = - fun - [ [] -> Ast.PaNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_patt x in Ast.PaCom _loc x (paCom_of_list xs) ]; - value rec exSem_of_list = - fun - [ [] -> Ast.ExNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_expr x in Ast.ExSem _loc x (exSem_of_list xs) ]; - value rec exCom_of_list = - fun - [ [] -> Ast.ExNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_expr x in Ast.ExCom _loc x (exCom_of_list xs) ]; - value ty_of_stl = - fun - [ (_loc, s, []) -> Ast.TyId _loc (Ast.IdUid _loc s) - | (_loc, s, tl) -> - Ast.TyOf _loc (Ast.TyId _loc (Ast.IdUid _loc s)) (tyAnd_of_list tl) ]; - value ty_of_sbt = - fun - [ (_loc, s, True, t) -> - Ast.TyCol _loc (Ast.TyId _loc (Ast.IdLid _loc s)) - (Ast.TyMut _loc t) - | (_loc, s, False, t) -> - Ast.TyCol _loc (Ast.TyId _loc (Ast.IdLid _loc s)) t ]; - value bi_of_pe (p, e) = let _loc = loc_of_patt p in Ast.BiEq _loc p e; - value sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l); - value record_type_of_list l = tySem_of_list (List.map ty_of_sbt l); - value binding_of_pel l = biAnd_of_list (List.map bi_of_pe l); - value rec pel_of_binding = - fun - [ Ast.BiAnd _ b1 b2 -> (pel_of_binding b1) @ (pel_of_binding b2) - | Ast.BiEq _ p e -> [ (p, e) ] - | _ -> assert False ]; - value rec list_of_binding x acc = - match x with - [ Ast.BiAnd _ b1 b2 -> list_of_binding b1 (list_of_binding b2 acc) - | t -> [ t :: acc ] ]; - value rec list_of_rec_binding x acc = - match x with - [ Ast.RbSem _ b1 b2 -> - list_of_rec_binding b1 (list_of_rec_binding b2 acc) - | t -> [ t :: acc ] ]; - value rec list_of_with_constr x acc = - match x with - [ Ast.WcAnd _ w1 w2 -> - list_of_with_constr w1 (list_of_with_constr w2 acc) - | t -> [ t :: acc ] ]; - value rec list_of_ctyp x acc = - match x with - [ Ast.TyNil _ -> acc - | Ast.TyAmp _ x y | Ast.TyCom _ x y | Ast.TySta _ x y | Ast.TySem _ x y - | Ast.TyAnd _ x y | Ast.TyOr _ x y -> - list_of_ctyp x (list_of_ctyp y acc) - | x -> [ x :: acc ] ]; - value rec list_of_patt x acc = - match x with - [ Ast.PaNil _ -> acc - | Ast.PaCom _ x y | Ast.PaSem _ x y -> - list_of_patt x (list_of_patt y acc) - | x -> [ x :: acc ] ]; - value rec list_of_expr x acc = - match x with - [ Ast.ExNil _ -> acc - | Ast.ExCom _ x y | Ast.ExSem _ x y -> - list_of_expr x (list_of_expr y acc) - | x -> [ x :: acc ] ]; - value rec list_of_str_item x acc = - match x with - [ Ast.StNil _ -> acc - | Ast.StSem _ x y -> list_of_str_item x (list_of_str_item y acc) - | x -> [ x :: acc ] ]; - value rec list_of_sig_item x acc = - match x with - [ Ast.SgNil _ -> acc - | Ast.SgSem _ x y -> list_of_sig_item x (list_of_sig_item y acc) - | x -> [ x :: acc ] ]; - value rec list_of_class_sig_item x acc = - match x with - [ Ast.CgNil _ -> acc - | Ast.CgSem _ x y -> - list_of_class_sig_item x (list_of_class_sig_item y acc) - | x -> [ x :: acc ] ]; - value rec list_of_class_str_item x acc = - match x with - [ Ast.CrNil _ -> acc - | Ast.CrSem _ x y -> - list_of_class_str_item x (list_of_class_str_item y acc) - | x -> [ x :: acc ] ]; - value rec list_of_class_type x acc = - match x with - [ Ast.CtAnd _ x y -> list_of_class_type x (list_of_class_type y acc) - | x -> [ x :: acc ] ]; - value rec list_of_class_expr x acc = - match x with - [ Ast.CeAnd _ x y -> list_of_class_expr x (list_of_class_expr y acc) - | x -> [ x :: acc ] ]; - value rec list_of_module_expr x acc = - match x with - [ Ast.MeApp _ x y -> list_of_module_expr x (list_of_module_expr y acc) - | x -> [ x :: acc ] ]; - value rec list_of_match_case x acc = - match x with - [ Ast.McNil _ -> acc - | Ast.McOr _ x y -> list_of_match_case x (list_of_match_case y acc) - | x -> [ x :: acc ] ]; - value rec list_of_ident x acc = - match x with - [ Ast.IdAcc _ x y | Ast.IdApp _ x y -> - list_of_ident x (list_of_ident y acc) - | x -> [ x :: acc ] ]; - value rec list_of_module_binding x acc = - match x with - [ Ast.MbAnd _ x y -> - list_of_module_binding x (list_of_module_binding y acc) - | x -> [ x :: acc ] ]; - module Meta = - struct - module type META_LOC = - sig - value meta_loc_patt : Loc.t -> Loc.t -> Ast.patt; - value meta_loc_expr : Loc.t -> Loc.t -> Ast.expr; - end; - module MetaLoc = - struct - value meta_loc_patt _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location - in - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") - (Ast.IdLid _loc "of_tuple"))) - (Ast.PaTup _loc - (Ast.PaCom _loc - (Ast.PaStr _loc (Ast.safe_string_escaped a)) - (Ast.PaCom _loc - (Ast.PaCom _loc - (Ast.PaCom _loc - (Ast.PaCom _loc - (Ast.PaCom _loc - (Ast.PaCom _loc - (Ast.PaInt _loc (string_of_int b)) - (Ast.PaInt _loc (string_of_int c))) - (Ast.PaInt _loc (string_of_int d))) - (Ast.PaInt _loc (string_of_int e))) - (Ast.PaInt _loc (string_of_int f))) - (Ast.PaInt _loc (string_of_int g))) - (if h - then Ast.PaId _loc (Ast.IdUid _loc "True") - else Ast.PaId _loc (Ast.IdUid _loc "False"))))); - value meta_loc_expr _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location - in - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") - (Ast.IdLid _loc "of_tuple"))) - (Ast.ExTup _loc - (Ast.ExCom _loc - (Ast.ExStr _loc (Ast.safe_string_escaped a)) - (Ast.ExCom _loc - (Ast.ExCom _loc - (Ast.ExCom _loc - (Ast.ExCom _loc - (Ast.ExCom _loc - (Ast.ExCom _loc - (Ast.ExInt _loc (string_of_int b)) - (Ast.ExInt _loc (string_of_int c))) - (Ast.ExInt _loc (string_of_int d))) - (Ast.ExInt _loc (string_of_int e))) - (Ast.ExInt _loc (string_of_int f))) - (Ast.ExInt _loc (string_of_int g))) - (if h - then Ast.ExId _loc (Ast.IdUid _loc "True") - else Ast.ExId _loc (Ast.IdUid _loc "False"))))); - end; - module MetaGhostLoc = - struct - value meta_loc_patt _loc _ = - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") - (Ast.IdLid _loc "ghost")); - value meta_loc_expr _loc _ = - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") - (Ast.IdLid _loc "ghost")); - end; - module MetaLocVar = - struct - value meta_loc_patt _loc _ = - Ast.PaId _loc (Ast.IdLid _loc Loc.name.val); - value meta_loc_expr _loc _ = - Ast.ExId _loc (Ast.IdLid _loc Loc.name.val); - end; - module Make (MetaLoc : META_LOC) = - struct - open MetaLoc; - value meta_loc = meta_loc_expr; - module Expr = - struct - value meta_string _loc s = - Ast.ExStr _loc (safe_string_escaped s); - value meta_int _loc s = Ast.ExInt _loc s; - value meta_float _loc s = Ast.ExFlo _loc s; - value meta_char _loc s = Ast.ExChr _loc (String.escaped s); - value meta_bool _loc = - fun - [ False -> Ast.ExId _loc (Ast.IdUid _loc "False") - | True -> Ast.ExId _loc (Ast.IdUid _loc "True") ]; - value rec meta_list mf_a _loc = - fun - [ [] -> Ast.ExId _loc (Ast.IdUid _loc "[]") - | [ x :: xs ] -> - Ast.ExApp _loc - (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdUid _loc "::")) - (mf_a _loc x)) - (meta_list mf_a _loc xs) ]; - value rec meta_binding _loc = - fun - [ Ast.BiAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.BiEq x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BiEq"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_expr _loc x2) - | Ast.BiAnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BiAnd"))) - (meta_loc _loc x0)) - (meta_binding _loc x1)) - (meta_binding _loc x2) - | Ast.BiNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BiNil"))) - (meta_loc _loc x0) ] - and meta_class_expr _loc = - fun - [ Ast.CeAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.CeEq x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeEq"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_class_expr _loc x2) - | Ast.CeAnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeAnd"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_class_expr _loc x2) - | Ast.CeTyc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeTyc"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_class_type _loc x2) - | Ast.CeStr x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeStr"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_class_str_item _loc x2) - | Ast.CeLet x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeLet"))) - (meta_loc _loc x0)) - (meta_rec_flag _loc x1)) - (meta_binding _loc x2)) - (meta_class_expr _loc x3) - | Ast.CeFun x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeFun"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_class_expr _loc x2) - | Ast.CeCon x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeCon"))) - (meta_loc _loc x0)) - (meta_virtual_flag _loc x1)) - (meta_ident _loc x2)) - (meta_ctyp _loc x3) - | Ast.CeApp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeApp"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_expr _loc x2) - | Ast.CeNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeNil"))) - (meta_loc _loc x0) ] - and meta_class_sig_item _loc = - fun - [ Ast.CgAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.CgVir x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgVir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_private_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CgVal x0 x1 x2 x3 x4 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgVal"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_mutable_flag _loc x2)) - (meta_virtual_flag _loc x3)) - (meta_ctyp _loc x4) - | Ast.CgMth x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgMth"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_private_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CgInh x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgInh"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.CgSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgSem"))) - (meta_loc _loc x0)) - (meta_class_sig_item _loc x1)) - (meta_class_sig_item _loc x2) - | Ast.CgCtr x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgCtr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.CgNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgNil"))) - (meta_loc _loc x0) ] - and meta_class_str_item _loc = - fun - [ Ast.CrAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.CrVvr x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrVvr"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_mutable_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CrVir x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrVir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_private_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CrVal x0 x1 x2 x3 x4 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrVal"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_override_flag _loc x2)) - (meta_mutable_flag _loc x3)) - (meta_expr _loc x4) - | Ast.CrMth x0 x1 x2 x3 x4 x5 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc - (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrMth"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_override_flag _loc x2)) - (meta_private_flag _loc x3)) - (meta_expr _loc x4)) - (meta_ctyp _loc x5) - | Ast.CrIni x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrIni"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.CrInh x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrInh"))) - (meta_loc _loc x0)) - (meta_override_flag _loc x1)) - (meta_class_expr _loc x2)) - (meta_string _loc x3) - | Ast.CrCtr x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrCtr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.CrSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrSem"))) - (meta_loc _loc x0)) - (meta_class_str_item _loc x1)) - (meta_class_str_item _loc x2) - | Ast.CrNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrNil"))) - (meta_loc _loc x0) ] - and meta_class_type _loc = - fun - [ Ast.CtAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.CtEq x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtEq"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1)) - (meta_class_type _loc x2) - | Ast.CtCol x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtCol"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1)) - (meta_class_type _loc x2) - | Ast.CtAnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtAnd"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1)) - (meta_class_type _loc x2) - | Ast.CtSig x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtSig"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_class_sig_item _loc x2) - | Ast.CtFun x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtFun"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_class_type _loc x2) - | Ast.CtCon x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtCon"))) - (meta_loc _loc x0)) - (meta_virtual_flag _loc x1)) - (meta_ident _loc x2)) - (meta_ctyp _loc x3) - | Ast.CtNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtNil"))) - (meta_loc _loc x0) ] - and meta_ctyp _loc = - fun - [ Ast.TyAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.TyPkg x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyPkg"))) - (meta_loc _loc x0)) - (meta_module_type _loc x1) - | Ast.TyOfAmp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOfAmp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyAmp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAmp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyVrnInfSup x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnInfSup"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyVrnInf x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnInf"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyVrnSup x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnSup"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyVrnEq x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnEq"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TySta x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TySta"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyTup x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyTup"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyMut x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyMut"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyPrv x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyPrv"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyOr x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyAnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAnd"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyOf x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOf"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TySum x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TySum"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyCom x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyCom"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TySem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TySem"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyCol x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyCol"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyRec x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyRec"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyVrn x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrn"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyAnM x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAnM"))) - (meta_loc _loc x0) - | Ast.TyAnP x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAnP"))) - (meta_loc _loc x0) - | Ast.TyQuM x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyQuM"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyQuP x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyQuP"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyQuo x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyQuo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyTypePol x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyTypePol"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyPol x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyPol"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyOlb x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOlb"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyObj x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyObj"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_row_var_flag _loc x2) - | Ast.TyDcl x0 x1 x2 x3 x4 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyDcl"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_list meta_ctyp _loc x2)) - (meta_ctyp _loc x3)) - (meta_list - (fun _loc (x1, x2) -> - Ast.ExTup _loc - (Ast.ExCom _loc (meta_ctyp _loc x1) - (meta_ctyp _loc x2))) - _loc x4) - | Ast.TyMan x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyMan"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyId x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.TyLab x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyLab"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyCls x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyCls"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.TyArr x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyArr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyApp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyApp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyAny x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAny"))) - (meta_loc _loc x0) - | Ast.TyAli x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAli"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyNil"))) - (meta_loc _loc x0) ] - and meta_direction_flag _loc = - fun - [ Ast.DiAnt x0 -> Ast.ExAnt _loc x0 - | Ast.DiDownto -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "DiDownto")) - | Ast.DiTo -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "DiTo")) ] - and meta_expr _loc = - fun - [ Ast.ExPkg x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExPkg"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1) - | Ast.ExFUN x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFUN"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.ExOpI x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExOpI"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_expr _loc x2) - | Ast.ExWhi x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExWhi"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExVrn x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExVrn"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExTyc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExTyc"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_ctyp _loc x2) - | Ast.ExCom x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExCom"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExTup x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExTup"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExTry x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExTry"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_match_case _loc x2) - | Ast.ExStr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExStr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExSte x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSte"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExSnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSnd"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_string _loc x2) - | Ast.ExSeq x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSeq"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExRec x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExRec"))) - (meta_loc _loc x0)) - (meta_rec_binding _loc x1)) - (meta_expr _loc x2) - | Ast.ExOvr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExOvr"))) - (meta_loc _loc x0)) - (meta_rec_binding _loc x1) - | Ast.ExOlb x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExOlb"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.ExObj x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExObj"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_class_str_item _loc x2) - | Ast.ExNew x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExNew"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.ExMat x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExMat"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_match_case _loc x2) - | Ast.ExLmd x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLmd"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_expr _loc x2)) - (meta_expr _loc x3) - | Ast.ExLet x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLet"))) - (meta_loc _loc x0)) - (meta_rec_flag _loc x1)) - (meta_binding _loc x2)) - (meta_expr _loc x3) - | Ast.ExLaz x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLaz"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExLab x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLab"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.ExNativeInt x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExNativeInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExInt64 x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExInt64"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExInt32 x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExInt32"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExInt x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExIfe x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExIfe"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2)) - (meta_expr _loc x3) - | Ast.ExFun x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFun"))) - (meta_loc _loc x0)) - (meta_match_case _loc x1) - | Ast.ExFor x0 x1 x2 x3 x4 x5 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc - (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFor"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2)) - (meta_expr _loc x3)) - (meta_direction_flag _loc x4)) - (meta_expr _loc x5) - | Ast.ExFlo x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFlo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExCoe x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExCoe"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_ctyp _loc x2)) - (meta_ctyp _loc x3) - | Ast.ExChr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExChr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExAss x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAss"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExAsr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAsr"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExAsf x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAsf"))) - (meta_loc _loc x0) - | Ast.ExSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSem"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExArr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExArr"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExAre x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAre"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExApp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExApp"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.ExAcc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAcc"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExId x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.ExNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExNil"))) - (meta_loc _loc x0) ] - and meta_ident _loc = - fun - [ Ast.IdAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.IdUid x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdUid"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.IdLid x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdLid"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.IdApp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdApp"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) - | Ast.IdAcc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdAcc"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) ] - and meta_match_case _loc = - fun - [ Ast.McAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.McArr x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "McArr"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_expr _loc x2)) - (meta_expr _loc x3) - | Ast.McOr x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "McOr"))) - (meta_loc _loc x0)) - (meta_match_case _loc x1)) - (meta_match_case _loc x2) - | Ast.McNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "McNil"))) - (meta_loc _loc x0) ] - and meta_meta_bool _loc = - fun - [ Ast.BAnt x0 -> Ast.ExAnt _loc x0 - | Ast.BFalse -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BFalse")) - | Ast.BTrue -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BTrue")) ] - and meta_meta_list mf_a _loc = - fun - [ Ast.LAnt x0 -> Ast.ExAnt _loc x0 - | Ast.LCons x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "LCons"))) - (mf_a _loc x0)) - (meta_meta_list mf_a _loc x1) - | Ast.LNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "LNil")) ] - and meta_meta_option mf_a _loc = - fun - [ Ast.OAnt x0 -> Ast.ExAnt _loc x0 - | Ast.OSome x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "OSome"))) - (mf_a _loc x0) - | Ast.ONone -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ONone")) ] - and meta_module_binding _loc = - fun - [ Ast.MbAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.MbCol x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbCol"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.MbColEq x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbColEq"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2)) - (meta_module_expr _loc x3) - | Ast.MbAnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbAnd"))) - (meta_loc _loc x0)) - (meta_module_binding _loc x1)) - (meta_module_binding _loc x2) - | Ast.MbNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbNil"))) - (meta_loc _loc x0) ] - and meta_module_expr _loc = - fun - [ Ast.MeAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.MePkg x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MePkg"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.MeTyc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeTyc"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1)) - (meta_module_type _loc x2) - | Ast.MeStr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeStr"))) - (meta_loc _loc x0)) - (meta_str_item _loc x1) - | Ast.MeFun x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeFun"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2)) - (meta_module_expr _loc x3) - | Ast.MeApp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeApp"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1)) - (meta_module_expr _loc x2) - | Ast.MeId x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.MeNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeNil"))) - (meta_loc _loc x0) ] - and meta_module_type _loc = - fun - [ Ast.MtAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.MtOf x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtOf"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1) - | Ast.MtWit x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtWit"))) - (meta_loc _loc x0)) - (meta_module_type _loc x1)) - (meta_with_constr _loc x2) - | Ast.MtSig x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtSig"))) - (meta_loc _loc x0)) - (meta_sig_item _loc x1) - | Ast.MtQuo x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtQuo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.MtFun x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtFun"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2)) - (meta_module_type _loc x3) - | Ast.MtId x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.MtNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtNil"))) - (meta_loc _loc x0) ] - and meta_mutable_flag _loc = - fun - [ Ast.MuAnt x0 -> Ast.ExAnt _loc x0 - | Ast.MuNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MuNil")) - | Ast.MuMutable -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MuMutable")) ] - and meta_override_flag _loc = - fun - [ Ast.OvAnt x0 -> Ast.ExAnt _loc x0 - | Ast.OvNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "OvNil")) - | Ast.OvOverride -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "OvOverride")) ] - and meta_patt _loc = - fun - [ Ast.PaMod x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaMod"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaLaz x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaLaz"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaVrn x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaVrn"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaTyp x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaTyp"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.PaTyc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaTyc"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_ctyp _loc x2) - | Ast.PaTup x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaTup"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaStr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaStr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaEq x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaEq"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_patt _loc x2) - | Ast.PaRec x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaRec"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaRng x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaRng"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaOrp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaOrp"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaOlbi x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaOlbi"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_patt _loc x2)) - (meta_expr _loc x3) - | Ast.PaOlb x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaOlb"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_patt _loc x2) - | Ast.PaLab x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaLab"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_patt _loc x2) - | Ast.PaFlo x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaFlo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaNativeInt x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaNativeInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaInt64 x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaInt64"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaInt32 x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaInt32"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaInt x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaChr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaChr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaSem"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaCom x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaCom"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaArr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaArr"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaApp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaApp"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaAny x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaAny"))) - (meta_loc _loc x0) - | Ast.PaAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.PaAli x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaAli"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaId x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.PaNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaNil"))) - (meta_loc _loc x0) ] - and meta_private_flag _loc = - fun - [ Ast.PrAnt x0 -> Ast.ExAnt _loc x0 - | Ast.PrNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PrNil")) - | Ast.PrPrivate -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PrPrivate")) ] - and meta_rec_binding _loc = - fun - [ Ast.RbAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.RbEq x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RbEq"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_expr _loc x2) - | Ast.RbSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RbSem"))) - (meta_loc _loc x0)) - (meta_rec_binding _loc x1)) - (meta_rec_binding _loc x2) - | Ast.RbNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RbNil"))) - (meta_loc _loc x0) ] - and meta_rec_flag _loc = - fun - [ Ast.ReAnt x0 -> Ast.ExAnt _loc x0 - | Ast.ReNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ReNil")) - | Ast.ReRecursive -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ReRecursive")) ] - and meta_row_var_flag _loc = - fun - [ Ast.RvAnt x0 -> Ast.ExAnt _loc x0 - | Ast.RvNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RvNil")) - | Ast.RvRowVar -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RvRowVar")) ] - and meta_sig_item _loc = - fun - [ Ast.SgAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.SgVal x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgVal"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2) - | Ast.SgTyp x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgTyp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.SgOpn x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgOpn"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.SgMty x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgMty"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.SgRecMod x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgRecMod"))) - (meta_loc _loc x0)) - (meta_module_binding _loc x1) - | Ast.SgMod x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgMod"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.SgInc x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgInc"))) - (meta_loc _loc x0)) - (meta_module_type _loc x1) - | Ast.SgExt x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgExt"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2)) - (meta_meta_list meta_string _loc x3) - | Ast.SgExc x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgExc"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.SgDir x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgDir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.SgSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgSem"))) - (meta_loc _loc x0)) - (meta_sig_item _loc x1)) - (meta_sig_item _loc x2) - | Ast.SgClt x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgClt"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.SgCls x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgCls"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.SgNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgNil"))) - (meta_loc _loc x0) ] - and meta_str_item _loc = - fun - [ Ast.StAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.StVal x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StVal"))) - (meta_loc _loc x0)) - (meta_rec_flag _loc x1)) - (meta_binding _loc x2) - | Ast.StTyp x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StTyp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.StOpn x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StOpn"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.StMty x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StMty"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.StRecMod x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StRecMod"))) - (meta_loc _loc x0)) - (meta_module_binding _loc x1) - | Ast.StMod x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StMod"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_expr _loc x2) - | Ast.StInc x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StInc"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1) - | Ast.StExt x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StExt"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2)) - (meta_meta_list meta_string _loc x3) - | Ast.StExp x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StExp"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.StExc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StExc"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_meta_option meta_ident _loc x2) - | Ast.StDir x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StDir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.StSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StSem"))) - (meta_loc _loc x0)) - (meta_str_item _loc x1)) - (meta_str_item _loc x2) - | Ast.StClt x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StClt"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.StCls x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StCls"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1) - | Ast.StNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StNil"))) - (meta_loc _loc x0) ] - and meta_virtual_flag _loc = - fun - [ Ast.ViAnt x0 -> Ast.ExAnt _loc x0 - | Ast.ViNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ViNil")) - | Ast.ViVirtual -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ViVirtual")) ] - and meta_with_constr _loc = - fun - [ Ast.WcAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.WcAnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcAnd"))) - (meta_loc _loc x0)) - (meta_with_constr _loc x1)) - (meta_with_constr _loc x2) - | Ast.WcMoS x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcMoS"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) - | Ast.WcTyS x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcTyS"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.WcMod x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcMod"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) - | Ast.WcTyp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcTyp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.WcNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcNil"))) - (meta_loc _loc x0) ]; - end; - value meta_loc = meta_loc_patt; - module Patt = - struct - value meta_string _loc s = - Ast.PaStr _loc (safe_string_escaped s); - value meta_int _loc s = Ast.PaInt _loc s; - value meta_float _loc s = Ast.PaFlo _loc s; - value meta_char _loc s = Ast.PaChr _loc (String.escaped s); - value meta_bool _loc = - fun - [ False -> Ast.PaId _loc (Ast.IdUid _loc "False") - | True -> Ast.PaId _loc (Ast.IdUid _loc "True") ]; - value rec meta_list mf_a _loc = - fun - [ [] -> Ast.PaId _loc (Ast.IdUid _loc "[]") - | [ x :: xs ] -> - Ast.PaApp _loc - (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdUid _loc "::")) - (mf_a _loc x)) - (meta_list mf_a _loc xs) ]; - value rec meta_binding _loc = - fun - [ Ast.BiAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.BiEq x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BiEq"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_expr _loc x2) - | Ast.BiAnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BiAnd"))) - (meta_loc _loc x0)) - (meta_binding _loc x1)) - (meta_binding _loc x2) - | Ast.BiNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BiNil"))) - (meta_loc _loc x0) ] - and meta_class_expr _loc = - fun - [ Ast.CeAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.CeEq x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeEq"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_class_expr _loc x2) - | Ast.CeAnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeAnd"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_class_expr _loc x2) - | Ast.CeTyc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeTyc"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_class_type _loc x2) - | Ast.CeStr x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeStr"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_class_str_item _loc x2) - | Ast.CeLet x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeLet"))) - (meta_loc _loc x0)) - (meta_rec_flag _loc x1)) - (meta_binding _loc x2)) - (meta_class_expr _loc x3) - | Ast.CeFun x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeFun"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_class_expr _loc x2) - | Ast.CeCon x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeCon"))) - (meta_loc _loc x0)) - (meta_virtual_flag _loc x1)) - (meta_ident _loc x2)) - (meta_ctyp _loc x3) - | Ast.CeApp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeApp"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_expr _loc x2) - | Ast.CeNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeNil"))) - (meta_loc _loc x0) ] - and meta_class_sig_item _loc = - fun - [ Ast.CgAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.CgVir x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgVir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_private_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CgVal x0 x1 x2 x3 x4 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgVal"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_mutable_flag _loc x2)) - (meta_virtual_flag _loc x3)) - (meta_ctyp _loc x4) - | Ast.CgMth x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgMth"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_private_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CgInh x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgInh"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.CgSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgSem"))) - (meta_loc _loc x0)) - (meta_class_sig_item _loc x1)) - (meta_class_sig_item _loc x2) - | Ast.CgCtr x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgCtr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.CgNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgNil"))) - (meta_loc _loc x0) ] - and meta_class_str_item _loc = - fun - [ Ast.CrAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.CrVvr x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrVvr"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_mutable_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CrVir x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrVir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_private_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CrVal x0 x1 x2 x3 x4 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrVal"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_override_flag _loc x2)) - (meta_mutable_flag _loc x3)) - (meta_expr _loc x4) - | Ast.CrMth x0 x1 x2 x3 x4 x5 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc - (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrMth"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_override_flag _loc x2)) - (meta_private_flag _loc x3)) - (meta_expr _loc x4)) - (meta_ctyp _loc x5) - | Ast.CrIni x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrIni"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.CrInh x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrInh"))) - (meta_loc _loc x0)) - (meta_override_flag _loc x1)) - (meta_class_expr _loc x2)) - (meta_string _loc x3) - | Ast.CrCtr x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrCtr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.CrSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrSem"))) - (meta_loc _loc x0)) - (meta_class_str_item _loc x1)) - (meta_class_str_item _loc x2) - | Ast.CrNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrNil"))) - (meta_loc _loc x0) ] - and meta_class_type _loc = - fun - [ Ast.CtAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.CtEq x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtEq"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1)) - (meta_class_type _loc x2) - | Ast.CtCol x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtCol"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1)) - (meta_class_type _loc x2) - | Ast.CtAnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtAnd"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1)) - (meta_class_type _loc x2) - | Ast.CtSig x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtSig"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_class_sig_item _loc x2) - | Ast.CtFun x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtFun"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_class_type _loc x2) - | Ast.CtCon x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtCon"))) - (meta_loc _loc x0)) - (meta_virtual_flag _loc x1)) - (meta_ident _loc x2)) - (meta_ctyp _loc x3) - | Ast.CtNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtNil"))) - (meta_loc _loc x0) ] - and meta_ctyp _loc = - fun - [ Ast.TyAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.TyPkg x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyPkg"))) - (meta_loc _loc x0)) - (meta_module_type _loc x1) - | Ast.TyOfAmp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOfAmp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyAmp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAmp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyVrnInfSup x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnInfSup"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyVrnInf x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnInf"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyVrnSup x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnSup"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyVrnEq x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnEq"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TySta x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TySta"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyTup x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyTup"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyMut x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyMut"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyPrv x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyPrv"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyOr x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyAnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAnd"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyOf x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOf"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TySum x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TySum"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyCom x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyCom"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TySem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TySem"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyCol x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyCol"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyRec x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyRec"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyVrn x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrn"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyAnM x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAnM"))) - (meta_loc _loc x0) - | Ast.TyAnP x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAnP"))) - (meta_loc _loc x0) - | Ast.TyQuM x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyQuM"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyQuP x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyQuP"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyQuo x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyQuo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyTypePol x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyTypePol"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyPol x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyPol"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyOlb x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOlb"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyObj x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyObj"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_row_var_flag _loc x2) - | Ast.TyDcl x0 x1 x2 x3 x4 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyDcl"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_list meta_ctyp _loc x2)) - (meta_ctyp _loc x3)) - (meta_list - (fun _loc (x1, x2) -> - Ast.PaTup _loc - (Ast.PaCom _loc (meta_ctyp _loc x1) - (meta_ctyp _loc x2))) - _loc x4) - | Ast.TyMan x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyMan"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyId x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.TyLab x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyLab"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyCls x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyCls"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.TyArr x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyArr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyApp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyApp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyAny x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAny"))) - (meta_loc _loc x0) - | Ast.TyAli x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAli"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyNil"))) - (meta_loc _loc x0) ] - and meta_direction_flag _loc = - fun - [ Ast.DiAnt x0 -> Ast.PaAnt _loc x0 - | Ast.DiDownto -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "DiDownto")) - | Ast.DiTo -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "DiTo")) ] - and meta_expr _loc = - fun - [ Ast.ExPkg x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExPkg"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1) - | Ast.ExFUN x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFUN"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.ExOpI x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExOpI"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_expr _loc x2) - | Ast.ExWhi x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExWhi"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExVrn x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExVrn"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExTyc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExTyc"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_ctyp _loc x2) - | Ast.ExCom x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExCom"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExTup x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExTup"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExTry x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExTry"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_match_case _loc x2) - | Ast.ExStr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExStr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExSte x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSte"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExSnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSnd"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_string _loc x2) - | Ast.ExSeq x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSeq"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExRec x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExRec"))) - (meta_loc _loc x0)) - (meta_rec_binding _loc x1)) - (meta_expr _loc x2) - | Ast.ExOvr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExOvr"))) - (meta_loc _loc x0)) - (meta_rec_binding _loc x1) - | Ast.ExOlb x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExOlb"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.ExObj x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExObj"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_class_str_item _loc x2) - | Ast.ExNew x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExNew"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.ExMat x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExMat"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_match_case _loc x2) - | Ast.ExLmd x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLmd"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_expr _loc x2)) - (meta_expr _loc x3) - | Ast.ExLet x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLet"))) - (meta_loc _loc x0)) - (meta_rec_flag _loc x1)) - (meta_binding _loc x2)) - (meta_expr _loc x3) - | Ast.ExLaz x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLaz"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExLab x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLab"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.ExNativeInt x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExNativeInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExInt64 x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExInt64"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExInt32 x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExInt32"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExInt x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExIfe x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExIfe"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2)) - (meta_expr _loc x3) - | Ast.ExFun x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFun"))) - (meta_loc _loc x0)) - (meta_match_case _loc x1) - | Ast.ExFor x0 x1 x2 x3 x4 x5 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc - (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFor"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2)) - (meta_expr _loc x3)) - (meta_direction_flag _loc x4)) - (meta_expr _loc x5) - | Ast.ExFlo x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFlo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExCoe x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExCoe"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_ctyp _loc x2)) - (meta_ctyp _loc x3) - | Ast.ExChr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExChr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExAss x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAss"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExAsr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAsr"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExAsf x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAsf"))) - (meta_loc _loc x0) - | Ast.ExSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSem"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExArr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExArr"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExAre x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAre"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExApp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExApp"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.ExAcc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAcc"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExId x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.ExNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExNil"))) - (meta_loc _loc x0) ] - and meta_ident _loc = - fun - [ Ast.IdAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.IdUid x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdUid"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.IdLid x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdLid"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.IdApp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdApp"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) - | Ast.IdAcc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdAcc"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) ] - and meta_match_case _loc = - fun - [ Ast.McAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.McArr x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "McArr"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_expr _loc x2)) - (meta_expr _loc x3) - | Ast.McOr x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "McOr"))) - (meta_loc _loc x0)) - (meta_match_case _loc x1)) - (meta_match_case _loc x2) - | Ast.McNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "McNil"))) - (meta_loc _loc x0) ] - and meta_meta_bool _loc = - fun - [ Ast.BAnt x0 -> Ast.PaAnt _loc x0 - | Ast.BFalse -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BFalse")) - | Ast.BTrue -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BTrue")) ] - and meta_meta_list mf_a _loc = - fun - [ Ast.LAnt x0 -> Ast.PaAnt _loc x0 - | Ast.LCons x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "LCons"))) - (mf_a _loc x0)) - (meta_meta_list mf_a _loc x1) - | Ast.LNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "LNil")) ] - and meta_meta_option mf_a _loc = - fun - [ Ast.OAnt x0 -> Ast.PaAnt _loc x0 - | Ast.OSome x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "OSome"))) - (mf_a _loc x0) - | Ast.ONone -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ONone")) ] - and meta_module_binding _loc = - fun - [ Ast.MbAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.MbCol x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbCol"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.MbColEq x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbColEq"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2)) - (meta_module_expr _loc x3) - | Ast.MbAnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbAnd"))) - (meta_loc _loc x0)) - (meta_module_binding _loc x1)) - (meta_module_binding _loc x2) - | Ast.MbNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbNil"))) - (meta_loc _loc x0) ] - and meta_module_expr _loc = - fun - [ Ast.MeAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.MePkg x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MePkg"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.MeTyc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeTyc"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1)) - (meta_module_type _loc x2) - | Ast.MeStr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeStr"))) - (meta_loc _loc x0)) - (meta_str_item _loc x1) - | Ast.MeFun x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeFun"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2)) - (meta_module_expr _loc x3) - | Ast.MeApp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeApp"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1)) - (meta_module_expr _loc x2) - | Ast.MeId x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.MeNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeNil"))) - (meta_loc _loc x0) ] - and meta_module_type _loc = - fun - [ Ast.MtAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.MtOf x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtOf"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1) - | Ast.MtWit x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtWit"))) - (meta_loc _loc x0)) - (meta_module_type _loc x1)) - (meta_with_constr _loc x2) - | Ast.MtSig x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtSig"))) - (meta_loc _loc x0)) - (meta_sig_item _loc x1) - | Ast.MtQuo x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtQuo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.MtFun x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtFun"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2)) - (meta_module_type _loc x3) - | Ast.MtId x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.MtNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtNil"))) - (meta_loc _loc x0) ] - and meta_mutable_flag _loc = - fun - [ Ast.MuAnt x0 -> Ast.PaAnt _loc x0 - | Ast.MuNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MuNil")) - | Ast.MuMutable -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MuMutable")) ] - and meta_override_flag _loc = - fun - [ Ast.OvAnt x0 -> Ast.PaAnt _loc x0 - | Ast.OvNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "OvNil")) - | Ast.OvOverride -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "OvOverride")) ] - and meta_patt _loc = - fun - [ Ast.PaMod x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaMod"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaLaz x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaLaz"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaVrn x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaVrn"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaTyp x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaTyp"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.PaTyc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaTyc"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_ctyp _loc x2) - | Ast.PaTup x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaTup"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaStr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaStr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaEq x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaEq"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_patt _loc x2) - | Ast.PaRec x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaRec"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaRng x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaRng"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaOrp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaOrp"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaOlbi x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaOlbi"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_patt _loc x2)) - (meta_expr _loc x3) - | Ast.PaOlb x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaOlb"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_patt _loc x2) - | Ast.PaLab x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaLab"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_patt _loc x2) - | Ast.PaFlo x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaFlo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaNativeInt x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaNativeInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaInt64 x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaInt64"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaInt32 x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaInt32"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaInt x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaChr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaChr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaSem"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaCom x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaCom"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaArr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaArr"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaApp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaApp"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaAny x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaAny"))) - (meta_loc _loc x0) - | Ast.PaAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.PaAli x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaAli"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaId x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.PaNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaNil"))) - (meta_loc _loc x0) ] - and meta_private_flag _loc = - fun - [ Ast.PrAnt x0 -> Ast.PaAnt _loc x0 - | Ast.PrNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PrNil")) - | Ast.PrPrivate -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PrPrivate")) ] - and meta_rec_binding _loc = - fun - [ Ast.RbAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.RbEq x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RbEq"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_expr _loc x2) - | Ast.RbSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RbSem"))) - (meta_loc _loc x0)) - (meta_rec_binding _loc x1)) - (meta_rec_binding _loc x2) - | Ast.RbNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RbNil"))) - (meta_loc _loc x0) ] - and meta_rec_flag _loc = - fun - [ Ast.ReAnt x0 -> Ast.PaAnt _loc x0 - | Ast.ReNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ReNil")) - | Ast.ReRecursive -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ReRecursive")) ] - and meta_row_var_flag _loc = - fun - [ Ast.RvAnt x0 -> Ast.PaAnt _loc x0 - | Ast.RvNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RvNil")) - | Ast.RvRowVar -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RvRowVar")) ] - and meta_sig_item _loc = - fun - [ Ast.SgAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.SgVal x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgVal"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2) - | Ast.SgTyp x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgTyp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.SgOpn x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgOpn"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.SgMty x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgMty"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.SgRecMod x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgRecMod"))) - (meta_loc _loc x0)) - (meta_module_binding _loc x1) - | Ast.SgMod x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgMod"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.SgInc x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgInc"))) - (meta_loc _loc x0)) - (meta_module_type _loc x1) - | Ast.SgExt x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgExt"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2)) - (meta_meta_list meta_string _loc x3) - | Ast.SgExc x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgExc"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.SgDir x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgDir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.SgSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgSem"))) - (meta_loc _loc x0)) - (meta_sig_item _loc x1)) - (meta_sig_item _loc x2) - | Ast.SgClt x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgClt"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.SgCls x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgCls"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.SgNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgNil"))) - (meta_loc _loc x0) ] - and meta_str_item _loc = - fun - [ Ast.StAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.StVal x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StVal"))) - (meta_loc _loc x0)) - (meta_rec_flag _loc x1)) - (meta_binding _loc x2) - | Ast.StTyp x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StTyp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.StOpn x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StOpn"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.StMty x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StMty"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.StRecMod x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StRecMod"))) - (meta_loc _loc x0)) - (meta_module_binding _loc x1) - | Ast.StMod x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StMod"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_expr _loc x2) - | Ast.StInc x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StInc"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1) - | Ast.StExt x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StExt"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2)) - (meta_meta_list meta_string _loc x3) - | Ast.StExp x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StExp"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.StExc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StExc"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_meta_option meta_ident _loc x2) - | Ast.StDir x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StDir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.StSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StSem"))) - (meta_loc _loc x0)) - (meta_str_item _loc x1)) - (meta_str_item _loc x2) - | Ast.StClt x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StClt"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.StCls x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StCls"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1) - | Ast.StNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StNil"))) - (meta_loc _loc x0) ] - and meta_virtual_flag _loc = - fun - [ Ast.ViAnt x0 -> Ast.PaAnt _loc x0 - | Ast.ViNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ViNil")) - | Ast.ViVirtual -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ViVirtual")) ] - and meta_with_constr _loc = - fun - [ Ast.WcAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.WcAnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcAnd"))) - (meta_loc _loc x0)) - (meta_with_constr _loc x1)) - (meta_with_constr _loc x2) - | Ast.WcMoS x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcMoS"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) - | Ast.WcTyS x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcTyS"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.WcMod x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcMod"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) - | Ast.WcTyp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcTyp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.WcNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcNil"))) - (meta_loc _loc x0) ]; - end; - end; - end; - class map = - object ((o : 'self_type)) - method string : string -> string = o#unknown; - method list : - ! 'a 'a_out. ('self_type -> 'a -> 'a_out) -> list 'a -> list 'a_out = - fun _f_a -> - fun - [ [] -> [] - | [ _x :: _x_i1 ] -> - let _x = _f_a o _x in - let _x_i1 = o#list _f_a _x_i1 in [ _x :: _x_i1 ] ]; - method with_constr : with_constr -> with_constr = - fun - [ WcNil _x -> let _x = o#loc _x in WcNil _x - | WcTyp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in WcTyp _x _x_i1 _x_i2 - | WcMod _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in WcMod _x _x_i1 _x_i2 - | WcTyS _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in WcTyS _x _x_i1 _x_i2 - | WcMoS _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in WcMoS _x _x_i1 _x_i2 - | WcAnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#with_constr _x_i1 in - let _x_i2 = o#with_constr _x_i2 in WcAnd _x _x_i1 _x_i2 - | WcAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in WcAnt _x _x_i1 ]; - method virtual_flag : virtual_flag -> virtual_flag = - fun - [ ViVirtual -> ViVirtual - | ViNil -> ViNil - | ViAnt _x -> let _x = o#string _x in ViAnt _x ]; - method str_item : str_item -> str_item = - fun - [ StNil _x -> let _x = o#loc _x in StNil _x - | StCls _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in StCls _x _x_i1 - | StClt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in StClt _x _x_i1 - | StSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#str_item _x_i1 in - let _x_i2 = o#str_item _x_i2 in StSem _x _x_i1 _x_i2 - | StDir _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in StDir _x _x_i1 _x_i2 - | StExc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#meta_option (fun o -> o#ident) _x_i2 - in StExc _x _x_i1 _x_i2 - | StExp _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in StExp _x _x_i1 - | StExt _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in - let _x_i3 = o#meta_list (fun o -> o#string) _x_i3 - in StExt _x _x_i1 _x_i2 _x_i3 - | StInc _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in StInc _x _x_i1 - | StMod _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_expr _x_i2 in StMod _x _x_i1 _x_i2 - | StRecMod _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_binding _x_i1 in StRecMod _x _x_i1 - | StMty _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in StMty _x _x_i1 _x_i2 - | StOpn _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in StOpn _x _x_i1 - | StTyp _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in StTyp _x _x_i1 - | StVal _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#rec_flag _x_i1 in - let _x_i2 = o#binding _x_i2 in StVal _x _x_i1 _x_i2 - | StAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in StAnt _x _x_i1 ]; - method sig_item : sig_item -> sig_item = - fun - [ SgNil _x -> let _x = o#loc _x in SgNil _x - | SgCls _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in SgCls _x _x_i1 - | SgClt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in SgClt _x _x_i1 - | SgSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#sig_item _x_i1 in - let _x_i2 = o#sig_item _x_i2 in SgSem _x _x_i1 _x_i2 - | SgDir _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in SgDir _x _x_i1 _x_i2 - | SgExc _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in SgExc _x _x_i1 - | SgExt _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in - let _x_i3 = o#meta_list (fun o -> o#string) _x_i3 - in SgExt _x _x_i1 _x_i2 _x_i3 - | SgInc _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_type _x_i1 in SgInc _x _x_i1 - | SgMod _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in SgMod _x _x_i1 _x_i2 - | SgRecMod _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_binding _x_i1 in SgRecMod _x _x_i1 - | SgMty _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in SgMty _x _x_i1 _x_i2 - | SgOpn _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in SgOpn _x _x_i1 - | SgTyp _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in SgTyp _x _x_i1 - | SgVal _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in SgVal _x _x_i1 _x_i2 - | SgAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in SgAnt _x _x_i1 ]; - method row_var_flag : row_var_flag -> row_var_flag = - fun - [ RvRowVar -> RvRowVar - | RvNil -> RvNil - | RvAnt _x -> let _x = o#string _x in RvAnt _x ]; - method rec_flag : rec_flag -> rec_flag = - fun - [ ReRecursive -> ReRecursive - | ReNil -> ReNil - | ReAnt _x -> let _x = o#string _x in ReAnt _x ]; - method rec_binding : rec_binding -> rec_binding = - fun - [ RbNil _x -> let _x = o#loc _x in RbNil _x - | RbSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#rec_binding _x_i1 in - let _x_i2 = o#rec_binding _x_i2 in RbSem _x _x_i1 _x_i2 - | RbEq _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#expr _x_i2 in RbEq _x _x_i1 _x_i2 - | RbAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in RbAnt _x _x_i1 ]; - method private_flag : private_flag -> private_flag = - fun - [ PrPrivate -> PrPrivate - | PrNil -> PrNil - | PrAnt _x -> let _x = o#string _x in PrAnt _x ]; - method patt : patt -> patt = - fun - [ PaNil _x -> let _x = o#loc _x in PaNil _x - | PaId _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in PaId _x _x_i1 - | PaAli _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaAli _x _x_i1 _x_i2 - | PaAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaAnt _x _x_i1 - | PaAny _x -> let _x = o#loc _x in PaAny _x - | PaApp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaApp _x _x_i1 _x_i2 - | PaArr _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaArr _x _x_i1 - | PaCom _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaCom _x _x_i1 _x_i2 - | PaSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaSem _x _x_i1 _x_i2 - | PaChr _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaChr _x _x_i1 - | PaInt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaInt _x _x_i1 - | PaInt32 _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaInt32 _x _x_i1 - | PaInt64 _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaInt64 _x _x_i1 - | PaNativeInt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaNativeInt _x _x_i1 - | PaFlo _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaFlo _x _x_i1 - | PaLab _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#patt _x_i2 in PaLab _x _x_i1 _x_i2 - | PaOlb _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#patt _x_i2 in PaOlb _x _x_i1 _x_i2 - | PaOlbi _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#patt _x_i2 in - let _x_i3 = o#expr _x_i3 in PaOlbi _x _x_i1 _x_i2 _x_i3 - | PaOrp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaOrp _x _x_i1 _x_i2 - | PaRng _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaRng _x _x_i1 _x_i2 - | PaRec _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaRec _x _x_i1 - | PaEq _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#patt _x_i2 in PaEq _x _x_i1 _x_i2 - | PaStr _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaStr _x _x_i1 - | PaTup _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaTup _x _x_i1 - | PaTyc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#ctyp _x_i2 in PaTyc _x _x_i1 _x_i2 - | PaTyp _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in PaTyp _x _x_i1 - | PaVrn _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaVrn _x _x_i1 - | PaLaz _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz _x _x_i1 - | PaMod _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaMod _x _x_i1 ]; - method override_flag : override_flag -> override_flag = - fun - [ OvOverride -> OvOverride - | OvNil -> OvNil - | OvAnt _x -> let _x = o#string _x in OvAnt _x ]; - method mutable_flag : mutable_flag -> mutable_flag = - fun - [ MuMutable -> MuMutable - | MuNil -> MuNil - | MuAnt _x -> let _x = o#string _x in MuAnt _x ]; - method module_type : module_type -> module_type = - fun - [ MtNil _x -> let _x = o#loc _x in MtNil _x - | MtId _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in MtId _x _x_i1 - | MtFun _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in - let _x_i3 = o#module_type _x_i3 in MtFun _x _x_i1 _x_i2 _x_i3 - | MtQuo _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MtQuo _x _x_i1 - | MtSig _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#sig_item _x_i1 in MtSig _x _x_i1 - | MtWit _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#module_type _x_i1 in - let _x_i2 = o#with_constr _x_i2 in MtWit _x _x_i1 _x_i2 - | MtOf _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in MtOf _x _x_i1 - | MtAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MtAnt _x _x_i1 ]; - method module_expr : module_expr -> module_expr = - fun - [ MeNil _x -> let _x = o#loc _x in MeNil _x - | MeId _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in MeId _x _x_i1 - | MeApp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in - let _x_i2 = o#module_expr _x_i2 in MeApp _x _x_i1 _x_i2 - | MeFun _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in - let _x_i3 = o#module_expr _x_i3 in MeFun _x _x_i1 _x_i2 _x_i3 - | MeStr _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#str_item _x_i1 in MeStr _x _x_i1 - | MeTyc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in - let _x_i2 = o#module_type _x_i2 in MeTyc _x _x_i1 _x_i2 - | MePkg _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in MePkg _x _x_i1 - | MeAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MeAnt _x _x_i1 ]; - method module_binding : module_binding -> module_binding = - fun - [ MbNil _x -> let _x = o#loc _x in MbNil _x - | MbAnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#module_binding _x_i1 in - let _x_i2 = o#module_binding _x_i2 in MbAnd _x _x_i1 _x_i2 - | MbColEq _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in - let _x_i3 = o#module_expr _x_i3 in MbColEq _x _x_i1 _x_i2 _x_i3 - | MbCol _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in MbCol _x _x_i1 _x_i2 - | MbAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MbAnt _x _x_i1 ]; - method meta_option : - ! (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2007 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Note: when you modify these types you must increment - ast magic numbers defined in Camlp4_config.ml. *) - 'a 'a_out. - ('self_type -> 'a -> 'a_out) -> - meta_option 'a -> meta_option 'a_out = - fun _f_a -> - fun - [ ONone -> ONone - | OSome _x -> let _x = _f_a o _x in OSome _x - | OAnt _x -> let _x = o#string _x in OAnt _x ]; - method meta_list : - ! 'a 'a_out. - ('self_type -> 'a -> 'a_out) -> meta_list 'a -> meta_list 'a_out = - fun _f_a -> - fun - [ LNil -> LNil - | LCons _x _x_i1 -> - let _x = _f_a o _x in - let _x_i1 = o#meta_list _f_a _x_i1 in LCons _x _x_i1 - | LAnt _x -> let _x = o#string _x in LAnt _x ]; - method meta_bool : meta_bool -> meta_bool = - fun - [ BTrue -> BTrue - | BFalse -> BFalse - | BAnt _x -> let _x = o#string _x in BAnt _x ]; - method match_case : match_case -> match_case = - fun - [ McNil _x -> let _x = o#loc _x in McNil _x - | McOr _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#match_case _x_i1 in - let _x_i2 = o#match_case _x_i2 in McOr _x _x_i1 _x_i2 - | McArr _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#expr _x_i2 in - let _x_i3 = o#expr _x_i3 in McArr _x _x_i1 _x_i2 _x_i3 - | McAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in McAnt _x _x_i1 ]; - method loc : loc -> loc = o#unknown; - method ident : ident -> ident = - fun - [ IdAcc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in IdAcc _x _x_i1 _x_i2 - | IdApp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in IdApp _x _x_i1 _x_i2 - | IdLid _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in IdLid _x _x_i1 - | IdUid _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in IdUid _x _x_i1 - | IdAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in IdAnt _x _x_i1 ]; - method expr : expr -> expr = - fun - [ ExNil _x -> let _x = o#loc _x in ExNil _x - | ExId _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in ExId _x _x_i1 - | ExAcc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExAcc _x _x_i1 _x_i2 - | ExAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExAnt _x _x_i1 - | ExApp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExApp _x _x_i1 _x_i2 - | ExAre _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExAre _x _x_i1 _x_i2 - | ExArr _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExArr _x _x_i1 - | ExSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExSem _x _x_i1 _x_i2 - | ExAsf _x -> let _x = o#loc _x in ExAsf _x - | ExAsr _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExAsr _x _x_i1 - | ExAss _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExAss _x _x_i1 _x_i2 - | ExChr _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExChr _x _x_i1 - | ExCoe _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#ctyp _x_i2 in - let _x_i3 = o#ctyp _x_i3 in ExCoe _x _x_i1 _x_i2 _x_i3 - | ExFlo _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExFlo _x _x_i1 - | ExFor _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in - let _x_i3 = o#expr _x_i3 in - let _x_i4 = o#direction_flag _x_i4 in - let _x_i5 = o#expr _x_i5 - in ExFor _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 - | ExFun _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#match_case _x_i1 in ExFun _x _x_i1 - | ExIfe _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in - let _x_i3 = o#expr _x_i3 in ExIfe _x _x_i1 _x_i2 _x_i3 - | ExInt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExInt _x _x_i1 - | ExInt32 _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExInt32 _x _x_i1 - | ExInt64 _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExInt64 _x _x_i1 - | ExNativeInt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExNativeInt _x _x_i1 - | ExLab _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in ExLab _x _x_i1 _x_i2 - | ExLaz _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExLaz _x _x_i1 - | ExLet _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#rec_flag _x_i1 in - let _x_i2 = o#binding _x_i2 in - let _x_i3 = o#expr _x_i3 in ExLet _x _x_i1 _x_i2 _x_i3 - | ExLmd _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_expr _x_i2 in - let _x_i3 = o#expr _x_i3 in ExLmd _x _x_i1 _x_i2 _x_i3 - | ExMat _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#match_case _x_i2 in ExMat _x _x_i1 _x_i2 - | ExNew _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in ExNew _x _x_i1 - | ExObj _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#class_str_item _x_i2 in ExObj _x _x_i1 _x_i2 - | ExOlb _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in ExOlb _x _x_i1 _x_i2 - | ExOvr _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#rec_binding _x_i1 in ExOvr _x _x_i1 - | ExRec _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#rec_binding _x_i1 in - let _x_i2 = o#expr _x_i2 in ExRec _x _x_i1 _x_i2 - | ExSeq _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExSeq _x _x_i1 - | ExSnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#string _x_i2 in ExSnd _x _x_i1 _x_i2 - | ExSte _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExSte _x _x_i1 _x_i2 - | ExStr _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExStr _x _x_i1 - | ExTry _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#match_case _x_i2 in ExTry _x _x_i1 _x_i2 - | ExTup _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExTup _x _x_i1 - | ExCom _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExCom _x _x_i1 _x_i2 - | ExTyc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#ctyp _x_i2 in ExTyc _x _x_i1 _x_i2 - | ExVrn _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExVrn _x _x_i1 - | ExWhi _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExWhi _x _x_i1 _x_i2 - | ExOpI _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#expr _x_i2 in ExOpI _x _x_i1 _x_i2 - | ExFUN _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in ExFUN _x _x_i1 _x_i2 - | ExPkg _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in ExPkg _x _x_i1 ]; - method direction_flag : direction_flag -> direction_flag = - fun - [ DiTo -> DiTo - | DiDownto -> DiDownto - | DiAnt _x -> let _x = o#string _x in DiAnt _x ]; - method ctyp : ctyp -> ctyp = - fun - [ TyNil _x -> let _x = o#loc _x in TyNil _x - | TyAli _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyAli _x _x_i1 _x_i2 - | TyAny _x -> let _x = o#loc _x in TyAny _x - | TyApp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyApp _x _x_i1 _x_i2 - | TyArr _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyArr _x _x_i1 _x_i2 - | TyCls _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in TyCls _x _x_i1 - | TyLab _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyLab _x _x_i1 _x_i2 - | TyId _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in TyId _x _x_i1 - | TyMan _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyMan _x _x_i1 _x_i2 - | TyDcl _x _x_i1 _x_i2 _x_i3 _x_i4 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#list (fun o -> o#ctyp) _x_i2 in - let _x_i3 = o#ctyp _x_i3 in - let _x_i4 = - o#list - (fun o (_x, _x_i1) -> - let _x = o#ctyp _x in - let _x_i1 = o#ctyp _x_i1 in (_x, _x_i1)) - _x_i4 - in TyDcl _x _x_i1 _x_i2 _x_i3 _x_i4 - | TyObj _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#row_var_flag _x_i2 in TyObj _x _x_i1 _x_i2 - | TyOlb _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOlb _x _x_i1 _x_i2 - | TyPol _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyPol _x _x_i1 _x_i2 - | TyTypePol _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyTypePol _x _x_i1 _x_i2 - | TyQuo _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyQuo _x _x_i1 - | TyQuP _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyQuP _x _x_i1 - | TyQuM _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyQuM _x _x_i1 - | TyAnP _x -> let _x = o#loc _x in TyAnP _x - | TyAnM _x -> let _x = o#loc _x in TyAnM _x - | TyVrn _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyVrn _x _x_i1 - | TyRec _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyRec _x _x_i1 - | TyCol _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyCol _x _x_i1 _x_i2 - | TySem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TySem _x _x_i1 _x_i2 - | TyCom _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyCom _x _x_i1 _x_i2 - | TySum _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TySum _x _x_i1 - | TyOf _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOf _x _x_i1 _x_i2 - | TyAnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyAnd _x _x_i1 _x_i2 - | TyOr _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOr _x _x_i1 _x_i2 - | TyPrv _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyPrv _x _x_i1 - | TyMut _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyMut _x _x_i1 - | TyTup _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyTup _x _x_i1 - | TySta _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TySta _x _x_i1 _x_i2 - | TyVrnEq _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyVrnEq _x _x_i1 - | TyVrnSup _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyVrnSup _x _x_i1 - | TyVrnInf _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyVrnInf _x _x_i1 - | TyVrnInfSup _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyVrnInfSup _x _x_i1 _x_i2 - | TyAmp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyAmp _x _x_i1 _x_i2 - | TyOfAmp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOfAmp _x _x_i1 _x_i2 - | TyPkg _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_type _x_i1 in TyPkg _x _x_i1 - | TyAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyAnt _x _x_i1 ]; - method class_type : class_type -> class_type = - fun - [ CtNil _x -> let _x = o#loc _x in CtNil _x - | CtCon _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#virtual_flag _x_i1 in - let _x_i2 = o#ident _x_i2 in - let _x_i3 = o#ctyp _x_i3 in CtCon _x _x_i1 _x_i2 _x_i3 - | CtFun _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#class_type _x_i2 in CtFun _x _x_i1 _x_i2 - | CtSig _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#class_sig_item _x_i2 in CtSig _x _x_i1 _x_i2 - | CtAnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in - let _x_i2 = o#class_type _x_i2 in CtAnd _x _x_i1 _x_i2 - | CtCol _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in - let _x_i2 = o#class_type _x_i2 in CtCol _x _x_i1 _x_i2 - | CtEq _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in - let _x_i2 = o#class_type _x_i2 in CtEq _x _x_i1 _x_i2 - | CtAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CtAnt _x _x_i1 ]; - method class_str_item : class_str_item -> class_str_item = - fun - [ CrNil _x -> let _x = o#loc _x in CrNil _x - | CrSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_str_item _x_i1 in - let _x_i2 = o#class_str_item _x_i2 in CrSem _x _x_i1 _x_i2 - | CrCtr _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in CrCtr _x _x_i1 _x_i2 - | CrInh _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#override_flag _x_i1 in - let _x_i2 = o#class_expr _x_i2 in - let _x_i3 = o#string _x_i3 in CrInh _x _x_i1 _x_i2 _x_i3 - | CrIni _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in CrIni _x _x_i1 - | CrMth _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#override_flag _x_i2 in - let _x_i3 = o#private_flag _x_i3 in - let _x_i4 = o#expr _x_i4 in - let _x_i5 = o#ctyp _x_i5 - in CrMth _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 - | CrVal _x _x_i1 _x_i2 _x_i3 _x_i4 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#override_flag _x_i2 in - let _x_i3 = o#mutable_flag _x_i3 in - let _x_i4 = o#expr _x_i4 in CrVal _x _x_i1 _x_i2 _x_i3 _x_i4 - | CrVir _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#private_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 in CrVir _x _x_i1 _x_i2 _x_i3 - | CrVvr _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#mutable_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 in CrVvr _x _x_i1 _x_i2 _x_i3 - | CrAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CrAnt _x _x_i1 ]; - method class_sig_item : class_sig_item -> class_sig_item = - fun - [ CgNil _x -> let _x = o#loc _x in CgNil _x - | CgCtr _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in CgCtr _x _x_i1 _x_i2 - | CgSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_sig_item _x_i1 in - let _x_i2 = o#class_sig_item _x_i2 in CgSem _x _x_i1 _x_i2 - | CgInh _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in CgInh _x _x_i1 - | CgMth _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#private_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 in CgMth _x _x_i1 _x_i2 _x_i3 - | CgVal _x _x_i1 _x_i2 _x_i3 _x_i4 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#mutable_flag _x_i2 in - let _x_i3 = o#virtual_flag _x_i3 in - let _x_i4 = o#ctyp _x_i4 in CgVal _x _x_i1 _x_i2 _x_i3 _x_i4 - | CgVir _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#private_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 in CgVir _x _x_i1 _x_i2 _x_i3 - | CgAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CgAnt _x _x_i1 ]; - method class_expr : class_expr -> class_expr = - fun - [ CeNil _x -> let _x = o#loc _x in CeNil _x - | CeApp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#expr _x_i2 in CeApp _x _x_i1 _x_i2 - | CeCon _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#virtual_flag _x_i1 in - let _x_i2 = o#ident _x_i2 in - let _x_i3 = o#ctyp _x_i3 in CeCon _x _x_i1 _x_i2 _x_i3 - | CeFun _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#class_expr _x_i2 in CeFun _x _x_i1 _x_i2 - | CeLet _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#rec_flag _x_i1 in - let _x_i2 = o#binding _x_i2 in - let _x_i3 = o#class_expr _x_i3 in CeLet _x _x_i1 _x_i2 _x_i3 - | CeStr _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#class_str_item _x_i2 in CeStr _x _x_i1 _x_i2 - | CeTyc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#class_type _x_i2 in CeTyc _x _x_i1 _x_i2 - | CeAnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#class_expr _x_i2 in CeAnd _x _x_i1 _x_i2 - | CeEq _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#class_expr _x_i2 in CeEq _x _x_i1 _x_i2 - | CeAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CeAnt _x _x_i1 ]; - method binding : binding -> binding = - fun - [ BiNil _x -> let _x = o#loc _x in BiNil _x - | BiAnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#binding _x_i1 in - let _x_i2 = o#binding _x_i2 in BiAnd _x _x_i1 _x_i2 - | BiEq _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#expr _x_i2 in BiEq _x _x_i1 _x_i2 - | BiAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in BiAnt _x _x_i1 ]; - method unknown : ! 'a. 'a -> 'a = fun x -> x; - end; - class fold = - object ((o : 'self_type)) - method string : string -> 'self_type = o#unknown; - method list : - ! 'a. ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type = - fun _f_a -> - fun - [ [] -> o - | [ _x :: _x_i1 ] -> - let o = _f_a o _x in let o = o#list _f_a _x_i1 in o ]; - method with_constr : with_constr -> 'self_type = - fun - [ WcNil _x -> let o = o#loc _x in o - | WcTyp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | WcMod _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | WcTyS _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | WcMoS _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | WcAnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#with_constr _x_i1 in let o = o#with_constr _x_i2 in o - | WcAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method virtual_flag : virtual_flag -> 'self_type = - fun - [ ViVirtual -> o - | ViNil -> o - | ViAnt _x -> let o = o#string _x in o ]; - method str_item : str_item -> 'self_type = - fun - [ StNil _x -> let o = o#loc _x in o - | StCls _x _x_i1 -> - let o = o#loc _x in let o = o#class_expr _x_i1 in o - | StClt _x _x_i1 -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | StSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#str_item _x_i1 in let o = o#str_item _x_i2 in o - | StDir _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | StExc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in - let o = o#meta_option (fun o -> o#ident) _x_i2 in o - | StExp _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | StExt _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#ctyp _x_i2 in - let o = o#meta_list (fun o -> o#string) _x_i3 in o - | StInc _x _x_i1 -> - let o = o#loc _x in let o = o#module_expr _x_i1 in o - | StMod _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#module_expr _x_i2 in o - | StRecMod _x _x_i1 -> - let o = o#loc _x in let o = o#module_binding _x_i1 in o - | StMty _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#module_type _x_i2 in o - | StOpn _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | StTyp _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | StVal _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#rec_flag _x_i1 in let o = o#binding _x_i2 in o - | StAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method sig_item : sig_item -> 'self_type = - fun - [ SgNil _x -> let o = o#loc _x in o - | SgCls _x _x_i1 -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | SgClt _x _x_i1 -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | SgSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#sig_item _x_i1 in let o = o#sig_item _x_i2 in o - | SgDir _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | SgExc _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | SgExt _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#ctyp _x_i2 in - let o = o#meta_list (fun o -> o#string) _x_i3 in o - | SgInc _x _x_i1 -> - let o = o#loc _x in let o = o#module_type _x_i1 in o - | SgMod _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#module_type _x_i2 in o - | SgRecMod _x _x_i1 -> - let o = o#loc _x in let o = o#module_binding _x_i1 in o - | SgMty _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#module_type _x_i2 in o - | SgOpn _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | SgTyp _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | SgVal _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o - | SgAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method row_var_flag : row_var_flag -> 'self_type = - fun - [ RvRowVar -> o - | RvNil -> o - | RvAnt _x -> let o = o#string _x in o ]; - method rec_flag : rec_flag -> 'self_type = - fun - [ ReRecursive -> o - | ReNil -> o - | ReAnt _x -> let o = o#string _x in o ]; - method rec_binding : rec_binding -> 'self_type = - fun - [ RbNil _x -> let o = o#loc _x in o - | RbSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#rec_binding _x_i1 in let o = o#rec_binding _x_i2 in o - | RbEq _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#expr _x_i2 in o - | RbAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method private_flag : private_flag -> 'self_type = - fun - [ PrPrivate -> o - | PrNil -> o - | PrAnt _x -> let o = o#string _x in o ]; - method patt : patt -> 'self_type = - fun - [ PaNil _x -> let o = o#loc _x in o - | PaId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | PaAli _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | PaAny _x -> let o = o#loc _x in o - | PaApp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaArr _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o - | PaCom _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaChr _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | PaInt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | PaInt32 _x _x_i1 -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaInt64 _x _x_i1 -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaNativeInt _x _x_i1 -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaFlo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | PaLab _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#patt _x_i2 in o - | PaOlb _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#patt _x_i2 in o - | PaOlbi _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#patt _x_i2 in let o = o#expr _x_i3 in o - | PaOrp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaRng _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaRec _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o - | PaEq _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#patt _x_i2 in o - | PaStr _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | PaTup _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o - | PaTyc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#ctyp _x_i2 in o - | PaTyp _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | PaVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | PaLaz _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o - | PaMod _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method override_flag : override_flag -> 'self_type = - fun - [ OvOverride -> o - | OvNil -> o - | OvAnt _x -> let o = o#string _x in o ]; - method mutable_flag : mutable_flag -> 'self_type = - fun - [ MuMutable -> o - | MuNil -> o - | MuAnt _x -> let o = o#string _x in o ]; - method module_type : module_type -> 'self_type = - fun - [ MtNil _x -> let o = o#loc _x in o - | MtId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | MtFun _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in let o = o#module_type _x_i3 in o - | MtQuo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | MtSig _x _x_i1 -> - let o = o#loc _x in let o = o#sig_item _x_i1 in o - | MtWit _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#module_type _x_i1 in let o = o#with_constr _x_i2 in o - | MtOf _x _x_i1 -> - let o = o#loc _x in let o = o#module_expr _x_i1 in o - | MtAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method module_expr : module_expr -> 'self_type = - fun - [ MeNil _x -> let o = o#loc _x in o - | MeId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | MeApp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#module_expr _x_i1 in let o = o#module_expr _x_i2 in o - | MeFun _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in let o = o#module_expr _x_i3 in o - | MeStr _x _x_i1 -> - let o = o#loc _x in let o = o#str_item _x_i1 in o - | MeTyc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#module_expr _x_i1 in let o = o#module_type _x_i2 in o - | MePkg _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | MeAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method module_binding : module_binding -> 'self_type = - fun - [ MbNil _x -> let o = o#loc _x in o - | MbAnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#module_binding _x_i1 in - let o = o#module_binding _x_i2 in o - | MbColEq _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in let o = o#module_expr _x_i3 in o - | MbCol _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#module_type _x_i2 in o - | MbAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method meta_option : - ! 'a. - ('self_type -> 'a -> 'self_type) -> meta_option 'a -> 'self_type = - fun _f_a -> - fun - [ ONone -> o - | OSome _x -> let o = _f_a o _x in o - | OAnt _x -> let o = o#string _x in o ]; - method meta_list : - ! 'a. - ('self_type -> 'a -> 'self_type) -> meta_list 'a -> 'self_type = - fun _f_a -> - fun - [ LNil -> o - | LCons _x _x_i1 -> - let o = _f_a o _x in let o = o#meta_list _f_a _x_i1 in o - | LAnt _x -> let o = o#string _x in o ]; - method meta_bool : meta_bool -> 'self_type = - fun - [ BTrue -> o - | BFalse -> o - | BAnt _x -> let o = o#string _x in o ]; - method match_case : match_case -> 'self_type = - fun - [ McNil _x -> let o = o#loc _x in o - | McOr _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#match_case _x_i1 in let o = o#match_case _x_i2 in o - | McArr _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#patt _x_i1 in - let o = o#expr _x_i2 in let o = o#expr _x_i3 in o - | McAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method loc : loc -> 'self_type = o#unknown; - method ident : ident -> 'self_type = - fun - [ IdAcc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | IdApp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | IdLid _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | IdUid _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | IdAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method expr : expr -> 'self_type = - fun - [ ExNil _x -> let o = o#loc _x in o - | ExId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | ExAcc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | ExApp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExAre _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExArr _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | ExSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExAsf _x -> let o = o#loc _x in o - | ExAsr _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | ExAss _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExChr _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | ExCoe _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#expr _x_i1 in - let o = o#ctyp _x_i2 in let o = o#ctyp _x_i3 in o - | ExFlo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | ExFor _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#expr _x_i2 in - let o = o#expr _x_i3 in - let o = o#direction_flag _x_i4 in let o = o#expr _x_i5 in o - | ExFun _x _x_i1 -> - let o = o#loc _x in let o = o#match_case _x_i1 in o - | ExIfe _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#expr _x_i1 in - let o = o#expr _x_i2 in let o = o#expr _x_i3 in o - | ExInt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | ExInt32 _x _x_i1 -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExInt64 _x _x_i1 -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExNativeInt _x _x_i1 -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExLab _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | ExLaz _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | ExLet _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#rec_flag _x_i1 in - let o = o#binding _x_i2 in let o = o#expr _x_i3 in o - | ExLmd _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_expr _x_i2 in let o = o#expr _x_i3 in o - | ExMat _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#match_case _x_i2 in o - | ExNew _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | ExObj _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#class_str_item _x_i2 in o - | ExOlb _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | ExOvr _x _x_i1 -> - let o = o#loc _x in let o = o#rec_binding _x_i1 in o - | ExRec _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#rec_binding _x_i1 in let o = o#expr _x_i2 in o - | ExSeq _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | ExSnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#string _x_i2 in o - | ExSte _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExStr _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | ExTry _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#match_case _x_i2 in o - | ExTup _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | ExCom _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExTyc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#ctyp _x_i2 in o - | ExVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | ExWhi _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExOpI _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#expr _x_i2 in o - | ExFUN _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | ExPkg _x _x_i1 -> - let o = o#loc _x in let o = o#module_expr _x_i1 in o ]; - method direction_flag : direction_flag -> 'self_type = - fun - [ DiTo -> o - | DiDownto -> o - | DiAnt _x -> let o = o#string _x in o ]; - method ctyp : ctyp -> 'self_type = - fun - [ TyNil _x -> let o = o#loc _x in o - | TyAli _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyAny _x -> let o = o#loc _x in o - | TyApp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyArr _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyCls _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | TyLab _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o - | TyId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | TyMan _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyDcl _x _x_i1 _x_i2 _x_i3 _x_i4 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#list (fun o -> o#ctyp) _x_i2 in - let o = o#ctyp _x_i3 in - let o = - o#list - (fun o (_x, _x_i1) -> - let o = o#ctyp _x in let o = o#ctyp _x_i1 in o) - _x_i4 - in o - | TyObj _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#row_var_flag _x_i2 in o - | TyOlb _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o - | TyPol _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyTypePol _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyQuo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | TyQuP _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | TyQuM _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | TyAnP _x -> let o = o#loc _x in o - | TyAnM _x -> let o = o#loc _x in o - | TyVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | TyRec _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyCol _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TySem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyCom _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TySum _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyOf _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyAnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyOr _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyPrv _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyMut _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyTup _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TySta _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyVrnEq _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyVrnSup _x _x_i1 -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyVrnInf _x _x_i1 -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyVrnInfSup _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyAmp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyOfAmp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyPkg _x _x_i1 -> - let o = o#loc _x in let o = o#module_type _x_i1 in o - | TyAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method class_type : class_type -> 'self_type = - fun - [ CtNil _x -> let o = o#loc _x in o - | CtCon _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#virtual_flag _x_i1 in - let o = o#ident _x_i2 in let o = o#ctyp _x_i3 in o - | CtFun _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#class_type _x_i2 in o - | CtSig _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#class_sig_item _x_i2 in o - | CtAnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_type _x_i1 in let o = o#class_type _x_i2 in o - | CtCol _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_type _x_i1 in let o = o#class_type _x_i2 in o - | CtEq _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_type _x_i1 in let o = o#class_type _x_i2 in o - | CtAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method class_str_item : class_str_item -> 'self_type = - fun - [ CrNil _x -> let o = o#loc _x in o - | CrSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_str_item _x_i1 in - let o = o#class_str_item _x_i2 in o - | CrCtr _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | CrInh _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#override_flag _x_i1 in - let o = o#class_expr _x_i2 in let o = o#string _x_i3 in o - | CrIni _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | CrMth _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#override_flag _x_i2 in - let o = o#private_flag _x_i3 in - let o = o#expr _x_i4 in let o = o#ctyp _x_i5 in o - | CrVal _x _x_i1 _x_i2 _x_i3 _x_i4 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#override_flag _x_i2 in - let o = o#mutable_flag _x_i3 in let o = o#expr _x_i4 in o - | CrVir _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#private_flag _x_i2 in let o = o#ctyp _x_i3 in o - | CrVvr _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#mutable_flag _x_i2 in let o = o#ctyp _x_i3 in o - | CrAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method class_sig_item : class_sig_item -> 'self_type = - fun - [ CgNil _x -> let o = o#loc _x in o - | CgCtr _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | CgSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_sig_item _x_i1 in - let o = o#class_sig_item _x_i2 in o - | CgInh _x _x_i1 -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | CgMth _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#private_flag _x_i2 in let o = o#ctyp _x_i3 in o - | CgVal _x _x_i1 _x_i2 _x_i3 _x_i4 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#mutable_flag _x_i2 in - let o = o#virtual_flag _x_i3 in let o = o#ctyp _x_i4 in o - | CgVir _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#private_flag _x_i2 in let o = o#ctyp _x_i3 in o - | CgAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method class_expr : class_expr -> 'self_type = - fun - [ CeNil _x -> let o = o#loc _x in o - | CeApp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in let o = o#expr _x_i2 in o - | CeCon _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#virtual_flag _x_i1 in - let o = o#ident _x_i2 in let o = o#ctyp _x_i3 in o - | CeFun _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#class_expr _x_i2 in o - | CeLet _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#rec_flag _x_i1 in - let o = o#binding _x_i2 in let o = o#class_expr _x_i3 in o - | CeStr _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#class_str_item _x_i2 in o - | CeTyc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in let o = o#class_type _x_i2 in o - | CeAnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in let o = o#class_expr _x_i2 in o - | CeEq _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in let o = o#class_expr _x_i2 in o - | CeAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method binding : binding -> 'self_type = - fun - [ BiNil _x -> let o = o#loc _x in o - | BiAnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#binding _x_i1 in let o = o#binding _x_i2 in o - | BiEq _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#expr _x_i2 in o - | BiAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method unknown : ! 'a. 'a -> 'self_type = fun _ -> o; - end; - value map_expr f = - object inherit map as super; method expr = fun x -> f (super#expr x); - end; - value map_patt f = - object inherit map as super; method patt = fun x -> f (super#patt x); - end; - value map_ctyp f = - object inherit map as super; method ctyp = fun x -> f (super#ctyp x); - end; - value map_str_item f = - object - inherit map as super; - method str_item = fun x -> f (super#str_item x); - end; - value map_sig_item f = - object - inherit map as super; - method sig_item = fun x -> f (super#sig_item x); - end; - value map_loc f = - object inherit map as super; method loc = fun x -> f (super#loc x); end; - end; - diff -Nru ocaml-4.01.0/camlp4/boot/camlp4boot.ml ocaml-4.05.0/camlp4/boot/camlp4boot.ml --- ocaml-4.01.0/camlp4/boot/camlp4boot.ml 2013-08-30 11:39:33.000000000 +0000 +++ ocaml-4.05.0/camlp4/boot/camlp4boot.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,16057 +0,0 @@ -module R = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2002-2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - module Id = - struct - let name = "Camlp4OCamlRevisedParser" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - open Sig - - include Syntax - - (* Camlp4_config.constructors_arity.val := True; *) - let _ = Camlp4_config.constructors_arity := false - - let help_sequences () = - (Printf.eprintf - "\ -New syntax:\ -\n (e1; e2; ... ; en) OR begin e1; e2; ... ; en end\ -\n while e do e1; e2; ... ; en done\ -\n for v = v1 to/downto v2 do e1; e2; ... ; en done\ -\nOld syntax (still supported):\ -\n do {e1; e2; ... ; en}\ -\n while e do {e1; e2; ... ; en}\ -\n for v = v1 to/downto v2 do {e1; e2; ... ; en}\ -\nVery old (no more supported) syntax:\ -\n do e1; e2; ... ; en-1; return en\ -\n while e do e1; e2; ... ; en; done\ -\n for v = v1 to/downto v2 do e1; e2; ... ; en; done\ -\n"; - flush stderr; - exit 1) - - let _ = - Options.add "-help_seq" (Arg.Unit help_sequences) - "Print explanations about new sequences and exit." - - let _ = Gram.Entry.clear a_CHAR - - let _ = Gram.Entry.clear a_FLOAT - - let _ = Gram.Entry.clear a_INT - - let _ = Gram.Entry.clear a_INT32 - - let _ = Gram.Entry.clear a_INT64 - - let _ = Gram.Entry.clear a_LABEL - - let _ = Gram.Entry.clear a_LIDENT - - let _ = Gram.Entry.clear a_NATIVEINT - - let _ = Gram.Entry.clear a_OPTLABEL - - let _ = Gram.Entry.clear a_STRING - - let _ = Gram.Entry.clear a_UIDENT - - let _ = Gram.Entry.clear a_ident - - let _ = Gram.Entry.clear amp_ctyp - - let _ = Gram.Entry.clear and_ctyp - - let _ = Gram.Entry.clear match_case - - let _ = Gram.Entry.clear match_case0 - - let _ = Gram.Entry.clear match_case_quot - - let _ = Gram.Entry.clear binding - - let _ = Gram.Entry.clear binding_quot - - let _ = Gram.Entry.clear rec_binding_quot - - let _ = Gram.Entry.clear class_declaration - - let _ = Gram.Entry.clear class_description - - let _ = Gram.Entry.clear class_expr - - let _ = Gram.Entry.clear class_expr_quot - - let _ = Gram.Entry.clear class_fun_binding - - let _ = Gram.Entry.clear class_fun_def - - let _ = Gram.Entry.clear class_info_for_class_expr - - let _ = Gram.Entry.clear class_info_for_class_type - - let _ = Gram.Entry.clear class_longident - - let _ = Gram.Entry.clear class_longident_and_param - - let _ = Gram.Entry.clear class_name_and_param - - let _ = Gram.Entry.clear class_sig_item - - let _ = Gram.Entry.clear class_sig_item_quot - - let _ = Gram.Entry.clear class_signature - - let _ = Gram.Entry.clear class_str_item - - let _ = Gram.Entry.clear class_str_item_quot - - let _ = Gram.Entry.clear class_structure - - let _ = Gram.Entry.clear class_type - - let _ = Gram.Entry.clear class_type_declaration - - let _ = Gram.Entry.clear class_type_longident - - let _ = Gram.Entry.clear class_type_longident_and_param - - let _ = Gram.Entry.clear class_type_plus - - let _ = Gram.Entry.clear class_type_quot - - let _ = Gram.Entry.clear comma_ctyp - - let _ = Gram.Entry.clear comma_expr - - let _ = Gram.Entry.clear comma_ipatt - - let _ = Gram.Entry.clear comma_patt - - let _ = Gram.Entry.clear comma_type_parameter - - let _ = Gram.Entry.clear constrain - - let _ = Gram.Entry.clear constructor_arg_list - - let _ = Gram.Entry.clear constructor_declaration - - let _ = Gram.Entry.clear constructor_declarations - - let _ = Gram.Entry.clear ctyp - - let _ = Gram.Entry.clear ctyp_quot - - let _ = Gram.Entry.clear cvalue_binding - - let _ = Gram.Entry.clear direction_flag - - let _ = Gram.Entry.clear dummy - - let _ = Gram.Entry.clear eq_expr - - let _ = Gram.Entry.clear expr - - let _ = Gram.Entry.clear expr_eoi - - let _ = Gram.Entry.clear expr_quot - - let _ = Gram.Entry.clear field_expr - - let _ = Gram.Entry.clear field_expr_list - - let _ = Gram.Entry.clear fun_binding - - let _ = Gram.Entry.clear fun_def - - let _ = Gram.Entry.clear ident - - let _ = Gram.Entry.clear ident_quot - - let _ = Gram.Entry.clear implem - - let _ = Gram.Entry.clear interf - - let _ = Gram.Entry.clear ipatt - - let _ = Gram.Entry.clear ipatt_tcon - - let _ = Gram.Entry.clear label - - let _ = Gram.Entry.clear label_declaration - - let _ = Gram.Entry.clear label_declaration_list - - let _ = Gram.Entry.clear label_expr_list - - let _ = Gram.Entry.clear label_expr - - let _ = Gram.Entry.clear label_ipatt - - let _ = Gram.Entry.clear label_ipatt_list - - let _ = Gram.Entry.clear label_longident - - let _ = Gram.Entry.clear label_patt - - let _ = Gram.Entry.clear label_patt_list - - let _ = Gram.Entry.clear labeled_ipatt - - let _ = Gram.Entry.clear let_binding - - let _ = Gram.Entry.clear meth_list - - let _ = Gram.Entry.clear meth_decl - - let _ = Gram.Entry.clear module_binding - - let _ = Gram.Entry.clear module_binding0 - - let _ = Gram.Entry.clear module_binding_quot - - let _ = Gram.Entry.clear module_declaration - - let _ = Gram.Entry.clear module_expr - - let _ = Gram.Entry.clear module_expr_quot - - let _ = Gram.Entry.clear module_longident - - let _ = Gram.Entry.clear module_longident_with_app - - let _ = Gram.Entry.clear module_rec_declaration - - let _ = Gram.Entry.clear module_type - - let _ = Gram.Entry.clear module_type_quot - - let _ = Gram.Entry.clear more_ctyp - - let _ = Gram.Entry.clear name_tags - - let _ = Gram.Entry.clear opt_as_lident - - let _ = Gram.Entry.clear opt_class_self_patt - - let _ = Gram.Entry.clear opt_class_self_type - - let _ = Gram.Entry.clear opt_comma_ctyp - - let _ = Gram.Entry.clear opt_dot_dot - - let _ = Gram.Entry.clear opt_eq_ctyp - - let _ = Gram.Entry.clear opt_expr - - let _ = Gram.Entry.clear opt_meth_list - - let _ = Gram.Entry.clear opt_mutable - - let _ = Gram.Entry.clear opt_polyt - - let _ = Gram.Entry.clear opt_private - - let _ = Gram.Entry.clear opt_rec - - let _ = Gram.Entry.clear opt_virtual - - let _ = Gram.Entry.clear opt_when_expr - - let _ = Gram.Entry.clear patt - - let _ = Gram.Entry.clear patt_as_patt_opt - - let _ = Gram.Entry.clear patt_eoi - - let _ = Gram.Entry.clear patt_quot - - let _ = Gram.Entry.clear patt_tcon - - let _ = Gram.Entry.clear phrase - - let _ = Gram.Entry.clear poly_type - - let _ = Gram.Entry.clear row_field - - let _ = Gram.Entry.clear sem_expr - - let _ = Gram.Entry.clear sem_expr_for_list - - let _ = Gram.Entry.clear sem_patt - - let _ = Gram.Entry.clear sem_patt_for_list - - let _ = Gram.Entry.clear semi - - let _ = Gram.Entry.clear sequence - - let _ = Gram.Entry.clear sig_item - - let _ = Gram.Entry.clear sig_item_quot - - let _ = Gram.Entry.clear sig_items - - let _ = Gram.Entry.clear star_ctyp - - let _ = Gram.Entry.clear str_item - - let _ = Gram.Entry.clear str_item_quot - - let _ = Gram.Entry.clear str_items - - let _ = Gram.Entry.clear top_phrase - - let _ = Gram.Entry.clear type_constraint - - let _ = Gram.Entry.clear type_declaration - - let _ = Gram.Entry.clear type_ident_and_parameters - - let _ = Gram.Entry.clear type_kind - - let _ = Gram.Entry.clear type_longident - - let _ = Gram.Entry.clear type_longident_and_parameters - - let _ = Gram.Entry.clear type_parameter - - let _ = Gram.Entry.clear type_parameters - - let _ = Gram.Entry.clear typevars - - let _ = Gram.Entry.clear use_file - - let _ = Gram.Entry.clear val_longident - - let _ = Gram.Entry.clear value_let - - let _ = Gram.Entry.clear value_val - - let _ = Gram.Entry.clear with_constr - - let _ = Gram.Entry.clear with_constr_quot - - let neg_string n = - let len = String.length n - in - if (len > 0) && (n.[0] = '-') - then String.sub n 1 (len - 1) - else "-" ^ n - - let mkumin _loc f arg = - match arg with - | Ast.ExInt (_, n) -> Ast.ExInt (_loc, (neg_string n)) - | Ast.ExInt32 (_, n) -> Ast.ExInt32 (_loc, (neg_string n)) - | Ast.ExInt64 (_, n) -> Ast.ExInt64 (_loc, (neg_string n)) - | Ast.ExNativeInt (_, n) -> Ast.ExNativeInt (_loc, (neg_string n)) - | Ast.ExFlo (_, n) -> Ast.ExFlo (_loc, (neg_string n)) - | _ -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, ("~" ^ f))))), arg) - - let mklistexp _loc last = - let rec loop top = - function - | [] -> - (match last with - | Some e -> e - | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) - | e1 :: el -> - let _loc = - if top then _loc else Loc.merge (Ast.loc_of_expr e1) _loc - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e1)), - (loop false el)) - in loop true - - let mkassert _loc = - function - | Ast.ExId (_, (Ast.IdUid (_, "False"))) -> Ast.ExAsf _loc - | (* this case takes care about - the special assert false node *) - e -> Ast.ExAsr (_loc, e) - - let append_eLem el e = el @ [ e ] - - let mk_anti ?(c = "") n s = "\\$" ^ (n ^ (c ^ (":" ^ s))) - - let mksequence _loc = - function - | (Ast.ExSem (_, _, _) | Ast.ExAnt (_, _) as e) -> - Ast.ExSeq (_loc, e) - | e -> e - - let mksequence' _loc = - function - | (Ast.ExSem (_, _, _) as e) -> Ast.ExSeq (_loc, e) - | e -> e - - let rec lid_of_ident = - function - | Ast.IdAcc (_, _, i) -> lid_of_ident i - | Ast.IdLid (_, lid) -> lid - | _ -> assert false - - let module_type_app mt1 mt2 = - match (mt1, mt2) with - | (Ast.MtId (_loc, i1), Ast.MtId (_, i2)) -> - Ast.MtId (_loc, (Ast.IdApp (_loc, i1, i2))) - | _ -> raise Stream.Failure - - let module_type_acc mt1 mt2 = - match (mt1, mt2) with - | (Ast.MtId (_loc, i1), Ast.MtId (_, i2)) -> - Ast.MtId (_loc, (Ast.IdAcc (_loc, i1, i2))) - | _ -> raise Stream.Failure - - let bigarray_get _loc arr arg = - let coords = - match arg with - | Ast.ExTup (_, (Ast.ExCom (_, e1, e2))) | Ast.ExCom (_, e1, e2) - -> Ast.list_of_expr e1 (Ast.list_of_expr e2 []) - | _ -> [ arg ] - in - match coords with - | [ c1 ] -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Array1")), - (Ast.IdLid (_loc, "get")))))))), - arr)), - c1) - | [ c1; c2 ] -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Array2")), - (Ast.IdLid (_loc, "get")))))))), - arr)), - c1)), - c2) - | [ c1; c2; c3 ] -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Array3")), - (Ast.IdLid (_loc, "get")))))))), - arr)), - c1)), - c2)), - c3) - | (* | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ] *) - coords -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Genarray")), - (Ast.IdLid (_loc, "get")))))))), - arr)), - (Ast.ExArr (_loc, (Ast.exSem_of_list coords)))) - - let bigarray_set _loc var newval = - match var with - | Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), - (Ast.IdAcc (_, (Ast.IdUid (_, "Array1")), - (Ast.IdLid (_, "get")))))))), - arr)), - c1) -> - Some - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Array1")), - (Ast.IdLid (_loc, "set")))))))), - arr)), - c1)), - newval)) - | Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), - (Ast.IdAcc (_, (Ast.IdUid (_, "Array2")), - (Ast.IdLid (_, "get")))))))), - arr)), - c1)), - c2) -> - Some - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Array2")), - (Ast.IdLid (_loc, "set")))))))), - arr)), - c1)), - c2)), - newval)) - | Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), - (Ast.IdAcc (_, (Ast.IdUid (_, "Array3")), - (Ast.IdLid (_, "get")))))))), - arr)), - c1)), - c2)), - c3) -> - Some - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Array3")), - (Ast.IdLid (_loc, "set")))))))), - arr)), - c1)), - c2)), - c3)), - newval)) - | Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), - (Ast.IdAcc (_, (Ast.IdUid (_, "Genarray")), - (Ast.IdLid (_, "get")))))))), - arr)), - (Ast.ExArr (_, coords))) -> - Some - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Genarray")), - (Ast.IdLid (_loc, "set")))))))), - arr)), - (Ast.ExArr (_loc, coords)))), - newval)) - | _ -> None - - let stopped_at _loc = Some (Loc.move_line 1 _loc) - - (* FIXME be more precise *) - let rec generalized_type_of_type = - function - | Ast.TyArr (_, t1, t2) -> - let (tl, rt) = generalized_type_of_type t2 in ((t1 :: tl), rt) - | t -> ([], t) - - let symbolchar = - let list = - [ '$'; '!'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; - '>'; '?'; '@'; '^'; '|'; '~'; '\\' ] in - let rec loop s i = - if i == (String.length s) - then true - else if List.mem s.[i] list then loop s (i + 1) else false - in loop - - let setup_op_parser entry p = - Gram.Entry.setup_parser entry - (fun (__strm : _ Stream.t) -> - match Stream.peek __strm with - | Some (((KEYWORD x | SYMBOL x), ti)) when p x -> - (Stream.junk __strm; - let _loc = Gram.token_location ti - in Ast.ExId (_loc, (Ast.IdLid (_loc, x)))) - | _ -> raise Stream.Failure) - - let _ = - let list = [ '!'; '?'; '~' ] in - let excl = [ "!="; "??" ] - in - setup_op_parser prefixop - (fun x -> - (not (List.mem x excl)) && - (((String.length x) >= 2) && - ((List.mem x.[0] list) && (symbolchar x 1)))) - - let _ = - let list_ok = - [ "<"; ">"; "<="; ">="; "="; "<>"; "=="; "!="; "$" ] in - let list_first_char_ok = [ '='; '<'; '>'; '|'; '&'; '$'; '!' ] in - let excl = [ "<-"; "||"; "&&" ] - in - setup_op_parser infixop0 - (fun x -> - (List.mem x list_ok) || - ((not (List.mem x excl)) && - (((String.length x) >= 2) && - ((List.mem x.[0] list_first_char_ok) && - (symbolchar x 1))))) - - let _ = - let list = [ '@'; '^' ] - in - setup_op_parser infixop1 - (fun x -> - ((String.length x) >= 1) && - ((List.mem x.[0] list) && (symbolchar x 1))) - - let _ = - let list = [ '+'; '-' ] - in - setup_op_parser infixop2 - (fun x -> - (x <> "->") && - (((String.length x) >= 1) && - ((List.mem x.[0] list) && (symbolchar x 1)))) - - let _ = - let list = [ '*'; '/'; '%'; '\\' ] - in - setup_op_parser infixop3 - (fun x -> - ((String.length x) >= 1) && - ((List.mem x.[0] list) && - (((x.[0] <> '*') || - (((String.length x) < 2) || (x.[1] <> '*'))) - && (symbolchar x 1)))) - - let _ = - setup_op_parser infixop4 - (fun x -> - ((String.length x) >= 2) && - ((x.[0] == '*') && ((x.[1] == '*') && (symbolchar x 2)))) - - let rec infix_kwds_filter (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some (((KEYWORD "(", _) as tok)) -> - (Stream.junk __strm; - let xs = __strm in - let (__strm : _ Stream.t) = xs - in - (match Stream.peek __strm with - | Some - ((KEYWORD - (("or" | "mod" | "land" | "lor" | "lxor" | "lsl" | - "lsr" | "asr" - as i)), - _loc)) - -> - (Stream.junk __strm; - (match Stream.peek __strm with - | Some ((KEYWORD ")", _)) -> - (Stream.junk __strm; - let xs = __strm - in - Stream.lcons (fun _ -> ((LIDENT i), _loc)) - (Stream.slazy - (fun _ -> infix_kwds_filter xs))) - | _ -> raise (Stream.Error ""))) - | _ -> - let xs = __strm - in - Stream.icons tok - (Stream.slazy (fun _ -> infix_kwds_filter xs)))) - | Some x -> - (Stream.junk __strm; - let xs = __strm - in - Stream.icons x - (Stream.slazy (fun _ -> infix_kwds_filter xs))) - | _ -> raise Stream.Failure - - let _ = - Token.Filter.define_filter (Gram.get_filter ()) - (fun f strm -> infix_kwds_filter (f strm)) - - let _ = - Gram.Entry.setup_parser sem_expr - (let symb1 = Gram.parse_tokens_after_filter expr in - let symb (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some ((ANTIQUOT ((("list" as n)), s), ti)) -> - (Stream.junk __strm; - let _loc = Gram.token_location ti - in Ast.ExAnt (_loc, (mk_anti ~c: "expr;" n s))) - | _ -> symb1 __strm in - let rec kont al (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some ((KEYWORD ";", _)) -> - (Stream.junk __strm; - let a = - (try symb __strm - with | Stream.Failure -> raise (Stream.Error "")) in - let s = __strm in - let _loc = - Loc.merge (Ast.loc_of_expr al) (Ast.loc_of_expr a) - in kont (Ast.ExSem (_loc, al, a)) s) - | _ -> al - in - fun (__strm : _ Stream.t) -> - let a = symb __strm in kont a __strm) - - let _ = - let apply () = - let _ = (a_CHAR : 'a_CHAR Gram.Entry.t) - and _ = (override_flag_quot : 'override_flag_quot Gram.Entry.t) - and _ = (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t) - and _ = (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t) - and _ = (private_flag_quot : 'private_flag_quot Gram.Entry.t) - and _ = (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t) - and _ = (direction_flag_quot : 'direction_flag_quot Gram.Entry.t) - and _ = (rec_flag_quot : 'rec_flag_quot Gram.Entry.t) - and _ = (package_type : 'package_type Gram.Entry.t) - and _ = (do_sequence : 'do_sequence Gram.Entry.t) - and _ = (infixop4 : 'infixop4 Gram.Entry.t) - and _ = (infixop3 : 'infixop3 Gram.Entry.t) - and _ = (infixop2 : 'infixop2 Gram.Entry.t) - and _ = (infixop1 : 'infixop1 Gram.Entry.t) - and _ = (infixop0 : 'infixop0 Gram.Entry.t) - and _ = (with_constr_quot : 'with_constr_quot Gram.Entry.t) - and _ = (with_constr : 'with_constr Gram.Entry.t) - and _ = (value_val : 'value_val Gram.Entry.t) - and _ = (value_let : 'value_let Gram.Entry.t) - and _ = (val_longident : 'val_longident Gram.Entry.t) - and _ = (use_file : 'use_file Gram.Entry.t) - and _ = (typevars : 'typevars Gram.Entry.t) - and _ = (type_parameters : 'type_parameters Gram.Entry.t) - and _ = (type_parameter : 'type_parameter Gram.Entry.t) - and _ = - (type_longident_and_parameters : - 'type_longident_and_parameters Gram.Entry.t) - and _ = (type_longident : 'type_longident Gram.Entry.t) - and _ = (type_kind : 'type_kind Gram.Entry.t) - and _ = - (type_ident_and_parameters : - 'type_ident_and_parameters Gram.Entry.t) - and _ = (type_declaration : 'type_declaration Gram.Entry.t) - and _ = (type_constraint : 'type_constraint Gram.Entry.t) - and _ = (top_phrase : 'top_phrase Gram.Entry.t) - and _ = (str_items : 'str_items Gram.Entry.t) - and _ = (str_item_quot : 'str_item_quot Gram.Entry.t) - and _ = (str_item : 'str_item Gram.Entry.t) - and _ = (star_ctyp : 'star_ctyp Gram.Entry.t) - and _ = (sig_items : 'sig_items Gram.Entry.t) - and _ = (sig_item_quot : 'sig_item_quot Gram.Entry.t) - and _ = (sig_item : 'sig_item Gram.Entry.t) - and _ = (sequence : 'sequence Gram.Entry.t) - and _ = (semi : 'semi Gram.Entry.t) - and _ = (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t) - and _ = (sem_patt : 'sem_patt Gram.Entry.t) - and _ = (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t) - and _ = (sem_expr : 'sem_expr Gram.Entry.t) - and _ = (row_field : 'row_field Gram.Entry.t) - and _ = (poly_type : 'poly_type Gram.Entry.t) - and _ = (phrase : 'phrase Gram.Entry.t) - and _ = (patt_tcon : 'patt_tcon Gram.Entry.t) - and _ = (patt_quot : 'patt_quot Gram.Entry.t) - and _ = (patt_eoi : 'patt_eoi Gram.Entry.t) - and _ = (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t) - and _ = (patt : 'patt Gram.Entry.t) - and _ = (opt_when_expr : 'opt_when_expr Gram.Entry.t) - and _ = (opt_virtual : 'opt_virtual Gram.Entry.t) - and _ = (opt_rec : 'opt_rec Gram.Entry.t) - and _ = (opt_private : 'opt_private Gram.Entry.t) - and _ = (opt_polyt : 'opt_polyt Gram.Entry.t) - and _ = (opt_mutable : 'opt_mutable Gram.Entry.t) - and _ = (opt_meth_list : 'opt_meth_list Gram.Entry.t) - and _ = (opt_expr : 'opt_expr Gram.Entry.t) - and _ = (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t) - and _ = (opt_dot_dot : 'opt_dot_dot Gram.Entry.t) - and _ = (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t) - and _ = (opt_class_self_type : 'opt_class_self_type Gram.Entry.t) - and _ = (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t) - and _ = (opt_as_lident : 'opt_as_lident Gram.Entry.t) - and _ = (name_tags : 'name_tags Gram.Entry.t) - and _ = (more_ctyp : 'more_ctyp Gram.Entry.t) - and _ = (module_type_quot : 'module_type_quot Gram.Entry.t) - and _ = (module_type : 'module_type Gram.Entry.t) - and _ = - (module_rec_declaration : 'module_rec_declaration Gram.Entry.t) - and _ = - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t) - and _ = (module_longident : 'module_longident Gram.Entry.t) - and _ = (module_expr_quot : 'module_expr_quot Gram.Entry.t) - and _ = (module_expr : 'module_expr Gram.Entry.t) - and _ = (module_declaration : 'module_declaration Gram.Entry.t) - and _ = (module_binding_quot : 'module_binding_quot Gram.Entry.t) - and _ = (module_binding0 : 'module_binding0 Gram.Entry.t) - and _ = (module_binding : 'module_binding Gram.Entry.t) - and _ = (meth_decl : 'meth_decl Gram.Entry.t) - and _ = (meth_list : 'meth_list Gram.Entry.t) - and _ = (let_binding : 'let_binding Gram.Entry.t) - and _ = (labeled_ipatt : 'labeled_ipatt Gram.Entry.t) - and _ = (label_patt_list : 'label_patt_list Gram.Entry.t) - and _ = (label_patt : 'label_patt Gram.Entry.t) - and _ = (label_longident : 'label_longident Gram.Entry.t) - and _ = (label_ipatt_list : 'label_ipatt_list Gram.Entry.t) - and _ = (label_ipatt : 'label_ipatt Gram.Entry.t) - and _ = (label_expr_list : 'label_expr_list Gram.Entry.t) - and _ = (label_expr : 'label_expr Gram.Entry.t) - and _ = - (label_declaration_list : 'label_declaration_list Gram.Entry.t) - and _ = (label_declaration : 'label_declaration Gram.Entry.t) - and _ = (label : 'label Gram.Entry.t) - and _ = (ipatt_tcon : 'ipatt_tcon Gram.Entry.t) - and _ = (ipatt : 'ipatt Gram.Entry.t) - and _ = (interf : 'interf Gram.Entry.t) - and _ = (implem : 'implem Gram.Entry.t) - and _ = (ident_quot : 'ident_quot Gram.Entry.t) - and _ = (ident : 'ident Gram.Entry.t) - and _ = (fun_def : 'fun_def Gram.Entry.t) - and _ = (fun_binding : 'fun_binding Gram.Entry.t) - and _ = (field_expr_list : 'field_expr_list Gram.Entry.t) - and _ = (field_expr : 'field_expr Gram.Entry.t) - and _ = (expr_quot : 'expr_quot Gram.Entry.t) - and _ = (expr_eoi : 'expr_eoi Gram.Entry.t) - and _ = (expr : 'expr Gram.Entry.t) - and _ = (eq_expr : 'eq_expr Gram.Entry.t) - and _ = (dummy : 'dummy Gram.Entry.t) - and _ = (direction_flag : 'direction_flag Gram.Entry.t) - and _ = (cvalue_binding : 'cvalue_binding Gram.Entry.t) - and _ = (ctyp_quot : 'ctyp_quot Gram.Entry.t) - and _ = (ctyp : 'ctyp Gram.Entry.t) - and _ = - (constructor_declarations : - 'constructor_declarations Gram.Entry.t) - and _ = - (constructor_declaration : - 'constructor_declaration Gram.Entry.t) - and _ = - (constructor_arg_list : 'constructor_arg_list Gram.Entry.t) - and _ = (constrain : 'constrain Gram.Entry.t) - and _ = - (comma_type_parameter : 'comma_type_parameter Gram.Entry.t) - and _ = (comma_patt : 'comma_patt Gram.Entry.t) - and _ = (comma_ipatt : 'comma_ipatt Gram.Entry.t) - and _ = (comma_expr : 'comma_expr Gram.Entry.t) - and _ = (comma_ctyp : 'comma_ctyp Gram.Entry.t) - and _ = (class_type_quot : 'class_type_quot Gram.Entry.t) - and _ = (class_type_plus : 'class_type_plus Gram.Entry.t) - and _ = - (class_type_longident_and_param : - 'class_type_longident_and_param Gram.Entry.t) - and _ = - (class_type_longident : 'class_type_longident Gram.Entry.t) - and _ = - (class_type_declaration : 'class_type_declaration Gram.Entry.t) - and _ = (class_type : 'class_type Gram.Entry.t) - and _ = (class_structure : 'class_structure Gram.Entry.t) - and _ = (class_str_item_quot : 'class_str_item_quot Gram.Entry.t) - and _ = (class_str_item : 'class_str_item Gram.Entry.t) - and _ = (class_signature : 'class_signature Gram.Entry.t) - and _ = (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t) - and _ = (class_sig_item : 'class_sig_item Gram.Entry.t) - and _ = - (class_name_and_param : 'class_name_and_param Gram.Entry.t) - and _ = - (class_longident_and_param : - 'class_longident_and_param Gram.Entry.t) - and _ = (class_longident : 'class_longident Gram.Entry.t) - and _ = - (class_info_for_class_type : - 'class_info_for_class_type Gram.Entry.t) - and _ = - (class_info_for_class_expr : - 'class_info_for_class_expr Gram.Entry.t) - and _ = (class_fun_def : 'class_fun_def Gram.Entry.t) - and _ = (class_fun_binding : 'class_fun_binding Gram.Entry.t) - and _ = (class_expr_quot : 'class_expr_quot Gram.Entry.t) - and _ = (class_expr : 'class_expr Gram.Entry.t) - and _ = (class_description : 'class_description Gram.Entry.t) - and _ = (class_declaration : 'class_declaration Gram.Entry.t) - and _ = (binding_quot : 'binding_quot Gram.Entry.t) - and _ = (binding : 'binding Gram.Entry.t) - and _ = (match_case_quot : 'match_case_quot Gram.Entry.t) - and _ = (match_case0 : 'match_case0 Gram.Entry.t) - and _ = (match_case : 'match_case Gram.Entry.t) - and _ = (and_ctyp : 'and_ctyp Gram.Entry.t) - and _ = (amp_ctyp : 'amp_ctyp Gram.Entry.t) - and _ = (a_ident : 'a_ident Gram.Entry.t) - and _ = (a_UIDENT : 'a_UIDENT Gram.Entry.t) - and _ = (a_STRING : 'a_STRING Gram.Entry.t) - and _ = (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t) - and _ = (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t) - and _ = (rec_binding_quot : 'rec_binding_quot Gram.Entry.t) - and _ = (a_LIDENT : 'a_LIDENT Gram.Entry.t) - and _ = (a_LABEL : 'a_LABEL Gram.Entry.t) - and _ = (a_INT64 : 'a_INT64 Gram.Entry.t) - and _ = (a_INT32 : 'a_INT32 Gram.Entry.t) - and _ = (a_INT : 'a_INT Gram.Entry.t) - and _ = (a_FLOAT : 'a_FLOAT Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let (* Here it's LABEL and not tilde_label since ~a:b is different than ~a : b *) - (* Same remark for ?a:b *) infixop5 : 'infixop5 Gram.Entry.t = - grammar_entry_create "infixop5" - and (* | i = opt_label; "("; p = patt_tcon; ")" -> *) - (* <:patt< ? $i$ : ($p$) >> *) - (* | i = opt_label; "("; p = ipatt_tcon; ")" -> - <:patt< ? $i$ : ($p$) >> - | i = opt_label; "("; p = ipatt_tcon; "="; e = expr; ")" -> - <:patt< ? $i$ : ($p$ = $e$) >> *) - string_list : 'string_list Gram.Entry.t = - grammar_entry_create "string_list" - and opt_override : 'opt_override Gram.Entry.t = - grammar_entry_create "opt_override" - and unquoted_typevars : 'unquoted_typevars Gram.Entry.t = - grammar_entry_create "unquoted_typevars" - and value_val_opt_override : - 'value_val_opt_override Gram.Entry.t = - grammar_entry_create "value_val_opt_override" - and method_opt_override : 'method_opt_override Gram.Entry.t = - grammar_entry_create "method_opt_override" - and module_longident_dot_lparen : - 'module_longident_dot_lparen Gram.Entry.t = - grammar_entry_create "module_longident_dot_lparen" - and optional_type_parameter : - 'optional_type_parameter Gram.Entry.t = - grammar_entry_create "optional_type_parameter" - and fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t = - grammar_entry_create "fun_def_cont_no_when" - and fun_def_cont : 'fun_def_cont Gram.Entry.t = - grammar_entry_create "fun_def_cont" - and sequence' : 'sequence' Gram.Entry.t = - grammar_entry_create "sequence'" - and infixop6 : 'infixop6 Gram.Entry.t = - grammar_entry_create "infixop6" - in - (Gram.extend (module_expr : 'module_expr Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Skeyword "struct"; - Gram.Snterm - (Gram.Entry.obj - (str_items : 'str_items Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (st : 'str_items) _ (_loc : Gram.Loc.t) - -> (Ast.MeStr (_loc, st) : 'module_expr)))); - ([ Gram.Skeyword "functor"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Skeyword "->"; Gram. - Sself ], - (Gram.Action.mk - (fun (me : 'module_expr) _ _ - (t : 'module_type) _ (i : 'a_UIDENT) _ _ - (_loc : Gram.Loc.t) -> - (Ast.MeFun (_loc, i, t, me) : 'module_expr)))) ]); - ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (me2 : 'module_expr) (me1 : 'module_expr) - (_loc : Gram.Loc.t) -> - (Ast.MeApp (_loc, me1, me2) : 'module_expr)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (package_type : - 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'package_type) _ (e : 'expr) _ _ - (_loc : Gram.Loc.t) -> - (Ast.MePkg (_loc, - (Ast.ExTyc (_loc, e, - (Ast.TyPkg (_loc, p))))) : - 'module_expr)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ _ (_loc : Gram.Loc.t) -> - (Ast.MePkg (_loc, e) : 'module_expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (me : 'module_expr) _ - (_loc : Gram.Loc.t) -> (me : 'module_expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (mt : 'module_type) _ - (me : 'module_expr) _ (_loc : Gram.Loc.t) - -> - (Ast.MeTyc (_loc, me, mt) : 'module_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'module_longident) - (_loc : Gram.Loc.t) -> - (Ast.MeId (_loc, i) : 'module_expr)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.module_expr_tag : - 'module_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "mexp" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"mexp\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "mexp" | "anti" | "list" as n)), - s) -> - (Ast.MeAnt (_loc, - (mk_anti ~c: "module_expr" n s)) : - 'module_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (str_item : 'str_item Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (Ast.StExp (_loc, e) : 'str_item)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.str_item_tag : - 'str_item) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "stri" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "stri" | "anti" | "list" as n)), - s) -> - (Ast.StAnt (_loc, - (mk_anti ~c: "str_item" n s)) : - 'str_item) - | _ -> assert false))); - ([ Gram.Skeyword "class"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (class_type_declaration : - 'class_type_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ctd : 'class_type_declaration) _ _ - (_loc : Gram.Loc.t) -> - (Ast.StClt (_loc, ctd) : 'str_item)))); - ([ Gram.Skeyword "class"; - Gram.Snterm - (Gram.Entry.obj - (class_declaration : - 'class_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (cd : 'class_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.StCls (_loc, cd) : 'str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_let : 'value_let Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (bi : 'binding) (r : 'opt_rec) _ - (_loc : Gram.Loc.t) -> - (Ast.StVal (_loc, r, bi) : 'str_item)))); - ([ Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (type_declaration : - 'type_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (td : 'type_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.StTyp (_loc, td) : 'str_item)))); - ([ Gram.Skeyword "open"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'module_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.StOpn (_loc, i) : 'str_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (i : 'a_ident) _ _ - (_loc : Gram.Loc.t) -> - (Ast.StMty (_loc, i, mt) : 'str_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; - Gram.Snterm - (Gram.Entry.obj - (module_binding : - 'module_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mb : 'module_binding) _ _ - (_loc : Gram.Loc.t) -> - (Ast.StRecMod (_loc, mb) : 'str_item)))); - ([ Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_binding0 : - 'module_binding0 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mb : 'module_binding0) (i : 'a_UIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.StMod (_loc, i, mb) : 'str_item)))); - ([ Gram.Skeyword "include"; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (_loc : Gram.Loc.t) - -> (Ast.StInc (_loc, me) : 'str_item)))); - ([ Gram.Skeyword "external"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (string_list : 'string_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sl : 'string_list) _ (t : 'ctyp) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.StExt (_loc, i, t, sl) : 'str_item)))); - ([ Gram.Skeyword "exception"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declaration : - 'constructor_declaration Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (type_longident : - 'type_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'type_longident) _ - (t : 'constructor_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.StExc (_loc, t, (Ast.OSome i)) : - 'str_item)))); - ([ Gram.Skeyword "exception"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declaration : - 'constructor_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'constructor_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.StExc (_loc, t, Ast.ONone) : - 'str_item)))) ]) ])) - ()); - Gram.extend (module_binding0 : 'module_binding0 Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (_loc : Gram.Loc.t) - -> (me : 'module_binding0)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) - _ (_loc : Gram.Loc.t) -> - (Ast.MeTyc (_loc, me, mt) : - 'module_binding0)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Sself ], - (Gram.Action.mk - (fun (mb : 'module_binding0) _ - (mt : 'module_type) _ (m : 'a_UIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.MeFun (_loc, m, mt, mb) : - 'module_binding0)))) ]) ])) - ()); - Gram.extend (module_binding : 'module_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) - _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.MbColEq (_loc, m, mt, me) : - 'module_binding)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.module_binding_tag : - 'module_binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) - _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), m) -> - (Ast.MbColEq (_loc, (mk_anti n m), mt, - me) : - 'module_binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), s) -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("module_binding" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"module_binding\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("module_binding" | "anti" | "list" - as n)), - s) -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_binding) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'module_binding) _ - (b1 : 'module_binding) (_loc : Gram.Loc.t) - -> - (Ast.MbAnd (_loc, b1, b2) : - 'module_binding)))) ]) ])) - ()); - Gram.extend (module_type : 'module_type Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Skeyword "functor"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself; - Gram.Skeyword ")"; Gram.Skeyword "->"; Gram. - Sself ], - (Gram.Action.mk - (fun (mt : 'module_type) _ _ - (t : 'module_type) _ (i : 'a_UIDENT) _ _ - (_loc : Gram.Loc.t) -> - (Ast.MtFun (_loc, i, t, mt) : 'module_type)))) ]); - ((Some "with"), None, - [ ([ Gram.Sself; Gram.Skeyword "with"; - Gram.Snterm - (Gram.Entry.obj - (with_constr : 'with_constr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (wc : 'with_constr) _ (mt : 'module_type) - (_loc : Gram.Loc.t) -> - (Ast.MtWit (_loc, mt, wc) : 'module_type)))) ]); - ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (mt2 : 'module_type) - (mt1 : 'module_type) (_loc : Gram.Loc.t) -> - (module_type_app mt1 mt2 : 'module_type)))) ]); - ((Some "."), None, - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (mt2 : 'module_type) _ - (mt1 : 'module_type) (_loc : Gram.Loc.t) -> - (module_type_acc mt1 mt2 : 'module_type)))) ]); - ((Some "sig"), None, - [ ([ Gram.Skeyword "sig"; - Gram.Snterm - (Gram.Entry.obj - (sig_items : 'sig_items Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (sg : 'sig_items) _ (_loc : Gram.Loc.t) - -> (Ast.MtSig (_loc, sg) : 'module_type)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "module"; Gram.Skeyword "type"; - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ _ _ - (_loc : Gram.Loc.t) -> - (Ast.MtOf (_loc, me) : 'module_type)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (mt : 'module_type) _ - (_loc : Gram.Loc.t) -> (mt : 'module_type)))); - ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.MtQuo (_loc, i) : 'module_type)))); - ([ Gram.Snterm - (Gram.Entry.obj - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'module_longident_with_app) - (_loc : Gram.Loc.t) -> - (Ast.MtId (_loc, i) : 'module_type)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.module_type_tag : - 'module_type) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "mtyp" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"mtyp\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "mtyp" | "anti" | "list" as n)), - s) -> - (Ast.MtAnt (_loc, - (mk_anti ~c: "module_type" n s)) : - 'module_type) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (sig_item : 'sig_item Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Skeyword "class"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (class_type_declaration : - 'class_type_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ctd : 'class_type_declaration) _ _ - (_loc : Gram.Loc.t) -> - (Ast.SgClt (_loc, ctd) : 'sig_item)))); - ([ Gram.Skeyword "class"; - Gram.Snterm - (Gram.Entry.obj - (class_description : - 'class_description Gram.Entry.t)) ], - (Gram.Action.mk - (fun (cd : 'class_description) _ - (_loc : Gram.Loc.t) -> - (Ast.SgCls (_loc, cd) : 'sig_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.SgVal (_loc, i, t) : 'sig_item)))); - ([ Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (type_declaration : - 'type_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'type_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.SgTyp (_loc, t) : 'sig_item)))); - ([ Gram.Skeyword "open"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'module_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.SgOpn (_loc, i) : 'sig_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.SgMty (_loc, i, (Ast.MtNil _loc)) : - 'sig_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (i : 'a_ident) _ _ - (_loc : Gram.Loc.t) -> - (Ast.SgMty (_loc, i, mt) : 'sig_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; - Gram.Snterm - (Gram.Entry.obj - (module_rec_declaration : - 'module_rec_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mb : 'module_rec_declaration) _ _ - (_loc : Gram.Loc.t) -> - (Ast.SgRecMod (_loc, mb) : 'sig_item)))); - ([ Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_declaration : - 'module_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_declaration) - (i : 'a_UIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.SgMod (_loc, i, mt) : 'sig_item)))); - ([ Gram.Skeyword "include"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (_loc : Gram.Loc.t) - -> (Ast.SgInc (_loc, mt) : 'sig_item)))); - ([ Gram.Skeyword "external"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (string_list : 'string_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sl : 'string_list) _ (t : 'ctyp) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.SgExt (_loc, i, t, sl) : 'sig_item)))); - ([ Gram.Skeyword "exception"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declaration : - 'constructor_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'constructor_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.SgExc (_loc, t) : 'sig_item)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.sig_item_tag : - 'sig_item) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "sigi" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "sigi" | "anti" | "list" as n)), - s) -> - (Ast.SgAnt (_loc, - (mk_anti ~c: "sig_item" n s)) : - 'sig_item) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (module_declaration : 'module_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Sself ], - (Gram.Action.mk - (fun (mt : 'module_declaration) _ - (t : 'module_type) _ (i : 'a_UIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.MtFun (_loc, i, t, mt) : - 'module_declaration)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (_loc : Gram.Loc.t) - -> (mt : 'module_declaration)))) ]) ])) - ()); - Gram.extend - (module_rec_declaration : - 'module_rec_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (m : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.MbCol (_loc, m, mt) : - 'module_rec_declaration)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.module_binding_tag : - 'module_rec_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "module_binding" | "anti" | - "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"module_binding\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "module_binding" | "anti" | - "list" - as n)), - s) -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_rec_declaration) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (m2 : 'module_rec_declaration) _ - (m1 : 'module_rec_declaration) - (_loc : Gram.Loc.t) -> - (Ast.MbAnd (_loc, m1, m2) : - 'module_rec_declaration)))) ]) ])) - ()); - Gram.extend (with_constr : 'with_constr Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)); - Gram.Skeyword ":="; - Gram.Snterm - (Gram.Entry.obj - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i2 : 'module_longident_with_app) _ - (i1 : 'module_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.WcMoS (_loc, i1, i2) : 'with_constr)))); - ([ Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (type_longident_and_parameters : - 'type_longident_and_parameters Gram. - Entry.t)); - Gram.Skeyword ":="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ - (t1 : 'type_longident_and_parameters) _ - (_loc : Gram.Loc.t) -> - (Ast.WcTyS (_loc, t1, t2) : 'with_constr)))); - ([ Gram.Skeyword "type"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")); - Gram.Skeyword ":="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t) - _ (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), - s) -> - (Ast.WcTyS (_loc, - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s))), - t) : - 'with_constr) - | _ -> assert false))); - ([ Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i2 : 'module_longident_with_app) _ - (i1 : 'module_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.WcMod (_loc, i1, i2) : 'with_constr)))); - ([ Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (type_longident_and_parameters : - 'type_longident_and_parameters Gram. - Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ - (t1 : 'type_longident_and_parameters) _ - (_loc : Gram.Loc.t) -> - (Ast.WcTyp (_loc, t1, t2) : 'with_constr)))); - ([ Gram.Skeyword "type"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t) - _ (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), - s) -> - (Ast.WcTyp (_loc, - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s))), - t) : - 'with_constr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.with_constr_tag : - 'with_constr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "with_constr" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"with_constr\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "with_constr" | "anti" | "list" - as n)), - s) -> - (Ast.WcAnt (_loc, - (mk_anti ~c: "with_constr" n s)) : - 'with_constr) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (wc2 : 'with_constr) _ - (wc1 : 'with_constr) (_loc : Gram.Loc.t) -> - (Ast.WcAnd (_loc, wc1, wc2) : 'with_constr)))) ]) ])) - ()); - Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "object"; - Gram.Snterm - (Gram.Entry.obj - (opt_class_self_patt : - 'opt_class_self_patt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_structure : - 'class_structure Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (cst : 'class_structure) - (csp : 'opt_class_self_patt) _ - (_loc : Gram.Loc.t) -> - (Ast.ExObj (_loc, csp, cst) : 'expr)))); - ([ Gram.Skeyword "while"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "do"; - Gram.Snterm - (Gram.Entry.obj - (do_sequence : 'do_sequence Gram.Entry.t)) ], - (Gram.Action.mk - (fun (seq : 'do_sequence) _ (e : 'sequence) _ - (_loc : Gram.Loc.t) -> - (Ast.ExWhi (_loc, (mksequence' _loc e), - seq) : - 'expr)))); - ([ Gram.Skeyword "for"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (direction_flag : - 'direction_flag Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "do"; - Gram.Snterm - (Gram.Entry.obj - (do_sequence : 'do_sequence Gram.Entry.t)) ], - (Gram.Action.mk - (fun (seq : 'do_sequence) _ (e2 : 'sequence) - (df : 'direction_flag) (e1 : 'sequence) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExFor (_loc, i, (mksequence' _loc e1), - (mksequence' _loc e2), df, seq) : - 'expr)))); - ([ Gram.Skeyword "do"; - Gram.Snterm - (Gram.Entry.obj - (do_sequence : 'do_sequence Gram.Entry.t)) ], - (Gram.Action.mk - (fun (seq : 'do_sequence) _ - (_loc : Gram.Loc.t) -> - (mksequence _loc seq : 'expr)))); - ([ Gram.Skeyword "if"; Gram.Sself; - Gram.Skeyword "then"; Gram.Sself; - Gram.Skeyword "else"; Gram.Sself ], - (Gram.Action.mk - (fun (e3 : 'expr) _ (e2 : 'expr) _ - (e1 : 'expr) _ (_loc : Gram.Loc.t) -> - (Ast.ExIfe (_loc, e1, e2, e3) : 'expr)))); - ([ Gram.Skeyword "try"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "with"; - Gram.Snterm - (Gram.Entry.obj - (match_case : 'match_case Gram.Entry.t)) ], - (Gram.Action.mk - (fun (a : 'match_case) _ (e : 'sequence) _ - (_loc : Gram.Loc.t) -> - (Ast.ExTry (_loc, (mksequence' _loc e), a) : - 'expr)))); - ([ Gram.Skeyword "match"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "with"; - Gram.Snterm - (Gram.Entry.obj - (match_case : 'match_case Gram.Entry.t)) ], - (Gram.Action.mk - (fun (a : 'match_case) _ (e : 'sequence) _ - (_loc : Gram.Loc.t) -> - (Ast.ExMat (_loc, (mksequence' _loc e), a) : - 'expr)))); - ([ Gram.Skeyword "fun"; - Gram.Snterm - (Gram.Entry.obj - (fun_def : 'fun_def Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_def) _ (_loc : Gram.Loc.t) -> - (e : 'expr)))); - ([ Gram.Skeyword "fun"; Gram.Skeyword "["; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (match_case0 : - 'match_case0 Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (a : 'match_case0 list) _ _ - (_loc : Gram.Loc.t) -> - (Ast.ExFun (_loc, (Ast.mcOr_of_list a)) : - 'expr)))); - ([ Gram.Skeyword "let"; Gram.Skeyword "open"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (i : 'module_longident) _ _ - (_loc : Gram.Loc.t) -> - (Ast.ExOpI (_loc, i, e) : 'expr)))); - ([ Gram.Skeyword "let"; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_binding0 : - 'module_binding0 Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (mb : 'module_binding0) - (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> - (Ast.ExLmd (_loc, m, mb, e) : 'expr)))); - ([ Gram.Skeyword "let"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (x : 'expr) _ (bi : 'binding) - (r : 'opt_rec) _ (_loc : Gram.Loc.t) -> - (Ast.ExLet (_loc, r, bi, x) : 'expr)))) ]); - ((Some "where"), None, - [ ([ Gram.Sself; Gram.Skeyword "where"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (let_binding : 'let_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (lb : 'let_binding) (rf : 'opt_rec) _ - (e : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExLet (_loc, rf, lb, e) : 'expr)))) ]); - ((Some ":="), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Sself; Gram.Skeyword ":="; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (match bigarray_set _loc e1 e2 with - | Some e -> e - | None -> Ast.ExAss (_loc, e1, e2) : - 'expr)))) ]); - ((Some "||"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop6 : 'infixop6 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop6) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))) ]); - ((Some "&&"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop5 : 'infixop5 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop5) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))) ]); - ((Some "<"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop0 : 'infixop0 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop0) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))) ]); - ((Some "^"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop1 : 'infixop1 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop1) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))) ]); - ((Some "+"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop2 : 'infixop2 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop2) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))) ]); - ((Some "*"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop3 : 'infixop3 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop3) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "mod"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "mod")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "lxor"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "lxor")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "lor"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "lor")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "land"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "land")))), - e1)), - e2) : - 'expr)))) ]); - ((Some "**"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop4 : 'infixop4 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop4) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "lsr"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "lsr")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "lsl"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "lsl")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "asr"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "asr")))), - e1)), - e2) : - 'expr)))) ]); - ((Some "unary minus"), - (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Skeyword "-."; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (mkumin _loc "-." e : 'expr)))); - ([ Gram.Skeyword "-"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (mkumin _loc "-" e : 'expr)))) ]); - ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "lazy"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (Ast.ExLaz (_loc, e) : 'expr)))); - ([ Gram.Skeyword "new"; - Gram.Snterm - (Gram.Entry.obj - (class_longident : - 'class_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'class_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.ExNew (_loc, i) : 'expr)))); - ([ Gram.Skeyword "assert"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (mkassert _loc e : 'expr)))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, e1, e2) : 'expr)))) ]); - ((Some "label"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Skeyword "?"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExOlb (_loc, i, (Ast.ExNil _loc)) : - 'expr)))); - ([ Gram.Skeyword "?"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.ExOlb (_loc, i, e) : 'expr)))); - ([ Gram.Stoken - (((function | OPTLABEL _ -> true | _ -> false), - "OPTLABEL _")); - Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | OPTLABEL i -> - (Ast.ExOlb (_loc, i, e) : 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function | LABEL _ -> true | _ -> false), - "LABEL _")); - Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LABEL i -> - (Ast.ExLab (_loc, i, e) : 'expr) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExLab (_loc, i, (Ast.ExNil _loc)) : - 'expr)))); - ([ Gram.Skeyword "~"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.ExLab (_loc, i, e) : 'expr)))) ]); - ((Some "."), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)) ], - (Gram.Action.mk - (fun (lab : 'label) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExSnd (_loc, e, lab) : 'expr)))); - ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExAcc (_loc, e1, e2) : 'expr)))); - ([ Gram.Sself; Gram.Skeyword "."; - Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (comma_expr : 'comma_expr Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (e2 : 'comma_expr) _ _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (bigarray_get _loc e1 e2 : 'expr)))); - ([ Gram.Sself; Gram.Skeyword "."; - Gram.Skeyword "["; Gram.Sself; - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExSte (_loc, e1, e2) : 'expr)))); - ([ Gram.Sself; Gram.Skeyword "."; - Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExAre (_loc, e1, e2) : 'expr)))) ]); - ((Some "~-"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (prefixop : 'prefixop Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) (f : 'prefixop) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, f, e) : 'expr)))); - ([ Gram.Skeyword "!"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (Ast.ExAcc (_loc, e, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "val"))))) : - 'expr)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (package_type : - 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pt : 'package_type) _ - (me : 'module_expr) _ _ (_loc : Gram.Loc.t) - -> - (Ast.ExPkg (_loc, - (Ast.MeTyc (_loc, me, pt))) : - 'expr)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (me : 'module_expr) _ _ - (_loc : Gram.Loc.t) -> - (Ast.ExPkg (_loc, me) : 'expr)))); - ([ Gram.Skeyword "begin"; Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'expr)))); - ([ Gram.Skeyword "begin"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (seq : 'sequence) _ (_loc : Gram.Loc.t) - -> (mksequence _loc seq : 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) -> - (e : 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":>"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (e : 'expr) _ - (_loc : Gram.Loc.t) -> - (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) : - 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ":>"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ - (e : 'expr) _ (_loc : Gram.Loc.t) -> - (Ast.ExCoe (_loc, e, t, t2) : 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ";"; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ _ (e : 'expr) _ (_loc : Gram.Loc.t) -> - (mksequence _loc e : 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (seq : 'sequence) _ (e : 'expr) _ - (_loc : Gram.Loc.t) -> - (mksequence _loc (Ast.ExSem (_loc, e, seq)) : - 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_expr : 'comma_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (el : 'comma_expr) _ (e : 'expr) _ - (_loc : Gram.Loc.t) -> - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, e, el))) : - 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (e : 'expr) _ - (_loc : Gram.Loc.t) -> - (Ast.ExTyc (_loc, e, t) : 'expr)))); - ([ Gram.Skeyword "("; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'expr)))); - ([ Gram.Skeyword "{<"; - Gram.Snterm - (Gram.Entry.obj - (field_expr_list : - 'field_expr_list Gram.Entry.t)); - Gram.Skeyword ">}" ], - (Gram.Action.mk - (fun _ (fel : 'field_expr_list) _ - (_loc : Gram.Loc.t) -> - (Ast.ExOvr (_loc, fel) : 'expr)))); - ([ Gram.Skeyword "{<"; Gram.Skeyword ">}" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExOvr (_loc, (Ast.RbNil _loc)) : - 'expr)))); - ([ Gram.Skeyword "{"; Gram.Skeyword "("; Gram. - Sself; Gram.Skeyword ")"; Gram.Skeyword "with"; - Gram.Snterm - (Gram.Entry.obj - (label_expr_list : - 'label_expr_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (el : 'label_expr_list) _ _ (e : 'expr) - _ _ (_loc : Gram.Loc.t) -> - (Ast.ExRec (_loc, el, e) : 'expr)))); - ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (label_expr_list : - 'label_expr_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (el : 'label_expr_list) _ - (_loc : Gram.Loc.t) -> - (Ast.ExRec (_loc, el, (Ast.ExNil _loc)) : - 'expr)))); - ([ Gram.Skeyword "[|"; - Gram.Snterm - (Gram.Entry.obj - (sem_expr : 'sem_expr Gram.Entry.t)); - Gram.Skeyword "|]" ], - (Gram.Action.mk - (fun _ (el : 'sem_expr) _ (_loc : Gram.Loc.t) - -> (Ast.ExArr (_loc, el) : 'expr)))); - ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExArr (_loc, (Ast.ExNil _loc)) : - 'expr)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : - 'sem_expr_for_list Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (mk_list : 'sem_expr_for_list) _ - (_loc : Gram.Loc.t) -> - (mk_list - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "[]")))) : - 'expr)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : - 'sem_expr_for_list Gram.Entry.t)); - Gram.Skeyword "::"; Gram.Sself; - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (last : 'expr) _ - (mk_list : 'sem_expr_for_list) _ - (_loc : Gram.Loc.t) -> - (mk_list last : 'expr)))); - ([ Gram.Skeyword "["; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))) : - 'expr)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.ExVrn (_loc, s) : 'expr)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (val_longident : - 'val_longident Gram.Entry.t))) ], - (Gram.Action.mk - (fun (i : 'val_longident) (_loc : Gram.Loc.t) - -> (Ast.ExId (_loc, i) : 'expr)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (module_longident_dot_lparen : - 'module_longident_dot_lparen Gram. - Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'sequence) - (i : 'module_longident_dot_lparen) - (_loc : Gram.Loc.t) -> - (Ast.ExOpI (_loc, i, e) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_CHAR : 'a_CHAR Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) -> - (Ast.ExChr (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_STRING : 'a_STRING Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_STRING) (_loc : Gram.Loc.t) -> - (Ast.ExStr (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) -> - (Ast.ExFlo (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) -> - (Ast.ExNativeInt (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_INT64 : 'a_INT64 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT64) (_loc : Gram.Loc.t) -> - (Ast.ExInt64 (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_INT32 : 'a_INT32 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT32) (_loc : Gram.Loc.t) -> - (Ast.ExInt32 (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT) (_loc : Gram.Loc.t) -> - (Ast.ExInt (_loc, s) : 'expr)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("seq", _) -> true - | _ -> false), - "ANTIQUOT (\"seq\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("seq" as n)), s) -> - (Ast.ExSeq (_loc, - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr" n s)))) : - 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("tup", _) -> true - | _ -> false), - "ANTIQUOT (\"tup\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("tup" as n)), s) -> - (Ast.ExTup (_loc, - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr" n s)))) : - 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("`bool", _) -> true - | _ -> false), - "ANTIQUOT (\"`bool\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("`bool" as n)), s) -> - (Ast.ExId (_loc, - (Ast.IdAnt (_loc, (mk_anti n s)))) : - 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("exp" | "" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"exp\" | \"\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("exp" | "" | "anti" as n)), - s) -> - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr" n s)) : - 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.expr_tag : - 'expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (do_sequence : 'do_sequence Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "done" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'do_sequence)))); - ([ Gram.Stry - (Gram.srules do_sequence - [ ([ Gram.Snterm - (Gram.Entry.obj - (sequence : - 'sequence Gram.Entry.t)); - Gram.Skeyword "done" ], - (Gram.Action.mk - (fun _ (seq : 'sequence) - (_loc : Gram.Loc.t) -> - (seq : 'e__3)))) ]) ], - (Gram.Action.mk - (fun (seq : 'e__3) (_loc : Gram.Loc.t) -> - (seq : 'do_sequence)))); - ([ Gram.Stry - (Gram.srules do_sequence - [ ([ Gram.Skeyword "{"; Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__2)))) ]) ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'do_sequence)))); - ([ Gram.Stry - (Gram.srules do_sequence - [ ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (sequence : - 'sequence Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (seq : 'sequence) _ - (_loc : Gram.Loc.t) -> - (seq : 'e__1)))) ]) ], - (Gram.Action.mk - (fun (seq : 'e__1) (_loc : Gram.Loc.t) -> - (seq : 'do_sequence)))) ]) ])) - ()); - Gram.extend (infixop5 : 'infixop5 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.srules infixop5 - [ ([ Gram.Skeyword "&&" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : - 'e__4)))); - ([ Gram.Skeyword "&" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : - 'e__4)))) ] ], - (Gram.Action.mk - (fun (x : 'e__4) (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) : - 'infixop5)))) ]) ])) - ()); - Gram.extend (infixop6 : 'infixop6 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.srules infixop6 - [ ([ Gram.Skeyword "||" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : - 'e__5)))); - ([ Gram.Skeyword "or" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : - 'e__5)))) ] ], - (Gram.Action.mk - (fun (x : 'e__5) (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) : - 'infixop6)))) ]) ])) - ()); - Gram.extend - (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - acc) : - 'sem_expr_for_list)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (e : 'expr) (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - acc) : - 'sem_expr_for_list)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (el : 'sem_expr_for_list) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - (el acc)) : - 'sem_expr_for_list)))) ]) ])) - ()); - Gram.extend (comma_expr : 'comma_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top") ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (e : 'comma_expr)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr," n s)) : - 'comma_expr) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'comma_expr) _ (e1 : 'comma_expr) - (_loc : Gram.Loc.t) -> - (Ast.ExCom (_loc, e1, e2) : 'comma_expr)))) ]) ])) - ()); - Gram.extend (dummy : 'dummy Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> (() : 'dummy)))) ]) ])) - ()); - Gram.extend (sequence' : 'sequence' Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)) ], - (Gram.Action.mk - (fun (el : 'sequence) _ (_loc : Gram.Loc.t) -> - (fun e -> Ast.ExSem (_loc, e, el) : - 'sequence')))); - ([ Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (fun e -> e : 'sequence')))); - ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (fun e -> e : 'sequence')))) ]) ])) - ()); - Gram.extend (sequence : 'sequence Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (sequence' : 'sequence' Gram.Entry.t)) ], - (Gram.Action.mk - (fun (k : 'sequence') (e : 'expr) - (_loc : Gram.Loc.t) -> (k e : 'sequence)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr;" n s)) : - 'sequence) - | _ -> assert false))); - ([ Gram.Skeyword "let"; Gram.Skeyword "open"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'sequence) _ (i : 'module_longident) - _ _ (_loc : Gram.Loc.t) -> - (Ast.ExOpI (_loc, i, e) : 'sequence)))); - ([ Gram.Skeyword "let"; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_binding0 : - 'module_binding0 Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (el : 'sequence) _ - (mb : 'module_binding0) (m : 'a_UIDENT) _ _ - (_loc : Gram.Loc.t) -> - (Ast.ExLmd (_loc, m, mb, - (mksequence _loc el)) : - 'sequence)))); - ([ Gram.Skeyword "let"; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_binding0 : - 'module_binding0 Gram.Entry.t)); - Gram.Skeyword "in"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (sequence' : 'sequence' Gram.Entry.t)) ], - (Gram.Action.mk - (fun (k : 'sequence') (e : 'expr) _ - (mb : 'module_binding0) (m : 'a_UIDENT) _ _ - (_loc : Gram.Loc.t) -> - (k (Ast.ExLmd (_loc, m, mb, e)) : - 'sequence)))); - ([ Gram.Skeyword "let"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (el : 'sequence) _ (bi : 'binding) - (rf : 'opt_rec) _ (_loc : Gram.Loc.t) -> - (Ast.ExLet (_loc, rf, bi, - (mksequence _loc el)) : - 'sequence)))); - ([ Gram.Skeyword "let"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)); - Gram.Skeyword "in"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (sequence' : 'sequence' Gram.Entry.t)) ], - (Gram.Action.mk - (fun (k : 'sequence') (e : 'expr) _ - (bi : 'binding) (rf : 'opt_rec) _ - (_loc : Gram.Loc.t) -> - (k (Ast.ExLet (_loc, rf, bi, e)) : - 'sequence)))) ]) ])) - ()); - Gram.extend (binding : 'binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (let_binding : 'let_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (b : 'let_binding) (_loc : Gram.Loc.t) -> - (b : 'binding)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'binding) _ (b1 : 'binding) - (_loc : Gram.Loc.t) -> - (Ast.BiAnd (_loc, b1, b2) : 'binding)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.BiAnt (_loc, - (mk_anti ~c: "binding" n s)) : - 'binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.BiEq (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s))), - e) : - 'binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("binding" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"binding\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("binding" | "list" as n)), s) - -> - (Ast.BiAnt (_loc, - (mk_anti ~c: "binding" n s)) : - 'binding) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (let_binding : 'let_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (fun_binding : 'fun_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_binding) (p : 'ipatt) - (_loc : Gram.Loc.t) -> - (Ast.BiEq (_loc, p, e) : 'let_binding)))) ]) ])) - ()); - Gram.extend (fun_binding : 'fun_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (cvalue_binding : - 'cvalue_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (bi : 'cvalue_binding) - (_loc : Gram.Loc.t) -> (bi : 'fun_binding)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t))); - Gram.Sself ], - (Gram.Action.mk - (fun (e : 'fun_binding) (p : 'labeled_ipatt) - (_loc : Gram.Loc.t) -> - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), - e))) : - 'fun_binding)))); - ([ Gram.Stry - (Gram.srules fun_binding - [ ([ Gram.Skeyword "("; - Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__6)))) ]); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'fun_binding) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.ExFUN (_loc, i, e) : 'fun_binding)))) ]) ])) - ()); - Gram.extend (match_case : 'match_case Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (p : 'ipatt) - (_loc : Gram.Loc.t) -> - (Ast.McArr (_loc, p, (Ast.ExNil _loc), e) : - 'match_case)))); - ([ Gram.Skeyword "["; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (match_case0 : - 'match_case0 Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (l : 'match_case0 list) _ - (_loc : Gram.Loc.t) -> - (Ast.mcOr_of_list l : 'match_case)))) ]) ])) - ()); - Gram.extend (match_case0 : 'match_case0 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (patt_as_patt_opt : - 'patt_as_patt_opt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_when_expr : - 'opt_when_expr Gram.Entry.t)); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (w : 'opt_when_expr) - (p : 'patt_as_patt_opt) (_loc : Gram.Loc.t) - -> - (Ast.McArr (_loc, p, w, e) : 'match_case0)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")); - Gram.Skeyword "when"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (w : 'expr) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.McArr (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s))), - w, e) : - 'match_case0) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.McArr (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s))), - (Ast.ExNil _loc), e) : - 'match_case0) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.McAnt (_loc, - (mk_anti ~c: "match_case" n s)) : - 'match_case0) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("match_case" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"match_case\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("match_case" | "list" as n)), - s) -> - (Ast.McAnt (_loc, - (mk_anti ~c: "match_case" n s)) : - 'match_case0) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (opt_when_expr : 'opt_when_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ExNil _loc : 'opt_when_expr)))); - ([ Gram.Skeyword "when"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (w : 'expr) _ (_loc : Gram.Loc.t) -> - (w : 'opt_when_expr)))) ]) ])) - ()); - Gram.extend - (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'patt_as_patt_opt)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword "as"; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaAli (_loc, p1, p2) : - 'patt_as_patt_opt)))) ]) ])) - ()); - Gram.extend (label_expr_list : 'label_expr_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_expr : 'label_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (b1 : 'label_expr) (_loc : Gram.Loc.t) -> - (b1 : 'label_expr_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_expr : 'label_expr Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (b1 : 'label_expr) (_loc : Gram.Loc.t) - -> (b1 : 'label_expr_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_expr : 'label_expr Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'label_expr_list) _ - (b1 : 'label_expr) (_loc : Gram.Loc.t) -> - (Ast.RbSem (_loc, b1, b2) : - 'label_expr_list)))) ]) ])) - ()); - Gram.extend (label_expr : 'label_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'label_longident) - (_loc : Gram.Loc.t) -> - (Ast.RbEq (_loc, i, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, (lid_of_ident i)))))) : - 'label_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (fun_binding : 'fun_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_binding) (i : 'label_longident) - (_loc : Gram.Loc.t) -> - (Ast.RbEq (_loc, i, e) : 'label_expr)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'label_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.RbEq (_loc, - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s))), - e) : - 'label_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'label_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("rec_binding", _) -> true - | _ -> false), - "ANTIQUOT (\"rec_binding\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("rec_binding" as n)), s) -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'label_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (fun_def : 'fun_def Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (fun_def_cont : - 'fun_def_cont Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((w, e) : 'fun_def_cont) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, w, e))) : - 'fun_def)))); - ([ Gram.Stry - (Gram.srules fun_def - [ ([ Gram.Skeyword "("; - Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__7)))) ]); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ")"; - Gram.Snterm - (Gram.Entry.obj - (fun_def_cont_no_when : - 'fun_def_cont_no_when Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_def_cont_no_when) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExFUN (_loc, i, e) : 'fun_def)))) ]) ])) - ()); - Gram.extend (fun_def_cont : 'fun_def_cont Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (((Ast.ExNil _loc), e) : 'fun_def_cont)))); - ([ Gram.Skeyword "when"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (w : 'expr) _ - (_loc : Gram.Loc.t) -> - ((w, e) : 'fun_def_cont)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t))); - Gram.Sself ], - (Gram.Action.mk - (fun ((w, e) : 'fun_def_cont) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (((Ast.ExNil _loc), - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, w, e))))) : - 'fun_def_cont)))); - ([ Gram.Stry - (Gram.srules fun_def_cont - [ ([ Gram.Skeyword "("; - Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__8)))) ]); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ")"; - Gram.Snterm - (Gram.Entry.obj - (fun_def_cont_no_when : - 'fun_def_cont_no_when Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_def_cont_no_when) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (((Ast.ExNil _loc), - (Ast.ExFUN (_loc, i, e))) : - 'fun_def_cont)))) ]) ])) - ()); - Gram.extend - (fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (e : 'fun_def_cont_no_when)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (fun_def_cont : - 'fun_def_cont Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((w, e) : 'fun_def_cont) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, w, e))) : - 'fun_def_cont_no_when)))); - ([ Gram.Stry - (Gram.srules fun_def_cont_no_when - [ ([ Gram.Skeyword "("; - Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__9)))) ]); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'fun_def_cont_no_when) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExFUN (_loc, i, e) : - 'fun_def_cont_no_when)))) ]) ])) - ()); - Gram.extend (patt : 'patt Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "|"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaOrp (_loc, p1, p2) : 'patt)))) ]); - ((Some ".."), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Sself; Gram.Skeyword ".."; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaRng (_loc, p1, p2) : 'patt)))) ]); - ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "lazy"; Gram.Sself ], - (Gram.Action.mk - (fun (p : 'patt) _ (_loc : Gram.Loc.t) -> - (Ast.PaLaz (_loc, p) : 'patt)))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'patt) (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaApp (_loc, p1, p2) : 'patt)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "?"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (patt_tcon : 'patt_tcon Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ (p : 'patt_tcon) _ _ - (_loc : Gram.Loc.t) -> - (Ast.PaOlbi (_loc, "", p, e) : 'patt)))); - ([ Gram.Skeyword "?"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (patt_tcon : 'patt_tcon Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'patt_tcon) _ _ - (_loc : Gram.Loc.t) -> - (Ast.PaOlb (_loc, "", p) : 'patt)))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaOlb (_loc, (mk_anti n i), - (Ast.PaNil _loc)) : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT i -> - (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")); - Gram.Skeyword ":"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (patt_tcon : 'patt_tcon Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (eq_expr : 'eq_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ _ - (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (f (mk_anti n i) p : 'patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function | OPTLABEL _ -> true | _ -> false), - "OPTLABEL _")); - Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (patt_tcon : 'patt_tcon Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (eq_expr : 'eq_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | OPTLABEL i -> (f i p : 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT i -> - (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaLab (_loc, (mk_anti n i), - (Ast.PaNil _loc)) : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (p : 'patt) _ (__camlp4_0 : Gram.Token.t) - _ (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaLab (_loc, (mk_anti n i), p) : - 'patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function | LABEL _ -> true | _ -> false), - "LABEL _")); - Gram.Sself ], - (Gram.Action.mk - (fun (p : 'patt) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LABEL i -> - (Ast.PaLab (_loc, i, p) : 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (type_longident : - 'type_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'type_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTyp (_loc, i) : 'patt)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.PaVrn (_loc, s) : 'patt)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.patt_tag : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.PaAny _loc : 'patt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_patt : 'comma_patt Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pl : 'comma_patt) _ (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTup (_loc, - (Ast.PaCom (_loc, p, pl))) : - 'patt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword "as"; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p2 : 'patt) _ (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaAli (_loc, p, p2) : 'patt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : 'patt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) -> - (p : 'patt)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (package_type : - 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) - _ _ (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)), - (Ast.TyPkg (_loc, pt))) : - 'patt)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) - -> (Ast.PaMod (_loc, m) : 'patt)))); - ([ Gram.Skeyword "("; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) : - 'patt)))); - ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (label_patt_list : - 'label_patt_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (pl : 'label_patt_list) _ - (_loc : Gram.Loc.t) -> - (Ast.PaRec (_loc, pl) : 'patt)))); - ([ Gram.Skeyword "[|"; - Gram.Snterm - (Gram.Entry.obj - (sem_patt : 'sem_patt Gram.Entry.t)); - Gram.Skeyword "|]" ], - (Gram.Action.mk - (fun _ (pl : 'sem_patt) _ (_loc : Gram.Loc.t) - -> (Ast.PaArr (_loc, pl) : 'patt)))); - ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.PaArr (_loc, (Ast.PaNil _loc)) : - 'patt)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_patt_for_list : - 'sem_patt_for_list Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (mk_list : 'sem_patt_for_list) _ - (_loc : Gram.Loc.t) -> - (mk_list - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "[]")))) : - 'patt)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_patt_for_list : - 'sem_patt_for_list Gram.Entry.t)); - Gram.Skeyword "::"; Gram.Sself; - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (last : 'patt) _ - (mk_list : 'sem_patt_for_list) _ - (_loc : Gram.Loc.t) -> - (mk_list last : 'patt)))); - ([ Gram.Skeyword "["; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdUid (_loc, "[]"))) : - 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj - (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_FLOAT) _ (_loc : Gram.Loc.t) -> - (Ast.PaFlo (_loc, (neg_string s)) : 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj - (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_NATIVEINT) _ (_loc : Gram.Loc.t) - -> - (Ast.PaNativeInt (_loc, (neg_string s)) : - 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj - (a_INT64 : 'a_INT64 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT64) _ (_loc : Gram.Loc.t) -> - (Ast.PaInt64 (_loc, (neg_string s)) : - 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj - (a_INT32 : 'a_INT32 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT32) _ (_loc : Gram.Loc.t) -> - (Ast.PaInt32 (_loc, (neg_string s)) : - 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT) _ (_loc : Gram.Loc.t) -> - (Ast.PaInt (_loc, (neg_string s)) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_CHAR : 'a_CHAR Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) -> - (Ast.PaChr (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_STRING : 'a_STRING Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_STRING) (_loc : Gram.Loc.t) -> - (Ast.PaStr (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) -> - (Ast.PaFlo (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) -> - (Ast.PaNativeInt (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_INT64 : 'a_INT64 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT64) (_loc : Gram.Loc.t) -> - (Ast.PaInt64 (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_INT32 : 'a_INT32 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT32) (_loc : Gram.Loc.t) -> - (Ast.PaInt32 (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT) (_loc : Gram.Loc.t) -> - (Ast.PaInt (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'ident) (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, i) : 'patt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("`bool", _) -> true - | _ -> false), - "ANTIQUOT (\"`bool\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("`bool" as n)), s) -> - (Ast.PaId (_loc, - (Ast.IdAnt (_loc, (mk_anti n s)))) : - 'patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("tup", _) -> true - | _ -> false), - "ANTIQUOT (\"tup\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("tup" as n)), s) -> - (Ast.PaTup (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)))) : - 'patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "pat" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "pat" | "anti" as n)), - s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)) : - 'patt) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (comma_patt : 'comma_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'comma_patt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt," n s)) : - 'comma_patt) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'comma_patt) _ (p1 : 'comma_patt) - (_loc : Gram.Loc.t) -> - (Ast.PaCom (_loc, p1, p2) : 'comma_patt)))) ]) ])) - ()); - Gram.extend (sem_patt : 'sem_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'sem_patt)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'sem_patt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt;" n s)) : - 'sem_patt) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'sem_patt) _ (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, p2) : 'sem_patt)))) ]) ])) - ()); - Gram.extend - (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "::")))), - p)), - acc) : - 'sem_patt_for_list)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (p : 'patt) (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "::")))), - p)), - acc) : - 'sem_patt_for_list)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (pl : 'sem_patt_for_list) _ (p : 'patt) - (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "::")))), - p)), - (pl acc)) : - 'sem_patt_for_list)))) ]) ])) - ()); - Gram.extend (label_patt_list : 'label_patt_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p1 : 'label_patt) (_loc : Gram.Loc.t) -> - (p1 : 'label_patt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (p1 : 'label_patt) (_loc : Gram.Loc.t) - -> (p1 : 'label_patt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Skeyword "_"; - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ _ _ (p1 : 'label_patt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : - 'label_patt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ _ (p1 : 'label_patt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : - 'label_patt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'label_patt_list) _ - (p1 : 'label_patt) (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, p2) : - 'label_patt_list)))) ]) ])) - ()); - Gram.extend (label_patt : 'label_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'label_longident) - (_loc : Gram.Loc.t) -> - (Ast.PaEq (_loc, i, - (Ast.PaId (_loc, - (Ast.IdLid (_loc, (lid_of_ident i)))))) : - 'label_patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) _ (i : 'label_longident) - (_loc : Gram.Loc.t) -> - (Ast.PaEq (_loc, i, p) : 'label_patt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt;" n s)) : - 'label_patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.patt_tag : - 'label_patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "pat" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "pat" | "anti" as n)), - s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)) : - 'label_patt) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (ipatt : 'ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.PaAny _loc : 'ipatt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdLid (_loc, s))) : - 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_ipatt : 'comma_ipatt Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pl : 'comma_ipatt) _ (p : 'ipatt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTup (_loc, - (Ast.PaCom (_loc, p, pl))) : - 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword "as"; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaAli (_loc, p, p2) : 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (p : 'ipatt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'ipatt) _ (_loc : Gram.Loc.t) -> - (p : 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (package_type : - 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) - _ _ (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)), - (Ast.TyPkg (_loc, pt))) : - 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) - -> (Ast.PaMod (_loc, m) : 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) : - 'ipatt)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.patt_tag : - 'ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("tup", _) -> true - | _ -> false), - "ANTIQUOT (\"tup\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("tup" as n)), s) -> - (Ast.PaTup (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)))) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "pat" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "pat" | "anti" as n)), - s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (label_ipatt_list : - 'label_ipatt_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (pl : 'label_ipatt_list) _ - (_loc : Gram.Loc.t) -> - (Ast.PaRec (_loc, pl) : 'ipatt)))) ]) ])) - ()); - Gram.extend (labeled_ipatt : 'labeled_ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> - (p : 'labeled_ipatt)))) ]) ])) - ()); - Gram.extend (comma_ipatt : 'comma_ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> - (p : 'comma_ipatt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt," n s)) : - 'comma_ipatt) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'comma_ipatt) _ (p1 : 'comma_ipatt) - (_loc : Gram.Loc.t) -> - (Ast.PaCom (_loc, p1, p2) : 'comma_ipatt)))) ]) ])) - ()); - Gram.extend - (label_ipatt_list : 'label_ipatt_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p1 : 'label_ipatt) (_loc : Gram.Loc.t) - -> (p1 : 'label_ipatt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t) - -> (p1 : 'label_ipatt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Skeyword "_"; - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ _ _ (p1 : 'label_ipatt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : - 'label_ipatt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ _ (p1 : 'label_ipatt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : - 'label_ipatt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'label_ipatt_list) _ - (p1 : 'label_ipatt) (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, p2) : - 'label_ipatt_list)))) ]) ])) - ()); - Gram.extend (label_ipatt : 'label_ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'ipatt) _ (i : 'label_longident) - (_loc : Gram.Loc.t) -> - (Ast.PaEq (_loc, i, p) : 'label_ipatt)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.patt_tag : - 'label_ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt;" n s)) : - 'label_ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "pat" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "pat" | "anti" as n)), - s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)) : - 'label_ipatt) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (type_declaration : 'type_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_ident_and_parameters : - 'type_ident_and_parameters Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t)); - Gram.Slist0 - (Gram.Snterm - (Gram.Entry.obj - (constrain : 'constrain Gram.Entry.t))) ], - (Gram.Action.mk - (fun (cl : 'constrain list) - (tk : 'opt_eq_ctyp) - ((n, tpl) : 'type_ident_and_parameters) - (_loc : Gram.Loc.t) -> - (Ast.TyDcl (_loc, n, tpl, tk, cl) : - 'type_declaration)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'type_declaration) _ - (t1 : 'type_declaration) - (_loc : Gram.Loc.t) -> - (Ast.TyAnd (_loc, t1, t2) : - 'type_declaration)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'type_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctypand" n s)) : - 'type_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), - s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'type_declaration) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (constrain : 'constrain Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "constraint"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Gram.Loc.t) -> - ((t1, t2) : 'constrain)))) ]) ])) - ()); - Gram.extend (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'opt_eq_ctyp)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (type_kind : 'type_kind Gram.Entry.t)) ], - (Gram.Action.mk - (fun (tk : 'type_kind) _ (_loc : Gram.Loc.t) - -> (tk : 'opt_eq_ctyp)))) ]) ])) - ()); - Gram.extend (type_kind : 'type_kind Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'type_kind)))) ]) ])) - ()); - Gram.extend - (type_ident_and_parameters : - 'type_ident_and_parameters Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Slist0 - (Gram.Snterm - (Gram.Entry.obj - (optional_type_parameter : - 'optional_type_parameter Gram.Entry.t))) ], - (Gram.Action.mk - (fun (tpl : 'optional_type_parameter list) - (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - ((i, tpl) : 'type_ident_and_parameters)))) ]) ])) - ()); - Gram.extend - (type_longident_and_parameters : - 'type_longident_and_parameters Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_longident : - 'type_longident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (type_parameters : - 'type_parameters Gram.Entry.t)) ], - (Gram.Action.mk - (fun (tpl : 'type_parameters) - (i : 'type_longident) (_loc : Gram.Loc.t) - -> - (tpl (Ast.TyId (_loc, i)) : - 'type_longident_and_parameters)))) ]) ])) - ()); - Gram.extend (type_parameters : 'type_parameters Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (fun t -> t : 'type_parameters)))); - ([ Gram.Snterm - (Gram.Entry.obj - (type_parameter : - 'type_parameter Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'type_parameter) (_loc : Gram.Loc.t) - -> - (fun acc -> Ast.TyApp (_loc, acc, t) : - 'type_parameters)))); - ([ Gram.Snterm - (Gram.Entry.obj - (type_parameter : - 'type_parameter Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'type_parameters) - (t1 : 'type_parameter) (_loc : Gram.Loc.t) - -> - (fun acc -> t2 (Ast.TyApp (_loc, acc, t1)) : - 'type_parameters)))) ]) ])) - ()); - Gram.extend (type_parameter : 'type_parameter Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "-"; Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.TyQuM (_loc, i) : 'type_parameter)))); - ([ Gram.Skeyword "+"; Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.TyQuP (_loc, i) : 'type_parameter)))); - ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyQuo (_loc, i) : 'type_parameter)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'type_parameter) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), - s) -> - (Ast.TyAnt (_loc, (mk_anti n s)) : - 'type_parameter) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (optional_type_parameter : - 'optional_type_parameter Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.TyAny _loc : 'optional_type_parameter)))); - ([ Gram.Skeyword "-"; Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.TyAnM _loc : 'optional_type_parameter)))); - ([ Gram.Skeyword "+"; Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.TyAnP _loc : 'optional_type_parameter)))); - ([ Gram.Skeyword "-"; Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.TyQuM (_loc, i) : - 'optional_type_parameter)))); - ([ Gram.Skeyword "+"; Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.TyQuP (_loc, i) : - 'optional_type_parameter)))); - ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyQuo (_loc, i) : - 'optional_type_parameter)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'optional_type_parameter) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), - s) -> - (Ast.TyAnt (_loc, (mk_anti n s)) : - 'optional_type_parameter) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (ctyp : 'ctyp Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "=="), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "=="; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyMan (_loc, t1, t2) : 'ctyp)))) ]); - ((Some "private"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Skeyword "private"; - Gram.Snterml - ((Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)), - "alias") ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (_loc : Gram.Loc.t) -> - (Ast.TyPrv (_loc, t) : 'ctyp)))) ]); - ((Some "alias"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "as"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyAli (_loc, t1, t2) : 'ctyp)))) ]); - ((Some "forall"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "!"; - Gram.Snterm - (Gram.Entry.obj - (typevars : 'typevars Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'typevars) _ - (_loc : Gram.Loc.t) -> - (Ast.TyPol (_loc, t1, t2) : 'ctyp)))) ]); - ((Some "arrow"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; Gram.Skeyword "->"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyArr (_loc, t1, t2) : 'ctyp)))) ]); - ((Some "label"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (t : 'ctyp) (i : 'a_OPTLABEL) - (_loc : Gram.Loc.t) -> - (Ast.TyOlb (_loc, i, t) : 'ctyp)))); - ([ Gram.Skeyword "?"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.TyOlb (_loc, i, t) : 'ctyp)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LABEL : 'a_LABEL Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (t : 'ctyp) (i : 'a_LABEL) - (_loc : Gram.Loc.t) -> - (Ast.TyLab (_loc, i, t) : 'ctyp)))); - ([ Gram.Skeyword "~"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.TyLab (_loc, i, t) : 'ctyp)))) ]); - ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (let t = Ast.TyApp (_loc, t1, t2) - in - try - Ast.TyId (_loc, (Ast.ident_of_ctyp t)) - with | Invalid_argument _ -> t : - 'ctyp)))) ]); - ((Some "."), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (try - Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.ident_of_ctyp t1), - (Ast.ident_of_ctyp t2)))) - with - | Invalid_argument s -> - raise (Stream.Error s) : - 'ctyp)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (package_type : - 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'package_type) _ _ - (_loc : Gram.Loc.t) -> - (Ast.TyPkg (_loc, p) : 'ctyp)))); - ([ Gram.Skeyword "<"; - Gram.Snterm - (Gram.Entry.obj - (opt_meth_list : - 'opt_meth_list Gram.Entry.t)); - Gram.Skeyword ">" ], - (Gram.Action.mk - (fun _ (t : 'opt_meth_list) _ - (_loc : Gram.Loc.t) -> (t : 'ctyp)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (class_longident : - 'class_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'class_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.TyCls (_loc, i) : 'ctyp)))); - ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (label_declaration_list : - 'label_declaration_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (t : 'label_declaration_list) _ - (_loc : Gram.Loc.t) -> - (Ast.TyRec (_loc, t) : 'ctyp)))); - ([ Gram.Skeyword "[<"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword ">"; - Gram.Snterm - (Gram.Entry.obj - (name_tags : 'name_tags Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) - _ (_loc : Gram.Loc.t) -> - (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp)))); - ([ Gram.Skeyword "[<"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rfl : 'row_field) _ - (_loc : Gram.Loc.t) -> - (Ast.TyVrnInf (_loc, rfl) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword "<"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword ">"; - Gram.Snterm - (Gram.Entry.obj - (name_tags : 'name_tags Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) - _ _ (_loc : Gram.Loc.t) -> - (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword "<"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rfl : 'row_field) _ _ - (_loc : Gram.Loc.t) -> - (Ast.TyVrnInf (_loc, rfl) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword ">"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rfl : 'row_field) _ _ - (_loc : Gram.Loc.t) -> - (Ast.TyVrnSup (_loc, rfl) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword ">"; - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ _ (_loc : Gram.Loc.t) -> - (Ast.TyVrnSup (_loc, (Ast.TyNil _loc)) : - 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rfl : 'row_field) _ _ - (_loc : Gram.Loc.t) -> - (Ast.TyVrnEq (_loc, rfl) : 'ctyp)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (constructor_declarations : - 'constructor_declarations Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (t : 'constructor_declarations) _ - (_loc : Gram.Loc.t) -> - (Ast.TySum (_loc, t) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.TySum (_loc, (Ast.TyNil _loc)) : - 'ctyp)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) -> - (t : 'ctyp)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword "*"; - Gram.Snterm - (Gram.Entry.obj - (star_ctyp : 'star_ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (tl : 'star_ctyp) _ (t : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.TyTup (_loc, - (Ast.TySta (_loc, t, tl))) : - 'ctyp)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdUid (_loc, i))) : - 'ctyp)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) : - 'ctyp)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'ctyp) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("id", _) -> true - | _ -> false), - "ANTIQUOT (\"id\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("id" as n)), s) -> - (Ast.TyId (_loc, - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)))) : - 'ctyp) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("tup", _) -> true - | _ -> false), - "ANTIQUOT (\"tup\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("tup" as n)), s) -> - (Ast.TyTup (_loc, - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)))) : - 'ctyp) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), - s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'ctyp) - | _ -> assert false))); - ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.TyAny _loc : 'ctyp)))); - ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyQuo (_loc, i) : 'ctyp)))) ]) ])) - ()); - Gram.extend (star_ctyp : 'star_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'star_ctyp)))); - ([ Gram.Sself; Gram.Skeyword "*"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'star_ctyp) _ (t1 : 'star_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TySta (_loc, t1, t2) : 'star_ctyp)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp*" n s)) : - 'star_ctyp) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'star_ctyp) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (constructor_declarations : - 'constructor_declarations Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) : - 'constructor_declarations)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (s : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (let (tl, rt) = generalized_type_of_type t - in - Ast.TyCol (_loc, - (Ast.TyId (_loc, - (Ast.IdUid (_loc, s)))), - (Ast.TyArr (_loc, - (Ast.tyAnd_of_list tl), rt))) : - 'constructor_declarations)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'constructor_arg_list) _ - (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyOf (_loc, - (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), - t) : - 'constructor_declarations)))); - ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'constructor_declarations) _ - (t1 : 'constructor_declarations) - (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, t1, t2) : - 'constructor_declarations)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'constructor_declarations) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp|" n s)) : - 'constructor_declarations) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'constructor_declarations) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (constructor_declaration : - 'constructor_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) : - 'constructor_declaration)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'constructor_arg_list) _ - (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyOf (_loc, - (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), - t) : - 'constructor_declaration)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'constructor_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'constructor_declaration) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (constructor_arg_list : 'constructor_arg_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'constructor_arg_list)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'constructor_arg_list) _ - (t1 : 'constructor_arg_list) - (_loc : Gram.Loc.t) -> - (Ast.TyAnd (_loc, t1, t2) : - 'constructor_arg_list)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctypand" n s)) : - 'constructor_arg_list) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (label_declaration_list : - 'label_declaration_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_declaration : - 'label_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t1 : 'label_declaration) - (_loc : Gram.Loc.t) -> - (t1 : 'label_declaration_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_declaration : - 'label_declaration Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (t1 : 'label_declaration) - (_loc : Gram.Loc.t) -> - (t1 : 'label_declaration_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_declaration : - 'label_declaration Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'label_declaration_list) _ - (t1 : 'label_declaration) - (_loc : Gram.Loc.t) -> - (Ast.TySem (_loc, t1, t2) : - 'label_declaration_list)))) ]) ])) - ()); - Gram.extend - (label_declaration : 'label_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Skeyword "mutable"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ _ (s : 'a_LIDENT) - (_loc : Gram.Loc.t) -> - (Ast.TyCol (_loc, - (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), - (Ast.TyMut (_loc, t))) : - 'label_declaration)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (s : 'a_LIDENT) - (_loc : Gram.Loc.t) -> - (Ast.TyCol (_loc, - (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), - t) : - 'label_declaration)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'label_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp;" n s)) : - 'label_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'label_declaration) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_ident : 'a_ident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (i : 'a_ident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (i : 'a_ident)))) ]) ])) - ()); - Gram.extend (ident : 'ident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'ident) _ (i : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, i)), j) : - 'ident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (i : 'ident) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAcc (_loc, - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s))), - i) : - 'ident) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdLid (_loc, i) : 'ident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : 'ident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'ident) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (module_longident : 'module_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : 'module_longident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (l : 'module_longident) _ (m : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : - 'module_longident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'module_longident) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'module_longident_with_app) - (i : 'module_longident_with_app) - (_loc : Gram.Loc.t) -> - (Ast.IdApp (_loc, i, j) : - 'module_longident_with_app)))) ]); - ((Some "."), None, - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'module_longident_with_app) _ - (i : 'module_longident_with_app) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, i, j) : - 'module_longident_with_app)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (i : 'module_longident_with_app) _ - (_loc : Gram.Loc.t) -> - (i : 'module_longident_with_app)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : - 'module_longident_with_app)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'module_longident_with_app) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (module_longident_dot_lparen : - 'module_longident_dot_lparen Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Skeyword "(" ], - (Gram.Action.mk - (fun _ _ (i : 'a_UIDENT) (_loc : Gram.Loc.t) - -> - (Ast.IdUid (_loc, i) : - 'module_longident_dot_lparen)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (l : 'module_longident_dot_lparen) _ - (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : - 'module_longident_dot_lparen)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); - Gram.Skeyword "."; Gram.Skeyword "(" ], - (Gram.Action.mk - (fun _ _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'module_longident_dot_lparen) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (type_longident : 'type_longident Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'type_longident) - (i : 'type_longident) (_loc : Gram.Loc.t) - -> - (Ast.IdApp (_loc, i, j) : 'type_longident)))) ]); - ((Some "."), None, - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'type_longident) _ - (i : 'type_longident) (_loc : Gram.Loc.t) - -> - (Ast.IdAcc (_loc, i, j) : 'type_longident)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (i : 'type_longident) _ - (_loc : Gram.Loc.t) -> - (i : 'type_longident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : 'type_longident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdLid (_loc, i) : 'type_longident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'type_longident) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (label_longident : 'label_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdLid (_loc, i) : 'label_longident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (l : 'label_longident) _ (m : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : - 'label_longident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'label_longident) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (class_type_longident : 'class_type_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_longident : - 'type_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'type_longident) (_loc : Gram.Loc.t) - -> (x : 'class_type_longident)))) ]) ])) - ()); - Gram.extend (val_longident : 'val_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'ident) (_loc : Gram.Loc.t) -> - (x : 'val_longident)))) ]) ])) - ()); - Gram.extend (class_longident : 'class_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'label_longident) - (_loc : Gram.Loc.t) -> - (x : 'class_longident)))) ]) ])) - ()); - Gram.extend - (class_declaration : 'class_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_info_for_class_expr : - 'class_info_for_class_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_fun_binding : - 'class_fun_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_fun_binding) - (ci : 'class_info_for_class_expr) - (_loc : Gram.Loc.t) -> - (Ast.CeEq (_loc, ci, ce) : - 'class_declaration)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_expr_tag : - 'class_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "cdcl" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"cdcl\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "cdcl" | "anti" | "list" as n)), - s) -> - (Ast.CeAnt (_loc, - (mk_anti ~c: "class_expr" n s)) : - 'class_declaration) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (c2 : 'class_declaration) _ - (c1 : 'class_declaration) - (_loc : Gram.Loc.t) -> - (Ast.CeAnd (_loc, c1, c2) : - 'class_declaration)))) ]) ])) - ()); - Gram.extend - (class_fun_binding : 'class_fun_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (cfb : 'class_fun_binding) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (Ast.CeFun (_loc, p, cfb) : - 'class_fun_binding)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (class_type_plus : - 'class_type_plus Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_expr) _ - (ct : 'class_type_plus) _ - (_loc : Gram.Loc.t) -> - (Ast.CeTyc (_loc, ce, ct) : - 'class_fun_binding)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t) - -> (ce : 'class_fun_binding)))) ]) ])) - ()); - Gram.extend - (class_info_for_class_type : - 'class_info_for_class_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_virtual : 'opt_virtual Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_name_and_param : - 'class_name_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((i, ot) : 'class_name_and_param) - (mv : 'opt_virtual) (_loc : Gram.Loc.t) -> - (Ast.CtCon (_loc, mv, - (Ast.IdLid (_loc, i)), ot) : - 'class_info_for_class_type)))) ]) ])) - ()); - Gram.extend - (class_info_for_class_expr : - 'class_info_for_class_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_virtual : 'opt_virtual Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_name_and_param : - 'class_name_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((i, ot) : 'class_name_and_param) - (mv : 'opt_virtual) (_loc : Gram.Loc.t) -> - (Ast.CeCon (_loc, mv, - (Ast.IdLid (_loc, i)), ot) : - 'class_info_for_class_expr)))) ]) ])) - ()); - Gram.extend - (class_name_and_param : 'class_name_and_param Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - ((i, (Ast.TyNil _loc)) : - 'class_name_and_param)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comma_type_parameter : - 'comma_type_parameter Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (x : 'comma_type_parameter) _ - (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - ((i, x) : 'class_name_and_param)))) ]) ])) - ()); - Gram.extend - (comma_type_parameter : 'comma_type_parameter Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_parameter : - 'type_parameter Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'type_parameter) (_loc : Gram.Loc.t) - -> (t : 'comma_type_parameter)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp," n s)) : - 'comma_type_parameter) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'comma_type_parameter) _ - (t1 : 'comma_type_parameter) - (_loc : Gram.Loc.t) -> - (Ast.TyCom (_loc, t1, t2) : - 'comma_type_parameter)))) ]) ])) - ()); - Gram.extend (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'opt_comma_ctyp)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comma_ctyp : 'comma_ctyp Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (x : 'comma_ctyp) _ (_loc : Gram.Loc.t) - -> (x : 'opt_comma_ctyp)))) ]) ])) - ()); - Gram.extend (comma_ctyp : 'comma_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'comma_ctyp)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp," n s)) : - 'comma_ctyp) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'comma_ctyp) _ (t1 : 'comma_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyCom (_loc, t1, t2) : 'comma_ctyp)))) ]) ])) - ()); - Gram.extend (class_fun_def : 'class_fun_def Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t) - -> (ce : 'class_fun_def)))); - ([ Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (ce : 'class_fun_def) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (Ast.CeFun (_loc, p, ce) : 'class_fun_def)))) ]) ])) - ()); - Gram.extend (class_expr : 'class_expr Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Skeyword "let"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (ce : 'class_expr) _ (bi : 'binding) - (rf : 'opt_rec) _ (_loc : Gram.Loc.t) -> - (Ast.CeLet (_loc, rf, bi, ce) : - 'class_expr)))); - ([ Gram.Skeyword "fun"; - Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_fun_def : - 'class_fun_def Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_fun_def) - (p : 'labeled_ipatt) _ (_loc : Gram.Loc.t) - -> (Ast.CeFun (_loc, p, ce) : 'class_expr)))) ]); - ((Some "apply"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Sself; - Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "label") ], - (Gram.Action.mk - (fun (e : 'expr) (ce : 'class_expr) - (_loc : Gram.Loc.t) -> - (Ast.CeApp (_loc, ce, e) : 'class_expr)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (ce : 'class_expr) _ - (_loc : Gram.Loc.t) -> (ce : 'class_expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (class_type : 'class_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (ct : 'class_type) _ (ce : 'class_expr) - _ (_loc : Gram.Loc.t) -> - (Ast.CeTyc (_loc, ce, ct) : 'class_expr)))); - ([ Gram.Skeyword "object"; - Gram.Snterm - (Gram.Entry.obj - (opt_class_self_patt : - 'opt_class_self_patt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_structure : - 'class_structure Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (cst : 'class_structure) - (csp : 'opt_class_self_patt) _ - (_loc : Gram.Loc.t) -> - (Ast.CeStr (_loc, csp, cst) : 'class_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_longident_and_param : - 'class_longident_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_longident_and_param) - (_loc : Gram.Loc.t) -> (ce : 'class_expr)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_expr_tag : - 'class_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "cexp" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"cexp\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "cexp" | "anti" as n)), - s) -> - (Ast.CeAnt (_loc, - (mk_anti ~c: "class_expr" n s)) : - 'class_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (class_longident_and_param : - 'class_longident_and_param Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_longident : - 'class_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ci : 'class_longident) - (_loc : Gram.Loc.t) -> - (Ast.CeCon (_loc, Ast.ViNil, ci, - (Ast.TyNil _loc)) : - 'class_longident_and_param)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_longident : - 'class_longident Gram.Entry.t)); - Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comma_ctyp : 'comma_ctyp Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (t : 'comma_ctyp) _ - (ci : 'class_longident) (_loc : Gram.Loc.t) - -> - (Ast.CeCon (_loc, Ast.ViNil, ci, t) : - 'class_longident_and_param)))) ]) ])) - ()); - Gram.extend (class_structure : 'class_structure Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0 - (Gram.srules class_structure - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_str_item : - 'class_str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (cst : 'class_str_item) - (_loc : Gram.Loc.t) -> - (cst : 'e__10)))) ]) ], - (Gram.Action.mk - (fun (l : 'e__10 list) (_loc : Gram.Loc.t) -> - (Ast.crSem_of_list l : 'class_structure)))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "cst" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (cst : 'class_structure) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "cst" | "anti" | "list" as n)), - s) -> - (Ast.CrSem (_loc, - (Ast.CrAnt (_loc, - (mk_anti ~c: "class_str_item" n s))), - cst) : - 'class_structure) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "cst" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "cst" | "anti" | "list" as n)), - s) -> - (Ast.CrAnt (_loc, - (mk_anti ~c: "class_str_item" n s)) : - 'class_structure) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.PaNil _loc : 'opt_class_self_patt)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : - 'opt_class_self_patt)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) -> - (p : 'opt_class_self_patt)))) ]) ])) - ()); - Gram.extend (class_str_item : 'class_str_item Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "initializer"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (se : 'expr) _ (_loc : Gram.Loc.t) -> - (Ast.CrIni (_loc, se) : 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (type_constraint : - 'type_constraint Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.CrCtr (_loc, t1, t2) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (method_opt_override : - 'method_opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) _ - (pf : 'opt_private) - (o : 'method_opt_override) - (_loc : Gram.Loc.t) -> - (if o <> Ast.OvNil - then - raise - (Stream.Error - "override (!) is incompatible with virtual") - else Ast.CrVir (_loc, l, pf, t) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (method_opt_override : - 'method_opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_polyt : 'opt_polyt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (fun_binding : 'fun_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_binding) (topt : 'opt_polyt) - (l : 'label) (pf : 'opt_private) - (o : 'method_opt_override) - (_loc : Gram.Loc.t) -> - (Ast.CrMth (_loc, l, o, pf, e, topt) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (method_opt_override : - 'method_opt_override Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) - (pf : 'opt_private) _ - (o : 'method_opt_override) - (_loc : Gram.Loc.t) -> - (if o <> Ast.OvNil - then - raise - (Stream.Error - "override (!) is incompatible with virtual") - else Ast.CrVir (_loc, l, pf, t) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val_opt_override : - 'value_val_opt_override Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) - (mf : 'opt_mutable) _ - (o : 'value_val_opt_override) - (_loc : Gram.Loc.t) -> - (if o <> Ast.OvNil - then - raise - (Stream.Error - "override (!) is incompatible with virtual") - else Ast.CrVvr (_loc, l, mf, t) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val_opt_override : - 'value_val_opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) _ - (mf : 'opt_mutable) - (o : 'value_val_opt_override) - (_loc : Gram.Loc.t) -> - (if o <> Ast.OvNil - then - raise - (Stream.Error - "override (!) is incompatible with virtual") - else Ast.CrVvr (_loc, l, mf, t) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val_opt_override : - 'value_val_opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (cvalue_binding : - 'cvalue_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'cvalue_binding) (lab : 'label) - (mf : 'opt_mutable) - (o : 'value_val_opt_override) - (_loc : Gram.Loc.t) -> - (Ast.CrVal (_loc, lab, o, mf, e) : - 'class_str_item)))); - ([ Gram.Skeyword "inherit"; - Gram.Snterm - (Gram.Entry.obj - (opt_override : - 'opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_as_lident : - 'opt_as_lident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (pb : 'opt_as_lident) (ce : 'class_expr) - (o : 'opt_override) _ (_loc : Gram.Loc.t) - -> - (Ast.CrInh (_loc, o, ce, pb) : - 'class_str_item)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_str_item_tag : - 'class_str_item) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "cst" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "cst" | "anti" | "list" as n)), - s) -> - (Ast.CrAnt (_loc, - (mk_anti ~c: "class_str_item" n s)) : - 'class_str_item) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (method_opt_override : 'method_opt_override Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "method" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.OvNil : 'method_opt_override)))); - ([ Gram.Skeyword "method"; - Gram.Stoken - (((function - | ANTIQUOT (("!" | "override" | "anti"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("!" | "override" | "anti" as n)), s) - -> - (Ast.OvAnt (mk_anti n s) : - 'method_opt_override) - | _ -> assert false))); - ([ Gram.Skeyword "method"; Gram.Skeyword "!" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.OvOverride : 'method_opt_override)))) ]) ])) - ()); - Gram.extend - (value_val_opt_override : - 'value_val_opt_override Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.OvNil : 'value_val_opt_override)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Stoken - (((function - | ANTIQUOT (("!" | "override" | "anti"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("!" | "override" | "anti" as n)), s) - -> - (Ast.OvAnt (mk_anti n s) : - 'value_val_opt_override) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Skeyword "!" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.OvOverride : 'value_val_opt_override)))) ]) ])) - ()); - Gram.extend (opt_as_lident : 'opt_as_lident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - ("" : 'opt_as_lident)))); - ([ Gram.Skeyword "as"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (i : 'opt_as_lident)))) ]) ])) - ()); - Gram.extend (opt_polyt : 'opt_polyt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'opt_polyt)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (_loc : Gram.Loc.t) -> - (t : 'opt_polyt)))) ]) ])) - ()); - Gram.extend (cvalue_binding : 'cvalue_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword ":>"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (t : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) : - 'cvalue_binding)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)); - Gram.Skeyword ":>"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (t2 : 'ctyp) _ - (t : 'poly_type) _ (_loc : Gram.Loc.t) -> - (match t with - | Ast.TyPol (_, _, _) -> - raise - (Stream.Error - "unexpected polytype here") - | _ -> Ast.ExCoe (_loc, e, t, t2) : - 'cvalue_binding)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (t : 'poly_type) _ - (_loc : Gram.Loc.t) -> - (Ast.ExTyc (_loc, e, t) : 'cvalue_binding)))); - ([ Gram.Skeyword ":"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (unquoted_typevars : - 'unquoted_typevars Gram.Entry.t)); - Gram.Skeyword "."; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (t2 : 'ctyp) _ - (t1 : 'unquoted_typevars) _ _ - (_loc : Gram.Loc.t) -> - (let u = Ast.TyTypePol (_loc, t1, t2) - in Ast.ExTyc (_loc, e, u) : - 'cvalue_binding)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (e : 'cvalue_binding)))) ]) ])) - ()); - Gram.extend (label : 'label Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (i : 'label)))) ]) ])) - ()); - Gram.extend (class_type : 'class_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "object"; - Gram.Snterm - (Gram.Entry.obj - (opt_class_self_type : - 'opt_class_self_type Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_signature : - 'class_signature Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (csg : 'class_signature) - (cst : 'opt_class_self_type) _ - (_loc : Gram.Loc.t) -> - (Ast.CtSig (_loc, cst, csg) : 'class_type)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_type_longident_and_param : - 'class_type_longident_and_param Gram. - Entry.t)) ], - (Gram.Action.mk - (fun (ct : 'class_type_longident_and_param) - (_loc : Gram.Loc.t) -> (ct : 'class_type)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_type_tag : - 'class_type) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "ctyp" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"ctyp\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "ctyp" | "anti" as n)), - s) -> - (Ast.CtAnt (_loc, - (mk_anti ~c: "class_type" n s)) : - 'class_type) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (class_type_longident_and_param : - 'class_type_longident_and_param Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_type_longident : - 'class_type_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'class_type_longident) - (_loc : Gram.Loc.t) -> - (Ast.CtCon (_loc, Ast.ViNil, i, - (Ast.TyNil _loc)) : - 'class_type_longident_and_param)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_type_longident : - 'class_type_longident Gram.Entry.t)); - Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comma_ctyp : 'comma_ctyp Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (t : 'comma_ctyp) _ - (i : 'class_type_longident) - (_loc : Gram.Loc.t) -> - (Ast.CtCon (_loc, Ast.ViNil, i, t) : - 'class_type_longident_and_param)))) ]) ])) - ()); - Gram.extend (class_type_plus : 'class_type_plus Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_type : 'class_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ct : 'class_type) (_loc : Gram.Loc.t) -> - (ct : 'class_type_plus)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "]"; Gram.Skeyword "->"; Gram. - Sself ], - (Gram.Action.mk - (fun (ct : 'class_type_plus) _ _ (t : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.CtFun (_loc, t, ct) : - 'class_type_plus)))) ]) ])) - ()); - Gram.extend - (opt_class_self_type : 'opt_class_self_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'opt_class_self_type)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) -> - (t : 'opt_class_self_type)))) ]) ])) - ()); - Gram.extend (class_signature : 'class_signature Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0 - (Gram.srules class_signature - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_sig_item : - 'class_sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (csg : 'class_sig_item) - (_loc : Gram.Loc.t) -> - (csg : 'e__11)))) ]) ], - (Gram.Action.mk - (fun (l : 'e__11 list) (_loc : Gram.Loc.t) -> - (Ast.cgSem_of_list l : 'class_signature)))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "csg" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (csg : 'class_signature) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "csg" | "anti" | "list" as n)), - s) -> - (Ast.CgSem (_loc, - (Ast.CgAnt (_loc, - (mk_anti ~c: "class_sig_item" n s))), - csg) : - 'class_signature) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "csg" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "csg" | "anti" | "list" as n)), - s) -> - (Ast.CgAnt (_loc, - (mk_anti ~c: "class_sig_item" n s)) : - 'class_signature) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (class_sig_item : 'class_sig_item Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_constraint : - 'type_constraint Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.CgCtr (_loc, t1, t2) : - 'class_sig_item)))); - ([ Gram.Skeyword "method"; - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) _ - (pf : 'opt_private) _ (_loc : Gram.Loc.t) - -> - (Ast.CgVir (_loc, l, pf, t) : - 'class_sig_item)))); - ([ Gram.Skeyword "method"; - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) - (pf : 'opt_private) _ (_loc : Gram.Loc.t) - -> - (Ast.CgMth (_loc, l, pf, t) : - 'class_sig_item)))); - ([ Gram.Skeyword "method"; - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) - (pf : 'opt_private) _ _ (_loc : Gram.Loc.t) - -> - (Ast.CgVir (_loc, l, pf, t) : - 'class_sig_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_virtual : 'opt_virtual Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (l : 'label) - (mv : 'opt_virtual) (mf : 'opt_mutable) _ - (_loc : Gram.Loc.t) -> - (Ast.CgVal (_loc, l, mf, mv, t) : - 'class_sig_item)))); - ([ Gram.Skeyword "inherit"; - Gram.Snterm - (Gram.Entry.obj - (class_type : 'class_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (cs : 'class_type) _ (_loc : Gram.Loc.t) - -> (Ast.CgInh (_loc, cs) : 'class_sig_item)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_sig_item_tag : - 'class_sig_item) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "csg" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "csg" | "anti" | "list" as n)), - s) -> - (Ast.CgAnt (_loc, - (mk_anti ~c: "class_sig_item" n s)) : - 'class_sig_item) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (type_constraint : 'type_constraint Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "constraint" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'type_constraint)))); - ([ Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'type_constraint)))) ]) ])) - ()); - Gram.extend - (class_description : 'class_description Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_info_for_class_type : - 'class_info_for_class_type Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (class_type_plus : - 'class_type_plus Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ct : 'class_type_plus) _ - (ci : 'class_info_for_class_type) - (_loc : Gram.Loc.t) -> - (Ast.CtCol (_loc, ci, ct) : - 'class_description)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_type_tag : - 'class_description) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "typ" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "typ" | "anti" | "list" as n)), - s) -> - (Ast.CtAnt (_loc, - (mk_anti ~c: "class_type" n s)) : - 'class_description) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (cd2 : 'class_description) _ - (cd1 : 'class_description) - (_loc : Gram.Loc.t) -> - (Ast.CtAnd (_loc, cd1, cd2) : - 'class_description)))) ]) ])) - ()); - Gram.extend - (class_type_declaration : - 'class_type_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_info_for_class_type : - 'class_info_for_class_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (class_type : 'class_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ct : 'class_type) _ - (ci : 'class_info_for_class_type) - (_loc : Gram.Loc.t) -> - (Ast.CtEq (_loc, ci, ct) : - 'class_type_declaration)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_type_tag : - 'class_type_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "typ" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "typ" | "anti" | "list" as n)), - s) -> - (Ast.CtAnt (_loc, - (mk_anti ~c: "class_type" n s)) : - 'class_type_declaration) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (cd2 : 'class_type_declaration) _ - (cd1 : 'class_type_declaration) - (_loc : Gram.Loc.t) -> - (Ast.CtAnd (_loc, cd1, cd2) : - 'class_type_declaration)))) ]) ])) - ()); - Gram.extend (field_expr_list : 'field_expr_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (field_expr : 'field_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (b1 : 'field_expr) (_loc : Gram.Loc.t) -> - (b1 : 'field_expr_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (field_expr : 'field_expr Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (b1 : 'field_expr) (_loc : Gram.Loc.t) - -> (b1 : 'field_expr_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (field_expr : 'field_expr Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'field_expr_list) _ - (b1 : 'field_expr) (_loc : Gram.Loc.t) -> - (Ast.RbSem (_loc, b1, b2) : - 'field_expr_list)))) ]) ])) - ()); - Gram.extend (field_expr : 'field_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top") ], - (Gram.Action.mk - (fun (e : 'expr) _ (l : 'label) - (_loc : Gram.Loc.t) -> - (Ast.RbEq (_loc, (Ast.IdLid (_loc, l)), e) : - 'field_expr)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'field_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "bi" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"bi\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "bi" | "anti" as n)), s) - -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'field_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (meth_list : 'meth_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (meth_decl : 'meth_decl Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], - (Gram.Action.mk - (fun (v : 'opt_dot_dot) (m : 'meth_decl) - (_loc : Gram.Loc.t) -> - ((m, v) : 'meth_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (meth_decl : 'meth_decl Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], - (Gram.Action.mk - (fun (v : 'opt_dot_dot) _ (m : 'meth_decl) - (_loc : Gram.Loc.t) -> - ((m, v) : 'meth_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (meth_decl : 'meth_decl Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun ((ml, v) : 'meth_list) _ (m : 'meth_decl) - (_loc : Gram.Loc.t) -> - (((Ast.TySem (_loc, m, ml)), v) : - 'meth_list)))) ]) ])) - ()); - Gram.extend (meth_decl : 'meth_decl Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (lab : 'a_LIDENT) - (_loc : Gram.Loc.t) -> - (Ast.TyCol (_loc, - (Ast.TyId (_loc, - (Ast.IdLid (_loc, lab)))), - t) : - 'meth_decl)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'meth_decl) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp;" n s)) : - 'meth_decl) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'meth_decl) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (opt_meth_list : 'opt_meth_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], - (Gram.Action.mk - (fun (v : 'opt_dot_dot) (_loc : Gram.Loc.t) -> - (Ast.TyObj (_loc, (Ast.TyNil _loc), v) : - 'opt_meth_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (meth_list : 'meth_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((ml, v) : 'meth_list) - (_loc : Gram.Loc.t) -> - (Ast.TyObj (_loc, ml, v) : 'opt_meth_list)))) ]) ])) - ()); - Gram.extend (poly_type : 'poly_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'poly_type)))) ]) ])) - ()); - Gram.extend (package_type : 'package_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'module_type) (_loc : Gram.Loc.t) -> - (p : 'package_type)))) ]) ])) - ()); - Gram.extend (typevars : 'typevars Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyQuo (_loc, i) : 'typevars)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'typevars) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'typevars) - | _ -> assert false))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'typevars) (t1 : 'typevars) - (_loc : Gram.Loc.t) -> - (Ast.TyApp (_loc, t1, t2) : 'typevars)))) ]) ])) - ()); - Gram.extend - (unquoted_typevars : 'unquoted_typevars Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) : - 'unquoted_typevars)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'unquoted_typevars) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'unquoted_typevars) - | _ -> assert false))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'unquoted_typevars) - (t1 : 'unquoted_typevars) - (_loc : Gram.Loc.t) -> - (Ast.TyApp (_loc, t1, t2) : - 'unquoted_typevars)))) ]) ])) - ()); - Gram.extend (row_field : 'row_field Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'row_field)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'amp_ctyp) _ (i : 'a_ident) _ - (_loc : Gram.Loc.t) -> - (Ast.TyOf (_loc, (Ast.TyVrn (_loc, i)), t) : - 'row_field)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)); - Gram.Skeyword "of"; Gram.Skeyword "&"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'amp_ctyp) _ _ (i : 'a_ident) _ - (_loc : Gram.Loc.t) -> - (Ast.TyOfAmp (_loc, (Ast.TyVrn (_loc, i)), - t) : - 'row_field)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyVrn (_loc, i) : 'row_field)))); - ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'row_field) _ (t1 : 'row_field) - (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, t1, t2) : 'row_field)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp|" n s)) : - 'row_field) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'row_field) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (amp_ctyp : 'amp_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'amp_ctyp)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp&" n s)) : - 'amp_ctyp) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "&"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'amp_ctyp) _ (t1 : 'amp_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyAmp (_loc, t1, t2) : 'amp_ctyp)))) ]) ])) - ()); - Gram.extend (name_tags : 'name_tags Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyVrn (_loc, i) : 'name_tags)))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'name_tags) (t1 : 'name_tags) - (_loc : Gram.Loc.t) -> - (Ast.TyApp (_loc, t1, t2) : 'name_tags)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'name_tags) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (eq_expr : 'eq_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (fun i p -> Ast.PaOlb (_loc, i, p) : - 'eq_expr)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (fun i p -> Ast.PaOlbi (_loc, i, p, e) : - 'eq_expr)))) ]) ])) - ()); - Gram.extend (patt_tcon : 'patt_tcon Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'patt_tcon)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (p : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : 'patt_tcon)))) ]) ])) - ()); - Gram.extend (ipatt : 'ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "?"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ (p : 'ipatt_tcon) _ _ - (_loc : Gram.Loc.t) -> - (Ast.PaOlbi (_loc, "", p, e) : 'ipatt)))); - ([ Gram.Skeyword "?"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'ipatt_tcon) _ _ - (_loc : Gram.Loc.t) -> - (Ast.PaOlb (_loc, "", p) : 'ipatt)))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaOlb (_loc, (mk_anti n i), - (Ast.PaNil _loc)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT i -> - (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")); - Gram.Skeyword ":"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (eq_expr : 'eq_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ _ - (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (f (mk_anti n i) p : 'ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function | OPTLABEL _ -> true | _ -> false), - "OPTLABEL _")); - Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (eq_expr : 'eq_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | OPTLABEL i -> (f i p : 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT i -> - (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaLab (_loc, (mk_anti n i), - (Ast.PaNil _loc)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (p : 'ipatt) _ - (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaLab (_loc, (mk_anti n i), p) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function | LABEL _ -> true | _ -> false), - "LABEL _")); - Gram.Sself ], - (Gram.Action.mk - (fun (p : 'ipatt) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LABEL i -> - (Ast.PaLab (_loc, i, p) : 'ipatt) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (ipatt_tcon : 'ipatt_tcon Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> - (p : 'ipatt_tcon)))); - ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (p : 'ipatt) - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : 'ipatt_tcon)))) ]) ])) - ()); - Gram.extend (direction_flag : 'direction_flag Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | ANTIQUOT (("to" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"to\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("to" | "anti" as n)), s) -> - (Ast.DiAnt (mk_anti n s) : - 'direction_flag) - | _ -> assert false))); - ([ Gram.Skeyword "downto" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.DiDownto : 'direction_flag)))); - ([ Gram.Skeyword "to" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.DiTo : 'direction_flag)))) ]) ])) - ()); - Gram.extend (opt_private : 'opt_private Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.PrNil : 'opt_private)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("private" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"private\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("private" | "anti" as n)), s) - -> - (Ast.PrAnt (mk_anti n s) : - 'opt_private) - | _ -> assert false))); - ([ Gram.Skeyword "private" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.PrPrivate : 'opt_private)))) ]) ])) - ()); - Gram.extend (opt_mutable : 'opt_mutable Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.MuNil : 'opt_mutable)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("mutable" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"mutable\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("mutable" | "anti" as n)), s) - -> - (Ast.MuAnt (mk_anti n s) : - 'opt_mutable) - | _ -> assert false))); - ([ Gram.Skeyword "mutable" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.MuMutable : 'opt_mutable)))) ]) ])) - ()); - Gram.extend (opt_virtual : 'opt_virtual Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ViNil : 'opt_virtual)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("virtual" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"virtual\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("virtual" | "anti" as n)), s) - -> - (Ast.ViAnt (mk_anti n s) : - 'opt_virtual) - | _ -> assert false))); - ([ Gram.Skeyword "virtual" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ViVirtual : 'opt_virtual)))) ]) ])) - ()); - Gram.extend (opt_dot_dot : 'opt_dot_dot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.RvNil : 'opt_dot_dot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ((".." | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"..\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT (((".." | "anti" as n)), s) -> - (Ast.RvAnt (mk_anti n s) : - 'opt_dot_dot) - | _ -> assert false))); - ([ Gram.Skeyword ".." ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.RvRowVar : 'opt_dot_dot)))) ]) ])) - ()); - Gram.extend (opt_rec : 'opt_rec Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ReNil : 'opt_rec)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("rec" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"rec\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("rec" | "anti" as n)), s) -> - (Ast.ReAnt (mk_anti n s) : 'opt_rec) - | _ -> assert false))); - ([ Gram.Skeyword "rec" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ReRecursive : 'opt_rec)))) ]) ])) - ()); - Gram.extend (opt_override : 'opt_override Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.OvNil : 'opt_override)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("!" | "override" | "anti"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("!" | "override" | "anti" as n)), s) - -> - (Ast.OvAnt (mk_anti n s) : - 'opt_override) - | _ -> assert false))); - ([ Gram.Skeyword "!" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.OvOverride : 'opt_override)))) ]) ])) - ()); - Gram.extend (opt_expr : 'opt_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ExNil _loc : 'opt_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (e : 'opt_expr)))) ]) ])) - ()); - Gram.extend (interf : 'interf Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (([], None) : 'interf) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : 'sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun ((sil, stopped) : 'interf) _ - (si : 'sig_item) (_loc : Gram.Loc.t) -> - (((si :: sil), stopped) : 'interf)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (([ Ast.SgDir (_loc, n, dp) ], - (stopped_at _loc)) : 'interf)))) ]) ])) - ()); - Gram.extend (sig_items : 'sig_items Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0 - (Gram.srules sig_items - [ ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : - 'sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (sg : 'sig_item) - (_loc : Gram.Loc.t) -> - (sg : 'e__12)))) ]) ], - (Gram.Action.mk - (fun (l : 'e__12 list) (_loc : Gram.Loc.t) -> - (Ast.sgSem_of_list l : 'sig_items)))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "sigi" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (sg : 'sig_items) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "sigi" | "anti" | "list" as n)), - s) -> - (Ast.SgSem (_loc, - (Ast.SgAnt (_loc, - (mk_anti n ~c: "sig_item" s))), - sg) : - 'sig_items) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "sigi" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "sigi" | "anti" | "list" as n)), - s) -> - (Ast.SgAnt (_loc, - (mk_anti n ~c: "sig_item" s)) : - 'sig_items) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (implem : 'implem Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (([], None) : 'implem) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun ((sil, stopped) : 'implem) _ - (si : 'str_item) (_loc : Gram.Loc.t) -> - (((si :: sil), stopped) : 'implem)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (([ Ast.StDir (_loc, n, dp) ], - (stopped_at _loc)) : 'implem)))) ]) ])) - ()); - Gram.extend (str_items : 'str_items Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0 - (Gram.srules str_items - [ ([ Gram.Snterm - (Gram.Entry.obj - (str_item : - 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (st : 'str_item) - (_loc : Gram.Loc.t) -> - (st : 'e__13)))) ]) ], - (Gram.Action.mk - (fun (l : 'e__13 list) (_loc : Gram.Loc.t) -> - (Ast.stSem_of_list l : 'str_items)))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "stri" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (st : 'str_items) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "stri" | "anti" | "list" as n)), - s) -> - (Ast.StSem (_loc, - (Ast.StAnt (_loc, - (mk_anti n ~c: "str_item" s))), - st) : - 'str_items) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "stri" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "stri" | "anti" | "list" as n)), - s) -> - (Ast.StAnt (_loc, - (mk_anti n ~c: "str_item" s)) : - 'str_items) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (top_phrase : 'top_phrase Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (None : 'top_phrase) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (phrase : 'phrase Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ph : 'phrase) (_loc : Gram.Loc.t) -> - (Some ph : 'top_phrase)))) ]) ])) - ()); - Gram.extend (use_file : 'use_file Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (([], None) : 'use_file) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun ((sil, stopped) : 'use_file) _ - (si : 'str_item) (_loc : Gram.Loc.t) -> - (((si :: sil), stopped) : 'use_file)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (([ Ast.StDir (_loc, n, dp) ], - (stopped_at _loc)) : 'use_file)))) ]) ])) - ()); - Gram.extend (phrase : 'phrase Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (st : 'str_item) (_loc : Gram.Loc.t) -> - (st : 'phrase)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.StDir (_loc, n, dp) : 'phrase)))) ]) ])) - ()); - Gram.extend (a_INT : 'a_INT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | INT (_, _) -> true | _ -> false), - "INT (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | INT (_, s) -> (s : 'a_INT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "int" | "`int"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"int\" | \"`int\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "int" | "`int" as n)), - s) -> (mk_anti n s : 'a_INT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_INT32 : 'a_INT32 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | INT32 (_, _) -> true - | _ -> false), - "INT32 (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | INT32 (_, s) -> (s : 'a_INT32) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "int32" | "`int32"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"int32\" | \"`int32\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "int32" | "`int32" as n)), s) - -> (mk_anti n s : 'a_INT32) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_INT64 : 'a_INT64 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | INT64 (_, _) -> true - | _ -> false), - "INT64 (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | INT64 (_, s) -> (s : 'a_INT64) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "int64" | "`int64"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"int64\" | \"`int64\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "int64" | "`int64" as n)), s) - -> (mk_anti n s : 'a_INT64) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | NATIVEINT (_, _) -> true - | _ -> false), - "NATIVEINT (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | NATIVEINT (_, s) -> (s : 'a_NATIVEINT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "nativeint" | "`nativeint"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"nativeint\" | \"`nativeint\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "nativeint" | "`nativeint" as - n)), - s) -> (mk_anti n s : 'a_NATIVEINT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_FLOAT : 'a_FLOAT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | FLOAT (_, _) -> true - | _ -> false), - "FLOAT (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | FLOAT (_, s) -> (s : 'a_FLOAT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "flo" | "`flo"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"flo\" | \"`flo\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "flo" | "`flo" as n)), - s) -> (mk_anti n s : 'a_FLOAT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_CHAR : 'a_CHAR Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | CHAR (_, _) -> true - | _ -> false), - "CHAR (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | CHAR (_, s) -> (s : 'a_CHAR) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "chr" | "`chr"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"chr\" | \"`chr\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "chr" | "`chr" as n)), - s) -> (mk_anti n s : 'a_CHAR) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_UIDENT : 'a_UIDENT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | UIDENT _ -> true | _ -> false), - "UIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT s -> (s : 'a_UIDENT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "uid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"uid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "uid" as n)), s) -> - (mk_anti n s : 'a_UIDENT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_LIDENT : 'a_LIDENT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT s -> (s : 'a_LIDENT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), s) -> - (mk_anti n s : 'a_LIDENT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_LABEL : 'a_LABEL Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | LABEL _ -> true | _ -> false), - "LABEL _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LABEL s -> (s : 'a_LABEL) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":" ], - (Gram.Action.mk - (fun _ (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), s) -> - (mk_anti n s : 'a_LABEL) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | OPTLABEL _ -> true | _ -> false), - "OPTLABEL _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | OPTLABEL s -> (s : 'a_OPTLABEL) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":" ], - (Gram.Action.mk - (fun _ (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), s) -> - (mk_anti n s : 'a_OPTLABEL) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_STRING : 'a_STRING Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | STRING (_, _) -> true - | _ -> false), - "STRING (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | STRING (_, s) -> (s : 'a_STRING) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "str" | "`str"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"str\" | \"`str\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "str" | "`str" as n)), - s) -> (mk_anti n s : 'a_STRING) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (string_list : 'string_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | STRING (_, _) -> true - | _ -> false), - "STRING (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | STRING (_, x) -> - (Ast.LCons (x, Ast.LNil) : - 'string_list) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | STRING (_, _) -> true - | _ -> false), - "STRING (_, _)")); - Gram.Sself ], - (Gram.Action.mk - (fun (xs : 'string_list) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | STRING (_, x) -> - (Ast.LCons (x, xs) : 'string_list) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "str_list"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"str_list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT (("" | "str_list"), s) -> - (Ast.LAnt (mk_anti "str_list" s) : - 'string_list) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (value_let : 'value_let Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "value" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'value_let)))) ]) ])) - ()); - Gram.extend (value_val : 'value_val Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "value" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'value_val)))) ]) ])) - ()); - Gram.extend (semi : 'semi Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> (() : 'semi)))) ]) ])) - ()); - Gram.extend (expr_quot : 'expr_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ExNil _loc : 'expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (e : 'expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sem_expr : 'sem_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e2 : 'sem_expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExSem (_loc, e1, e2) : 'expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_expr : 'comma_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e2 : 'comma_expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExCom (_loc, e1, e2) : 'expr_quot)))) ]) ])) - ()); - Gram.extend (patt_quot : 'patt_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.PaNil _loc : 'patt_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'patt) (_loc : Gram.Loc.t) -> - (x : 'patt_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'patt) _ (x : 'patt) - (_loc : Gram.Loc.t) -> - (let i = - match x with - | Ast.PaAnt (loc, s) -> - Ast.IdAnt (loc, s) - | p -> Ast.ident_of_patt p - in Ast.PaEq (_loc, i, y) : 'patt_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sem_patt : 'sem_patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'sem_patt) _ (x : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, x, y) : 'patt_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_patt : 'comma_patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'comma_patt) _ (x : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaCom (_loc, x, y) : 'patt_quot)))) ]) ])) - ()); - Gram.extend (ctyp_quot : 'ctyp_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (x : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "and"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'constructor_arg_list) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyAnd (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "&"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'amp_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyAmp (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "*"; - Gram.Snterm - (Gram.Entry.obj - (star_ctyp : 'star_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'star_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TySta (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (label_declaration_list : - 'label_declaration_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (z : 'label_declaration_list) _ - (y : 'more_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TySem (_loc, (Ast.TyCol (_loc, x, y)), - z) : - 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'more_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyCol (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "of"; Gram.Skeyword "&"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)); - Gram.Skeyword "|"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)) ], - (Gram.Action.mk - (fun (z : 'row_field) _ (y : 'amp_ctyp) _ _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, - (Ast.TyOfAmp (_loc, x, y)), z) : - 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "of"; Gram.Skeyword "&"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'amp_ctyp) _ _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyOfAmp (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)); - Gram.Skeyword "|"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declarations : - 'constructor_declarations Gram.Entry.t)) ], - (Gram.Action.mk - (fun (z : 'constructor_declarations) _ - (y : 'constructor_arg_list) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, (Ast.TyOf (_loc, x, y)), - z) : - 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'constructor_arg_list) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyOf (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "|"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declarations : - 'constructor_declarations Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'constructor_declarations) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (label_declaration_list : - 'label_declaration_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'label_declaration_list) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TySem (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_ctyp : 'comma_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'comma_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyCom (_loc, x, y) : 'ctyp_quot)))) ]) ])) - ()); - Gram.extend (more_ctyp : 'more_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_parameter : - 'type_parameter Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'type_parameter) (_loc : Gram.Loc.t) - -> (x : 'more_ctyp)))); - ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'ctyp) (_loc : Gram.Loc.t) -> - (x : 'more_ctyp)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyVrn (_loc, x) : 'more_ctyp)))); - ([ Gram.Skeyword "mutable"; Gram.Sself ], - (Gram.Action.mk - (fun (x : 'more_ctyp) _ (_loc : Gram.Loc.t) -> - (Ast.TyMut (_loc, x) : 'more_ctyp)))) ]) ])) - ()); - Gram.extend (str_item_quot : 'str_item_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.StNil _loc : 'str_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)) ], - (Gram.Action.mk - (fun (st : 'str_item) (_loc : Gram.Loc.t) -> - (st : 'str_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (st2 : 'str_item_quot) _ - (st1 : 'str_item) (_loc : Gram.Loc.t) -> - (match st2 with - | Ast.StNil _ -> st1 - | _ -> Ast.StSem (_loc, st1, st2) : - 'str_item_quot)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.StDir (_loc, n, dp) : 'str_item_quot)))) ]) ])) - ()); - Gram.extend (sig_item_quot : 'sig_item_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.SgNil _loc : 'sig_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : 'sig_item Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sg : 'sig_item) (_loc : Gram.Loc.t) -> - (sg : 'sig_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : 'sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (sg2 : 'sig_item_quot) _ - (sg1 : 'sig_item) (_loc : Gram.Loc.t) -> - (match sg2 with - | Ast.SgNil _ -> sg1 - | _ -> Ast.SgSem (_loc, sg1, sg2) : - 'sig_item_quot)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.SgDir (_loc, n, dp) : 'sig_item_quot)))) ]) ])) - ()); - Gram.extend - (module_type_quot : 'module_type_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.MtNil _loc : 'module_type_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'module_type) (_loc : Gram.Loc.t) -> - (x : 'module_type_quot)))) ]) ])) - ()); - Gram.extend - (module_expr_quot : 'module_expr_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.MeNil _loc : 'module_expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'module_expr) (_loc : Gram.Loc.t) -> - (x : 'module_expr_quot)))) ]) ])) - ()); - Gram.extend (match_case_quot : 'match_case_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.McNil _loc : 'match_case_quot)))); - ([ Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (match_case0 : - 'match_case0 Gram.Entry.t))), - (Gram.Skeyword "|")) ], - (Gram.Action.mk - (fun (x : 'match_case0 list) - (_loc : Gram.Loc.t) -> - (Ast.mcOr_of_list x : 'match_case_quot)))) ]) ])) - ()); - Gram.extend (binding_quot : 'binding_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.BiNil _loc : 'binding_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'binding) (_loc : Gram.Loc.t) -> - (x : 'binding_quot)))) ]) ])) - ()); - Gram.extend - (rec_binding_quot : 'rec_binding_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.RbNil _loc : 'rec_binding_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_expr_list : - 'label_expr_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'label_expr_list) - (_loc : Gram.Loc.t) -> - (x : 'rec_binding_quot)))) ]) ])) - ()); - Gram.extend - (module_binding_quot : 'module_binding_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.MbNil _loc : 'module_binding_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) - _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.MbColEq (_loc, m, mt, me) : - 'module_binding_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (m : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.MbCol (_loc, m, mt) : - 'module_binding_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) - _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), m) -> - (Ast.MbColEq (_loc, (mk_anti n m), mt, - me) : - 'module_binding_quot) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), m) -> - (Ast.MbCol (_loc, (mk_anti n m), mt) : - 'module_binding_quot) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), s) -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_binding_quot) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("module_binding" | "anti"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"module_binding\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("module_binding" | "anti" as n)), s) - -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_binding_quot) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'module_binding_quot) _ - (b1 : 'module_binding_quot) - (_loc : Gram.Loc.t) -> - (Ast.MbAnd (_loc, b1, b2) : - 'module_binding_quot)))) ]) ])) - ()); - Gram.extend (ident_quot : 'ident_quot Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'ident_quot) (i : 'ident_quot) - (_loc : Gram.Loc.t) -> - (Ast.IdApp (_loc, i, j) : 'ident_quot)))) ]); - ((Some "."), None, - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'ident_quot) _ (i : 'ident_quot) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, i, j) : 'ident_quot)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (i : 'ident_quot) _ (_loc : Gram.Loc.t) - -> (i : 'ident_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (i : 'ident_quot) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAcc (_loc, - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s))), - i) : - 'ident_quot) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdLid (_loc, i) : 'ident_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : 'ident_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'ident_quot) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (class_expr_quot : 'class_expr_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.CeNil _loc : 'class_expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'class_expr) (_loc : Gram.Loc.t) -> - (x : 'class_expr_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("virtual", _) -> true - | _ -> false), - "ANTIQUOT (\"virtual\", _)")); - Gram.Snterm - (Gram.Entry.obj (ident : 'ident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_comma_ctyp : - 'opt_comma_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ot : 'opt_comma_ctyp) (i : 'ident) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("virtual" as n)), s) -> - (let anti = - Ast.ViAnt - (mk_anti ~c: "class_expr" n s) - in Ast.CeCon (_loc, anti, i, ot) : - 'class_expr_quot) - | _ -> assert false))); - ([ Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (class_name_and_param : - 'class_name_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((i, ot) : 'class_name_and_param) _ - (_loc : Gram.Loc.t) -> - (Ast.CeCon (_loc, Ast.ViVirtual, - (Ast.IdLid (_loc, i)), ot) : - 'class_expr_quot)))); - ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ], - (Gram.Action.mk - (fun (ce2 : 'class_expr_quot) _ - (ce1 : 'class_expr_quot) - (_loc : Gram.Loc.t) -> - (Ast.CeEq (_loc, ce1, ce2) : - 'class_expr_quot)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (ce2 : 'class_expr_quot) _ - (ce1 : 'class_expr_quot) - (_loc : Gram.Loc.t) -> - (Ast.CeAnd (_loc, ce1, ce2) : - 'class_expr_quot)))) ]) ])) - ()); - Gram.extend (class_type_quot : 'class_type_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.CtNil _loc : 'class_type_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_type_plus : - 'class_type_plus Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'class_type_plus) - (_loc : Gram.Loc.t) -> - (x : 'class_type_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("virtual", _) -> true - | _ -> false), - "ANTIQUOT (\"virtual\", _)")); - Gram.Snterm - (Gram.Entry.obj (ident : 'ident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_comma_ctyp : - 'opt_comma_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ot : 'opt_comma_ctyp) (i : 'ident) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("virtual" as n)), s) -> - (let anti = - Ast.ViAnt - (mk_anti ~c: "class_type" n s) - in Ast.CtCon (_loc, anti, i, ot) : - 'class_type_quot) - | _ -> assert false))); - ([ Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (class_name_and_param : - 'class_name_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((i, ot) : 'class_name_and_param) _ - (_loc : Gram.Loc.t) -> - (Ast.CtCon (_loc, Ast.ViVirtual, - (Ast.IdLid (_loc, i)), ot) : - 'class_type_quot)))); - ([ Gram.Sself; Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (ct2 : 'class_type_quot) _ - (ct1 : 'class_type_quot) - (_loc : Gram.Loc.t) -> - (Ast.CtCol (_loc, ct1, ct2) : - 'class_type_quot)))); - ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ], - (Gram.Action.mk - (fun (ct2 : 'class_type_quot) _ - (ct1 : 'class_type_quot) - (_loc : Gram.Loc.t) -> - (Ast.CtEq (_loc, ct1, ct2) : - 'class_type_quot)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (ct2 : 'class_type_quot) _ - (ct1 : 'class_type_quot) - (_loc : Gram.Loc.t) -> - (Ast.CtAnd (_loc, ct1, ct2) : - 'class_type_quot)))) ]) ])) - ()); - Gram.extend - (class_str_item_quot : 'class_str_item_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.CrNil _loc : 'class_str_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_str_item : - 'class_str_item Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'class_str_item) (_loc : Gram.Loc.t) - -> (x : 'class_str_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_str_item : - 'class_str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (x2 : 'class_str_item_quot) _ - (x1 : 'class_str_item) (_loc : Gram.Loc.t) - -> - (match x2 with - | Ast.CrNil _ -> x1 - | _ -> Ast.CrSem (_loc, x1, x2) : - 'class_str_item_quot)))) ]) ])) - ()); - Gram.extend - (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.CgNil _loc : 'class_sig_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_sig_item : - 'class_sig_item Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'class_sig_item) (_loc : Gram.Loc.t) - -> (x : 'class_sig_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_sig_item : - 'class_sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (x2 : 'class_sig_item_quot) _ - (x1 : 'class_sig_item) (_loc : Gram.Loc.t) - -> - (match x2 with - | Ast.CgNil _ -> x1 - | _ -> Ast.CgSem (_loc, x1, x2) : - 'class_sig_item_quot)))) ]) ])) - ()); - Gram.extend - (with_constr_quot : 'with_constr_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.WcNil _loc : 'with_constr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (with_constr : 'with_constr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'with_constr) (_loc : Gram.Loc.t) -> - (x : 'with_constr_quot)))) ]) ])) - ()); - Gram.extend (rec_flag_quot : 'rec_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_rec) (_loc : Gram.Loc.t) -> - (x : 'rec_flag_quot)))) ]) ])) - ()); - Gram.extend - (direction_flag_quot : 'direction_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (direction_flag : - 'direction_flag Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'direction_flag) (_loc : Gram.Loc.t) - -> (x : 'direction_flag_quot)))) ]) ])) - ()); - Gram.extend - (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_mutable) (_loc : Gram.Loc.t) -> - (x : 'mutable_flag_quot)))) ]) ])) - ()); - Gram.extend - (private_flag_quot : 'private_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_private) (_loc : Gram.Loc.t) -> - (x : 'private_flag_quot)))) ]) ])) - ()); - Gram.extend - (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_virtual : 'opt_virtual Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_virtual) (_loc : Gram.Loc.t) -> - (x : 'virtual_flag_quot)))) ]) ])) - ()); - Gram.extend - (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_dot_dot) (_loc : Gram.Loc.t) -> - (x : 'row_var_flag_quot)))) ]) ])) - ()); - Gram.extend - (override_flag_quot : 'override_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_override : - 'opt_override Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_override) (_loc : Gram.Loc.t) - -> (x : 'override_flag_quot)))) ]) ])) - ()); - Gram.extend (patt_eoi : 'patt_eoi Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) (x : 'patt) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (x : 'patt_eoi) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (expr_eoi : 'expr_eoi Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) (x : 'expr) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (x : 'expr_eoi) - | _ -> assert false))) ]) ])) - ())) - in apply () - - end - - let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () - - end - -module Camlp4QuotationCommon = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2002-2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Nicolas Pouillard: initial version - *) - module Id = - struct - let name = "Camlp4QuotationCommon" - - let version = Sys.ocaml_version - - end - - module Make - (Syntax : Sig.Camlp4Syntax) - (TheAntiquotSyntax : Sig.Parser(Syntax.Ast).SIMPLE) = - struct - open Sig - - include Syntax - - (* Be careful an AntiquotSyntax module appears here *) - module MetaLocHere = Ast.Meta.MetaLoc - - module MetaLoc = - struct - module Ast = Ast - - let loc_name = ref None - - let meta_loc_expr _loc loc = - match !loc_name with - | None -> Ast.ExId (_loc, (Ast.IdLid (_loc, !Loc.name))) - | Some "here" -> MetaLocHere.meta_loc_expr _loc loc - | Some x -> Ast.ExId (_loc, (Ast.IdLid (_loc, x))) - - let meta_loc_patt _loc _ = Ast.PaAny _loc - - end - - module MetaAst = Ast.Meta.Make(MetaLoc) - - module ME = MetaAst.Expr - - module MP = MetaAst.Patt - - let is_antiquot s = - let len = String.length s - in (len > 2) && ((s.[0] = '\\') && (s.[1] = '$')) - - let handle_antiquot_in_string s term parse loc decorate = - if is_antiquot s - then - (let pos = String.index s ':' in - let name = String.sub s 2 (pos - 2) - and code = - String.sub s (pos + 1) (((String.length s) - pos) - 1) - in decorate name (parse loc code)) - else term - - let antiquot_expander = - object - inherit Ast.map as super - method patt = - function - | (Ast.PaAnt (_loc, s) | Ast.PaStr (_loc, s) as p) -> - let mloc _loc = MetaLoc.meta_loc_patt _loc _loc - in - handle_antiquot_in_string s p TheAntiquotSyntax. - parse_patt _loc - (fun n p -> - match n with - | "antisig_item" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgAnt")))))), - (mloc _loc))), - p) - | "antistr_item" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StAnt")))))), - (mloc _loc))), - p) - | "antictyp" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnt")))))), - (mloc _loc))), - p) - | "antipatt" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaAnt")))))), - (mloc _loc))), - p) - | "antiexpr" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAnt")))))), - (mloc _loc))), - p) - | "antimodule_type" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtAnt")))))), - (mloc _loc))), - p) - | "antimodule_expr" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeAnt")))))), - (mloc _loc))), - p) - | "anticlass_type" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtAnt")))))), - (mloc _loc))), - p) - | "anticlass_expr" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeAnt")))))), - (mloc _loc))), - p) - | "anticlass_sig_item" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgAnt")))))), - (mloc _loc))), - p) - | "anticlass_str_item" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrAnt")))))), - (mloc _loc))), - p) - | "antiwith_constr" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcAnt")))))), - (mloc _loc))), - p) - | "antibinding" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiAnt")))))), - (mloc _loc))), - p) - | "antirec_binding" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbAnt")))))), - (mloc _loc))), - p) - | "antimatch_case" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McAnt")))))), - (mloc _loc))), - p) - | "antimodule_binding" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbAnt")))))), - (mloc _loc))), - p) - | "antiident" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdAnt")))))), - (mloc _loc))), - p) - | _ -> p) - | p -> super#patt p - method expr = - function - | (Ast.ExAnt (_loc, s) | Ast.ExStr (_loc, s) as e) -> - let mloc _loc = MetaLoc.meta_loc_expr _loc _loc - in - handle_antiquot_in_string s e TheAntiquotSyntax. - parse_expr _loc - (fun n e -> - match n with - | "`int" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "string_of_int")))), - e) - | "`int32" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Int32")), - (Ast.IdLid (_loc, "to_string")))))), - e) - | "`int64" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Int64")), - (Ast.IdLid (_loc, "to_string")))))), - e) - | "`nativeint" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Nativeint")), - (Ast.IdLid (_loc, "to_string")))))), - e) - | "`flo" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4_import")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Oprint")), - (Ast.IdLid (_loc, "float_repres")))))))), - e) - | "`str" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "safe_string_escaped")))))), - e) - | "`chr" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Char")), - (Ast.IdLid (_loc, "escaped")))))), - e) - | "`bool" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdUid")))))), - (mloc _loc))), - (Ast.ExIfe (_loc, e, - (Ast.ExStr (_loc, "True")), - (Ast.ExStr (_loc, "False"))))) - | "liststr_item" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "stSem_of_list")))))), - e) - | "listsig_item" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "sgSem_of_list")))))), - e) - | "listclass_sig_item" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "cgSem_of_list")))))), - e) - | "listclass_str_item" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "crSem_of_list")))))), - e) - | "listmodule_expr" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "meApp_of_list")))))), - e) - | "listmodule_type" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "mtApp_of_list")))))), - e) - | "listmodule_binding" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "mbAnd_of_list")))))), - e) - | "listbinding" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "biAnd_of_list")))))), - e) - | "listbinding;" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "biSem_of_list")))))), - e) - | "listrec_binding" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "rbSem_of_list")))))), - e) - | "listclass_type" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "ctAnd_of_list")))))), - e) - | "listclass_expr" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "ceAnd_of_list")))))), - e) - | "listident" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "idAcc_of_list")))))), - e) - | "listctypand" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "tyAnd_of_list")))))), - e) - | "listctyp;" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "tySem_of_list")))))), - e) - | "listctyp*" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "tySta_of_list")))))), - e) - | "listctyp|" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "tyOr_of_list")))))), - e) - | "listctyp," -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "tyCom_of_list")))))), - e) - | "listctyp&" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "tyAmp_of_list")))))), - e) - | "listwith_constr" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "wcAnd_of_list")))))), - e) - | "listmatch_case" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "mcOr_of_list")))))), - e) - | "listpatt," -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "paCom_of_list")))))), - e) - | "listpatt;" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "paSem_of_list")))))), - e) - | "listexpr," -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "exCom_of_list")))))), - e) - | "listexpr;" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "exSem_of_list")))))), - e) - | "antisig_item" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgAnt")))))), - (mloc _loc))), - e) - | "antistr_item" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StAnt")))))), - (mloc _loc))), - e) - | "antictyp" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnt")))))), - (mloc _loc))), - e) - | "antipatt" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaAnt")))))), - (mloc _loc))), - e) - | "antiexpr" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAnt")))))), - (mloc _loc))), - e) - | "antimodule_type" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtAnt")))))), - (mloc _loc))), - e) - | "antimodule_expr" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeAnt")))))), - (mloc _loc))), - e) - | "anticlass_type" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtAnt")))))), - (mloc _loc))), - e) - | "anticlass_expr" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeAnt")))))), - (mloc _loc))), - e) - | "anticlass_sig_item" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgAnt")))))), - (mloc _loc))), - e) - | "anticlass_str_item" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrAnt")))))), - (mloc _loc))), - e) - | "antiwith_constr" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcAnt")))))), - (mloc _loc))), - e) - | "antibinding" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiAnt")))))), - (mloc _loc))), - e) - | "antirec_binding" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbAnt")))))), - (mloc _loc))), - e) - | "antimatch_case" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McAnt")))))), - (mloc _loc))), - e) - | "antimodule_binding" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbAnt")))))), - (mloc _loc))), - e) - | "antiident" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdAnt")))))), - (mloc _loc))), - e) - | _ -> e) - | e -> super#expr e - end - - let add_quotation name entry mexpr mpatt = - let entry_eoi = Gram.Entry.mk (Gram.Entry.name entry) in - let parse_quot_string entry loc s = - let q = !Camlp4_config.antiquotations in - let () = Camlp4_config.antiquotations := true in - let res = Gram.parse_string entry loc s in - let () = Camlp4_config.antiquotations := q in res in - let expand_expr loc loc_name_opt s = - let ast = parse_quot_string entry_eoi loc s in - let () = MetaLoc.loc_name := loc_name_opt in - let meta_ast = mexpr loc ast in - let exp_ast = antiquot_expander#expr meta_ast in exp_ast in - let expand_str_item loc loc_name_opt s = - let exp_ast = expand_expr loc loc_name_opt s - in Ast.StExp (loc, exp_ast) in - let expand_patt _loc loc_name_opt s = - let ast = parse_quot_string entry_eoi _loc s in - let meta_ast = mpatt _loc ast in - let exp_ast = antiquot_expander#patt meta_ast - in - match loc_name_opt with - | None -> exp_ast - | Some name -> - let rec subst_first_loc = - (function - | Ast.PaApp (_loc, - (Ast.PaId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Ast")), - (Ast.IdUid (_, u)))))), - _) -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, u)))))), - (Ast.PaId (_loc, (Ast.IdLid (_loc, name))))) - | Ast.PaApp (_loc, a, b) -> - Ast.PaApp (_loc, (subst_first_loc a), b) - | p -> p) - in subst_first_loc exp_ast - in - (Gram.extend (entry_eoi : 'entry_eoi Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (entry : 'entry Gram.Entry.t)); - Gram.Stoken - (((function | EOI -> true | _ -> false), "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) (x : 'entry) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (x : 'entry_eoi) - | _ -> assert false))) ]) ])) - ()); - Quotation.add name Quotation.DynAst.expr_tag expand_expr; - Quotation.add name Quotation.DynAst.patt_tag expand_patt; - Quotation.add name Quotation.DynAst.str_item_tag expand_str_item) - - let _ = - add_quotation "sig_item" sig_item_quot ME.meta_sig_item MP. - meta_sig_item - - let _ = - add_quotation "str_item" str_item_quot ME.meta_str_item MP. - meta_str_item - - let _ = add_quotation "ctyp" ctyp_quot ME.meta_ctyp MP.meta_ctyp - - let _ = add_quotation "patt" patt_quot ME.meta_patt MP.meta_patt - - let _ = add_quotation "expr" expr_quot ME.meta_expr MP.meta_expr - - let _ = - add_quotation "module_type" module_type_quot ME.meta_module_type - MP.meta_module_type - - let _ = - add_quotation "module_expr" module_expr_quot ME.meta_module_expr - MP.meta_module_expr - - let _ = - add_quotation "class_type" class_type_quot ME.meta_class_type MP. - meta_class_type - - let _ = - add_quotation "class_expr" class_expr_quot ME.meta_class_expr MP. - meta_class_expr - - let _ = - add_quotation "class_sig_item" class_sig_item_quot ME. - meta_class_sig_item MP.meta_class_sig_item - - let _ = - add_quotation "class_str_item" class_str_item_quot ME. - meta_class_str_item MP.meta_class_str_item - - let _ = - add_quotation "with_constr" with_constr_quot ME.meta_with_constr - MP.meta_with_constr - - let _ = - add_quotation "binding" binding_quot ME.meta_binding MP. - meta_binding - - let _ = - add_quotation "rec_binding" rec_binding_quot ME.meta_rec_binding - MP.meta_rec_binding - - let _ = - add_quotation "match_case" match_case_quot ME.meta_match_case MP. - meta_match_case - - let _ = - add_quotation "module_binding" module_binding_quot ME. - meta_module_binding MP.meta_module_binding - - let _ = add_quotation "ident" ident_quot ME.meta_ident MP.meta_ident - - let _ = - add_quotation "rec_flag" rec_flag_quot ME.meta_rec_flag MP. - meta_rec_flag - - let _ = - add_quotation "private_flag" private_flag_quot ME.meta_private_flag - MP.meta_private_flag - - let _ = - add_quotation "row_var_flag" row_var_flag_quot ME.meta_row_var_flag - MP.meta_row_var_flag - - let _ = - add_quotation "mutable_flag" mutable_flag_quot ME.meta_mutable_flag - MP.meta_mutable_flag - - let _ = - add_quotation "virtual_flag" virtual_flag_quot ME.meta_virtual_flag - MP.meta_virtual_flag - - let _ = - add_quotation "override_flag" override_flag_quot ME. - meta_override_flag MP.meta_override_flag - - let _ = - add_quotation "direction_flag" direction_flag_quot ME. - meta_direction_flag MP.meta_direction_flag - - end - - end - -module Q = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2002-2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - module Id = - struct - let name = "Camlp4QuotationExpander" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - module M = Camlp4QuotationCommon.Make(Syntax)(Syntax.AntiquotSyntax) - - include M - - end - - let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () - - end - -module Rp = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 1998-2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - module Id : Sig.Id = - struct - let name = "Camlp4OCamlRevisedParserParser" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - open Sig - - include Syntax - - type spat_comp = - | SpTrm of Loc.t * Ast.patt * Ast.expr option - | SpNtr of Loc.t * Ast.patt * Ast.expr - | SpStr of Loc.t * Ast.patt - - type sexp_comp = - | SeTrm of Loc.t * Ast.expr | SeNtr of Loc.t * Ast.expr - - let stream_expr = Gram.Entry.mk "stream_expr" - - let stream_begin = Gram.Entry.mk "stream_begin" - - let stream_end = Gram.Entry.mk "stream_end" - - let stream_quot = Gram.Entry.mk "stream_quot" - - let parser_case = Gram.Entry.mk "parser_case" - - let parser_case_list = Gram.Entry.mk "parser_case_list" - - let strm_n = "__strm" - - let peek_fun _loc = - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "peek"))))) - - let junk_fun _loc = - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "junk"))))) - - (* Parsers. *) - (* In syntax generated, many cases are optimisations. *) - let rec pattern_eq_expression p e = - match (p, e) with - | (Ast.PaId (_, (Ast.IdLid (_, a))), - Ast.ExId (_, (Ast.IdLid (_, b)))) -> a = b - | (Ast.PaId (_, (Ast.IdUid (_, a))), - Ast.ExId (_, (Ast.IdUid (_, b)))) -> a = b - | (Ast.PaApp (_, p1, p2), Ast.ExApp (_, e1, e2)) -> - (pattern_eq_expression p1 e1) && (pattern_eq_expression p2 e2) - | _ -> false - - let is_raise e = - match e with - | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "raise")))), _) -> - true - | _ -> false - - let is_raise_failure e = - match e with - | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "raise")))), - (Ast.ExId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), - (Ast.IdUid (_, "Failure"))))))) - -> true - | _ -> false - - let rec handle_failure e = - match e with - | Ast.ExTry (_, _, - (Ast.McArr (_, - (Ast.PaId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), - (Ast.IdUid (_, "Failure")))))), - (Ast.ExNil _), e))) - -> handle_failure e - | Ast.ExMat (_, me, a) -> - let rec match_case_handle_failure = - (function - | Ast.McOr (_, a1, a2) -> - (match_case_handle_failure a1) && - (match_case_handle_failure a2) - | Ast.McArr (_, _, (Ast.ExNil _), e) -> handle_failure e - | _ -> false) - in (handle_failure me) && (match_case_handle_failure a) - | Ast.ExLet (_, Ast.ReNil, bi, e) -> - let rec binding_handle_failure = - (function - | Ast.BiAnd (_, b1, b2) -> - (binding_handle_failure b1) && - (binding_handle_failure b2) - | Ast.BiEq (_, _, e) -> handle_failure e - | _ -> false) - in (binding_handle_failure bi) && (handle_failure e) - | Ast.ExId (_, (Ast.IdLid (_, _))) | Ast.ExInt (_, _) | - Ast.ExStr (_, _) | Ast.ExChr (_, _) | Ast.ExFun (_, _) | - Ast.ExId (_, (Ast.IdUid (_, _))) -> true - | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "raise")))), e) -> - (match e with - | Ast.ExId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), - (Ast.IdUid (_, "Failure"))))) - -> false - | _ -> true) - | Ast.ExApp (_, f, x) -> - (is_constr_apply f) && - ((handle_failure f) && (handle_failure x)) - | _ -> false - and is_constr_apply = - function - | Ast.ExId (_, (Ast.IdUid (_, _))) -> true - | Ast.ExId (_, (Ast.IdLid (_, _))) -> false - | Ast.ExApp (_, x, _) -> is_constr_apply x - | _ -> false - - let rec subst v e = - let _loc = Ast.loc_of_expr e - in - match e with - | Ast.ExId (_, (Ast.IdLid (_, x))) -> - let x = if x = v then strm_n else x - in Ast.ExId (_loc, (Ast.IdLid (_loc, x))) - | Ast.ExId (_, (Ast.IdUid (_, _))) -> e - | Ast.ExInt (_, _) -> e - | Ast.ExChr (_, _) -> e - | Ast.ExStr (_, _) -> e - | Ast.ExAcc (_, _, _) -> e - | Ast.ExLet (_, rf, bi, e) -> - Ast.ExLet (_loc, rf, (subst_binding v bi), (subst v e)) - | Ast.ExApp (_, e1, e2) -> - Ast.ExApp (_loc, (subst v e1), (subst v e2)) - | Ast.ExTup (_, e) -> Ast.ExTup (_loc, (subst v e)) - | Ast.ExCom (_, e1, e2) -> - Ast.ExCom (_loc, (subst v e1), (subst v e2)) - | _ -> raise Not_found - and subst_binding v = - function - | Ast.BiAnd (_loc, b1, b2) -> - Ast.BiAnd (_loc, (subst_binding v b1), (subst_binding v b2)) - | Ast.BiEq (_loc, (Ast.PaId (_, (Ast.IdLid (_, v')))), e) -> - Ast.BiEq (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, v')))), - (if v = v' then e else subst v e)) - | _ -> raise Not_found - - let stream_pattern_component skont ckont = - function - | SpTrm (_loc, p, None) -> - Ast.ExMat (_loc, - (Ast.ExApp (_loc, (peek_fun _loc), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - (Ast.McOr (_loc, - (Ast.McArr (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "Some")))), p)), - (Ast.ExNil _loc), - (Ast.ExSeq (_loc, - (Ast.ExSem (_loc, - (Ast.ExApp (_loc, (junk_fun _loc), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - skont)))))), - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - ckont))))) - | SpTrm (_loc, p, (Some w)) -> - Ast.ExMat (_loc, - (Ast.ExApp (_loc, (peek_fun _loc), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - (Ast.McOr (_loc, - (Ast.McArr (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "Some")))), p)), - w, - (Ast.ExSeq (_loc, - (Ast.ExSem (_loc, - (Ast.ExApp (_loc, (junk_fun _loc), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - skont)))))), - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - ckont))))) - | SpNtr (_loc, p, e) -> - let e = - (match e with - | Ast.ExFun (_, - (Ast.McArr (_, - (Ast.PaTyc (_, (Ast.PaId (_, (Ast.IdLid (_, v)))), - (Ast.TyApp (_, - (Ast.TyId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), - (Ast.IdLid (_, "t")))))), - (Ast.TyAny _))))), - (Ast.ExNil _), e))) - when v = strm_n -> e - | _ -> - Ast.ExApp (_loc, e, - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))) - in - if pattern_eq_expression p skont - then - if is_raise_failure ckont - then e - else - if handle_failure e - then e - else - Ast.ExTry (_loc, e, - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Failure")))))), - (Ast.ExNil _loc), ckont))) - else - if is_raise_failure ckont - then - Ast.ExLet (_loc, Ast.ReNil, (Ast.BiEq (_loc, p, e)), - skont) - else - if - pattern_eq_expression - (Ast.PaApp (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "Some")))), p)) - skont - then - Ast.ExTry (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), e)), - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Failure")))))), - (Ast.ExNil _loc), ckont))) - else - if is_raise ckont - then - (let tst = - if handle_failure e - then e - else - Ast.ExTry (_loc, e, - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Failure")))))), - (Ast.ExNil _loc), ckont))) - in - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, p, tst)), skont)) - else - Ast.ExMat (_loc, - (Ast.ExTry (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), - e)), - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Failure")))))), - (Ast.ExNil _loc), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "None")))))))), - (Ast.McOr (_loc, - (Ast.McArr (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "Some")))), - p)), - (Ast.ExNil _loc), skont)), - (Ast.McArr (_loc, (Ast.PaAny _loc), - (Ast.ExNil _loc), ckont))))) - | SpStr (_loc, p) -> - (try - match p with - | Ast.PaId (_, (Ast.IdLid (_, v))) -> subst v skont - | _ -> raise Not_found - with - | Not_found -> - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, p, - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - skont)) - - let rec stream_pattern _loc epo e ekont = - function - | [] -> - (match epo with - | Some ep -> - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, ep, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "count")))))), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))))), - e) - | _ -> e) - | (spc, err) :: spcl -> - let skont = - let ekont err = - let str = - (match err with - | Some estr -> estr - | _ -> Ast.ExStr (_loc, "")) - in - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, "raise")))), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Error")))))), - str))) - in stream_pattern _loc epo e ekont spcl in - let ckont = ekont err - in stream_pattern_component skont ckont spc - - let stream_patterns_term _loc ekont tspel = - let pel = - List.fold_right - (fun (p, w, _loc, spcl, epo, e) acc -> - let p = - Ast.PaApp (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "Some")))), p) in - let e = - let ekont err = - let str = - match err with - | Some estr -> estr - | _ -> Ast.ExStr (_loc, "") - in - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, "raise")))), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Error")))))), - str))) in - let skont = stream_pattern _loc epo e ekont spcl - in - Ast.ExSeq (_loc, - (Ast.ExSem (_loc, - (Ast.ExApp (_loc, (junk_fun _loc), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - skont))) - in - match w with - | Some w -> - Ast.McOr (_loc, (Ast.McArr (_loc, p, w, e)), acc) - | None -> - Ast.McOr (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), e)), acc)) - tspel (Ast.McNil _loc) - in - Ast.ExMat (_loc, - (Ast.ExApp (_loc, (peek_fun _loc), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - (Ast.McOr (_loc, pel, - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - (ekont ())))))) - - let rec group_terms = - function - | ((SpTrm (_loc, p, w), None) :: spcl, epo, e) :: spel -> - let (tspel, spel) = group_terms spel - in (((p, w, _loc, spcl, epo, e) :: tspel), spel) - | spel -> ([], spel) - - let rec parser_cases _loc = - function - | [] -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, "raise")))), - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Failure"))))))) - | spel -> - (match group_terms spel with - | ([], (spcl, epo, e) :: spel) -> - stream_pattern _loc epo e - (fun _ -> parser_cases _loc spel) spcl - | (tspel, spel) -> - stream_patterns_term _loc - (fun _ -> parser_cases _loc spel) tspel) - - let cparser _loc bpo pc = - let e = parser_cases _loc pc in - let e = - match bpo with - | Some bp -> - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, bp, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "count")))))), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))))), - e) - | None -> e in - let p = - Ast.PaTyc (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, strm_n)))), - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyAny _loc)))) - in Ast.ExFun (_loc, (Ast.McArr (_loc, p, (Ast.ExNil _loc), e))) - - let cparser_match _loc me bpo pc = - let pc = parser_cases _loc pc in - let e = - match bpo with - | Some bp -> - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, bp, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "count")))))), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))))), - pc) - | None -> pc in - let me = - match me with - | (Ast.ExSem (_loc, _, _) as e) -> Ast.ExSeq (_loc, e) - | e -> e - in - match me with - | Ast.ExId (_, (Ast.IdLid (_, x))) when x = strm_n -> e - | _ -> - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, - (Ast.PaTyc (_loc, - (Ast.PaId (_loc, (Ast.IdLid (_loc, strm_n)))), - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyAny _loc))))), - me)), - e) - - (* streams *) - let rec not_computing = - function - | Ast.ExId (_, (Ast.IdLid (_, _))) | - Ast.ExId (_, (Ast.IdUid (_, _))) | Ast.ExInt (_, _) | - Ast.ExFlo (_, _) | Ast.ExChr (_, _) | Ast.ExStr (_, _) -> true - | Ast.ExApp (_, x, y) -> - (is_cons_apply_not_computing x) && (not_computing y) - | _ -> false - and is_cons_apply_not_computing = - function - | Ast.ExId (_, (Ast.IdUid (_, _))) -> true - | Ast.ExId (_, (Ast.IdLid (_, _))) -> false - | Ast.ExApp (_, x, y) -> - (is_cons_apply_not_computing x) && (not_computing y) - | _ -> false - - let slazy _loc e = - match e with - | Ast.ExApp (_, f, (Ast.ExId (_, (Ast.IdUid (_, "()"))))) -> - (match f with - | Ast.ExId (_, (Ast.IdLid (_, _))) -> f - | _ -> - Ast.ExFun (_loc, - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), e)))) - | _ -> - Ast.ExFun (_loc, - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), e))) - - let rec cstream gloc = - function - | [] -> - let _loc = gloc - in - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "sempty"))))) - | [ SeTrm (_loc, e) ] -> - if not_computing e - then - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "ising")))))), - e) - else - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "lsing")))))), - (slazy _loc e)) - | SeTrm (_loc, e) :: secl -> - if not_computing e - then - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "icons")))))), - e)), - (cstream gloc secl)) - else - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "lcons")))))), - (slazy _loc e))), - (cstream gloc secl)) - | [ SeNtr (_loc, e) ] -> - if not_computing e - then e - else - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "slazy")))))), - (slazy _loc e)) - | SeNtr (_loc, e) :: secl -> - if not_computing e - then - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "iapp")))))), - e)), - (cstream gloc secl)) - else - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "lapp")))))), - (slazy _loc e))), - (cstream gloc secl)) - - (* Syntax extensions in Revised Syntax grammar *) - let _ = - let _ = (expr : 'expr Gram.Entry.t) - and _ = (parser_case_list : 'parser_case_list Gram.Entry.t) - and _ = (parser_case : 'parser_case Gram.Entry.t) - and _ = (stream_quot : 'stream_quot Gram.Entry.t) - and _ = (stream_end : 'stream_end Gram.Entry.t) - and _ = (stream_begin : 'stream_begin Gram.Entry.t) - and _ = (stream_expr : 'stream_expr Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let stream_patt : 'stream_patt Gram.Entry.t = - grammar_entry_create "stream_patt" - and stream_expr_comp : 'stream_expr_comp Gram.Entry.t = - grammar_entry_create "stream_expr_comp" - and stream_expr_comp_list : 'stream_expr_comp_list Gram.Entry.t = - grammar_entry_create "stream_expr_comp_list" - and parser_ipatt : 'parser_ipatt Gram.Entry.t = - grammar_entry_create "parser_ipatt" - and stream_patt_comp : 'stream_patt_comp Gram.Entry.t = - grammar_entry_create "stream_patt_comp" - and stream_patt_comp_err_list : - 'stream_patt_comp_err_list Gram.Entry.t = - grammar_entry_create "stream_patt_comp_err_list" - and stream_patt_comp_err : 'stream_patt_comp_err Gram.Entry.t = - grammar_entry_create "stream_patt_comp_err" - in - (Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "top")), - [ (None, None, - [ ([ Gram.Skeyword "match"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "with"; Gram.Skeyword "parser"; - Gram.Sopt - (Gram.Snterm - (Gram.Entry.obj - (parser_ipatt : - 'parser_ipatt Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (parser_case_list : - 'parser_case_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (pcl : 'parser_case_list) - (po : 'parser_ipatt option) _ _ - (e : 'sequence) _ (_loc : Gram.Loc.t) -> - (cparser_match _loc e po pcl : 'expr)))); - ([ Gram.Skeyword "parser"; - Gram.Sopt - (Gram.Snterm - (Gram.Entry.obj - (parser_ipatt : - 'parser_ipatt Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (parser_case_list : - 'parser_case_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (pcl : 'parser_case_list) - (po : 'parser_ipatt option) _ - (_loc : Gram.Loc.t) -> - (cparser _loc po pcl : 'expr)))) ]) ])) - ()); - Gram.extend (parser_case_list : 'parser_case_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (parser_case : 'parser_case Gram.Entry.t)) ], - (Gram.Action.mk - (fun (pc : 'parser_case) (_loc : Gram.Loc.t) -> - ([ pc ] : 'parser_case_list)))); - ([ Gram.Skeyword "["; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (parser_case : - 'parser_case Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (pcl : 'parser_case list) _ - (_loc : Gram.Loc.t) -> - (pcl : 'parser_case_list)))) ]) ])) - ()); - Gram.extend (parser_case : 'parser_case Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (stream_begin : 'stream_begin Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (stream_patt : 'stream_patt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (stream_end : 'stream_end Gram.Entry.t)); - Gram.Sopt - (Gram.Snterm - (Gram.Entry.obj - (parser_ipatt : - 'parser_ipatt Gram.Entry.t))); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (po : 'parser_ipatt option) _ - (sp : 'stream_patt) _ (_loc : Gram.Loc.t) -> - ((sp, po, e) : 'parser_case)))) ]) ])) - ()); - Gram.extend (stream_begin : 'stream_begin Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "[:" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'stream_begin)))) ]) ])) - ()); - Gram.extend (stream_end : 'stream_end Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword ":]" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> (() : 'stream_end)))) ]) ])) - ()); - Gram.extend (stream_quot : 'stream_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "`" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'stream_quot)))) ]) ])) - ()); - Gram.extend (stream_expr : 'stream_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (e : 'stream_expr)))) ]) ])) - ()); - Gram.extend (stream_patt : 'stream_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> ([] : 'stream_patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp : - 'stream_patt_comp Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp_err_list : - 'stream_patt_comp_err_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sp : 'stream_patt_comp_err_list) _ - (spc : 'stream_patt_comp) (_loc : Gram.Loc.t) - -> ((spc, None) :: sp : 'stream_patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp : - 'stream_patt_comp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (spc : 'stream_patt_comp) - (_loc : Gram.Loc.t) -> - ([ (spc, None) ] : 'stream_patt)))) ]) ])) - ()); - Gram.extend - (stream_patt_comp_err : 'stream_patt_comp_err Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp : - 'stream_patt_comp Gram.Entry.t)); - Gram.Sopt - (Gram.srules stream_patt_comp_err - [ ([ Gram.Skeyword "??"; - Gram.Snterm - (Gram.Entry.obj - (stream_expr : - 'stream_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'stream_expr) _ - (_loc : Gram.Loc.t) -> (e : 'e__14)))) ]) ], - (Gram.Action.mk - (fun (eo : 'e__14 option) - (spc : 'stream_patt_comp) (_loc : Gram.Loc.t) - -> ((spc, eo) : 'stream_patt_comp_err)))) ]) ])) - ()); - Gram.extend - (stream_patt_comp_err_list : - 'stream_patt_comp_err_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp_err : - 'stream_patt_comp_err Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (sp : 'stream_patt_comp_err_list) _ - (spc : 'stream_patt_comp_err) - (_loc : Gram.Loc.t) -> - (spc :: sp : 'stream_patt_comp_err_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp_err : - 'stream_patt_comp_err Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (spc : 'stream_patt_comp_err) - (_loc : Gram.Loc.t) -> - ([ spc ] : 'stream_patt_comp_err_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp_err : - 'stream_patt_comp_err Gram.Entry.t)) ], - (Gram.Action.mk - (fun (spc : 'stream_patt_comp_err) - (_loc : Gram.Loc.t) -> - ([ spc ] : 'stream_patt_comp_err_list)))) ]) ])) - ()); - Gram.extend (stream_patt_comp : 'stream_patt_comp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (SpStr (_loc, p) : 'stream_patt_comp)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (stream_expr : 'stream_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'stream_expr) _ (p : 'patt) - (_loc : Gram.Loc.t) -> - (SpNtr (_loc, p, e) : 'stream_patt_comp)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_quot : 'stream_quot Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Sopt - (Gram.srules stream_patt_comp - [ ([ Gram.Skeyword "when"; - Gram.Snterm - (Gram.Entry.obj - (stream_expr : - 'stream_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'stream_expr) _ - (_loc : Gram.Loc.t) -> (e : 'e__15)))) ]) ], - (Gram.Action.mk - (fun (eo : 'e__15 option) (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (SpTrm (_loc, p, eo) : 'stream_patt_comp)))) ]) ])) - ()); - Gram.extend (parser_ipatt : 'parser_ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.PaAny _loc : 'parser_ipatt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdLid (_loc, i))) : - 'parser_ipatt)))) ]) ])) - ()); - Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "simple")), - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (stream_begin : 'stream_begin Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (stream_expr_comp_list : - 'stream_expr_comp_list Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (stream_end : 'stream_end Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (sel : 'stream_expr_comp_list) _ - (_loc : Gram.Loc.t) -> - (cstream _loc sel : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_begin : 'stream_begin Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (stream_end : 'stream_end Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (cstream _loc [] : 'expr)))) ]) ])) - ()); - Gram.extend - (stream_expr_comp_list : 'stream_expr_comp_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (stream_expr_comp : - 'stream_expr_comp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (se : 'stream_expr_comp) - (_loc : Gram.Loc.t) -> - ([ se ] : 'stream_expr_comp_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_expr_comp : - 'stream_expr_comp Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (se : 'stream_expr_comp) - (_loc : Gram.Loc.t) -> - ([ se ] : 'stream_expr_comp_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_expr_comp : - 'stream_expr_comp Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (sel : 'stream_expr_comp_list) _ - (se : 'stream_expr_comp) (_loc : Gram.Loc.t) - -> (se :: sel : 'stream_expr_comp_list)))) ]) ])) - ()); - Gram.extend (stream_expr_comp : 'stream_expr_comp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (stream_expr : 'stream_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'stream_expr) (_loc : Gram.Loc.t) -> - (SeNtr (_loc, e) : 'stream_expr_comp)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_quot : 'stream_quot Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (stream_expr : 'stream_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'stream_expr) _ (_loc : Gram.Loc.t) -> - (SeTrm (_loc, e) : 'stream_expr_comp)))) ]) ])) - ())) - - end - - module M = Register.OCamlSyntaxExtension(Id)(Make) - - end - -module G = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2002-2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - module Id = - struct let name = "Camlp4GrammarParser" - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - open Sig - - include Syntax - - module MetaLoc = Ast.Meta.MetaGhostLoc - - module MetaAst = Ast.Meta.Make(MetaLoc) - - module PP = Camlp4.Printers.OCaml.Make(Syntax) - - let pp = new PP.printer ~comments: false () - - let string_of_patt patt = - let buf = Buffer.create 42 in - let () = Format.bprintf buf "%a@?" pp#patt patt in - let str = Buffer.contents buf - in if str = "" then assert false else str - - let split_ext = ref false - - type loc = Loc.t - - type 'e name = { expr : 'e; tvar : string; loc : loc } - - type styp = - | STlid of loc * string - | STapp of loc * styp * styp - | STquo of loc * string - | STself of loc * string - | STtok of loc - | STstring_tok of loc - | STtyp of Ast.ctyp - - type ('e, 'p) text = - | TXmeta of loc * string * (('e, 'p) text) list * 'e * styp - | TXlist of loc * bool * ('e, 'p) symbol * (('e, 'p) symbol) option - | TXnext of loc - | TXnterm of loc * 'e name * string option - | TXopt of loc * ('e, 'p) text - | TXtry of loc * ('e, 'p) text - | TXrules of loc * (((('e, 'p) text) list) * 'e) list - | TXself of loc - | TXkwd of loc * string - | TXtok of loc * 'e * string - and (** The first is the match function expr, - the second is the string description. - The description string will be used for - grammar insertion and left factoring. - Keep this string normalized and well comparable. *) - ('e, 'p) entry = - { name : 'e name; pos : 'e option; levels : (('e, 'p) level) list - } - and ('e, 'p) level = - { label : string option; assoc : 'e option; - rules : (('e, 'p) rule) list - } - and ('e, 'p) rule = - { prod : (('e, 'p) symbol) list; action : 'e option - } - and ('e, 'p) symbol = - { used : string list; text : ('e, 'p) text; styp : styp; - pattern : 'p option - } - - type used = | Unused | UsedScanned | UsedNotScanned - - let _loc = Loc.ghost - - let gm = "Camlp4Grammar__" - - let mark_used modif ht n = - try - let rll = Hashtbl.find_all ht n - in - List.iter - (fun (r, _) -> - if !r == Unused - then (r := UsedNotScanned; modif := true) - else ()) - rll - with | Not_found -> () - - let rec mark_symbol modif ht symb = - List.iter (fun e -> mark_used modif ht e) symb.used - - let check_use nl el = - let ht = Hashtbl.create 301 in - let modif = ref false - in - (List.iter - (fun e -> - let u = - match e.name.expr with - | Ast.ExId (_, (Ast.IdLid (_, _))) -> Unused - | _ -> UsedNotScanned - in Hashtbl.add ht e.name.tvar ((ref u), e)) - el; - List.iter - (fun n -> - try - let rll = Hashtbl.find_all ht n.tvar - in List.iter (fun (r, _) -> r := UsedNotScanned) rll - with | _ -> ()) - nl; - modif := true; - while !modif do modif := false; - Hashtbl.iter - (fun _ (r, e) -> - if !r = UsedNotScanned - then - (r := UsedScanned; - List.iter - (fun level -> - let rules = level.rules - in - List.iter - (fun rule -> - List.iter - (fun s -> mark_symbol modif ht s) - rule.prod) - rules) - e.levels) - else ()) - ht - done; - Hashtbl.iter - (fun s (r, e) -> - if !r = Unused - then - print_warning e.name.loc - ("Unused local entry \"" ^ (s ^ "\"")) - else ()) - ht) - - let new_type_var = - let i = ref 0 in fun () -> (incr i; "e__" ^ (string_of_int !i)) - - let used_of_rule_list rl = - List.fold_left - (fun nl r -> List.fold_left (fun nl s -> s.used @ nl) nl r.prod) - [] rl - - let retype_rule_list_without_patterns _loc rl = - try - List.map - (function - | (* ...; [ "foo" ]; ... ==> ...; (x = [ "foo" ] -> Gram.Token.extract_string x); ... *) - { - prod = [ ({ pattern = None; styp = STtok _ } as s) ]; - action = None - } -> - { - prod = - [ { - (s) - with - pattern = - Some (Ast.PaId (_loc, (Ast.IdLid (_loc, "x")))); - } ]; - action = - Some - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Token")), - (Ast.IdLid (_loc, "extract_string")))))))), - (Ast.ExId (_loc, (Ast.IdLid (_loc, "x")))))); - } - | (* ...; [ symb ]; ... ==> ...; (x = [ symb ] -> x); ... *) - { prod = [ ({ pattern = None } as s) ]; action = None } -> - { - prod = - [ { - (s) - with - pattern = - Some (Ast.PaId (_loc, (Ast.IdLid (_loc, "x")))); - } ]; - action = Some (Ast.ExId (_loc, (Ast.IdLid (_loc, "x")))); - } - | (* ...; ([] -> a); ... *) - ({ prod = []; action = Some _ } as r) -> r - | _ -> raise Exit) - rl - with | Exit -> rl - - let meta_action = ref false - - let mklistexp _loc = - let rec loop top = - function - | [] -> Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))) - | e1 :: el -> - let _loc = - if top then _loc else Loc.merge (Ast.loc_of_expr e1) _loc - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e1)), - (loop false el)) - in loop true - - let mklistpat _loc = - let rec loop top = - function - | [] -> Ast.PaId (_loc, (Ast.IdUid (_loc, "[]"))) - | p1 :: pl -> - let _loc = - if top then _loc else Loc.merge (Ast.loc_of_patt p1) _loc - in - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "::")))), p1)), - (loop false pl)) - in loop true - - let rec expr_fa al = - function - | Ast.ExApp (_, f, a) -> expr_fa (a :: al) f - | f -> (f, al) - - let rec make_ctyp styp tvar = - match styp with - | STlid (_loc, s) -> Ast.TyId (_loc, (Ast.IdLid (_loc, s))) - | STapp (_loc, t1, t2) -> - Ast.TyApp (_loc, (make_ctyp t1 tvar), (make_ctyp t2 tvar)) - | STquo (_loc, s) -> Ast.TyQuo (_loc, s) - | STself (_loc, x) -> - if tvar = "" - then - Loc.raise _loc - (Stream.Error - ("'" ^ (x ^ "' illegal in anonymous entry level"))) - else Ast.TyQuo (_loc, tvar) - | STtok _loc -> - Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Token")))), - (Ast.IdLid (_loc, "t"))))) - | STstring_tok _loc -> - Ast.TyId (_loc, (Ast.IdLid (_loc, "string"))) - | STtyp t -> t - - let make_ctyp_patt styp tvar patt = - let styp = - match styp with | STstring_tok _loc -> STtok _loc | t -> t - in - match make_ctyp styp tvar with - | Ast.TyAny _ -> patt - | t -> - let _loc = Ast.loc_of_patt patt in Ast.PaTyc (_loc, patt, t) - - let make_ctyp_expr styp tvar expr = - match make_ctyp styp tvar with - | Ast.TyAny _ -> expr - | t -> let _loc = Ast.loc_of_expr expr in Ast.ExTyc (_loc, expr, t) - - let text_of_action _loc psl rtvar act tvar = - let locid = Ast.PaId (_loc, (Ast.IdLid (_loc, !Loc.name))) in - let act = - match act with - | Some act -> act - | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) in - let (tok_match_pl, act, _) = - List.fold_left - (fun (((tok_match_pl, act, i) as accu)) -> - function - | { pattern = None } -> accu - | { pattern = Some p } when Ast.is_irrefut_patt p -> accu - | { - pattern = - Some - (Ast.PaAli (_, - (Ast.PaApp (_, _, (Ast.PaTup (_, (Ast.PaAny _))))), - (Ast.PaId (_, (Ast.IdLid (_, s)))))) - } -> - (tok_match_pl, - (Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, - (Ast.PaId (_loc, (Ast.IdLid (_loc, s)))), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Token")), - (Ast.IdLid (_loc, "extract_string")))))))), - (Ast.ExId (_loc, (Ast.IdLid (_loc, s)))))))), - act)), - i) - | { pattern = Some p; text = TXtok (_, _, _) } -> - let id = "__camlp4_" ^ (string_of_int i) - in - ((Some - (match tok_match_pl with - | None -> - ((Ast.ExId (_loc, (Ast.IdLid (_loc, id)))), - p) - | Some ((tok_pl, match_pl)) -> - ((Ast.ExCom (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, id)))), - tok_pl)), - (Ast.PaCom (_loc, p, match_pl))))), - act, (succ i)) - | _ -> accu) - (None, act, 0) psl in - let e = - let e1 = Ast.ExTyc (_loc, act, (Ast.TyQuo (_loc, rtvar))) in - let e2 = - match tok_match_pl with - | None -> e1 - | Some ((Ast.ExCom (_, t1, t2), Ast.PaCom (_, p1, p2))) -> - Ast.ExMat (_loc, - (Ast.ExTup (_loc, (Ast.ExCom (_loc, t1, t2)))), - (Ast.McOr (_loc, - (Ast.McArr (_loc, - (Ast.PaTup (_loc, (Ast.PaCom (_loc, p1, p2)))), - (Ast.ExNil _loc), e1)), - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - (Ast.ExAsf _loc)))))) - | Some ((tok, match_)) -> - Ast.ExMat (_loc, tok, - (Ast.McOr (_loc, - (Ast.McArr (_loc, match_, (Ast.ExNil _loc), e1)), - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - (Ast.ExAsf _loc)))))) - in - Ast.ExFun (_loc, - (Ast.McArr (_loc, - (Ast.PaTyc (_loc, locid, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Loc")))), - (Ast.IdLid (_loc, "t")))))))), - (Ast.ExNil _loc), e2))) in - let (txt, _) = - List.fold_left - (fun (txt, i) s -> - match s.pattern with - | None | Some (Ast.PaAny _) -> - ((Ast.ExFun (_loc, - (Ast.McArr (_loc, (Ast.PaAny _loc), - (Ast.ExNil _loc), txt)))), - i) - | Some - (Ast.PaAli (_, - (Ast.PaApp (_, _, (Ast.PaTup (_, (Ast.PaAny _))))), - p)) - -> - let p = make_ctyp_patt s.styp tvar p - in - ((Ast.ExFun (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), txt)))), - i) - | Some p when Ast.is_irrefut_patt p -> - let p = make_ctyp_patt s.styp tvar p - in - ((Ast.ExFun (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), txt)))), - i) - | Some _ -> - let p = - make_ctyp_patt s.styp tvar - (Ast.PaId (_loc, - (Ast.IdLid (_loc, - ("__camlp4_" ^ (string_of_int i)))))) - in - ((Ast.ExFun (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), txt)))), - (succ i))) - (e, 0) psl in - let txt = - if !meta_action - then - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Obj")), - (Ast.IdLid (_loc, "magic")))))), - (MetaAst.Expr.meta_expr _loc txt)) - else txt - in - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Action")), - (Ast.IdLid (_loc, "mk")))))))), - txt) - - let srules loc t rl tvar = - List.map - (fun r -> - let sl = List.map (fun s -> s.text) r.prod in - let ac = text_of_action loc r.prod t r.action tvar in (sl, ac)) - rl - - let rec make_expr entry tvar = - function - | TXmeta (_loc, n, tl, e, t) -> - let el = - List.fold_right - (fun t el -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), - (make_expr entry "" t))), - el)) - tl (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Smeta")))))), - (Ast.ExStr (_loc, n)))), - el)), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Action")), - (Ast.IdLid (_loc, "mk")))))))), - (make_ctyp_expr t tvar e)))) - | TXlist (_loc, min, t, ts) -> - let txt = make_expr entry "" t.text - in - (match (min, ts) with - | (false, None) -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Slist0")))))), - txt) - | (true, None) -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Slist1")))))), - txt) - | (false, Some s) -> - let x = make_expr entry tvar s.text - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Slist0sep")))))), - txt)), - x) - | (true, Some s) -> - let x = make_expr entry tvar s.text - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Slist1sep")))))), - txt)), - x)) - | TXnext _loc -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Snext"))))) - | TXnterm (_loc, n, lev) -> - (match lev with - | Some lab -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Snterml")))))), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Entry")), - (Ast.IdLid (_loc, "obj")))))))), - (Ast.ExTyc (_loc, n.expr, - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Entry")))), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyQuo (_loc, n.tvar)))))))))), - (Ast.ExStr (_loc, lab))) - | None -> - if n.tvar = tvar - then - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Sself"))))) - else - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Snterm")))))), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Entry")), - (Ast.IdLid (_loc, "obj")))))))), - (Ast.ExTyc (_loc, n.expr, - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Entry")))), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyQuo (_loc, n.tvar)))))))))) - | TXopt (_loc, t) -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Sopt")))))), - (make_expr entry "" t)) - | TXtry (_loc, t) -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Stry")))))), - (make_expr entry "" t)) - | TXrules (_loc, rl) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, "srules")))))), - entry.expr)), - (make_expr_rules _loc entry rl "")) - | TXself _loc -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Sself"))))) - | TXkwd (_loc, kwd) -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Skeyword")))))), - (Ast.ExStr (_loc, kwd))) - | TXtok (_loc, match_fun, descr) -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Stoken")))))), - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, match_fun, - (Ast.ExStr (_loc, (Ast.safe_string_escaped descr)))))))) - and make_expr_rules _loc n rl tvar = - List.fold_left - (fun txt (sl, ac) -> - let sl = - List.fold_right - (fun t txt -> - let x = make_expr n tvar t - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), x)), - txt)) - sl (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), - (Ast.ExTup (_loc, (Ast.ExCom (_loc, sl, ac)))))), - txt)) - (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) rl - - let expr_of_delete_rule _loc n sl = - let sl = - List.fold_right - (fun s e -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), - (make_expr n "" s.text))), - e)) - sl (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) - in ((n.expr), sl) - - let rec tvar_of_ident = - function - | Ast.IdLid (_, x) | Ast.IdUid (_, x) -> x - | Ast.IdAcc (_, (Ast.IdUid (_, x)), xs) -> - x ^ ("__" ^ (tvar_of_ident xs)) - | _ -> failwith "internal error in the Grammar extension" - - let mk_name _loc i = - { expr = Ast.ExId (_loc, i); tvar = tvar_of_ident i; loc = _loc; } - - let slist loc min sep symb = TXlist (loc, min, symb, sep) - - (* - value sstoken _loc s = - let n = mk_name _loc <:ident< $lid:"a_" ^ s$ >> in - TXnterm _loc n None - ; - - value mk_symbol p s t = - {used = []; text = s; styp = t; pattern=Some p}; - - value sslist _loc min sep s = - let rl = - let r1 = - let prod = - let n = mk_name _loc <:ident< a_list >> in - [mk_symbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_list")] - in - let act = <:expr< a >> in - {prod = prod; action = Some act} - in - let r2 = - let prod = - [mk_symbol <:patt< a >> (slist _loc min sep s) - (STapp _loc (STlid _loc "list") s.styp)] - in - let act = <:expr< Qast.List a >> in - {prod = prod; action = Some act} - in - [r1; r2] - in - let used = - match sep with - [ Some symb -> symb.used @ s.used - | None -> s.used ] - in - let used = ["a_list" :: used] in - let text = TXrules _loc (srules _loc "a_list" rl "") in - let styp = STquo _loc "a_list" in - {used = used; text = text; styp = styp; pattern = None} - ; - - value ssopt _loc s = - let rl = - let r1 = - let prod = - let n = mk_name _loc <:ident< a_opt >> in - [mk_symbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_opt")] - in - let act = <:expr< a >> in - {prod = prod; action = Some act} - in - let r2 = - let s = - match s.text with - [ TXkwd _loc _ | TXtok _loc _ _ -> - let rl = - [{prod = [{ (s) with pattern = Some <:patt< x >> }]; - action = Some <:expr< Qast.Str (Token.extract_string x) >>}] - in - let t = new_type_var () in - {used = []; text = TXrules _loc (srules _loc t rl ""); - styp = STquo _loc t; pattern = None} - | _ -> s ] - in - let prod = - [mk_symbol <:patt< a >> (TXopt _loc s.text) - (STapp _loc (STlid _loc "option") s.styp)] - in - let act = <:expr< Qast.Option a >> in - {prod = prod; action = Some act} - in - [r1; r2] - in - let used = ["a_opt" :: s.used] in - let text = TXrules _loc (srules _loc "a_opt" rl "") in - let styp = STquo _loc "a_opt" in - {used = used; text = text; styp = styp; pattern = None} - ; - *) - let text_of_entry _loc e = - let ent = - let x = e.name in - let _loc = e.name.loc - in - Ast.ExTyc (_loc, x.expr, - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Entry")))), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyQuo (_loc, x.tvar))))) in - let pos = - match e.pos with - | Some pos -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), pos) - | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "None"))) in - let txt = - List.fold_right - (fun level txt -> - let lab = - match level.label with - | Some lab -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), - (Ast.ExStr (_loc, lab))) - | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "None"))) in - let ass = - match level.assoc with - | Some ass -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), ass) - | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "None"))) in - let txt = - let rl = - srules _loc e.name.tvar level.rules e.name.tvar in - let e = make_expr_rules _loc e.name rl e.name.tvar - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, lab, - (Ast.ExCom (_loc, ass, e)))))))), - txt) - in txt) - e.levels (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) - in (ent, pos, txt) - - let let_in_of_extend _loc gram gl el args = - match gl with - | None -> args - | Some nl -> - (check_use nl el; - let ll = - let same_tvar e n = e.name.tvar = n.tvar - in - List.fold_right - (fun e ll -> - match e.name.expr with - | Ast.ExId (_, (Ast.IdLid (_, _))) -> - if List.exists (same_tvar e) nl - then ll - else - if List.exists (same_tvar e) ll - then ll - else e.name :: ll - | _ -> ll) - el [] in - let local_binding_of_name { expr = e; tvar = x; loc = _loc } = - let i = - (match e with - | Ast.ExId (_, (Ast.IdLid (_, i))) -> i - | _ -> failwith "internal error in the Grammar extension") - in - Ast.BiEq (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, i)))), - (Ast.ExTyc (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "grammar_entry_create")))), - (Ast.ExStr (_loc, i)))), - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Entry")))), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyQuo (_loc, x))))))) in - let expr_of_name { expr = e; tvar = x; loc = _loc } = - Ast.ExTyc (_loc, e, - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Entry")))), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyQuo (_loc, x))))) in - let e = - (match ll with - | [] -> args - | x :: xs -> - let locals = - List.fold_right - (fun name acc -> - Ast.BiAnd (_loc, acc, - (local_binding_of_name name))) - xs (local_binding_of_name x) in - let entry_mk = - (match gram with - | Some g -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Entry")), - (Ast.IdLid (_loc, "mk")))))))), - (Ast.ExId (_loc, g))) - | None -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Entry")), - (Ast.IdLid (_loc, "mk")))))))) - in - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, - (Ast.PaId (_loc, - (Ast.IdLid (_loc, "grammar_entry_create")))), - entry_mk)), - (Ast.ExLet (_loc, Ast.ReNil, locals, args)))) - in - (match nl with - | [] -> e - | x :: xs -> - let globals = - List.fold_right - (fun name acc -> - Ast.BiAnd (_loc, acc, - (Ast.BiEq (_loc, (Ast.PaAny _loc), - (expr_of_name name))))) - xs - (Ast.BiEq (_loc, (Ast.PaAny _loc), - (expr_of_name x))) - in Ast.ExLet (_loc, Ast.ReNil, globals, e))) - - class subst gmod = - object inherit Ast.map as super - method ident = - function - | Ast.IdUid (_, x) when x = gm -> gmod - | x -> super#ident x - end - - let subst_gmod ast gmod = (new subst gmod)#expr ast - - let text_of_functorial_extend _loc gmod gram gl el = - let args = - let el = - List.map - (fun e -> - let (ent, pos, txt) = text_of_entry e.name.loc e in - let e = - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, "extend")))))), - ent)), - (Ast.ExApp (_loc, - (Ast.ExFun (_loc, - (Ast.McArr (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "()")))), - (Ast.ExNil _loc), - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, pos, txt)))))))), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))))))) - in - if !split_ext - then - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, - (Ast.PaId (_loc, (Ast.IdLid (_loc, "aux")))), - (Ast.ExFun (_loc, - (Ast.McArr (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "()")))), - (Ast.ExNil _loc), e)))))), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, "aux")))), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))))))) - else e) - el - in - match el with - | [] -> Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) - | [ e ] -> e - | e :: el -> - Ast.ExSeq (_loc, - (List.fold_left (fun acc x -> Ast.ExSem (_loc, acc, x)) e - el)) - in subst_gmod (let_in_of_extend _loc gram gl el args) gmod - - let wildcarder = - object (self) - inherit Ast.map as super - method patt = - function - | Ast.PaId (_loc, (Ast.IdLid (_, _))) -> Ast.PaAny _loc - | Ast.PaAli (_, p, _) -> self#patt p - | p -> super#patt p - end - - let mk_tok _loc p t = - let p' = wildcarder#patt p in - let match_fun = - if Ast.is_irrefut_patt p' - then - Ast.ExFun (_loc, - (Ast.McArr (_loc, p', (Ast.ExNil _loc), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "True"))))))) - else - Ast.ExFun (_loc, - (Ast.McOr (_loc, - (Ast.McArr (_loc, p', (Ast.ExNil _loc), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "True")))))), - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))))))))) in - let descr = string_of_patt p' in - let text = TXtok (_loc, match_fun, descr) - in { used = []; text = text; styp = t; pattern = Some p; } - - let symbol = Gram.Entry.mk "symbol" - - let check_not_tok s = - match s with - | { text = TXtok (_loc, _, _) } -> - Loc.raise _loc - (Stream.Error - ("Deprecated syntax, use a sub rule. " ^ - "LIST0 STRING becomes LIST0 [ x = STRING -> x ]")) - | _ -> () - - let _ = Camlp4_config.antiquotations := true - - let _ = - let _ = (expr : 'expr Gram.Entry.t) - and _ = (symbol : 'symbol Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let extend_header : 'extend_header Gram.Entry.t = - grammar_entry_create "extend_header" - and semi_sep : 'semi_sep Gram.Entry.t = - grammar_entry_create "semi_sep" - and string : 'string Gram.Entry.t = grammar_entry_create "string" - and name : 'name Gram.Entry.t = grammar_entry_create "name" - and comma_patt : 'comma_patt Gram.Entry.t = - grammar_entry_create "comma_patt" - and pattern : 'pattern Gram.Entry.t = - grammar_entry_create "pattern" - and psymbol : 'psymbol Gram.Entry.t = - grammar_entry_create "psymbol" - and rule : 'rule Gram.Entry.t = grammar_entry_create "rule" - and rule_list : 'rule_list Gram.Entry.t = - grammar_entry_create "rule_list" - and assoc : 'assoc Gram.Entry.t = grammar_entry_create "assoc" - and level : 'level Gram.Entry.t = grammar_entry_create "level" - and level_list : 'level_list Gram.Entry.t = - grammar_entry_create "level_list" - and position : 'position Gram.Entry.t = - grammar_entry_create "position" - and entry : 'entry Gram.Entry.t = grammar_entry_create "entry" - and global : 'global Gram.Entry.t = grammar_entry_create "global" - and t_qualid : 't_qualid Gram.Entry.t = - grammar_entry_create "t_qualid" - and qualid : 'qualid Gram.Entry.t = grammar_entry_create "qualid" - and qualuid : 'qualuid Gram.Entry.t = - grammar_entry_create "qualuid" - and delete_rule_body : 'delete_rule_body Gram.Entry.t = - grammar_entry_create "delete_rule_body" - and extend_body : 'extend_body Gram.Entry.t = - grammar_entry_create "extend_body" - in - (Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.After "top")), - [ (None, None, - [ ([ Gram.Skeyword "GEXTEND" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Loc.raise _loc - (Stream.Error - "Deprecated syntax, use EXTEND MyGramModule ... END instead") : - 'expr)))); - ([ Gram.Skeyword "GDELETE_RULE" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Loc.raise _loc - (Stream.Error - "Deprecated syntax, use DELETE_RULE MyGramModule ... END instead") : - 'expr)))); - ([ Gram.Skeyword "DELETE_RULE"; - Gram.Snterm - (Gram.Entry.obj - (delete_rule_body : - 'delete_rule_body Gram.Entry.t)); - Gram.Skeyword "END" ], - (Gram.Action.mk - (fun _ (e : 'delete_rule_body) _ - (_loc : Gram.Loc.t) -> (e : 'expr)))); - ([ Gram.Skeyword "EXTEND"; - Gram.Snterm - (Gram.Entry.obj - (extend_body : 'extend_body Gram.Entry.t)); - Gram.Skeyword "END" ], - (Gram.Action.mk - (fun _ (e : 'extend_body) _ (_loc : Gram.Loc.t) - -> (e : 'expr)))) ]) ])) - ()); - Gram.extend (extend_header : 'extend_header Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (qualuid : 'qualuid Gram.Entry.t)) ], - (Gram.Action.mk - (fun (g : 'qualuid) (_loc : Gram.Loc.t) -> - ((None, g) : 'extend_header)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj (qualid : 'qualid Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (t_qualid : 't_qualid Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 't_qualid) _ (i : 'qualid) _ - (_loc : Gram.Loc.t) -> - (((Some i), t) : 'extend_header)))) ]) ])) - ()); - Gram.extend (extend_body : 'extend_body Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (extend_header : - 'extend_header Gram.Entry.t)); - Gram.Sopt - (Gram.Snterm - (Gram.Entry.obj - (global : 'global Gram.Entry.t))); - Gram.Slist1 - (Gram.srules extend_body - [ ([ Gram.Snterm - (Gram.Entry.obj - (entry : 'entry Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi_sep : - 'semi_sep Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (e : 'entry) - (_loc : Gram.Loc.t) -> (e : 'e__16)))) ]) ], - (Gram.Action.mk - (fun (el : 'e__16 list) - (global_list : 'global option) - ((gram, g) : 'extend_header) - (_loc : Gram.Loc.t) -> - (text_of_functorial_extend _loc g gram - global_list el : - 'extend_body)))) ]) ])) - ()); - Gram.extend (delete_rule_body : 'delete_rule_body Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (qualuid : 'qualuid Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (name : 'name Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (symbol : 'symbol Gram.Entry.t))), - (Gram.Snterm - (Gram.Entry.obj - (semi_sep : 'semi_sep Gram.Entry.t)))) ], - (Gram.Action.mk - (fun (sl : 'symbol list) _ (n : 'name) - (g : 'qualuid) (_loc : Gram.Loc.t) -> - (let (e, b) = expr_of_delete_rule _loc n sl - in - subst_gmod - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, - "delete_rule")))))), - e)), - b)) - g : - 'delete_rule_body)))) ]) ])) - ()); - Gram.extend (qualuid : 'qualuid Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.srules qualuid - [ ([ Gram.Stoken - (((function - | UIDENT "GLOBAL" -> true - | _ -> false), - "UIDENT \"GLOBAL\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "GLOBAL" -> (() : 'e__17) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | LIDENT ((_)) -> true - | _ -> false), - "LIDENT ((_))")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT ((_)) -> (() : 'e__17) - | _ -> assert false))) ] ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Loc.raise _loc - (Stream.Error - "Deprecated syntax, the grammar module is expected") : - 'qualuid)))) ]); - (None, None, - [ ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")) ], - (Gram.Action.mk - (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i - in Ast.IdUid (_loc, i) : 'qualuid)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (xs : 'qualuid) _ (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let x = Gram.Token.extract_string x - in - Ast.IdAcc (_loc, (Ast.IdUid (_loc, x)), - xs) : - 'qualuid)))) ]) ])) - ()); - Gram.extend (qualuid : 'qualuid Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.srules qualuid - [ ([ Gram.Stoken - (((function - | UIDENT "GLOBAL" -> true - | _ -> false), - "UIDENT \"GLOBAL\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "GLOBAL" -> (() : 'e__18) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | LIDENT ((_)) -> true - | _ -> false), - "LIDENT ((_))")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT ((_)) -> (() : 'e__18) - | _ -> assert false))) ] ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Loc.raise _loc - (Stream.Error - "Deprecated syntax, the grammar module is expected") : - 'qualuid)))) ]); - (None, None, - [ ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")) ], - (Gram.Action.mk - (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i - in Ast.IdUid (_loc, i) : 'qualuid)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (xs : 'qualuid) _ (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let x = Gram.Token.extract_string x - in - Ast.IdAcc (_loc, (Ast.IdUid (_loc, x)), - xs) : - 'qualuid)))) ]) ])) - ()); - Gram.extend (qualid : 'qualid Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | LIDENT ((_)) -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i - in Ast.IdLid (_loc, i) : 'qualid)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")) ], - (Gram.Action.mk - (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i - in Ast.IdUid (_loc, i) : 'qualid)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (xs : 'qualid) _ (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let x = Gram.Token.extract_string x - in - Ast.IdAcc (_loc, (Ast.IdUid (_loc, x)), - xs) : - 'qualid)))) ]) ])) - ()); - Gram.extend (t_qualid : 't_qualid Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | LIDENT _ | UIDENT _ -> true - | _ -> false), - "LIDENT _ | UIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT _ | UIDENT _ -> - (Loc.raise _loc - (Stream.Error - ("Wrong EXTEND header, the grammar type must finish by 't', " - ^ - "like in EXTEND (g : Gram.t) ... END")) : - 't_qualid) - | _ -> assert false))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Skeyword "."; - Gram.Stoken - (((function | LIDENT "t" -> true | _ -> false), - "LIDENT \"t\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (x : Gram.Token.t) (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT "t" -> - (let x = Gram.Token.extract_string x - in Ast.IdUid (_loc, x) : 't_qualid) - | _ -> assert false))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (xs : 't_qualid) _ (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let x = Gram.Token.extract_string x - in - Ast.IdAcc (_loc, (Ast.IdUid (_loc, x)), - xs) : - 't_qualid)))) ]) ])) - ()); - Gram.extend (global : 'global Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT "GLOBAL" -> true - | _ -> false), - "UIDENT \"GLOBAL\"")); - Gram.Skeyword ":"; - Gram.Slist1 - (Gram.Snterm - (Gram.Entry.obj (name : 'name Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (semi_sep : 'semi_sep Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (sl : 'name list) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "GLOBAL" -> (sl : 'global) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (entry : 'entry Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (name : 'name Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Sopt - (Gram.Snterm - (Gram.Entry.obj - (position : 'position Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (level_list : 'level_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ll : 'level_list) (pos : 'position option) - _ (n : 'name) (_loc : Gram.Loc.t) -> - ({ name = n; pos = pos; levels = ll; } : - 'entry)))) ]) ])) - ()); - Gram.extend (position : 'position Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT "LEVEL" -> true - | _ -> false), - "UIDENT \"LEVEL\"")); - Gram.Snterm - (Gram.Entry.obj (string : 'string Gram.Entry.t)) ], - (Gram.Action.mk - (fun (n : 'string) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LEVEL" -> - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, - "Grammar")), - (Ast.IdUid (_loc, "Level")))))))))), - n) : - 'position) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "AFTER" -> true - | _ -> false), - "UIDENT \"AFTER\"")); - Gram.Snterm - (Gram.Entry.obj (string : 'string Gram.Entry.t)) ], - (Gram.Action.mk - (fun (n : 'string) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "AFTER" -> - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, - "Grammar")), - (Ast.IdUid (_loc, "After")))))))))), - n) : - 'position) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "BEFORE" -> true - | _ -> false), - "UIDENT \"BEFORE\"")); - Gram.Snterm - (Gram.Entry.obj (string : 'string Gram.Entry.t)) ], - (Gram.Action.mk - (fun (n : 'string) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "BEFORE" -> - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, - "Grammar")), - (Ast.IdUid (_loc, - "Before")))))))))), - n) : - 'position) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "LAST" -> true - | _ -> false), - "UIDENT \"LAST\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LAST" -> - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Grammar")), - (Ast.IdUid (_loc, "Last"))))))))) : - 'position) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "FIRST" -> true - | _ -> false), - "UIDENT \"FIRST\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "FIRST" -> - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Grammar")), - (Ast.IdUid (_loc, "First"))))))))) : - 'position) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (level_list : 'level_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "["; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (level : 'level Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (ll : 'level list) _ (_loc : Gram.Loc.t) - -> (ll : 'level_list)))) ]) ])) - ()); - Gram.extend (level : 'level Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Sopt - (Gram.srules level - [ ([ Gram.Stoken - (((function - | STRING ((_)) -> true - | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let x = - Gram.Token.extract_string x - in x : 'e__19)))) ]); - Gram.Sopt - (Gram.Snterm - (Gram.Entry.obj - (assoc : 'assoc Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (rule_list : 'rule_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (rules : 'rule_list) (ass : 'assoc option) - (lab : 'e__19 option) (_loc : Gram.Loc.t) -> - ({ label = lab; assoc = ass; rules = rules; } : - 'level)))) ]) ])) - ()); - Gram.extend (assoc : 'assoc Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT "NONA" -> true - | _ -> false), - "UIDENT \"NONA\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "NONA" -> - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Grammar")), - (Ast.IdUid (_loc, "NonA"))))))))) : - 'assoc) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "RIGHTA" -> true - | _ -> false), - "UIDENT \"RIGHTA\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "RIGHTA" -> - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Grammar")), - (Ast.IdUid (_loc, "RightA"))))))))) : - 'assoc) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "LEFTA" -> true - | _ -> false), - "UIDENT \"LEFTA\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LEFTA" -> - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Grammar")), - (Ast.IdUid (_loc, "LeftA"))))))))) : - 'assoc) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (rule_list : 'rule_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "["; - Gram.Slist1sep - ((Gram.Snterm - (Gram.Entry.obj (rule : 'rule Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rules : 'rule list) _ - (_loc : Gram.Loc.t) -> - (retype_rule_list_without_patterns _loc rules : - 'rule_list)))); - ([ Gram.Skeyword "["; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - ([] : 'rule_list)))) ]) ])) - ()); - Gram.extend (rule : 'rule Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (psymbol : 'psymbol Gram.Entry.t))), - (Gram.Snterm - (Gram.Entry.obj - (semi_sep : 'semi_sep Gram.Entry.t)))) ], - (Gram.Action.mk - (fun (psl : 'psymbol list) (_loc : Gram.Loc.t) - -> ({ prod = psl; action = None; } : 'rule)))); - ([ Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (psymbol : 'psymbol Gram.Entry.t))), - (Gram.Snterm - (Gram.Entry.obj - (semi_sep : 'semi_sep Gram.Entry.t)))); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (act : 'expr) _ (psl : 'psymbol list) - (_loc : Gram.Loc.t) -> - ({ prod = psl; action = Some act; } : 'rule)))) ]) ])) - ()); - Gram.extend (psymbol : 'psymbol Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'symbol) (_loc : Gram.Loc.t) -> - (s : 'psymbol)))); - ([ Gram.Snterm - (Gram.Entry.obj - (pattern : 'pattern Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'symbol) _ (p : 'pattern) - (_loc : Gram.Loc.t) -> - (match s.pattern with - | Some - (Ast.PaApp (_, - (Ast.PaId (_, (Ast.IdUid (_, u)))), - (Ast.PaTup (_, (Ast.PaAny _))))) - -> - mk_tok _loc - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, u)))), - p)) - s.styp - | _ -> { (s) with pattern = Some p; } : - 'psymbol)))); - ([ Gram.Stoken - (((function | LIDENT ((_)) -> true | _ -> false), - "LIDENT _")); - Gram.Sopt - (Gram.srules psymbol - [ ([ Gram.Stoken - (((function - | UIDENT "LEVEL" -> true - | _ -> false), - "UIDENT \"LEVEL\"")); - Gram.Stoken - (((function - | STRING ((_)) -> true - | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (s : Gram.Token.t) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LEVEL" -> - (let s = - Gram.Token.extract_string s - in s : 'e__20) - | _ -> assert false))) ]) ], - (Gram.Action.mk - (fun (lev : 'e__20 option) (i : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i in - let name = - mk_name _loc (Ast.IdLid (_loc, i)) in - let text = TXnterm (_loc, name, lev) in - let styp = STquo (_loc, i) - in - { - used = [ i ]; - text = text; - styp = styp; - pattern = None; - } : - 'psymbol)))); - ([ Gram.Stoken - (((function | LIDENT ((_)) -> true | _ -> false), - "LIDENT _")); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'symbol) _ (p : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let p = Gram.Token.extract_string p - in - match s.pattern with - | Some - ((Ast.PaApp (_, - (Ast.PaId (_, (Ast.IdUid (_, u)))), - (Ast.PaTup (_, (Ast.PaAny _)))) - as p')) - -> - let match_fun = - Ast.ExFun (_loc, - (Ast.McOr (_loc, - (Ast.McArr (_loc, p', - (Ast.ExNil _loc), - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "True")))))), - (Ast.McArr (_loc, - (Ast.PaAny _loc), - (Ast.ExNil _loc), - (Ast.ExId (_loc, - (Ast.IdUid (_loc, - "False"))))))))) in - let p' = - Ast.PaAli (_loc, p', - (Ast.PaId (_loc, - (Ast.IdLid (_loc, p))))) in - let descr = u ^ " _" in - let text = - TXtok (_loc, match_fun, descr) - in - { - (s) - with - text = text; - pattern = Some p'; - } - | _ -> - { - (s) - with - pattern = - Some - (Ast.PaId (_loc, - (Ast.IdLid (_loc, p)))); - } : - 'psymbol)))) ]) ])) - ()); - Gram.extend (symbol : 'symbol Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Stoken - (((function | UIDENT "TRY" -> true | _ -> false), - "UIDENT \"TRY\"")); - Gram.Sself ], - (Gram.Action.mk - (fun (s : 'symbol) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "TRY" -> - (let text = TXtry (_loc, s.text) - in - { - used = s.used; - text = text; - styp = s.styp; - pattern = None; - } : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function | UIDENT "OPT" -> true | _ -> false), - "UIDENT \"OPT\"")); - Gram.Sself ], - (Gram.Action.mk - (fun (s : 'symbol) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "OPT" -> - (let () = check_not_tok s in - let styp = - STapp (_loc, (STlid (_loc, "option")), - s.styp) in - let text = TXopt (_loc, s.text) - in - { - used = s.used; - text = text; - styp = styp; - pattern = None; - } : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "LIST1" -> true - | _ -> false), - "UIDENT \"LIST1\"")); - Gram.Sself; - Gram.Sopt - (Gram.srules symbol - [ ([ Gram.Stoken - (((function - | UIDENT "SEP" -> true - | _ -> false), - "UIDENT \"SEP\"")); - Gram.Snterm - (Gram.Entry.obj - (symbol : 'symbol Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'symbol) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "SEP" -> (t : 'e__22) - | _ -> assert false))) ]) ], - (Gram.Action.mk - (fun (sep : 'e__22 option) (s : 'symbol) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LIST1" -> - (let () = check_not_tok s in - let used = - (match sep with - | Some symb -> symb.used @ s.used - | None -> s.used) in - let styp = - STapp (_loc, (STlid (_loc, "list")), - s.styp) in - let text = slist _loc true sep s - in - { - used = used; - text = text; - styp = styp; - pattern = None; - } : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "LIST0" -> true - | _ -> false), - "UIDENT \"LIST0\"")); - Gram.Sself; - Gram.Sopt - (Gram.srules symbol - [ ([ Gram.Stoken - (((function - | UIDENT "SEP" -> true - | _ -> false), - "UIDENT \"SEP\"")); - Gram.Snterm - (Gram.Entry.obj - (symbol : 'symbol Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'symbol) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "SEP" -> (t : 'e__21) - | _ -> assert false))) ]) ], - (Gram.Action.mk - (fun (sep : 'e__21 option) (s : 'symbol) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LIST0" -> - (let () = check_not_tok s in - let used = - (match sep with - | Some symb -> symb.used @ s.used - | None -> s.used) in - let styp = - STapp (_loc, (STlid (_loc, "list")), - s.styp) in - let text = slist _loc false sep s - in - { - used = used; - text = text; - styp = styp; - pattern = None; - } : - 'symbol) - | _ -> assert false))) ]); - (None, None, - [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (s_t : 'symbol) _ (_loc : Gram.Loc.t) -> - (s_t : 'symbol)))); - ([ Gram.Snterm - (Gram.Entry.obj (name : 'name Gram.Entry.t)); - Gram.Sopt - (Gram.srules symbol - [ ([ Gram.Stoken - (((function - | UIDENT "LEVEL" -> true - | _ -> false), - "UIDENT \"LEVEL\"")); - Gram.Stoken - (((function - | STRING ((_)) -> true - | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (s : Gram.Token.t) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LEVEL" -> - (let s = - Gram.Token.extract_string s - in s : 'e__24) - | _ -> assert false))) ]) ], - (Gram.Action.mk - (fun (lev : 'e__24 option) (n : 'name) - (_loc : Gram.Loc.t) -> - ({ - used = [ n.tvar ]; - text = TXnterm (_loc, n, lev); - styp = STquo (_loc, n.tvar); - pattern = None; - } : 'symbol)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Skeyword "."; - Gram.Snterm - (Gram.Entry.obj (qualid : 'qualid Gram.Entry.t)); - Gram.Sopt - (Gram.srules symbol - [ ([ Gram.Stoken - (((function - | UIDENT "LEVEL" -> true - | _ -> false), - "UIDENT \"LEVEL\"")); - Gram.Stoken - (((function - | STRING ((_)) -> true - | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (s : Gram.Token.t) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LEVEL" -> - (let s = - Gram.Token.extract_string s - in s : 'e__23) - | _ -> assert false))) ]) ], - (Gram.Action.mk - (fun (lev : 'e__23 option) (il : 'qualid) _ - (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i in - let n = - mk_name _loc - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, i)), - il)) - in - { - used = [ n.tvar ]; - text = TXnterm (_loc, n, lev); - styp = STquo (_loc, n.tvar); - pattern = None; - } : - 'symbol)))); - ([ Gram.Stoken - (((function | STRING ((_)) -> true | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (s : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let s = Gram.Token.extract_string s - in - { - used = []; - text = TXkwd (_loc, s); - styp = STtok _loc; - pattern = None; - } : - 'symbol)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (x : Gram.Token.t) (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ("", s) -> - (let x = Gram.Token.extract_string x in - let e = - AntiquotSyntax.parse_expr _loc s in - let match_fun = - Ast.ExFun (_loc, - (Ast.McOr (_loc, - (Ast.McArr (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, x)))), - (Ast.PaId (_loc, - (Ast.IdLid (_loc, - "camlp4_x")))))), - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, - "=")))), - (Ast.ExId (_loc, - (Ast.IdLid (_loc, - "camlp4_x")))))), - e)), - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "True")))))), - (Ast.McArr (_loc, - (Ast.PaAny _loc), - (Ast.ExNil _loc), - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "False"))))))))) in - let descr = "$" ^ (x ^ (" " ^ s)) in - let text = - TXtok (_loc, match_fun, descr) in - let p = - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, x)))), - (Ast.PaTup (_loc, (Ast.PaAny _loc)))) - in - { - used = []; - text = text; - styp = STtok _loc; - pattern = Some p; - } : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Stoken - (((function | STRING ((_)) -> true | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (s : Gram.Token.t) (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let s = Gram.Token.extract_string s in - let x = Gram.Token.extract_string x - in - mk_tok _loc - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, x)))), - (Ast.PaStr (_loc, s)))) - (STtok _loc) : - 'symbol)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")) ], - (Gram.Action.mk - (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let x = Gram.Token.extract_string x - in - mk_tok _loc - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, x)))), - (Ast.PaTup (_loc, (Ast.PaAny _loc))))) - (STstring_tok _loc) : - 'symbol)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) _ (_loc : Gram.Loc.t) -> - (mk_tok _loc p (STtok _loc) : 'symbol)))); - ([ Gram.Skeyword "["; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj (rule : 'rule Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rl : 'rule list) _ (_loc : Gram.Loc.t) - -> - (let rl = - retype_rule_list_without_patterns _loc rl in - let t = new_type_var () - in - { - used = used_of_rule_list rl; - text = - TXrules (_loc, (srules _loc t rl "")); - styp = STquo (_loc, t); - pattern = None; - } : - 'symbol)))); - ([ Gram.Stoken - (((function - | UIDENT "NEXT" -> true - | _ -> false), - "UIDENT \"NEXT\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "NEXT" -> - ({ - used = []; - text = TXnext _loc; - styp = STself (_loc, "NEXT"); - pattern = None; - } : 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "SELF" -> true - | _ -> false), - "UIDENT \"SELF\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "SELF" -> - ({ - used = []; - text = TXself _loc; - styp = STself (_loc, "SELF"); - pattern = None; - } : 'symbol) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (pattern : 'pattern Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_patt : 'comma_patt Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p2 : 'comma_patt) _ (p1 : 'pattern) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTup (_loc, (Ast.PaCom (_loc, p1, p2))) : - 'pattern)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'pattern) _ (_loc : Gram.Loc.t) -> - (p : 'pattern)))); - ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.PaAny _loc : 'pattern)))); - ([ Gram.Stoken - (((function | LIDENT ((_)) -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i - in Ast.PaId (_loc, (Ast.IdLid (_loc, i))) : - 'pattern)))) ]) ])) - ()); - Gram.extend (comma_patt : 'comma_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (pattern : 'pattern Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'pattern) (_loc : Gram.Loc.t) -> - (p : 'comma_patt)))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'comma_patt) _ (p1 : 'comma_patt) - (_loc : Gram.Loc.t) -> - (Ast.PaCom (_loc, p1, p2) : 'comma_patt)))) ]) ])) - ()); - Gram.extend (name : 'name Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (qualid : 'qualid Gram.Entry.t)) ], - (Gram.Action.mk - (fun (il : 'qualid) (_loc : Gram.Loc.t) -> - (mk_name _loc il : 'name)))) ]) ])) - ()); - Gram.extend (string : 'string Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ("", s) -> - (AntiquotSyntax.parse_expr _loc s : - 'string) - | _ -> assert false))); - ([ Gram.Stoken - (((function | STRING ((_)) -> true | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (s : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let s = Gram.Token.extract_string s - in Ast.ExStr (_loc, s) : 'string)))) ]) ])) - ()); - Gram.extend (semi_sep : 'semi_sep Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> (() : 'semi_sep)))) ]) ])) - ())) - - (* - EXTEND Gram - symbol: LEVEL "top" - [ NONA - [ min = [ UIDENT "SLIST0" -> False | UIDENT "SLIST1" -> True ]; - s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> - sslist _loc min sep s - | UIDENT "SOPT"; s = SELF -> - ssopt _loc s ] ] - ; - END; - *) - let sfold _loc n foldfun f e s = - let styp = STquo (_loc, (new_type_var ())) in - let e = - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, foldfun)))))), - f)), - e) in - let t = - STapp (_loc, - (STapp (_loc, - (STtyp - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, "fold")))))), - (Ast.TyAny _loc)))), - s.styp)), - styp) - in - { - used = s.used; - text = TXmeta (_loc, n, [ s.text ], e, t); - styp = styp; - pattern = None; - } - - let sfoldsep _loc n foldfun f e s sep = - let styp = STquo (_loc, (new_type_var ())) in - let e = - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, foldfun)))))), - f)), - e) in - let t = - STapp (_loc, - (STapp (_loc, - (STtyp - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, "foldsep")))))), - (Ast.TyAny _loc)))), - s.styp)), - styp) - in - { - used = s.used @ sep.used; - text = TXmeta (_loc, n, [ s.text; sep.text ], e, t); - styp = styp; - pattern = None; - } - - let _ = - let _ = (symbol : 'symbol Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let simple_expr : 'simple_expr Gram.Entry.t = - grammar_entry_create "simple_expr" - in - (Gram.extend (symbol : 'symbol Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "top")), - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT "FOLD1" -> true - | _ -> false), - "UIDENT \"FOLD1\"")); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Sself; - Gram.Stoken - (((function | UIDENT "SEP" -> true | _ -> false), - "UIDENT \"SEP\"")); - Gram.Sself ], - (Gram.Action.mk - (fun (sep : 'symbol) (__camlp4_1 : Gram.Token.t) - (s : 'symbol) (e : 'simple_expr) - (f : 'simple_expr) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match (__camlp4_1, __camlp4_0) with - | (UIDENT "SEP", UIDENT "FOLD1") -> - (sfoldsep _loc "FOLD1 SEP" "sfold1sep" f - e s sep : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "FOLD0" -> true - | _ -> false), - "UIDENT \"FOLD0\"")); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Sself; - Gram.Stoken - (((function | UIDENT "SEP" -> true | _ -> false), - "UIDENT \"SEP\"")); - Gram.Sself ], - (Gram.Action.mk - (fun (sep : 'symbol) (__camlp4_1 : Gram.Token.t) - (s : 'symbol) (e : 'simple_expr) - (f : 'simple_expr) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match (__camlp4_1, __camlp4_0) with - | (UIDENT "SEP", UIDENT "FOLD0") -> - (sfoldsep _loc "FOLD0 SEP" "sfold0sep" f - e s sep : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "FOLD1" -> true - | _ -> false), - "UIDENT \"FOLD1\"")); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (s : 'symbol) (e : 'simple_expr) - (f : 'simple_expr) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "FOLD1" -> - (sfold _loc "FOLD1" "sfold1" f e s : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "FOLD0" -> true - | _ -> false), - "UIDENT \"FOLD0\"")); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (s : 'symbol) (e : 'simple_expr) - (f : 'simple_expr) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "FOLD0" -> - (sfold _loc "FOLD0" "sfold0" f e s : - 'symbol) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (simple_expr : 'simple_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) -> - (e : 'simple_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdLid (_loc, i))) : - 'simple_expr)))) ]) ])) - ())) - - let _ = - Options.add "-split_ext" (Arg.Set split_ext) - "Split EXTEND by functions to turn around a PowerPC problem." - - let _ = - Options.add "-split_gext" (Arg.Set split_ext) - "Old name for the option -split_ext." - - let _ = - Options.add "-meta_action" (Arg.Set meta_action) "Undocumented" - - end - - (* FIXME *) - module M = Register.OCamlSyntaxExtension(Id)(Make) - - end - -module M = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - * - Aleksey Nogin: extra features and bug fixes. - * - Christopher Conway: extra feature (-D=) - * - Jean-vincent Loddo: definitions inside IFs. - *) - module Id = - struct let name = "Camlp4MacroParser" - let version = Sys.ocaml_version - - end - - (* -Added statements: - - At toplevel (structure item): - - DEFINE - DEFINE = - DEFINE () = - IFDEF THEN [ ELSE ] (END | ENDIF) - IFNDEF THEN [ ELSE ] (END | ENDIF) - INCLUDE - - At toplevel (signature item): - - DEFINE - IFDEF THEN [ ELSE ] (END | ENDIF) - IFNDEF THEN [ ELSE ] (END | ENDIF) - INCLUDE - - In expressions: - - IFDEF THEN [ ELSE ] (END | ENDIF) - IFNDEF THEN [ ELSE ] (END | ENDIF) - DEFINE = IN - __FILE__ - __LOCATION__ - LOCATION_OF - - In patterns: - - IFDEF THEN ELSE (END | ENDIF) - IFNDEF THEN ELSE (END | ENDIF) - - As Camlp4 options: - - -D or -D=expr define with optional value - -U undefine it - -I add to the search path for INCLUDE'd files - - After having used a DEFINE followed by "= ", you - can use it in expressions *and* in patterns. If the expression defining - the macro cannot be used as a pattern, there is an error message if - it is used in a pattern. - - You can also define a local macro in an expression usigng the DEFINE ... IN form. - Note that local macros have lowercase names and can not take parameters. - - If a macro is defined to = NOTHING, and then used as an argument to a function, - this will be equivalent to function taking one less argument. Similarly, - passing NOTHING as an argument to a macro is equivalent to "erasing" the - corresponding parameter from the macro body. - - The toplevel statement INCLUDE can be used to include a - file containing macro definitions and also any other toplevel items. - The included files are looked up in directories passed in via the -I - option, falling back to the current directory. - - The expression __FILE__ returns the current compiled file name. - The expression __LOCATION__ returns the current location of itself. - If used inside a macro, it returns the location where the macro is - called. - The expression (LOCATION_OF parameter) returns the location of the given - macro parameter. It cannot be used outside a macro definition. - -*) - open Camlp4 - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - open Sig - - include Syntax - - type 'a item_or_def = - | SdStr of 'a - | SdDef of string * ((string list) * Ast.expr) option - | SdUnd of string - | SdITE of bool * ('a item_or_def) list * ('a item_or_def) list - | SdLazy of 'a Lazy.t - - let rec list_remove x = - function - | (y, _) :: l when y = x -> l - | d :: l -> d :: (list_remove x l) - | [] -> [] - - let defined = ref [] - - let is_defined i = List.mem_assoc i !defined - - let bad_patt _loc = - Loc.raise _loc - (Failure - "this macro cannot be used in a pattern (see its definition)") - - let substp _loc env = - let rec loop = - function - | Ast.ExApp (_, e1, e2) -> Ast.PaApp (_loc, (loop e1), (loop e2)) - | Ast.ExNil _ -> Ast.PaNil _loc - | Ast.ExId (_, (Ast.IdLid (_, x))) -> - (try List.assoc x env - with | Not_found -> Ast.PaId (_loc, (Ast.IdLid (_loc, x)))) - | Ast.ExId (_, (Ast.IdUid (_, x))) -> - (try List.assoc x env - with | Not_found -> Ast.PaId (_loc, (Ast.IdUid (_loc, x)))) - | Ast.ExInt (_, x) -> Ast.PaInt (_loc, x) - | Ast.ExStr (_, s) -> Ast.PaStr (_loc, s) - | Ast.ExTup (_, x) -> Ast.PaTup (_loc, (loop x)) - | Ast.ExCom (_, x1, x2) -> Ast.PaCom (_loc, (loop x1), (loop x2)) - | Ast.ExRec (_, bi, (Ast.ExNil _)) -> - let rec substbi = - (function - | Ast.RbSem (_, b1, b2) -> - Ast.PaSem (_loc, (substbi b1), (substbi b2)) - | Ast.RbEq (_, i, e) -> Ast.PaEq (_loc, i, (loop e)) - | _ -> bad_patt _loc) - in Ast.PaRec (_loc, (substbi bi)) - | _ -> bad_patt _loc - in loop - - class reloc _loc = - object inherit Ast.map as super method loc = fun _ -> _loc end - - (* method _Loc_t _ = _loc; *) - class subst _loc env = - object inherit reloc _loc as super - method expr = - function - | (Ast.ExId (_, (Ast.IdLid (_, x))) | - Ast.ExId (_, (Ast.IdUid (_, x))) - as e) -> - (try List.assoc x env with | Not_found -> super#expr e) - | (Ast.ExApp (_loc, - (Ast.ExId (_, (Ast.IdUid (_, "LOCATION_OF")))), - (Ast.ExId (_, (Ast.IdLid (_, x))))) | - Ast.ExApp (_loc, - (Ast.ExId (_, (Ast.IdUid (_, "LOCATION_OF")))), - (Ast.ExId (_, (Ast.IdUid (_, x))))) - as e) -> - (try - let loc = Ast.loc_of_expr (List.assoc x env) in - let (a, b, c, d, e, f, g, h) = Loc.to_tuple loc - in - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), - (Ast.IdLid (_loc, "of_tuple")))))), - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, - (Ast.ExStr (_loc, (Ast.safe_string_escaped a))), - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExInt (_loc, - (string_of_int b))), - (Ast.ExInt (_loc, - (string_of_int c))))), - (Ast.ExInt (_loc, - (string_of_int d))))), - (Ast.ExInt (_loc, - (string_of_int e))))), - (Ast.ExInt (_loc, (string_of_int f))))), - (Ast.ExInt (_loc, (string_of_int g))))), - (if h - then - Ast.ExId (_loc, - (Ast.IdUid (_loc, "True"))) - else - Ast.ExId (_loc, - (Ast.IdUid (_loc, "False"))))))))))) - with | Not_found -> super#expr e) - | e -> super#expr e - method patt = - function - | (Ast.PaId (_, (Ast.IdLid (_, x))) | - Ast.PaId (_, (Ast.IdUid (_, x))) - as p) -> - (try substp _loc [] (List.assoc x env) - with | Not_found -> super#patt p) - | p -> super#patt p - end - - let incorrect_number loc l1 l2 = - Loc.raise loc - (Failure - (Printf.sprintf "expected %d parameters; found %d" - (List.length l2) (List.length l1))) - - let define eo x = - ((match eo with - | Some (([], e)) -> - (Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "simple")), - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> - true - | _ -> false), - "$UIDENT x")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT ((_)) -> - ((new reloc _loc)#expr e : 'expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (patt : 'patt Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "simple")), - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> - true - | _ -> false), - "$UIDENT x")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT ((_)) -> - (let p = substp _loc [] e - in (new reloc _loc)#patt p : 'patt) - | _ -> assert false))) ]) ])) - ())) - | Some ((sl, e)) -> - (Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "apply")), - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> - true - | _ -> false), - "$UIDENT x")); - Gram.Sself ], - (Gram.Action.mk - (fun (param : 'expr) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT ((_)) -> - (let el = - (match param with - | Ast.ExTup (_, e) -> - Ast.list_of_expr e [] - | e -> [ e ]) - in - if - (List.length el) = - (List.length sl) - then - (let env = List.combine sl el - in (new subst _loc env)#expr e) - else incorrect_number _loc el sl : - 'expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (patt : 'patt Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "simple")), - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> - true - | _ -> false), - "$UIDENT x")); - Gram.Sself ], - (Gram.Action.mk - (fun (param : 'patt) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT ((_)) -> - (let pl = - (match param with - | Ast.PaTup (_, p) -> - Ast.list_of_patt p [] - | p -> [ p ]) - in - if - (List.length pl) = - (List.length sl) - then - (let env = List.combine sl pl in - let p = substp _loc env e - in (new reloc _loc)#patt p) - else incorrect_number _loc pl sl : - 'patt) - | _ -> assert false))) ]) ])) - ())) - | None -> ()); - defined := (x, eo) :: !defined) - - let undef x = - try - ((let eo = List.assoc x !defined - in - match eo with - | Some (([], _)) -> - (Gram.delete_rule expr - [ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> true - | _ -> false), - "$UIDENT x")) ]; - Gram.delete_rule patt - [ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> true - | _ -> false), - "$UIDENT x")) ]) - | Some ((_, _)) -> - (Gram.delete_rule expr - [ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> true - | _ -> false), - "$UIDENT x")); - Gram.Sself ]; - Gram.delete_rule patt - [ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> true - | _ -> false), - "$UIDENT x")); - Gram.Sself ]) - | None -> ()); - defined := list_remove x !defined) - with | Not_found -> () - - let parse_def s = - match Gram.parse_string expr (Loc.mk "") s with - | Ast.ExId (_, (Ast.IdUid (_, n))) -> define None n - | Ast.ExApp (_, - (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "=")))), - (Ast.ExId (_, (Ast.IdUid (_, n)))))), - e) -> define (Some (([], e))) n - | _ -> invalid_arg s - - (* This is a list of directories to search for INCLUDE statements. *) - let include_dirs = ref [] - - (* Add something to the above, make sure it ends with a slash. *) - let add_include_dir str = - if str <> "" - then - (let str = - if (String.get str ((String.length str) - 1)) = '/' - then str - else str ^ "/" - in include_dirs := !include_dirs @ [ str ]) - else () - - let parse_include_file rule = - let dir_ok file dir = Sys.file_exists (dir ^ file) - in - fun file -> - let file = - try - (List.find (dir_ok file) (!include_dirs @ [ "./" ])) ^ file - with | Not_found -> file in - let ch = open_in file in - let st = Stream.of_channel ch - in Gram.parse rule (Loc.mk file) st - - let rec execute_macro nil cons = - function - | SdStr i -> i - | SdDef (x, eo) -> (define eo x; nil) - | SdUnd x -> (undef x; nil) - | SdITE (b, l1, l2) -> - execute_macro_list nil cons (if b then l1 else l2) - | SdLazy l -> Lazy.force l - and execute_macro_list nil cons = - function - | [] -> nil - | hd :: tl -> (* The evaluation order is important here *) - let il1 = execute_macro nil cons hd in - let il2 = execute_macro_list nil cons tl in cons il1 il2 - - (* Stack of conditionals. *) - let stack = Stack.create () - - (* Make an SdITE value by extracting the result of the test from the stack. *) - let make_SdITE_result st1 st2 = - let test = Stack.pop stack in SdITE (test, st1, st2) - - type branch = | Then | Else - - (* Execute macro only if it belongs to the currently active branch. *) - let execute_macro_if_active_branch _loc nil cons branch macro_def = - let test = Stack.top stack in - let item = - if (test && (branch = Then)) || ((not test) && (branch = Else)) - then execute_macro nil cons macro_def - else (* ignore the macro *) nil - in SdStr item - - let _ = - let _ = (expr : 'expr Gram.Entry.t) - and _ = (sig_item : 'sig_item Gram.Entry.t) - and _ = (str_item : 'str_item Gram.Entry.t) - and _ = (patt : 'patt Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let macro_def : 'macro_def Gram.Entry.t = - grammar_entry_create "macro_def" - and uident : 'uident Gram.Entry.t = grammar_entry_create "uident" - and opt_macro_value : 'opt_macro_value Gram.Entry.t = - grammar_entry_create "opt_macro_value" - and endif : 'endif Gram.Entry.t = grammar_entry_create "endif" - and sglist_else : 'sglist_else Gram.Entry.t = - grammar_entry_create "sglist_else" - and sglist_then : 'sglist_then Gram.Entry.t = - grammar_entry_create "sglist_then" - and smlist_else : 'smlist_else Gram.Entry.t = - grammar_entry_create "smlist_else" - and smlist_then : 'smlist_then Gram.Entry.t = - grammar_entry_create "smlist_then" - and else_expr : 'else_expr Gram.Entry.t = - grammar_entry_create "else_expr" - and else_macro_def_sig : 'else_macro_def_sig Gram.Entry.t = - grammar_entry_create "else_macro_def_sig" - and else_macro_def : 'else_macro_def Gram.Entry.t = - grammar_entry_create "else_macro_def" - and uident_eval_ifndef : 'uident_eval_ifndef Gram.Entry.t = - grammar_entry_create "uident_eval_ifndef" - and uident_eval_ifdef : 'uident_eval_ifdef Gram.Entry.t = - grammar_entry_create "uident_eval_ifdef" - and macro_def_sig : 'macro_def_sig Gram.Entry.t = - grammar_entry_create "macro_def_sig" - in - (Gram.extend (str_item : 'str_item Gram.Entry.t) - ((fun () -> - ((Some Camlp4.Sig.Grammar.First), - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (macro_def : 'macro_def Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'macro_def) (_loc : Gram.Loc.t) -> - (execute_macro (Ast.StNil _loc) - (fun a b -> Ast.StSem (_loc, a, b)) x : - 'str_item)))) ]) ])) - ()); - Gram.extend (sig_item : 'sig_item Gram.Entry.t) - ((fun () -> - ((Some Camlp4.Sig.Grammar.First), - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (macro_def_sig : - 'macro_def_sig Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'macro_def_sig) (_loc : Gram.Loc.t) -> - (execute_macro (Ast.SgNil _loc) - (fun a b -> Ast.SgSem (_loc, a, b)) x : - 'sig_item)))) ]) ])) - ()); - Gram.extend (macro_def : 'macro_def Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "INCLUDE"; - Gram.Stoken - (((function | STRING ((_)) -> true | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (fname : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - (let fname = Gram.Token.extract_string fname - in - SdLazy - (lazy - (parse_include_file str_items fname)) : - 'macro_def)))); - ([ Gram.Skeyword "IFNDEF"; - Gram.Snterm - (Gram.Entry.obj - (uident_eval_ifndef : - 'uident_eval_ifndef Gram.Entry.t)); - Gram.Skeyword "THEN"; - Gram.Snterm - (Gram.Entry.obj - (smlist_then : 'smlist_then Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (else_macro_def : - 'else_macro_def Gram.Entry.t)) ], - (Gram.Action.mk - (fun (st2 : 'else_macro_def) - (st1 : 'smlist_then) _ _ _ - (_loc : Gram.Loc.t) -> - (make_SdITE_result st1 st2 : 'macro_def)))); - ([ Gram.Skeyword "IFDEF"; - Gram.Snterm - (Gram.Entry.obj - (uident_eval_ifdef : - 'uident_eval_ifdef Gram.Entry.t)); - Gram.Skeyword "THEN"; - Gram.Snterm - (Gram.Entry.obj - (smlist_then : 'smlist_then Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (else_macro_def : - 'else_macro_def Gram.Entry.t)) ], - (Gram.Action.mk - (fun (st2 : 'else_macro_def) - (st1 : 'smlist_then) _ _ _ - (_loc : Gram.Loc.t) -> - (make_SdITE_result st1 st2 : 'macro_def)))); - ([ Gram.Skeyword "UNDEF"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'uident) _ (_loc : Gram.Loc.t) -> - (SdUnd i : 'macro_def)))); - ([ Gram.Skeyword "DEFINE"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_macro_value : - 'opt_macro_value Gram.Entry.t)) ], - (Gram.Action.mk - (fun (def : 'opt_macro_value) (i : 'uident) _ - (_loc : Gram.Loc.t) -> - (SdDef (i, def) : 'macro_def)))) ]) ])) - ()); - Gram.extend (macro_def_sig : 'macro_def_sig Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "INCLUDE"; - Gram.Stoken - (((function | STRING ((_)) -> true | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (fname : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - (let fname = Gram.Token.extract_string fname - in - SdLazy - (lazy - (parse_include_file sig_items fname)) : - 'macro_def_sig)))); - ([ Gram.Skeyword "IFNDEF"; - Gram.Snterm - (Gram.Entry.obj - (uident_eval_ifndef : - 'uident_eval_ifndef Gram.Entry.t)); - Gram.Skeyword "THEN"; - Gram.Snterm - (Gram.Entry.obj - (sglist_then : 'sglist_then Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (else_macro_def_sig : - 'else_macro_def_sig Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sg2 : 'else_macro_def_sig) - (sg1 : 'sglist_then) _ _ _ - (_loc : Gram.Loc.t) -> - (make_SdITE_result sg1 sg2 : 'macro_def_sig)))); - ([ Gram.Skeyword "IFDEF"; - Gram.Snterm - (Gram.Entry.obj - (uident_eval_ifdef : - 'uident_eval_ifdef Gram.Entry.t)); - Gram.Skeyword "THEN"; - Gram.Snterm - (Gram.Entry.obj - (sglist_then : 'sglist_then Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (else_macro_def_sig : - 'else_macro_def_sig Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sg2 : 'else_macro_def_sig) - (sg1 : 'sglist_then) _ _ _ - (_loc : Gram.Loc.t) -> - (make_SdITE_result sg1 sg2 : 'macro_def_sig)))); - ([ Gram.Skeyword "UNDEF"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'uident) _ (_loc : Gram.Loc.t) -> - (SdUnd i : 'macro_def_sig)))); - ([ Gram.Skeyword "DEFINE"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'uident) _ (_loc : Gram.Loc.t) -> - (SdDef (i, None) : 'macro_def_sig)))) ]) ])) - ()); - Gram.extend - (uident_eval_ifdef : 'uident_eval_ifdef Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'uident) (_loc : Gram.Loc.t) -> - (Stack.push (is_defined i) stack : - 'uident_eval_ifdef)))) ]) ])) - ()); - Gram.extend - (uident_eval_ifndef : 'uident_eval_ifndef Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'uident) (_loc : Gram.Loc.t) -> - (Stack.push (not (is_defined i)) stack : - 'uident_eval_ifndef)))) ]) ])) - ()); - Gram.extend (else_macro_def : 'else_macro_def Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - ([] : 'else_macro_def)))); - ([ Gram.Skeyword "ELSE"; - Gram.Snterm - (Gram.Entry.obj - (smlist_else : 'smlist_else Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (st : 'smlist_else) _ (_loc : Gram.Loc.t) - -> (st : 'else_macro_def)))) ]) ])) - ()); - Gram.extend - (else_macro_def_sig : 'else_macro_def_sig Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - ([] : 'else_macro_def_sig)))); - ([ Gram.Skeyword "ELSE"; - Gram.Snterm - (Gram.Entry.obj - (sglist_else : 'sglist_else Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (st : 'sglist_else) _ (_loc : Gram.Loc.t) - -> (st : 'else_macro_def_sig)))) ]) ])) - ()); - Gram.extend (else_expr : 'else_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'else_expr)))); - ([ Gram.Skeyword "ELSE"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) -> - (e : 'else_expr)))) ]) ])) - ()); - Gram.extend (smlist_then : 'smlist_then Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist1 - (Gram.srules smlist_then - [ ([ Gram.Snterm - (Gram.Entry.obj - (str_item : - 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (si : 'str_item) - (_loc : Gram.Loc.t) -> - (SdStr si : 'e__25)))); - ([ Gram.Snterm - (Gram.Entry.obj - (macro_def : - 'macro_def Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (d : 'macro_def) - (_loc : Gram.Loc.t) -> - (execute_macro_if_active_branch - _loc (Ast.StNil _loc) - (fun a b -> - Ast.StSem (_loc, a, b)) - Then d : - 'e__25)))) ]) ], - (Gram.Action.mk - (fun (sml : 'e__25 list) (_loc : Gram.Loc.t) -> - (sml : 'smlist_then)))) ]) ])) - ()); - Gram.extend (smlist_else : 'smlist_else Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist1 - (Gram.srules smlist_else - [ ([ Gram.Snterm - (Gram.Entry.obj - (str_item : - 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (si : 'str_item) - (_loc : Gram.Loc.t) -> - (SdStr si : 'e__26)))); - ([ Gram.Snterm - (Gram.Entry.obj - (macro_def : - 'macro_def Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (d : 'macro_def) - (_loc : Gram.Loc.t) -> - (execute_macro_if_active_branch - _loc (Ast.StNil _loc) - (fun a b -> - Ast.StSem (_loc, a, b)) - Else d : - 'e__26)))) ]) ], - (Gram.Action.mk - (fun (sml : 'e__26 list) (_loc : Gram.Loc.t) -> - (sml : 'smlist_else)))) ]) ])) - ()); - Gram.extend (sglist_then : 'sglist_then Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist1 - (Gram.srules sglist_then - [ ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : - 'sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (si : 'sig_item) - (_loc : Gram.Loc.t) -> - (SdStr si : 'e__27)))); - ([ Gram.Snterm - (Gram.Entry.obj - (macro_def_sig : - 'macro_def_sig Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (d : 'macro_def_sig) - (_loc : Gram.Loc.t) -> - (execute_macro_if_active_branch - _loc (Ast.SgNil _loc) - (fun a b -> - Ast.SgSem (_loc, a, b)) - Then d : - 'e__27)))) ]) ], - (Gram.Action.mk - (fun (sgl : 'e__27 list) (_loc : Gram.Loc.t) -> - (sgl : 'sglist_then)))) ]) ])) - ()); - Gram.extend (sglist_else : 'sglist_else Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist1 - (Gram.srules sglist_else - [ ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : - 'sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (si : 'sig_item) - (_loc : Gram.Loc.t) -> - (SdStr si : 'e__28)))); - ([ Gram.Snterm - (Gram.Entry.obj - (macro_def_sig : - 'macro_def_sig Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (d : 'macro_def_sig) - (_loc : Gram.Loc.t) -> - (execute_macro_if_active_branch - _loc (Ast.SgNil _loc) - (fun a b -> - Ast.SgSem (_loc, a, b)) - Else d : - 'e__28)))) ]) ], - (Gram.Action.mk - (fun (sgl : 'e__28 list) (_loc : Gram.Loc.t) -> - (sgl : 'sglist_else)))) ]) ])) - ()); - Gram.extend (endif : 'endif Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "ENDIF" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> (() : 'endif)))); - ([ Gram.Skeyword "END" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> (() : 'endif)))) ]) ])) - ()); - Gram.extend (opt_macro_value : 'opt_macro_value Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (None : 'opt_macro_value)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (Some (([], e)) : 'opt_macro_value)))); - ([ Gram.Skeyword "("; - Gram.Slist1sep - ((Gram.srules opt_macro_value - [ ([ Gram.Stoken - (((function - | LIDENT ((_)) -> true - | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let x = - Gram.Token.extract_string x - in x : 'e__29)))) ]), - (Gram.Skeyword ",")); - Gram.Skeyword ")"; Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ _ (pl : 'e__29 list) _ - (_loc : Gram.Loc.t) -> - (Some ((pl, e)) : 'opt_macro_value)))) ]) ])) - ()); - Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "top")), - [ (None, None, - [ ([ Gram.Skeyword "DEFINE"; - Gram.Stoken - (((function | LIDENT ((_)) -> true | _ -> false), - "LIDENT _")); - Gram.Skeyword "="; Gram.Sself; - Gram.Skeyword "IN"; Gram.Sself ], - (Gram.Action.mk - (fun (body : 'expr) _ (def : 'expr) _ - (i : Gram.Token.t) _ (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i - in (new subst _loc [ (i, def) ])#expr body : - 'expr)))); - ([ Gram.Skeyword "IFNDEF"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); - Gram.Skeyword "THEN"; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (else_expr : 'else_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e2 : 'else_expr) (e1 : 'expr) _ - (i : 'uident) _ (_loc : Gram.Loc.t) -> - (if is_defined i then e2 else e1 : 'expr)))); - ([ Gram.Skeyword "IFDEF"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); - Gram.Skeyword "THEN"; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (else_expr : 'else_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e2 : 'else_expr) (e1 : 'expr) _ - (i : 'uident) _ (_loc : Gram.Loc.t) -> - (if is_defined i then e1 else e2 : 'expr)))) ]) ])) - ()); - Gram.extend (patt : 'patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "IFNDEF"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); - Gram.Skeyword "THEN"; Gram.Sself; - Gram.Skeyword "ELSE"; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (p2 : 'patt) _ (p1 : 'patt) _ - (i : 'uident) _ (_loc : Gram.Loc.t) -> - (if is_defined i then p2 else p1 : 'patt)))); - ([ Gram.Skeyword "IFDEF"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); - Gram.Skeyword "THEN"; Gram.Sself; - Gram.Skeyword "ELSE"; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (p2 : 'patt) _ (p1 : 'patt) _ - (i : 'uident) _ (_loc : Gram.Loc.t) -> - (if is_defined i then p1 else p2 : 'patt)))) ]) ])) - ()); - Gram.extend (uident : 'uident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")) ], - (Gram.Action.mk - (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i in i : - 'uident)))) ]) ])) - ()); - Gram.extend - (* dirty hack to allow polymorphic variants using the introduced keywords. *) - (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Before "simple")), - [ (None, None, - [ ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.ExVrn (_loc, s) : 'expr)))); - ([ Gram.Skeyword "`"; - Gram.srules expr - [ ([ Gram.Skeyword "IN" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "DEFINE" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "ENDIF" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "END" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "ELSE" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "THEN" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "IFNDEF" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "IFDEF" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))) ] ], - (Gram.Action.mk - (fun (kwd : 'e__30) _ (_loc : Gram.Loc.t) -> - (Ast.ExVrn (_loc, kwd) : 'expr)))) ]) ])) - ()); - Gram.extend (* idem *) (patt : 'patt Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Before "simple")), - [ (None, None, - [ ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.PaVrn (_loc, s) : 'patt)))); - ([ Gram.Skeyword "`"; - Gram.srules patt - [ ([ Gram.Skeyword "ENDIF" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__31)))); - ([ Gram.Skeyword "END" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__31)))); - ([ Gram.Skeyword "ELSE" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__31)))); - ([ Gram.Skeyword "THEN" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__31)))); - ([ Gram.Skeyword "IFNDEF" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__31)))); - ([ Gram.Skeyword "IFDEF" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__31)))) ] ], - (Gram.Action.mk - (fun (kwd : 'e__31) _ (_loc : Gram.Loc.t) -> - (Ast.PaVrn (_loc, kwd) : 'patt)))) ]) ])) - ())) - - let _ = - Options.add "-D" (Arg.String parse_def) - " Define for IFDEF instruction." - - let _ = - Options.add "-U" (Arg.String undef) - " Undefine for IFDEF instruction." - - let _ = - Options.add "-I" (Arg.String add_include_dir) - " Add a directory to INCLUDE search path." - - end - - let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () - - module MakeNothing (AstFilters : Camlp4.Sig.AstFilters) = - struct - open AstFilters - - open Ast - - (* Remove NOTHING and expanse __FILE__ and __LOCATION__ *) - let map_expr = - function - | Ast.ExApp (_, e, (Ast.ExId (_, (Ast.IdUid (_, "NOTHING"))))) | - Ast.ExFun (_, - (Ast.McArr (_, (Ast.PaId (_, (Ast.IdUid (_, "NOTHING")))), - (Ast.ExNil _), e))) - -> e - | Ast.ExId (_loc, (Ast.IdLid (_, "__FILE__"))) -> - Ast.ExStr (_loc, - (Ast.safe_string_escaped (Loc.file_name _loc))) - | Ast.ExId (_loc, (Ast.IdLid (_, "__LOCATION__"))) -> - let (a, b, c, d, e, f, g, h) = Loc.to_tuple _loc - in - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), - (Ast.IdLid (_loc, "of_tuple")))))), - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, - (Ast.ExStr (_loc, (Ast.safe_string_escaped a))), - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExInt (_loc, - (string_of_int b))), - (Ast.ExInt (_loc, - (string_of_int c))))), - (Ast.ExInt (_loc, (string_of_int d))))), - (Ast.ExInt (_loc, (string_of_int e))))), - (Ast.ExInt (_loc, (string_of_int f))))), - (Ast.ExInt (_loc, (string_of_int g))))), - (if h - then Ast.ExId (_loc, (Ast.IdUid (_loc, "True"))) - else Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))))))))))) - | e -> e - - let _ = register_str_item_filter (Ast.map_expr map_expr)#str_item - - end - - let _ = let module M = Camlp4.Register.AstFilter(Id)(MakeNothing) in () - - end - -module D = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Nicolas Pouillard: initial version - *) - module Id = - struct let name = "Camlp4DebugParser" - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - open Sig - - include Syntax - - module StringSet = Set.Make(String) - - let debug_mode = - try - let str = Sys.getenv "STATIC_CAMLP4_DEBUG" in - let rec loop acc i = - try - let pos = String.index_from str i ':' - in - loop (StringSet.add (String.sub str i (pos - i)) acc) - (pos + 1) - with - | Not_found -> - StringSet.add (String.sub str i ((String.length str) - i)) - acc in - let sections = loop StringSet.empty 0 - in - if StringSet.mem "*" sections - then (fun _ -> true) - else (fun x -> StringSet.mem x sections) - with | Not_found -> (fun _ -> false) - - let rec apply accu = - function - | [] -> accu - | x :: xs -> - let _loc = Ast.loc_of_expr x - in apply (Ast.ExApp (_loc, accu, x)) xs - - let mk_debug_mode _loc = - function - | None -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Debug")), - (Ast.IdLid (_loc, "mode"))))) - | Some m -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Debug")), - (Ast.IdLid (_loc, "mode"))))))) - - let mk_debug _loc m fmt section args = - let call = - apply - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Debug")), - (Ast.IdLid (_loc, "printf")))))), - (Ast.ExStr (_loc, section)))), - (Ast.ExStr (_loc, fmt)))) - args - in - Ast.ExIfe (_loc, - (Ast.ExApp (_loc, (mk_debug_mode _loc m), - (Ast.ExStr (_loc, section)))), - call, (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))))) - - let _ = - let _ = (expr : 'expr Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let end_or_in : 'end_or_in Gram.Entry.t = - grammar_entry_create "end_or_in" - and start_debug : 'start_debug Gram.Entry.t = - grammar_entry_create "start_debug" - in - (Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (start_debug : 'start_debug Gram.Entry.t)); - Gram.Stoken - (((function | LIDENT ((_)) -> true | _ -> false), - "LIDENT _")); - Gram.Stoken - (((function | STRING ((_)) -> true | _ -> false), - "STRING _")); - Gram.Slist0 - (Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - ".")); - Gram.Snterm - (Gram.Entry.obj - (end_or_in : 'end_or_in Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'end_or_in) (args : 'expr list) - (fmt : Gram.Token.t) (section : Gram.Token.t) - (m : 'start_debug) (_loc : Gram.Loc.t) -> - (let fmt = Gram.Token.extract_string fmt in - let section = - Gram.Token.extract_string section - in - match (x, (debug_mode section)) with - | (None, false) -> - Ast.ExId (_loc, - (Ast.IdUid (_loc, "()"))) - | (Some e, false) -> e - | (None, _) -> - mk_debug _loc m fmt section args - | (Some e, _) -> - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "()")))), - (mk_debug _loc m fmt section args))), - e) : - 'expr)))) ]) ])) - ()); - Gram.extend (end_or_in : 'end_or_in Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "in"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (Some e : 'end_or_in)))); - ([ Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (None : 'end_or_in)))) ]) ])) - ()); - Gram.extend (start_debug : 'start_debug Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | LIDENT "camlp4_debug" -> true - | _ -> false), - "LIDENT \"camlp4_debug\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT "camlp4_debug" -> - (Some "Camlp4" : 'start_debug) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | LIDENT "debug" -> true - | _ -> false), - "LIDENT \"debug\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT "debug" -> (None : 'start_debug) - | _ -> assert false))) ]) ])) - ())) - - end - - let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () - - end - -module L = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2007 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Nao Hirokawa: initial version - * - Nicolas Pouillard: revised syntax version - *) - module Id = - struct - let name = "Camlp4ListComprehension" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - open Sig - - include Syntax - - let rec loop n = - function - | [] -> None - | [ (x, _) ] -> if n = 1 then Some x else None - | _ :: l -> loop (n - 1) l - - let stream_peek_nth n strm = loop n (Stream.npeek n strm) - - (* usual trick *) - let test_patt_lessminus = - Gram.Entry.of_parser "test_patt_lessminus" - (fun strm -> - let rec skip_patt n = - match stream_peek_nth n strm with - | Some (KEYWORD "<-") -> n - | Some (KEYWORD ("[" | "[<")) -> - skip_patt ((ignore_upto "]" (n + 1)) + 1) - | Some (KEYWORD "(") -> - skip_patt ((ignore_upto ")" (n + 1)) + 1) - | Some (KEYWORD "{") -> - skip_patt ((ignore_upto "}" (n + 1)) + 1) - | Some (KEYWORD ("as" | "::" | "," | "_")) | - Some (LIDENT _ | UIDENT _) -> skip_patt (n + 1) - | Some _ | None -> raise Stream.Failure - and ignore_upto end_kwd n = - match stream_peek_nth n strm with - | Some (KEYWORD prm) when prm = end_kwd -> n - | Some (KEYWORD ("[" | "[<")) -> - ignore_upto end_kwd ((ignore_upto "]" (n + 1)) + 1) - | Some (KEYWORD "(") -> - ignore_upto end_kwd ((ignore_upto ")" (n + 1)) + 1) - | Some (KEYWORD "{") -> - ignore_upto end_kwd ((ignore_upto "}" (n + 1)) + 1) - | Some _ -> ignore_upto end_kwd (n + 1) - | None -> raise Stream.Failure - in skip_patt 1) - - let map _loc p e l = - match (p, e) with - | (Ast.PaId (_, (Ast.IdLid (_, x))), - Ast.ExId (_, (Ast.IdLid (_, y)))) when x = y -> l - | _ -> - if Ast.is_irrefut_patt p - then - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), - (Ast.IdLid (_loc, "map")))))), - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), e)))))), - l) - else - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), - (Ast.IdLid (_loc, "fold_right")))))), - (Ast.ExFun (_loc, - (Ast.McOr (_loc, - (Ast.McArr (_loc, p, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "True")))), - (Ast.ExApp (_loc, - (Ast.ExFun (_loc, - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdLid (_loc, "x")))), - (Ast.ExNil _loc), - (Ast.ExFun (_loc, - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdLid (_loc, "xs")))), - (Ast.ExNil _loc), - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, - "::")))), - (Ast.ExId (_loc, - (Ast.IdLid (_loc, - "x")))))), - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "xs")))))))))))))), - e)))), - (Ast.McArr (_loc, (Ast.PaAny _loc), - (Ast.ExNil _loc), - (Ast.ExFun (_loc, - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdLid (_loc, "l")))), - (Ast.ExNil _loc), - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "l")))))))))))))))), - l)), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))))) - - let filter _loc p b l = - if Ast.is_irrefut_patt p - then - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), - (Ast.IdLid (_loc, "filter")))))), - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), b)))))), - l) - else - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), - (Ast.IdLid (_loc, "filter")))))), - (Ast.ExFun (_loc, - (Ast.McOr (_loc, - (Ast.McArr (_loc, p, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "True")))), b)), - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "False")))))))))))), - l) - - let concat _loc l = - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), - (Ast.IdLid (_loc, "concat")))))), - l) - - let rec compr _loc e = - function - | [ `gen ((p, l)) ] -> map _loc p e l - | `gen ((p, l)) :: `cond b :: items -> - compr _loc e ((`gen ((p, (filter _loc p b l)))) :: items) - | `gen ((p, l)) :: ((`gen ((_, _)) :: _ as is)) -> - concat _loc (map _loc p (compr _loc e is) l) - | _ -> raise Stream.Failure - - let _ = - Gram.delete_rule expr - [ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)); - Gram.Skeyword "]" ] - - let is_revised = - try - (Gram.delete_rule expr - [ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)); - Gram.Skeyword "::"; - Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword "]" ]; - true) - with | Struct.Grammar.Delete.Rule_not_found _ -> false - - let comprehension_or_sem_expr_for_list = - Gram.Entry.mk "comprehension_or_sem_expr_for_list" - - let _ = - let _ = (expr : 'expr Gram.Entry.t) - and _ = - (comprehension_or_sem_expr_for_list : - 'comprehension_or_sem_expr_for_list Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let item : 'item Gram.Entry.t = grammar_entry_create "item" - in - (Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "simple")), - [ (None, None, - [ ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comprehension_or_sem_expr_for_list : - 'comprehension_or_sem_expr_for_list Gram. - Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (e : 'comprehension_or_sem_expr_for_list) - _ (_loc : Gram.Loc.t) -> (e : 'expr)))) ]) ])) - ()); - Gram.extend - (comprehension_or_sem_expr_for_list : - 'comprehension_or_sem_expr_for_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top") ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))))) : - 'comprehension_or_sem_expr_for_list)))); - ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top"); - Gram.Skeyword "|"; - Gram.Slist1sep - ((Gram.Snterm - (Gram.Entry.obj (item : 'item Gram.Entry.t))), - (Gram.Skeyword ";")) ], - (Gram.Action.mk - (fun (l : 'item list) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (compr _loc e l : - 'comprehension_or_sem_expr_for_list)))); - ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top"); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (e : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))))) : - 'comprehension_or_sem_expr_for_list)))); - ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top"); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : - 'sem_expr_for_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mk : 'sem_expr_for_list) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - (mk - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "[]")))))) : - 'comprehension_or_sem_expr_for_list)))) ]) ])) - ()); - Gram.extend (item : 'item Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ (* NP: These rules rely on being on this particular order. Which should - be improved. *) - Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top") ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (`cond e : 'item)))); - ([ Gram.Stry - (Gram.srules item - [ ([ Gram.Snterm - (Gram.Entry.obj - (patt : 'patt Gram.Entry.t)); - Gram.Skeyword "<-" ], - (Gram.Action.mk - (fun _ (p : 'patt) (_loc : Gram.Loc.t) - -> (p : 'e__32)))) ]); - Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top") ], - (Gram.Action.mk - (fun (e : 'expr) (p : 'e__32) - (_loc : Gram.Loc.t) -> - (`gen ((p, e)) : 'item)))) ]) ])) - ())) - - let _ = - if is_revised - then - (let _ = (expr : 'expr Gram.Entry.t) - and _ = - (comprehension_or_sem_expr_for_list : - 'comprehension_or_sem_expr_for_list Gram.Entry.t) - in - Gram.extend - (comprehension_or_sem_expr_for_list : - 'comprehension_or_sem_expr_for_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top"); - Gram.Skeyword "::"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (last : 'expr) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - last) : - 'comprehension_or_sem_expr_for_list)))); - ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top"); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : - 'sem_expr_for_list Gram.Entry.t)); - Gram.Skeyword "::"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (last : 'expr) _ - (mk : 'sem_expr_for_list) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - (mk last)) : - 'comprehension_or_sem_expr_for_list)))) ]) ])) - ())) - else () - - end - - let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () - - end - -module P = - struct - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Nicolas Pouillard: initial version - *) - let _ = Camlp4.Register.enable_dump_ocaml_ast_printer () - - end - -module B = - struct - (* camlp4r *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - open Camlp4 - - open PreCast.Syntax - - open PreCast - - open Format - - module CleanAst = Camlp4.Struct.CleanAst.Make(Ast) - - module SSet = Set.Make(String) - - let pa_r = "Camlp4OCamlRevisedParser" - - let pa_rr = "Camlp4OCamlReloadedParser" - - let pa_o = "Camlp4OCamlParser" - - let pa_rp = "Camlp4OCamlRevisedParserParser" - - let pa_op = "Camlp4OCamlParserParser" - - let pa_g = "Camlp4GrammarParser" - - let pa_m = "Camlp4MacroParser" - - let pa_qb = "Camlp4QuotationCommon" - - let pa_q = "Camlp4QuotationExpander" - - let pa_rq = "Camlp4OCamlRevisedQuotationExpander" - - let pa_oq = "Camlp4OCamlOriginalQuotationExpander" - - let pa_l = "Camlp4ListComprehension" - - open Register - - let dyn_loader = - ref (fun _ -> raise (Match_failure ("./camlp4/Camlp4Bin.ml", 45, 24))) - - let rcall_callback = ref (fun () -> ()) - - let loaded_modules = ref SSet.empty - - let add_to_loaded_modules name = - loaded_modules := SSet.add name !loaded_modules - - let (objext, libext) = - if DynLoader.is_native then (".cmxs", ".cmxs") else (".cmo", ".cma") - - let rewrite_and_load n x = - let dyn_loader = !dyn_loader () in - let find_in_path = DynLoader.find_in_path dyn_loader in - let real_load name = - (add_to_loaded_modules name; DynLoader.load dyn_loader name) in - let load = - List.iter - (fun n -> - if - (SSet.mem n !loaded_modules) || - (List.mem n !Register.loaded_modules) - then () - else - (add_to_loaded_modules n; - DynLoader.load dyn_loader (n ^ objext))) - in - ((match (n, (String.lowercase x)) with - | (("Parsers" | ""), - ("pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" | - "camlp4ocamlrevisedparser.cmo")) - -> load [ pa_r ] - | (("Parsers" | ""), - ("rr" | "reloaded" | "ocamlreloaded" | - "camlp4ocamlreloadedparser.cmo")) - -> load [ pa_rr ] - | (("Parsers" | ""), - ("pa_o.cmo" | "o" | "ocaml" | "camlp4ocamlparser.cmo")) -> - load [ pa_r; pa_o ] - | (("Parsers" | ""), - ("pa_rp.cmo" | "rp" | "rparser" | - "camlp4ocamlrevisedparserparser.cmo")) - -> load [ pa_r; pa_rp ] - | (("Parsers" | ""), - ("pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo")) - -> load [ pa_r; pa_o; pa_rp; pa_op ] - | (("Parsers" | ""), - ("pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | - "camlp4grammarparser.cmo")) - -> load [ pa_g ] - | (("Parsers" | ""), - ("pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo")) -> - load [ pa_m ] - | (("Parsers" | ""), ("q" | "camlp4quotationexpander.cmo")) -> - load [ pa_qb; pa_q ] - | (("Parsers" | ""), - ("q_mlast.cmo" | "rq" | - "camlp4ocamlrevisedquotationexpander.cmo")) - -> load [ pa_qb; pa_rq ] - | (("Parsers" | ""), - ("oq" | "camlp4ocamloriginalquotationexpander.cmo")) -> - load [ pa_r; pa_o; pa_qb; pa_oq ] - | (("Parsers" | ""), "rf") -> - load [ pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m ] - | (("Parsers" | ""), "of") -> - load - [ pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m ] - | (("Parsers" | ""), ("comp" | "camlp4listcomprehension.cmo")) -> - load [ pa_l ] - | (("Filters" | ""), ("lift" | "camlp4astlifter.cmo")) -> - load [ "Camlp4AstLifter" ] - | (("Filters" | ""), ("exn" | "camlp4exceptiontracer.cmo")) -> - load [ "Camlp4ExceptionTracer" ] - | (("Filters" | ""), ("prof" | "camlp4profiler.cmo")) -> - load [ "Camlp4Profiler" ] - | (* map is now an alias of fold since fold handles map too *) - (("Filters" | ""), ("map" | "camlp4mapgenerator.cmo")) -> - load [ "Camlp4FoldGenerator" ] - | (("Filters" | ""), ("fold" | "camlp4foldgenerator.cmo")) -> - load [ "Camlp4FoldGenerator" ] - | (("Filters" | ""), ("meta" | "camlp4metagenerator.cmo")) -> - load [ "Camlp4MetaGenerator" ] - | (("Filters" | ""), ("trash" | "camlp4trashremover.cmo")) -> - load [ "Camlp4TrashRemover" ] - | (("Filters" | ""), ("striploc" | "camlp4locationstripper.cmo")) - -> load [ "Camlp4LocationStripper" ] - | (("Printers" | ""), - ("pr_r.cmo" | "r" | "ocamlr" | "camlp4ocamlrevisedprinter.cmo")) - -> Register.enable_ocamlr_printer () - | (("Printers" | ""), - ("pr_o.cmo" | "o" | "ocaml" | "camlp4ocamlprinter.cmo")) -> - Register.enable_ocaml_printer () - | (("Printers" | ""), - ("pr_dump.cmo" | "p" | "dumpocaml" | "camlp4ocamlastdumper.cmo")) - -> Register.enable_dump_ocaml_ast_printer () - | (("Printers" | ""), ("d" | "dumpcamlp4" | "camlp4astdumper.cmo")) - -> Register.enable_dump_camlp4_ast_printer () - | (("Printers" | ""), ("a" | "auto" | "camlp4autoprinter.cmo")) -> - load [ "Camlp4AutoPrinter" ] - | _ -> - let y = "Camlp4" ^ (n ^ ("/" ^ (x ^ objext))) - in real_load (try find_in_path y with | Not_found -> x)); - !rcall_callback ()) - - let print_warning = eprintf "%a:\n%s@." Loc.print - - let rec parse_file dyn_loader name pa getdir = - let directive_handler = - Some - (fun ast -> - match getdir ast with - | Some x -> - (match x with - | (_, "load", s) -> (rewrite_and_load "" s; None) - | (_, "directory", s) -> - (DynLoader.include_dir dyn_loader s; None) - | (_, "use", s) -> Some (parse_file dyn_loader s pa getdir) - | (_, "default_quotation", s) -> - (Quotation.default := s; None) - | (loc, _, _) -> - Loc.raise loc (Stream.Error "bad directive")) - | None -> None) in - let loc = Loc.mk name - in - (current_warning := print_warning; - let ic = if name = "-" then stdin else open_in_bin name in - let cs = Stream.of_channel ic in - let clear () = if name = "-" then () else close_in ic in - let phr = - try pa ?directive_handler loc cs with | x -> (clear (); raise x) - in (clear (); phr)) - - let output_file = ref None - - let process dyn_loader name pa pr clean fold_filters getdir = - let ast = parse_file dyn_loader name pa getdir in - let ast = fold_filters (fun t filter -> filter t) ast in - let ast = clean ast - in pr ?input_file: (Some name) ?output_file: !output_file ast - - let gind = - function - | Ast.SgDir (loc, n, (Ast.ExStr (_, s))) -> Some ((loc, n, s)) - | _ -> None - - let gimd = - function - | Ast.StDir (loc, n, (Ast.ExStr (_, s))) -> Some ((loc, n, s)) - | _ -> None - - let process_intf dyn_loader name = - process dyn_loader name CurrentParser.parse_interf CurrentPrinter. - print_interf (new CleanAst.clean_ast)#sig_item AstFilters. - fold_interf_filters gind - - let process_impl dyn_loader name = - process dyn_loader name CurrentParser.parse_implem CurrentPrinter. - print_implem (new CleanAst.clean_ast)#str_item AstFilters. - fold_implem_filters gimd - - let just_print_the_version () = - (printf "%s@." Camlp4_config.version; exit 0) - - let print_version () = - (eprintf "Camlp4 version %s@." Camlp4_config.version; exit 0) - - let print_stdlib () = - (printf "%s@." Camlp4_config.camlp4_standard_library; exit 0) - - let usage ini_sl ext_sl = - (eprintf - "\ -Usage: camlp4 [load-options] [--] [other-options]\n\ -Options:\n\ -.ml Parse this implementation file\n\ -.mli Parse this interface file\n\ -.%s Load this module inside the Camlp4 core@." - (if DynLoader.is_native then "cmxs " else "(cmo|cma)"); - Options.print_usage_list ini_sl; - (* loop (ini_sl @ ext_sl) where rec loop = - fun - [ [(y, _, _) :: _] when y = "-help" -> () - | [_ :: sl] -> loop sl - | [] -> eprintf " -help Display this list of options.@." ]; *) - if ext_sl <> [] - then - (eprintf "Options added by loaded object files:@."; - Options.print_usage_list ext_sl) - else ()) - - let warn_noassert () = - eprintf - "\ -camlp4 warning: option -noassert is obsolete\n\ -You should give the -noassert option to the ocaml compiler instead.@." - - type file_kind = - | Intf of string - | Impl of string - | Str of string - | ModuleImpl of string - | IncludeDir of string - - let search_stdlib = ref true - - let print_loaded_modules = ref false - - let (task, do_task) = - let t = ref None in - let task f x = - let () = Camlp4_config.current_input_file := x - in - t := - Some - (if !t = None then (fun _ -> f x) else (fun usage -> usage ())) in - let do_task usage = match !t with | Some f -> f usage | None -> () - in (task, do_task) - - let input_file x = - let dyn_loader = !dyn_loader () - in - (!rcall_callback (); - (match x with - | Intf file_name -> task (process_intf dyn_loader) file_name - | Impl file_name -> task (process_impl dyn_loader) file_name - | Str s -> - let (f, o) = Filename.open_temp_file "from_string" ".ml" - in - (output_string o s; - close_out o; - task (process_impl dyn_loader) f; - at_exit (fun () -> Sys.remove f)) - | ModuleImpl file_name -> rewrite_and_load "" file_name - | IncludeDir dir -> DynLoader.include_dir dyn_loader dir); - !rcall_callback ()) - - let initial_spec_list = - [ ("-I", (Arg.String (fun x -> input_file (IncludeDir x))), - " Add directory in search patch for object files."); - ("-where", (Arg.Unit print_stdlib), - "Print camlp4 library directory and exit."); - ("-nolib", (Arg.Clear search_stdlib), - "No automatic search for object files in library directory."); - ("-intf", (Arg.String (fun x -> input_file (Intf x))), - " Parse as an interface, whatever its extension."); - ("-impl", (Arg.String (fun x -> input_file (Impl x))), - " Parse as an implementation, whatever its extension."); - ("-str", (Arg.String (fun x -> input_file (Str x))), - " Parse as an implementation."); - ("-unsafe", (Arg.Set Camlp4_config.unsafe), - "Generate unsafe accesses to array and strings."); - ("-noassert", (Arg.Unit warn_noassert), - "Obsolete, do not use this option."); - ("-verbose", (Arg.Set Camlp4_config.verbose), - "More verbose in parsing errors."); - ("-loc", (Arg.Set_string Loc.name), - (" Name of the location variable (default: " ^ - (!Loc.name ^ ")."))); - ("-QD", (Arg.String (fun x -> Quotation.dump_file := Some x)), - " Dump quotation expander result in case of syntax error."); - ("-o", (Arg.String (fun x -> output_file := Some x)), - " Output on instead of standard output."); - ("-v", (Arg.Unit print_version), "Print Camlp4 version and exit."); - ("-version", (Arg.Unit just_print_the_version), - "Print Camlp4 version number and exit."); - ("-vnum", (Arg.Unit just_print_the_version), - "Print Camlp4 version number and exit."); - ("-no_quot", (Arg.Clear Camlp4_config.quotations), - "Don't parse quotations, allowing to use, e.g. \"<:>\" as token."); - ("-loaded-modules", (Arg.Set print_loaded_modules), - "Print the list of loaded modules."); - ("-parser", (Arg.String (rewrite_and_load "Parsers")), - " Load the parser Camlp4Parsers/.cm(o|a|xs)"); - ("-printer", (Arg.String (rewrite_and_load "Printers")), - " Load the printer Camlp4Printers/.cm(o|a|xs)"); - ("-filter", (Arg.String (rewrite_and_load "Filters")), - " Load the filter Camlp4Filters/.cm(o|a|xs)"); - ("-ignore", (Arg.String ignore), "ignore the next argument"); - ("--", (Arg.Unit ignore), "Deprecated, does nothing") ] - - let _ = Options.init initial_spec_list - - let anon_fun name = - input_file - (if Filename.check_suffix name ".mli" - then Intf name - else - if Filename.check_suffix name ".ml" - then Impl name - else - if Filename.check_suffix name objext - then ModuleImpl name - else - if Filename.check_suffix name libext - then ModuleImpl name - else raise (Arg.Bad ("don't know what to do with " ^ name))) - - let main argv = - let usage () = - (usage initial_spec_list (Options.ext_spec_list ()); exit 0) - in - try - let dynloader = - DynLoader.mk ~ocaml_stdlib: !search_stdlib - ~camlp4_stdlib: !search_stdlib () - in - (dyn_loader := (fun () -> dynloader); - let call_callback () = - Register.iter_and_take_callbacks - (fun (name, module_callback) -> - let () = add_to_loaded_modules name in module_callback ()) - in - (call_callback (); - rcall_callback := call_callback; - (match Options.parse anon_fun argv with - | [] -> () - | ("-help" | "--help" | "-h" | "-?") :: _ -> usage () - | s :: _ -> - (eprintf "%s: unknown or misused option\n" s; - eprintf "Use option -help for usage@."; - exit 2)); - do_task usage; - call_callback (); - if !print_loaded_modules - then SSet.iter (eprintf "%s@.") !loaded_modules - else ())) - with - | Arg.Bad s -> - (eprintf "Error: %s\n" s; - eprintf "Use option -help for usage@."; - exit 2) - | Arg.Help _ -> usage () - | exc -> (eprintf "@[%a@]@." ErrorHandler.print exc; exit 2) - - let _ = main Sys.argv - - end - - diff -Nru ocaml-4.01.0/camlp4/boot/camlp4boot.ml4 ocaml-4.05.0/camlp4/boot/camlp4boot.ml4 --- ocaml-4.01.0/camlp4/boot/camlp4boot.ml4 2012-08-02 08:17:59.000000000 +0000 +++ ocaml-4.05.0/camlp4/boot/camlp4boot.ml4 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module R = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml"; end; -module Camlp4QuotationCommon = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml"; end; -module Q = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml"; end; -module Rp = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml"; end; -module G = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4GrammarParser.ml"; end; -module M = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4MacroParser.ml"; end; -module D = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4DebugParser.ml"; end; -module L = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4ListComprehension.ml"; end; -module P = struct INCLUDE "camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml"; end; -module B = struct INCLUDE "camlp4/Camlp4Bin.ml"; end; diff -Nru ocaml-4.01.0/camlp4/boot/Camlp4.ml ocaml-4.05.0/camlp4/boot/Camlp4.ml --- ocaml-4.01.0/camlp4/boot/Camlp4.ml 2013-08-30 11:39:33.000000000 +0000 +++ ocaml-4.05.0/camlp4/boot/Camlp4.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,21644 +0,0 @@ -module Debug : - sig - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - (* camlp4r *) - type section = string - - val mode : section -> bool - - val printf : section -> ('a, Format.formatter, unit) format -> 'a - - end = - struct - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - (* camlp4r *) - open Format - - module Debug = struct let mode _ = false - end - - type section = string - - let out_channel = - try - let f = Sys.getenv "CAMLP4_DEBUG_FILE" - in - open_out_gen [ Open_wronly; Open_creat; Open_append; Open_text ] - 0o666 f - with | Not_found -> Pervasives.stderr - - module StringSet = Set.Make(String) - - let mode = - try - let str = Sys.getenv "CAMLP4_DEBUG" in - let rec loop acc i = - try - let pos = String.index_from str i ':' - in - loop (StringSet.add (String.sub str i (pos - i)) acc) (pos + 1) - with - | Not_found -> - StringSet.add (String.sub str i ((String.length str) - i)) acc in - let sections = loop StringSet.empty 0 - in - if StringSet.mem "*" sections - then (fun _ -> true) - else (fun x -> StringSet.mem x sections) - with | Not_found -> (fun _ -> false) - - let formatter = - let header = "camlp4-debug: " in - let at_bol = ref true - in - make_formatter - (fun buf pos len -> - for i = pos to (pos + len) - 1 do - if !at_bol then output_string out_channel header else (); - let ch = buf.[i] - in (output_char out_channel ch; at_bol := ch = '\n') - done) - (fun () -> flush out_channel) - - let printf section fmt = fprintf formatter ("%s: " ^^ fmt) section - - end - -module Options : - sig - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - type spec_list = (string * Arg.spec * string) list - - val init : spec_list -> unit - - val add : string -> Arg.spec -> string -> unit - - (** Add an option to the command line options. *) - val print_usage_list : spec_list -> unit - - val ext_spec_list : unit -> spec_list - - val parse : (string -> unit) -> string array -> string list - - end = - struct - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - type spec_list = (string * Arg.spec * string) list - - open Format - - let rec action_arg s sl = - function - | Arg.Unit f -> if s = "" then (f (); Some sl) else None - | Arg.Bool f -> - if s = "" - then - (match sl with - | s :: sl -> - (try (f (bool_of_string s); Some sl) - with | Invalid_argument "bool_of_string" -> None) - | [] -> None) - else - (try (f (bool_of_string s); Some sl) - with | Invalid_argument "bool_of_string" -> None) - | Arg.Set r -> if s = "" then (r := true; Some sl) else None - | Arg.Clear r -> if s = "" then (r := false; Some sl) else None - | Arg.Rest f -> (List.iter f (s :: sl); Some []) - | Arg.String f -> - if s = "" - then (match sl with | s :: sl -> (f s; Some sl) | [] -> None) - else (f s; Some sl) - | Arg.Set_string r -> - if s = "" - then (match sl with | s :: sl -> (r := s; Some sl) | [] -> None) - else (r := s; Some sl) - | Arg.Int f -> - if s = "" - then - (match sl with - | s :: sl -> - (try (f (int_of_string s); Some sl) - with | Failure "int_of_string" -> None) - | [] -> None) - else - (try (f (int_of_string s); Some sl) - with | Failure "int_of_string" -> None) - | Arg.Set_int r -> - if s = "" - then - (match sl with - | s :: sl -> - (try (r := int_of_string s; Some sl) - with | Failure "int_of_string" -> None) - | [] -> None) - else - (try (r := int_of_string s; Some sl) - with | Failure "int_of_string" -> None) - | Arg.Float f -> - if s = "" - then - (match sl with - | s :: sl -> (f (float_of_string s); Some sl) - | [] -> None) - else (f (float_of_string s); Some sl) - | Arg.Set_float r -> - if s = "" - then - (match sl with - | s :: sl -> (r := float_of_string s; Some sl) - | [] -> None) - else (r := float_of_string s; Some sl) - | Arg.Tuple specs -> - let rec action_args s sl = - (function - | [] -> Some sl - | spec :: spec_list -> - (match action_arg s sl spec with - | None -> action_args "" [] spec_list - | Some (s :: sl) -> action_args s sl spec_list - | Some sl -> action_args "" sl spec_list)) - in action_args s sl specs - | Arg.Symbol (syms, f) -> - (match if s = "" then sl else s :: sl with - | s :: sl when List.mem s syms -> (f s; Some sl) - | _ -> None) - - let common_start s1 s2 = - let rec loop i = - if (i == (String.length s1)) || (i == (String.length s2)) - then i - else if s1.[i] == s2.[i] then loop (i + 1) else i - in loop 0 - - let parse_arg fold s sl = - fold - (fun (name, action, _) acu -> - let i = common_start s name - in - if i == (String.length name) - then - (try - action_arg (String.sub s i ((String.length s) - i)) sl - action - with | Arg.Bad _ -> acu) - else acu) - None - - let rec parse_aux fold anon_fun = - function - | [] -> [] - | s :: sl -> - if ((String.length s) > 1) && (s.[0] = '-') - then - (match parse_arg fold s sl with - | Some sl -> parse_aux fold anon_fun sl - | None -> s :: (parse_aux fold anon_fun sl)) - else ((anon_fun s : unit); parse_aux fold anon_fun sl) - - let align_doc key s = - let s = - let rec loop i = - if i = (String.length s) - then "" - else - if s.[i] = ' ' - then loop (i + 1) - else String.sub s i ((String.length s) - i) - in loop 0 in - let (p, s) = - if (String.length s) > 0 - then - if s.[0] = '<' - then - (let rec loop i = - if i = (String.length s) - then ("", s) - else - if s.[i] <> '>' - then loop (i + 1) - else - (let p = String.sub s 0 (i + 1) in - let rec loop i = - if i >= (String.length s) - then (p, "") - else - if s.[i] = ' ' - then loop (i + 1) - else (p, (String.sub s i ((String.length s) - i))) - in loop (i + 1)) - in loop 0) - else ("", s) - else ("", "") in - let tab = - String.make (max 1 ((16 - (String.length key)) - (String.length p))) - ' ' - in p ^ (tab ^ s) - - let make_symlist l = - match l with - | [] -> "" - | h :: t -> - (List.fold_left (fun x y -> x ^ ("|" ^ y)) ("{" ^ h) t) ^ "}" - - let print_usage_list l = - List.iter - (fun (key, spec, doc) -> - match spec with - | Arg.Symbol (symbs, _) -> - let s = make_symlist symbs in - let synt = key ^ (" " ^ s) - in eprintf " %s %s\n" synt (align_doc synt doc) - | _ -> eprintf " %s %s\n" key (align_doc key doc)) - l - - let remaining_args argv = - let rec loop l i = - if i == (Array.length argv) then l else loop (argv.(i) :: l) (i + 1) - in List.rev (loop [] (!Arg.current + 1)) - - let init_spec_list = ref [] - - let ext_spec_list = ref [] - - let init spec_list = init_spec_list := spec_list - - let add name spec descr = - ext_spec_list := (name, spec, descr) :: !ext_spec_list - - let fold f init = - let spec_list = !init_spec_list @ !ext_spec_list in - let specs = Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list - in List.fold_right f specs init - - let parse anon_fun argv = - let remaining_args = remaining_args argv - in parse_aux fold anon_fun remaining_args - - let ext_spec_list () = !ext_spec_list - - end - -module Sig = - struct - (* camlp4r *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - (** Camlp4 signature repository *) - (** {6 Basic signatures} *) - (** Signature with just a type. *) - module type Type = sig type t - end - - (** Signature for errors modules, an Error modules can be registred with - the {!ErrorHandler.Register} functor in order to be well printed. *) - module type Error = - sig - type t - - exception E of t - - val to_string : t -> string - - val print : Format.formatter -> t -> unit - - end - - (** A signature for extensions identifiers. *) - module type Id = - sig - (** The name of the extension, typically the module name. *) - val name : string - - (** The version of the extension, typically $ Id$ with a versionning system. *) - val version : string - - end - - (** A signature for warnings abstract from locations. *) - module Warning (Loc : Type) = - struct - module type S = - sig - type warning = Loc.t -> string -> unit - - val default_warning : warning - - val current_warning : warning ref - - val print_warning : warning - - end - - end - - (** {6 Advanced signatures} *) - (** A signature for locations. *) - module type Loc = - sig - (** The type of locations. Note that, as for OCaml locations, - character numbers in locations refer to character numbers in the - parsed character stream, while line numbers refer to line - numbers in the source file. The source file and the parsed - character stream differ, for instance, when the parsed character - stream contains a line number directive. The line number - directive will only update the file-name field and the - line-number field of the position. It makes therefore no sense - to use character numbers with the source file if the sources - contain line number directives. *) - type t - - (** Return a start location for the given file name. - This location starts at the begining of the file. *) - val mk : string -> t - - (** The [ghost] location can be used when no location - information is available. *) - val ghost : t - - (** {6 Conversion functions} *) - (** Return a location where both positions are set the given position. *) - val of_lexing_position : Lexing.position -> t - - (** Return an OCaml location. *) - val to_ocaml_location : t -> Camlp4_import.Location.t - - (** Return a location from an OCaml location. *) - val of_ocaml_location : Camlp4_import.Location.t -> t - - (** Return a location from ocamllex buffer. *) - val of_lexbuf : Lexing.lexbuf -> t - - (** Return a location from [(file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost)]. *) - val of_tuple : - (string * int * int * int * int * int * int * bool) -> t - - (** Return [(file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost)]. *) - val to_tuple : - t -> (string * int * int * int * int * int * int * bool) - - (** [merge loc1 loc2] Return a location that starts at [loc1] and end at - [loc2]. *) - val merge : t -> t -> t - - (** The stop pos becomes equal to the start pos. *) - val join : t -> t - - (** [move selector n loc] - Return the location where positions are moved. - Affected positions are chosen with [selector]. - Returned positions have their character offset plus [n]. *) - val move : [ | `start | `stop | `both ] -> int -> t -> t - - (** [shift n loc] Return the location where the new start position is the old - stop position, and where the new stop position character offset is the - old one plus [n]. *) - val shift : int -> t -> t - - (** [move_line n loc] Return the location with the old line count plus [n]. - The "begin of line" of both positions become the current offset. *) - val move_line : int -> t -> t - - (** {6 Accessors} *) - (** Return the file name *) - val file_name : t -> string - - (** Return the line number of the begining of this location. *) - val start_line : t -> int - - (** Return the line number of the ending of this location. *) - val stop_line : t -> int - - (** Returns the number of characters from the begining of the stream - to the begining of the line of location's begining. *) - val start_bol : t -> int - - (** Returns the number of characters from the begining of the stream - to the begining of the line of location's ending. *) - val stop_bol : t -> int - - (** Returns the number of characters from the begining of the stream - of the begining of this location. *) - val start_off : t -> int - - (** Return the number of characters from the begining of the stream - of the ending of this location. *) - val stop_off : t -> int - - (** Return the start position as a Lexing.position. *) - val start_pos : t -> Lexing.position - - (** Return the stop position as a Lexing.position. *) - val stop_pos : t -> Lexing.position - - (** Generally, return true if this location does not come - from an input stream. *) - val is_ghost : t -> bool - - (** Return the associated ghost location. *) - val ghostify : t -> t - - (** Return the location with the give file name *) - val set_file_name : string -> t -> t - - (** [strictly_before loc1 loc2] True if the stop position of [loc1] is - strictly_before the start position of [loc2]. *) - val strictly_before : t -> t -> bool - - (** Return the location with an absolute file name. *) - val make_absolute : t -> t - - (** Print the location into the formatter in a format suitable for error - reporting. *) - val print : Format.formatter -> t -> unit - - (** Print the location in a short format useful for debugging. *) - val dump : Format.formatter -> t -> unit - - (** Same as {!print} but return a string instead of printting it. *) - val to_string : t -> string - - (** [Exc_located loc e] is an encapsulation of the exception [e] with - the input location [loc]. To be used in quotation expanders - and in grammars to specify some input location for an error. - Do not raise this exception directly: rather use the following - function [Loc.raise]. *) - exception Exc_located of t * exn - - (** [raise loc e], if [e] is already an [Exc_located] exception, - re-raise it, else raise the exception [Exc_located loc e]. *) - val raise : t -> exn -> 'a - - (** The name of the location variable used in grammars and in - the predefined quotations for OCaml syntax trees. Default: [_loc]. *) - val name : string ref - - end - - (** Abstract syntax tree minimal signature. - Types of this signature are abstract. - See the {!Camlp4Ast} signature for a concrete definition. *) - module type Ast = - sig - (** {6 Syntactic categories as abstract types} *) - type loc - - type meta_bool - - type 'a meta_option - - type 'a meta_list - - type ctyp - - type patt - - type expr - - type module_type - - type sig_item - - type with_constr - - type module_expr - - type str_item - - type class_type - - type class_sig_item - - type class_expr - - type class_str_item - - type match_case - - type ident - - type binding - - type rec_binding - - type module_binding - - type rec_flag - - type direction_flag - - type mutable_flag - - type private_flag - - type virtual_flag - - type row_var_flag - - type override_flag - - (** {6 Location accessors} *) - val loc_of_ctyp : ctyp -> loc - - val loc_of_patt : patt -> loc - - val loc_of_expr : expr -> loc - - val loc_of_module_type : module_type -> loc - - val loc_of_module_expr : module_expr -> loc - - val loc_of_sig_item : sig_item -> loc - - val loc_of_str_item : str_item -> loc - - val loc_of_class_type : class_type -> loc - - val loc_of_class_sig_item : class_sig_item -> loc - - val loc_of_class_expr : class_expr -> loc - - val loc_of_class_str_item : class_str_item -> loc - - val loc_of_with_constr : with_constr -> loc - - val loc_of_binding : binding -> loc - - val loc_of_rec_binding : rec_binding -> loc - - val loc_of_module_binding : module_binding -> loc - - val loc_of_match_case : match_case -> loc - - val loc_of_ident : ident -> loc - - (** {6 Traversals} *) - (** This class is the base class for map traversal on the Ast. - To make a custom traversal class one just extend it like that: - - This example swap pairs expression contents: - open Camlp4.PreCast; - [class swap = object - inherit Ast.map as super; - method expr e = - match super#expr e with - \[ <:expr\@_loc< ($e1$, $e2$) >> -> <:expr< ($e2$, $e1$) >> - | e -> e \]; - end; - value _loc = Loc.ghost; - value map = (new swap)#expr; - assert (map <:expr< fun x -> (x, 42) >> = <:expr< fun x -> (42, x) >>);] - *) - class map : - object ('self_type) - method string : string -> string - method list : - 'a 'b. ('self_type -> 'a -> 'b) -> 'a list -> 'b list - method meta_bool : meta_bool -> meta_bool - method meta_option : - 'a 'b. - ('self_type -> 'a -> 'b) -> 'a meta_option -> 'b meta_option - method meta_list : - 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_list -> 'b meta_list - method loc : loc -> loc - method expr : expr -> expr - method patt : patt -> patt - method ctyp : ctyp -> ctyp - method str_item : str_item -> str_item - method sig_item : sig_item -> sig_item - method module_expr : module_expr -> module_expr - method module_type : module_type -> module_type - method class_expr : class_expr -> class_expr - method class_type : class_type -> class_type - method class_sig_item : class_sig_item -> class_sig_item - method class_str_item : class_str_item -> class_str_item - method with_constr : with_constr -> with_constr - method binding : binding -> binding - method rec_binding : rec_binding -> rec_binding - method module_binding : module_binding -> module_binding - method match_case : match_case -> match_case - method ident : ident -> ident - method override_flag : override_flag -> override_flag - method mutable_flag : mutable_flag -> mutable_flag - method private_flag : private_flag -> private_flag - method virtual_flag : virtual_flag -> virtual_flag - method direction_flag : direction_flag -> direction_flag - method rec_flag : rec_flag -> rec_flag - method row_var_flag : row_var_flag -> row_var_flag - method unknown : 'a. 'a -> 'a - end - - (** Fold style traversal *) - class fold : - object ('self_type) - method string : string -> 'self_type - method list : - 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type - method meta_bool : meta_bool -> 'self_type - method meta_option : - 'a. - ('self_type -> 'a -> 'self_type) -> - 'a meta_option -> 'self_type - method meta_list : - 'a. - ('self_type -> 'a -> 'self_type) -> - 'a meta_list -> 'self_type - method loc : loc -> 'self_type - method expr : expr -> 'self_type - method patt : patt -> 'self_type - method ctyp : ctyp -> 'self_type - method str_item : str_item -> 'self_type - method sig_item : sig_item -> 'self_type - method module_expr : module_expr -> 'self_type - method module_type : module_type -> 'self_type - method class_expr : class_expr -> 'self_type - method class_type : class_type -> 'self_type - method class_sig_item : class_sig_item -> 'self_type - method class_str_item : class_str_item -> 'self_type - method with_constr : with_constr -> 'self_type - method binding : binding -> 'self_type - method rec_binding : rec_binding -> 'self_type - method module_binding : module_binding -> 'self_type - method match_case : match_case -> 'self_type - method ident : ident -> 'self_type - method rec_flag : rec_flag -> 'self_type - method direction_flag : direction_flag -> 'self_type - method mutable_flag : mutable_flag -> 'self_type - method private_flag : private_flag -> 'self_type - method virtual_flag : virtual_flag -> 'self_type - method row_var_flag : row_var_flag -> 'self_type - method override_flag : override_flag -> 'self_type - method unknown : 'a. 'a -> 'self_type - end - - end - - (** Signature for OCaml syntax trees. *) - (* - This signature is an extension of {!Ast} - It provides: - - Types for all kinds of structure. - - Map: A base class for map traversals. - - Map classes and functions for common kinds. - - == Core language == - ctyp :: Representaion of types - patt :: The type of patterns - expr :: The type of expressions - match_case :: The type of cases for match/function/try constructions - ident :: The type of identifiers (including path like Foo(X).Bar.y) - binding :: The type of let bindings - rec_binding :: The type of record definitions - - == Modules == - module_type :: The type of module types - sig_item :: The type of signature items - str_item :: The type of structure items - module_expr :: The type of module expressions - module_binding :: The type of recursive module definitions - with_constr :: The type of `with' constraints - - == Classes == - class_type :: The type of class types - class_sig_item :: The type of class signature items - class_expr :: The type of class expressions - class_str_item :: The type of class structure items - *) - module type Camlp4Ast = - sig - (** The inner module for locations *) - module Loc : Loc - - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2007 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 LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Note: when you modify these types you must increment - ast magic numbers defined in Camlp4_config.ml. *) - type loc = - Loc. - t - and meta_bool = - | BTrue | BFalse | BAnt of string - and rec_flag = - | ReRecursive | ReNil | ReAnt of string - and direction_flag = - | DiTo | DiDownto | DiAnt of string - and mutable_flag = - | MuMutable | MuNil | MuAnt of string - and private_flag = - | PrPrivate | PrNil | PrAnt of string - and virtual_flag = - | ViVirtual | ViNil | ViAnt of string - and override_flag = - | OvOverride | OvNil | OvAnt of string - and row_var_flag = - | RvRowVar | RvNil | RvAnt of string - and 'a meta_option = - | ONone | OSome of 'a | OAnt of string - and 'a meta_list = - | LNil | LCons of 'a * 'a meta_list | LAnt of string - and ident = - | IdAcc of loc * ident * ident - | (* i . i *) - IdApp of loc * ident * ident - | (* i i *) - IdLid of loc * string - | (* foo *) - IdUid of loc * string - | (* Bar *) - IdAnt of loc * string - and (* $s$ *) - ctyp = - | TyNil of loc - | TyAli of loc * ctyp * ctyp - | (* t as t *) - (* list 'a as 'a *) - TyAny of loc - | (* _ *) - TyApp of loc * ctyp * ctyp - | (* t t *) - (* list 'a *) - TyArr of loc * ctyp * ctyp - | (* t -> t *) - (* int -> string *) - TyCls of loc * ident - | (* #i *) - (* #point *) - TyLab of loc * string * ctyp - | (* ~s:t *) - TyId of loc * ident - | (* i *) - (* Lazy.t *) - TyMan of loc * ctyp * ctyp - | (* t == t *) - (* type t = [ A | B ] == Foo.t *) - (* type t 'a 'b 'c = t constraint t = t constraint t = t *) - TyDcl of loc * string * ctyp list * ctyp * (ctyp * ctyp) list - | (* < (t)? (..)? > *) - (* < move : int -> 'a .. > as 'a *) - TyObj of loc * ctyp * row_var_flag - | TyOlb of loc * string * ctyp - | (* ?s:t *) - TyPol of loc * ctyp * ctyp - | (* ! t . t *) - (* ! 'a . list 'a -> 'a *) - TyTypePol of loc * ctyp * ctyp - | (* type t . t *) - (* type a . list a -> a *) - TyQuo of loc * string - | (* 's *) - TyQuP of loc * string - | (* +'s *) - TyQuM of loc * string - | (* -'s *) - TyAnP of loc - | (* +_ *) - TyAnM of loc - | (* -_ *) - TyVrn of loc * string - | (* `s *) - TyRec of loc * ctyp - | (* { t } *) - (* { foo : int ; bar : mutable string } *) - TyCol of loc * ctyp * ctyp - | (* t : t *) - TySem of loc * ctyp * ctyp - | (* t; t *) - TyCom of loc * ctyp * ctyp - | (* t, t *) - TySum of loc * ctyp - | (* [ t ] *) - (* [ A of int and string | B ] *) - TyOf of loc * ctyp * ctyp - | (* t of t *) - (* A of int *) - TyAnd of loc * ctyp * ctyp - | (* t and t *) - TyOr of loc * ctyp * ctyp - | (* t | t *) - TyPrv of loc * ctyp - | (* private t *) - TyMut of loc * ctyp - | (* mutable t *) - TyTup of loc * ctyp - | (* ( t ) *) - (* (int * string) *) - TySta of loc * ctyp * ctyp - | (* t * t *) - TyVrnEq of loc * ctyp - | (* [ = t ] *) - TyVrnSup of loc * ctyp - | (* [ > t ] *) - TyVrnInf of loc * ctyp - | (* [ < t ] *) - TyVrnInfSup of loc * ctyp * ctyp - | (* [ < t > t ] *) - TyAmp of loc * ctyp * ctyp - | (* t & t *) - TyOfAmp of loc * ctyp * ctyp - | (* t of & t *) - TyPkg of loc * module_type - | (* (module S) *) - TyAnt of loc * string - and (* $s$ *) - patt = - | PaNil of loc - | PaId of loc * ident - | (* i *) - PaAli of loc * patt * patt - | (* p as p *) - (* (Node x y as n) *) - PaAnt of loc * string - | (* $s$ *) - PaAny of loc - | (* _ *) - PaApp of loc * patt * patt - | (* p p *) - (* fun x y -> *) - PaArr of loc * patt - | (* [| p |] *) - PaCom of loc * patt * patt - | (* p, p *) - PaSem of loc * patt * patt - | (* p; p *) - PaChr of loc * string - | (* c *) - (* 'x' *) - PaInt of loc * string - | PaInt32 of loc * string - | PaInt64 of loc * string - | PaNativeInt of loc * string - | PaFlo of loc * string - | PaLab of loc * string * patt - | (* ~s or ~s:(p) *) - (* ?s or ?s:(p) *) - PaOlb of loc * string * patt - | (* ?s:(p = e) or ?(p = e) *) - PaOlbi of loc * string * patt * expr - | PaOrp of loc * patt * patt - | (* p | p *) - PaRng of loc * patt * patt - | (* p .. p *) - PaRec of loc * patt - | (* { p } *) - PaEq of loc * ident * patt - | (* i = p *) - PaStr of loc * string - | (* s *) - PaTup of loc * patt - | (* ( p ) *) - PaTyc of loc * patt * ctyp - | (* (p : t) *) - PaTyp of loc * ident - | (* #i *) - PaVrn of loc * string - | (* `s *) - PaLaz of loc * patt - | (* lazy p *) - PaMod of loc * string - and (* (module M) *) - expr = - | ExNil of loc - | ExId of loc * ident - | (* i *) - ExAcc of loc * expr * expr - | (* e.e *) - ExAnt of loc * string - | (* $s$ *) - ExApp of loc * expr * expr - | (* e e *) - ExAre of loc * expr * expr - | (* e.(e) *) - ExArr of loc * expr - | (* [| e |] *) - ExSem of loc * expr * expr - | (* e; e *) - ExAsf of loc - | (* assert False *) - ExAsr of loc * expr - | (* assert e *) - ExAss of loc * expr * expr - | (* e := e *) - ExChr of loc * string - | (* 'c' *) - ExCoe of loc * expr * ctyp * ctyp - | (* (e : t) or (e : t :> t) *) - ExFlo of loc * string - | (* 3.14 *) - (* for s = e to/downto e do { e } *) - ExFor of loc * string * expr * expr * direction_flag * expr - | ExFun of loc * match_case - | (* fun [ mc ] *) - ExIfe of loc * expr * expr * expr - | (* if e then e else e *) - ExInt of loc * string - | (* 42 *) - ExInt32 of loc * string - | ExInt64 of loc * string - | ExNativeInt of loc * string - | ExLab of loc * string * expr - | (* ~s or ~s:e *) - ExLaz of loc * expr - | (* lazy e *) - (* let b in e or let rec b in e *) - ExLet of loc * rec_flag * binding * expr - | (* let module s = me in e *) - ExLmd of loc * string * module_expr * expr - | (* match e with [ mc ] *) - ExMat of loc * expr * match_case - | (* new i *) - ExNew of loc * ident - | (* object ((p))? (cst)? end *) - ExObj of loc * patt * class_str_item - | (* ?s or ?s:e *) - ExOlb of loc * string * expr - | (* {< rb >} *) - ExOvr of loc * rec_binding - | (* { rb } or { (e) with rb } *) - ExRec of loc * rec_binding * expr - | (* do { e } *) - ExSeq of loc * expr - | (* e#s *) - ExSnd of loc * expr * string - | (* e.[e] *) - ExSte of loc * expr * expr - | (* s *) - (* "foo" *) - ExStr of loc * string - | (* try e with [ mc ] *) - ExTry of loc * expr * match_case - | (* (e) *) - ExTup of loc * expr - | (* e, e *) - ExCom of loc * expr * expr - | (* (e : t) *) - ExTyc of loc * expr * ctyp - | (* `s *) - ExVrn of loc * string - | (* while e do { e } *) - ExWhi of loc * expr * expr - | (* let open i in e *) - ExOpI of loc * ident * expr - | (* fun (type t) -> e *) - (* let f x (type t) y z = e *) - ExFUN of loc * string * expr - | (* (module ME : S) which is represented as (module (ME : S)) *) - ExPkg of loc * module_expr - and module_type = - | MtNil of loc - | (* i *) - (* A.B.C *) - MtId of loc * ident - | (* functor (s : mt) -> mt *) - MtFun of loc * string * module_type * module_type - | (* 's *) - MtQuo of loc * string - | (* sig sg end *) - MtSig of loc * sig_item - | (* mt with wc *) - MtWit of loc * module_type * with_constr - | (* module type of m *) - MtOf of loc * module_expr - | MtAnt of loc * string - and (* $s$ *) - sig_item = - | SgNil of loc - | (* class cict *) - SgCls of loc * class_type - | (* class type cict *) - SgClt of loc * class_type - | (* sg ; sg *) - SgSem of loc * sig_item * sig_item - | (* # s or # s e *) - SgDir of loc * string * expr - | (* exception t *) - SgExc of loc * ctyp - | (* external s : t = s ... s *) - SgExt of loc * string * ctyp * string meta_list - | (* include mt *) - SgInc of loc * module_type - | (* module s : mt *) - SgMod of loc * string * module_type - | (* module rec mb *) - SgRecMod of loc * module_binding - | (* module type s = mt *) - SgMty of loc * string * module_type - | (* open i *) - SgOpn of loc * ident - | (* type t *) - SgTyp of loc * ctyp - | (* value s : t *) - SgVal of loc * string * ctyp - | SgAnt of loc * string - and (* $s$ *) - with_constr = - | WcNil of loc - | (* type t = t *) - WcTyp of loc * ctyp * ctyp - | (* module i = i *) - WcMod of loc * ident * ident - | (* type t := t *) - WcTyS of loc * ctyp * ctyp - | (* module i := i *) - WcMoS of loc * ident * ident - | (* wc and wc *) - WcAnd of loc * with_constr * with_constr - | WcAnt of loc * string - and (* $s$ *) - binding = - | BiNil of loc - | (* bi and bi *) - (* let a = 42 and c = 43 *) - BiAnd of loc * binding * binding - | (* p = e *) - (* let patt = expr *) - BiEq of loc * patt * expr - | BiAnt of loc * string - and (* $s$ *) - rec_binding = - | RbNil of loc - | (* rb ; rb *) - RbSem of loc * rec_binding * rec_binding - | (* i = e *) - RbEq of loc * ident * expr - | RbAnt of loc * string - and (* $s$ *) - module_binding = - | MbNil of loc - | (* mb and mb *) - (* module rec (s : mt) = me and (s : mt) = me *) - MbAnd of loc * module_binding * module_binding - | (* s : mt = me *) - MbColEq of loc * string * module_type * module_expr - | (* s : mt *) - MbCol of loc * string * module_type - | MbAnt of loc * string - and (* $s$ *) - match_case = - | McNil of loc - | (* a | a *) - McOr of loc * match_case * match_case - | (* p (when e)? -> e *) - McArr of loc * patt * expr * expr - | McAnt of loc * string - and (* $s$ *) - module_expr = - | MeNil of loc - | (* i *) - MeId of loc * ident - | (* me me *) - MeApp of loc * module_expr * module_expr - | (* functor (s : mt) -> me *) - MeFun of loc * string * module_type * module_expr - | (* struct st end *) - MeStr of loc * str_item - | (* (me : mt) *) - MeTyc of loc * module_expr * module_type - | (* (value e) *) - (* (value e : S) which is represented as (value (e : S)) *) - MePkg of loc * expr - | MeAnt of loc * string - and (* $s$ *) - str_item = - | StNil of loc - | (* class cice *) - StCls of loc * class_expr - | (* class type cict *) - StClt of loc * class_type - | (* st ; st *) - StSem of loc * str_item * str_item - | (* # s or # s e *) - StDir of loc * string * expr - | (* exception t or exception t = i *) - StExc of loc * ctyp * (*FIXME*) ident meta_option - | (* e *) - StExp of loc * expr - | (* external s : t = s ... s *) - StExt of loc * string * ctyp * string meta_list - | (* include me *) - StInc of loc * module_expr - | (* module s = me *) - StMod of loc * string * module_expr - | (* module rec mb *) - StRecMod of loc * module_binding - | (* module type s = mt *) - StMty of loc * string * module_type - | (* open i *) - StOpn of loc * ident - | (* type t *) - StTyp of loc * ctyp - | (* value (rec)? bi *) - StVal of loc * rec_flag * binding - | StAnt of loc * string - and (* $s$ *) - class_type = - | CtNil of loc - | (* (virtual)? i ([ t ])? *) - CtCon of loc * virtual_flag * ident * ctyp - | (* [t] -> ct *) - CtFun of loc * ctyp * class_type - | (* object ((t))? (csg)? end *) - CtSig of loc * ctyp * class_sig_item - | (* ct and ct *) - CtAnd of loc * class_type * class_type - | (* ct : ct *) - CtCol of loc * class_type * class_type - | (* ct = ct *) - CtEq of loc * class_type * class_type - | (* $s$ *) - CtAnt of loc * string - and class_sig_item = - | CgNil of loc - | (* type t = t *) - CgCtr of loc * ctyp * ctyp - | (* csg ; csg *) - CgSem of loc * class_sig_item * class_sig_item - | (* inherit ct *) - CgInh of loc * class_type - | (* method s : t or method private s : t *) - CgMth of loc * string * private_flag * ctyp - | (* value (virtual)? (mutable)? s : t *) - CgVal of loc * string * mutable_flag * virtual_flag * ctyp - | (* method virtual (private)? s : t *) - CgVir of loc * string * private_flag * ctyp - | CgAnt of loc * string - and (* $s$ *) - class_expr = - | CeNil of loc - | (* ce e *) - CeApp of loc * class_expr * expr - | (* (virtual)? i ([ t ])? *) - CeCon of loc * virtual_flag * ident * ctyp - | (* fun p -> ce *) - CeFun of loc * patt * class_expr - | (* let (rec)? bi in ce *) - CeLet of loc * rec_flag * binding * class_expr - | (* object ((p))? (cst)? end *) - CeStr of loc * patt * class_str_item - | (* ce : ct *) - CeTyc of loc * class_expr * class_type - | (* ce and ce *) - CeAnd of loc * class_expr * class_expr - | (* ce = ce *) - CeEq of loc * class_expr * class_expr - | (* $s$ *) - CeAnt of loc * string - and class_str_item = - | CrNil of loc - | (* cst ; cst *) - CrSem of loc * class_str_item * class_str_item - | (* type t = t *) - CrCtr of loc * ctyp * ctyp - | (* inherit(!)? ce (as s)? *) - CrInh of loc * override_flag * class_expr * string - | (* initializer e *) - CrIni of loc * expr - | (* method(!)? (private)? s : t = e or method(!)? (private)? s = e *) - CrMth of loc * string * override_flag * private_flag * expr * ctyp - | (* value(!)? (mutable)? s = e *) - CrVal of loc * string * override_flag * mutable_flag * expr - | (* method virtual (private)? s : t *) - CrVir of loc * string * private_flag * ctyp - | (* value virtual (mutable)? s : t *) - CrVvr of loc * string * mutable_flag * ctyp - | CrAnt of loc * string - - val loc_of_ctyp : ctyp -> loc - - val loc_of_patt : patt -> loc - - val loc_of_expr : expr -> loc - - val loc_of_module_type : module_type -> loc - - val loc_of_module_expr : module_expr -> loc - - val loc_of_sig_item : sig_item -> loc - - val loc_of_str_item : str_item -> loc - - val loc_of_class_type : class_type -> loc - - val loc_of_class_sig_item : class_sig_item -> loc - - val loc_of_class_expr : class_expr -> loc - - val loc_of_class_str_item : class_str_item -> loc - - val loc_of_with_constr : with_constr -> loc - - val loc_of_binding : binding -> loc - - val loc_of_rec_binding : rec_binding -> loc - - val loc_of_module_binding : module_binding -> loc - - val loc_of_match_case : match_case -> loc - - val loc_of_ident : ident -> loc - - module Meta : - sig - module type META_LOC = - sig - val meta_loc_patt : loc -> loc -> patt - - val meta_loc_expr : loc -> loc -> expr - - end - - module MetaLoc : - sig - val meta_loc_patt : loc -> loc -> patt - - val meta_loc_expr : loc -> loc -> expr - - end - - module MetaGhostLoc : - sig - val meta_loc_patt : loc -> 'a -> patt - - val meta_loc_expr : loc -> 'a -> expr - - end - - module MetaLocVar : - sig - val meta_loc_patt : loc -> 'a -> patt - - val meta_loc_expr : loc -> 'a -> expr - - end - - module Make (MetaLoc : META_LOC) : - sig - module Expr : - sig - val meta_string : loc -> string -> expr - - val meta_int : loc -> string -> expr - - val meta_float : loc -> string -> expr - - val meta_char : loc -> string -> expr - - val meta_bool : loc -> bool -> expr - - val meta_list : - (loc -> 'a -> expr) -> loc -> 'a list -> expr - - val meta_binding : loc -> binding -> expr - - val meta_rec_binding : loc -> rec_binding -> expr - - val meta_class_expr : loc -> class_expr -> expr - - val meta_class_sig_item : loc -> class_sig_item -> expr - - val meta_class_str_item : loc -> class_str_item -> expr - - val meta_class_type : loc -> class_type -> expr - - val meta_ctyp : loc -> ctyp -> expr - - val meta_expr : loc -> expr -> expr - - val meta_ident : loc -> ident -> expr - - val meta_match_case : loc -> match_case -> expr - - val meta_module_binding : loc -> module_binding -> expr - - val meta_module_expr : loc -> module_expr -> expr - - val meta_module_type : loc -> module_type -> expr - - val meta_patt : loc -> patt -> expr - - val meta_sig_item : loc -> sig_item -> expr - - val meta_str_item : loc -> str_item -> expr - - val meta_with_constr : loc -> with_constr -> expr - - val meta_rec_flag : loc -> rec_flag -> expr - - val meta_mutable_flag : loc -> mutable_flag -> expr - - val meta_virtual_flag : loc -> virtual_flag -> expr - - val meta_private_flag : loc -> private_flag -> expr - - val meta_row_var_flag : loc -> row_var_flag -> expr - - val meta_override_flag : loc -> override_flag -> expr - - val meta_direction_flag : loc -> direction_flag -> expr - - end - - module Patt : - sig - val meta_string : loc -> string -> patt - - val meta_int : loc -> string -> patt - - val meta_float : loc -> string -> patt - - val meta_char : loc -> string -> patt - - val meta_bool : loc -> bool -> patt - - val meta_list : - (loc -> 'a -> patt) -> loc -> 'a list -> patt - - val meta_binding : loc -> binding -> patt - - val meta_rec_binding : loc -> rec_binding -> patt - - val meta_class_expr : loc -> class_expr -> patt - - val meta_class_sig_item : loc -> class_sig_item -> patt - - val meta_class_str_item : loc -> class_str_item -> patt - - val meta_class_type : loc -> class_type -> patt - - val meta_ctyp : loc -> ctyp -> patt - - val meta_expr : loc -> expr -> patt - - val meta_ident : loc -> ident -> patt - - val meta_match_case : loc -> match_case -> patt - - val meta_module_binding : loc -> module_binding -> patt - - val meta_module_expr : loc -> module_expr -> patt - - val meta_module_type : loc -> module_type -> patt - - val meta_patt : loc -> patt -> patt - - val meta_sig_item : loc -> sig_item -> patt - - val meta_str_item : loc -> str_item -> patt - - val meta_with_constr : loc -> with_constr -> patt - - val meta_rec_flag : loc -> rec_flag -> patt - - val meta_mutable_flag : loc -> mutable_flag -> patt - - val meta_virtual_flag : loc -> virtual_flag -> patt - - val meta_private_flag : loc -> private_flag -> patt - - val meta_row_var_flag : loc -> row_var_flag -> patt - - val meta_override_flag : loc -> override_flag -> patt - - val meta_direction_flag : loc -> direction_flag -> patt - - end - - end - - end - - class map : - object ('self_type) - method string : string -> string - method list : - 'a 'b. ('self_type -> 'a -> 'b) -> 'a list -> 'b list - method meta_bool : meta_bool -> meta_bool - method meta_option : - 'a 'b. - ('self_type -> 'a -> 'b) -> 'a meta_option -> 'b meta_option - method meta_list : - 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_list -> 'b meta_list - method loc : loc -> loc - method expr : expr -> expr - method patt : patt -> patt - method ctyp : ctyp -> ctyp - method str_item : str_item -> str_item - method sig_item : sig_item -> sig_item - method module_expr : module_expr -> module_expr - method module_type : module_type -> module_type - method class_expr : class_expr -> class_expr - method class_type : class_type -> class_type - method class_sig_item : class_sig_item -> class_sig_item - method class_str_item : class_str_item -> class_str_item - method with_constr : with_constr -> with_constr - method binding : binding -> binding - method rec_binding : rec_binding -> rec_binding - method module_binding : module_binding -> module_binding - method match_case : match_case -> match_case - method ident : ident -> ident - method mutable_flag : mutable_flag -> mutable_flag - method private_flag : private_flag -> private_flag - method virtual_flag : virtual_flag -> virtual_flag - method direction_flag : direction_flag -> direction_flag - method rec_flag : rec_flag -> rec_flag - method row_var_flag : row_var_flag -> row_var_flag - method override_flag : override_flag -> override_flag - method unknown : 'a. 'a -> 'a - end - - class fold : - object ('self_type) - method string : string -> 'self_type - method list : - 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type - method meta_bool : meta_bool -> 'self_type - method meta_option : - 'a. - ('self_type -> 'a -> 'self_type) -> - 'a meta_option -> 'self_type - method meta_list : - 'a. - ('self_type -> 'a -> 'self_type) -> - 'a meta_list -> 'self_type - method loc : loc -> 'self_type - method expr : expr -> 'self_type - method patt : patt -> 'self_type - method ctyp : ctyp -> 'self_type - method str_item : str_item -> 'self_type - method sig_item : sig_item -> 'self_type - method module_expr : module_expr -> 'self_type - method module_type : module_type -> 'self_type - method class_expr : class_expr -> 'self_type - method class_type : class_type -> 'self_type - method class_sig_item : class_sig_item -> 'self_type - method class_str_item : class_str_item -> 'self_type - method with_constr : with_constr -> 'self_type - method binding : binding -> 'self_type - method rec_binding : rec_binding -> 'self_type - method module_binding : module_binding -> 'self_type - method match_case : match_case -> 'self_type - method ident : ident -> 'self_type - method rec_flag : rec_flag -> 'self_type - method direction_flag : direction_flag -> 'self_type - method mutable_flag : mutable_flag -> 'self_type - method private_flag : private_flag -> 'self_type - method virtual_flag : virtual_flag -> 'self_type - method row_var_flag : row_var_flag -> 'self_type - method override_flag : override_flag -> 'self_type - method unknown : 'a. 'a -> 'self_type - end - - val map_expr : (expr -> expr) -> map - - val map_patt : (patt -> patt) -> map - - val map_ctyp : (ctyp -> ctyp) -> map - - val map_str_item : (str_item -> str_item) -> map - - val map_sig_item : (sig_item -> sig_item) -> map - - val map_loc : (loc -> loc) -> map - - val ident_of_expr : expr -> ident - - val ident_of_patt : patt -> ident - - val ident_of_ctyp : ctyp -> ident - - val biAnd_of_list : binding list -> binding - - val rbSem_of_list : rec_binding list -> rec_binding - - val paSem_of_list : patt list -> patt - - val paCom_of_list : patt list -> patt - - val tyOr_of_list : ctyp list -> ctyp - - val tyAnd_of_list : ctyp list -> ctyp - - val tyAmp_of_list : ctyp list -> ctyp - - val tySem_of_list : ctyp list -> ctyp - - val tyCom_of_list : ctyp list -> ctyp - - val tySta_of_list : ctyp list -> ctyp - - val stSem_of_list : str_item list -> str_item - - val sgSem_of_list : sig_item list -> sig_item - - val crSem_of_list : class_str_item list -> class_str_item - - val cgSem_of_list : class_sig_item list -> class_sig_item - - val ctAnd_of_list : class_type list -> class_type - - val ceAnd_of_list : class_expr list -> class_expr - - val wcAnd_of_list : with_constr list -> with_constr - - val meApp_of_list : module_expr list -> module_expr - - val mbAnd_of_list : module_binding list -> module_binding - - val mcOr_of_list : match_case list -> match_case - - val idAcc_of_list : ident list -> ident - - val idApp_of_list : ident list -> ident - - val exSem_of_list : expr list -> expr - - val exCom_of_list : expr list -> expr - - val list_of_ctyp : ctyp -> ctyp list -> ctyp list - - val list_of_binding : binding -> binding list -> binding list - - val list_of_rec_binding : - rec_binding -> rec_binding list -> rec_binding list - - val list_of_with_constr : - with_constr -> with_constr list -> with_constr list - - val list_of_patt : patt -> patt list -> patt list - - val list_of_expr : expr -> expr list -> expr list - - val list_of_str_item : str_item -> str_item list -> str_item list - - val list_of_sig_item : sig_item -> sig_item list -> sig_item list - - val list_of_class_sig_item : - class_sig_item -> class_sig_item list -> class_sig_item list - - val list_of_class_str_item : - class_str_item -> class_str_item list -> class_str_item list - - val list_of_class_type : - class_type -> class_type list -> class_type list - - val list_of_class_expr : - class_expr -> class_expr list -> class_expr list - - val list_of_module_expr : - module_expr -> module_expr list -> module_expr list - - val list_of_module_binding : - module_binding -> module_binding list -> module_binding list - - val list_of_match_case : - match_case -> match_case list -> match_case list - - val list_of_ident : ident -> ident list -> ident list - - val safe_string_escaped : string -> string - - val is_irrefut_patt : patt -> bool - - val is_constructor : ident -> bool - - val is_patt_constructor : patt -> bool - - val is_expr_constructor : expr -> bool - - val ty_of_stl : (Loc.t * string * (ctyp list)) -> ctyp - - val ty_of_sbt : (Loc.t * string * bool * ctyp) -> ctyp - - val bi_of_pe : (patt * expr) -> binding - - val pel_of_binding : binding -> (patt * expr) list - - val binding_of_pel : (patt * expr) list -> binding - - val sum_type_of_list : (Loc.t * string * (ctyp list)) list -> ctyp - - val record_type_of_list : (Loc.t * string * bool * ctyp) list -> ctyp - - end - - module Camlp4AstToAst (M : Camlp4Ast) : Ast with type loc = M.loc - and type meta_bool = M.meta_bool - and type 'a meta_option = 'a M.meta_option - and type 'a meta_list = 'a M.meta_list and type ctyp = M.ctyp - and type patt = M.patt and type expr = M.expr - and type module_type = M.module_type and type sig_item = M.sig_item - and type with_constr = M.with_constr - and type module_expr = M.module_expr and type str_item = M.str_item - and type class_type = M.class_type - and type class_sig_item = M.class_sig_item - and type class_expr = M.class_expr - and type class_str_item = M.class_str_item and type binding = M.binding - and type rec_binding = M.rec_binding - and type module_binding = M.module_binding - and type match_case = M.match_case and type ident = M.ident - and type rec_flag = M.rec_flag - and type direction_flag = M.direction_flag - and type mutable_flag = M.mutable_flag - and type private_flag = M.private_flag - and type virtual_flag = M.virtual_flag - and type row_var_flag = M.row_var_flag - and type override_flag = M.override_flag = M - - module MakeCamlp4Ast (Loc : Type) = - struct - type loc = - Loc. - t - and meta_bool = - | BTrue | BFalse | BAnt of string - and rec_flag = - | ReRecursive | ReNil | ReAnt of string - and direction_flag = - | DiTo | DiDownto | DiAnt of string - and mutable_flag = - | MuMutable | MuNil | MuAnt of string - and private_flag = - | PrPrivate | PrNil | PrAnt of string - and virtual_flag = - | ViVirtual | ViNil | ViAnt of string - and override_flag = - | OvOverride | OvNil | OvAnt of string - and row_var_flag = - | RvRowVar | RvNil | RvAnt of string - and 'a meta_option = - | ONone | OSome of 'a | OAnt of string - and 'a meta_list = - | LNil | LCons of 'a * 'a meta_list | LAnt of string - and ident = - | IdAcc of loc * ident * ident - | IdApp of loc * ident * ident - | IdLid of loc * string - | IdUid of loc * string - | IdAnt of loc * string - and ctyp = - | TyNil of loc - | TyAli of loc * ctyp * ctyp - | TyAny of loc - | TyApp of loc * ctyp * ctyp - | TyArr of loc * ctyp * ctyp - | TyCls of loc * ident - | TyLab of loc * string * ctyp - | TyId of loc * ident - | TyMan of loc * ctyp * ctyp - | TyDcl of loc * string * ctyp list * ctyp * (ctyp * ctyp) list - | TyObj of loc * ctyp * row_var_flag - | TyOlb of loc * string * ctyp - | TyPol of loc * ctyp * ctyp - | TyTypePol of loc * ctyp * ctyp - | TyQuo of loc * string - | TyQuP of loc * string - | TyQuM of loc * string - | TyAnP of loc - | TyAnM of loc - | TyVrn of loc * string - | TyRec of loc * ctyp - | TyCol of loc * ctyp * ctyp - | TySem of loc * ctyp * ctyp - | TyCom of loc * ctyp * ctyp - | TySum of loc * ctyp - | TyOf of loc * ctyp * ctyp - | TyAnd of loc * ctyp * ctyp - | TyOr of loc * ctyp * ctyp - | TyPrv of loc * ctyp - | TyMut of loc * ctyp - | TyTup of loc * ctyp - | TySta of loc * ctyp * ctyp - | TyVrnEq of loc * ctyp - | TyVrnSup of loc * ctyp - | TyVrnInf of loc * ctyp - | TyVrnInfSup of loc * ctyp * ctyp - | TyAmp of loc * ctyp * ctyp - | TyOfAmp of loc * ctyp * ctyp - | TyPkg of loc * module_type - | TyAnt of loc * string - and patt = - | PaNil of loc - | PaId of loc * ident - | PaAli of loc * patt * patt - | PaAnt of loc * string - | PaAny of loc - | PaApp of loc * patt * patt - | PaArr of loc * patt - | PaCom of loc * patt * patt - | PaSem of loc * patt * patt - | PaChr of loc * string - | PaInt of loc * string - | PaInt32 of loc * string - | PaInt64 of loc * string - | PaNativeInt of loc * string - | PaFlo of loc * string - | PaLab of loc * string * patt - | PaOlb of loc * string * patt - | PaOlbi of loc * string * patt * expr - | PaOrp of loc * patt * patt - | PaRng of loc * patt * patt - | PaRec of loc * patt - | PaEq of loc * ident * patt - | PaStr of loc * string - | PaTup of loc * patt - | PaTyc of loc * patt * ctyp - | PaTyp of loc * ident - | PaVrn of loc * string - | PaLaz of loc * patt - | PaMod of loc * string - and expr = - | ExNil of loc - | ExId of loc * ident - | ExAcc of loc * expr * expr - | ExAnt of loc * string - | ExApp of loc * expr * expr - | ExAre of loc * expr * expr - | ExArr of loc * expr - | ExSem of loc * expr * expr - | ExAsf of loc - | ExAsr of loc * expr - | ExAss of loc * expr * expr - | ExChr of loc * string - | ExCoe of loc * expr * ctyp * ctyp - | ExFlo of loc * string - | ExFor of loc * string * expr * expr * direction_flag * expr - | ExFun of loc * match_case - | ExIfe of loc * expr * expr * expr - | ExInt of loc * string - | ExInt32 of loc * string - | ExInt64 of loc * string - | ExNativeInt of loc * string - | ExLab of loc * string * expr - | ExLaz of loc * expr - | ExLet of loc * rec_flag * binding * expr - | ExLmd of loc * string * module_expr * expr - | ExMat of loc * expr * match_case - | ExNew of loc * ident - | ExObj of loc * patt * class_str_item - | ExOlb of loc * string * expr - | ExOvr of loc * rec_binding - | ExRec of loc * rec_binding * expr - | ExSeq of loc * expr - | ExSnd of loc * expr * string - | ExSte of loc * expr * expr - | ExStr of loc * string - | ExTry of loc * expr * match_case - | ExTup of loc * expr - | ExCom of loc * expr * expr - | ExTyc of loc * expr * ctyp - | ExVrn of loc * string - | ExWhi of loc * expr * expr - | ExOpI of loc * ident * expr - | ExFUN of loc * string * expr - | ExPkg of loc * module_expr - and module_type = - | MtNil of loc - | MtId of loc * ident - | MtFun of loc * string * module_type * module_type - | MtQuo of loc * string - | MtSig of loc * sig_item - | MtWit of loc * module_type * with_constr - | MtOf of loc * module_expr - | MtAnt of loc * string - and sig_item = - | SgNil of loc - | SgCls of loc * class_type - | SgClt of loc * class_type - | SgSem of loc * sig_item * sig_item - | SgDir of loc * string * expr - | SgExc of loc * ctyp - | SgExt of loc * string * ctyp * string meta_list - | SgInc of loc * module_type - | SgMod of loc * string * module_type - | SgRecMod of loc * module_binding - | SgMty of loc * string * module_type - | SgOpn of loc * ident - | SgTyp of loc * ctyp - | SgVal of loc * string * ctyp - | SgAnt of loc * string - and with_constr = - | WcNil of loc - | WcTyp of loc * ctyp * ctyp - | WcMod of loc * ident * ident - | WcTyS of loc * ctyp * ctyp - | WcMoS of loc * ident * ident - | WcAnd of loc * with_constr * with_constr - | WcAnt of loc * string - and binding = - | BiNil of loc - | BiAnd of loc * binding * binding - | BiEq of loc * patt * expr - | BiAnt of loc * string - and rec_binding = - | RbNil of loc - | RbSem of loc * rec_binding * rec_binding - | RbEq of loc * ident * expr - | RbAnt of loc * string - and module_binding = - | MbNil of loc - | MbAnd of loc * module_binding * module_binding - | MbColEq of loc * string * module_type * module_expr - | MbCol of loc * string * module_type - | MbAnt of loc * string - and match_case = - | McNil of loc - | McOr of loc * match_case * match_case - | McArr of loc * patt * expr * expr - | McAnt of loc * string - and module_expr = - | MeNil of loc - | MeId of loc * ident - | MeApp of loc * module_expr * module_expr - | MeFun of loc * string * module_type * module_expr - | MeStr of loc * str_item - | MeTyc of loc * module_expr * module_type - | MePkg of loc * expr - | MeAnt of loc * string - and str_item = - | StNil of loc - | StCls of loc * class_expr - | StClt of loc * class_type - | StSem of loc * str_item * str_item - | StDir of loc * string * expr - | StExc of loc * ctyp * ident meta_option - | StExp of loc * expr - | StExt of loc * string * ctyp * string meta_list - | StInc of loc * module_expr - | StMod of loc * string * module_expr - | StRecMod of loc * module_binding - | StMty of loc * string * module_type - | StOpn of loc * ident - | StTyp of loc * ctyp - | StVal of loc * rec_flag * binding - | StAnt of loc * string - and class_type = - | CtNil of loc - | CtCon of loc * virtual_flag * ident * ctyp - | CtFun of loc * ctyp * class_type - | CtSig of loc * ctyp * class_sig_item - | CtAnd of loc * class_type * class_type - | CtCol of loc * class_type * class_type - | CtEq of loc * class_type * class_type - | CtAnt of loc * string - and class_sig_item = - | CgNil of loc - | CgCtr of loc * ctyp * ctyp - | CgSem of loc * class_sig_item * class_sig_item - | CgInh of loc * class_type - | CgMth of loc * string * private_flag * ctyp - | CgVal of loc * string * mutable_flag * virtual_flag * ctyp - | CgVir of loc * string * private_flag * ctyp - | CgAnt of loc * string - and class_expr = - | CeNil of loc - | CeApp of loc * class_expr * expr - | CeCon of loc * virtual_flag * ident * ctyp - | CeFun of loc * patt * class_expr - | CeLet of loc * rec_flag * binding * class_expr - | CeStr of loc * patt * class_str_item - | CeTyc of loc * class_expr * class_type - | CeAnd of loc * class_expr * class_expr - | CeEq of loc * class_expr * class_expr - | CeAnt of loc * string - and class_str_item = - | CrNil of loc - | CrSem of loc * class_str_item * class_str_item - | CrCtr of loc * ctyp * ctyp - | CrInh of loc * override_flag * class_expr * string - | CrIni of loc * expr - | CrMth of loc * string * override_flag * private_flag * expr - * ctyp - | CrVal of loc * string * override_flag * mutable_flag * expr - | CrVir of loc * string * private_flag * ctyp - | CrVvr of loc * string * mutable_flag * ctyp - | CrAnt of loc * string - - end - - type ('a, 'loc) stream_filter = - ('a * 'loc) Stream.t -> ('a * 'loc) Stream.t - - module type AstFilters = - sig - module Ast : Camlp4Ast - - type 'a filter = 'a -> 'a - - val register_sig_item_filter : Ast.sig_item filter -> unit - - val register_str_item_filter : Ast.str_item filter -> unit - - val register_topphrase_filter : Ast.str_item filter -> unit - - val fold_interf_filters : - ('a -> Ast.sig_item filter -> 'a) -> 'a -> 'a - - val fold_implem_filters : - ('a -> Ast.str_item filter -> 'a) -> 'a -> 'a - - val fold_topphrase_filters : - ('a -> Ast.str_item filter -> 'a) -> 'a -> 'a - - end - - module type DynAst = - sig - module Ast : Ast - - type 'a tag - - val ctyp_tag : Ast.ctyp tag - - val patt_tag : Ast.patt tag - - val expr_tag : Ast.expr tag - - val module_type_tag : Ast.module_type tag - - val sig_item_tag : Ast.sig_item tag - - val with_constr_tag : Ast.with_constr tag - - val module_expr_tag : Ast.module_expr tag - - val str_item_tag : Ast.str_item tag - - val class_type_tag : Ast.class_type tag - - val class_sig_item_tag : Ast.class_sig_item tag - - val class_expr_tag : Ast.class_expr tag - - val class_str_item_tag : Ast.class_str_item tag - - val match_case_tag : Ast.match_case tag - - val ident_tag : Ast.ident tag - - val binding_tag : Ast.binding tag - - val rec_binding_tag : Ast.rec_binding tag - - val module_binding_tag : Ast.module_binding tag - - val string_of_tag : 'a tag -> string - - module Pack (X : sig type 'a t - end) : - sig - type pack - - val pack : 'a tag -> 'a X.t -> pack - - val unpack : 'a tag -> pack -> 'a X.t - - val print_tag : Format.formatter -> pack -> unit - - end - - end - - type quotation = - { q_name : string; q_loc : string; q_shift : int; q_contents : string - } - - module type Quotation = - sig - module Ast : Ast - - module DynAst : DynAst with module Ast = Ast - - open Ast - - type 'a expand_fun = loc -> string option -> string -> 'a - - val add : string -> 'a DynAst.tag -> 'a expand_fun -> unit - - val find : string -> 'a DynAst.tag -> 'a expand_fun - - val default : string ref - - val parse_quotation_result : - (loc -> string -> 'a) -> loc -> quotation -> string -> string -> 'a - - val translate : (string -> string) ref - - val expand : loc -> quotation -> 'a DynAst.tag -> 'a - - val dump_file : (string option) ref - - module Error : Error - - end - - module type Token = - sig - module Loc : Loc - - type t - - val to_string : t -> string - - val print : Format.formatter -> t -> unit - - val match_keyword : string -> t -> bool - - val extract_string : t -> string - - module Filter : - sig - type token_filter = (t, Loc.t) stream_filter - - type t - - val mk : (string -> bool) -> t - - val define_filter : t -> (token_filter -> token_filter) -> unit - - val filter : t -> token_filter - - val keyword_added : t -> string -> bool -> unit - - val keyword_removed : t -> string -> unit - - end - - module Error : Error - - end - - type camlp4_token = - | KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int * string - | INT32 of int32 * string - | INT64 of int64 * string - | NATIVEINT of nativeint * string - | FLOAT of float * string - | CHAR of char * string - | STRING of string * string - | LABEL of string - | OPTLABEL of string - | QUOTATION of quotation - | ANTIQUOT of string * string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int * string option - | EOI - - module type Camlp4Token = Token with type t = camlp4_token - - module type DynLoader = - sig - type t - - exception Error of string * string - - val mk : ?ocaml_stdlib: bool -> ?camlp4_stdlib: bool -> unit -> t - - val fold_load_path : t -> (string -> 'a -> 'a) -> 'a -> 'a - - val load : t -> string -> unit - - val include_dir : t -> string -> unit - - val find_in_path : t -> string -> string - - val is_native : bool - - end - - module Grammar = - struct - module type Action = - sig - type t - - val mk : 'a -> t - - val get : t -> 'a - - val getf : t -> 'a -> 'b - - val getf2 : t -> 'a -> 'b -> 'c - - end - - type assoc = | NonA | RightA | LeftA - - type position = - | First - | Last - | Before of string - | After of string - | Level of string - - module type Structure = - sig - module Loc : Loc - - module Action : Action - - module Token : Token with module Loc = Loc - - type gram - - type internal_entry - - type tree - - type token_pattern = ((Token.t -> bool) * string) - - type token_info - - type token_stream = (Token.t * token_info) Stream.t - - val token_location : token_info -> Loc.t - - type symbol = - | Smeta of string * symbol list * Action.t - | Snterm of internal_entry - | Snterml of internal_entry * string - | Slist0 of symbol - | Slist0sep of symbol * symbol - | Slist1 of symbol - | Slist1sep of symbol * symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree - - type production_rule = ((symbol list) * Action.t) - - type single_extend_statment = - ((string option) * (assoc option) * (production_rule list)) - - type extend_statment = - ((position option) * (single_extend_statment list)) - - type delete_statment = symbol list - - type ('a, 'b, 'c) fold = - internal_entry -> - symbol list -> ('a Stream.t -> 'b) -> 'a Stream.t -> 'c - - type ('a, 'b, 'c) foldsep = - internal_entry -> - symbol list -> - ('a Stream.t -> 'b) -> - ('a Stream.t -> unit) -> 'a Stream.t -> 'c - - end - - module type Dynamic = - sig - include Structure - - val mk : unit -> gram - - module Entry : - sig - type 'a t - - val mk : gram -> string -> 'a t - - val of_parser : - gram -> string -> (token_stream -> 'a) -> 'a t - - val setup_parser : 'a t -> (token_stream -> 'a) -> unit - - val name : 'a t -> string - - val print : Format.formatter -> 'a t -> unit - - val dump : Format.formatter -> 'a t -> unit - - val obj : 'a t -> internal_entry - - val clear : 'a t -> unit - - end - - val get_filter : gram -> Token.Filter.t - - type 'a not_filtered - - val extend : 'a Entry.t -> extend_statment -> unit - - val delete_rule : 'a Entry.t -> delete_statment -> unit - - val srules : - 'a Entry.t -> ((symbol list) * Action.t) list -> symbol - - val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold - - val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold - - val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) foldsep - - val lex : - gram -> - Loc.t -> - char Stream.t -> ((Token.t * Loc.t) Stream.t) not_filtered - - val lex_string : - gram -> - Loc.t -> string -> ((Token.t * Loc.t) Stream.t) not_filtered - - val filter : - gram -> - ((Token.t * Loc.t) Stream.t) not_filtered -> token_stream - - val parse : 'a Entry.t -> Loc.t -> char Stream.t -> 'a - - val parse_string : 'a Entry.t -> Loc.t -> string -> 'a - - val parse_tokens_before_filter : - 'a Entry.t -> ((Token.t * Loc.t) Stream.t) not_filtered -> 'a - - val parse_tokens_after_filter : 'a Entry.t -> token_stream -> 'a - - end - - module type Static = - sig - include Structure - - module Entry : - sig - type 'a t - - val mk : string -> 'a t - - val of_parser : string -> (token_stream -> 'a) -> 'a t - - val setup_parser : 'a t -> (token_stream -> 'a) -> unit - - val name : 'a t -> string - - val print : Format.formatter -> 'a t -> unit - - val dump : Format.formatter -> 'a t -> unit - - val obj : 'a t -> internal_entry - - val clear : 'a t -> unit - - end - - val get_filter : unit -> Token.Filter.t - - type 'a not_filtered - - val extend : 'a Entry.t -> extend_statment -> unit - - val delete_rule : 'a Entry.t -> delete_statment -> unit - - val srules : - 'a Entry.t -> ((symbol list) * Action.t) list -> symbol - - val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold - - val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold - - val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) foldsep - - val lex : - Loc.t -> - char Stream.t -> ((Token.t * Loc.t) Stream.t) not_filtered - - val lex_string : - Loc.t -> string -> ((Token.t * Loc.t) Stream.t) not_filtered - - val filter : - ((Token.t * Loc.t) Stream.t) not_filtered -> token_stream - - val parse : 'a Entry.t -> Loc.t -> char Stream.t -> 'a - - val parse_string : 'a Entry.t -> Loc.t -> string -> 'a - - val parse_tokens_before_filter : - 'a Entry.t -> ((Token.t * Loc.t) Stream.t) not_filtered -> 'a - - val parse_tokens_after_filter : 'a Entry.t -> token_stream -> 'a - - end - - end - - module type Lexer = - sig - module Loc : Loc - - module Token : Token with module Loc = Loc - - module Error : Error - - val mk : unit -> Loc.t -> char Stream.t -> (Token.t * Loc.t) Stream.t - - end - - module Parser (Ast : Ast) = - struct - module type SIMPLE = - sig - val parse_expr : Ast.loc -> string -> Ast.expr - - val parse_patt : Ast.loc -> string -> Ast.patt - - end - - module type S = - sig - val parse_implem : - ?directive_handler: (Ast.str_item -> Ast.str_item option) -> - Ast.loc -> char Stream.t -> Ast.str_item - - val parse_interf : - ?directive_handler: (Ast.sig_item -> Ast.sig_item option) -> - Ast.loc -> char Stream.t -> Ast.sig_item - - end - - end - - module Printer (Ast : Ast) = - struct - module type S = - sig - val print_interf : - ?input_file: string -> - ?output_file: string -> Ast.sig_item -> unit - - val print_implem : - ?input_file: string -> - ?output_file: string -> Ast.str_item -> unit - - end - - end - - module type Syntax = - sig - module Loc : Loc - - module Ast : Ast with type loc = Loc.t - - module Token : Token with module Loc = Loc - - module Gram : Grammar.Static with module Loc = Loc - and module Token = Token - - module Quotation : Quotation with module Ast = Ast - - module AntiquotSyntax : Parser(Ast).SIMPLE - - include Warning(Loc).S - - include Parser(Ast).S - - include Printer(Ast).S - - end - - module type Camlp4Syntax = - sig - module Loc : Loc - - module Ast : Camlp4Ast with module Loc = Loc - - module Token : Camlp4Token with module Loc = Loc - - module Gram : Grammar.Static with module Loc = Loc - and module Token = Token - - module Quotation : Quotation with module Ast = Camlp4AstToAst(Ast) - - module AntiquotSyntax : Parser(Ast).SIMPLE - - include Warning(Loc).S - - include Parser(Ast).S - - include Printer(Ast).S - - val interf : ((Ast.sig_item list) * (Loc.t option)) Gram.Entry.t - - val implem : ((Ast.str_item list) * (Loc.t option)) Gram.Entry.t - - val top_phrase : (Ast.str_item option) Gram.Entry.t - - val use_file : ((Ast.str_item list) * (Loc.t option)) Gram.Entry.t - - val a_CHAR : string Gram.Entry.t - - val a_FLOAT : string Gram.Entry.t - - val a_INT : string Gram.Entry.t - - val a_INT32 : string Gram.Entry.t - - val a_INT64 : string Gram.Entry.t - - val a_LABEL : string Gram.Entry.t - - val a_LIDENT : string Gram.Entry.t - - val a_NATIVEINT : string Gram.Entry.t - - val a_OPTLABEL : string Gram.Entry.t - - val a_STRING : string Gram.Entry.t - - val a_UIDENT : string Gram.Entry.t - - val a_ident : string Gram.Entry.t - - val amp_ctyp : Ast.ctyp Gram.Entry.t - - val and_ctyp : Ast.ctyp Gram.Entry.t - - val match_case : Ast.match_case Gram.Entry.t - - val match_case0 : Ast.match_case Gram.Entry.t - - val match_case_quot : Ast.match_case Gram.Entry.t - - val binding : Ast.binding Gram.Entry.t - - val binding_quot : Ast.binding Gram.Entry.t - - val rec_binding_quot : Ast.rec_binding Gram.Entry.t - - val class_declaration : Ast.class_expr Gram.Entry.t - - val class_description : Ast.class_type Gram.Entry.t - - val class_expr : Ast.class_expr Gram.Entry.t - - val class_expr_quot : Ast.class_expr Gram.Entry.t - - val class_fun_binding : Ast.class_expr Gram.Entry.t - - val class_fun_def : Ast.class_expr Gram.Entry.t - - val class_info_for_class_expr : Ast.class_expr Gram.Entry.t - - val class_info_for_class_type : Ast.class_type Gram.Entry.t - - val class_longident : Ast.ident Gram.Entry.t - - val class_longident_and_param : Ast.class_expr Gram.Entry.t - - val class_name_and_param : (string * Ast.ctyp) Gram.Entry.t - - val class_sig_item : Ast.class_sig_item Gram.Entry.t - - val class_sig_item_quot : Ast.class_sig_item Gram.Entry.t - - val class_signature : Ast.class_sig_item Gram.Entry.t - - val class_str_item : Ast.class_str_item Gram.Entry.t - - val class_str_item_quot : Ast.class_str_item Gram.Entry.t - - val class_structure : Ast.class_str_item Gram.Entry.t - - val class_type : Ast.class_type Gram.Entry.t - - val class_type_declaration : Ast.class_type Gram.Entry.t - - val class_type_longident : Ast.ident Gram.Entry.t - - val class_type_longident_and_param : Ast.class_type Gram.Entry.t - - val class_type_plus : Ast.class_type Gram.Entry.t - - val class_type_quot : Ast.class_type Gram.Entry.t - - val comma_ctyp : Ast.ctyp Gram.Entry.t - - val comma_expr : Ast.expr Gram.Entry.t - - val comma_ipatt : Ast.patt Gram.Entry.t - - val comma_patt : Ast.patt Gram.Entry.t - - val comma_type_parameter : Ast.ctyp Gram.Entry.t - - val constrain : (Ast.ctyp * Ast.ctyp) Gram.Entry.t - - val constructor_arg_list : Ast.ctyp Gram.Entry.t - - val constructor_declaration : Ast.ctyp Gram.Entry.t - - val constructor_declarations : Ast.ctyp Gram.Entry.t - - val ctyp : Ast.ctyp Gram.Entry.t - - val ctyp_quot : Ast.ctyp Gram.Entry.t - - val cvalue_binding : Ast.expr Gram.Entry.t - - val direction_flag : Ast.direction_flag Gram.Entry.t - - val direction_flag_quot : Ast.direction_flag Gram.Entry.t - - val dummy : unit Gram.Entry.t - - val eq_expr : (string -> Ast.patt -> Ast.patt) Gram.Entry.t - - val expr : Ast.expr Gram.Entry.t - - val expr_eoi : Ast.expr Gram.Entry.t - - val expr_quot : Ast.expr Gram.Entry.t - - val field_expr : Ast.rec_binding Gram.Entry.t - - val field_expr_list : Ast.rec_binding Gram.Entry.t - - val fun_binding : Ast.expr Gram.Entry.t - - val fun_def : Ast.expr Gram.Entry.t - - val ident : Ast.ident Gram.Entry.t - - val ident_quot : Ast.ident Gram.Entry.t - - val ipatt : Ast.patt Gram.Entry.t - - val ipatt_tcon : Ast.patt Gram.Entry.t - - val label : string Gram.Entry.t - - val label_declaration : Ast.ctyp Gram.Entry.t - - val label_declaration_list : Ast.ctyp Gram.Entry.t - - val label_expr : Ast.rec_binding Gram.Entry.t - - val label_expr_list : Ast.rec_binding Gram.Entry.t - - val label_ipatt : Ast.patt Gram.Entry.t - - val label_ipatt_list : Ast.patt Gram.Entry.t - - val label_longident : Ast.ident Gram.Entry.t - - val label_patt : Ast.patt Gram.Entry.t - - val label_patt_list : Ast.patt Gram.Entry.t - - val labeled_ipatt : Ast.patt Gram.Entry.t - - val let_binding : Ast.binding Gram.Entry.t - - val meth_list : (Ast.ctyp * Ast.row_var_flag) Gram.Entry.t - - val meth_decl : Ast.ctyp Gram.Entry.t - - val module_binding : Ast.module_binding Gram.Entry.t - - val module_binding0 : Ast.module_expr Gram.Entry.t - - val module_binding_quot : Ast.module_binding Gram.Entry.t - - val module_declaration : Ast.module_type Gram.Entry.t - - val module_expr : Ast.module_expr Gram.Entry.t - - val module_expr_quot : Ast.module_expr Gram.Entry.t - - val module_longident : Ast.ident Gram.Entry.t - - val module_longident_with_app : Ast.ident Gram.Entry.t - - val module_rec_declaration : Ast.module_binding Gram.Entry.t - - val module_type : Ast.module_type Gram.Entry.t - - val package_type : Ast.module_type Gram.Entry.t - - val module_type_quot : Ast.module_type Gram.Entry.t - - val more_ctyp : Ast.ctyp Gram.Entry.t - - val name_tags : Ast.ctyp Gram.Entry.t - - val opt_as_lident : string Gram.Entry.t - - val opt_class_self_patt : Ast.patt Gram.Entry.t - - val opt_class_self_type : Ast.ctyp Gram.Entry.t - - val opt_comma_ctyp : Ast.ctyp Gram.Entry.t - - val opt_dot_dot : Ast.row_var_flag Gram.Entry.t - - val row_var_flag_quot : Ast.row_var_flag Gram.Entry.t - - val opt_eq_ctyp : Ast.ctyp Gram.Entry.t - - val opt_expr : Ast.expr Gram.Entry.t - - val opt_meth_list : Ast.ctyp Gram.Entry.t - - val opt_mutable : Ast.mutable_flag Gram.Entry.t - - val mutable_flag_quot : Ast.mutable_flag Gram.Entry.t - - val opt_override : Ast.override_flag Gram.Entry.t - - val override_flag_quot : Ast.override_flag Gram.Entry.t - - val opt_polyt : Ast.ctyp Gram.Entry.t - - val opt_private : Ast.private_flag Gram.Entry.t - - val private_flag_quot : Ast.private_flag Gram.Entry.t - - val opt_rec : Ast.rec_flag Gram.Entry.t - - val rec_flag_quot : Ast.rec_flag Gram.Entry.t - - val opt_virtual : Ast.virtual_flag Gram.Entry.t - - val virtual_flag_quot : Ast.virtual_flag Gram.Entry.t - - val opt_when_expr : Ast.expr Gram.Entry.t - - val patt : Ast.patt Gram.Entry.t - - val patt_as_patt_opt : Ast.patt Gram.Entry.t - - val patt_eoi : Ast.patt Gram.Entry.t - - val patt_quot : Ast.patt Gram.Entry.t - - val patt_tcon : Ast.patt Gram.Entry.t - - val phrase : Ast.str_item Gram.Entry.t - - val poly_type : Ast.ctyp Gram.Entry.t - - val row_field : Ast.ctyp Gram.Entry.t - - val sem_expr : Ast.expr Gram.Entry.t - - val sem_expr_for_list : (Ast.expr -> Ast.expr) Gram.Entry.t - - val sem_patt : Ast.patt Gram.Entry.t - - val sem_patt_for_list : (Ast.patt -> Ast.patt) Gram.Entry.t - - val semi : unit Gram.Entry.t - - val sequence : Ast.expr Gram.Entry.t - - val do_sequence : Ast.expr Gram.Entry.t - - val sig_item : Ast.sig_item Gram.Entry.t - - val sig_item_quot : Ast.sig_item Gram.Entry.t - - val sig_items : Ast.sig_item Gram.Entry.t - - val star_ctyp : Ast.ctyp Gram.Entry.t - - val str_item : Ast.str_item Gram.Entry.t - - val str_item_quot : Ast.str_item Gram.Entry.t - - val str_items : Ast.str_item Gram.Entry.t - - val type_constraint : unit Gram.Entry.t - - val type_declaration : Ast.ctyp Gram.Entry.t - - val type_ident_and_parameters : - (string * (Ast.ctyp list)) Gram.Entry.t - - val type_kind : Ast.ctyp Gram.Entry.t - - val type_longident : Ast.ident Gram.Entry.t - - val type_longident_and_parameters : Ast.ctyp Gram.Entry.t - - val type_parameter : Ast.ctyp Gram.Entry.t - - val type_parameters : (Ast.ctyp -> Ast.ctyp) Gram.Entry.t - - val typevars : Ast.ctyp Gram.Entry.t - - val val_longident : Ast.ident Gram.Entry.t - - val value_let : unit Gram.Entry.t - - val value_val : unit Gram.Entry.t - - val with_constr : Ast.with_constr Gram.Entry.t - - val with_constr_quot : Ast.with_constr Gram.Entry.t - - val prefixop : Ast.expr Gram.Entry.t - - val infixop0 : Ast.expr Gram.Entry.t - - val infixop1 : Ast.expr Gram.Entry.t - - val infixop2 : Ast.expr Gram.Entry.t - - val infixop3 : Ast.expr Gram.Entry.t - - val infixop4 : Ast.expr Gram.Entry.t - - end - - module type SyntaxExtension = - functor (Syn : Syntax) -> Syntax with module Loc = Syn.Loc - and module Ast = Syn.Ast and module Token = Syn.Token - and module Gram = Syn.Gram and module Quotation = Syn.Quotation - - end - -module ErrorHandler : - sig - val print : Format.formatter -> exn -> unit - - val try_print : Format.formatter -> exn -> unit - - val to_string : exn -> string - - val try_to_string : exn -> string - - val register : (Format.formatter -> exn -> unit) -> unit - - module Register (Error : Sig.Error) : sig end - - module ObjTools : - sig - val print : Format.formatter -> Obj.t -> unit - - val print_desc : Format.formatter -> Obj.t -> unit - - val to_string : Obj.t -> string - - val desc : Obj.t -> string - - end - - end = - struct - open Format - - module ObjTools = - struct - let desc obj = - if Obj.is_block obj - then "tag = " ^ (string_of_int (Obj.tag obj)) - else "int_val = " ^ (string_of_int (Obj.obj obj)) - - let rec to_string r = - if Obj.is_int r - then - (let i : int = Obj.magic r - in (string_of_int i) ^ (" | CstTag" ^ (string_of_int (i + 1)))) - else - (let rec get_fields acc = - function - | 0 -> acc - | n -> let n = n - 1 in get_fields ((Obj.field r n) :: acc) n in - let rec is_list r = - if Obj.is_int r - then r = (Obj.repr 0) - else - (let s = Obj.size r - and t = Obj.tag r - in (t = 0) && ((s = 2) && (is_list (Obj.field r 1)))) in - let rec get_list r = - if Obj.is_int r - then [] - else - (let h = Obj.field r 0 - and t = get_list (Obj.field r 1) - in h :: t) in - let opaque name = "<" ^ (name ^ ">") in - let s = Obj.size r - and t = Obj.tag r - in - match t with - | _ when is_list r -> - let fields = get_list r - in - "[" ^ - ((String.concat "; " (List.map to_string fields)) ^ - "]") - | 0 -> - let fields = get_fields [] s - in - "(" ^ - ((String.concat ", " (List.map to_string fields)) ^ - ")") - | x when x = Obj.lazy_tag -> opaque "lazy" - | x when x = Obj.closure_tag -> opaque "closure" - | x when x = Obj.object_tag -> - let fields = get_fields [] s in - let (_class, id, slots) = - (match fields with - | h :: h' :: t -> (h, h', t) - | _ -> assert false) - in - "Object #" ^ - ((to_string id) ^ - (" (" ^ - ((String.concat ", " (List.map to_string slots)) - ^ ")"))) - | x when x = Obj.infix_tag -> opaque "infix" - | x when x = Obj.forward_tag -> opaque "forward" - | x when x < Obj.no_scan_tag -> - let fields = get_fields [] s - in - "Tag" ^ - ((string_of_int t) ^ - (" (" ^ - ((String.concat ", " (List.map to_string fields)) - ^ ")"))) - | x when x = Obj.string_tag -> - "\"" ^ ((String.escaped (Obj.magic r : string)) ^ "\"") - | x when x = Obj.double_tag -> - Camlp4_import.Oprint.float_repres (Obj.magic r : float) - | x when x = Obj.abstract_tag -> opaque "abstract" - | x when x = Obj.custom_tag -> opaque "custom" - | x when x = Obj.final_tag -> opaque "final" - | _ -> - failwith - ("ObjTools.to_string: unknown tag (" ^ - ((string_of_int t) ^ ")"))) - - let print ppf x = fprintf ppf "%s" (to_string x) - - let print_desc ppf x = fprintf ppf "%s" (desc x) - - end - - let default_handler ppf x = - let x = Obj.repr x - in - (fprintf ppf "Camlp4: Uncaught exception: %s" - (Obj.obj (Obj.field (Obj.field x 0) 0) : string); - if (Obj.size x) > 1 - then - (pp_print_string ppf " ("; - for i = 1 to (Obj.size x) - 1 do - if i > 1 then pp_print_string ppf ", " else (); - ObjTools.print ppf (Obj.field x i) - done; - pp_print_char ppf ')') - else (); - fprintf ppf "@.") - - let handler = - ref (fun ppf default_handler exn -> default_handler ppf exn) - - let register f = - let current_handler = !handler - in - handler := - fun ppf default_handler exn -> - try f ppf exn - with | exn -> current_handler ppf default_handler exn - - module Register (Error : Sig.Error) = - struct - let _ = - let current_handler = !handler - in - handler := - fun ppf default_handler -> - function - | Error.E x -> Error.print ppf x - | x -> current_handler ppf default_handler x - - end - - let gen_print ppf default_handler = - function - | Out_of_memory -> fprintf ppf "Out of memory" - | Assert_failure ((file, line, char)) -> - fprintf ppf "Assertion failed, file %S, line %d, char %d" file line - char - | Match_failure ((file, line, char)) -> - fprintf ppf "Pattern matching failed, file %S, line %d, char %d" - file line char - | Failure str -> fprintf ppf "Failure: %S" str - | Invalid_argument str -> fprintf ppf "Invalid argument: %S" str - | Sys_error str -> fprintf ppf "I/O error: %S" str - | Stream.Failure -> fprintf ppf "Parse failure" - | Stream.Error str -> fprintf ppf "Parse error: %s" str - | x -> !handler ppf default_handler x - - let print ppf = gen_print ppf default_handler - - let try_print ppf = gen_print ppf (fun _ -> raise) - - let to_string exn = - let buf = Buffer.create 128 in - let () = bprintf buf "%a" print exn in Buffer.contents buf - - let try_to_string exn = - let buf = Buffer.create 128 in - let () = bprintf buf "%a" try_print exn in Buffer.contents buf - - end - -module Struct = - struct - module Loc : sig include Sig.Loc - end = - struct - open Format - - type pos = { line : int; bol : int; off : int } - - type t = - { file_name : string; start : pos; stop : pos; ghost : bool - } - - let dump_sel f x = - let s = - match x with - | `start -> "`start" - | `stop -> "`stop" - | `both -> "`both" - | _ -> "" - in pp_print_string f s - - let dump_pos f x = - fprintf f "@[{ line = %d ;@ bol = %d ;@ off = %d } : pos@]" - x.line x.bol x.off - - let dump_long f x = - fprintf f - "@[{ file_name = %s ;@ start = %a (%d-%d);@ stop = %a (%d);@ ghost = %b@ } : Loc.t@]" - x.file_name dump_pos x.start (x.start.off - x.start.bol) - (x.stop.off - x.start.bol) dump_pos x.stop - (x.stop.off - x.stop.bol) x.ghost - - let dump f x = - fprintf f "[%S: %d:%d-%d %d:%d%t]" x.file_name x.start.line - (x.start.off - x.start.bol) (x.stop.off - x.start.bol) - x.stop.line (x.stop.off - x.stop.bol) - (fun o -> if x.ghost then fprintf o " (ghost)" else ()) - - let start_pos = { line = 1; bol = 0; off = 0; } - - let ghost = - { - file_name = "ghost-location"; - start = start_pos; - stop = start_pos; - ghost = true; - } - - let mk file_name = - { - file_name = file_name; - start = start_pos; - stop = start_pos; - ghost = false; - } - - let of_tuple (file_name, start_line, start_bol, start_off, stop_line, - stop_bol, stop_off, ghost) - = - { - file_name = file_name; - start = { line = start_line; bol = start_bol; off = start_off; }; - stop = { line = stop_line; bol = stop_bol; off = stop_off; }; - ghost = ghost; - } - - let to_tuple { - file_name = file_name; - start = - { - line = start_line; - bol = start_bol; - off = start_off - }; - stop = - { line = stop_line; bol = stop_bol; off = stop_off }; - ghost = ghost - } = - (file_name, start_line, start_bol, start_off, stop_line, stop_bol, - stop_off, ghost) - - let pos_of_lexing_position p = - let pos = - { - line = p.Lexing.pos_lnum; - bol = p.Lexing.pos_bol; - off = p.Lexing.pos_cnum; - } - in pos - - let pos_to_lexing_position p file_name = - { - Lexing.pos_fname = file_name; - pos_lnum = p.line; - pos_bol = p.bol; - pos_cnum = p.off; - } - - let better_file_name a b = - match (a, b) with - | ("", "") -> a - | ("", x) -> x - | (x, "") -> x - | ("-", x) -> x - | (x, "-") -> x - | (x, _) -> x - - let of_lexbuf lb = - let start = Lexing.lexeme_start_p lb - and stop = Lexing.lexeme_end_p lb in - let loc = - { - file_name = - better_file_name start.Lexing.pos_fname stop.Lexing.pos_fname; - start = pos_of_lexing_position start; - stop = pos_of_lexing_position stop; - ghost = false; - } - in loc - - let of_lexing_position pos = - let loc = - { - file_name = pos.Lexing.pos_fname; - start = pos_of_lexing_position pos; - stop = pos_of_lexing_position pos; - ghost = false; - } - in loc - - let to_ocaml_location x = - { - Camlp4_import.Location.loc_start = - pos_to_lexing_position x.start x.file_name; - loc_end = pos_to_lexing_position x.stop x.file_name; - loc_ghost = x.ghost; - } - - let of_ocaml_location { - Camlp4_import.Location.loc_start = a; - loc_end = b; - loc_ghost = g - } = - let res = - { - file_name = - better_file_name a.Lexing.pos_fname b.Lexing.pos_fname; - start = pos_of_lexing_position a; - stop = pos_of_lexing_position b; - ghost = g; - } - in res - - let start_pos x = pos_to_lexing_position x.start x.file_name - - let stop_pos x = pos_to_lexing_position x.stop x.file_name - - let merge a b = - if a == b - then a - else - (let r = - match ((a.ghost), (b.ghost)) with - | (false, false) -> { (a) with stop = b.stop; } - | (true, true) -> { (a) with stop = b.stop; } - | (true, _) -> { (a) with stop = b.stop; } - | (_, true) -> { (b) with start = a.start; } - in r) - - let join x = { (x) with stop = x.start; } - - let map f start_stop_both x = - match start_stop_both with - | `start -> { (x) with start = f x.start; } - | `stop -> { (x) with stop = f x.stop; } - | `both -> { (x) with start = f x.start; stop = f x.stop; } - - let move_pos chars x = { (x) with off = x.off + chars; } - - let move s chars x = map (move_pos chars) s x - - let move_line lines x = - let move_line_pos x = - { (x) with line = x.line + lines; bol = x.off; } - in map move_line_pos `both x - - let shift width x = - { (x) with start = x.stop; stop = move_pos width x.stop; } - - let file_name x = x.file_name - - let start_line x = x.start.line - - let stop_line x = x.stop.line - - let start_bol x = x.start.bol - - let stop_bol x = x.stop.bol - - let start_off x = x.start.off - - let stop_off x = x.stop.off - - let is_ghost x = x.ghost - - let set_file_name s x = { (x) with file_name = s; } - - let ghostify x = { (x) with ghost = true; } - - let make_absolute x = - let pwd = Sys.getcwd () - in - if Filename.is_relative x.file_name - then { (x) with file_name = Filename.concat pwd x.file_name; } - else x - - let strictly_before x y = - let b = (x.stop.off < y.start.off) && (x.file_name = y.file_name) - in b - - let to_string x = - let (a, b) = ((x.start), (x.stop)) in - let res = - sprintf "File \"%s\", line %d, characters %d-%d" x.file_name - a.line (a.off - a.bol) (b.off - a.bol) - in - if x.start.line <> x.stop.line - then - sprintf "%s (end at line %d, character %d)" res x.stop.line - (b.off - b.bol) - else res - - let print out x = pp_print_string out (to_string x) - - let check x msg = - if - ((start_line x) > (stop_line x)) || - (((start_bol x) > (stop_bol x)) || - (((start_off x) > (stop_off x)) || - (((start_line x) < 0) || - (((stop_line x) < 0) || - (((start_bol x) < 0) || - (((stop_bol x) < 0) || - (((start_off x) < 0) || ((stop_off x) < 0)))))))) - then - (eprintf "*** Warning: (%s) strange positions ***\n%a@\n" msg - print x; - false) - else true - - exception Exc_located of t * exn - - let _ = - ErrorHandler.register - (fun ppf -> - function - | Exc_located (loc, exn) -> - fprintf ppf "%a:@\n%a" print loc ErrorHandler.print exn - | exn -> raise exn) - - let name = ref "_loc" - - let raise loc exc = - match exc with - | Exc_located (_, _) -> raise exc - | _ -> raise (Exc_located (loc, exc)) - - end - - module Token : - sig - module Make (Loc : Sig.Loc) : Sig.Camlp4Token with module Loc = Loc - - module Eval : - sig - val char : string -> char - - val string : ?strict: unit -> string -> string - - end - - end = - struct - open Format - - module Make (Loc : Sig.Loc) : Sig.Camlp4Token with module Loc = Loc = - struct - module Loc = Loc - - open Sig - - type t = camlp4_token - - type token = t - - let to_string = - function - | KEYWORD s -> sprintf "KEYWORD %S" s - | SYMBOL s -> sprintf "SYMBOL %S" s - | LIDENT s -> sprintf "LIDENT %S" s - | UIDENT s -> sprintf "UIDENT %S" s - | INT (_, s) -> sprintf "INT %s" s - | INT32 (_, s) -> sprintf "INT32 %sd" s - | INT64 (_, s) -> sprintf "INT64 %sd" s - | NATIVEINT (_, s) -> sprintf "NATIVEINT %sd" s - | FLOAT (_, s) -> sprintf "FLOAT %s" s - | CHAR (_, s) -> sprintf "CHAR '%s'" s - | STRING (_, s) -> sprintf "STRING \"%s\"" s - | LABEL s -> sprintf "LABEL %S" s - | OPTLABEL s -> sprintf "OPTLABEL %S" s - | ANTIQUOT (n, s) -> sprintf "ANTIQUOT %s: %S" n s - | QUOTATION x -> - sprintf - "QUOTATION { q_name=%S; q_loc=%S; q_shift=%d; q_contents=%S }" - x.q_name x.q_loc x.q_shift x.q_contents - | COMMENT s -> sprintf "COMMENT %S" s - | BLANKS s -> sprintf "BLANKS %S" s - | NEWLINE -> sprintf "NEWLINE" - | EOI -> sprintf "EOI" - | ESCAPED_IDENT s -> sprintf "ESCAPED_IDENT %S" s - | LINE_DIRECTIVE (i, None) -> sprintf "LINE_DIRECTIVE %d" i - | LINE_DIRECTIVE (i, (Some s)) -> - sprintf "LINE_DIRECTIVE %d %S" i s - - let print ppf x = pp_print_string ppf (to_string x) - - let match_keyword kwd = - function | KEYWORD kwd' when kwd = kwd' -> true | _ -> false - - let extract_string = - function - | KEYWORD s | SYMBOL s | LIDENT s | UIDENT s | INT (_, s) | - INT32 (_, s) | INT64 (_, s) | NATIVEINT (_, s) | - FLOAT (_, s) | CHAR (_, s) | STRING (_, s) | LABEL s | - OPTLABEL s | COMMENT s | BLANKS s | ESCAPED_IDENT s -> s - | tok -> - invalid_arg - ("Cannot extract a string from this token: " ^ - (to_string tok)) - - module Error = - struct - type t = - | Illegal_token of string - | Keyword_as_label of string - | Illegal_token_pattern of string * string - | Illegal_constructor of string - - exception E of t - - let print ppf = - function - | Illegal_token s -> fprintf ppf "Illegal token (%s)" s - | Keyword_as_label kwd -> - fprintf ppf - "`%s' is a keyword, it cannot be used as label name" - kwd - | Illegal_token_pattern (p_con, p_prm) -> - fprintf ppf "Illegal token pattern: %s %S" p_con p_prm - | Illegal_constructor con -> - fprintf ppf "Illegal constructor %S" con - - let to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b - - end - - let _ = let module M = ErrorHandler.Register(Error) in () - - module Filter = - struct - type token_filter = (t, Loc.t) stream_filter - - type t = - { is_kwd : string -> bool; mutable filter : token_filter - } - - let err error loc = - raise (Loc.Exc_located (loc, (Error.E error))) - - let keyword_conversion tok is_kwd = - match tok with - | SYMBOL s | LIDENT s | UIDENT s when is_kwd s -> KEYWORD s - | ESCAPED_IDENT s -> LIDENT s - | _ -> tok - - let check_keyword_as_label tok loc is_kwd = - let s = - match tok with | LABEL s -> s | OPTLABEL s -> s | _ -> "" - in - if (s <> "") && (is_kwd s) - then err (Error.Keyword_as_label s) loc - else () - - let check_unknown_keywords tok loc = - match tok with - | SYMBOL s -> err (Error.Illegal_token s) loc - | _ -> () - - let error_no_respect_rules p_con p_prm = - raise - (Error.E (Error.Illegal_token_pattern (p_con, p_prm))) - - let check_keyword _ = true - - let error_on_unknown_keywords = ref false - - let rec ignore_layout (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some - (((COMMENT _ | BLANKS _ | NEWLINE | - LINE_DIRECTIVE (_, _)), - _)) - -> (Stream.junk __strm; ignore_layout __strm) - | Some x -> - (Stream.junk __strm; - let s = __strm - in - Stream.icons x - (Stream.slazy (fun _ -> ignore_layout s))) - | _ -> Stream.sempty - - let mk is_kwd = { is_kwd = is_kwd; filter = ignore_layout; } - - let filter x = - let f tok loc = - let tok = keyword_conversion tok x.is_kwd - in - (check_keyword_as_label tok loc x.is_kwd; - if !error_on_unknown_keywords - then check_unknown_keywords tok loc - else (); - (tok, loc)) in - let rec filter (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some ((tok, loc)) -> - (Stream.junk __strm; - let s = __strm - in - Stream.lcons (fun _ -> f tok loc) - (Stream.slazy (fun _ -> filter s))) - | _ -> Stream.sempty in - let rec tracer (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some (((_tok, _loc) as x)) -> - (Stream.junk __strm; - let xs = __strm - in - Stream.icons x (Stream.slazy (fun _ -> tracer xs))) - | _ -> Stream.sempty - in fun strm -> tracer (x.filter (filter strm)) - - let define_filter x f = x.filter <- f x.filter - - let keyword_added _ _ _ = () - - let keyword_removed _ _ = () - - end - - end - - module Eval = - struct - let valch x = (Char.code x) - (Char.code '0') - - let valch_hex x = - let d = Char.code x - in - if d >= 97 - then d - 87 - else if d >= 65 then d - 55 else d - 48 - - let rec skip_indent (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some (' ' | '\t') -> (Stream.junk __strm; skip_indent __strm) - | _ -> () - - let skip_opt_linefeed (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some '\n' -> (Stream.junk __strm; ()) - | _ -> () - - let chr c = - if (c < 0) || (c > 255) - then failwith "invalid char token" - else Char.chr c - - let rec backslash (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some '\n' -> (Stream.junk __strm; '\n') - | Some '\r' -> (Stream.junk __strm; '\r') - | Some 'n' -> (Stream.junk __strm; '\n') - | Some 'r' -> (Stream.junk __strm; '\r') - | Some 't' -> (Stream.junk __strm; '\t') - | Some 'b' -> (Stream.junk __strm; '\b') - | Some '\\' -> (Stream.junk __strm; '\\') - | Some '"' -> (Stream.junk __strm; '"') - | Some '\'' -> (Stream.junk __strm; '\'') - | Some ' ' -> (Stream.junk __strm; ' ') - | Some (('0' .. '9' as c1)) -> - (Stream.junk __strm; - (match Stream.peek __strm with - | Some (('0' .. '9' as c2)) -> - (Stream.junk __strm; - (match Stream.peek __strm with - | Some (('0' .. '9' as c3)) -> - (Stream.junk __strm; - chr - (((100 * (valch c1)) + (10 * (valch c2))) + - (valch c3))) - | _ -> raise (Stream.Error ""))) - | _ -> raise (Stream.Error ""))) - | Some 'x' -> - (Stream.junk __strm; - (match Stream.peek __strm with - | Some (('0' .. '9' | 'a' .. 'f' | 'A' .. 'F' as c1)) -> - (Stream.junk __strm; - (match Stream.peek __strm with - | Some - (('0' .. '9' | 'a' .. 'f' | 'A' .. 'F' as c2)) - -> - (Stream.junk __strm; - chr ((16 * (valch_hex c1)) + (valch_hex c2))) - | _ -> raise (Stream.Error ""))) - | _ -> raise (Stream.Error ""))) - | _ -> raise Stream.Failure - - let rec backslash_in_string strict store (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some '\n' -> (Stream.junk __strm; skip_indent __strm) - | Some '\r' -> - (Stream.junk __strm; - let s = __strm in (skip_opt_linefeed s; skip_indent s)) - | _ -> - (match try Some (backslash __strm) - with | Stream.Failure -> None - with - | Some x -> store x - | _ -> - (match Stream.peek __strm with - | Some c when not strict -> - (Stream.junk __strm; store '\\'; store c) - | _ -> failwith "invalid string token")) - - let char s = - if (String.length s) = 1 - then s.[0] - else - if (String.length s) = 0 - then failwith "invalid char token" - else - (let (__strm : _ Stream.t) = Stream.of_string s - in - match Stream.peek __strm with - | Some '\\' -> - (Stream.junk __strm; - (try backslash __strm - with | Stream.Failure -> raise (Stream.Error ""))) - | _ -> failwith "invalid char token") - - let string ?strict s = - let buf = Buffer.create 23 in - let store = Buffer.add_char buf in - let rec parse (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some '\\' -> - (Stream.junk __strm; - let _ = - (try backslash_in_string (strict <> None) store __strm - with | Stream.Failure -> raise (Stream.Error "")) - in parse __strm) - | Some c -> - (Stream.junk __strm; - let s = __strm in (store c; parse s)) - | _ -> Buffer.contents buf - in parse (Stream.of_string s) - - end - - end - - module Lexer = - struct - module TokenEval = Token.Eval - - module Make (Token : Sig.Camlp4Token) = - struct - module Loc = Token.Loc - - module Token = Token - - open Lexing - - open Sig - - module Error = - struct - type t = - | Illegal_character of char - | Illegal_escape of string - | Unterminated_comment - | Unterminated_string - | Unterminated_quotation - | Unterminated_antiquot - | Unterminated_string_in_comment - | Comment_start - | Comment_not_end - | Literal_overflow of string - - exception E of t - - open Format - - let print ppf = - function - | Illegal_character c -> - fprintf ppf "Illegal character (%s)" (Char.escaped c) - | Illegal_escape s -> - fprintf ppf - "Illegal backslash escape in string or character (%s)" - s - | Unterminated_comment -> - fprintf ppf "Comment not terminated" - | Unterminated_string -> - fprintf ppf "String literal not terminated" - | Unterminated_string_in_comment -> - fprintf ppf - "This comment contains an unterminated string literal" - | Unterminated_quotation -> - fprintf ppf "Quotation not terminated" - | Unterminated_antiquot -> - fprintf ppf "Antiquotation not terminated" - | Literal_overflow ty -> - fprintf ppf - "Integer literal exceeds the range of representable integers of type %s" - ty - | Comment_start -> - fprintf ppf "this is the start of a comment" - | Comment_not_end -> - fprintf ppf "this is not the end of a comment" - - let to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b - - end - - let _ = let module M = ErrorHandler.Register(Error) in () - - open Error - - type context = - { loc : Loc.t; in_comment : bool; quotations : bool; - antiquots : bool; lexbuf : lexbuf; buffer : Buffer.t - } - - let default_context lb = - { - loc = Loc.ghost; - in_comment = false; - quotations = true; - antiquots = false; - lexbuf = lb; - buffer = Buffer.create 256; - } - - let store c = Buffer.add_string c.buffer (Lexing.lexeme c.lexbuf) - - let istore_char c i = - Buffer.add_char c.buffer (Lexing.lexeme_char c.lexbuf i) - - let buff_contents c = - let contents = Buffer.contents c.buffer - in (Buffer.reset c.buffer; contents) - - let loc c = Loc.merge c.loc (Loc.of_lexbuf c.lexbuf) - - let quotations c = c.quotations - - let antiquots c = c.antiquots - - let is_in_comment c = c.in_comment - - let in_comment c = { (c) with in_comment = true; } - - let set_start_p c = c.lexbuf.lex_start_p <- Loc.start_pos c.loc - - let move_start_p shift c = - let p = c.lexbuf.lex_start_p - in - c.lexbuf.lex_start_p <- - { (p) with pos_cnum = p.pos_cnum + shift; } - - let update_loc c = { (c) with loc = Loc.of_lexbuf c.lexbuf; } - - let with_curr_loc f c = f (update_loc c) c.lexbuf - - let parse_nested f c = - (with_curr_loc f c; set_start_p c; buff_contents c) - - let shift n c = { (c) with loc = Loc.move `both n c.loc; } - - let store_parse f c = (store c; f c c.lexbuf) - - let parse f c = f c c.lexbuf - - let mk_quotation quotation c name loc shift = - let s = parse_nested quotation (update_loc c) in - let contents = String.sub s 0 ((String.length s) - 2) - in - QUOTATION - { - q_name = name; - q_loc = loc; - q_shift = shift; - q_contents = contents; - } - - let update_loc c file line absolute chars = - let lexbuf = c.lexbuf in - let pos = lexbuf.lex_curr_p in - let new_file = - match file with | None -> pos.pos_fname | Some s -> s - in - lexbuf.lex_curr_p <- - { - (pos) - with - pos_fname = new_file; - pos_lnum = if absolute then line else pos.pos_lnum + line; - pos_bol = pos.pos_cnum - chars; - } - - let cvt_int_literal s = - (int_of_string ("-" ^ s)) - - let cvt_int32_literal s = Int32.neg (Int32.of_string ("-" ^ s)) - - let cvt_int64_literal s = Int64.neg (Int64.of_string ("-" ^ s)) - - let cvt_nativeint_literal s = - Nativeint.neg (Nativeint.of_string ("-" ^ s)) - - let err error loc = - raise (Loc.Exc_located (loc, (Error.E error))) - - let warn error loc = - Format.eprintf "Warning: %a: %a@." Loc.print loc Error.print - error - - let __ocaml_lex_tables = - { - Lexing.lex_base = - "\000\000\223\255\224\255\224\000\226\255\253\000\035\001\072\001\ - \109\001\146\001\091\000\183\001\068\000\190\001\218\001\227\255\ - \122\000\002\002\071\002\110\002\176\000\244\255\129\002\162\002\ - \235\002\187\003\154\004\246\004\124\000\001\000\255\255\198\005\ - \253\255\150\006\252\255\245\255\246\255\247\255\253\000\224\000\ - \086\000\091\000\054\003\006\004\029\002\237\001\182\004\109\000\ - \118\007\091\000\253\000\093\000\243\255\242\255\241\255\106\005\ - \077\003\108\000\087\003\017\006\151\007\218\007\001\008\068\008\ - \107\008\107\000\239\255\126\008\075\001\210\008\249\008\060\009\ - \232\255\231\255\230\255\099\009\166\009\205\009\016\010\055\010\ - \249\001\228\255\229\255\238\255\090\010\127\010\164\010\201\010\ - \238\010\019\011\056\011\091\011\128\011\165\011\202\011\239\011\ - \020\012\057\012\094\012\011\007\136\005\004\000\233\255\008\000\ - \054\001\245\002\009\000\005\000\233\255\131\012\138\012\175\012\ - \212\012\249\012\000\013\037\013\068\013\096\013\133\013\138\013\ - \205\013\242\013\023\014\085\014\241\255\006\000\242\255\243\255\ - \148\002\251\255\047\015\123\000\109\000\125\000\255\255\254\255\ - \253\255\111\015\046\016\254\016\206\017\174\018\129\000\017\001\ - \130\000\141\000\249\255\248\255\247\255\237\006\109\003\143\000\ - \246\255\035\004\145\000\245\255\160\014\149\000\244\255\086\004\ - \247\255\248\255\007\000\249\255\201\018\255\255\250\255\121\016\ - \154\004\253\255\091\001\057\001\171\004\252\255\073\017\251\255\ - \240\018\051\019\018\020\048\020\255\255\015\021\238\021\015\022\ - \079\022\255\255\031\023\254\255\164\001\251\255\010\000\252\255\ - \253\255\128\000\079\001\255\255\095\023\030\024\238\024\190\025\ - \254\255\190\026\253\255\254\255\153\001\143\027\110\028\255\255\ - \167\001\062\029\206\001\251\255\080\001\013\000\253\255\254\255\ - \255\255\252\255\126\029\061\030\013\031\221\031"; - Lexing.lex_backtrk = - "\255\255\255\255\255\255\030\000\255\255\028\000\030\000\030\000\ - \030\000\030\000\028\000\028\000\028\000\028\000\028\000\255\255\ - \028\000\030\000\030\000\028\000\028\000\255\255\006\000\006\000\ - \005\000\004\000\030\000\030\000\001\000\000\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\007\000\ - \255\255\255\255\255\255\006\000\006\000\006\000\007\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\014\000\ - \014\000\014\000\255\255\255\255\255\255\255\255\255\255\028\000\ - \028\000\015\000\255\255\028\000\255\255\255\255\028\000\255\255\ - \255\255\255\255\255\255\028\000\028\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\030\000\021\000\020\000\ - \018\000\030\000\018\000\018\000\018\000\018\000\028\000\018\000\ - \255\255\019\000\030\000\255\255\255\255\022\000\255\255\255\255\ - \255\255\255\255\255\255\022\000\255\255\255\255\255\255\255\255\ - \028\000\255\255\028\000\255\255\028\000\028\000\028\000\028\000\ - \030\000\030\000\030\000\255\255\255\255\013\000\255\255\255\255\ - \014\000\255\255\003\000\014\000\014\000\014\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\005\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\006\000\255\255\008\000\255\255\255\255\005\000\ - \005\000\255\255\001\000\001\000\255\255\255\255\255\255\255\255\ - \000\000\001\000\001\000\255\255\255\255\002\000\002\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\003\000\255\255\ - \255\255\004\000\004\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\002\000\002\000\002\000\255\255\ - \255\255\255\255\255\255\255\255\004\000\002\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255"; - Lexing.lex_default = - "\001\000\000\000\000\000\255\255\000\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\000\000\ - \255\255\255\255\255\255\255\255\049\000\000\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\000\000\255\255\ - \000\000\255\255\000\000\000\000\000\000\000\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \054\000\255\255\255\255\255\255\000\000\000\000\000\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\000\000\255\255\255\255\255\255\255\255\255\255\ - \000\000\000\000\000\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\000\000\000\000\000\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\103\000\255\255\255\255\000\000\103\000\ - \104\000\103\000\106\000\255\255\000\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\124\000\000\000\255\255\000\000\000\000\ - \142\000\000\000\255\255\255\255\255\255\255\255\000\000\000\000\ - \000\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\000\000\000\000\000\000\255\255\255\255\255\255\ - \000\000\255\255\255\255\000\000\255\255\255\255\000\000\160\000\ - \000\000\000\000\255\255\000\000\166\000\000\000\000\000\255\255\ - \255\255\000\000\255\255\255\255\255\255\000\000\255\255\000\000\ - \255\255\255\255\255\255\255\255\000\000\255\255\255\255\255\255\ - \255\255\000\000\255\255\000\000\189\000\000\000\255\255\000\000\ - \000\000\255\255\255\255\000\000\255\255\255\255\255\255\255\255\ - \000\000\205\000\000\000\000\000\255\255\255\255\255\255\000\000\ - \255\255\255\255\211\000\000\000\255\255\255\255\000\000\000\000\ - \000\000\000\000\255\255\255\255\255\255\255\255"; - Lexing.lex_trans = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\028\000\030\000\030\000\028\000\029\000\102\000\108\000\ - \126\000\163\000\102\000\108\000\191\000\101\000\107\000\214\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \028\000\003\000\021\000\016\000\004\000\009\000\009\000\020\000\ - \019\000\005\000\018\000\003\000\015\000\003\000\014\000\009\000\ - \023\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ - \022\000\022\000\013\000\012\000\017\000\006\000\007\000\026\000\ - \009\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\011\000\003\000\005\000\009\000\025\000\ - \015\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\010\000\008\000\005\000\027\000\015\000\ - \117\000\117\000\053\000\100\000\052\000\028\000\045\000\045\000\ - \028\000\115\000\117\000\044\000\044\000\044\000\044\000\044\000\ - \044\000\044\000\044\000\053\000\066\000\118\000\135\000\116\000\ - \115\000\115\000\100\000\117\000\028\000\046\000\046\000\046\000\ - \046\000\046\000\046\000\046\000\046\000\046\000\046\000\134\000\ - \148\000\147\000\099\000\099\000\099\000\099\000\099\000\099\000\ - \099\000\099\000\099\000\099\000\146\000\138\000\152\000\136\000\ - \155\000\117\000\051\000\137\000\158\000\050\000\200\000\000\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\118\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\000\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \002\000\003\000\000\000\000\000\003\000\003\000\003\000\051\000\ - \255\255\255\255\003\000\003\000\048\000\003\000\003\000\003\000\ - \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ - \039\000\039\000\003\000\144\000\003\000\003\000\003\000\003\000\ - \003\000\000\000\096\000\096\000\052\000\038\000\084\000\000\000\ - \047\000\000\000\047\000\084\000\096\000\046\000\046\000\046\000\ - \046\000\046\000\046\000\046\000\046\000\046\000\046\000\084\000\ - \147\000\084\000\084\000\084\000\003\000\096\000\003\000\039\000\ - \102\000\000\000\171\000\101\000\003\000\038\000\000\000\003\000\ - \009\000\009\000\000\000\000\000\084\000\003\000\003\000\000\000\ - \003\000\006\000\009\000\000\000\068\000\000\000\000\000\068\000\ - \106\000\171\000\084\000\096\000\003\000\085\000\003\000\006\000\ - \006\000\006\000\003\000\009\000\171\000\171\000\000\000\000\000\ - \000\000\003\000\000\000\068\000\003\000\121\000\121\000\000\000\ - \000\000\084\000\003\000\003\000\074\000\003\000\007\000\121\000\ - \000\000\084\000\084\000\171\000\000\000\000\000\000\000\003\000\ - \084\000\009\000\120\000\000\000\007\000\007\000\007\000\003\000\ - \121\000\197\000\219\000\195\000\217\000\000\000\003\000\196\000\ - \218\000\003\000\009\000\009\000\000\000\000\000\005\000\003\000\ - \003\000\000\000\003\000\006\000\009\000\000\000\000\000\085\000\ - \084\000\003\000\000\000\000\000\003\000\005\000\121\000\085\000\ - \000\000\006\000\006\000\006\000\003\000\009\000\191\000\000\000\ - \255\255\190\000\000\000\003\000\000\000\000\000\003\000\009\000\ - \009\000\000\000\208\000\094\000\003\000\003\000\000\000\003\000\ - \009\000\009\000\000\000\000\000\120\000\005\000\003\000\208\000\ - \208\000\003\000\005\000\009\000\098\000\000\000\009\000\009\000\ - \009\000\003\000\009\000\203\000\000\000\208\000\000\000\000\000\ - \214\000\000\000\000\000\213\000\117\000\117\000\000\000\000\000\ - \194\000\203\000\193\000\111\000\111\000\115\000\117\000\005\000\ - \000\000\085\000\005\000\003\000\109\000\111\000\003\000\094\000\ - \009\000\116\000\216\000\116\000\115\000\115\000\000\000\117\000\ - \114\000\000\000\109\000\112\000\112\000\000\000\111\000\111\000\ - \111\000\000\000\080\000\084\000\000\000\080\000\000\000\000\000\ - \112\000\111\000\212\000\000\000\000\000\000\000\098\000\094\000\ - \003\000\000\000\000\000\000\000\110\000\117\000\109\000\109\000\ - \109\000\080\000\111\000\005\000\111\000\045\000\045\000\000\000\ - \000\000\000\000\081\000\003\000\000\000\000\000\003\000\009\000\ - \009\000\000\000\000\000\084\000\003\000\003\000\000\000\003\000\ - \006\000\009\000\000\000\116\000\000\000\000\000\255\255\084\000\ - \111\000\036\000\110\000\005\000\086\000\000\000\088\000\006\000\ - \006\000\003\000\087\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\045\000\044\000\044\000\044\000\ - \044\000\044\000\044\000\044\000\044\000\000\000\110\000\084\000\ - \000\000\037\000\000\000\035\000\000\000\000\000\003\000\084\000\ - \009\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \003\000\036\000\000\000\003\000\003\000\003\000\000\000\000\000\ - \083\000\003\000\003\000\000\000\003\000\003\000\003\000\060\000\ - \000\000\000\000\060\000\000\000\044\000\000\000\085\000\084\000\ - \003\000\003\000\000\000\003\000\003\000\003\000\003\000\003\000\ - \000\000\037\000\000\000\035\000\000\000\000\000\060\000\061\000\ - \000\000\000\000\061\000\064\000\064\000\000\000\000\000\000\000\ - \065\000\061\000\000\000\061\000\062\000\064\000\144\000\000\000\ - \000\000\143\000\000\000\003\000\192\000\003\000\000\000\000\000\ - \063\000\000\000\062\000\062\000\062\000\061\000\064\000\039\000\ - \000\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ - \022\000\022\000\022\000\145\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\003\000\000\000\003\000\038\000\000\000\ - \000\000\000\000\061\000\000\000\064\000\036\000\215\000\000\000\ - \039\000\000\000\022\000\022\000\022\000\022\000\022\000\022\000\ - \022\000\022\000\022\000\022\000\000\000\000\000\000\000\000\000\ - \022\000\000\000\000\000\000\000\040\000\000\000\038\000\038\000\ - \000\000\000\000\063\000\000\000\061\000\037\000\036\000\035\000\ - \141\000\041\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\042\000\000\000\000\000\000\000\105\000\102\000\ - \000\000\022\000\101\000\000\000\040\000\000\000\000\000\038\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\037\000\000\000\ - \035\000\041\000\024\000\000\000\000\000\105\000\000\000\104\000\ - \000\000\000\000\042\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\000\000\000\000\ - \000\000\000\000\024\000\000\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\043\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\049\000\ - \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ - \049\000\000\000\000\000\000\000\255\255\000\000\000\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\153\000\153\000\153\000\ - \153\000\153\000\153\000\153\000\153\000\153\000\153\000\000\000\ - \000\000\000\000\000\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\000\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\025\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\255\255\000\000\000\000\ - \000\000\000\000\000\000\000\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\000\000\000\000\ - \000\000\000\000\025\000\000\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\043\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\000\000\000\000\000\000\ - \000\000\000\000\036\000\154\000\154\000\154\000\154\000\154\000\ - \154\000\154\000\154\000\154\000\154\000\000\000\000\000\000\000\ - \163\000\000\000\000\000\162\000\000\000\043\000\000\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\000\000\000\000\000\000\ - \000\000\000\000\037\000\000\000\035\000\000\000\000\000\000\000\ - \165\000\000\000\000\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\000\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\164\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\003\000\000\000\000\000\003\000\003\000\ - \003\000\000\000\000\000\000\000\003\000\003\000\000\000\003\000\ - \003\000\003\000\172\000\172\000\172\000\172\000\172\000\172\000\ - \172\000\172\000\172\000\172\000\003\000\000\000\003\000\003\000\ - \003\000\003\000\003\000\173\000\173\000\173\000\173\000\173\000\ - \173\000\173\000\173\000\173\000\173\000\000\000\046\000\046\000\ - \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\003\000\000\000\ - \003\000\033\000\000\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\046\000\003\000\003\000\ - \003\000\000\000\003\000\003\000\003\000\000\000\000\000\000\000\ - \003\000\003\000\000\000\003\000\003\000\003\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \003\000\000\000\003\000\003\000\003\000\003\000\003\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\003\000\000\000\003\000\031\000\161\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\000\000\003\000\000\000\003\000\000\000\000\000\000\000\ - \000\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\100\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\059\000\059\000\059\000\059\000\059\000\059\000\ - \059\000\059\000\059\000\059\000\000\000\000\000\000\000\000\000\ - \100\000\000\000\000\000\059\000\059\000\059\000\059\000\059\000\ - \059\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \099\000\099\000\099\000\099\000\099\000\099\000\099\000\099\000\ - \099\000\099\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\059\000\059\000\059\000\059\000\059\000\ - \059\000\000\000\000\000\000\000\000\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \032\000\000\000\000\000\000\000\000\000\000\000\000\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\000\000\000\000\000\000\000\000\031\000\000\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ - \049\000\049\000\049\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\049\000\049\000\049\000\049\000\049\000\049\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\049\000\049\000\049\000\049\000\049\000\049\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\000\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\033\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \034\000\000\000\000\000\000\000\000\000\000\000\000\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\000\000\000\000\000\000\000\000\033\000\000\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\000\000\000\000\000\000\105\000\102\000\000\000\000\000\ - \101\000\000\000\000\000\000\000\000\000\156\000\156\000\156\000\ - \156\000\156\000\156\000\156\000\156\000\156\000\156\000\000\000\ - \000\000\000\000\000\000\105\000\000\000\104\000\156\000\156\000\ - \156\000\156\000\156\000\156\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\099\000\099\000\099\000\099\000\099\000\ - \099\000\099\000\099\000\099\000\099\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\156\000\156\000\ - \156\000\156\000\156\000\156\000\000\000\000\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\000\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\000\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\057\000\000\000\ - \057\000\000\000\000\000\000\000\000\000\057\000\000\000\000\000\ - \060\000\000\000\000\000\060\000\000\000\000\000\056\000\056\000\ - \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\060\000\ - \078\000\000\000\000\000\078\000\078\000\078\000\000\000\000\000\ - \000\000\079\000\078\000\000\000\078\000\078\000\078\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\078\000\057\000\078\000\078\000\078\000\078\000\078\000\ - \057\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\068\000\057\000\000\000\068\000\000\000\ - \057\000\000\000\057\000\000\000\000\000\000\000\055\000\000\000\ - \000\000\000\000\000\000\078\000\000\000\078\000\000\000\000\000\ - \000\000\000\000\068\000\069\000\000\000\000\000\069\000\069\000\ - \069\000\000\000\000\000\072\000\071\000\069\000\000\000\069\000\ - \069\000\069\000\068\000\255\255\000\000\068\000\000\000\000\000\ - \000\000\000\000\000\000\078\000\069\000\078\000\069\000\069\000\ - \069\000\069\000\069\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\068\000\069\000\000\000\000\000\069\000\070\000\070\000\ - \000\000\000\000\072\000\071\000\069\000\000\000\069\000\077\000\ - \070\000\000\000\000\000\000\000\000\000\000\000\069\000\000\000\ - \069\000\000\000\000\000\077\000\000\000\077\000\077\000\077\000\ - \069\000\070\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\068\000\000\000\000\000\ - \068\000\000\000\000\000\000\000\000\000\000\000\069\000\000\000\ - \069\000\000\000\000\000\000\000\000\000\069\000\000\000\070\000\ - \000\000\000\000\000\000\000\000\068\000\069\000\000\000\000\000\ - \069\000\076\000\076\000\000\000\000\000\072\000\071\000\069\000\ - \000\000\069\000\075\000\076\000\068\000\000\000\255\255\068\000\ - \000\000\000\000\000\000\000\000\000\000\077\000\075\000\069\000\ - \075\000\075\000\075\000\069\000\076\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\068\000\069\000\000\000\000\000\069\000\ - \070\000\070\000\000\000\067\000\072\000\071\000\069\000\000\000\ - \069\000\070\000\070\000\000\000\000\000\000\000\000\000\000\000\ - \069\000\000\000\076\000\067\000\067\000\070\000\067\000\070\000\ - \070\000\070\000\069\000\070\000\067\000\067\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \067\000\000\000\067\000\067\000\067\000\000\000\067\000\000\000\ - \075\000\000\000\069\000\000\000\000\000\000\000\067\000\069\000\ - \000\000\070\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\067\000\000\000\068\000\067\000\000\000\068\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\067\000\070\000\ - \000\000\069\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\068\000\069\000\000\000\000\000\069\000\069\000\ - \069\000\067\000\067\000\073\000\071\000\069\000\000\000\069\000\ - \069\000\069\000\068\000\000\000\000\000\068\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\069\000\000\000\069\000\069\000\ - \069\000\069\000\069\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\068\000\069\000\000\000\000\000\069\000\070\000\070\000\ - \000\000\067\000\073\000\071\000\069\000\000\000\069\000\070\000\ - \070\000\000\000\000\000\000\000\000\000\000\000\069\000\000\000\ - \069\000\000\000\000\000\070\000\000\000\070\000\070\000\070\000\ - \069\000\070\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\068\000\000\000\000\000\ - \068\000\000\000\000\000\000\000\000\000\000\000\069\000\000\000\ - \069\000\000\000\000\000\000\000\067\000\069\000\000\000\070\000\ - \000\000\000\000\000\000\000\000\068\000\069\000\000\000\000\000\ - \069\000\069\000\069\000\000\000\000\000\000\000\071\000\069\000\ - \000\000\069\000\069\000\069\000\068\000\000\000\000\000\068\000\ - \000\000\000\000\000\000\000\000\067\000\070\000\069\000\069\000\ - \069\000\069\000\069\000\069\000\069\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\068\000\069\000\000\000\000\000\069\000\ - \076\000\076\000\000\000\000\000\073\000\071\000\069\000\000\000\ - \069\000\075\000\076\000\000\000\000\000\000\000\000\000\000\000\ - \069\000\000\000\069\000\000\000\000\000\075\000\000\000\075\000\ - \075\000\075\000\069\000\076\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\068\000\ - \000\000\000\000\068\000\000\000\000\000\000\000\000\000\000\000\ - \069\000\000\000\069\000\000\000\000\000\000\000\000\000\069\000\ - \000\000\076\000\000\000\000\000\000\000\000\000\068\000\069\000\ - \000\000\000\000\069\000\076\000\076\000\000\000\067\000\073\000\ - \071\000\069\000\000\000\069\000\076\000\076\000\068\000\000\000\ - \000\000\068\000\000\000\000\000\000\000\000\000\000\000\075\000\ - \076\000\069\000\076\000\076\000\076\000\069\000\076\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\068\000\069\000\000\000\ - \000\000\069\000\070\000\070\000\000\000\000\000\073\000\071\000\ - \069\000\000\000\069\000\077\000\070\000\000\000\000\000\000\000\ - \000\000\067\000\069\000\000\000\076\000\000\000\000\000\077\000\ - \000\000\077\000\077\000\077\000\069\000\070\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\080\000\000\000\000\000\080\000\000\000\000\000\000\000\ - \000\000\067\000\076\000\000\000\069\000\000\000\000\000\000\000\ - \000\000\069\000\000\000\070\000\000\000\000\000\000\000\000\000\ - \080\000\078\000\000\000\000\000\078\000\078\000\078\000\000\000\ - \000\000\082\000\079\000\078\000\000\000\078\000\078\000\078\000\ - \080\000\000\000\000\000\080\000\000\000\000\000\000\000\000\000\ - \000\000\077\000\078\000\069\000\078\000\078\000\078\000\078\000\ - \078\000\000\000\000\000\000\000\000\000\000\000\000\000\080\000\ - \078\000\000\000\000\000\078\000\078\000\078\000\000\000\000\000\ - \000\000\079\000\078\000\000\000\078\000\078\000\078\000\000\000\ - \000\000\000\000\000\000\000\000\078\000\000\000\078\000\000\000\ - \000\000\078\000\000\000\078\000\078\000\078\000\078\000\078\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\096\000\ - \096\000\000\000\000\000\084\000\000\000\000\000\000\000\000\000\ - \084\000\096\000\000\000\000\000\078\000\000\000\078\000\000\000\ - \000\000\000\000\000\000\078\000\084\000\078\000\084\000\084\000\ - \084\000\000\000\096\000\000\000\000\000\000\000\000\000\000\000\ - \003\000\000\000\000\000\003\000\009\000\009\000\000\000\000\000\ - \005\000\003\000\003\000\000\000\003\000\006\000\009\000\000\000\ - \000\000\000\000\000\000\078\000\000\000\078\000\000\000\084\000\ - \096\000\085\000\000\000\006\000\006\000\006\000\003\000\009\000\ - \000\000\000\000\000\000\000\000\000\000\003\000\000\000\000\000\ - \003\000\009\000\009\000\000\000\000\000\005\000\003\000\003\000\ - \000\000\003\000\006\000\009\000\000\000\000\000\084\000\084\000\ - \000\000\000\000\000\000\003\000\084\000\009\000\085\000\000\000\ - \006\000\006\000\006\000\003\000\009\000\000\000\000\000\000\000\ - \000\000\000\000\003\000\000\000\000\000\003\000\009\000\009\000\ - \000\000\000\000\094\000\003\000\003\000\000\000\003\000\009\000\ - \009\000\000\000\000\000\085\000\005\000\003\000\000\000\000\000\ - \003\000\084\000\009\000\098\000\000\000\009\000\009\000\009\000\ - \003\000\009\000\000\000\000\000\000\000\000\000\000\000\090\000\ - \000\000\000\000\003\000\093\000\093\000\000\000\000\000\084\000\ - \090\000\090\000\000\000\090\000\091\000\093\000\000\000\000\000\ - \085\000\005\000\003\000\000\000\000\000\003\000\094\000\009\000\ - \092\000\000\000\006\000\091\000\089\000\090\000\093\000\000\000\ - \000\000\000\000\000\000\000\000\003\000\000\000\000\000\003\000\ - \009\000\009\000\000\000\000\000\084\000\003\000\003\000\000\000\ - \003\000\006\000\009\000\000\000\000\000\098\000\094\000\003\000\ - \000\000\000\000\090\000\084\000\093\000\085\000\000\000\006\000\ - \006\000\097\000\003\000\009\000\000\000\000\000\000\000\000\000\ - \000\000\090\000\000\000\000\000\003\000\090\000\090\000\000\000\ - \000\000\000\000\090\000\090\000\000\000\090\000\090\000\090\000\ - \000\000\000\000\092\000\084\000\090\000\000\000\000\000\003\000\ - \084\000\009\000\090\000\000\000\003\000\090\000\003\000\090\000\ - \090\000\000\000\000\000\000\000\090\000\000\000\000\000\003\000\ - \093\000\093\000\000\000\000\000\084\000\090\000\090\000\000\000\ - \090\000\091\000\093\000\000\000\000\000\000\000\000\000\085\000\ - \084\000\003\000\000\000\000\000\090\000\092\000\090\000\006\000\ - \091\000\006\000\090\000\093\000\000\000\000\000\000\000\000\000\ - \000\000\090\000\000\000\000\000\003\000\093\000\093\000\000\000\ - \000\000\005\000\090\000\090\000\000\000\090\000\091\000\093\000\ - \000\000\000\000\000\000\000\000\090\000\000\000\090\000\090\000\ - \084\000\093\000\092\000\000\000\006\000\091\000\006\000\090\000\ - \093\000\000\000\000\000\000\000\000\000\000\000\090\000\000\000\ - \000\000\003\000\093\000\093\000\000\000\000\000\094\000\090\000\ - \090\000\000\000\090\000\093\000\093\000\000\000\000\000\092\000\ - \084\000\090\000\000\000\000\000\090\000\084\000\093\000\095\000\ - \000\000\009\000\093\000\009\000\090\000\093\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\096\000\ - \096\000\000\000\000\000\094\000\000\000\000\000\000\000\000\000\ - \096\000\096\000\000\000\000\000\092\000\005\000\090\000\000\000\ - \000\000\090\000\094\000\093\000\096\000\000\000\096\000\096\000\ - \096\000\000\000\096\000\000\000\000\000\000\000\000\000\000\000\ - \090\000\000\000\000\000\003\000\093\000\093\000\000\000\000\000\ - \094\000\090\000\090\000\000\000\090\000\093\000\093\000\000\000\ - \000\000\095\000\094\000\090\000\000\000\000\000\000\000\094\000\ - \096\000\095\000\000\000\009\000\093\000\009\000\090\000\093\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\096\000\096\000\000\000\000\000\094\000\000\000\000\000\ - \000\000\000\000\096\000\096\000\000\000\000\000\096\000\094\000\ - \000\000\000\000\000\000\090\000\094\000\093\000\096\000\000\000\ - \096\000\096\000\096\000\000\000\096\000\000\000\000\000\000\000\ - \000\000\000\000\003\000\000\000\000\000\003\000\009\000\009\000\ - \000\000\000\000\084\000\003\000\003\000\000\000\003\000\006\000\ - \009\000\000\000\000\000\095\000\094\000\090\000\000\000\000\000\ - \000\000\094\000\096\000\085\000\000\000\006\000\006\000\006\000\ - \003\000\009\000\000\000\000\000\000\000\000\000\000\000\003\000\ - \000\000\000\000\003\000\009\000\009\000\000\000\000\000\094\000\ - \003\000\003\000\000\000\003\000\009\000\009\000\000\000\000\000\ - \096\000\094\000\000\000\000\000\000\000\003\000\084\000\009\000\ - \098\000\000\000\009\000\009\000\009\000\003\000\009\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \111\000\111\000\000\000\000\000\084\000\000\000\000\000\111\000\ - \111\000\109\000\111\000\005\000\000\000\085\000\084\000\003\000\ - \109\000\111\000\003\000\094\000\009\000\110\000\000\000\109\000\ - \109\000\109\000\000\000\111\000\110\000\000\000\109\000\109\000\ - \109\000\000\000\111\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\111\000\111\000\000\000\000\000\ - \094\000\000\000\098\000\094\000\003\000\111\000\111\000\000\000\ - \084\000\111\000\000\000\000\000\000\000\000\000\000\000\084\000\ - \111\000\113\000\000\000\111\000\111\000\111\000\000\000\111\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\111\000\111\000\000\000\000\000\084\000\000\000\110\000\ - \084\000\000\000\109\000\111\000\000\000\000\000\110\000\005\000\ - \000\000\000\000\000\000\000\000\094\000\111\000\110\000\000\000\ - \109\000\109\000\109\000\000\000\111\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\111\000\111\000\ - \000\000\000\000\094\000\000\000\000\000\111\000\111\000\111\000\ - \111\000\005\000\000\000\113\000\094\000\000\000\109\000\111\000\ - \000\000\084\000\111\000\113\000\000\000\111\000\111\000\111\000\ - \000\000\111\000\110\000\000\000\109\000\109\000\109\000\000\000\ - \111\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\117\000\117\000\000\000\000\000\000\000\000\000\ - \110\000\084\000\000\000\115\000\117\000\000\000\094\000\111\000\ - \000\000\000\000\000\000\000\000\000\000\084\000\111\000\115\000\ - \000\000\116\000\115\000\115\000\000\000\117\000\000\000\000\000\ - \000\000\117\000\117\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\115\000\117\000\000\000\113\000\094\000\000\000\ - \000\000\000\000\000\000\000\000\110\000\005\000\115\000\000\000\ - \116\000\115\000\115\000\117\000\117\000\117\000\117\000\000\000\ - \067\000\000\000\000\000\000\000\000\000\000\000\117\000\117\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\117\000\000\000\117\000\117\000\117\000\000\000\ - \117\000\115\000\117\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\119\000\119\000\000\000\000\000\000\000\119\000\ - \119\000\000\000\067\000\118\000\119\000\000\000\000\000\000\000\ - \119\000\119\000\000\000\067\000\000\000\000\000\117\000\118\000\ - \115\000\118\000\118\000\118\000\119\000\119\000\119\000\119\000\ - \119\000\000\000\119\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\067\000\117\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\119\000\000\000\067\000\000\000\000\000\ - \119\000\000\000\000\000\000\000\000\000\000\000\003\000\000\000\ - \000\000\003\000\121\000\121\000\000\000\000\000\005\000\003\000\ - \003\000\000\000\003\000\007\000\121\000\000\000\000\000\000\000\ - \000\000\118\000\000\000\000\000\000\000\067\000\119\000\120\000\ - \000\000\007\000\007\000\007\000\003\000\121\000\000\000\000\000\ - \000\000\000\000\000\000\003\000\000\000\000\000\003\000\121\000\ - \121\000\000\000\000\000\094\000\003\000\003\000\000\000\003\000\ - \121\000\121\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\003\000\005\000\121\000\122\000\000\000\121\000\121\000\ - \121\000\003\000\121\000\000\000\000\000\000\000\000\000\000\000\ - \003\000\000\000\000\000\003\000\121\000\121\000\000\000\000\000\ - \094\000\003\000\003\000\000\000\003\000\121\000\121\000\000\000\ - \000\000\120\000\005\000\003\000\000\000\000\000\003\000\094\000\ - \121\000\122\000\000\000\121\000\121\000\121\000\003\000\121\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\126\000\ - \000\000\000\000\125\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\122\000\094\000\ - \003\000\000\000\000\000\003\000\094\000\121\000\000\000\129\000\ - \000\000\000\000\000\000\000\000\128\000\133\000\000\000\132\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\131\000\000\000\122\000\094\000\003\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \000\000\000\000\000\000\000\000\130\000\000\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \157\000\157\000\157\000\157\000\157\000\157\000\157\000\157\000\ - \157\000\157\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\157\000\157\000\157\000\157\000\157\000\157\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\157\000\157\000\157\000\157\000\157\000\157\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\000\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\000\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\127\000\130\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\000\000\000\000\000\000\000\000\130\000\000\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\000\000\000\000\000\000\000\000\140\000\000\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\000\000\000\000\000\000\000\000\000\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\000\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\000\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\000\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\000\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\000\000\000\000\000\000\000\000\139\000\000\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\174\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\000\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \000\000\000\000\136\000\000\000\000\000\000\000\137\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\000\000\000\000\000\000\000\000\139\000\000\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \175\000\175\000\175\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\000\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\140\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \000\000\000\000\136\000\000\000\000\000\000\000\000\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\000\000\000\000\000\000\000\000\140\000\000\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\000\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\000\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\151\000\000\000\ - \151\000\000\000\000\000\171\000\000\000\151\000\170\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\150\000\150\000\ - \150\000\150\000\150\000\150\000\150\000\150\000\150\000\150\000\ - \000\000\169\000\000\000\169\000\000\000\000\000\000\000\000\000\ - \169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\151\000\000\000\000\000\000\000\000\000\000\000\ - \151\000\176\000\000\000\000\000\176\000\176\000\176\000\000\000\ - \000\000\000\000\176\000\176\000\151\000\176\000\176\000\176\000\ - \151\000\000\000\151\000\000\000\000\000\169\000\149\000\000\000\ - \000\000\000\000\176\000\169\000\176\000\176\000\176\000\176\000\ - \176\000\000\000\000\000\000\000\000\000\000\000\000\000\169\000\ - \000\000\000\000\000\000\169\000\000\000\169\000\000\000\000\000\ - \000\000\167\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\176\000\000\000\176\000\000\000\ - \000\000\000\000\000\000\000\000\178\000\000\000\000\000\178\000\ - \178\000\178\000\000\000\000\000\000\000\178\000\178\000\000\000\ - \178\000\178\000\178\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\176\000\178\000\176\000\178\000\ - \178\000\178\000\178\000\178\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\000\000\178\000\ - \000\000\178\000\179\000\000\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\000\000\178\000\ - \000\000\178\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\255\255\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\000\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\000\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\178\000\000\000\000\000\178\000\178\000\ - \178\000\000\000\000\000\000\000\178\000\178\000\000\000\178\000\ - \178\000\178\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\178\000\000\000\178\000\178\000\ - \178\000\178\000\178\000\000\000\000\000\000\000\000\000\179\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\000\000\000\000\180\000\000\000\178\000\000\000\ - \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\000\000\000\000\000\000\178\000\179\000\ - \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\000\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\000\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \182\000\000\000\000\000\182\000\182\000\182\000\000\000\000\000\ - \000\000\182\000\182\000\000\000\182\000\182\000\182\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\182\000\000\000\182\000\182\000\182\000\182\000\182\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\000\000\182\000\000\000\182\000\183\000\000\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\000\000\182\000\000\000\182\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\182\000\ - \000\000\000\000\182\000\182\000\182\000\000\000\000\000\000\000\ - \182\000\182\000\000\000\182\000\182\000\182\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \182\000\000\000\182\000\182\000\182\000\182\000\182\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\183\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\000\000\182\000\185\000\182\000\000\000\000\000\184\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\182\000\000\000\182\000\000\000\183\000\000\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\000\000\000\000\000\000\000\000\186\000\000\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\000\000\000\000\000\000\000\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\000\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\000\000\000\000\187\000\000\000\000\000\000\000\000\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\000\000\000\000\000\000\000\000\186\000\000\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\000\000\000\000\000\000\000\000\199\000\000\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\000\000\000\000\000\000\000\000\000\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\000\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\000\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\000\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\000\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\000\000\000\000\000\000\000\000\198\000\000\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\000\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \000\000\000\000\195\000\000\000\000\000\000\000\196\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\000\000\000\000\000\000\000\000\198\000\000\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\000\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\199\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \000\000\000\000\195\000\000\000\000\000\000\000\000\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\000\000\000\000\000\000\000\000\199\000\000\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\000\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\000\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\204\000\ - \202\000\202\000\207\000\202\000\202\000\000\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\204\000\202\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \203\000\202\000\202\000\202\000\202\000\202\000\202\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\202\000\202\000\202\000\202\000\000\000\206\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\202\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\202\000\209\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\255\255\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\203\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\000\000\000\000\000\000\000\000\209\000\000\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\208\000\ - \000\000\000\000\000\000\000\000\000\000\209\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\208\000\000\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \203\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\000\000\000\000\000\000\000\000\209\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\000\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \203\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\000\000\000\000\000\000\000\000\209\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\000\000\000\000\000\000\000\000\000\000\000\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\000\000\000\000\000\000\000\000\221\000\000\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\000\000\000\000\000\000\000\000\000\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\000\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\000\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\000\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\000\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \000\000\000\000\000\000\000\000\220\000\000\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\000\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\000\000\ - \000\000\217\000\000\000\000\000\000\000\218\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \000\000\000\000\000\000\000\000\220\000\000\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\000\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\221\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\000\000\ - \000\000\217\000\000\000\000\000\000\000\000\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \000\000\000\000\000\000\000\000\221\000\000\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\000\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\000\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\000\000"; - Lexing.lex_check = - "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\000\000\000\000\029\000\000\000\000\000\101\000\107\000\ - \125\000\162\000\103\000\106\000\190\000\103\000\106\000\213\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\ - \010\000\010\000\049\000\016\000\051\000\028\000\040\000\040\000\ - \028\000\010\000\010\000\041\000\041\000\041\000\041\000\041\000\ - \041\000\041\000\041\000\057\000\065\000\010\000\132\000\010\000\ - \010\000\010\000\016\000\010\000\028\000\047\000\047\000\047\000\ - \047\000\047\000\047\000\047\000\047\000\047\000\047\000\133\000\ - \142\000\144\000\016\000\016\000\016\000\016\000\016\000\016\000\ - \016\000\016\000\016\000\016\000\145\000\131\000\151\000\131\000\ - \154\000\010\000\020\000\131\000\157\000\020\000\193\000\255\255\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\010\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\255\255\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\003\000\255\255\255\255\003\000\003\000\003\000\050\000\ - \103\000\106\000\003\000\003\000\020\000\003\000\003\000\003\000\ - \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ - \039\000\039\000\003\000\143\000\003\000\003\000\003\000\003\000\ - \003\000\255\255\005\000\005\000\050\000\039\000\005\000\255\255\ - \038\000\255\255\038\000\005\000\005\000\038\000\038\000\038\000\ - \038\000\038\000\038\000\038\000\038\000\038\000\038\000\005\000\ - \143\000\005\000\005\000\005\000\003\000\005\000\003\000\039\000\ - \104\000\255\255\171\000\104\000\006\000\039\000\255\255\006\000\ - \006\000\006\000\255\255\255\255\006\000\006\000\006\000\255\255\ - \006\000\006\000\006\000\255\255\068\000\255\255\255\255\068\000\ - \104\000\171\000\005\000\005\000\003\000\006\000\003\000\006\000\ - \006\000\006\000\006\000\006\000\170\000\170\000\255\255\255\255\ - \255\255\007\000\255\255\068\000\007\000\007\000\007\000\255\255\ - \255\255\007\000\007\000\007\000\068\000\007\000\007\000\007\000\ - \255\255\005\000\005\000\170\000\255\255\255\255\255\255\006\000\ - \006\000\006\000\007\000\255\255\007\000\007\000\007\000\007\000\ - \007\000\194\000\212\000\194\000\212\000\255\255\008\000\194\000\ - \212\000\008\000\008\000\008\000\255\255\255\255\008\000\008\000\ - \008\000\255\255\008\000\008\000\008\000\255\255\255\255\006\000\ - \006\000\006\000\255\255\255\255\007\000\007\000\007\000\008\000\ - \255\255\008\000\008\000\008\000\008\000\008\000\188\000\255\255\ - \020\000\188\000\255\255\009\000\255\255\255\255\009\000\009\000\ - \009\000\255\255\204\000\009\000\009\000\009\000\255\255\009\000\ - \009\000\009\000\255\255\255\255\007\000\007\000\007\000\204\000\ - \208\000\008\000\008\000\008\000\009\000\255\255\009\000\009\000\ - \009\000\009\000\009\000\204\000\255\255\208\000\255\255\255\255\ - \210\000\255\255\255\255\210\000\011\000\011\000\255\255\255\255\ - \188\000\208\000\188\000\013\000\013\000\011\000\011\000\013\000\ - \255\255\008\000\008\000\008\000\013\000\013\000\009\000\009\000\ - \009\000\011\000\210\000\011\000\011\000\011\000\255\255\011\000\ - \013\000\255\255\013\000\013\000\013\000\255\255\013\000\014\000\ - \014\000\255\255\080\000\014\000\255\255\080\000\255\255\255\255\ - \014\000\014\000\210\000\255\255\255\255\255\255\009\000\009\000\ - \009\000\255\255\255\255\255\255\014\000\011\000\014\000\014\000\ - \014\000\080\000\014\000\013\000\013\000\045\000\045\000\255\255\ - \255\255\255\255\080\000\017\000\255\255\255\255\017\000\017\000\ - \017\000\255\255\255\255\017\000\017\000\017\000\255\255\017\000\ - \017\000\017\000\255\255\011\000\255\255\255\255\104\000\014\000\ - \014\000\045\000\013\000\013\000\017\000\255\255\017\000\017\000\ - \017\000\017\000\017\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\045\000\044\000\044\000\044\000\ - \044\000\044\000\044\000\044\000\044\000\255\255\014\000\014\000\ - \255\255\045\000\255\255\045\000\255\255\255\255\017\000\017\000\ - \017\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \018\000\044\000\255\255\018\000\018\000\018\000\255\255\255\255\ - \018\000\018\000\018\000\255\255\018\000\018\000\018\000\019\000\ - \255\255\255\255\019\000\255\255\044\000\255\255\017\000\017\000\ - \017\000\018\000\255\255\018\000\018\000\018\000\018\000\018\000\ - \255\255\044\000\255\255\044\000\255\255\255\255\019\000\019\000\ - \255\255\255\255\019\000\019\000\019\000\255\255\255\255\255\255\ - \019\000\019\000\255\255\019\000\019\000\019\000\128\000\255\255\ - \255\255\128\000\255\255\018\000\188\000\018\000\255\255\255\255\ - \019\000\255\255\019\000\019\000\019\000\019\000\019\000\022\000\ - \255\255\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ - \022\000\022\000\022\000\128\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\018\000\255\255\018\000\022\000\255\255\ - \255\255\255\255\019\000\255\255\019\000\022\000\210\000\255\255\ - \023\000\255\255\023\000\023\000\023\000\023\000\023\000\023\000\ - \023\000\023\000\023\000\023\000\255\255\255\255\255\255\255\255\ - \022\000\255\255\255\255\255\255\023\000\255\255\022\000\023\000\ - \255\255\255\255\019\000\255\255\019\000\022\000\023\000\022\000\ - \128\000\023\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\023\000\255\255\255\255\255\255\105\000\105\000\ - \255\255\023\000\105\000\255\255\023\000\255\255\255\255\023\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\023\000\255\255\ - \023\000\023\000\024\000\255\255\255\255\105\000\255\255\105\000\ - \255\255\255\255\023\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\255\255\255\255\ - \255\255\255\255\024\000\255\255\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\042\000\042\000\ - \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\042\000\ - \042\000\042\000\042\000\042\000\042\000\056\000\056\000\056\000\ - \056\000\056\000\056\000\056\000\056\000\056\000\056\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\255\255\255\255\255\255\128\000\255\255\255\255\042\000\ - \042\000\042\000\042\000\042\000\042\000\150\000\150\000\150\000\ - \150\000\150\000\150\000\150\000\150\000\150\000\150\000\255\255\ - \255\255\255\255\255\255\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\255\255\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\025\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\105\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\255\255\255\255\ - \255\255\255\255\025\000\255\255\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\043\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\043\000\ - \043\000\043\000\043\000\043\000\043\000\255\255\255\255\255\255\ - \255\255\255\255\043\000\153\000\153\000\153\000\153\000\153\000\ - \153\000\153\000\153\000\153\000\153\000\255\255\255\255\255\255\ - \159\000\255\255\255\255\159\000\255\255\043\000\255\255\043\000\ - \043\000\043\000\043\000\043\000\043\000\255\255\255\255\255\255\ - \255\255\255\255\043\000\255\255\043\000\255\255\255\255\255\255\ - \159\000\255\255\255\255\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\255\255\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\159\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\026\000\255\255\255\255\026\000\026\000\ - \026\000\255\255\255\255\255\255\026\000\026\000\255\255\026\000\ - \026\000\026\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\026\000\255\255\026\000\026\000\ - \026\000\026\000\026\000\172\000\172\000\172\000\172\000\172\000\ - \172\000\172\000\172\000\172\000\172\000\255\255\046\000\046\000\ - \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\026\000\255\255\ - \026\000\026\000\255\255\026\000\026\000\026\000\026\000\026\000\ - \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ - \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ - \026\000\026\000\026\000\026\000\026\000\046\000\026\000\027\000\ - \026\000\255\255\027\000\027\000\027\000\255\255\255\255\255\255\ - \027\000\027\000\255\255\027\000\027\000\027\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \027\000\255\255\027\000\027\000\027\000\027\000\027\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\027\000\255\255\027\000\027\000\159\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ - \027\000\255\255\027\000\255\255\027\000\255\255\255\255\255\255\ - \255\255\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ - \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ - \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ - \026\000\100\000\026\000\026\000\026\000\026\000\026\000\026\000\ - \026\000\026\000\055\000\055\000\055\000\055\000\055\000\055\000\ - \055\000\055\000\055\000\055\000\255\255\255\255\255\255\255\255\ - \100\000\255\255\255\255\055\000\055\000\055\000\055\000\055\000\ - \055\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \100\000\100\000\100\000\100\000\100\000\100\000\100\000\100\000\ - \100\000\100\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\055\000\055\000\055\000\055\000\055\000\ - \055\000\255\255\255\255\255\255\255\255\027\000\027\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\031\000\027\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\027\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\255\255\255\255\255\255\255\255\255\255\255\255\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\255\255\255\255\255\255\255\255\031\000\255\255\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ - \059\000\059\000\059\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\059\000\059\000\059\000\059\000\059\000\059\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\059\000\059\000\059\000\059\000\059\000\059\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\255\255\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\033\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\255\255\255\255\255\255\255\255\255\255\255\255\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\255\255\255\255\255\255\255\255\033\000\255\255\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\255\255\255\255\255\255\099\000\099\000\255\255\255\255\ - \099\000\255\255\255\255\255\255\255\255\149\000\149\000\149\000\ - \149\000\149\000\149\000\149\000\149\000\149\000\149\000\255\255\ - \255\255\255\255\255\255\099\000\255\255\099\000\149\000\149\000\ - \149\000\149\000\149\000\149\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\099\000\099\000\099\000\099\000\099\000\ - \099\000\099\000\099\000\099\000\099\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\149\000\149\000\ - \149\000\149\000\149\000\149\000\255\255\255\255\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\255\255\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\255\255\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\048\000\255\255\ - \048\000\255\255\255\255\255\255\255\255\048\000\255\255\255\255\ - \060\000\255\255\255\255\060\000\255\255\255\255\048\000\048\000\ - \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\000\ - \060\000\255\255\255\255\060\000\060\000\060\000\255\255\255\255\ - \255\255\060\000\060\000\255\255\060\000\060\000\060\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\060\000\048\000\060\000\060\000\060\000\060\000\060\000\ - \048\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\061\000\048\000\255\255\061\000\255\255\ - \048\000\255\255\048\000\255\255\255\255\255\255\048\000\255\255\ - \255\255\255\255\255\255\060\000\255\255\060\000\255\255\255\255\ - \255\255\255\255\061\000\061\000\255\255\255\255\061\000\061\000\ - \061\000\255\255\255\255\061\000\061\000\061\000\255\255\061\000\ - \061\000\061\000\062\000\099\000\255\255\062\000\255\255\255\255\ - \255\255\255\255\255\255\060\000\061\000\060\000\061\000\061\000\ - \061\000\061\000\061\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\062\000\062\000\255\255\255\255\062\000\062\000\062\000\ - \255\255\255\255\062\000\062\000\062\000\255\255\062\000\062\000\ - \062\000\255\255\255\255\255\255\255\255\255\255\061\000\255\255\ - \061\000\255\255\255\255\062\000\255\255\062\000\062\000\062\000\ - \062\000\062\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\063\000\255\255\255\255\ - \063\000\255\255\255\255\255\255\255\255\255\255\061\000\255\255\ - \061\000\255\255\255\255\255\255\255\255\062\000\255\255\062\000\ - \255\255\255\255\255\255\255\255\063\000\063\000\255\255\255\255\ - \063\000\063\000\063\000\255\255\255\255\063\000\063\000\063\000\ - \255\255\063\000\063\000\063\000\064\000\255\255\048\000\064\000\ - \255\255\255\255\255\255\255\255\255\255\062\000\063\000\062\000\ - \063\000\063\000\063\000\063\000\063\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\064\000\064\000\255\255\255\255\064\000\ - \064\000\064\000\255\255\064\000\064\000\064\000\064\000\255\255\ - \064\000\064\000\064\000\255\255\255\255\255\255\255\255\255\255\ - \063\000\255\255\063\000\067\000\067\000\064\000\067\000\064\000\ - \064\000\064\000\064\000\064\000\067\000\067\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \067\000\255\255\067\000\067\000\067\000\255\255\067\000\255\255\ - \063\000\255\255\063\000\255\255\255\255\255\255\064\000\064\000\ - \255\255\064\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\067\000\255\255\069\000\067\000\255\255\069\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\064\000\064\000\ - \255\255\064\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\069\000\069\000\255\255\255\255\069\000\069\000\ - \069\000\067\000\067\000\069\000\069\000\069\000\255\255\069\000\ - \069\000\069\000\070\000\255\255\255\255\070\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\069\000\255\255\069\000\069\000\ - \069\000\069\000\069\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\070\000\070\000\255\255\255\255\070\000\070\000\070\000\ - \255\255\070\000\070\000\070\000\070\000\255\255\070\000\070\000\ - \070\000\255\255\255\255\255\255\255\255\255\255\069\000\255\255\ - \069\000\255\255\255\255\070\000\255\255\070\000\070\000\070\000\ - \070\000\070\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\071\000\255\255\255\255\ - \071\000\255\255\255\255\255\255\255\255\255\255\069\000\255\255\ - \069\000\255\255\255\255\255\255\070\000\070\000\255\255\070\000\ - \255\255\255\255\255\255\255\255\071\000\071\000\255\255\255\255\ - \071\000\071\000\071\000\255\255\255\255\255\255\071\000\071\000\ - \255\255\071\000\071\000\071\000\075\000\255\255\255\255\075\000\ - \255\255\255\255\255\255\255\255\070\000\070\000\071\000\070\000\ - \071\000\071\000\071\000\071\000\071\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\075\000\075\000\255\255\255\255\075\000\ - \075\000\075\000\255\255\255\255\075\000\075\000\075\000\255\255\ - \075\000\075\000\075\000\255\255\255\255\255\255\255\255\255\255\ - \071\000\255\255\071\000\255\255\255\255\075\000\255\255\075\000\ - \075\000\075\000\075\000\075\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\076\000\ - \255\255\255\255\076\000\255\255\255\255\255\255\255\255\255\255\ - \071\000\255\255\071\000\255\255\255\255\255\255\255\255\075\000\ - \255\255\075\000\255\255\255\255\255\255\255\255\076\000\076\000\ - \255\255\255\255\076\000\076\000\076\000\255\255\076\000\076\000\ - \076\000\076\000\255\255\076\000\076\000\076\000\077\000\255\255\ - \255\255\077\000\255\255\255\255\255\255\255\255\255\255\075\000\ - \076\000\075\000\076\000\076\000\076\000\076\000\076\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\077\000\077\000\255\255\ - \255\255\077\000\077\000\077\000\255\255\255\255\077\000\077\000\ - \077\000\255\255\077\000\077\000\077\000\255\255\255\255\255\255\ - \255\255\076\000\076\000\255\255\076\000\255\255\255\255\077\000\ - \255\255\077\000\077\000\077\000\077\000\077\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\078\000\255\255\255\255\078\000\255\255\255\255\255\255\ - \255\255\076\000\076\000\255\255\076\000\255\255\255\255\255\255\ - \255\255\077\000\255\255\077\000\255\255\255\255\255\255\255\255\ - \078\000\078\000\255\255\255\255\078\000\078\000\078\000\255\255\ - \255\255\078\000\078\000\078\000\255\255\078\000\078\000\078\000\ - \079\000\255\255\255\255\079\000\255\255\255\255\255\255\255\255\ - \255\255\077\000\078\000\077\000\078\000\078\000\078\000\078\000\ - \078\000\255\255\255\255\255\255\255\255\255\255\255\255\079\000\ - \079\000\255\255\255\255\079\000\079\000\079\000\255\255\255\255\ - \255\255\079\000\079\000\255\255\079\000\079\000\079\000\255\255\ - \255\255\255\255\255\255\255\255\078\000\255\255\078\000\255\255\ - \255\255\079\000\255\255\079\000\079\000\079\000\079\000\079\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\084\000\ - \084\000\255\255\255\255\084\000\255\255\255\255\255\255\255\255\ - \084\000\084\000\255\255\255\255\078\000\255\255\078\000\255\255\ - \255\255\255\255\255\255\079\000\084\000\079\000\084\000\084\000\ - \084\000\255\255\084\000\255\255\255\255\255\255\255\255\255\255\ - \085\000\255\255\255\255\085\000\085\000\085\000\255\255\255\255\ - \085\000\085\000\085\000\255\255\085\000\085\000\085\000\255\255\ - \255\255\255\255\255\255\079\000\255\255\079\000\255\255\084\000\ - \084\000\085\000\255\255\085\000\085\000\085\000\085\000\085\000\ - \255\255\255\255\255\255\255\255\255\255\086\000\255\255\255\255\ - \086\000\086\000\086\000\255\255\255\255\086\000\086\000\086\000\ - \255\255\086\000\086\000\086\000\255\255\255\255\084\000\084\000\ - \255\255\255\255\255\255\085\000\085\000\085\000\086\000\255\255\ - \086\000\086\000\086\000\086\000\086\000\255\255\255\255\255\255\ - \255\255\255\255\087\000\255\255\255\255\087\000\087\000\087\000\ - \255\255\255\255\087\000\087\000\087\000\255\255\087\000\087\000\ - \087\000\255\255\255\255\085\000\085\000\085\000\255\255\255\255\ - \086\000\086\000\086\000\087\000\255\255\087\000\087\000\087\000\ - \087\000\087\000\255\255\255\255\255\255\255\255\255\255\088\000\ - \255\255\255\255\088\000\088\000\088\000\255\255\255\255\088\000\ - \088\000\088\000\255\255\088\000\088\000\088\000\255\255\255\255\ - \086\000\086\000\086\000\255\255\255\255\087\000\087\000\087\000\ - \088\000\255\255\088\000\088\000\088\000\088\000\088\000\255\255\ - \255\255\255\255\255\255\255\255\089\000\255\255\255\255\089\000\ - \089\000\089\000\255\255\255\255\089\000\089\000\089\000\255\255\ - \089\000\089\000\089\000\255\255\255\255\087\000\087\000\087\000\ - \255\255\255\255\088\000\088\000\088\000\089\000\255\255\089\000\ - \089\000\089\000\089\000\089\000\255\255\255\255\255\255\255\255\ - \255\255\090\000\255\255\255\255\090\000\090\000\090\000\255\255\ - \255\255\255\255\090\000\090\000\255\255\090\000\090\000\090\000\ - \255\255\255\255\088\000\088\000\088\000\255\255\255\255\089\000\ - \089\000\089\000\090\000\255\255\090\000\090\000\090\000\090\000\ - \090\000\255\255\255\255\255\255\091\000\255\255\255\255\091\000\ - \091\000\091\000\255\255\255\255\091\000\091\000\091\000\255\255\ - \091\000\091\000\091\000\255\255\255\255\255\255\255\255\089\000\ - \089\000\089\000\255\255\255\255\090\000\091\000\090\000\091\000\ - \091\000\091\000\091\000\091\000\255\255\255\255\255\255\255\255\ - \255\255\092\000\255\255\255\255\092\000\092\000\092\000\255\255\ - \255\255\092\000\092\000\092\000\255\255\092\000\092\000\092\000\ - \255\255\255\255\255\255\255\255\090\000\255\255\090\000\091\000\ - \091\000\091\000\092\000\255\255\092\000\092\000\092\000\092\000\ - \092\000\255\255\255\255\255\255\255\255\255\255\093\000\255\255\ - \255\255\093\000\093\000\093\000\255\255\255\255\093\000\093\000\ - \093\000\255\255\093\000\093\000\093\000\255\255\255\255\091\000\ - \091\000\091\000\255\255\255\255\092\000\092\000\092\000\093\000\ - \255\255\093\000\093\000\093\000\093\000\093\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\094\000\ - \094\000\255\255\255\255\094\000\255\255\255\255\255\255\255\255\ - \094\000\094\000\255\255\255\255\092\000\092\000\092\000\255\255\ - \255\255\093\000\093\000\093\000\094\000\255\255\094\000\094\000\ - \094\000\255\255\094\000\255\255\255\255\255\255\255\255\255\255\ - \095\000\255\255\255\255\095\000\095\000\095\000\255\255\255\255\ - \095\000\095\000\095\000\255\255\095\000\095\000\095\000\255\255\ - \255\255\093\000\093\000\093\000\255\255\255\255\255\255\094\000\ - \094\000\095\000\255\255\095\000\095\000\095\000\095\000\095\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\096\000\096\000\255\255\255\255\096\000\255\255\255\255\ - \255\255\255\255\096\000\096\000\255\255\255\255\094\000\094\000\ - \255\255\255\255\255\255\095\000\095\000\095\000\096\000\255\255\ - \096\000\096\000\096\000\255\255\096\000\255\255\255\255\255\255\ - \255\255\255\255\097\000\255\255\255\255\097\000\097\000\097\000\ - \255\255\255\255\097\000\097\000\097\000\255\255\097\000\097\000\ - \097\000\255\255\255\255\095\000\095\000\095\000\255\255\255\255\ - \255\255\096\000\096\000\097\000\255\255\097\000\097\000\097\000\ - \097\000\097\000\255\255\255\255\255\255\255\255\255\255\098\000\ - \255\255\255\255\098\000\098\000\098\000\255\255\255\255\098\000\ - \098\000\098\000\255\255\098\000\098\000\098\000\255\255\255\255\ - \096\000\096\000\255\255\255\255\255\255\097\000\097\000\097\000\ - \098\000\255\255\098\000\098\000\098\000\098\000\098\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \109\000\109\000\255\255\255\255\109\000\255\255\255\255\110\000\ - \110\000\109\000\109\000\110\000\255\255\097\000\097\000\097\000\ - \110\000\110\000\098\000\098\000\098\000\109\000\255\255\109\000\ - \109\000\109\000\255\255\109\000\110\000\255\255\110\000\110\000\ - \110\000\255\255\110\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\111\000\111\000\255\255\255\255\ - \111\000\255\255\098\000\098\000\098\000\111\000\111\000\255\255\ - \109\000\109\000\255\255\255\255\255\255\255\255\255\255\110\000\ - \110\000\111\000\255\255\111\000\111\000\111\000\255\255\111\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\112\000\112\000\255\255\255\255\112\000\255\255\109\000\ - \109\000\255\255\112\000\112\000\255\255\255\255\110\000\110\000\ - \255\255\255\255\255\255\255\255\111\000\111\000\112\000\255\255\ - \112\000\112\000\112\000\255\255\112\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\113\000\113\000\ - \255\255\255\255\113\000\255\255\255\255\114\000\114\000\113\000\ - \113\000\114\000\255\255\111\000\111\000\255\255\114\000\114\000\ - \255\255\112\000\112\000\113\000\255\255\113\000\113\000\113\000\ - \255\255\113\000\114\000\255\255\114\000\114\000\114\000\255\255\ - \114\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\115\000\115\000\255\255\255\255\255\255\255\255\ - \112\000\112\000\255\255\115\000\115\000\255\255\113\000\113\000\ - \255\255\255\255\255\255\255\255\255\255\114\000\114\000\115\000\ - \255\255\115\000\115\000\115\000\255\255\115\000\255\255\255\255\ - \255\255\116\000\116\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\116\000\116\000\255\255\113\000\113\000\255\255\ - \255\255\255\255\255\255\255\255\114\000\114\000\116\000\255\255\ - \116\000\116\000\116\000\115\000\116\000\117\000\117\000\255\255\ - \117\000\255\255\255\255\255\255\255\255\255\255\117\000\117\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\117\000\255\255\117\000\117\000\117\000\255\255\ - \117\000\115\000\116\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\118\000\118\000\255\255\255\255\255\255\119\000\ - \119\000\255\255\119\000\118\000\118\000\255\255\255\255\255\255\ - \119\000\119\000\255\255\117\000\255\255\255\255\117\000\118\000\ - \116\000\118\000\118\000\118\000\119\000\118\000\119\000\119\000\ - \119\000\255\255\119\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\117\000\117\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\118\000\255\255\119\000\255\255\255\255\ - \119\000\255\255\255\255\255\255\255\255\255\255\120\000\255\255\ - \255\255\120\000\120\000\120\000\255\255\255\255\120\000\120\000\ - \120\000\255\255\120\000\120\000\120\000\255\255\255\255\255\255\ - \255\255\118\000\255\255\255\255\255\255\119\000\119\000\120\000\ - \255\255\120\000\120\000\120\000\120\000\120\000\255\255\255\255\ - \255\255\255\255\255\255\121\000\255\255\255\255\121\000\121\000\ - \121\000\255\255\255\255\121\000\121\000\121\000\255\255\121\000\ - \121\000\121\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\120\000\120\000\120\000\121\000\255\255\121\000\121\000\ - \121\000\121\000\121\000\255\255\255\255\255\255\255\255\255\255\ - \122\000\255\255\255\255\122\000\122\000\122\000\255\255\255\255\ - \122\000\122\000\122\000\255\255\122\000\122\000\122\000\255\255\ - \255\255\120\000\120\000\120\000\255\255\255\255\121\000\121\000\ - \121\000\122\000\255\255\122\000\122\000\122\000\122\000\122\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\123\000\ - \255\255\255\255\123\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\121\000\121\000\ - \121\000\255\255\255\255\122\000\122\000\122\000\255\255\123\000\ - \255\255\255\255\255\255\255\255\123\000\123\000\255\255\123\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\123\000\255\255\122\000\122\000\122\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \255\255\255\255\255\255\255\255\123\000\255\255\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \156\000\156\000\156\000\156\000\156\000\156\000\156\000\156\000\ - \156\000\156\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\156\000\156\000\156\000\156\000\156\000\156\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\156\000\156\000\156\000\156\000\156\000\156\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\255\255\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\255\255\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\130\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\255\255\255\255\255\255\255\255\130\000\255\255\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\255\255\255\255\255\255\255\255\137\000\255\255\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\255\255\255\255\255\255\255\255\255\255\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\255\255\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\255\255\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\255\255\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\255\255\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\255\255\255\255\255\255\255\255\138\000\255\255\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ - \167\000\167\000\167\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\167\000\167\000\167\000\167\000\167\000\167\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\167\000\167\000\167\000\167\000\167\000\167\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\255\255\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\139\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \255\255\255\255\139\000\255\255\255\255\255\255\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\255\255\255\255\255\255\255\255\139\000\255\255\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\174\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\174\000\174\000\174\000\174\000\174\000\174\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\174\000\174\000\174\000\174\000\174\000\174\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\255\255\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\140\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \255\255\255\255\140\000\255\255\255\255\255\255\255\255\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\255\255\255\255\255\255\255\255\140\000\255\255\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\255\255\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\255\255\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\141\000\255\255\ - \141\000\255\255\255\255\164\000\255\255\141\000\164\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\141\000\141\000\ - \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ - \255\255\164\000\255\255\164\000\255\255\255\255\255\255\255\255\ - \164\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\141\000\255\255\255\255\255\255\255\255\255\255\ - \141\000\176\000\255\255\255\255\176\000\176\000\176\000\255\255\ - \255\255\255\255\176\000\176\000\141\000\176\000\176\000\176\000\ - \141\000\255\255\141\000\255\255\255\255\164\000\141\000\255\255\ - \255\255\255\255\176\000\164\000\176\000\176\000\176\000\176\000\ - \176\000\255\255\255\255\255\255\255\255\255\255\255\255\164\000\ - \255\255\255\255\255\255\164\000\255\255\164\000\255\255\255\255\ - \255\255\164\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\176\000\255\255\176\000\255\255\ - \255\255\255\255\255\255\255\255\177\000\255\255\255\255\177\000\ - \177\000\177\000\255\255\255\255\255\255\177\000\177\000\255\255\ - \177\000\177\000\177\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\176\000\177\000\176\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\255\255\177\000\ - \255\255\177\000\177\000\255\255\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\255\255\177\000\ - \255\255\177\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\164\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\255\255\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\255\255\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\178\000\255\255\255\255\178\000\178\000\ - \178\000\255\255\255\255\255\255\178\000\178\000\255\255\178\000\ - \178\000\178\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\178\000\255\255\178\000\178\000\ - \178\000\178\000\178\000\255\255\255\255\255\255\255\255\179\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\255\255\255\255\179\000\255\255\178\000\255\255\ - \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\255\255\255\255\255\255\178\000\179\000\ - \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\255\255\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\255\255\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \181\000\255\255\255\255\181\000\181\000\181\000\255\255\255\255\ - \255\255\181\000\181\000\255\255\181\000\181\000\181\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\181\000\255\255\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\255\255\181\000\255\255\181\000\181\000\255\255\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\255\255\181\000\255\255\181\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\255\255\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\255\255\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\182\000\ - \255\255\255\255\182\000\182\000\182\000\255\255\255\255\255\255\ - \182\000\182\000\255\255\182\000\182\000\182\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \182\000\255\255\182\000\182\000\182\000\182\000\182\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\183\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\255\255\182\000\183\000\182\000\255\255\255\255\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\182\000\255\255\182\000\255\255\183\000\255\255\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\255\255\255\255\255\255\255\255\184\000\255\255\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\255\255\255\255\255\255\255\255\255\255\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\255\255\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\255\255\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\255\255\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\186\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\255\255\255\255\186\000\255\255\255\255\255\255\255\255\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\255\255\255\255\255\255\255\255\186\000\255\255\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\255\255\255\255\255\255\255\255\196\000\255\255\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\255\255\255\255\255\255\255\255\255\255\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\255\255\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\255\255\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\255\255\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\255\255\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\255\255\255\255\255\255\255\255\197\000\255\255\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\255\255\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\198\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \255\255\255\255\198\000\255\255\255\255\255\255\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\255\255\255\255\255\255\255\255\198\000\255\255\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\255\255\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\199\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \255\255\255\255\199\000\255\255\255\255\255\255\255\255\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\255\255\255\255\255\255\255\255\199\000\255\255\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\255\255\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\255\255\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\255\255\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\201\000\201\000\201\000\201\000\255\255\201\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\201\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\201\000\205\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\201\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\255\255\255\255\255\255\255\255\205\000\255\255\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\255\255\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\255\255\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\206\000\ - \255\255\255\255\255\255\255\255\255\255\206\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\206\000\255\255\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\255\255\255\255\255\255\255\255\255\255\255\255\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\255\255\255\255\255\255\255\255\206\000\255\255\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\255\255\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\209\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\255\255\255\255\255\255\255\255\255\255\255\255\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\255\255\255\255\255\255\255\255\209\000\255\255\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\255\255\255\255\255\255\255\255\255\255\255\255\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\255\255\255\255\255\255\255\255\218\000\255\255\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\255\255\255\255\255\255\255\255\255\255\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\255\255\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\255\255\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\255\255\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\255\255\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \255\255\255\255\255\255\255\255\219\000\255\255\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\255\255\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\220\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\255\255\ - \255\255\220\000\255\255\255\255\255\255\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \255\255\255\255\255\255\255\255\220\000\255\255\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\255\255\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\221\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\255\255\ - \255\255\221\000\255\255\255\255\255\255\255\255\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \255\255\255\255\255\255\255\255\221\000\255\255\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\255\255\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\255\255\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\255\255"; - Lexing.lex_base_code = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\066\000\101\000\136\000\171\000\ - \206\000\000\000\000\000\000\000\000\000\241\000\020\001\055\001\ - \000\000\000\000\018\000\090\001\125\001\160\001\195\001\230\001\ - \000\000\021\000\026\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\247\001\040\002\000\000\034\000\000\000\ - \000\000\003\000\000\000\000\000\049\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\ - \000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\036\002\000\000\244\002\ - \000\000\000\000\000\000\061\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000"; - Lexing.lex_backtrk_code = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\034\000\000\000\000\000\ - \000\000\000\000\000\000\049\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\061\000\061\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000"; - Lexing.lex_default_code = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \041\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000"; - Lexing.lex_trans_code = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\001\000\000\000\058\000\058\000\000\000\058\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \001\000\000\000\000\000\001\000\007\000\044\000\000\000\007\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ - \004\000\004\000\000\000\007\000\012\000\000\000\000\000\012\000\ - \012\000\012\000\000\000\000\000\000\000\000\000\012\000\000\000\ - \012\000\012\000\012\000\007\000\000\000\000\000\007\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\012\000\000\000\012\000\ - \012\000\012\000\012\000\012\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\007\000\015\000\000\000\000\000\015\000\015\000\ - \015\000\000\000\000\000\000\000\015\000\015\000\000\000\015\000\ - \015\000\015\000\000\000\000\000\000\000\000\000\000\000\012\000\ - \000\000\012\000\000\000\000\000\015\000\000\000\015\000\015\000\ - \015\000\015\000\015\000\000\000\000\000\000\000\012\000\000\000\ - \000\000\012\000\012\000\012\000\000\000\000\000\000\000\012\000\ - \012\000\000\000\012\000\012\000\012\000\000\000\000\000\012\000\ - \000\000\012\000\000\000\000\000\000\000\000\000\015\000\012\000\ - \015\000\012\000\012\000\012\000\012\000\012\000\000\000\000\000\ - \000\000\012\000\000\000\000\000\012\000\012\000\012\000\000\000\ - \000\000\000\000\012\000\012\000\000\000\012\000\012\000\012\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\015\000\000\000\ - \015\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ - \012\000\000\000\000\000\000\000\012\000\000\000\000\000\012\000\ - \012\000\012\000\000\000\000\000\000\000\012\000\012\000\000\000\ - \012\000\012\000\012\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\012\000\000\000\012\000\012\000\012\000\012\000\012\000\ - \012\000\012\000\012\000\012\000\000\000\000\000\000\000\012\000\ - \000\000\000\000\012\000\012\000\012\000\000\000\000\000\000\000\ - \012\000\012\000\000\000\012\000\012\000\012\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\012\000\000\000\012\000\012\000\ - \012\000\012\000\012\000\012\000\012\000\012\000\012\000\000\000\ - \000\000\000\000\012\000\000\000\000\000\012\000\012\000\012\000\ - \000\000\000\000\000\000\012\000\012\000\000\000\012\000\012\000\ - \012\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\ - \000\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ - \012\000\012\000\000\000\000\000\000\000\012\000\000\000\000\000\ - \012\000\012\000\012\000\000\000\000\000\000\000\012\000\012\000\ - \000\000\012\000\012\000\012\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\012\000\000\000\012\000\012\000\012\000\012\000\ - \012\000\012\000\012\000\012\000\012\000\000\000\000\000\000\000\ - \012\000\000\000\000\000\012\000\012\000\012\000\000\000\000\000\ - \000\000\012\000\012\000\000\000\012\000\012\000\012\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\012\000\000\000\012\000\ - \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ - \000\000\000\000\000\000\012\000\000\000\000\000\012\000\012\000\ - \012\000\000\000\000\000\000\000\012\000\012\000\000\000\012\000\ - \012\000\012\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \012\000\000\000\012\000\012\000\012\000\012\000\012\000\012\000\ - \012\000\012\000\012\000\000\000\000\000\000\000\012\000\000\000\ - \000\000\012\000\012\000\012\000\000\000\000\000\000\000\012\000\ - \012\000\000\000\012\000\012\000\012\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\012\000\000\000\012\000\012\000\012\000\ - \012\000\012\000\012\000\012\000\012\000\012\000\000\000\000\000\ - \000\000\012\000\000\000\000\000\012\000\012\000\012\000\000\000\ - \000\000\000\000\012\000\012\000\000\000\012\000\012\000\012\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\012\000\000\000\ - \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ - \012\000\000\000\000\000\000\000\015\000\000\000\000\000\015\000\ - \015\000\015\000\000\000\000\000\000\000\015\000\015\000\000\000\ - \015\000\015\000\015\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\012\000\000\000\012\000\012\000\015\000\012\000\015\000\ - \015\000\015\000\015\000\015\000\000\000\000\000\000\000\015\000\ - \000\000\000\000\015\000\015\000\015\000\000\000\000\000\000\000\ - \015\000\015\000\000\000\015\000\015\000\015\000\000\000\000\000\ - \000\000\029\000\000\000\000\000\012\000\000\000\012\000\015\000\ - \015\000\015\000\015\000\015\000\015\000\015\000\015\000\004\000\ - \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ - \004\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\015\000\ - \000\000\015\000\015\000\000\000\015\000\000\000\000\000\000\000\ - \001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ - \004\000\004\000\015\000\000\000\015\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\000\000\ - \000\000\000\000\000\000\058\000\000\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\000\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\000\000\ - \000\000\000\000\000\000\058\000\000\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\000\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\000\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\000\000"; - Lexing.lex_check_code = - "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\016\000\104\000\164\000\170\000\104\000\164\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \016\000\255\255\104\000\000\000\019\000\105\000\255\255\019\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ - \016\000\016\000\255\255\019\000\019\000\255\255\255\255\019\000\ - \019\000\019\000\255\255\255\255\255\255\255\255\019\000\255\255\ - \019\000\019\000\019\000\060\000\255\255\255\255\060\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\019\000\255\255\019\000\ - \019\000\019\000\019\000\019\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\060\000\060\000\255\255\255\255\060\000\060\000\ - \060\000\255\255\255\255\255\255\060\000\060\000\255\255\060\000\ - \060\000\060\000\255\255\255\255\255\255\255\255\255\255\019\000\ - \255\255\019\000\255\255\255\255\060\000\255\255\060\000\060\000\ - \060\000\060\000\060\000\255\255\255\255\255\255\061\000\255\255\ - \255\255\061\000\061\000\061\000\255\255\255\255\255\255\061\000\ - \061\000\255\255\061\000\061\000\061\000\255\255\255\255\019\000\ - \255\255\019\000\255\255\255\255\255\255\255\255\060\000\061\000\ - \060\000\061\000\061\000\061\000\061\000\061\000\255\255\255\255\ - \255\255\062\000\255\255\255\255\062\000\062\000\062\000\255\255\ - \255\255\255\255\062\000\062\000\255\255\062\000\062\000\062\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\060\000\255\255\ - \060\000\061\000\062\000\061\000\062\000\062\000\062\000\062\000\ - \062\000\255\255\255\255\255\255\063\000\255\255\255\255\063\000\ - \063\000\063\000\255\255\255\255\255\255\063\000\063\000\255\255\ - \063\000\063\000\063\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\061\000\255\255\061\000\062\000\063\000\062\000\063\000\ - \063\000\063\000\063\000\063\000\255\255\255\255\255\255\064\000\ - \255\255\255\255\064\000\064\000\064\000\255\255\255\255\255\255\ - \064\000\064\000\255\255\064\000\064\000\064\000\255\255\255\255\ - \104\000\255\255\255\255\255\255\062\000\255\255\062\000\063\000\ - \064\000\063\000\064\000\064\000\064\000\064\000\064\000\255\255\ - \255\255\255\255\069\000\255\255\255\255\069\000\069\000\069\000\ - \255\255\255\255\255\255\069\000\069\000\255\255\069\000\069\000\ - \069\000\255\255\255\255\255\255\255\255\255\255\255\255\063\000\ - \255\255\063\000\064\000\069\000\064\000\069\000\069\000\069\000\ - \069\000\069\000\255\255\255\255\255\255\070\000\255\255\255\255\ - \070\000\070\000\070\000\255\255\255\255\255\255\070\000\070\000\ - \255\255\070\000\070\000\070\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\064\000\255\255\064\000\069\000\070\000\069\000\ - \070\000\070\000\070\000\070\000\070\000\255\255\255\255\255\255\ - \071\000\255\255\255\255\071\000\071\000\071\000\255\255\255\255\ - \255\255\071\000\071\000\255\255\071\000\071\000\071\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\069\000\255\255\069\000\ - \070\000\071\000\070\000\071\000\071\000\071\000\071\000\071\000\ - \255\255\255\255\255\255\075\000\255\255\255\255\075\000\075\000\ - \075\000\255\255\255\255\255\255\075\000\075\000\255\255\075\000\ - \075\000\075\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \070\000\255\255\070\000\071\000\075\000\071\000\075\000\075\000\ - \075\000\075\000\075\000\255\255\255\255\255\255\076\000\255\255\ - \255\255\076\000\076\000\076\000\255\255\255\255\255\255\076\000\ - \076\000\255\255\076\000\076\000\076\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\071\000\255\255\071\000\075\000\076\000\ - \075\000\076\000\076\000\076\000\076\000\076\000\255\255\255\255\ - \255\255\077\000\255\255\255\255\077\000\077\000\077\000\255\255\ - \255\255\255\255\077\000\077\000\255\255\077\000\077\000\077\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\075\000\255\255\ - \075\000\076\000\077\000\076\000\077\000\077\000\077\000\077\000\ - \077\000\255\255\255\255\255\255\078\000\255\255\255\255\078\000\ - \078\000\078\000\255\255\255\255\255\255\078\000\078\000\255\255\ - \078\000\078\000\078\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\076\000\255\255\076\000\077\000\078\000\077\000\078\000\ - \078\000\078\000\078\000\078\000\255\255\255\255\255\255\079\000\ - \255\255\255\255\079\000\079\000\079\000\255\255\255\255\255\255\ - \079\000\079\000\255\255\079\000\079\000\079\000\255\255\255\255\ - \255\255\099\000\255\255\255\255\077\000\255\255\077\000\078\000\ - \079\000\078\000\079\000\079\000\079\000\079\000\079\000\099\000\ - \099\000\099\000\099\000\099\000\099\000\099\000\099\000\099\000\ - \099\000\100\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\078\000\ - \255\255\078\000\079\000\255\255\079\000\255\255\255\255\255\255\ - \100\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \100\000\100\000\100\000\100\000\100\000\100\000\100\000\100\000\ - \100\000\100\000\079\000\255\255\079\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\255\255\ - \255\255\255\255\255\255\181\000\255\255\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\255\255\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\183\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\255\255\ - \255\255\255\255\255\255\183\000\255\255\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\255\255\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\255\255\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\255\255"; - Lexing.lex_code = - "\255\004\255\255\009\255\255\006\255\005\255\255\007\255\255\008\ - \255\255\000\007\255\000\006\001\008\255\000\005\255\011\255\010\ - \255\255\003\255\000\004\001\009\255\011\255\255\010\255\011\255\ - \255\000\004\001\009\003\010\002\011\255\001\255\255\000\001\255\ - "; - } - - let rec token c lexbuf = - (lexbuf.Lexing.lex_mem <- Array.create 12 (-1); - __ocaml_lex_token_rec c lexbuf 0) - and __ocaml_lex_token_rec c lexbuf __ocaml_lex_state = - match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state - lexbuf - with - | 0 -> (update_loc c None 1 false 0; NEWLINE) - | 1 -> - let x = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in BLANKS x - | 2 -> - let x = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in LABEL x - | 3 -> - let x = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in OPTLABEL x - | 4 -> - let x = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in LIDENT x - | 5 -> - let x = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in UIDENT x - | 6 -> - let i = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in - (try INT ((cvt_int_literal i), i) - with - | Failure _ -> - err (Literal_overflow "int") (Loc.of_lexbuf lexbuf)) - | 7 -> - let f = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in - (try FLOAT ((float_of_string f), f) - with - | Failure _ -> - err (Literal_overflow "float") - (Loc.of_lexbuf lexbuf)) - | 8 -> - let i = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - (try INT32 ((cvt_int32_literal i), i) - with - | Failure _ -> - err (Literal_overflow "int32") - (Loc.of_lexbuf lexbuf)) - | 9 -> - let i = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - (try INT64 ((cvt_int64_literal i), i) - with - | Failure _ -> - err (Literal_overflow "int64") - (Loc.of_lexbuf lexbuf)) - | 10 -> - let i = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - (try NATIVEINT ((cvt_nativeint_literal i), i) - with - | Failure _ -> - err (Literal_overflow "nativeint") - (Loc.of_lexbuf lexbuf)) - | 11 -> - (with_curr_loc string c; - let s = buff_contents c - in STRING ((TokenEval.string s), s)) - | 12 -> - let x = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - (update_loc c None 1 false 1; - CHAR ((TokenEval.char x), x)) - | 13 -> - let x = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in CHAR ((TokenEval.char x), x) - | 14 -> - let c = - Lexing.sub_lexeme_char lexbuf - (lexbuf.Lexing.lex_start_pos + 2) - in - err (Illegal_escape (String.make 1 c)) - (Loc.of_lexbuf lexbuf) - | 15 -> - (store c; COMMENT (parse_nested comment (in_comment c))) - | 16 -> - (warn Comment_start (Loc.of_lexbuf lexbuf); - parse comment (in_comment c); - COMMENT (buff_contents c)) - | 17 -> - (warn Comment_not_end (Loc.of_lexbuf lexbuf); - move_start_p (-1) c; - SYMBOL "*") - | 18 -> - let beginning = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 2) - lexbuf.Lexing.lex_curr_pos - in - if quotations c - then - (move_start_p (- (String.length beginning)); - mk_quotation quotation c "" "" 2) - else parse (symbolchar_star ("<<" ^ beginning)) c - | 19 -> - if quotations c - then - QUOTATION - { - q_name = ""; - q_loc = ""; - q_shift = 2; - q_contents = ""; - } - else parse (symbolchar_star "<<>>") c - | 20 -> - if quotations c - then with_curr_loc maybe_quotation_at c - else parse (symbolchar_star "<@") c - | 21 -> - if quotations c - then with_curr_loc maybe_quotation_colon c - else parse (symbolchar_star "<:") c - | 22 -> - let num = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) - lexbuf.Lexing.lex_mem.(1) - and name = - Lexing.sub_lexeme_opt lexbuf lexbuf.Lexing.lex_mem.(3) - lexbuf.Lexing.lex_mem.(2) in - let inum = int_of_string num - in - (update_loc c name inum true 0; - LINE_DIRECTIVE (inum, name)) - | 23 -> - let op = - Lexing.sub_lexeme_char lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - in ESCAPED_IDENT (String.make 1 op) - | 24 -> - let op = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in ESCAPED_IDENT op - | 25 -> - let op = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - lexbuf.Lexing.lex_mem.(0) - in ESCAPED_IDENT op - | 26 -> - let op = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in ESCAPED_IDENT op - | 27 -> - let op = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) - lexbuf.Lexing.lex_mem.(1) - in ESCAPED_IDENT op - | 28 -> - let x = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in SYMBOL x - | 29 -> - if antiquots c - then with_curr_loc dollar (shift 1 c) - else parse (symbolchar_star "$") c - | 30 -> - let x = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in SYMBOL x - | 31 -> - let pos = lexbuf.lex_curr_p - in - (lexbuf.lex_curr_p <- - { - (pos) - with - pos_bol = pos.pos_bol + 1; - pos_cnum = pos.pos_cnum + 1; - }; - EOI) - | 32 -> - let c = - Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos - in err (Illegal_character c) (Loc.of_lexbuf lexbuf) - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_token_rec c lexbuf __ocaml_lex_state) - and comment c lexbuf = __ocaml_lex_comment_rec c lexbuf 123 - and __ocaml_lex_comment_rec c lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf - with - | 0 -> (store c; with_curr_loc comment c; parse comment c) - | 1 -> store c - | 2 -> - (store c; - if quotations c then with_curr_loc quotation c else (); - parse comment c) - | 3 -> store_parse comment c - | 4 -> - (store c; - (try with_curr_loc string c - with - | Loc.Exc_located (_, (Error.E Unterminated_string)) -> - err Unterminated_string_in_comment (loc c)); - Buffer.add_char c.buffer '"'; - parse comment c) - | 5 -> store_parse comment c - | 6 -> store_parse comment c - | 7 -> (update_loc c None 1 false 1; store_parse comment c) - | 8 -> store_parse comment c - | 9 -> store_parse comment c - | 10 -> store_parse comment c - | 11 -> store_parse comment c - | 12 -> err Unterminated_comment (loc c) - | 13 -> (update_loc c None 1 false 0; store_parse comment c) - | 14 -> store_parse comment c - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_comment_rec c lexbuf __ocaml_lex_state) - and string c lexbuf = - (lexbuf.Lexing.lex_mem <- Array.create 2 (-1); - __ocaml_lex_string_rec c lexbuf 159) - and __ocaml_lex_string_rec c lexbuf __ocaml_lex_state = - match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state - lexbuf - with - | 0 -> set_start_p c - | 1 -> - let space = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) - lexbuf.Lexing.lex_curr_pos - in - (update_loc c None 1 false (String.length space); - store_parse string c) - | 2 -> store_parse string c - | 3 -> store_parse string c - | 4 -> store_parse string c - | 5 -> - let x = - Lexing.sub_lexeme_char lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - in - if is_in_comment c - then store_parse string c - else - (warn (Illegal_escape (String.make 1 x)) - (Loc.of_lexbuf lexbuf); - store_parse string c) - | 6 -> (update_loc c None 1 false 0; store_parse string c) - | 7 -> err Unterminated_string (loc c) - | 8 -> store_parse string c - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_string_rec c lexbuf __ocaml_lex_state) - and symbolchar_star beginning c lexbuf = - __ocaml_lex_symbolchar_star_rec beginning c lexbuf 176 - and - __ocaml_lex_symbolchar_star_rec beginning c lexbuf - __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf - with - | 0 -> - let tok = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in - (move_start_p (- (String.length beginning)) c; - SYMBOL (beginning ^ tok)) - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_symbolchar_star_rec beginning c lexbuf - __ocaml_lex_state) - and maybe_quotation_at c lexbuf = - __ocaml_lex_maybe_quotation_at_rec c lexbuf 177 - and - __ocaml_lex_maybe_quotation_at_rec c lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf - with - | 0 -> - let loc = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - mk_quotation quotation c "" loc (1 + (String.length loc)) - | 1 -> - let tok = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in SYMBOL ("<@" ^ tok) - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_maybe_quotation_at_rec c lexbuf - __ocaml_lex_state) - and maybe_quotation_colon c lexbuf = - (lexbuf.Lexing.lex_mem <- Array.create 2 (-1); - __ocaml_lex_maybe_quotation_colon_rec c lexbuf 181) - and - __ocaml_lex_maybe_quotation_colon_rec c lexbuf - __ocaml_lex_state = - match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state - lexbuf - with - | 0 -> - let name = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - mk_quotation quotation c name "" - (1 + (String.length name)) - | 1 -> - let name = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_mem.(0) - and loc = - Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_mem.(0) + 1) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - mk_quotation quotation c name loc - ((2 + (String.length loc)) + (String.length name)) - | 2 -> - let tok = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in SYMBOL ("<:" ^ tok) - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_maybe_quotation_colon_rec c lexbuf - __ocaml_lex_state) - and quotation c lexbuf = __ocaml_lex_quotation_rec c lexbuf 188 - and __ocaml_lex_quotation_rec c lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf - with - | 0 -> (store c; with_curr_loc quotation c; parse quotation c) - | 1 -> store c - | 2 -> err Unterminated_quotation (loc c) - | 3 -> (update_loc c None 1 false 0; store_parse quotation c) - | 4 -> store_parse quotation c - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_quotation_rec c lexbuf __ocaml_lex_state) - and dollar c lexbuf = __ocaml_lex_dollar_rec c lexbuf 201 - and __ocaml_lex_dollar_rec c lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf - with - | 0 -> (set_start_p c; ANTIQUOT ("", "")) - | 1 -> - let name = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - with_curr_loc (antiquot name) - (shift (1 + (String.length name)) c) - | 2 -> store_parse (antiquot "") c - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_dollar_rec c lexbuf __ocaml_lex_state) - and antiquot name c lexbuf = - __ocaml_lex_antiquot_rec name c lexbuf 210 - and __ocaml_lex_antiquot_rec name c lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf - with - | 0 -> (set_start_p c; ANTIQUOT (name, (buff_contents c))) - | 1 -> err Unterminated_antiquot (loc c) - | 2 -> - (update_loc c None 1 false 0; - store_parse (antiquot name) c) - | 3 -> - (store c; - with_curr_loc quotation c; - parse (antiquot name) c) - | 4 -> store_parse (antiquot name) c - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_antiquot_rec name c lexbuf __ocaml_lex_state) - - let lexing_store s buff max = - let rec self n s = - if n >= max - then n - else - (match Stream.peek s with - | Some x -> (Stream.junk s; buff.[n] <- x; succ n) - | _ -> n) - in self 0 s - - let from_context c = - let next _ = - let tok = with_curr_loc token c in - let loc = Loc.of_lexbuf c.lexbuf in Some (tok, loc) - in Stream.from next - - let from_lexbuf ?(quotations = true) lb = - let c = - { - (default_context lb) - with - loc = Loc.of_lexbuf lb; - antiquots = !Camlp4_config.antiquotations; - quotations = quotations; - } - in from_context c - - let setup_loc lb loc = - let start_pos = Loc.start_pos loc - in - (lb.lex_abs_pos <- start_pos.pos_cnum; - lb.lex_curr_p <- start_pos) - - let from_string ?quotations loc str = - let lb = Lexing.from_string str - in (setup_loc lb loc; from_lexbuf ?quotations lb) - - let from_stream ?quotations loc strm = - let lb = Lexing.from_function (lexing_store strm) - in (setup_loc lb loc; from_lexbuf ?quotations lb) - - let mk () loc strm = - from_stream ~quotations: !Camlp4_config.quotations loc strm - - end - - end - - module Camlp4Ast = - struct - module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = - struct - module Loc = Loc - - module Ast = - struct - include Sig.MakeCamlp4Ast(Loc) - - let safe_string_escaped s = - if - ((String.length s) > 2) && - ((s.[0] = '\\') && (s.[1] = '$')) - then s - else String.escaped s - - end - - include Ast - - external loc_of_ctyp : ctyp -> Loc.t = "%field0" - - external loc_of_patt : patt -> Loc.t = "%field0" - - external loc_of_expr : expr -> Loc.t = "%field0" - - external loc_of_module_type : module_type -> Loc.t = "%field0" - - external loc_of_module_expr : module_expr -> Loc.t = "%field0" - - external loc_of_sig_item : sig_item -> Loc.t = "%field0" - - external loc_of_str_item : str_item -> Loc.t = "%field0" - - external loc_of_class_type : class_type -> Loc.t = "%field0" - - external loc_of_class_sig_item : class_sig_item -> Loc.t = - "%field0" - - external loc_of_class_expr : class_expr -> Loc.t = "%field0" - - external loc_of_class_str_item : class_str_item -> Loc.t = - "%field0" - - external loc_of_with_constr : with_constr -> Loc.t = "%field0" - - external loc_of_binding : binding -> Loc.t = "%field0" - - external loc_of_rec_binding : rec_binding -> Loc.t = "%field0" - - external loc_of_module_binding : module_binding -> Loc.t = - "%field0" - - external loc_of_match_case : match_case -> Loc.t = "%field0" - - external loc_of_ident : ident -> Loc.t = "%field0" - - let ghost = Loc.ghost - - let rec is_module_longident = - function - | Ast.IdAcc (_, _, i) -> is_module_longident i - | Ast.IdApp (_, i1, i2) -> - (is_module_longident i1) && (is_module_longident i2) - | Ast.IdUid (_, _) -> true - | _ -> false - - let ident_of_expr = - let error () = - invalid_arg - "ident_of_expr: this expression is not an identifier" in - let rec self = - function - | Ast.ExApp (_loc, e1, e2) -> - Ast.IdApp (_loc, (self e1), (self e2)) - | Ast.ExAcc (_loc, e1, e2) -> - Ast.IdAcc (_loc, (self e1), (self e2)) - | Ast.ExId (_, (Ast.IdLid (_, _))) -> error () - | Ast.ExId (_, i) -> - if is_module_longident i then i else error () - | _ -> error () - in - function - | Ast.ExId (_, i) -> i - | Ast.ExApp (_, _, _) -> error () - | t -> self t - - let ident_of_ctyp = - let error () = - invalid_arg "ident_of_ctyp: this type is not an identifier" in - let rec self = - function - | Ast.TyApp (_loc, t1, t2) -> - Ast.IdApp (_loc, (self t1), (self t2)) - | Ast.TyId (_, (Ast.IdLid (_, _))) -> error () - | Ast.TyId (_, i) -> - if is_module_longident i then i else error () - | _ -> error () - in function | Ast.TyId (_, i) -> i | t -> self t - - let ident_of_patt = - let error () = - invalid_arg - "ident_of_patt: this pattern is not an identifier" in - let rec self = - function - | Ast.PaApp (_loc, p1, p2) -> - Ast.IdApp (_loc, (self p1), (self p2)) - | Ast.PaId (_, (Ast.IdLid (_, _))) -> error () - | Ast.PaId (_, i) -> - if is_module_longident i then i else error () - | _ -> error () - in function | Ast.PaId (_, i) -> i | p -> self p - - let rec is_irrefut_patt = - function - | Ast.PaId (_, (Ast.IdLid (_, _))) -> true - | Ast.PaId (_, (Ast.IdUid (_, "()"))) -> true - | Ast.PaAny _ -> true - | Ast.PaNil _ -> true - | Ast.PaAli (_, x, y) -> - (is_irrefut_patt x) && (is_irrefut_patt y) - | Ast.PaRec (_, p) -> is_irrefut_patt p - | Ast.PaEq (_, _, p) -> is_irrefut_patt p - | Ast.PaSem (_, p1, p2) -> - (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaCom (_, p1, p2) -> - (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaOrp (_, p1, p2) -> - (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaApp (_, p1, p2) -> - (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaTyc (_, p, _) -> is_irrefut_patt p - | Ast.PaTup (_, pl) -> is_irrefut_patt pl - | Ast.PaOlb (_, _, (Ast.PaNil _)) -> true - | Ast.PaOlb (_, _, p) -> is_irrefut_patt p - | Ast.PaOlbi (_, _, p, _) -> is_irrefut_patt p - | Ast.PaLab (_, _, (Ast.PaNil _)) -> true - | Ast.PaLab (_, _, p) -> is_irrefut_patt p - | Ast.PaLaz (_, p) -> is_irrefut_patt p - | Ast.PaId (_, _) -> false - | Ast.PaMod (_, _) -> true - | Ast.PaVrn (_, _) | Ast.PaStr (_, _) | Ast.PaRng (_, _, _) | - Ast.PaFlo (_, _) | Ast.PaNativeInt (_, _) | - Ast.PaInt64 (_, _) | Ast.PaInt32 (_, _) | Ast.PaInt (_, _) - | Ast.PaChr (_, _) | Ast.PaTyp (_, _) | Ast.PaArr (_, _) | - Ast.PaAnt (_, _) -> false - - let rec is_constructor = - function - | Ast.IdAcc (_, _, i) -> is_constructor i - | Ast.IdUid (_, _) -> true - | Ast.IdLid (_, _) | Ast.IdApp (_, _, _) -> false - | Ast.IdAnt (_, _) -> assert false - - let is_patt_constructor = - function - | Ast.PaId (_, i) -> is_constructor i - | Ast.PaVrn (_, _) -> true - | _ -> false - - let rec is_expr_constructor = - function - | Ast.ExId (_, i) -> is_constructor i - | Ast.ExAcc (_, e1, e2) -> - (is_expr_constructor e1) && (is_expr_constructor e2) - | Ast.ExVrn (_, _) -> true - | _ -> false - - let rec tyOr_of_list = - function - | [] -> Ast.TyNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_ctyp t - in Ast.TyOr (_loc, t, (tyOr_of_list ts)) - - let rec tyAnd_of_list = - function - | [] -> Ast.TyNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_ctyp t - in Ast.TyAnd (_loc, t, (tyAnd_of_list ts)) - - let rec tySem_of_list = - function - | [] -> Ast.TyNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_ctyp t - in Ast.TySem (_loc, t, (tySem_of_list ts)) - - let rec tyCom_of_list = - function - | [] -> Ast.TyNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_ctyp t - in Ast.TyCom (_loc, t, (tyCom_of_list ts)) - - let rec tyAmp_of_list = - function - | [] -> Ast.TyNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_ctyp t - in Ast.TyAmp (_loc, t, (tyAmp_of_list ts)) - - let rec tySta_of_list = - function - | [] -> Ast.TyNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_ctyp t - in Ast.TySta (_loc, t, (tySta_of_list ts)) - - let rec stSem_of_list = - function - | [] -> Ast.StNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_str_item t - in Ast.StSem (_loc, t, (stSem_of_list ts)) - - let rec sgSem_of_list = - function - | [] -> Ast.SgNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_sig_item t - in Ast.SgSem (_loc, t, (sgSem_of_list ts)) - - let rec biAnd_of_list = - function - | [] -> Ast.BiNil ghost - | [ b ] -> b - | b :: bs -> - let _loc = loc_of_binding b - in Ast.BiAnd (_loc, b, (biAnd_of_list bs)) - - let rec rbSem_of_list = - function - | [] -> Ast.RbNil ghost - | [ b ] -> b - | b :: bs -> - let _loc = loc_of_rec_binding b - in Ast.RbSem (_loc, b, (rbSem_of_list bs)) - - let rec wcAnd_of_list = - function - | [] -> Ast.WcNil ghost - | [ w ] -> w - | w :: ws -> - let _loc = loc_of_with_constr w - in Ast.WcAnd (_loc, w, (wcAnd_of_list ws)) - - let rec idAcc_of_list = - function - | [] -> assert false - | [ i ] -> i - | i :: is -> - let _loc = loc_of_ident i - in Ast.IdAcc (_loc, i, (idAcc_of_list is)) - - let rec idApp_of_list = - function - | [] -> assert false - | [ i ] -> i - | i :: is -> - let _loc = loc_of_ident i - in Ast.IdApp (_loc, i, (idApp_of_list is)) - - let rec mcOr_of_list = - function - | [] -> Ast.McNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_match_case x - in Ast.McOr (_loc, x, (mcOr_of_list xs)) - - let rec mbAnd_of_list = - function - | [] -> Ast.MbNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_module_binding x - in Ast.MbAnd (_loc, x, (mbAnd_of_list xs)) - - let rec meApp_of_list = - function - | [] -> assert false - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_module_expr x - in Ast.MeApp (_loc, x, (meApp_of_list xs)) - - let rec ceAnd_of_list = - function - | [] -> Ast.CeNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_class_expr x - in Ast.CeAnd (_loc, x, (ceAnd_of_list xs)) - - let rec ctAnd_of_list = - function - | [] -> Ast.CtNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_class_type x - in Ast.CtAnd (_loc, x, (ctAnd_of_list xs)) - - let rec cgSem_of_list = - function - | [] -> Ast.CgNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_class_sig_item x - in Ast.CgSem (_loc, x, (cgSem_of_list xs)) - - let rec crSem_of_list = - function - | [] -> Ast.CrNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_class_str_item x - in Ast.CrSem (_loc, x, (crSem_of_list xs)) - - let rec paSem_of_list = - function - | [] -> Ast.PaNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_patt x - in Ast.PaSem (_loc, x, (paSem_of_list xs)) - - let rec paCom_of_list = - function - | [] -> Ast.PaNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_patt x - in Ast.PaCom (_loc, x, (paCom_of_list xs)) - - let rec exSem_of_list = - function - | [] -> Ast.ExNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_expr x - in Ast.ExSem (_loc, x, (exSem_of_list xs)) - - let rec exCom_of_list = - function - | [] -> Ast.ExNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_expr x - in Ast.ExCom (_loc, x, (exCom_of_list xs)) - - let ty_of_stl = - function - | (_loc, s, []) -> Ast.TyId (_loc, (Ast.IdUid (_loc, s))) - | (_loc, s, tl) -> - Ast.TyOf (_loc, (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), - (tyAnd_of_list tl)) - - let ty_of_sbt = - function - | (_loc, s, true, t) -> - Ast.TyCol (_loc, (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), - (Ast.TyMut (_loc, t))) - | (_loc, s, false, t) -> - Ast.TyCol (_loc, (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), - t) - - let bi_of_pe (p, e) = - let _loc = loc_of_patt p in Ast.BiEq (_loc, p, e) - - let sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l) - - let record_type_of_list l = tySem_of_list (List.map ty_of_sbt l) - - let binding_of_pel l = biAnd_of_list (List.map bi_of_pe l) - - let rec pel_of_binding = - function - | Ast.BiAnd (_, b1, b2) -> - (pel_of_binding b1) @ (pel_of_binding b2) - | Ast.BiEq (_, p, e) -> [ (p, e) ] - | _ -> assert false - - let rec list_of_binding x acc = - match x with - | Ast.BiAnd (_, b1, b2) -> - list_of_binding b1 (list_of_binding b2 acc) - | t -> t :: acc - - let rec list_of_rec_binding x acc = - match x with - | Ast.RbSem (_, b1, b2) -> - list_of_rec_binding b1 (list_of_rec_binding b2 acc) - | t -> t :: acc - - let rec list_of_with_constr x acc = - match x with - | Ast.WcAnd (_, w1, w2) -> - list_of_with_constr w1 (list_of_with_constr w2 acc) - | t -> t :: acc - - let rec list_of_ctyp x acc = - match x with - | Ast.TyNil _ -> acc - | Ast.TyAmp (_, x, y) | Ast.TyCom (_, x, y) | - Ast.TySta (_, x, y) | Ast.TySem (_, x, y) | - Ast.TyAnd (_, x, y) | Ast.TyOr (_, x, y) -> - list_of_ctyp x (list_of_ctyp y acc) - | x -> x :: acc - - let rec list_of_patt x acc = - match x with - | Ast.PaNil _ -> acc - | Ast.PaCom (_, x, y) | Ast.PaSem (_, x, y) -> - list_of_patt x (list_of_patt y acc) - | x -> x :: acc - - let rec list_of_expr x acc = - match x with - | Ast.ExNil _ -> acc - | Ast.ExCom (_, x, y) | Ast.ExSem (_, x, y) -> - list_of_expr x (list_of_expr y acc) - | x -> x :: acc - - let rec list_of_str_item x acc = - match x with - | Ast.StNil _ -> acc - | Ast.StSem (_, x, y) -> - list_of_str_item x (list_of_str_item y acc) - | x -> x :: acc - - let rec list_of_sig_item x acc = - match x with - | Ast.SgNil _ -> acc - | Ast.SgSem (_, x, y) -> - list_of_sig_item x (list_of_sig_item y acc) - | x -> x :: acc - - let rec list_of_class_sig_item x acc = - match x with - | Ast.CgNil _ -> acc - | Ast.CgSem (_, x, y) -> - list_of_class_sig_item x (list_of_class_sig_item y acc) - | x -> x :: acc - - let rec list_of_class_str_item x acc = - match x with - | Ast.CrNil _ -> acc - | Ast.CrSem (_, x, y) -> - list_of_class_str_item x (list_of_class_str_item y acc) - | x -> x :: acc - - let rec list_of_class_type x acc = - match x with - | Ast.CtAnd (_, x, y) -> - list_of_class_type x (list_of_class_type y acc) - | x -> x :: acc - - let rec list_of_class_expr x acc = - match x with - | Ast.CeAnd (_, x, y) -> - list_of_class_expr x (list_of_class_expr y acc) - | x -> x :: acc - - let rec list_of_module_expr x acc = - match x with - | Ast.MeApp (_, x, y) -> - list_of_module_expr x (list_of_module_expr y acc) - | x -> x :: acc - - let rec list_of_match_case x acc = - match x with - | Ast.McNil _ -> acc - | Ast.McOr (_, x, y) -> - list_of_match_case x (list_of_match_case y acc) - | x -> x :: acc - - let rec list_of_ident x acc = - match x with - | Ast.IdAcc (_, x, y) | Ast.IdApp (_, x, y) -> - list_of_ident x (list_of_ident y acc) - | x -> x :: acc - - let rec list_of_module_binding x acc = - match x with - | Ast.MbAnd (_, x, y) -> - list_of_module_binding x (list_of_module_binding y acc) - | x -> x :: acc - - module Meta = - struct - module type META_LOC = - sig - val meta_loc_patt : Loc.t -> Loc.t -> Ast.patt - - val meta_loc_expr : Loc.t -> Loc.t -> Ast.expr - - end - - module MetaLoc = - struct - let meta_loc_patt _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location - in - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), - (Ast.IdLid (_loc, "of_tuple")))))), - (Ast.PaTup (_loc, - (Ast.PaCom (_loc, - (Ast.PaStr (_loc, - (Ast.safe_string_escaped a))), - (Ast.PaCom (_loc, - (Ast.PaCom (_loc, - (Ast.PaCom (_loc, - (Ast.PaCom (_loc, - (Ast.PaCom (_loc, - (Ast.PaCom (_loc, - (Ast.PaInt (_loc, - (string_of_int b))), - (Ast.PaInt (_loc, - (string_of_int c))))), - (Ast.PaInt (_loc, - (string_of_int d))))), - (Ast.PaInt (_loc, - (string_of_int e))))), - (Ast.PaInt (_loc, (string_of_int f))))), - (Ast.PaInt (_loc, (string_of_int g))))), - (if h - then - Ast.PaId (_loc, - (Ast.IdUid (_loc, "True"))) - else - Ast.PaId (_loc, - (Ast.IdUid (_loc, "False"))))))))))) - - let meta_loc_expr _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location - in - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), - (Ast.IdLid (_loc, "of_tuple")))))), - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, - (Ast.ExStr (_loc, - (Ast.safe_string_escaped a))), - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExInt (_loc, - (string_of_int b))), - (Ast.ExInt (_loc, - (string_of_int c))))), - (Ast.ExInt (_loc, - (string_of_int d))))), - (Ast.ExInt (_loc, - (string_of_int e))))), - (Ast.ExInt (_loc, (string_of_int f))))), - (Ast.ExInt (_loc, (string_of_int g))))), - (if h - then - Ast.ExId (_loc, - (Ast.IdUid (_loc, "True"))) - else - Ast.ExId (_loc, - (Ast.IdUid (_loc, "False"))))))))))) - - end - - module MetaGhostLoc = - struct - let meta_loc_patt _loc _ = - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), - (Ast.IdLid (_loc, "ghost"))))) - - let meta_loc_expr _loc _ = - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), - (Ast.IdLid (_loc, "ghost"))))) - - end - - module MetaLocVar = - struct - let meta_loc_patt _loc _ = - Ast.PaId (_loc, (Ast.IdLid (_loc, !Loc.name))) - - let meta_loc_expr _loc _ = - Ast.ExId (_loc, (Ast.IdLid (_loc, !Loc.name))) - - end - - module Make (MetaLoc : META_LOC) = - struct - open MetaLoc - - let meta_loc = meta_loc_expr - - module Expr = - struct - let meta_string _loc s = - Ast.ExStr (_loc, (safe_string_escaped s)) - - let meta_int _loc s = Ast.ExInt (_loc, s) - - let meta_float _loc s = Ast.ExFlo (_loc, s) - - let meta_char _loc s = - Ast.ExChr (_loc, (String.escaped s)) - - let meta_bool _loc = - function - | false -> - Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))) - | true -> - Ast.ExId (_loc, (Ast.IdUid (_loc, "True"))) - - let rec meta_list mf_a _loc = - function - | [] -> Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))) - | x :: xs -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), - (mf_a _loc x))), - (meta_list mf_a _loc xs)) - - let rec meta_binding _loc = - function - | Ast.BiAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.BiEq (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiEq")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_expr _loc x2)) - | Ast.BiAnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiAnd")))))), - (meta_loc _loc x0))), - (meta_binding _loc x1))), - (meta_binding _loc x2)) - | Ast.BiNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiNil")))))), - (meta_loc _loc x0)) - and meta_class_expr _loc = - function - | Ast.CeAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.CeEq (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeEq")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_class_expr _loc x2)) - | Ast.CeAnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeAnd")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_class_expr _loc x2)) - | Ast.CeTyc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeTyc")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_class_type _loc x2)) - | Ast.CeStr (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeStr")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_class_str_item _loc x2)) - | Ast.CeLet (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeLet")))))), - (meta_loc _loc x0))), - (meta_rec_flag _loc x1))), - (meta_binding _loc x2))), - (meta_class_expr _loc x3)) - | Ast.CeFun (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeFun")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_class_expr _loc x2)) - | Ast.CeCon (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeCon")))))), - (meta_loc _loc x0))), - (meta_virtual_flag _loc x1))), - (meta_ident _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CeApp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeApp")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.CeNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeNil")))))), - (meta_loc _loc x0)) - and meta_class_sig_item _loc = - function - | Ast.CgAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.CgVir (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgVir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_private_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CgVal (x0, x1, x2, x3, x4) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgVal")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_mutable_flag _loc x2))), - (meta_virtual_flag _loc x3))), - (meta_ctyp _loc x4)) - | Ast.CgMth (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgMth")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_private_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CgInh (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgInh")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.CgSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgSem")))))), - (meta_loc _loc x0))), - (meta_class_sig_item _loc x1))), - (meta_class_sig_item _loc x2)) - | Ast.CgCtr (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgCtr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.CgNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgNil")))))), - (meta_loc _loc x0)) - and meta_class_str_item _loc = - function - | Ast.CrAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.CrVvr (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrVvr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_mutable_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CrVir (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrVir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_private_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CrVal (x0, x1, x2, x3, x4) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrVal")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_override_flag _loc x2))), - (meta_mutable_flag _loc x3))), - (meta_expr _loc x4)) - | Ast.CrMth (x0, x1, x2, x3, x4, x5) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, - "CrMth")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_override_flag _loc x2))), - (meta_private_flag _loc x3))), - (meta_expr _loc x4))), - (meta_ctyp _loc x5)) - | Ast.CrIni (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrIni")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.CrInh (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrInh")))))), - (meta_loc _loc x0))), - (meta_override_flag _loc x1))), - (meta_class_expr _loc x2))), - (meta_string _loc x3)) - | Ast.CrCtr (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrCtr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.CrSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrSem")))))), - (meta_loc _loc x0))), - (meta_class_str_item _loc x1))), - (meta_class_str_item _loc x2)) - | Ast.CrNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrNil")))))), - (meta_loc _loc x0)) - and meta_class_type _loc = - function - | Ast.CtAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.CtEq (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtEq")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtCol (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtCol")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtAnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtAnd")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtSig (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtSig")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_class_sig_item _loc x2)) - | Ast.CtFun (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtFun")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtCon (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtCon")))))), - (meta_loc _loc x0))), - (meta_virtual_flag _loc x1))), - (meta_ident _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CtNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtNil")))))), - (meta_loc _loc x0)) - and meta_ctyp _loc = - function - | Ast.TyAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.TyPkg (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyPkg")))))), - (meta_loc _loc x0))), - (meta_module_type _loc x1)) - | Ast.TyOfAmp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOfAmp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyAmp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAmp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyVrnInfSup (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnInfSup")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyVrnInf (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnInf")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyVrnSup (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnSup")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyVrnEq (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnEq")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TySta (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TySta")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyTup (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyTup")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyMut (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyMut")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyPrv (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyPrv")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyOr (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyAnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnd")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyOf (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOf")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TySum (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TySum")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyCom (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyCom")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TySem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TySem")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyCol (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyCol")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyRec (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyRec")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyVrn (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrn")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyAnM x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnM")))))), - (meta_loc _loc x0)) - | Ast.TyAnP x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnP")))))), - (meta_loc _loc x0)) - | Ast.TyQuM (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyQuM")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyQuP (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyQuP")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyQuo (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyQuo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyTypePol (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyTypePol")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyPol (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyPol")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyOlb (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOlb")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyObj (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyObj")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_row_var_flag _loc x2)) - | Ast.TyDcl (x0, x1, x2, x3, x4) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyDcl")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_list meta_ctyp _loc x2))), - (meta_ctyp _loc x3))), - (meta_list - (fun _loc (x1, x2) -> - Ast.ExTup (_loc, - (Ast.ExCom (_loc, - (meta_ctyp _loc x1), - (meta_ctyp _loc x2))))) - _loc x4)) - | Ast.TyMan (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyMan")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyId (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.TyLab (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyLab")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyCls (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyCls")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.TyArr (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyArr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyApp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyApp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyAny x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAny")))))), - (meta_loc _loc x0)) - | Ast.TyAli (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAli")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyNil")))))), - (meta_loc _loc x0)) - and meta_direction_flag _loc = - function - | Ast.DiAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.DiDownto -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "DiDownto"))))) - | Ast.DiTo -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "DiTo"))))) - and meta_expr _loc = - function - | Ast.ExPkg (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExPkg")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1)) - | Ast.ExFUN (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExFUN")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.ExOpI (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExOpI")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_expr _loc x2)) - | Ast.ExWhi (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExWhi")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExVrn (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExVrn")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExTyc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExTyc")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_ctyp _loc x2)) - | Ast.ExCom (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExCom")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExTup (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExTup")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExTry (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExTry")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_match_case _loc x2)) - | Ast.ExStr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExStr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExSte (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSte")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExSnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSnd")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_string _loc x2)) - | Ast.ExSeq (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSeq")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExRec (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExRec")))))), - (meta_loc _loc x0))), - (meta_rec_binding _loc x1))), - (meta_expr _loc x2)) - | Ast.ExOvr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExOvr")))))), - (meta_loc _loc x0))), - (meta_rec_binding _loc x1)) - | Ast.ExOlb (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExOlb")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.ExObj (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExObj")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_class_str_item _loc x2)) - | Ast.ExNew (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExNew")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.ExMat (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExMat")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_match_case _loc x2)) - | Ast.ExLmd (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLmd")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_expr _loc x2))), - (meta_expr _loc x3)) - | Ast.ExLet (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLet")))))), - (meta_loc _loc x0))), - (meta_rec_flag _loc x1))), - (meta_binding _loc x2))), - (meta_expr _loc x3)) - | Ast.ExLaz (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLaz")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExLab (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLab")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.ExNativeInt (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExNativeInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExInt64 (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExInt64")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExInt32 (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExInt32")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExInt (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExIfe (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExIfe")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2))), - (meta_expr _loc x3)) - | Ast.ExFun (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExFun")))))), - (meta_loc _loc x0))), - (meta_match_case _loc x1)) - | Ast.ExFor (x0, x1, x2, x3, x4, x5) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, - "ExFor")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2))), - (meta_expr _loc x3))), - (meta_direction_flag _loc x4))), - (meta_expr _loc x5)) - | Ast.ExFlo (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExFlo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExCoe (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExCoe")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_ctyp _loc x2))), - (meta_ctyp _loc x3)) - | Ast.ExChr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExChr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExAss (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAss")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExAsr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAsr")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExAsf x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAsf")))))), - (meta_loc _loc x0)) - | Ast.ExSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSem")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExArr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExArr")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExAre (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAre")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExApp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExApp")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.ExAcc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAcc")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExId (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.ExNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExNil")))))), - (meta_loc _loc x0)) - and meta_ident _loc = - function - | Ast.IdAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.IdUid (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdUid")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.IdLid (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdLid")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.IdApp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdApp")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - | Ast.IdAcc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdAcc")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - and meta_match_case _loc = - function - | Ast.McAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.McArr (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McArr")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_expr _loc x2))), - (meta_expr _loc x3)) - | Ast.McOr (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McOr")))))), - (meta_loc _loc x0))), - (meta_match_case _loc x1))), - (meta_match_case _loc x2)) - | Ast.McNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McNil")))))), - (meta_loc _loc x0)) - and meta_meta_bool _loc = - function - | Ast.BAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.BFalse -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BFalse"))))) - | Ast.BTrue -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BTrue"))))) - and meta_meta_list mf_a _loc = - function - | Ast.LAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.LCons (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "LCons")))))), - (mf_a _loc x0))), - (meta_meta_list mf_a _loc x1)) - | Ast.LNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "LNil"))))) - and meta_meta_option mf_a _loc = - function - | Ast.OAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.OSome x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "OSome")))))), - (mf_a _loc x0)) - | Ast.ONone -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ONone"))))) - and meta_module_binding _loc = - function - | Ast.MbAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.MbCol (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbCol")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.MbColEq (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbColEq")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2))), - (meta_module_expr _loc x3)) - | Ast.MbAnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbAnd")))))), - (meta_loc _loc x0))), - (meta_module_binding _loc x1))), - (meta_module_binding _loc x2)) - | Ast.MbNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbNil")))))), - (meta_loc _loc x0)) - and meta_module_expr _loc = - function - | Ast.MeAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.MePkg (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MePkg")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.MeTyc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeTyc")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1))), - (meta_module_type _loc x2)) - | Ast.MeStr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeStr")))))), - (meta_loc _loc x0))), - (meta_str_item _loc x1)) - | Ast.MeFun (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeFun")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2))), - (meta_module_expr _loc x3)) - | Ast.MeApp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeApp")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1))), - (meta_module_expr _loc x2)) - | Ast.MeId (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.MeNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeNil")))))), - (meta_loc _loc x0)) - and meta_module_type _loc = - function - | Ast.MtAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.MtOf (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtOf")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1)) - | Ast.MtWit (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtWit")))))), - (meta_loc _loc x0))), - (meta_module_type _loc x1))), - (meta_with_constr _loc x2)) - | Ast.MtSig (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtSig")))))), - (meta_loc _loc x0))), - (meta_sig_item _loc x1)) - | Ast.MtQuo (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtQuo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.MtFun (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtFun")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2))), - (meta_module_type _loc x3)) - | Ast.MtId (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.MtNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtNil")))))), - (meta_loc _loc x0)) - and meta_mutable_flag _loc = - function - | Ast.MuAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.MuNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MuNil"))))) - | Ast.MuMutable -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MuMutable"))))) - and meta_override_flag _loc = - function - | Ast.OvAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.OvNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "OvNil"))))) - | Ast.OvOverride -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "OvOverride"))))) - and meta_patt _loc = - function - | Ast.PaMod (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaMod")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaLaz (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaLaz")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaVrn (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaVrn")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaTyp (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaTyp")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.PaTyc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaTyc")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_ctyp _loc x2)) - | Ast.PaTup (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaTup")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaStr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaStr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaEq (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaEq")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_patt _loc x2)) - | Ast.PaRec (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaRec")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaRng (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaRng")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaOrp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaOrp")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaOlbi (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaOlbi")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_patt _loc x2))), - (meta_expr _loc x3)) - | Ast.PaOlb (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaOlb")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_patt _loc x2)) - | Ast.PaLab (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaLab")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_patt _loc x2)) - | Ast.PaFlo (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaFlo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaNativeInt (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaNativeInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaInt64 (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaInt64")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaInt32 (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaInt32")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaInt (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaChr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaChr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaSem")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaCom (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaCom")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaArr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaArr")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaApp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaApp")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaAny x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaAny")))))), - (meta_loc _loc x0)) - | Ast.PaAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.PaAli (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaAli")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaId (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.PaNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaNil")))))), - (meta_loc _loc x0)) - and meta_private_flag _loc = - function - | Ast.PrAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.PrNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PrNil"))))) - | Ast.PrPrivate -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PrPrivate"))))) - and meta_rec_binding _loc = - function - | Ast.RbAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.RbEq (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbEq")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_expr _loc x2)) - | Ast.RbSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbSem")))))), - (meta_loc _loc x0))), - (meta_rec_binding _loc x1))), - (meta_rec_binding _loc x2)) - | Ast.RbNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbNil")))))), - (meta_loc _loc x0)) - and meta_rec_flag _loc = - function - | Ast.ReAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.ReNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ReNil"))))) - | Ast.ReRecursive -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ReRecursive"))))) - and meta_row_var_flag _loc = - function - | Ast.RvAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.RvNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RvNil"))))) - | Ast.RvRowVar -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RvRowVar"))))) - and meta_sig_item _loc = - function - | Ast.SgAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.SgVal (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgVal")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2)) - | Ast.SgTyp (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgTyp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.SgOpn (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgOpn")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.SgMty (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgMty")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.SgRecMod (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgRecMod")))))), - (meta_loc _loc x0))), - (meta_module_binding _loc x1)) - | Ast.SgMod (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgMod")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.SgInc (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgInc")))))), - (meta_loc _loc x0))), - (meta_module_type _loc x1)) - | Ast.SgExt (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgExt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2))), - (meta_meta_list meta_string _loc x3)) - | Ast.SgExc (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgExc")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.SgDir (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgDir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.SgSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgSem")))))), - (meta_loc _loc x0))), - (meta_sig_item _loc x1))), - (meta_sig_item _loc x2)) - | Ast.SgClt (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgClt")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.SgCls (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgCls")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.SgNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgNil")))))), - (meta_loc _loc x0)) - and meta_str_item _loc = - function - | Ast.StAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.StVal (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StVal")))))), - (meta_loc _loc x0))), - (meta_rec_flag _loc x1))), - (meta_binding _loc x2)) - | Ast.StTyp (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StTyp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.StOpn (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StOpn")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.StMty (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StMty")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.StRecMod (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StRecMod")))))), - (meta_loc _loc x0))), - (meta_module_binding _loc x1)) - | Ast.StMod (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StMod")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_expr _loc x2)) - | Ast.StInc (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StInc")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1)) - | Ast.StExt (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StExt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2))), - (meta_meta_list meta_string _loc x3)) - | Ast.StExp (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StExp")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.StExc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StExc")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_meta_option meta_ident _loc x2)) - | Ast.StDir (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StDir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.StSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StSem")))))), - (meta_loc _loc x0))), - (meta_str_item _loc x1))), - (meta_str_item _loc x2)) - | Ast.StClt (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StClt")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.StCls (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StCls")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1)) - | Ast.StNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StNil")))))), - (meta_loc _loc x0)) - and meta_virtual_flag _loc = - function - | Ast.ViAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.ViNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ViNil"))))) - | Ast.ViVirtual -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ViVirtual"))))) - and meta_with_constr _loc = - function - | Ast.WcAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.WcAnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcAnd")))))), - (meta_loc _loc x0))), - (meta_with_constr _loc x1))), - (meta_with_constr _loc x2)) - | Ast.WcMoS (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcMoS")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - | Ast.WcTyS (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcTyS")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.WcMod (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcMod")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - | Ast.WcTyp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcTyp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.WcNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcNil")))))), - (meta_loc _loc x0)) - - end - - let meta_loc = meta_loc_patt - - module Patt = - struct - let meta_string _loc s = - Ast.PaStr (_loc, (safe_string_escaped s)) - - let meta_int _loc s = Ast.PaInt (_loc, s) - - let meta_float _loc s = Ast.PaFlo (_loc, s) - - let meta_char _loc s = - Ast.PaChr (_loc, (String.escaped s)) - - let meta_bool _loc = - function - | false -> - Ast.PaId (_loc, (Ast.IdUid (_loc, "False"))) - | true -> - Ast.PaId (_loc, (Ast.IdUid (_loc, "True"))) - - let rec meta_list mf_a _loc = - function - | [] -> Ast.PaId (_loc, (Ast.IdUid (_loc, "[]"))) - | x :: xs -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "::")))), - (mf_a _loc x))), - (meta_list mf_a _loc xs)) - - let rec meta_binding _loc = - function - | Ast.BiAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.BiEq (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiEq")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_expr _loc x2)) - | Ast.BiAnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiAnd")))))), - (meta_loc _loc x0))), - (meta_binding _loc x1))), - (meta_binding _loc x2)) - | Ast.BiNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiNil")))))), - (meta_loc _loc x0)) - and meta_class_expr _loc = - function - | Ast.CeAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.CeEq (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeEq")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_class_expr _loc x2)) - | Ast.CeAnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeAnd")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_class_expr _loc x2)) - | Ast.CeTyc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeTyc")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_class_type _loc x2)) - | Ast.CeStr (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeStr")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_class_str_item _loc x2)) - | Ast.CeLet (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeLet")))))), - (meta_loc _loc x0))), - (meta_rec_flag _loc x1))), - (meta_binding _loc x2))), - (meta_class_expr _loc x3)) - | Ast.CeFun (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeFun")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_class_expr _loc x2)) - | Ast.CeCon (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeCon")))))), - (meta_loc _loc x0))), - (meta_virtual_flag _loc x1))), - (meta_ident _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CeApp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeApp")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.CeNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeNil")))))), - (meta_loc _loc x0)) - and meta_class_sig_item _loc = - function - | Ast.CgAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.CgVir (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgVir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_private_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CgVal (x0, x1, x2, x3, x4) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgVal")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_mutable_flag _loc x2))), - (meta_virtual_flag _loc x3))), - (meta_ctyp _loc x4)) - | Ast.CgMth (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgMth")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_private_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CgInh (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgInh")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.CgSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgSem")))))), - (meta_loc _loc x0))), - (meta_class_sig_item _loc x1))), - (meta_class_sig_item _loc x2)) - | Ast.CgCtr (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgCtr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.CgNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgNil")))))), - (meta_loc _loc x0)) - and meta_class_str_item _loc = - function - | Ast.CrAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.CrVvr (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrVvr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_mutable_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CrVir (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrVir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_private_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CrVal (x0, x1, x2, x3, x4) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrVal")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_override_flag _loc x2))), - (meta_mutable_flag _loc x3))), - (meta_expr _loc x4)) - | Ast.CrMth (x0, x1, x2, x3, x4, x5) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, - "CrMth")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_override_flag _loc x2))), - (meta_private_flag _loc x3))), - (meta_expr _loc x4))), - (meta_ctyp _loc x5)) - | Ast.CrIni (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrIni")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.CrInh (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrInh")))))), - (meta_loc _loc x0))), - (meta_override_flag _loc x1))), - (meta_class_expr _loc x2))), - (meta_string _loc x3)) - | Ast.CrCtr (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrCtr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.CrSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrSem")))))), - (meta_loc _loc x0))), - (meta_class_str_item _loc x1))), - (meta_class_str_item _loc x2)) - | Ast.CrNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrNil")))))), - (meta_loc _loc x0)) - and meta_class_type _loc = - function - | Ast.CtAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.CtEq (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtEq")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtCol (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtCol")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtAnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtAnd")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtSig (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtSig")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_class_sig_item _loc x2)) - | Ast.CtFun (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtFun")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtCon (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtCon")))))), - (meta_loc _loc x0))), - (meta_virtual_flag _loc x1))), - (meta_ident _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CtNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtNil")))))), - (meta_loc _loc x0)) - and meta_ctyp _loc = - function - | Ast.TyAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.TyPkg (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyPkg")))))), - (meta_loc _loc x0))), - (meta_module_type _loc x1)) - | Ast.TyOfAmp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOfAmp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyAmp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAmp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyVrnInfSup (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnInfSup")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyVrnInf (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnInf")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyVrnSup (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnSup")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyVrnEq (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnEq")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TySta (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TySta")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyTup (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyTup")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyMut (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyMut")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyPrv (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyPrv")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyOr (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyAnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnd")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyOf (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOf")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TySum (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TySum")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyCom (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyCom")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TySem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TySem")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyCol (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyCol")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyRec (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyRec")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyVrn (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrn")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyAnM x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnM")))))), - (meta_loc _loc x0)) - | Ast.TyAnP x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnP")))))), - (meta_loc _loc x0)) - | Ast.TyQuM (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyQuM")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyQuP (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyQuP")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyQuo (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyQuo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyTypePol (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyTypePol")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyPol (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyPol")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyOlb (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOlb")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyObj (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyObj")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_row_var_flag _loc x2)) - | Ast.TyDcl (x0, x1, x2, x3, x4) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyDcl")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_list meta_ctyp _loc x2))), - (meta_ctyp _loc x3))), - (meta_list - (fun _loc (x1, x2) -> - Ast.PaTup (_loc, - (Ast.PaCom (_loc, - (meta_ctyp _loc x1), - (meta_ctyp _loc x2))))) - _loc x4)) - | Ast.TyMan (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyMan")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyId (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.TyLab (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyLab")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyCls (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyCls")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.TyArr (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyArr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyApp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyApp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyAny x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAny")))))), - (meta_loc _loc x0)) - | Ast.TyAli (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAli")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyNil")))))), - (meta_loc _loc x0)) - and meta_direction_flag _loc = - function - | Ast.DiAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.DiDownto -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "DiDownto"))))) - | Ast.DiTo -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "DiTo"))))) - and meta_expr _loc = - function - | Ast.ExPkg (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExPkg")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1)) - | Ast.ExFUN (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExFUN")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.ExOpI (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExOpI")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_expr _loc x2)) - | Ast.ExWhi (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExWhi")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExVrn (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExVrn")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExTyc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExTyc")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_ctyp _loc x2)) - | Ast.ExCom (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExCom")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExTup (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExTup")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExTry (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExTry")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_match_case _loc x2)) - | Ast.ExStr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExStr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExSte (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSte")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExSnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSnd")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_string _loc x2)) - | Ast.ExSeq (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSeq")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExRec (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExRec")))))), - (meta_loc _loc x0))), - (meta_rec_binding _loc x1))), - (meta_expr _loc x2)) - | Ast.ExOvr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExOvr")))))), - (meta_loc _loc x0))), - (meta_rec_binding _loc x1)) - | Ast.ExOlb (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExOlb")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.ExObj (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExObj")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_class_str_item _loc x2)) - | Ast.ExNew (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExNew")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.ExMat (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExMat")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_match_case _loc x2)) - | Ast.ExLmd (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLmd")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_expr _loc x2))), - (meta_expr _loc x3)) - | Ast.ExLet (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLet")))))), - (meta_loc _loc x0))), - (meta_rec_flag _loc x1))), - (meta_binding _loc x2))), - (meta_expr _loc x3)) - | Ast.ExLaz (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLaz")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExLab (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLab")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.ExNativeInt (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExNativeInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExInt64 (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExInt64")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExInt32 (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExInt32")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExInt (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExIfe (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExIfe")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2))), - (meta_expr _loc x3)) - | Ast.ExFun (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExFun")))))), - (meta_loc _loc x0))), - (meta_match_case _loc x1)) - | Ast.ExFor (x0, x1, x2, x3, x4, x5) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, - "ExFor")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2))), - (meta_expr _loc x3))), - (meta_direction_flag _loc x4))), - (meta_expr _loc x5)) - | Ast.ExFlo (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExFlo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExCoe (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExCoe")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_ctyp _loc x2))), - (meta_ctyp _loc x3)) - | Ast.ExChr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExChr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExAss (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAss")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExAsr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAsr")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExAsf x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAsf")))))), - (meta_loc _loc x0)) - | Ast.ExSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSem")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExArr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExArr")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExAre (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAre")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExApp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExApp")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.ExAcc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAcc")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExId (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.ExNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExNil")))))), - (meta_loc _loc x0)) - and meta_ident _loc = - function - | Ast.IdAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.IdUid (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdUid")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.IdLid (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdLid")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.IdApp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdApp")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - | Ast.IdAcc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdAcc")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - and meta_match_case _loc = - function - | Ast.McAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.McArr (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McArr")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_expr _loc x2))), - (meta_expr _loc x3)) - | Ast.McOr (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McOr")))))), - (meta_loc _loc x0))), - (meta_match_case _loc x1))), - (meta_match_case _loc x2)) - | Ast.McNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McNil")))))), - (meta_loc _loc x0)) - and meta_meta_bool _loc = - function - | Ast.BAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.BFalse -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BFalse"))))) - | Ast.BTrue -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BTrue"))))) - and meta_meta_list mf_a _loc = - function - | Ast.LAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.LCons (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "LCons")))))), - (mf_a _loc x0))), - (meta_meta_list mf_a _loc x1)) - | Ast.LNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "LNil"))))) - and meta_meta_option mf_a _loc = - function - | Ast.OAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.OSome x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "OSome")))))), - (mf_a _loc x0)) - | Ast.ONone -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ONone"))))) - and meta_module_binding _loc = - function - | Ast.MbAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.MbCol (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbCol")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.MbColEq (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbColEq")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2))), - (meta_module_expr _loc x3)) - | Ast.MbAnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbAnd")))))), - (meta_loc _loc x0))), - (meta_module_binding _loc x1))), - (meta_module_binding _loc x2)) - | Ast.MbNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbNil")))))), - (meta_loc _loc x0)) - and meta_module_expr _loc = - function - | Ast.MeAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.MePkg (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MePkg")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.MeTyc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeTyc")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1))), - (meta_module_type _loc x2)) - | Ast.MeStr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeStr")))))), - (meta_loc _loc x0))), - (meta_str_item _loc x1)) - | Ast.MeFun (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeFun")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2))), - (meta_module_expr _loc x3)) - | Ast.MeApp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeApp")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1))), - (meta_module_expr _loc x2)) - | Ast.MeId (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.MeNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeNil")))))), - (meta_loc _loc x0)) - and meta_module_type _loc = - function - | Ast.MtAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.MtOf (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtOf")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1)) - | Ast.MtWit (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtWit")))))), - (meta_loc _loc x0))), - (meta_module_type _loc x1))), - (meta_with_constr _loc x2)) - | Ast.MtSig (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtSig")))))), - (meta_loc _loc x0))), - (meta_sig_item _loc x1)) - | Ast.MtQuo (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtQuo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.MtFun (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtFun")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2))), - (meta_module_type _loc x3)) - | Ast.MtId (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.MtNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtNil")))))), - (meta_loc _loc x0)) - and meta_mutable_flag _loc = - function - | Ast.MuAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.MuNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MuNil"))))) - | Ast.MuMutable -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MuMutable"))))) - and meta_override_flag _loc = - function - | Ast.OvAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.OvNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "OvNil"))))) - | Ast.OvOverride -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "OvOverride"))))) - and meta_patt _loc = - function - | Ast.PaMod (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaMod")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaLaz (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaLaz")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaVrn (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaVrn")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaTyp (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaTyp")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.PaTyc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaTyc")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_ctyp _loc x2)) - | Ast.PaTup (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaTup")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaStr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaStr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaEq (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaEq")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_patt _loc x2)) - | Ast.PaRec (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaRec")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaRng (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaRng")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaOrp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaOrp")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaOlbi (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaOlbi")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_patt _loc x2))), - (meta_expr _loc x3)) - | Ast.PaOlb (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaOlb")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_patt _loc x2)) - | Ast.PaLab (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaLab")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_patt _loc x2)) - | Ast.PaFlo (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaFlo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaNativeInt (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaNativeInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaInt64 (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaInt64")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaInt32 (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaInt32")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaInt (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaChr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaChr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaSem")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaCom (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaCom")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaArr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaArr")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaApp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaApp")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaAny x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaAny")))))), - (meta_loc _loc x0)) - | Ast.PaAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.PaAli (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaAli")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaId (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.PaNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaNil")))))), - (meta_loc _loc x0)) - and meta_private_flag _loc = - function - | Ast.PrAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.PrNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PrNil"))))) - | Ast.PrPrivate -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PrPrivate"))))) - and meta_rec_binding _loc = - function - | Ast.RbAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.RbEq (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbEq")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_expr _loc x2)) - | Ast.RbSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbSem")))))), - (meta_loc _loc x0))), - (meta_rec_binding _loc x1))), - (meta_rec_binding _loc x2)) - | Ast.RbNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbNil")))))), - (meta_loc _loc x0)) - and meta_rec_flag _loc = - function - | Ast.ReAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.ReNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ReNil"))))) - | Ast.ReRecursive -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ReRecursive"))))) - and meta_row_var_flag _loc = - function - | Ast.RvAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.RvNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RvNil"))))) - | Ast.RvRowVar -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RvRowVar"))))) - and meta_sig_item _loc = - function - | Ast.SgAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.SgVal (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgVal")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2)) - | Ast.SgTyp (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgTyp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.SgOpn (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgOpn")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.SgMty (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgMty")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.SgRecMod (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgRecMod")))))), - (meta_loc _loc x0))), - (meta_module_binding _loc x1)) - | Ast.SgMod (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgMod")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.SgInc (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgInc")))))), - (meta_loc _loc x0))), - (meta_module_type _loc x1)) - | Ast.SgExt (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgExt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2))), - (meta_meta_list meta_string _loc x3)) - | Ast.SgExc (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgExc")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.SgDir (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgDir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.SgSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgSem")))))), - (meta_loc _loc x0))), - (meta_sig_item _loc x1))), - (meta_sig_item _loc x2)) - | Ast.SgClt (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgClt")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.SgCls (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgCls")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.SgNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgNil")))))), - (meta_loc _loc x0)) - and meta_str_item _loc = - function - | Ast.StAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.StVal (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StVal")))))), - (meta_loc _loc x0))), - (meta_rec_flag _loc x1))), - (meta_binding _loc x2)) - | Ast.StTyp (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StTyp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.StOpn (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StOpn")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.StMty (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StMty")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.StRecMod (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StRecMod")))))), - (meta_loc _loc x0))), - (meta_module_binding _loc x1)) - | Ast.StMod (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StMod")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_expr _loc x2)) - | Ast.StInc (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StInc")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1)) - | Ast.StExt (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StExt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2))), - (meta_meta_list meta_string _loc x3)) - | Ast.StExp (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StExp")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.StExc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StExc")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_meta_option meta_ident _loc x2)) - | Ast.StDir (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StDir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.StSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StSem")))))), - (meta_loc _loc x0))), - (meta_str_item _loc x1))), - (meta_str_item _loc x2)) - | Ast.StClt (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StClt")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.StCls (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StCls")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1)) - | Ast.StNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StNil")))))), - (meta_loc _loc x0)) - and meta_virtual_flag _loc = - function - | Ast.ViAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.ViNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ViNil"))))) - | Ast.ViVirtual -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ViVirtual"))))) - and meta_with_constr _loc = - function - | Ast.WcAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.WcAnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcAnd")))))), - (meta_loc _loc x0))), - (meta_with_constr _loc x1))), - (meta_with_constr _loc x2)) - | Ast.WcMoS (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcMoS")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - | Ast.WcTyS (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcTyS")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.WcMod (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcMod")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - | Ast.WcTyp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcTyp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.WcNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcNil")))))), - (meta_loc _loc x0)) - - end - - end - - end - - class map = - object ((o : 'self_type)) - method string : string -> string = o#unknown - method list : - 'a 'a_out. - ('self_type -> 'a -> 'a_out) -> 'a list -> 'a_out list = - fun _f_a -> - function - | [] -> [] - | _x :: _x_i1 -> - let _x = _f_a o _x in - let _x_i1 = o#list _f_a _x_i1 in _x :: _x_i1 - method with_constr : with_constr -> with_constr = - function - | WcNil _x -> let _x = o#loc _x in WcNil _x - | WcTyp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in WcTyp (_x, _x_i1, _x_i2) - | WcMod (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in WcMod (_x, _x_i1, _x_i2) - | WcTyS (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in WcTyS (_x, _x_i1, _x_i2) - | WcMoS (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in WcMoS (_x, _x_i1, _x_i2) - | WcAnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#with_constr _x_i1 in - let _x_i2 = o#with_constr _x_i2 - in WcAnd (_x, _x_i1, _x_i2) - | WcAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in WcAnt (_x, _x_i1) - method virtual_flag : virtual_flag -> virtual_flag = - function - | ViVirtual -> ViVirtual - | ViNil -> ViNil - | ViAnt _x -> let _x = o#string _x in ViAnt _x - method str_item : str_item -> str_item = - function - | StNil _x -> let _x = o#loc _x in StNil _x - | StCls (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in StCls (_x, _x_i1) - | StClt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in StClt (_x, _x_i1) - | StSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#str_item _x_i1 in - let _x_i2 = o#str_item _x_i2 - in StSem (_x, _x_i1, _x_i2) - | StDir (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in StDir (_x, _x_i1, _x_i2) - | StExc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#meta_option (fun o -> o#ident) _x_i2 - in StExc (_x, _x_i1, _x_i2) - | StExp (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in StExp (_x, _x_i1) - | StExt (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in - let _x_i3 = o#meta_list (fun o -> o#string) _x_i3 - in StExt (_x, _x_i1, _x_i2, _x_i3) - | StInc (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in StInc (_x, _x_i1) - | StMod (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_expr _x_i2 - in StMod (_x, _x_i1, _x_i2) - | StRecMod (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_binding _x_i1 - in StRecMod (_x, _x_i1) - | StMty (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 - in StMty (_x, _x_i1, _x_i2) - | StOpn (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in StOpn (_x, _x_i1) - | StTyp (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in StTyp (_x, _x_i1) - | StVal (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#rec_flag _x_i1 in - let _x_i2 = o#binding _x_i2 in StVal (_x, _x_i1, _x_i2) - | StAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in StAnt (_x, _x_i1) - method sig_item : sig_item -> sig_item = - function - | SgNil _x -> let _x = o#loc _x in SgNil _x - | SgCls (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in SgCls (_x, _x_i1) - | SgClt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in SgClt (_x, _x_i1) - | SgSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#sig_item _x_i1 in - let _x_i2 = o#sig_item _x_i2 - in SgSem (_x, _x_i1, _x_i2) - | SgDir (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in SgDir (_x, _x_i1, _x_i2) - | SgExc (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in SgExc (_x, _x_i1) - | SgExt (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in - let _x_i3 = o#meta_list (fun o -> o#string) _x_i3 - in SgExt (_x, _x_i1, _x_i2, _x_i3) - | SgInc (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_type _x_i1 in SgInc (_x, _x_i1) - | SgMod (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 - in SgMod (_x, _x_i1, _x_i2) - | SgRecMod (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_binding _x_i1 - in SgRecMod (_x, _x_i1) - | SgMty (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 - in SgMty (_x, _x_i1, _x_i2) - | SgOpn (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in SgOpn (_x, _x_i1) - | SgTyp (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in SgTyp (_x, _x_i1) - | SgVal (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in SgVal (_x, _x_i1, _x_i2) - | SgAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in SgAnt (_x, _x_i1) - method row_var_flag : row_var_flag -> row_var_flag = - function - | RvRowVar -> RvRowVar - | RvNil -> RvNil - | RvAnt _x -> let _x = o#string _x in RvAnt _x - method rec_flag : rec_flag -> rec_flag = - function - | ReRecursive -> ReRecursive - | ReNil -> ReNil - | ReAnt _x -> let _x = o#string _x in ReAnt _x - method rec_binding : rec_binding -> rec_binding = - function - | RbNil _x -> let _x = o#loc _x in RbNil _x - | RbSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#rec_binding _x_i1 in - let _x_i2 = o#rec_binding _x_i2 - in RbSem (_x, _x_i1, _x_i2) - | RbEq (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#expr _x_i2 in RbEq (_x, _x_i1, _x_i2) - | RbAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in RbAnt (_x, _x_i1) - method private_flag : private_flag -> private_flag = - function - | PrPrivate -> PrPrivate - | PrNil -> PrNil - | PrAnt _x -> let _x = o#string _x in PrAnt _x - method patt : patt -> patt = - function - | PaNil _x -> let _x = o#loc _x in PaNil _x - | PaId (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in PaId (_x, _x_i1) - | PaAli (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaAli (_x, _x_i1, _x_i2) - | PaAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaAnt (_x, _x_i1) - | PaAny _x -> let _x = o#loc _x in PaAny _x - | PaApp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaApp (_x, _x_i1, _x_i2) - | PaArr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in PaArr (_x, _x_i1) - | PaCom (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaCom (_x, _x_i1, _x_i2) - | PaSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaSem (_x, _x_i1, _x_i2) - | PaChr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaChr (_x, _x_i1) - | PaInt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaInt (_x, _x_i1) - | PaInt32 (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaInt32 (_x, _x_i1) - | PaInt64 (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaInt64 (_x, _x_i1) - | PaNativeInt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaNativeInt (_x, _x_i1) - | PaFlo (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaFlo (_x, _x_i1) - | PaLab (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#patt _x_i2 in PaLab (_x, _x_i1, _x_i2) - | PaOlb (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#patt _x_i2 in PaOlb (_x, _x_i1, _x_i2) - | PaOlbi (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#patt _x_i2 in - let _x_i3 = o#expr _x_i3 - in PaOlbi (_x, _x_i1, _x_i2, _x_i3) - | PaOrp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaOrp (_x, _x_i1, _x_i2) - | PaRng (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaRng (_x, _x_i1, _x_i2) - | PaRec (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in PaRec (_x, _x_i1) - | PaEq (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#patt _x_i2 in PaEq (_x, _x_i1, _x_i2) - | PaStr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaStr (_x, _x_i1) - | PaTup (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in PaTup (_x, _x_i1) - | PaTyc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#ctyp _x_i2 in PaTyc (_x, _x_i1, _x_i2) - | PaTyp (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in PaTyp (_x, _x_i1) - | PaVrn (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaVrn (_x, _x_i1) - | PaLaz (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in PaLaz (_x, _x_i1) - | PaMod (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaMod (_x, _x_i1) - method override_flag : override_flag -> override_flag = - function - | OvOverride -> OvOverride - | OvNil -> OvNil - | OvAnt _x -> let _x = o#string _x in OvAnt _x - method mutable_flag : mutable_flag -> mutable_flag = - function - | MuMutable -> MuMutable - | MuNil -> MuNil - | MuAnt _x -> let _x = o#string _x in MuAnt _x - method module_type : module_type -> module_type = - function - | MtNil _x -> let _x = o#loc _x in MtNil _x - | MtId (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in MtId (_x, _x_i1) - | MtFun (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in - let _x_i3 = o#module_type _x_i3 - in MtFun (_x, _x_i1, _x_i2, _x_i3) - | MtQuo (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MtQuo (_x, _x_i1) - | MtSig (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#sig_item _x_i1 in MtSig (_x, _x_i1) - | MtWit (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#module_type _x_i1 in - let _x_i2 = o#with_constr _x_i2 - in MtWit (_x, _x_i1, _x_i2) - | MtOf (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in MtOf (_x, _x_i1) - | MtAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MtAnt (_x, _x_i1) - method module_expr : module_expr -> module_expr = - function - | MeNil _x -> let _x = o#loc _x in MeNil _x - | MeId (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in MeId (_x, _x_i1) - | MeApp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in - let _x_i2 = o#module_expr _x_i2 - in MeApp (_x, _x_i1, _x_i2) - | MeFun (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in - let _x_i3 = o#module_expr _x_i3 - in MeFun (_x, _x_i1, _x_i2, _x_i3) - | MeStr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#str_item _x_i1 in MeStr (_x, _x_i1) - | MeTyc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in - let _x_i2 = o#module_type _x_i2 - in MeTyc (_x, _x_i1, _x_i2) - | MePkg (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in MePkg (_x, _x_i1) - | MeAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MeAnt (_x, _x_i1) - method module_binding : module_binding -> module_binding = - function - | MbNil _x -> let _x = o#loc _x in MbNil _x - | MbAnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#module_binding _x_i1 in - let _x_i2 = o#module_binding _x_i2 - in MbAnd (_x, _x_i1, _x_i2) - | MbColEq (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in - let _x_i3 = o#module_expr _x_i3 - in MbColEq (_x, _x_i1, _x_i2, _x_i3) - | MbCol (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 - in MbCol (_x, _x_i1, _x_i2) - | MbAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MbAnt (_x, _x_i1) - method meta_option : - 'a 'a_out. - ('self_type -> 'a -> 'a_out) -> - 'a meta_option -> 'a_out meta_option = - fun _f_a -> - function - | ONone -> ONone - | OSome _x -> let _x = _f_a o _x in OSome _x - | OAnt _x -> let _x = o#string _x in OAnt _x - method meta_list : - 'a 'a_out. - ('self_type -> 'a -> 'a_out) -> - 'a meta_list -> 'a_out meta_list = - fun _f_a -> - function - | LNil -> LNil - | LCons (_x, _x_i1) -> - let _x = _f_a o _x in - let _x_i1 = o#meta_list _f_a _x_i1 - in LCons (_x, _x_i1) - | LAnt _x -> let _x = o#string _x in LAnt _x - method meta_bool : meta_bool -> meta_bool = - function - | BTrue -> BTrue - | BFalse -> BFalse - | BAnt _x -> let _x = o#string _x in BAnt _x - method match_case : match_case -> match_case = - function - | McNil _x -> let _x = o#loc _x in McNil _x - | McOr (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#match_case _x_i1 in - let _x_i2 = o#match_case _x_i2 - in McOr (_x, _x_i1, _x_i2) - | McArr (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#expr _x_i2 in - let _x_i3 = o#expr _x_i3 - in McArr (_x, _x_i1, _x_i2, _x_i3) - | McAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in McAnt (_x, _x_i1) - method loc : loc -> loc = o#unknown - method ident : ident -> ident = - function - | IdAcc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in IdAcc (_x, _x_i1, _x_i2) - | IdApp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in IdApp (_x, _x_i1, _x_i2) - | IdLid (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in IdLid (_x, _x_i1) - | IdUid (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in IdUid (_x, _x_i1) - | IdAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in IdAnt (_x, _x_i1) - method expr : expr -> expr = - function - | ExNil _x -> let _x = o#loc _x in ExNil _x - | ExId (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in ExId (_x, _x_i1) - | ExAcc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExAcc (_x, _x_i1, _x_i2) - | ExAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExAnt (_x, _x_i1) - | ExApp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExApp (_x, _x_i1, _x_i2) - | ExAre (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExAre (_x, _x_i1, _x_i2) - | ExArr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in ExArr (_x, _x_i1) - | ExSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExSem (_x, _x_i1, _x_i2) - | ExAsf _x -> let _x = o#loc _x in ExAsf _x - | ExAsr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in ExAsr (_x, _x_i1) - | ExAss (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExAss (_x, _x_i1, _x_i2) - | ExChr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExChr (_x, _x_i1) - | ExCoe (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#ctyp _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in ExCoe (_x, _x_i1, _x_i2, _x_i3) - | ExFlo (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExFlo (_x, _x_i1) - | ExFor (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in - let _x_i3 = o#expr _x_i3 in - let _x_i4 = o#direction_flag _x_i4 in - let _x_i5 = o#expr _x_i5 - in ExFor (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) - | ExFun (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#match_case _x_i1 in ExFun (_x, _x_i1) - | ExIfe (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in - let _x_i3 = o#expr _x_i3 - in ExIfe (_x, _x_i1, _x_i2, _x_i3) - | ExInt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExInt (_x, _x_i1) - | ExInt32 (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExInt32 (_x, _x_i1) - | ExInt64 (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExInt64 (_x, _x_i1) - | ExNativeInt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExNativeInt (_x, _x_i1) - | ExLab (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in ExLab (_x, _x_i1, _x_i2) - | ExLaz (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in ExLaz (_x, _x_i1) - | ExLet (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#rec_flag _x_i1 in - let _x_i2 = o#binding _x_i2 in - let _x_i3 = o#expr _x_i3 - in ExLet (_x, _x_i1, _x_i2, _x_i3) - | ExLmd (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_expr _x_i2 in - let _x_i3 = o#expr _x_i3 - in ExLmd (_x, _x_i1, _x_i2, _x_i3) - | ExMat (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#match_case _x_i2 - in ExMat (_x, _x_i1, _x_i2) - | ExNew (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in ExNew (_x, _x_i1) - | ExObj (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#class_str_item _x_i2 - in ExObj (_x, _x_i1, _x_i2) - | ExOlb (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in ExOlb (_x, _x_i1, _x_i2) - | ExOvr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#rec_binding _x_i1 in ExOvr (_x, _x_i1) - | ExRec (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#rec_binding _x_i1 in - let _x_i2 = o#expr _x_i2 in ExRec (_x, _x_i1, _x_i2) - | ExSeq (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in ExSeq (_x, _x_i1) - | ExSnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#string _x_i2 in ExSnd (_x, _x_i1, _x_i2) - | ExSte (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExSte (_x, _x_i1, _x_i2) - | ExStr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExStr (_x, _x_i1) - | ExTry (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#match_case _x_i2 - in ExTry (_x, _x_i1, _x_i2) - | ExTup (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in ExTup (_x, _x_i1) - | ExCom (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExCom (_x, _x_i1, _x_i2) - | ExTyc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#ctyp _x_i2 in ExTyc (_x, _x_i1, _x_i2) - | ExVrn (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExVrn (_x, _x_i1) - | ExWhi (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExWhi (_x, _x_i1, _x_i2) - | ExOpI (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#expr _x_i2 in ExOpI (_x, _x_i1, _x_i2) - | ExFUN (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in ExFUN (_x, _x_i1, _x_i2) - | ExPkg (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in ExPkg (_x, _x_i1) - method direction_flag : direction_flag -> direction_flag = - function - | DiTo -> DiTo - | DiDownto -> DiDownto - | DiAnt _x -> let _x = o#string _x in DiAnt _x - method ctyp : ctyp -> ctyp = - function - | TyNil _x -> let _x = o#loc _x in TyNil _x - | TyAli (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyAli (_x, _x_i1, _x_i2) - | TyAny _x -> let _x = o#loc _x in TyAny _x - | TyApp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyApp (_x, _x_i1, _x_i2) - | TyArr (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyArr (_x, _x_i1, _x_i2) - | TyCls (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in TyCls (_x, _x_i1) - | TyLab (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyLab (_x, _x_i1, _x_i2) - | TyId (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in TyId (_x, _x_i1) - | TyMan (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyMan (_x, _x_i1, _x_i2) - | TyDcl (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#list (fun o -> o#ctyp) _x_i2 in - let _x_i3 = o#ctyp _x_i3 in - let _x_i4 = - o#list - (fun o (_x, _x_i1) -> - let _x = o#ctyp _x in - let _x_i1 = o#ctyp _x_i1 in (_x, _x_i1)) - _x_i4 - in TyDcl (_x, _x_i1, _x_i2, _x_i3, _x_i4) - | TyObj (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#row_var_flag _x_i2 - in TyObj (_x, _x_i1, _x_i2) - | TyOlb (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOlb (_x, _x_i1, _x_i2) - | TyPol (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyPol (_x, _x_i1, _x_i2) - | TyTypePol (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 - in TyTypePol (_x, _x_i1, _x_i2) - | TyQuo (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyQuo (_x, _x_i1) - | TyQuP (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyQuP (_x, _x_i1) - | TyQuM (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyQuM (_x, _x_i1) - | TyAnP _x -> let _x = o#loc _x in TyAnP _x - | TyAnM _x -> let _x = o#loc _x in TyAnM _x - | TyVrn (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyVrn (_x, _x_i1) - | TyRec (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyRec (_x, _x_i1) - | TyCol (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyCol (_x, _x_i1, _x_i2) - | TySem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TySem (_x, _x_i1, _x_i2) - | TyCom (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyCom (_x, _x_i1, _x_i2) - | TySum (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TySum (_x, _x_i1) - | TyOf (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOf (_x, _x_i1, _x_i2) - | TyAnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyAnd (_x, _x_i1, _x_i2) - | TyOr (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOr (_x, _x_i1, _x_i2) - | TyPrv (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyPrv (_x, _x_i1) - | TyMut (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyMut (_x, _x_i1) - | TyTup (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyTup (_x, _x_i1) - | TySta (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TySta (_x, _x_i1, _x_i2) - | TyVrnEq (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyVrnEq (_x, _x_i1) - | TyVrnSup (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyVrnSup (_x, _x_i1) - | TyVrnInf (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyVrnInf (_x, _x_i1) - | TyVrnInfSup (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 - in TyVrnInfSup (_x, _x_i1, _x_i2) - | TyAmp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyAmp (_x, _x_i1, _x_i2) - | TyOfAmp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOfAmp (_x, _x_i1, _x_i2) - | TyPkg (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_type _x_i1 in TyPkg (_x, _x_i1) - | TyAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyAnt (_x, _x_i1) - method class_type : class_type -> class_type = - function - | CtNil _x -> let _x = o#loc _x in CtNil _x - | CtCon (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#virtual_flag _x_i1 in - let _x_i2 = o#ident _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in CtCon (_x, _x_i1, _x_i2, _x_i3) - | CtFun (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#class_type _x_i2 - in CtFun (_x, _x_i1, _x_i2) - | CtSig (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#class_sig_item _x_i2 - in CtSig (_x, _x_i1, _x_i2) - | CtAnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in - let _x_i2 = o#class_type _x_i2 - in CtAnd (_x, _x_i1, _x_i2) - | CtCol (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in - let _x_i2 = o#class_type _x_i2 - in CtCol (_x, _x_i1, _x_i2) - | CtEq (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in - let _x_i2 = o#class_type _x_i2 - in CtEq (_x, _x_i1, _x_i2) - | CtAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CtAnt (_x, _x_i1) - method class_str_item : class_str_item -> class_str_item = - function - | CrNil _x -> let _x = o#loc _x in CrNil _x - | CrSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_str_item _x_i1 in - let _x_i2 = o#class_str_item _x_i2 - in CrSem (_x, _x_i1, _x_i2) - | CrCtr (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in CrCtr (_x, _x_i1, _x_i2) - | CrInh (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#override_flag _x_i1 in - let _x_i2 = o#class_expr _x_i2 in - let _x_i3 = o#string _x_i3 - in CrInh (_x, _x_i1, _x_i2, _x_i3) - | CrIni (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in CrIni (_x, _x_i1) - | CrMth (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#override_flag _x_i2 in - let _x_i3 = o#private_flag _x_i3 in - let _x_i4 = o#expr _x_i4 in - let _x_i5 = o#ctyp _x_i5 - in CrMth (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) - | CrVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#override_flag _x_i2 in - let _x_i3 = o#mutable_flag _x_i3 in - let _x_i4 = o#expr _x_i4 - in CrVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) - | CrVir (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#private_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in CrVir (_x, _x_i1, _x_i2, _x_i3) - | CrVvr (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#mutable_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in CrVvr (_x, _x_i1, _x_i2, _x_i3) - | CrAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CrAnt (_x, _x_i1) - method class_sig_item : class_sig_item -> class_sig_item = - function - | CgNil _x -> let _x = o#loc _x in CgNil _x - | CgCtr (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in CgCtr (_x, _x_i1, _x_i2) - | CgSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_sig_item _x_i1 in - let _x_i2 = o#class_sig_item _x_i2 - in CgSem (_x, _x_i1, _x_i2) - | CgInh (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in CgInh (_x, _x_i1) - | CgMth (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#private_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in CgMth (_x, _x_i1, _x_i2, _x_i3) - | CgVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#mutable_flag _x_i2 in - let _x_i3 = o#virtual_flag _x_i3 in - let _x_i4 = o#ctyp _x_i4 - in CgVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) - | CgVir (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#private_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in CgVir (_x, _x_i1, _x_i2, _x_i3) - | CgAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CgAnt (_x, _x_i1) - method class_expr : class_expr -> class_expr = - function - | CeNil _x -> let _x = o#loc _x in CeNil _x - | CeApp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#expr _x_i2 in CeApp (_x, _x_i1, _x_i2) - | CeCon (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#virtual_flag _x_i1 in - let _x_i2 = o#ident _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in CeCon (_x, _x_i1, _x_i2, _x_i3) - | CeFun (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#class_expr _x_i2 - in CeFun (_x, _x_i1, _x_i2) - | CeLet (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#rec_flag _x_i1 in - let _x_i2 = o#binding _x_i2 in - let _x_i3 = o#class_expr _x_i3 - in CeLet (_x, _x_i1, _x_i2, _x_i3) - | CeStr (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#class_str_item _x_i2 - in CeStr (_x, _x_i1, _x_i2) - | CeTyc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#class_type _x_i2 - in CeTyc (_x, _x_i1, _x_i2) - | CeAnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#class_expr _x_i2 - in CeAnd (_x, _x_i1, _x_i2) - | CeEq (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#class_expr _x_i2 - in CeEq (_x, _x_i1, _x_i2) - | CeAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CeAnt (_x, _x_i1) - method binding : binding -> binding = - function - | BiNil _x -> let _x = o#loc _x in BiNil _x - | BiAnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#binding _x_i1 in - let _x_i2 = o#binding _x_i2 in BiAnd (_x, _x_i1, _x_i2) - | BiEq (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#expr _x_i2 in BiEq (_x, _x_i1, _x_i2) - | BiAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in BiAnt (_x, _x_i1) - method unknown : 'a. 'a -> 'a = fun x -> x - end - - class fold = - object ((o : 'self_type)) - method string : string -> 'self_type = o#unknown - method list : - 'a. - ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type = - fun _f_a -> - function - | [] -> o - | _x :: _x_i1 -> - let o = _f_a o _x in let o = o#list _f_a _x_i1 in o - method with_constr : with_constr -> 'self_type = - function - | WcNil _x -> let o = o#loc _x in o - | WcTyp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | WcMod (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | WcTyS (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | WcMoS (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | WcAnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#with_constr _x_i1 in - let o = o#with_constr _x_i2 in o - | WcAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method virtual_flag : virtual_flag -> 'self_type = - function - | ViVirtual -> o - | ViNil -> o - | ViAnt _x -> let o = o#string _x in o - method str_item : str_item -> 'self_type = - function - | StNil _x -> let o = o#loc _x in o - | StCls (_x, _x_i1) -> - let o = o#loc _x in let o = o#class_expr _x_i1 in o - | StClt (_x, _x_i1) -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | StSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#str_item _x_i1 in - let o = o#str_item _x_i2 in o - | StDir (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | StExc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in - let o = o#meta_option (fun o -> o#ident) _x_i2 in o - | StExp (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | StExt (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#ctyp _x_i2 in - let o = o#meta_list (fun o -> o#string) _x_i3 in o - | StInc (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_expr _x_i1 in o - | StMod (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_expr _x_i2 in o - | StRecMod (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_binding _x_i1 in o - | StMty (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in o - | StOpn (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | StTyp (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | StVal (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#rec_flag _x_i1 in - let o = o#binding _x_i2 in o - | StAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method sig_item : sig_item -> 'self_type = - function - | SgNil _x -> let o = o#loc _x in o - | SgCls (_x, _x_i1) -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | SgClt (_x, _x_i1) -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | SgSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#sig_item _x_i1 in - let o = o#sig_item _x_i2 in o - | SgDir (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | SgExc (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | SgExt (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#ctyp _x_i2 in - let o = o#meta_list (fun o -> o#string) _x_i3 in o - | SgInc (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_type _x_i1 in o - | SgMod (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in o - | SgRecMod (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_binding _x_i1 in o - | SgMty (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in o - | SgOpn (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | SgTyp (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | SgVal (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o - | SgAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method row_var_flag : row_var_flag -> 'self_type = - function - | RvRowVar -> o - | RvNil -> o - | RvAnt _x -> let o = o#string _x in o - method rec_flag : rec_flag -> 'self_type = - function - | ReRecursive -> o - | ReNil -> o - | ReAnt _x -> let o = o#string _x in o - method rec_binding : rec_binding -> 'self_type = - function - | RbNil _x -> let o = o#loc _x in o - | RbSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#rec_binding _x_i1 in - let o = o#rec_binding _x_i2 in o - | RbEq (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#expr _x_i2 in o - | RbAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method private_flag : private_flag -> 'self_type = - function - | PrPrivate -> o - | PrNil -> o - | PrAnt _x -> let o = o#string _x in o - method patt : patt -> 'self_type = - function - | PaNil _x -> let o = o#loc _x in o - | PaId (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | PaAli (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaAny _x -> let o = o#loc _x in o - | PaApp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaArr (_x, _x_i1) -> - let o = o#loc _x in let o = o#patt _x_i1 in o - | PaCom (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaChr (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaInt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaInt32 (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaInt64 (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaNativeInt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaFlo (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaLab (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#patt _x_i2 in o - | PaOlb (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#patt _x_i2 in o - | PaOlbi (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#patt _x_i2 in let o = o#expr _x_i3 in o - | PaOrp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaRng (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaRec (_x, _x_i1) -> - let o = o#loc _x in let o = o#patt _x_i1 in o - | PaEq (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#patt _x_i2 in o - | PaStr (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaTup (_x, _x_i1) -> - let o = o#loc _x in let o = o#patt _x_i1 in o - | PaTyc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#ctyp _x_i2 in o - | PaTyp (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | PaVrn (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaLaz (_x, _x_i1) -> - let o = o#loc _x in let o = o#patt _x_i1 in o - | PaMod (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method override_flag : override_flag -> 'self_type = - function - | OvOverride -> o - | OvNil -> o - | OvAnt _x -> let o = o#string _x in o - method mutable_flag : mutable_flag -> 'self_type = - function - | MuMutable -> o - | MuNil -> o - | MuAnt _x -> let o = o#string _x in o - method module_type : module_type -> 'self_type = - function - | MtNil _x -> let o = o#loc _x in o - | MtId (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | MtFun (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in - let o = o#module_type _x_i3 in o - | MtQuo (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | MtSig (_x, _x_i1) -> - let o = o#loc _x in let o = o#sig_item _x_i1 in o - | MtWit (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#module_type _x_i1 in - let o = o#with_constr _x_i2 in o - | MtOf (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_expr _x_i1 in o - | MtAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method module_expr : module_expr -> 'self_type = - function - | MeNil _x -> let o = o#loc _x in o - | MeId (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | MeApp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#module_expr _x_i1 in - let o = o#module_expr _x_i2 in o - | MeFun (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in - let o = o#module_expr _x_i3 in o - | MeStr (_x, _x_i1) -> - let o = o#loc _x in let o = o#str_item _x_i1 in o - | MeTyc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#module_expr _x_i1 in - let o = o#module_type _x_i2 in o - | MePkg (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | MeAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method module_binding : module_binding -> 'self_type = - function - | MbNil _x -> let o = o#loc _x in o - | MbAnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#module_binding _x_i1 in - let o = o#module_binding _x_i2 in o - | MbColEq (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in - let o = o#module_expr _x_i3 in o - | MbCol (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in o - | MbAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method meta_option : - 'a. - ('self_type -> 'a -> 'self_type) -> - 'a meta_option -> 'self_type = - fun _f_a -> - function - | ONone -> o - | OSome _x -> let o = _f_a o _x in o - | OAnt _x -> let o = o#string _x in o - method meta_list : - 'a. - ('self_type -> 'a -> 'self_type) -> - 'a meta_list -> 'self_type = - fun _f_a -> - function - | LNil -> o - | LCons (_x, _x_i1) -> - let o = _f_a o _x in - let o = o#meta_list _f_a _x_i1 in o - | LAnt _x -> let o = o#string _x in o - method meta_bool : meta_bool -> 'self_type = - function - | BTrue -> o - | BFalse -> o - | BAnt _x -> let o = o#string _x in o - method match_case : match_case -> 'self_type = - function - | McNil _x -> let o = o#loc _x in o - | McOr (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#match_case _x_i1 in - let o = o#match_case _x_i2 in o - | McArr (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#patt _x_i1 in - let o = o#expr _x_i2 in let o = o#expr _x_i3 in o - | McAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method loc : loc -> 'self_type = o#unknown - method ident : ident -> 'self_type = - function - | IdAcc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | IdApp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | IdLid (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | IdUid (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | IdAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method expr : expr -> 'self_type = - function - | ExNil _x -> let o = o#loc _x in o - | ExId (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | ExAcc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExApp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExAre (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExArr (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | ExSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExAsf _x -> let o = o#loc _x in o - | ExAsr (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | ExAss (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExChr (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExCoe (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#expr _x_i1 in - let o = o#ctyp _x_i2 in let o = o#ctyp _x_i3 in o - | ExFlo (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExFor (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#expr _x_i2 in - let o = o#expr _x_i3 in - let o = o#direction_flag _x_i4 in - let o = o#expr _x_i5 in o - | ExFun (_x, _x_i1) -> - let o = o#loc _x in let o = o#match_case _x_i1 in o - | ExIfe (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#expr _x_i1 in - let o = o#expr _x_i2 in let o = o#expr _x_i3 in o - | ExInt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExInt32 (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExInt64 (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExNativeInt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExLab (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | ExLaz (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | ExLet (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#rec_flag _x_i1 in - let o = o#binding _x_i2 in let o = o#expr _x_i3 in o - | ExLmd (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_expr _x_i2 in - let o = o#expr _x_i3 in o - | ExMat (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#match_case _x_i2 in o - | ExNew (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | ExObj (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in - let o = o#class_str_item _x_i2 in o - | ExOlb (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | ExOvr (_x, _x_i1) -> - let o = o#loc _x in let o = o#rec_binding _x_i1 in o - | ExRec (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#rec_binding _x_i1 in - let o = o#expr _x_i2 in o - | ExSeq (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | ExSnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#string _x_i2 in o - | ExSte (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExStr (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExTry (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#match_case _x_i2 in o - | ExTup (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | ExCom (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExTyc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#ctyp _x_i2 in o - | ExVrn (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExWhi (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExOpI (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#expr _x_i2 in o - | ExFUN (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | ExPkg (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_expr _x_i1 in o - method direction_flag : direction_flag -> 'self_type = - function - | DiTo -> o - | DiDownto -> o - | DiAnt _x -> let o = o#string _x in o - method ctyp : ctyp -> 'self_type = - function - | TyNil _x -> let o = o#loc _x in o - | TyAli (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyAny _x -> let o = o#loc _x in o - | TyApp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyArr (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyCls (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | TyLab (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o - | TyId (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | TyMan (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyDcl (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#list (fun o -> o#ctyp) _x_i2 in - let o = o#ctyp _x_i3 in - let o = - o#list - (fun o (_x, _x_i1) -> - let o = o#ctyp _x in let o = o#ctyp _x_i1 in o) - _x_i4 - in o - | TyObj (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in - let o = o#row_var_flag _x_i2 in o - | TyOlb (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o - | TyPol (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyTypePol (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyQuo (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | TyQuP (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | TyQuM (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | TyAnP _x -> let o = o#loc _x in o - | TyAnM _x -> let o = o#loc _x in o - | TyVrn (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | TyRec (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyCol (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TySem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyCom (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TySum (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyOf (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyAnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyOr (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyPrv (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyMut (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyTup (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TySta (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyVrnEq (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyVrnSup (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyVrnInf (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyVrnInfSup (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyAmp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyOfAmp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyPkg (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_type _x_i1 in o - | TyAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method class_type : class_type -> 'self_type = - function - | CtNil _x -> let o = o#loc _x in o - | CtCon (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#virtual_flag _x_i1 in - let o = o#ident _x_i2 in let o = o#ctyp _x_i3 in o - | CtFun (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#class_type _x_i2 in o - | CtSig (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in - let o = o#class_sig_item _x_i2 in o - | CtAnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_type _x_i1 in - let o = o#class_type _x_i2 in o - | CtCol (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_type _x_i1 in - let o = o#class_type _x_i2 in o - | CtEq (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_type _x_i1 in - let o = o#class_type _x_i2 in o - | CtAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method class_str_item : class_str_item -> 'self_type = - function - | CrNil _x -> let o = o#loc _x in o - | CrSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_str_item _x_i1 in - let o = o#class_str_item _x_i2 in o - | CrCtr (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | CrInh (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#override_flag _x_i1 in - let o = o#class_expr _x_i2 in - let o = o#string _x_i3 in o - | CrIni (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | CrMth (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#override_flag _x_i2 in - let o = o#private_flag _x_i3 in - let o = o#expr _x_i4 in let o = o#ctyp _x_i5 in o - | CrVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#override_flag _x_i2 in - let o = o#mutable_flag _x_i3 in - let o = o#expr _x_i4 in o - | CrVir (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#private_flag _x_i2 in - let o = o#ctyp _x_i3 in o - | CrVvr (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#mutable_flag _x_i2 in - let o = o#ctyp _x_i3 in o - | CrAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method class_sig_item : class_sig_item -> 'self_type = - function - | CgNil _x -> let o = o#loc _x in o - | CgCtr (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | CgSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_sig_item _x_i1 in - let o = o#class_sig_item _x_i2 in o - | CgInh (_x, _x_i1) -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | CgMth (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#private_flag _x_i2 in - let o = o#ctyp _x_i3 in o - | CgVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#mutable_flag _x_i2 in - let o = o#virtual_flag _x_i3 in - let o = o#ctyp _x_i4 in o - | CgVir (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#private_flag _x_i2 in - let o = o#ctyp _x_i3 in o - | CgAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method class_expr : class_expr -> 'self_type = - function - | CeNil _x -> let o = o#loc _x in o - | CeApp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in let o = o#expr _x_i2 in o - | CeCon (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#virtual_flag _x_i1 in - let o = o#ident _x_i2 in let o = o#ctyp _x_i3 in o - | CeFun (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#class_expr _x_i2 in o - | CeLet (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#rec_flag _x_i1 in - let o = o#binding _x_i2 in - let o = o#class_expr _x_i3 in o - | CeStr (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in - let o = o#class_str_item _x_i2 in o - | CeTyc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in - let o = o#class_type _x_i2 in o - | CeAnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in - let o = o#class_expr _x_i2 in o - | CeEq (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in - let o = o#class_expr _x_i2 in o - | CeAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method binding : binding -> 'self_type = - function - | BiNil _x -> let o = o#loc _x in o - | BiAnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#binding _x_i1 in let o = o#binding _x_i2 in o - | BiEq (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#expr _x_i2 in o - | BiAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method unknown : 'a. 'a -> 'self_type = fun _ -> o - end - - let map_expr f = - object - inherit map as super - method expr = fun x -> f (super#expr x) - end - - let map_patt f = - object - inherit map as super - method patt = fun x -> f (super#patt x) - end - - let map_ctyp f = - object - inherit map as super - method ctyp = fun x -> f (super#ctyp x) - end - - let map_str_item f = - object - inherit map as super - method str_item = fun x -> f (super#str_item x) - end - - let map_sig_item f = - object - inherit map as super - method sig_item = fun x -> f (super#sig_item x) - end - - let map_loc f = - object - inherit map as super - method loc = fun x -> f (super#loc x) - end - - end - - end - - module DynAst = - struct - module Make (Ast : Sig.Ast) : Sig.DynAst with module Ast = Ast = - struct - module Ast = Ast - - type 'a tag = - | Tag_ctyp - | Tag_patt - | Tag_expr - | Tag_module_type - | Tag_sig_item - | Tag_with_constr - | Tag_module_expr - | Tag_str_item - | Tag_class_type - | Tag_class_sig_item - | Tag_class_expr - | Tag_class_str_item - | Tag_match_case - | Tag_ident - | Tag_binding - | Tag_rec_binding - | Tag_module_binding - - let string_of_tag = - function - | Tag_ctyp -> "ctyp" - | Tag_patt -> "patt" - | Tag_expr -> "expr" - | Tag_module_type -> "module_type" - | Tag_sig_item -> "sig_item" - | Tag_with_constr -> "with_constr" - | Tag_module_expr -> "module_expr" - | Tag_str_item -> "str_item" - | Tag_class_type -> "class_type" - | Tag_class_sig_item -> "class_sig_item" - | Tag_class_expr -> "class_expr" - | Tag_class_str_item -> "class_str_item" - | Tag_match_case -> "match_case" - | Tag_ident -> "ident" - | Tag_binding -> "binding" - | Tag_rec_binding -> "rec_binding" - | Tag_module_binding -> "module_binding" - - let ctyp_tag = Tag_ctyp - - let patt_tag = Tag_patt - - let expr_tag = Tag_expr - - let module_type_tag = Tag_module_type - - let sig_item_tag = Tag_sig_item - - let with_constr_tag = Tag_with_constr - - let module_expr_tag = Tag_module_expr - - let str_item_tag = Tag_str_item - - let class_type_tag = Tag_class_type - - let class_sig_item_tag = Tag_class_sig_item - - let class_expr_tag = Tag_class_expr - - let class_str_item_tag = Tag_class_str_item - - let match_case_tag = Tag_match_case - - let ident_tag = Tag_ident - - let binding_tag = Tag_binding - - let rec_binding_tag = Tag_rec_binding - - let module_binding_tag = Tag_module_binding - - type dyn - - external dyn_tag : 'a tag -> dyn tag = "%identity" - - module Pack (X : sig type 'a t - end) = - struct - type pack = ((dyn tag) * Obj.t) - - exception Pack_error - - let pack tag v = ((dyn_tag tag), (Obj.repr v)) - - let unpack (tag : 'a tag) (tag', obj) = - if (dyn_tag tag) = tag' - then (Obj.obj obj : 'a X.t) - else raise Pack_error - - let print_tag f (tag, _) = - Format.pp_print_string f (string_of_tag tag) - - end - - end - - end - - module Quotation = - struct - module Make (Ast : Sig.Camlp4Ast) : - Sig.Quotation with module Ast = Ast = - struct - module Ast = Ast - - module DynAst = DynAst.Make(Ast) - - module Loc = Ast.Loc - - open Format - - open Sig - - type 'a expand_fun = Loc.t -> string option -> string -> 'a - - module Exp_key = DynAst.Pack(struct type 'a t = unit - end) - - module Exp_fun = - DynAst.Pack(struct type 'a t = 'a expand_fun - end) - - let expanders_table : - (((string * Exp_key.pack) * Exp_fun.pack) list) ref = ref [] - - let default = ref "" - - let translate = ref (fun x -> x) - - let expander_name name = - match !translate name with | "" -> !default | name -> name - - let find name tag = - let key = ((expander_name name), (Exp_key.pack tag ())) - in Exp_fun.unpack tag (List.assoc key !expanders_table) - - let add name tag f = - let elt = ((name, (Exp_key.pack tag ())), (Exp_fun.pack tag f)) - in expanders_table := elt :: !expanders_table - - let dump_file = ref None - - module Error = - struct - type error = - | Finding - | Expanding - | ParsingResult of Loc.t * string - | Locating - - type t = (string * string * error * exn) - - exception E of t - - let print ppf (name, position, ctx, exn) = - let name = if name = "" then !default else name in - let pp x = - fprintf ppf "@?@[<2>While %s %S in a position of %S:" x - name position in - let () = - match ctx with - | Finding -> - (pp "finding quotation"; - if !expanders_table = [] - then - fprintf ppf - "@ There is no quotation expander available." - else - (fprintf ppf - "@ @[Available quotation expanders are:@\n"; - List.iter - (fun ((s, t), _) -> - fprintf ppf - "@[<2>%s@ (in@ a@ position@ of %a)@]@ " s - Exp_key.print_tag t) - !expanders_table; - fprintf ppf "@]")) - | Expanding -> pp "expanding quotation" - | Locating -> pp "parsing" - | ParsingResult (loc, str) -> - let () = pp "parsing result of quotation" - in - (match !dump_file with - | Some dump_file -> - let () = fprintf ppf " dumping result...\n" - in - (try - let oc = open_out_bin dump_file - in - (output_string oc str; - output_string oc "\n"; - flush oc; - close_out oc; - fprintf ppf "%a:" Loc.print - (Loc.set_file_name dump_file loc)) - with - | _ -> - fprintf ppf - "Error while dumping result in file %S; dump aborted" - dump_file) - | None -> - fprintf ppf - "\n(consider setting variable Quotation.dump_file, or using the -QD option)") - in fprintf ppf "@\n%a@]@." ErrorHandler.print exn - - let to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b - - end - - let _ = let module M = ErrorHandler.Register(Error) in () - - open Error - - let expand_quotation loc expander pos_tag quot = - let loc_name_opt = - if quot.q_loc = "" then None else Some quot.q_loc - in - try expander loc loc_name_opt quot.q_contents - with | (Loc.Exc_located (_, (Error.E _)) as exc) -> raise exc - | Loc.Exc_located (iloc, exc) -> - let exc1 = - Error.E (((quot.q_name), pos_tag, Expanding, exc)) - in raise (Loc.Exc_located (iloc, exc1)) - | exc -> - let exc1 = - Error.E (((quot.q_name), pos_tag, Expanding, exc)) - in raise (Loc.Exc_located (loc, exc1)) - - let parse_quotation_result parse loc quot pos_tag str = - try parse loc str - with - | Loc.Exc_located (iloc, - (Error.E ((n, pos_tag, Expanding, exc)))) -> - let ctx = ParsingResult (iloc, quot.q_contents) in - let exc1 = Error.E ((n, pos_tag, ctx, exc)) - in raise (Loc.Exc_located (iloc, exc1)) - | Loc.Exc_located (iloc, ((Error.E _ as exc))) -> - raise (Loc.Exc_located (iloc, exc)) - | Loc.Exc_located (iloc, exc) -> - let ctx = ParsingResult (iloc, quot.q_contents) in - let exc1 = Error.E (((quot.q_name), pos_tag, ctx, exc)) - in raise (Loc.Exc_located (iloc, exc1)) - - let expand loc quotation tag = - let pos_tag = DynAst.string_of_tag tag in - let name = quotation.q_name in - let expander = - try find name tag - with | (Loc.Exc_located (_, (Error.E _)) as exc) -> raise exc - | Loc.Exc_located (qloc, exc) -> - raise - (Loc.Exc_located (qloc, - (Error.E ((name, pos_tag, Finding, exc))))) - | exc -> - raise - (Loc.Exc_located (loc, - (Error.E ((name, pos_tag, Finding, exc))))) in - let loc = Loc.join (Loc.move `start quotation.q_shift loc) - in expand_quotation loc expander pos_tag quotation - - end - - end - - module AstFilters = - struct - module Make (Ast : Sig.Camlp4Ast) : - Sig.AstFilters with module Ast = Ast = - struct - module Ast = Ast - - type 'a filter = 'a -> 'a - - let interf_filters = Queue.create () - - let fold_interf_filters f i = Queue.fold f i interf_filters - - let implem_filters = Queue.create () - - let fold_implem_filters f i = Queue.fold f i implem_filters - - let topphrase_filters = Queue.create () - - let fold_topphrase_filters f i = Queue.fold f i topphrase_filters - - let register_sig_item_filter f = Queue.add f interf_filters - - let register_str_item_filter f = Queue.add f implem_filters - - let register_topphrase_filter f = Queue.add f topphrase_filters - - end - - end - - module Camlp4Ast2OCamlAst : - sig - module Make (Camlp4Ast : Sig.Camlp4Ast) : - sig - open Camlp4Ast - - val sig_item : sig_item -> Camlp4_import.Parsetree.signature - - val str_item : str_item -> Camlp4_import.Parsetree.structure - - val phrase : str_item -> Camlp4_import.Parsetree.toplevel_phrase - - end - - end = - struct - module Make (Ast : Sig.Camlp4Ast) = - struct - open Format - - open Camlp4_import.Parsetree - - open Camlp4_import.Longident - - open Camlp4_import.Asttypes - - open Ast - - let constructors_arity () = !Camlp4_config.constructors_arity - - let error loc str = Loc.raise loc (Failure str) - - let char_of_char_token loc s = - try Token.Eval.char s - with | (Failure _ as exn) -> Loc.raise loc exn - - let string_of_string_token loc s = - try Token.Eval.string s - with | (Failure _ as exn) -> Loc.raise loc exn - - let remove_underscores s = - let l = String.length s in - let rec remove src dst = - if src >= l - then if dst >= l then s else String.sub s 0 dst - else - (match s.[src] with - | '_' -> remove (src + 1) dst - | c -> (s.[dst] <- c; remove (src + 1) (dst + 1))) - in remove 0 0 - - let mkloc = Loc.to_ocaml_location - - let mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc) - - let with_loc txt loc = - Camlp4_import.Location.mkloc txt (mkloc loc) - - let mktyp loc d = { ptyp_desc = d; ptyp_loc = mkloc loc; } - - let mkpat loc d = { ppat_desc = d; ppat_loc = mkloc loc; } - - let mkghpat loc d = { ppat_desc = d; ppat_loc = mkghloc loc; } - - let mkexp loc d = { pexp_desc = d; pexp_loc = mkloc loc; } - - let mkmty loc d = { pmty_desc = d; pmty_loc = mkloc loc; } - - let mksig loc d = { psig_desc = d; psig_loc = mkloc loc; } - - let mkmod loc d = { pmod_desc = d; pmod_loc = mkloc loc; } - - let mkstr loc d = { pstr_desc = d; pstr_loc = mkloc loc; } - - let mkfield loc d = { pfield_desc = d; pfield_loc = mkloc loc; } - - let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; } - - let mkcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; } - - let mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; } - - let mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; } - - let mkpolytype t = - match t.ptyp_desc with - | Ptyp_poly (_, _) -> t - | _ -> { (t) with ptyp_desc = Ptyp_poly ([], t); } - - let mkvirtual = - function - | Ast.ViVirtual -> Virtual - | Ast.ViNil -> Concrete - | _ -> assert false - - let mkdirection = - function - | Ast.DiTo -> Upto - | Ast.DiDownto -> Downto - | _ -> assert false - - let lident s = Lident s - - let lident_with_loc s loc = with_loc (Lident s) loc - - let ldot l s = Ldot (l, s) - - let lapply l s = Lapply (l, s) - - let conv_con = - let t = Hashtbl.create 73 - in - (List.iter (fun (s, s') -> Hashtbl.add t s s') - [ ("True", "true"); ("False", "false"); (" True", "True"); - (" False", "False") ]; - fun s -> try Hashtbl.find t s with | Not_found -> s) - - let conv_lab = - let t = Hashtbl.create 73 - in - (List.iter (fun (s, s') -> Hashtbl.add t s s') - [ ("val", "contents") ]; - fun s -> try Hashtbl.find t s with | Not_found -> s) - - let array_function_no_loc str name = - ldot (lident str) - (if !Camlp4_config.unsafe then "unsafe_" ^ name else name) - - let array_function loc str name = - with_loc (array_function_no_loc str name) loc - - let mkrf = - function - | Ast.ReRecursive -> Recursive - | Ast.ReNil -> Nonrecursive - | _ -> assert false - - let mkli sloc s list = - let rec loop f = - function | i :: il -> loop (ldot (f i)) il | [] -> f s - in with_loc (loop lident list) sloc - - let rec ctyp_fa al = - function - | TyApp (_, f, a) -> ctyp_fa (a :: al) f - | f -> (f, al) - - let ident_tag ?(conv_lid = fun x -> x) i = - let rec self i acc = - match i with - | Ast.IdAcc (_, (Ast.IdLid (_, "*predef*")), - (Ast.IdLid (_, "option"))) -> - ((ldot (lident "*predef*") "option"), `lident) - | Ast.IdAcc (_, i1, i2) -> self i2 (Some (self i1 acc)) - | Ast.IdApp (_, i1, i2) -> - let i' = - Lapply ((fst (self i1 None)), (fst (self i2 None))) in - let x = - (match acc with - | None -> i' - | _ -> - error (loc_of_ident i) "invalid long identifier") - in (x, `app) - | Ast.IdUid (_, s) -> - let x = - (match acc with - | None -> lident s - | Some ((acc, (`uident | `app))) -> ldot acc s - | _ -> - error (loc_of_ident i) "invalid long identifier") - in (x, `uident) - | Ast.IdLid (_, s) -> - let x = - (match acc with - | None -> lident (conv_lid s) - | Some ((acc, (`uident | `app))) -> - ldot acc (conv_lid s) - | _ -> - error (loc_of_ident i) "invalid long identifier") - in (x, `lident) - | _ -> error (loc_of_ident i) "invalid long identifier" - in self i None - - let ident_noloc ?conv_lid i = fst (ident_tag ?conv_lid i) - - let ident ?conv_lid i = - with_loc (ident_noloc ?conv_lid i) (loc_of_ident i) - - let long_lident msg id = - match ident_tag id with - | (i, `lident) -> with_loc i (loc_of_ident id) - | _ -> error (loc_of_ident id) msg - - let long_type_ident = long_lident "invalid long identifier type" - - let long_class_ident = long_lident "invalid class name" - - let long_uident_noloc ?(conv_con = fun x -> x) i = - match ident_tag i with - | (Ldot (i, s), `uident) -> ldot i (conv_con s) - | (Lident s, `uident) -> lident (conv_con s) - | (i, `app) -> i - | _ -> error (loc_of_ident i) "uppercase identifier expected" - - let long_uident ?conv_con i = - with_loc (long_uident_noloc ?conv_con i) (loc_of_ident i) - - let rec ctyp_long_id_prefix t = - match t with - | Ast.TyId (_, i) -> ident_noloc i - | Ast.TyApp (_, m1, m2) -> - let li1 = ctyp_long_id_prefix m1 in - let li2 = ctyp_long_id_prefix m2 in Lapply (li1, li2) - | t -> error (loc_of_ctyp t) "invalid module expression" - - let ctyp_long_id t = - match t with - | Ast.TyId (_, i) -> (false, (long_type_ident i)) - | TyApp (loc, _, _) -> error loc "invalid type name" - | TyCls (_, i) -> (true, (ident i)) - | t -> error (loc_of_ctyp t) "invalid type" - - let rec ty_var_list_of_ctyp = - function - | Ast.TyApp (_, t1, t2) -> - (ty_var_list_of_ctyp t1) @ (ty_var_list_of_ctyp t2) - | Ast.TyQuo (_, s) -> [ s ] - | _ -> assert false - - let predef_option loc = - TyId - ((loc, - (IdAcc - ((loc, (IdLid ((loc, "*predef*"))), - (IdLid ((loc, "option")))))))) - - let rec ctyp = - function - | TyId (loc, i) -> - let li = long_type_ident i - in mktyp loc (Ptyp_constr (li, [])) - | TyAli (loc, t1, t2) -> - let (t, i) = - (match (t1, t2) with - | (t, TyQuo (_, s)) -> (t, s) - | (TyQuo (_, s), t) -> (t, s) - | _ -> error loc "invalid alias type") - in mktyp loc (Ptyp_alias ((ctyp t), i)) - | TyAny loc -> mktyp loc Ptyp_any - | (TyApp (loc, _, _) as f) -> - let (f, al) = ctyp_fa [] f in - let (is_cls, li) = ctyp_long_id f - in - if is_cls - then mktyp loc (Ptyp_class (li, (List.map ctyp al), [])) - else mktyp loc (Ptyp_constr (li, (List.map ctyp al))) - | TyArr (loc, (TyLab (_, lab, t1)), t2) -> - mktyp loc (Ptyp_arrow (lab, (ctyp t1), (ctyp t2))) - | TyArr (loc, (TyOlb (loc1, lab, t1)), t2) -> - let t1 = TyApp (loc1, (predef_option loc1), t1) - in - mktyp loc - (Ptyp_arrow (("?" ^ lab), (ctyp t1), (ctyp t2))) - | TyArr (loc, t1, t2) -> - mktyp loc (Ptyp_arrow ("", (ctyp t1), (ctyp t2))) - | Ast.TyObj (loc, fl, Ast.RvNil) -> - mktyp loc (Ptyp_object (meth_list fl [])) - | Ast.TyObj (loc, fl, Ast.RvRowVar) -> - mktyp loc - (Ptyp_object (meth_list fl [ mkfield loc Pfield_var ])) - | TyCls (loc, id) -> - mktyp loc (Ptyp_class ((ident id), [], [])) - | Ast.TyPkg (loc, pt) -> - let (i, cs) = package_type pt - in mktyp loc (Ptyp_package (i, cs)) - | TyLab (loc, _, _) -> - error loc "labelled type not allowed here" - | TyMan (loc, _, _) -> - error loc "manifest type not allowed here" - | TyOlb (loc, _, _) -> - error loc "labelled type not allowed here" - | TyPol (loc, t1, t2) -> - mktyp loc (Ptyp_poly ((ty_var_list_of_ctyp t1), (ctyp t2))) - | TyQuo (loc, s) -> mktyp loc (Ptyp_var s) - | TyRec (loc, _) -> error loc "record type not allowed here" - | TySum (loc, _) -> error loc "sum type not allowed here" - | TyPrv (loc, _) -> error loc "private type not allowed here" - | TyMut (loc, _) -> error loc "mutable type not allowed here" - | TyOr (loc, _, _) -> - error loc "type1 | type2 not allowed here" - | TyAnd (loc, _, _) -> - error loc "type1 and type2 not allowed here" - | TyOf (loc, _, _) -> - error loc "type1 of type2 not allowed here" - | TyCol (loc, _, _) -> - error loc "type1 : type2 not allowed here" - | TySem (loc, _, _) -> - error loc "type1 ; type2 not allowed here" - | Ast.TyTup (loc, (Ast.TySta (_, t1, t2))) -> - mktyp loc - (Ptyp_tuple - (List.map ctyp (list_of_ctyp t1 (list_of_ctyp t2 [])))) - | Ast.TyVrnEq (loc, t) -> - mktyp loc (Ptyp_variant ((row_field t), true, None)) - | Ast.TyVrnSup (loc, t) -> - mktyp loc (Ptyp_variant ((row_field t), false, None)) - | Ast.TyVrnInf (loc, t) -> - mktyp loc (Ptyp_variant ((row_field t), true, (Some []))) - | Ast.TyVrnInfSup (loc, t, t') -> - mktyp loc - (Ptyp_variant ((row_field t), true, - (Some (name_tags t')))) - | TyAnt (loc, _) -> error loc "antiquotation not allowed here" - | TyOfAmp (_, _, _) | TyAmp (_, _, _) | TySta (_, _, _) | - TyCom (_, _, _) | TyVrn (_, _) | TyQuM (_, _) | - TyQuP (_, _) | TyDcl (_, _, _, _, _) | TyAnP _ | TyAnM _ | - TyTypePol (_, _, _) | TyObj (_, _, (RvAnt _)) | TyNil _ | - TyTup (_, _) -> assert false - and row_field = - function - | Ast.TyNil _ -> [] - | Ast.TyVrn (_, i) -> [ Rtag (i, true, []) ] - | Ast.TyOfAmp (_, (Ast.TyVrn (_, i)), t) -> - [ Rtag (i, true, (List.map ctyp (list_of_ctyp t []))) ] - | Ast.TyOf (_, (Ast.TyVrn (_, i)), t) -> - [ Rtag (i, false, (List.map ctyp (list_of_ctyp t []))) ] - | Ast.TyOr (_, t1, t2) -> (row_field t1) @ (row_field t2) - | t -> [ Rinherit (ctyp t) ] - and name_tags = - function - | Ast.TyApp (_, t1, t2) -> (name_tags t1) @ (name_tags t2) - | Ast.TyVrn (_, s) -> [ s ] - | _ -> assert false - and meth_list fl acc = - match fl with - | Ast.TyNil _ -> acc - | Ast.TySem (_, t1, t2) -> meth_list t1 (meth_list t2 acc) - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, lab)))), t) -> - (mkfield loc (Pfield (lab, (mkpolytype (ctyp t))))) :: acc - | _ -> assert false - and package_type_constraints wc acc = - match wc with - | Ast.WcNil _ -> acc - | Ast.WcTyp (_, (Ast.TyId (_, id)), ct) -> - ((ident id), (ctyp ct)) :: acc - | Ast.WcAnd (_, wc1, wc2) -> - package_type_constraints wc1 - (package_type_constraints wc2 acc) - | _ -> - error (loc_of_with_constr wc) - "unexpected `with constraint' for a package type" - and package_type : module_type -> package_type = - function - | Ast.MtWit (_, (Ast.MtId (_, i)), wc) -> - ((long_uident i), (package_type_constraints wc [])) - | Ast.MtId (_, i) -> ((long_uident i), []) - | mt -> error (loc_of_module_type mt) "unexpected package type" - - let mktype loc tl cl tk tp tm = - let (params, variance) = List.split tl - in - { - ptype_params = params; - ptype_cstrs = cl; - ptype_kind = tk; - ptype_private = tp; - ptype_manifest = tm; - ptype_loc = mkloc loc; - ptype_variance = variance; - } - - let mkprivate' m = if m then Private else Public - - let mkprivate = - function - | Ast.PrPrivate -> Private - | Ast.PrNil -> Public - | _ -> assert false - - let mktrecord = - function - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (sloc, s)))), - (Ast.TyMut (_, t))) -> - ((with_loc s sloc), Mutable, (mkpolytype (ctyp t)), - (mkloc loc)) - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (sloc, s)))), t) -> - ((with_loc s sloc), Immutable, (mkpolytype (ctyp t)), - (mkloc loc)) - | _ -> assert false - - let mkvariant = - function - | Ast.TyId (loc, (Ast.IdUid (sloc, s))) -> - ((with_loc (conv_con s) sloc), [], None, (mkloc loc)) - | Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), t) -> - ((with_loc (conv_con s) sloc), - (List.map ctyp (list_of_ctyp t [])), None, (mkloc loc)) - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), - (Ast.TyArr (_, t, u))) -> - ((with_loc (conv_con s) sloc), - (List.map ctyp (list_of_ctyp t [])), (Some (ctyp u)), - (mkloc loc)) - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), t) -> - ((with_loc (conv_con s) sloc), [], (Some (ctyp t)), - (mkloc loc)) - | _ -> assert false - - let rec type_decl tl cl loc m pflag = - function - | Ast.TyMan (_, t1, t2) -> - type_decl tl cl loc (Some (ctyp t1)) pflag t2 - | Ast.TyPrv (_loc, t) -> - if pflag - then - error _loc - "multiple private keyword used, use only one instead" - else type_decl tl cl loc m true t - | Ast.TyRec (_, t) -> - mktype loc tl cl - (Ptype_record (List.map mktrecord (list_of_ctyp t []))) - (mkprivate' pflag) m - | Ast.TySum (_, t) -> - mktype loc tl cl - (Ptype_variant (List.map mkvariant (list_of_ctyp t []))) - (mkprivate' pflag) m - | t -> - if m <> None - then - error loc "only one manifest type allowed by definition" - else - (let m = - match t with - | Ast.TyNil _ -> None - | _ -> Some (ctyp t) - in mktype loc tl cl Ptype_abstract (mkprivate' pflag) m) - - let type_decl tl cl t loc = type_decl tl cl loc None false t - - let mkvalue_desc loc t p = - { pval_type = ctyp t; pval_prim = p; pval_loc = mkloc loc; } - - let rec list_of_meta_list = - function - | Ast.LNil -> [] - | Ast.LCons (x, xs) -> x :: (list_of_meta_list xs) - | Ast.LAnt _ -> assert false - - let mkmutable = - function - | Ast.MuMutable -> Mutable - | Ast.MuNil -> Immutable - | _ -> assert false - - let paolab lab p = - match (lab, p) with - | ("", - (Ast.PaId (_, (Ast.IdLid (_, i))) | - Ast.PaTyc (_, (Ast.PaId (_, (Ast.IdLid (_, i)))), _))) - -> i - | ("", p) -> error (loc_of_patt p) "bad ast in label" - | _ -> lab - - let opt_private_ctyp = - function - | Ast.TyPrv (_, t) -> (Ptype_abstract, Private, (ctyp t)) - | t -> (Ptype_abstract, Public, (ctyp t)) - - let rec type_parameters t acc = - match t with - | Ast.TyApp (_, t1, t2) -> - type_parameters t1 (type_parameters t2 acc) - | Ast.TyQuP (_, s) -> (s, (true, false)) :: acc - | Ast.TyQuM (_, s) -> (s, (false, true)) :: acc - | Ast.TyQuo (_, s) -> (s, (false, false)) :: acc - | _ -> assert false - - let rec optional_type_parameters t acc = - match t with - | Ast.TyApp (_, t1, t2) -> - optional_type_parameters t1 - (optional_type_parameters t2 acc) - | Ast.TyQuP (loc, s) -> - ((Some (with_loc s loc)), (true, false)) :: acc - | Ast.TyAnP _loc -> (None, (true, false)) :: acc - | Ast.TyQuM (loc, s) -> - ((Some (with_loc s loc)), (false, true)) :: acc - | Ast.TyAnM _loc -> (None, (false, true)) :: acc - | Ast.TyQuo (loc, s) -> - ((Some (with_loc s loc)), (false, false)) :: acc - | Ast.TyAny _loc -> (None, (false, false)) :: acc - | _ -> assert false - - let rec class_parameters t acc = - match t with - | Ast.TyCom (_, t1, t2) -> - class_parameters t1 (class_parameters t2 acc) - | Ast.TyQuP (loc, s) -> - ((with_loc s loc), (true, false)) :: acc - | Ast.TyQuM (loc, s) -> - ((with_loc s loc), (false, true)) :: acc - | Ast.TyQuo (loc, s) -> - ((with_loc s loc), (false, false)) :: acc - | _ -> assert false - - let rec type_parameters_and_type_name t acc = - match t with - | Ast.TyApp (_, t1, t2) -> - type_parameters_and_type_name t1 - (optional_type_parameters t2 acc) - | Ast.TyId (_, i) -> ((ident i), acc) - | _ -> assert false - - let mkwithtyp pwith_type loc id_tpl ct = - let (id, tpl) = type_parameters_and_type_name id_tpl [] in - let (params, variance) = List.split tpl in - let (kind, priv, ct) = opt_private_ctyp ct - in - (id, - (pwith_type - { - ptype_params = params; - ptype_cstrs = []; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = Some ct; - ptype_loc = mkloc loc; - ptype_variance = variance; - })) - - let rec mkwithc wc acc = - match wc with - | Ast.WcNil _ -> acc - | Ast.WcTyp (loc, id_tpl, ct) -> - (mkwithtyp (fun x -> Pwith_type x) loc id_tpl ct) :: acc - | Ast.WcMod (_, i1, i2) -> - ((long_uident i1), (Pwith_module (long_uident i2))) :: acc - | Ast.WcTyS (loc, id_tpl, ct) -> - (mkwithtyp (fun x -> Pwith_typesubst x) loc id_tpl ct) :: - acc - | Ast.WcMoS (_, i1, i2) -> - ((long_uident i1), (Pwith_modsubst (long_uident i2))) :: - acc - | Ast.WcAnd (_, wc1, wc2) -> mkwithc wc1 (mkwithc wc2 acc) - | Ast.WcAnt (loc, _) -> - error loc "bad with constraint (antiquotation)" - - let rec patt_fa al = - function - | PaApp (_, f, a) -> patt_fa (a :: al) f - | f -> (f, al) - - let rec deep_mkrangepat loc c1 c2 = - if c1 = c2 - then mkghpat loc (Ppat_constant (Const_char c1)) - else - mkghpat loc - (Ppat_or ((mkghpat loc (Ppat_constant (Const_char c1))), - (deep_mkrangepat loc (Char.chr ((Char.code c1) + 1)) c2))) - - let rec mkrangepat loc c1 c2 = - if c1 > c2 - then mkrangepat loc c2 c1 - else - if c1 = c2 - then mkpat loc (Ppat_constant (Const_char c1)) - else - mkpat loc - (Ppat_or ((mkghpat loc (Ppat_constant (Const_char c1))), - (deep_mkrangepat loc (Char.chr ((Char.code c1) + 1)) - c2))) - - let rec patt = - function - | Ast.PaId (loc, (Ast.IdLid (sloc, s))) -> - mkpat loc (Ppat_var (with_loc s sloc)) - | Ast.PaId (loc, i) -> - let p = - Ppat_construct ((long_uident ~conv_con i), None, - (constructors_arity ())) - in mkpat loc p - | PaAli (loc, p1, p2) -> - let (p, i) = - (match (p1, p2) with - | (p, Ast.PaId (_, (Ast.IdLid (sloc, s)))) -> - (p, (with_loc s sloc)) - | (Ast.PaId (_, (Ast.IdLid (sloc, s))), p) -> - (p, (with_loc s sloc)) - | _ -> error loc "invalid alias pattern") - in mkpat loc (Ppat_alias ((patt p), i)) - | PaAnt (loc, _) -> error loc "antiquotation not allowed here" - | PaAny loc -> mkpat loc Ppat_any - | Ast.PaApp (loc, (Ast.PaId (_, (Ast.IdUid (sloc, s)))), - (Ast.PaTup (_, (Ast.PaAny loc_any)))) -> - mkpat loc - (Ppat_construct ((lident_with_loc (conv_con s) sloc), - (Some (mkpat loc_any Ppat_any)), false)) - | (PaApp (loc, _, _) as f) -> - let (f, al) = patt_fa [] f in - let al = List.map patt al - in - (match (patt f).ppat_desc with - | Ppat_construct (li, None, _) -> - if constructors_arity () - then - mkpat loc - (Ppat_construct (li, - (Some (mkpat loc (Ppat_tuple al))), true)) - else - (let a = - match al with - | [ a ] -> a - | _ -> mkpat loc (Ppat_tuple al) - in - mkpat loc - (Ppat_construct (li, (Some a), false))) - | Ppat_variant (s, None) -> - let a = - if constructors_arity () - then mkpat loc (Ppat_tuple al) - else - (match al with - | [ a ] -> a - | _ -> mkpat loc (Ppat_tuple al)) - in mkpat loc (Ppat_variant (s, (Some a))) - | _ -> - error (loc_of_patt f) - "this is not a constructor, it cannot be applied in a pattern") - | PaArr (loc, p) -> - mkpat loc (Ppat_array (List.map patt (list_of_patt p []))) - | PaChr (loc, s) -> - mkpat loc - (Ppat_constant (Const_char (char_of_char_token loc s))) - | PaInt (loc, s) -> - let i = - (try int_of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type int") - in mkpat loc (Ppat_constant (Const_int i)) - | PaInt32 (loc, s) -> - let i32 = - (try Int32.of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type int32") - in mkpat loc (Ppat_constant (Const_int32 i32)) - | PaInt64 (loc, s) -> - let i64 = - (try Int64.of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type int64") - in mkpat loc (Ppat_constant (Const_int64 i64)) - | PaNativeInt (loc, s) -> - let nati = - (try Nativeint.of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type nativeint") - in mkpat loc (Ppat_constant (Const_nativeint nati)) - | PaFlo (loc, s) -> - mkpat loc - (Ppat_constant (Const_float (remove_underscores s))) - | PaLab (loc, _, _) -> - error loc "labeled pattern not allowed here" - | PaOlb (loc, _, _) | PaOlbi (loc, _, _, _) -> - error loc "labeled pattern not allowed here" - | PaOrp (loc, p1, p2) -> - mkpat loc (Ppat_or ((patt p1), (patt p2))) - | PaRng (loc, p1, p2) -> - (match (p1, p2) with - | (PaChr (loc1, c1), PaChr (loc2, c2)) -> - let c1 = char_of_char_token loc1 c1 in - let c2 = char_of_char_token loc2 c2 - in mkrangepat loc c1 c2 - | _ -> - error loc "range pattern allowed only for characters") - | PaRec (loc, p) -> - let ps = list_of_patt p [] in - let is_wildcard = - (function | Ast.PaAny _ -> true | _ -> false) in - let (wildcards, ps) = List.partition is_wildcard ps in - let is_closed = if wildcards = [] then Closed else Open - in - mkpat loc - (Ppat_record (((List.map mklabpat ps), is_closed))) - | PaStr (loc, s) -> - mkpat loc - (Ppat_constant - (Const_string (string_of_string_token loc s))) - | Ast.PaTup (loc, (Ast.PaCom (_, p1, p2))) -> - mkpat loc - (Ppat_tuple - (List.map patt (list_of_patt p1 (list_of_patt p2 [])))) - | Ast.PaTup (loc, _) -> error loc "singleton tuple pattern" - | PaTyc (loc, p, t) -> - mkpat loc (Ppat_constraint ((patt p), (ctyp t))) - | PaTyp (loc, i) -> mkpat loc (Ppat_type (long_type_ident i)) - | PaVrn (loc, s) -> - mkpat loc (Ppat_variant ((conv_con s), None)) - | PaLaz (loc, p) -> mkpat loc (Ppat_lazy (patt p)) - | PaMod (loc, m) -> mkpat loc (Ppat_unpack (with_loc m loc)) - | (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _ - as p) -> error (loc_of_patt p) "invalid pattern" - and mklabpat = - function - | Ast.PaEq (_, i, p) -> - ((ident ~conv_lid: conv_lab i), (patt p)) - | p -> error (loc_of_patt p) "invalid pattern" - - let rec expr_fa al = - function - | ExApp (_, f, a) -> expr_fa (a :: al) f - | f -> (f, al) - - let rec class_expr_fa al = - function - | CeApp (_, ce, a) -> class_expr_fa (a :: al) ce - | ce -> (ce, al) - - let rec sep_expr_acc l = - function - | ExAcc (_, e1, e2) -> sep_expr_acc (sep_expr_acc l e2) e1 - | (Ast.ExId (loc, (Ast.IdUid (_, s))) as e) -> - (match l with - | [] -> [ (loc, [], e) ] - | (loc', sl, e) :: l -> - ((Loc.merge loc loc'), (s :: sl), e) :: l) - | Ast.ExId (_, ((Ast.IdAcc (_, _, _) as i))) -> - let rec normalize_acc = - (function - | Ast.IdAcc (_loc, i1, i2) -> - Ast.ExAcc (_loc, (normalize_acc i1), - (normalize_acc i2)) - | Ast.IdApp (_loc, i1, i2) -> - Ast.ExApp (_loc, (normalize_acc i1), - (normalize_acc i2)) - | (Ast.IdAnt (_loc, _) | Ast.IdUid (_loc, _) | - Ast.IdLid (_loc, _) - as i) -> Ast.ExId (_loc, i)) - in sep_expr_acc l (normalize_acc i) - | e -> ((loc_of_expr e), [], e) :: l - - let override_flag loc = - function - | Ast.OvOverride -> Override - | Ast.OvNil -> Fresh - | _ -> error loc "antiquotation not allowed here" - - let list_of_opt_ctyp ot acc = - match ot with | Ast.TyNil _ -> acc | t -> list_of_ctyp t acc - - let varify_constructors var_names = - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> Ptyp_var x - | Ptyp_arrow (label, core_type, core_type') -> - Ptyp_arrow (label, (loop core_type), (loop core_type')) - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr ({ txt = Lident s }, []) when - List.mem s var_names -> Ptyp_var ("&" ^ s) - | Ptyp_constr (longident, lst) -> - Ptyp_constr (longident, (List.map loop lst)) - | Ptyp_object lst -> - Ptyp_object (List.map loop_core_field lst) - | Ptyp_class (longident, lst, lbl_list) -> - Ptyp_class ((longident, (List.map loop lst), lbl_list)) - | Ptyp_alias (core_type, string) -> - Ptyp_alias (((loop core_type), string)) - | Ptyp_variant (row_field_list, flag, lbl_lst_option) -> - Ptyp_variant - (((List.map loop_row_field row_field_list), flag, - lbl_lst_option)) - | Ptyp_poly (string_lst, core_type) -> - Ptyp_poly ((string_lst, (loop core_type))) - | Ptyp_package (longident, lst) -> - Ptyp_package - ((longident, - (List.map (fun (n, typ) -> (n, (loop typ))) lst))) - in { (t) with ptyp_desc = desc; } - and loop_core_field t = - let desc = - match t.pfield_desc with - | Pfield ((n, typ)) -> Pfield ((n, (loop typ))) - | Pfield_var -> Pfield_var - in { (t) with pfield_desc = desc; } - and loop_row_field x = - match x with - | Rtag ((label, flag, lst)) -> - Rtag ((label, flag, (List.map loop lst))) - | Rinherit t -> Rinherit (loop t) - in loop - - let rec expr = - function - | Ast.ExAcc (loc, x, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> - mkexp loc - (Pexp_apply - ((mkexp loc (Pexp_ident (lident_with_loc "!" loc))), - [ ("", (expr x)) ])) - | (ExAcc (loc, _, _) | Ast.ExId (loc, (Ast.IdAcc (_, _, _))) as - e) -> - let (e, l) = - (match sep_expr_acc [] e with - | (loc, ml, Ast.ExId (sloc, (Ast.IdUid (_, s)))) :: l -> - let ca = constructors_arity () - in - ((mkexp loc - (Pexp_construct ((mkli sloc (conv_con s) ml), - None, ca))), - l) - | (loc, ml, Ast.ExId (sloc, (Ast.IdLid (_, s)))) :: l -> - ((mkexp loc (Pexp_ident (mkli sloc s ml))), l) - | (_, [], e) :: l -> ((expr e), l) - | _ -> error loc "bad ast in expression") in - let (_, e) = - List.fold_left - (fun (loc_bp, e1) (loc_ep, ml, e2) -> - match e2 with - | Ast.ExId (sloc, (Ast.IdLid (_, s))) -> - let loc = Loc.merge loc_bp loc_ep - in - (loc, - (mkexp loc - (Pexp_field (e1, - (mkli sloc (conv_lab s) ml))))) - | _ -> - error (loc_of_expr e2) - "lowercase identifier expected") - (loc, e) l - in e - | ExAnt (loc, _) -> error loc "antiquotation not allowed here" - | (ExApp (loc, _, _) as f) -> - let (f, al) = expr_fa [] f in - let al = List.map label_expr al - in - (match (expr f).pexp_desc with - | Pexp_construct (li, None, _) -> - let al = List.map snd al - in - if constructors_arity () - then - mkexp loc - (Pexp_construct (li, - (Some (mkexp loc (Pexp_tuple al))), true)) - else - (let a = - match al with - | [ a ] -> a - | _ -> mkexp loc (Pexp_tuple al) - in - mkexp loc - (Pexp_construct (li, (Some a), false))) - | Pexp_variant (s, None) -> - let al = List.map snd al in - let a = - if constructors_arity () - then mkexp loc (Pexp_tuple al) - else - (match al with - | [ a ] -> a - | _ -> mkexp loc (Pexp_tuple al)) - in mkexp loc (Pexp_variant (s, (Some a))) - | _ -> mkexp loc (Pexp_apply ((expr f), al))) - | ExAre (loc, e1, e2) -> - mkexp loc - (Pexp_apply - ((mkexp loc - (Pexp_ident (array_function loc "Array" "get"))), - [ ("", (expr e1)); ("", (expr e2)) ])) - | ExArr (loc, e) -> - mkexp loc (Pexp_array (List.map expr (list_of_expr e []))) - | ExAsf loc -> mkexp loc Pexp_assertfalse - | ExAss (loc, e, v) -> - let e = - (match e with - | Ast.ExAcc (loc, x, - (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> - Pexp_apply - ((mkexp loc - (Pexp_ident (lident_with_loc ":=" loc))), - [ ("", (expr x)); ("", (expr v)) ]) - | ExAcc (loc, _, _) -> - (match (expr e).pexp_desc with - | Pexp_field (e, lab) -> - Pexp_setfield (e, lab, (expr v)) - | _ -> error loc "bad record access") - | ExAre (loc, e1, e2) -> - Pexp_apply - ((mkexp loc - (Pexp_ident (array_function loc "Array" "set"))), - [ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ]) - | Ast.ExId (_, (Ast.IdLid (lloc, lab))) -> - Pexp_setinstvar ((with_loc lab lloc), (expr v)) - | ExSte (loc, e1, e2) -> - Pexp_apply - ((mkexp loc - (Pexp_ident - (array_function loc "String" "set"))), - [ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ]) - | _ -> error loc "bad left part of assignment") - in mkexp loc e - | ExAsr (loc, e) -> mkexp loc (Pexp_assert (expr e)) - | ExChr (loc, s) -> - mkexp loc - (Pexp_constant (Const_char (char_of_char_token loc s))) - | ExCoe (loc, e, t1, t2) -> - let t1 = - (match t1 with | Ast.TyNil _ -> None | t -> Some (ctyp t)) - in - mkexp loc - (Pexp_constraint ((expr e), t1, (Some (ctyp t2)))) - | ExFlo (loc, s) -> - mkexp loc - (Pexp_constant (Const_float (remove_underscores s))) - | ExFor (loc, i, e1, e2, df, el) -> - let e3 = ExSeq (loc, el) - in - mkexp loc - (Pexp_for ((with_loc i loc), (expr e1), (expr e2), - (mkdirection df), (expr e3))) - | Ast.ExFun (loc, (Ast.McArr (_, (PaLab (_, lab, po)), w, e))) - -> - mkexp loc - (Pexp_function (lab, None, - [ ((patt_of_lab loc lab po), (when_expr e w)) ])) - | Ast.ExFun (loc, - (Ast.McArr (_, (PaOlbi (_, lab, p, e1)), w, e2))) -> - let lab = paolab lab p - in - mkexp loc - (Pexp_function (("?" ^ lab), (Some (expr e1)), - [ ((patt p), (when_expr e2 w)) ])) - | Ast.ExFun (loc, (Ast.McArr (_, (PaOlb (_, lab, p)), w, e))) - -> - let lab = paolab lab p - in - mkexp loc - (Pexp_function (("?" ^ lab), None, - [ ((patt_of_lab loc lab p), (when_expr e w)) ])) - | ExFun (loc, a) -> - mkexp loc (Pexp_function ("", None, (match_case a []))) - | ExIfe (loc, e1, e2, e3) -> - mkexp loc - (Pexp_ifthenelse ((expr e1), (expr e2), (Some (expr e3)))) - | ExInt (loc, s) -> - let i = - (try int_of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type int") - in mkexp loc (Pexp_constant (Const_int i)) - | ExInt32 (loc, s) -> - let i32 = - (try Int32.of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type int32") - in mkexp loc (Pexp_constant (Const_int32 i32)) - | ExInt64 (loc, s) -> - let i64 = - (try Int64.of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type int64") - in mkexp loc (Pexp_constant (Const_int64 i64)) - | ExNativeInt (loc, s) -> - let nati = - (try Nativeint.of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type nativeint") - in mkexp loc (Pexp_constant (Const_nativeint nati)) - | ExLab (loc, _, _) -> - error loc "labeled expression not allowed here" - | ExLaz (loc, e) -> mkexp loc (Pexp_lazy (expr e)) - | ExLet (loc, rf, bi, e) -> - mkexp loc (Pexp_let ((mkrf rf), (binding bi []), (expr e))) - | ExLmd (loc, i, me, e) -> - mkexp loc - (Pexp_letmodule ((with_loc i loc), (module_expr me), - (expr e))) - | ExMat (loc, e, a) -> - mkexp loc (Pexp_match ((expr e), (match_case a []))) - | ExNew (loc, id) -> mkexp loc (Pexp_new (long_type_ident id)) - | ExObj (loc, po, cfl) -> - let p = - (match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in - let cil = class_str_item cfl [] - in - mkexp loc - (Pexp_object - { pcstr_pat = patt p; pcstr_fields = cil; }) - | ExOlb (loc, _, _) -> - error loc "labeled expression not allowed here" - | ExOvr (loc, iel) -> - mkexp loc (Pexp_override (mkideexp iel [])) - | ExRec (loc, lel, eo) -> - (match lel with - | Ast.RbNil _ -> error loc "empty record" - | _ -> - let eo = - (match eo with - | Ast.ExNil _ -> None - | e -> Some (expr e)) - in mkexp loc (Pexp_record ((mklabexp lel []), eo))) - | ExSeq (_loc, e) -> - let rec loop = - (function - | [] -> expr (Ast.ExId (_loc, (Ast.IdUid (_loc, "()")))) - | [ e ] -> expr e - | e :: el -> - let _loc = Loc.merge (loc_of_expr e) _loc - in mkexp _loc (Pexp_sequence ((expr e), (loop el)))) - in loop (list_of_expr e []) - | ExSnd (loc, e, s) -> mkexp loc (Pexp_send ((expr e), s)) - | ExSte (loc, e1, e2) -> - mkexp loc - (Pexp_apply - ((mkexp loc - (Pexp_ident (array_function loc "String" "get"))), - [ ("", (expr e1)); ("", (expr e2)) ])) - | ExStr (loc, s) -> - mkexp loc - (Pexp_constant - (Const_string (string_of_string_token loc s))) - | ExTry (loc, e, a) -> - mkexp loc (Pexp_try ((expr e), (match_case a []))) - | Ast.ExTup (loc, (Ast.ExCom (_, e1, e2))) -> - mkexp loc - (Pexp_tuple - (List.map expr (list_of_expr e1 (list_of_expr e2 [])))) - | Ast.ExTup (loc, _) -> error loc "singleton tuple" - | ExTyc (loc, e, t) -> - mkexp loc - (Pexp_constraint ((expr e), (Some (ctyp t)), None)) - | Ast.ExId (loc, (Ast.IdUid (_, "()"))) -> - mkexp loc - (Pexp_construct ((lident_with_loc "()" loc), None, true)) - | Ast.ExId (loc, (Ast.IdLid (_, s))) -> - mkexp loc (Pexp_ident (lident_with_loc s loc)) - | Ast.ExId (loc, (Ast.IdUid (_, s))) -> - mkexp loc - (Pexp_construct ((lident_with_loc (conv_con s) loc), - None, true)) - | ExVrn (loc, s) -> - mkexp loc (Pexp_variant ((conv_con s), None)) - | ExWhi (loc, e1, el) -> - let e2 = ExSeq (loc, el) - in mkexp loc (Pexp_while ((expr e1), (expr e2))) - | Ast.ExOpI (loc, i, e) -> - mkexp loc (Pexp_open (Fresh, (long_uident i), (expr e))) - | Ast.ExPkg (loc, (Ast.MeTyc (_, me, pt))) -> - mkexp loc - (Pexp_constraint - (((mkexp loc (Pexp_pack (module_expr me))), - (Some (mktyp loc (Ptyp_package (package_type pt)))), - None))) - | Ast.ExPkg (loc, me) -> mkexp loc (Pexp_pack (module_expr me)) - | ExFUN (loc, i, e) -> mkexp loc (Pexp_newtype (i, (expr e))) - | Ast.ExCom (loc, _, _) -> - error loc "expr, expr: not allowed here" - | Ast.ExSem (loc, _, _) -> - error loc - "expr; expr: not allowed here, use do {...} or [|...|] to surround them" - | (ExId (_, _) | ExNil _ as e) -> - error (loc_of_expr e) "invalid expr" - and patt_of_lab _loc lab = - function - | Ast.PaNil _ -> - patt (Ast.PaId (_loc, (Ast.IdLid (_loc, lab)))) - | p -> patt p - and expr_of_lab _loc lab = - function - | Ast.ExNil _ -> - expr (Ast.ExId (_loc, (Ast.IdLid (_loc, lab)))) - | e -> expr e - and label_expr = - function - | ExLab (loc, lab, eo) -> (lab, (expr_of_lab loc lab eo)) - | ExOlb (loc, lab, eo) -> - (("?" ^ lab), (expr_of_lab loc lab eo)) - | e -> ("", (expr e)) - and binding x acc = - match x with - | Ast.BiAnd (_, x, y) -> binding x (binding y acc) - | Ast.BiEq (_loc, - (Ast.PaId (sloc, (Ast.IdLid (_, bind_name)))), - (Ast.ExTyc (_, e, (TyTypePol (_, vs, ty))))) -> - let rec id_to_string x = - (match x with - | Ast.TyId (_, (Ast.IdLid (_, x))) -> [ x ] - | Ast.TyApp (_, x, y) -> - (id_to_string x) @ (id_to_string y) - | _ -> assert false) in - let vars = id_to_string vs in - let ampersand_vars = List.map (fun x -> "&" ^ x) vars in - let ty' = varify_constructors vars (ctyp ty) in - let mkexp = mkexp _loc in - let mkpat = mkpat _loc in - let e = - mkexp - (Pexp_constraint ((expr e), (Some (ctyp ty)), None)) in - let rec mk_newtypes x = - (match x with - | [ newtype ] -> mkexp (Pexp_newtype ((newtype, e))) - | newtype :: newtypes -> - mkexp - (Pexp_newtype ((newtype, (mk_newtypes newtypes)))) - | [] -> assert false) in - let pat = - mkpat - (Ppat_constraint - (((mkpat (Ppat_var (with_loc bind_name sloc))), - (mktyp _loc (Ptyp_poly (ampersand_vars, ty')))))) in - let e = mk_newtypes vars in (pat, e) :: acc - | Ast.BiEq (_loc, p, - (Ast.ExTyc (_, e, (Ast.TyPol (_, vs, ty))))) -> - ((patt (Ast.PaTyc (_loc, p, (Ast.TyPol (_loc, vs, ty))))), - (expr e)) :: acc - | Ast.BiEq (_, p, e) -> ((patt p), (expr e)) :: acc - | Ast.BiNil _ -> acc - | _ -> assert false - and match_case x acc = - match x with - | Ast.McOr (_, x, y) -> match_case x (match_case y acc) - | Ast.McArr (_, p, w, e) -> ((patt p), (when_expr e w)) :: acc - | Ast.McNil _ -> acc - | _ -> assert false - and when_expr e w = - match w with - | Ast.ExNil _ -> expr e - | w -> mkexp (loc_of_expr w) (Pexp_when ((expr w), (expr e))) - and mklabexp x acc = - match x with - | Ast.RbSem (_, x, y) -> mklabexp x (mklabexp y acc) - | Ast.RbEq (_, i, e) -> - ((ident ~conv_lid: conv_lab i), (expr e)) :: acc - | _ -> assert false - and mkideexp x acc = - match x with - | Ast.RbNil _ -> acc - | Ast.RbSem (_, x, y) -> mkideexp x (mkideexp y acc) - | Ast.RbEq (_, (Ast.IdLid (sloc, s)), e) -> - ((with_loc s sloc), (expr e)) :: acc - | _ -> assert false - and mktype_decl x acc = - match x with - | Ast.TyAnd (_, x, y) -> mktype_decl x (mktype_decl y acc) - | Ast.TyDcl (cloc, c, tl, td, cl) -> - let cl = - List.map - (fun (t1, t2) -> - let loc = - Loc.merge (loc_of_ctyp t1) (loc_of_ctyp t2) - in ((ctyp t1), (ctyp t2), (mkloc loc))) - cl - in - ((with_loc c cloc), - (type_decl - (List.fold_right optional_type_parameters tl []) cl - td cloc)) :: - acc - | _ -> assert false - and module_type = - function - | Ast.MtNil loc -> - error loc "abstract/nil module type not allowed here" - | Ast.MtId (loc, i) -> mkmty loc (Pmty_ident (long_uident i)) - | Ast.MtFun (loc, n, nt, mt) -> - mkmty loc - (Pmty_functor ((with_loc n loc), (module_type nt), - (module_type mt))) - | Ast.MtQuo (loc, _) -> - error loc "module type variable not allowed here" - | Ast.MtSig (loc, sl) -> - mkmty loc (Pmty_signature (sig_item sl [])) - | Ast.MtWit (loc, mt, wc) -> - mkmty loc (Pmty_with ((module_type mt), (mkwithc wc []))) - | Ast.MtOf (loc, me) -> - mkmty loc (Pmty_typeof (module_expr me)) - | Ast.MtAnt (_, _) -> assert false - and sig_item s l = - match s with - | Ast.SgNil _ -> l - | SgCls (loc, cd) -> - (mksig loc - (Psig_class - (List.map class_info_class_type - (list_of_class_type cd [])))) :: - l - | SgClt (loc, ctd) -> - (mksig loc - (Psig_class_type - (List.map class_info_class_type - (list_of_class_type ctd [])))) :: - l - | Ast.SgSem (_, sg1, sg2) -> sig_item sg1 (sig_item sg2 l) - | SgDir (_, _, _) -> l - | Ast.SgExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s))))) -> - (mksig loc - (Psig_exception ((with_loc (conv_con s) loc), []))) :: - l - | Ast.SgExc (loc, - (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t))) -> - (mksig loc - (Psig_exception ((with_loc (conv_con s) loc), - (List.map ctyp (list_of_ctyp t []))))) :: - l - | SgExc (_, _) -> assert false - | SgExt (loc, n, t, sl) -> - (mksig loc - (Psig_value ((with_loc n loc), - (mkvalue_desc loc t (list_of_meta_list sl))))) :: - l - | SgInc (loc, mt) -> - (mksig loc (Psig_include (module_type mt))) :: l - | SgMod (loc, n, mt) -> - (mksig loc - (Psig_module ((with_loc n loc), (module_type mt)))) :: - l - | SgRecMod (loc, mb) -> - (mksig loc (Psig_recmodule (module_sig_binding mb []))) :: - l - | SgMty (loc, n, mt) -> - let si = - (match mt with - | MtQuo (_, _) -> Pmodtype_abstract - | _ -> Pmodtype_manifest (module_type mt)) - in (mksig loc (Psig_modtype ((with_loc n loc), si))) :: l - | SgOpn (loc, id) -> - (mksig loc (Psig_open (Fresh, (long_uident id)))) :: l - | SgTyp (loc, tdl) -> - (mksig loc (Psig_type (mktype_decl tdl []))) :: l - | SgVal (loc, n, t) -> - (mksig loc - (Psig_value ((with_loc n loc), (mkvalue_desc loc t [])))) :: - l - | Ast.SgAnt (loc, _) -> error loc "antiquotation in sig_item" - and module_sig_binding x acc = - match x with - | Ast.MbAnd (_, x, y) -> - module_sig_binding x (module_sig_binding y acc) - | Ast.MbCol (loc, s, mt) -> - ((with_loc s loc), (module_type mt)) :: acc - | _ -> assert false - and module_str_binding x acc = - match x with - | Ast.MbAnd (_, x, y) -> - module_str_binding x (module_str_binding y acc) - | Ast.MbColEq (loc, s, mt, me) -> - ((with_loc s loc), (module_type mt), (module_expr me)) :: - acc - | _ -> assert false - and module_expr = - function - | Ast.MeNil loc -> error loc "nil module expression" - | Ast.MeId (loc, i) -> mkmod loc (Pmod_ident (long_uident i)) - | Ast.MeApp (loc, me1, me2) -> - mkmod loc - (Pmod_apply ((module_expr me1), (module_expr me2))) - | Ast.MeFun (loc, n, mt, me) -> - mkmod loc - (Pmod_functor ((with_loc n loc), (module_type mt), - (module_expr me))) - | Ast.MeStr (loc, sl) -> - mkmod loc (Pmod_structure (str_item sl [])) - | Ast.MeTyc (loc, me, mt) -> - mkmod loc - (Pmod_constraint ((module_expr me), (module_type mt))) - | Ast.MePkg (loc, (Ast.ExTyc (_, e, (Ast.TyPkg (_, pt))))) -> - mkmod loc - (Pmod_unpack - (mkexp loc - (Pexp_constraint - (((expr e), - (Some - (mktyp loc (Ptyp_package (package_type pt)))), - None))))) - | Ast.MePkg (loc, e) -> mkmod loc (Pmod_unpack (expr e)) - | Ast.MeAnt (loc, _) -> - error loc "antiquotation in module_expr" - and str_item s l = - match s with - | Ast.StNil _ -> l - | StCls (loc, cd) -> - (mkstr loc - (Pstr_class - (List.map class_info_class_expr - (list_of_class_expr cd [])))) :: - l - | StClt (loc, ctd) -> - (mkstr loc - (Pstr_class_type - (List.map class_info_class_type - (list_of_class_type ctd [])))) :: - l - | Ast.StSem (_, st1, st2) -> str_item st1 (str_item st2 l) - | StDir (_, _, _) -> l - | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), Ast. - ONone) -> - (mkstr loc - (Pstr_exception ((with_loc (conv_con s) loc), []))) :: - l - | Ast.StExc (loc, - (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t)), Ast. - ONone) -> - (mkstr loc - (Pstr_exception ((with_loc (conv_con s) loc), - (List.map ctyp (list_of_ctyp t []))))) :: - l - | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), - (Ast.OSome i)) -> - (mkstr loc - (Pstr_exn_rebind ((with_loc (conv_con s) loc), - (long_uident ~conv_con i)))) :: - l - | Ast.StExc (loc, - (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)), - (Ast.OSome _)) -> error loc "type in exception alias" - | StExc (_, _, _) -> assert false - | StExp (loc, e) -> (mkstr loc (Pstr_eval (expr e))) :: l - | StExt (loc, n, t, sl) -> - (mkstr loc - (Pstr_primitive ((with_loc n loc), - (mkvalue_desc loc t (list_of_meta_list sl))))) :: - l - | StInc (loc, me) -> - (mkstr loc (Pstr_include (module_expr me))) :: l - | StMod (loc, n, me) -> - (mkstr loc - (Pstr_module ((with_loc n loc), (module_expr me)))) :: - l - | StRecMod (loc, mb) -> - (mkstr loc (Pstr_recmodule (module_str_binding mb []))) :: - l - | StMty (loc, n, mt) -> - (mkstr loc - (Pstr_modtype ((with_loc n loc), (module_type mt)))) :: - l - | StOpn (loc, id) -> - (mkstr loc (Pstr_open (Fresh, (long_uident id)))) :: l - | StTyp (loc, tdl) -> - (mkstr loc (Pstr_type (mktype_decl tdl []))) :: l - | StVal (loc, rf, bi) -> - (mkstr loc (Pstr_value ((mkrf rf), (binding bi [])))) :: l - | Ast.StAnt (loc, _) -> error loc "antiquotation in str_item" - and class_type = - function - | CtCon (loc, ViNil, id, tl) -> - mkcty loc - (Pcty_constr ((long_class_ident id), - (List.map ctyp (list_of_opt_ctyp tl [])))) - | CtFun (loc, (TyLab (_, lab, t)), ct) -> - mkcty loc (Pcty_fun (lab, (ctyp t), (class_type ct))) - | CtFun (loc, (TyOlb (loc1, lab, t)), ct) -> - let t = TyApp (loc1, (predef_option loc1), t) - in - mkcty loc - (Pcty_fun (("?" ^ lab), (ctyp t), (class_type ct))) - | CtFun (loc, t, ct) -> - mkcty loc (Pcty_fun ("", (ctyp t), (class_type ct))) - | CtSig (loc, t_o, ctfl) -> - let t = - (match t_o with | Ast.TyNil _ -> Ast.TyAny loc | t -> t) in - let cil = class_sig_item ctfl [] - in - mkcty loc - (Pcty_signature - { - pcsig_self = ctyp t; - pcsig_fields = cil; - pcsig_loc = mkloc loc; - }) - | CtCon (loc, _, _, _) -> - error loc "invalid virtual class inside a class type" - | CtAnt (_, _) | CtEq (_, _, _) | CtCol (_, _, _) | - CtAnd (_, _, _) | CtNil _ -> assert false - and class_info_class_expr ci = - match ci with - | CeEq (_, (CeCon (loc, vir, (IdLid (nloc, name)), params)), - ce) -> - let (loc_params, (params, variance)) = - (match params with - | Ast.TyNil _ -> (loc, ([], [])) - | t -> - ((loc_of_ctyp t), - (List.split (class_parameters t [])))) - in - { - pci_virt = mkvirtual vir; - pci_params = (params, (mkloc loc_params)); - pci_name = with_loc name nloc; - pci_expr = class_expr ce; - pci_loc = mkloc loc; - pci_variance = variance; - } - | ce -> error (loc_of_class_expr ce) "bad class definition" - and class_info_class_type ci = - match ci with - | CtEq (_, (CtCon (loc, vir, (IdLid (nloc, name)), params)), - ct) | - CtCol (_, (CtCon (loc, vir, (IdLid (nloc, name)), params)), - ct) - -> - let (loc_params, (params, variance)) = - (match params with - | Ast.TyNil _ -> (loc, ([], [])) - | t -> - ((loc_of_ctyp t), - (List.split (class_parameters t [])))) - in - { - pci_virt = mkvirtual vir; - pci_params = (params, (mkloc loc_params)); - pci_name = with_loc name nloc; - pci_expr = class_type ct; - pci_loc = mkloc loc; - pci_variance = variance; - } - | ct -> - error (loc_of_class_type ct) - "bad class/class type declaration/definition" - and class_sig_item c l = - match c with - | Ast.CgNil _ -> l - | CgCtr (loc, t1, t2) -> - (mkctf loc (Pctf_cstr (((ctyp t1), (ctyp t2))))) :: l - | Ast.CgSem (_, csg1, csg2) -> - class_sig_item csg1 (class_sig_item csg2 l) - | CgInh (loc, ct) -> - (mkctf loc (Pctf_inher (class_type ct))) :: l - | CgMth (loc, s, pf, t) -> - (mkctf loc - (Pctf_meth ((s, (mkprivate pf), (mkpolytype (ctyp t)))))) :: - l - | CgVal (loc, s, b, v, t) -> - (mkctf loc - (Pctf_val ((s, (mkmutable b), (mkvirtual v), (ctyp t))))) :: - l - | CgVir (loc, s, b, t) -> - (mkctf loc - (Pctf_virt ((s, (mkprivate b), (mkpolytype (ctyp t)))))) :: - l - | CgAnt (_, _) -> assert false - and class_expr = - function - | (CeApp (loc, _, _) as c) -> - let (ce, el) = class_expr_fa [] c in - let el = List.map label_expr el - in mkcl loc (Pcl_apply ((class_expr ce), el)) - | CeCon (loc, ViNil, id, tl) -> - mkcl loc - (Pcl_constr ((long_class_ident id), - (List.map ctyp (list_of_opt_ctyp tl [])))) - | CeFun (loc, (PaLab (_, lab, po)), ce) -> - mkcl loc - (Pcl_fun (lab, None, (patt_of_lab loc lab po), - (class_expr ce))) - | CeFun (loc, (PaOlbi (_, lab, p, e)), ce) -> - let lab = paolab lab p - in - mkcl loc - (Pcl_fun (("?" ^ lab), (Some (expr e)), (patt p), - (class_expr ce))) - | CeFun (loc, (PaOlb (_, lab, p)), ce) -> - let lab = paolab lab p - in - mkcl loc - (Pcl_fun (("?" ^ lab), None, (patt_of_lab loc lab p), - (class_expr ce))) - | CeFun (loc, p, ce) -> - mkcl loc (Pcl_fun ("", None, (patt p), (class_expr ce))) - | CeLet (loc, rf, bi, ce) -> - mkcl loc - (Pcl_let ((mkrf rf), (binding bi []), (class_expr ce))) - | CeStr (loc, po, cfl) -> - let p = - (match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in - let cil = class_str_item cfl [] - in - mkcl loc - (Pcl_structure - { pcstr_pat = patt p; pcstr_fields = cil; }) - | CeTyc (loc, ce, ct) -> - mkcl loc - (Pcl_constraint ((class_expr ce), (class_type ct))) - | CeCon (loc, _, _, _) -> - error loc "invalid virtual class inside a class expression" - | CeAnt (_, _) | CeEq (_, _, _) | CeAnd (_, _, _) | CeNil _ -> - assert false - and class_str_item c l = - match c with - | CrNil _ -> l - | CrCtr (loc, t1, t2) -> - (mkcf loc (Pcf_constr (((ctyp t1), (ctyp t2))))) :: l - | Ast.CrSem (_, cst1, cst2) -> - class_str_item cst1 (class_str_item cst2 l) - | CrInh (loc, ov, ce, pb) -> - let opb = if pb = "" then None else Some pb - in - (mkcf loc - (Pcf_inher ((override_flag loc ov), (class_expr ce), - opb))) :: - l - | CrIni (loc, e) -> (mkcf loc (Pcf_init (expr e))) :: l - | CrMth (loc, s, ov, pf, e, t) -> - let t = - (match t with - | Ast.TyNil _ -> None - | t -> Some (mkpolytype (ctyp t))) in - let e = mkexp loc (Pexp_poly ((expr e), t)) - in - (mkcf loc - (Pcf_meth - (((with_loc s loc), (mkprivate pf), - (override_flag loc ov), e)))) :: - l - | CrVal (loc, s, ov, mf, e) -> - (mkcf loc - (Pcf_val - (((with_loc s loc), (mkmutable mf), - (override_flag loc ov), (expr e))))) :: - l - | CrVir (loc, s, pf, t) -> - (mkcf loc - (Pcf_virt - (((with_loc s loc), (mkprivate pf), - (mkpolytype (ctyp t)))))) :: - l - | CrVvr (loc, s, mf, t) -> - (mkcf loc - (Pcf_valvirt - (((with_loc s loc), (mkmutable mf), (ctyp t))))) :: - l - | CrAnt (_, _) -> assert false - - let sig_item ast = sig_item ast [] - - let str_item ast = str_item ast [] - - let directive = - function - | Ast.ExNil _ -> Pdir_none - | ExStr (_, s) -> Pdir_string s - | ExInt (_, i) -> Pdir_int (int_of_string i) - | Ast.ExId (_, (Ast.IdUid (_, "True"))) -> Pdir_bool true - | Ast.ExId (_, (Ast.IdUid (_, "False"))) -> Pdir_bool false - | e -> Pdir_ident (ident_noloc (ident_of_expr e)) - - let phrase = - function - | StDir (_, d, dp) -> Ptop_dir (d, (directive dp)) - | si -> Ptop_def (str_item si) - - end - - end - - module CleanAst = - struct - module Make (Ast : Sig.Camlp4Ast) = - struct - class clean_ast = - object inherit Ast.map as super - method with_constr = - fun wc -> - match super#with_constr wc with - | Ast.WcAnd (_, (Ast.WcNil _), wc) | - Ast.WcAnd (_, wc, (Ast.WcNil _)) -> wc - | wc -> wc - method expr = - fun e -> - match super#expr e with - | Ast.ExLet (_, _, (Ast.BiNil _), e) | - Ast.ExRec (_, (Ast.RbNil _), e) | - Ast.ExCom (_, (Ast.ExNil _), e) | - Ast.ExCom (_, e, (Ast.ExNil _)) | - Ast.ExSem (_, (Ast.ExNil _), e) | - Ast.ExSem (_, e, (Ast.ExNil _)) -> e - | e -> e - method patt = - fun p -> - match super#patt p with - | Ast.PaAli (_, p, (Ast.PaNil _)) | - Ast.PaOrp (_, (Ast.PaNil _), p) | - Ast.PaOrp (_, p, (Ast.PaNil _)) | - Ast.PaCom (_, (Ast.PaNil _), p) | - Ast.PaCom (_, p, (Ast.PaNil _)) | - Ast.PaSem (_, (Ast.PaNil _), p) | - Ast.PaSem (_, p, (Ast.PaNil _)) -> p - | p -> p - method match_case = - fun mc -> - match super#match_case mc with - | Ast.McOr (_, (Ast.McNil _), mc) | - Ast.McOr (_, mc, (Ast.McNil _)) -> mc - | mc -> mc - method binding = - fun bi -> - match super#binding bi with - | Ast.BiAnd (_, (Ast.BiNil _), bi) | - Ast.BiAnd (_, bi, (Ast.BiNil _)) -> bi - | bi -> bi - method rec_binding = - fun rb -> - match super#rec_binding rb with - | Ast.RbSem (_, (Ast.RbNil _), bi) | - Ast.RbSem (_, bi, (Ast.RbNil _)) -> bi - | bi -> bi - method module_binding = - fun mb -> - match super#module_binding mb with - | Ast.MbAnd (_, (Ast.MbNil _), mb) | - Ast.MbAnd (_, mb, (Ast.MbNil _)) -> mb - | mb -> mb - method ctyp = - fun t -> - match super#ctyp t with - | Ast.TyPol (_, (Ast.TyNil _), t) | - Ast.TyAli (_, (Ast.TyNil _), t) | - Ast.TyAli (_, t, (Ast.TyNil _)) | - Ast.TyArr (_, t, (Ast.TyNil _)) | - Ast.TyArr (_, (Ast.TyNil _), t) | - Ast.TyOr (_, (Ast.TyNil _), t) | - Ast.TyOr (_, t, (Ast.TyNil _)) | - Ast.TyOf (_, t, (Ast.TyNil _)) | - Ast.TyAnd (_, (Ast.TyNil _), t) | - Ast.TyAnd (_, t, (Ast.TyNil _)) | - Ast.TySem (_, t, (Ast.TyNil _)) | - Ast.TySem (_, (Ast.TyNil _), t) | - Ast.TyCom (_, (Ast.TyNil _), t) | - Ast.TyCom (_, t, (Ast.TyNil _)) | - Ast.TyAmp (_, t, (Ast.TyNil _)) | - Ast.TyAmp (_, (Ast.TyNil _), t) | - Ast.TySta (_, (Ast.TyNil _), t) | - Ast.TySta (_, t, (Ast.TyNil _)) -> t - | t -> t - method sig_item = - fun sg -> - match super#sig_item sg with - | Ast.SgSem (_, (Ast.SgNil _), sg) | - Ast.SgSem (_, sg, (Ast.SgNil _)) -> sg - | Ast.SgTyp (loc, (Ast.TyNil _)) -> Ast.SgNil loc - | sg -> sg - method str_item = - fun st -> - match super#str_item st with - | Ast.StSem (_, (Ast.StNil _), st) | - Ast.StSem (_, st, (Ast.StNil _)) -> st - | Ast.StTyp (loc, (Ast.TyNil _)) -> Ast.StNil loc - | Ast.StVal (loc, _, (Ast.BiNil _)) -> Ast.StNil loc - | st -> st - method module_type = - fun mt -> - match super#module_type mt with - | Ast.MtWit (_, mt, (Ast.WcNil _)) -> mt - | mt -> mt - method class_expr = - fun ce -> - match super#class_expr ce with - | Ast.CeAnd (_, (Ast.CeNil _), ce) | - Ast.CeAnd (_, ce, (Ast.CeNil _)) -> ce - | ce -> ce - method class_type = - fun ct -> - match super#class_type ct with - | Ast.CtAnd (_, (Ast.CtNil _), ct) | - Ast.CtAnd (_, ct, (Ast.CtNil _)) -> ct - | ct -> ct - method class_sig_item = - fun csg -> - match super#class_sig_item csg with - | Ast.CgSem (_, (Ast.CgNil _), csg) | - Ast.CgSem (_, csg, (Ast.CgNil _)) -> csg - | csg -> csg - method class_str_item = - fun cst -> - match super#class_str_item cst with - | Ast.CrSem (_, (Ast.CrNil _), cst) | - Ast.CrSem (_, cst, (Ast.CrNil _)) -> cst - | cst -> cst - end - - end - - end - - module CommentFilter : - sig - module Make (Token : Sig.Camlp4Token) : - sig - open Token - - type t - - val mk : unit -> t - - val define : Token.Filter.t -> t -> unit - - val filter : - t -> (Token.t * Loc.t) Stream.t -> (Token.t * Loc.t) Stream.t - - val take_list : t -> (string * Loc.t) list - - val take_stream : t -> (string * Loc.t) Stream.t - - end - - end = - struct - module Make (Token : Sig.Camlp4Token) = - struct - open Token - - type t = - (((string * Loc.t) Stream.t) * ((string * Loc.t) Queue.t)) - - let mk () = - let q = Queue.create () in - let f _ = try Some (Queue.take q) with | Queue.Empty -> None - in ((Stream.from f), q) - - let filter (_, q) = - let rec self (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some ((Sig.COMMENT x, loc)) -> - (Stream.junk __strm; - let xs = __strm in (Queue.add (x, loc) q; self xs)) - | Some x -> - (Stream.junk __strm; - let xs = __strm - in Stream.icons x (Stream.slazy (fun _ -> self xs))) - | _ -> Stream.sempty - in self - - let take_list (_, q) = - let rec self accu = - if Queue.is_empty q - then accu - else self ((Queue.take q) :: accu) - in self [] - - let take_stream = fst - - let define token_fiter comments_strm = - Token.Filter.define_filter token_fiter - (fun previous strm -> previous (filter comments_strm strm)) - - end - - end - - module DynLoader : sig include Sig.DynLoader - end = - struct - type t = string Queue.t - - exception Error of string * string - - let include_dir x y = Queue.add y x - - let fold_load_path x f acc = Queue.fold (fun x y -> f y x) acc x - - let mk ?(ocaml_stdlib = true) ?(camlp4_stdlib = true) () = - let q = Queue.create () - in - (if ocaml_stdlib - then include_dir q Camlp4_config.ocaml_standard_library - else (); - if camlp4_stdlib - then - (include_dir q Camlp4_config.camlp4_standard_library; - include_dir q - (Filename.concat Camlp4_config.camlp4_standard_library - "Camlp4Parsers"); - include_dir q - (Filename.concat Camlp4_config.camlp4_standard_library - "Camlp4Printers"); - include_dir q - (Filename.concat Camlp4_config.camlp4_standard_library - "Camlp4Filters")) - else (); - include_dir q "."; - q) - - let find_in_path x name = - if not (Filename.is_implicit name) - then if Sys.file_exists name then name else raise Not_found - else - (let res = - fold_load_path x - (fun dir -> - function - | None -> - let fullname = Filename.concat dir name - in - if Sys.file_exists fullname - then Some fullname - else None - | x -> x) - None - in match res with | None -> raise Not_found | Some x -> x) - - let load = - let _initialized = ref false - in - fun _path file -> - (if not !_initialized - then - (try - (Dynlink.init (); - Dynlink.allow_unsafe_modules true; - _initialized := true) - with - | Dynlink.Error e -> - raise - (Error ("Camlp4's dynamic loader initialization", - (Dynlink.error_message e)))) - else (); - let fname = - try find_in_path _path file - with - | Not_found -> - raise (Error (file, "file not found in path")) - in - try Dynlink.loadfile fname - with - | Dynlink.Error e -> - raise (Error (fname, (Dynlink.error_message e)))) - - let is_native = Dynlink.is_native - - end - - module EmptyError : sig include Sig.Error - end = - struct - type t = unit - - exception E of t - - let print _ = assert false - - let to_string _ = assert false - - end - - module EmptyPrinter : - sig module Make (Ast : Sig.Ast) : Sig.Printer(Ast).S - end = - struct - module Make (Ast : Sig.Ast) = - struct - let print_interf ?input_file:(_) ?output_file:(_) _ = - failwith "No interface printer" - - let print_implem ?input_file:(_) ?output_file:(_) _ = - failwith "No implementation printer" - - end - - end - - module FreeVars : - sig - module Make (Ast : Sig.Camlp4Ast) : - sig - module S : Set.S with type elt = string - - val fold_binding_vars : - (string -> 'accu -> 'accu) -> Ast.binding -> 'accu -> 'accu - - class ['accu] c_fold_pattern_vars : - (string -> 'accu -> 'accu) -> - 'accu -> - object inherit Ast.fold val acc : 'accu method acc : 'accu - end - - val fold_pattern_vars : - (string -> 'accu -> 'accu) -> Ast.patt -> 'accu -> 'accu - - class ['accu] fold_free_vars : - (string -> 'accu -> 'accu) -> - ?env_init: S.t -> - 'accu -> - object ('self_type) - inherit Ast.fold - val free : 'accu - val env : S.t - method free : 'accu - method set_env : S.t -> 'self_type - method add_atom : string -> 'self_type - method add_patt : Ast.patt -> 'self_type - method add_binding : Ast.binding -> 'self_type - end - - val free_vars : S.t -> Ast.expr -> S.t - - end - - end = - struct - module Make (Ast : Sig.Camlp4Ast) = - struct - module S = Set.Make(String) - - class ['accu] c_fold_pattern_vars f init = - object inherit Ast.fold as super - val acc = init - method acc : 'accu = acc - method patt = - function - | Ast.PaId (_, (Ast.IdLid (_, s))) | - Ast.PaLab (_, s, (Ast.PaNil _)) | - Ast.PaOlb (_, s, (Ast.PaNil _)) -> {< acc = f s acc; >} - | p -> super#patt p - end - - let fold_pattern_vars f p init = - ((new c_fold_pattern_vars f init)#patt p)#acc - - let rec fold_binding_vars f bi acc = - match bi with - | Ast.BiAnd (_, bi1, bi2) -> - fold_binding_vars f bi1 (fold_binding_vars f bi2 acc) - | Ast.BiEq (_, p, _) -> fold_pattern_vars f p acc - | Ast.BiNil _ -> acc - | Ast.BiAnt (_, _) -> assert false - - class ['accu] fold_free_vars (f : string -> 'accu -> 'accu) - ?(env_init = S.empty) free_init = - object (o) - inherit Ast.fold as super - val free = (free_init : 'accu) - val env = (env_init : S.t) - method free = free - method set_env = fun env -> {< env = env; >} - method add_atom = fun s -> {< env = S.add s env; >} - method add_patt = - fun p -> {< env = fold_pattern_vars S.add p env; >} - method add_binding = - fun bi -> {< env = fold_binding_vars S.add bi env; >} - method expr = - function - | Ast.ExId (_, (Ast.IdLid (_, s))) | - Ast.ExLab (_, s, (Ast.ExNil _)) | - Ast.ExOlb (_, s, (Ast.ExNil _)) -> - if S.mem s env then o else {< free = f s free; >} - | Ast.ExLet (_, Ast.ReNil, bi, e) -> - (((o#add_binding bi)#expr e)#set_env env)#binding bi - | Ast.ExLet (_, Ast.ReRecursive, bi, e) -> - (((o#add_binding bi)#expr e)#binding bi)#set_env env - | Ast.ExFor (_, s, e1, e2, _, e3) -> - ((((o#expr e1)#expr e2)#add_atom s)#expr e3)#set_env - env - | Ast.ExId (_, _) | Ast.ExNew (_, _) -> o - | Ast.ExObj (_, p, cst) -> - ((o#add_patt p)#class_str_item cst)#set_env env - | e -> super#expr e - method match_case = - function - | Ast.McArr (_, p, e1, e2) -> - (((o#add_patt p)#expr e1)#expr e2)#set_env env - | m -> super#match_case m - method str_item = - function - | Ast.StExt (_, s, t, _) -> (o#ctyp t)#add_atom s - | Ast.StVal (_, Ast.ReNil, bi) -> - (o#binding bi)#add_binding bi - | Ast.StVal (_, Ast.ReRecursive, bi) -> - (o#add_binding bi)#binding bi - | st -> super#str_item st - method class_expr = - function - | Ast.CeFun (_, p, ce) -> - ((o#add_patt p)#class_expr ce)#set_env env - | Ast.CeLet (_, Ast.ReNil, bi, ce) -> - (((o#binding bi)#add_binding bi)#class_expr ce)#set_env - env - | Ast.CeLet (_, Ast.ReRecursive, bi, ce) -> - (((o#add_binding bi)#binding bi)#class_expr ce)#set_env - env - | Ast.CeStr (_, p, cst) -> - ((o#add_patt p)#class_str_item cst)#set_env env - | ce -> super#class_expr ce - method class_str_item = - function - | (Ast.CrInh (_, _, _, "") as cst) -> - super#class_str_item cst - | Ast.CrInh (_, _, ce, s) -> (o#class_expr ce)#add_atom s - | Ast.CrVal (_, s, _, _, e) -> (o#expr e)#add_atom s - | Ast.CrVvr (_, s, _, t) -> (o#ctyp t)#add_atom s - | cst -> super#class_str_item cst - method module_expr = - function - | Ast.MeStr (_, st) -> (o#str_item st)#set_env env - | me -> super#module_expr me - end - - let free_vars env_init e = - let fold = new fold_free_vars S.add ~env_init S.empty - in (fold#expr e)#free - - end - - end - - module Grammar = - struct - module Structure = - struct - open Sig.Grammar - - module type S = - sig - module Loc : Sig.Loc - - module Token : Sig.Token with module Loc = Loc - - module Lexer : Sig.Lexer with module Loc = Loc - and module Token = Token - - module Action : Sig.Grammar.Action - - type gram = - { gfilter : Token.Filter.t; - gkeywords : (string, int ref) Hashtbl.t; - glexer : - Loc.t -> char Stream.t -> (Token.t * Loc.t) Stream.t; - warning_verbose : bool ref; error_verbose : bool ref - } - - type token_info = - { prev_loc : Loc.t; cur_loc : Loc.t; prev_loc_only : bool - } - - type token_stream = (Token.t * token_info) Stream.t - - type efun = token_stream -> Action.t - - type token_pattern = ((Token.t -> bool) * string) - - type internal_entry = - { egram : gram; ename : string; - mutable estart : int -> efun; - mutable econtinue : int -> Loc.t -> Action.t -> efun; - mutable edesc : desc - } - and desc = - | Dlevels of level list - | Dparser of (token_stream -> Action.t) - and level = - { assoc : assoc; lname : string option; lsuffix : tree; - lprefix : tree - } - and symbol = - | Smeta of string * symbol list * Action.t - | Snterm of internal_entry - | Snterml of internal_entry * string - | Slist0 of symbol - | Slist0sep of symbol * symbol - | Slist1 of symbol - | Slist1sep of symbol * symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree - and tree = - | Node of node - | LocAct of Action.t * Action.t list - | DeadEnd - and node = - { node : symbol; son : tree; brother : tree - } - - type production_rule = ((symbol list) * Action.t) - - type single_extend_statment = - ((string option) * (assoc option) * (production_rule list)) - - type extend_statment = - ((position option) * (single_extend_statment list)) - - type delete_statment = symbol list - - type ('a, 'b, 'c) fold = - internal_entry -> - symbol list -> ('a Stream.t -> 'b) -> 'a Stream.t -> 'c - - type ('a, 'b, 'c) foldsep = - internal_entry -> - symbol list -> - ('a Stream.t -> 'b) -> - ('a Stream.t -> unit) -> 'a Stream.t -> 'c - - val get_filter : gram -> Token.Filter.t - - val using : gram -> string -> unit - - val removing : gram -> string -> unit - - end - - module Make (Lexer : Sig.Lexer) = - struct - module Loc = Lexer.Loc - - module Token = Lexer.Token - - module Action : Sig.Grammar.Action = - struct - type t = Obj.t - - let mk = Obj.repr - - let get = Obj.obj - - let getf = Obj.obj - - let getf2 = Obj.obj - - end - - module Lexer = Lexer - - type gram = - { gfilter : Token.Filter.t; - gkeywords : (string, int ref) Hashtbl.t; - glexer : - Loc.t -> char Stream.t -> (Token.t * Loc.t) Stream.t; - warning_verbose : bool ref; error_verbose : bool ref - } - - type token_info = - { prev_loc : Loc.t; cur_loc : Loc.t; prev_loc_only : bool - } - - type token_stream = (Token.t * token_info) Stream.t - - type efun = token_stream -> Action.t - - type token_pattern = ((Token.t -> bool) * string) - - type internal_entry = - { egram : gram; ename : string; - mutable estart : int -> efun; - mutable econtinue : int -> Loc.t -> Action.t -> efun; - mutable edesc : desc - } - and desc = - | Dlevels of level list - | Dparser of (token_stream -> Action.t) - and level = - { assoc : assoc; lname : string option; lsuffix : tree; - lprefix : tree - } - and symbol = - | Smeta of string * symbol list * Action.t - | Snterm of internal_entry - | Snterml of internal_entry * string - | Slist0 of symbol - | Slist0sep of symbol * symbol - | Slist1 of symbol - | Slist1sep of symbol * symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree - and tree = - | Node of node - | LocAct of Action.t * Action.t list - | DeadEnd - and node = - { node : symbol; son : tree; brother : tree - } - - type production_rule = ((symbol list) * Action.t) - - type single_extend_statment = - ((string option) * (assoc option) * (production_rule list)) - - type extend_statment = - ((position option) * (single_extend_statment list)) - - type delete_statment = symbol list - - type ('a, 'b, 'c) fold = - internal_entry -> - symbol list -> ('a Stream.t -> 'b) -> 'a Stream.t -> 'c - - type ('a, 'b, 'c) foldsep = - internal_entry -> - symbol list -> - ('a Stream.t -> 'b) -> - ('a Stream.t -> unit) -> 'a Stream.t -> 'c - - let get_filter g = g.gfilter - - let token_location r = r.cur_loc - - type 'a not_filtered = 'a - - let using { gkeywords = table; gfilter = filter } kwd = - let r = - try Hashtbl.find table kwd - with - | Not_found -> - let r = ref 0 in (Hashtbl.add table kwd r; r) - in (Token.Filter.keyword_added filter kwd (!r = 0); incr r) - - let removing { gkeywords = table; gfilter = filter } kwd = - let r = Hashtbl.find table kwd in - let () = decr r - in - if !r = 0 - then - (Token.Filter.keyword_removed filter kwd; - Hashtbl.remove table kwd) - else () - - end - - end - - module Search = - struct - module Make (Structure : Structure.S) = - struct - open Structure - - let tree_in_entry prev_symb tree = - function - | Dlevels levels -> - let rec search_levels = - (function - | [] -> tree - | level :: levels -> - (match search_level level with - | Some tree -> tree - | None -> search_levels levels)) - and search_level level = - (match search_tree level.lsuffix with - | Some t -> - Some - (Node - { node = Sself; son = t; brother = DeadEnd; - }) - | None -> search_tree level.lprefix) - and search_tree t = - if (tree <> DeadEnd) && (t == tree) - then Some t - else - (match t with - | Node n -> - (match search_symbol n.node with - | Some symb -> - Some - (Node - { - node = symb; - son = n.son; - brother = DeadEnd; - }) - | None -> - (match search_tree n.son with - | Some t -> - Some - (Node - { - node = n.node; - son = t; - brother = DeadEnd; - }) - | None -> search_tree n.brother)) - | LocAct (_, _) | DeadEnd -> None) - and search_symbol symb = - (match symb with - | Snterm _ | Snterml (_, _) | Slist0 _ | - Slist0sep (_, _) | Slist1 _ | Slist1sep (_, _) | - Sopt _ | Stry _ | Stoken _ | Stree _ | - Skeyword _ when symb == prev_symb -> Some symb - | Slist0 symb -> - (match search_symbol symb with - | Some symb -> Some (Slist0 symb) - | None -> None) - | Slist0sep (symb, sep) -> - (match search_symbol symb with - | Some symb -> Some (Slist0sep (symb, sep)) - | None -> - (match search_symbol sep with - | Some sep -> Some (Slist0sep (symb, sep)) - | None -> None)) - | Slist1 symb -> - (match search_symbol symb with - | Some symb -> Some (Slist1 symb) - | None -> None) - | Slist1sep (symb, sep) -> - (match search_symbol symb with - | Some symb -> Some (Slist1sep (symb, sep)) - | None -> - (match search_symbol sep with - | Some sep -> Some (Slist1sep (symb, sep)) - | None -> None)) - | Sopt symb -> - (match search_symbol symb with - | Some symb -> Some (Sopt symb) - | None -> None) - | Stry symb -> - (match search_symbol symb with - | Some symb -> Some (Stry symb) - | None -> None) - | Stree t -> - (match search_tree t with - | Some t -> Some (Stree t) - | None -> None) - | _ -> None) - in search_levels levels - | Dparser _ -> tree - - end - - end - - module Tools = - struct - let get_prev_loc_only = ref false - - module Make (Structure : Structure.S) = - struct - open Structure - - let empty_entry ename _ = - raise (Stream.Error ("entry [" ^ (ename ^ "] is empty"))) - - let rec stream_map f (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some x -> - (Stream.junk __strm; - let strm = __strm - in - Stream.lcons (fun _ -> f x) - (Stream.slazy (fun _ -> stream_map f strm))) - | _ -> Stream.sempty - - let keep_prev_loc strm = - match Stream.peek strm with - | None -> Stream.sempty - | Some ((tok0, init_loc)) -> - let rec go prev_loc strm1 = - if !get_prev_loc_only - then - Stream.lcons - (fun _ -> - (tok0, - { - prev_loc = prev_loc; - cur_loc = prev_loc; - prev_loc_only = true; - })) - (Stream.slazy (fun _ -> go prev_loc strm1)) - else - (let (__strm : _ Stream.t) = strm1 - in - match Stream.peek __strm with - | Some ((tok, cur_loc)) -> - (Stream.junk __strm; - let strm = __strm - in - Stream.lcons - (fun _ -> - (tok, - { - prev_loc = prev_loc; - cur_loc = cur_loc; - prev_loc_only = false; - })) - (Stream.slazy - (fun _ -> go cur_loc strm))) - | _ -> Stream.sempty) - in go init_loc strm - - let drop_prev_loc strm = - stream_map (fun (tok, r) -> (tok, (r.cur_loc))) strm - - let get_cur_loc strm = - match Stream.peek strm with - | Some ((_, r)) -> r.cur_loc - | None -> Loc.ghost - - let get_prev_loc strm = - (get_prev_loc_only := true; - let result = - match Stream.peek strm with - | Some - ((_, { prev_loc = prev_loc; prev_loc_only = true })) - -> (Stream.junk strm; prev_loc) - | Some - ((_, { prev_loc = prev_loc; prev_loc_only = false })) - -> prev_loc - | None -> Loc.ghost - in (get_prev_loc_only := false; result)) - - let is_level_labelled n lev = - match lev.lname with | Some n1 -> n = n1 | None -> false - - let warning_verbose = ref true - - let rec get_token_list entry tokl last_tok tree = - match tree with - | Node - { - node = (Stoken _ | Skeyword _ as tok); - son = son; - brother = DeadEnd - } -> get_token_list entry (last_tok :: tokl) tok son - | _ -> - if tokl = [] - then None - else - Some - (((List.rev (last_tok :: tokl)), last_tok, tree)) - - let is_antiquot s = - let len = String.length s in (len > 1) && (s.[0] = '$') - - let eq_Stoken_ids s1 s2 = - (not (is_antiquot s1)) && - ((not (is_antiquot s2)) && (s1 = s2)) - - let logically_eq_symbols entry = - let rec eq_symbols s1 s2 = - match (s1, s2) with - | (Snterm e1, Snterm e2) -> e1.ename = e2.ename - | (Snterm e1, Sself) -> e1.ename = entry.ename - | (Sself, Snterm e2) -> entry.ename = e2.ename - | (Snterml (e1, l1), Snterml (e2, l2)) -> - (e1.ename = e2.ename) && (l1 = l2) - | (Slist0 s1, Slist0 s2) | (Slist1 s1, Slist1 s2) | - (Sopt s1, Sopt s2) | (Stry s1, Stry s2) -> - eq_symbols s1 s2 - | (Slist0sep (s1, sep1), Slist0sep (s2, sep2)) | - (Slist1sep (s1, sep1), Slist1sep (s2, sep2)) -> - (eq_symbols s1 s2) && (eq_symbols sep1 sep2) - | (Stree t1, Stree t2) -> eq_trees t1 t2 - | (Stoken ((_, s1)), Stoken ((_, s2))) -> - eq_Stoken_ids s1 s2 - | _ -> s1 = s2 - and eq_trees t1 t2 = - match (t1, t2) with - | (Node n1, Node n2) -> - (eq_symbols n1.node n2.node) && - ((eq_trees n1.son n2.son) && - (eq_trees n1.brother n2.brother)) - | ((LocAct (_, _) | DeadEnd), (LocAct (_, _) | DeadEnd)) - -> true - | _ -> false - in eq_symbols - - let rec eq_symbol s1 s2 = - match (s1, s2) with - | (Snterm e1, Snterm e2) -> e1 == e2 - | (Snterml (e1, l1), Snterml (e2, l2)) -> - (e1 == e2) && (l1 = l2) - | (Slist0 s1, Slist0 s2) | (Slist1 s1, Slist1 s2) | - (Sopt s1, Sopt s2) | (Stry s1, Stry s2) -> - eq_symbol s1 s2 - | (Slist0sep (s1, sep1), Slist0sep (s2, sep2)) | - (Slist1sep (s1, sep1), Slist1sep (s2, sep2)) -> - (eq_symbol s1 s2) && (eq_symbol sep1 sep2) - | (Stree _, Stree _) -> false - | (Stoken ((_, s1)), Stoken ((_, s2))) -> - eq_Stoken_ids s1 s2 - | _ -> s1 = s2 - - end - - end - - module Print : - sig - module Make (Structure : Structure.S) : - sig - val flatten_tree : - Structure.tree -> (Structure.symbol list) list - - val print_symbol : - Format.formatter -> Structure.symbol -> unit - - val print_meta : - Format.formatter -> string -> Structure.symbol list -> unit - - val print_symbol1 : - Format.formatter -> Structure.symbol -> unit - - val print_rule : - Format.formatter -> Structure.symbol list -> unit - - val print_level : - Format.formatter -> - (Format.formatter -> unit -> unit) -> - (Structure.symbol list) list -> unit - - val levels : Format.formatter -> Structure.level list -> unit - - val entry : - Format.formatter -> Structure.internal_entry -> unit - - end - - module MakeDump (Structure : Structure.S) : - sig - val print_symbol : - Format.formatter -> Structure.symbol -> unit - - val print_meta : - Format.formatter -> string -> Structure.symbol list -> unit - - val print_symbol1 : - Format.formatter -> Structure.symbol -> unit - - val print_rule : - Format.formatter -> Structure.symbol list -> unit - - val print_level : - Format.formatter -> - (Format.formatter -> unit -> unit) -> - (Structure.symbol list) list -> unit - - val levels : Format.formatter -> Structure.level list -> unit - - val entry : - Format.formatter -> Structure.internal_entry -> unit - - end - - end = - struct - module Make (Structure : Structure.S) = - struct - open Structure - - open Format - - open Sig.Grammar - - let rec flatten_tree = - function - | DeadEnd -> [] - | LocAct (_, _) -> [ [] ] - | Node { node = n; brother = b; son = s } -> - (List.map (fun l -> n :: l) (flatten_tree s)) @ - (flatten_tree b) - - let rec print_symbol ppf = - function - | Smeta (n, sl, _) -> print_meta ppf n sl - | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s - | Slist0sep (s, t) -> - fprintf ppf "LIST0 %a SEP %a" print_symbol1 s - print_symbol1 t - | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s - | Slist1sep (s, t) -> - fprintf ppf "LIST1 %a SEP %a" print_symbol1 s - print_symbol1 t - | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stry s -> fprintf ppf "TRY %a" print_symbol1 s - | Snterml (e, l) -> fprintf ppf "%s@ LEVEL@ %S" e.ename l - | (Snterm _ | Snext | Sself | Stree _ | Stoken _ | - Skeyword _ - as s) -> print_symbol1 ppf s - and print_meta ppf n sl = - let rec loop i = - function - | [] -> () - | s :: sl -> - let j = - (try String.index_from n i ' ' - with | Not_found -> String.length n) - in - (fprintf ppf "%s %a" (String.sub n i (j - i)) - print_symbol1 s; - if sl = [] - then () - else - (fprintf ppf " "; - loop (min (j + 1) (String.length n)) sl)) - in loop 0 sl - and print_symbol1 ppf = - function - | Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken ((_, descr)) -> pp_print_string ppf descr - | Skeyword s -> fprintf ppf "%S" s - | Stree t -> - print_level ppf pp_print_space (flatten_tree t) - | (Smeta (_, _, _) | Snterml (_, _) | Slist0 _ | - Slist0sep (_, _) | Slist1 _ | Slist1sep (_, _) | - Sopt _ | Stry _ - as s) -> fprintf ppf "(%a)" print_symbol s - and print_rule ppf symbols = - (fprintf ppf "@["; - let _ = - List.fold_left - (fun sep symbol -> - (fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ ")) - (fun _ -> ()) symbols - in fprintf ppf "@]") - and print_level ppf pp_print_space rules = - (fprintf ppf "@[[ "; - let _ = - List.fold_left - (fun sep rule -> - (fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space ())) - (fun _ -> ()) rules - in fprintf ppf " ]@]") - - let levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - let rules = - (List.map (fun t -> Sself :: t) - (flatten_tree lev.lsuffix)) - @ (flatten_tree lev.lprefix) - in - (fprintf ppf "%t@[" sep; - (match lev.lname with - | Some n -> fprintf ppf "%S@;<1 2>" n - | None -> ()); - (match lev.assoc with - | LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA"); - fprintf ppf "@]@;<1 2>"; - print_level ppf pp_force_newline rules; - fun ppf -> fprintf ppf "@,| ")) - (fun _ -> ()) elev - in () - - let entry ppf e = - (fprintf ppf "@[%s: [ " e.ename; - (match e.edesc with - | Dlevels elev -> levels ppf elev - | Dparser _ -> fprintf ppf ""); - fprintf ppf " ]@]") - - end - - module MakeDump (Structure : Structure.S) = - struct - open Structure - - open Format - - open Sig.Grammar - - type brothers = | Bro of symbol * brothers list - - let rec print_tree ppf tree = - let rec get_brothers acc = - function - | DeadEnd -> List.rev acc - | LocAct (_, _) -> List.rev acc - | Node { node = n; brother = b; son = s } -> - get_brothers ((Bro (n, (get_brothers [] s))) :: acc) - b - and print_brothers ppf brothers = - if brothers = [] - then fprintf ppf "@ []" - else - List.iter - (function - | Bro (n, xs) -> - (fprintf ppf "@ @[- %a" print_symbol n; - (match xs with - | [] -> () - | [ _ ] -> - (try - print_children ppf (get_children [] xs) - with - | Exit -> - fprintf ppf ":%a" print_brothers xs) - | _ -> fprintf ppf ":%a" print_brothers xs); - fprintf ppf "@]")) - brothers - and print_children ppf = - List.iter (fprintf ppf ";@ %a" print_symbol) - and get_children acc = - function - | [] -> List.rev acc - | [ Bro (n, x) ] -> get_children (n :: acc) x - | _ -> raise Exit - in print_brothers ppf (get_brothers [] tree) - and print_symbol ppf = - function - | Smeta (n, sl, _) -> print_meta ppf n sl - | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s - | Slist0sep (s, t) -> - fprintf ppf "LIST0 %a SEP %a" print_symbol1 s - print_symbol1 t - | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s - | Slist1sep (s, t) -> - fprintf ppf "LIST1 %a SEP %a" print_symbol1 s - print_symbol1 t - | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stry s -> fprintf ppf "TRY %a" print_symbol1 s - | Snterml (e, l) -> fprintf ppf "%s@ LEVEL@ %S" e.ename l - | (Snterm _ | Snext | Sself | Stree _ | Stoken _ | - Skeyword _ - as s) -> print_symbol1 ppf s - and print_meta ppf n sl = - let rec loop i = - function - | [] -> () - | s :: sl -> - let j = - (try String.index_from n i ' ' - with | Not_found -> String.length n) - in - (fprintf ppf "%s %a" (String.sub n i (j - i)) - print_symbol1 s; - if sl = [] - then () - else - (fprintf ppf " "; - loop (min (j + 1) (String.length n)) sl)) - in loop 0 sl - and print_symbol1 ppf = - function - | Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken ((_, descr)) -> pp_print_string ppf descr - | Skeyword s -> fprintf ppf "%S" s - | Stree t -> print_tree ppf t - | (Smeta (_, _, _) | Snterml (_, _) | Slist0 _ | - Slist0sep (_, _) | Slist1 _ | Slist1sep (_, _) | - Sopt _ | Stry _ - as s) -> fprintf ppf "(%a)" print_symbol s - and print_rule ppf symbols = - (fprintf ppf "@["; - let _ = - List.fold_left - (fun sep symbol -> - (fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ ")) - (fun _ -> ()) symbols - in fprintf ppf "@]") - and print_level ppf pp_print_space rules = - (fprintf ppf "@[[ "; - let _ = - List.fold_left - (fun sep rule -> - (fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space ())) - (fun _ -> ()) rules - in fprintf ppf " ]@]") - - let levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - (fprintf ppf "%t@[" sep; - (match lev.lname with - | Some n -> fprintf ppf "%S@;<1 2>" n - | None -> ()); - (match lev.assoc with - | LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA"); - fprintf ppf "@]@;<1 2>"; - fprintf ppf "@[suffix:@ "; - print_tree ppf lev.lsuffix; - fprintf ppf "@]@ @[prefix:@ "; - print_tree ppf lev.lprefix; - fprintf ppf "@]"; - fun ppf -> fprintf ppf "@,| ")) - (fun _ -> ()) elev - in () - - let entry ppf e = - (fprintf ppf "@[%s: [ " e.ename; - (match e.edesc with - | Dlevels elev -> levels ppf elev - | Dparser _ -> fprintf ppf ""); - fprintf ppf " ]@]") - - end - - end - - module Failed = - struct - module Make (Structure : Structure.S) = - struct - module Tools = Tools.Make(Structure) - - module Search = Search.Make(Structure) - - module Print = Print.Make(Structure) - - open Structure - - open Format - - let rec name_of_symbol entry = - function - | Snterm e -> "[" ^ (e.ename ^ "]") - | Snterml (e, l) -> - "[" ^ (e.ename ^ (" level " ^ (l ^ "]"))) - | Sself | Snext -> "[" ^ (entry.ename ^ "]") - | Stoken ((_, descr)) -> descr - | Skeyword kwd -> "\"" ^ (kwd ^ "\"") - | _ -> "???" - - let rec name_of_symbol_failed entry = - function - | Slist0 s | Slist0sep (s, _) | Slist1 s | Slist1sep (s, _) - | Sopt s | Stry s -> name_of_symbol_failed entry s - | Stree t -> name_of_tree_failed entry t - | s -> name_of_symbol entry s - and name_of_tree_failed entry = - function - | Node { node = s; brother = bro; son = son } -> - let tokl = - (match s with - | Stoken _ | Skeyword _ -> - Tools.get_token_list entry [] s son - | _ -> None) - in - (match tokl with - | None -> - let txt = name_of_symbol_failed entry s in - let txt = - (match (s, son) with - | (Sopt _, Node _) -> - txt ^ - (" or " ^ - (name_of_tree_failed entry son)) - | _ -> txt) in - let txt = - (match bro with - | DeadEnd | LocAct (_, _) -> txt - | Node _ -> - txt ^ - (" or " ^ - (name_of_tree_failed entry bro))) - in txt - | Some ((tokl, _, _)) -> - List.fold_left - (fun s tok -> - (if s = "" then "" else s ^ " then ") ^ - (match tok with - | Stoken ((_, descr)) -> descr - | Skeyword kwd -> kwd - | _ -> assert false)) - "" tokl) - | DeadEnd | LocAct (_, _) -> "???" - - let magic _s x = Obj.magic x - - let tree_failed entry prev_symb_result prev_symb tree = - let txt = name_of_tree_failed entry tree in - let txt = - match prev_symb with - | Slist0 s -> - let txt1 = name_of_symbol_failed entry s - in txt1 ^ (" or " ^ (txt ^ " expected")) - | Slist1 s -> - let txt1 = name_of_symbol_failed entry s - in txt1 ^ (" or " ^ (txt ^ " expected")) - | Slist0sep (s, sep) -> - (match magic "tree_failed: 'a -> list 'b" - prev_symb_result - with - | [] -> - let txt1 = name_of_symbol_failed entry s - in txt1 ^ (" or " ^ (txt ^ " expected")) - | _ -> - let txt1 = name_of_symbol_failed entry sep - in txt1 ^ (" or " ^ (txt ^ " expected"))) - | Slist1sep (s, sep) -> - (match magic "tree_failed: 'a -> list 'b" - prev_symb_result - with - | [] -> - let txt1 = name_of_symbol_failed entry s - in txt1 ^ (" or " ^ (txt ^ " expected")) - | _ -> - let txt1 = name_of_symbol_failed entry sep - in txt1 ^ (" or " ^ (txt ^ " expected"))) - | Stry _ | Sopt _ | Stree _ -> txt ^ " expected" - | _ -> - txt ^ - (" expected after " ^ - (name_of_symbol entry prev_symb)) - in - (if !(entry.egram.error_verbose) - then - (let tree = - Search.tree_in_entry prev_symb tree entry.edesc in - let ppf = err_formatter - in - (fprintf ppf "@[@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf - "Parse error in entry [%s], rule:@;<0 2>" - entry.ename; - fprintf ppf "@["; - Print.print_level ppf pp_force_newline - (Print.flatten_tree tree); - fprintf ppf "@]@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "@]@.")) - else (); - txt ^ (" (in [" ^ (entry.ename ^ "])"))) - - let symb_failed entry prev_symb_result prev_symb symb = - let tree = - Node { node = symb; brother = DeadEnd; son = DeadEnd; } - in tree_failed entry prev_symb_result prev_symb tree - - let symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2 - - end - - end - - module Parser = - struct - module Make (Structure : Structure.S) = - struct - module Tools = Tools.Make(Structure) - - module Failed = Failed.Make(Structure) - - module Print = Print.Make(Structure) - - open Structure - - open Sig.Grammar - - module StreamOrig = Stream - - let njunk strm n = for i = 1 to n do Stream.junk strm done - - let loc_bp = Tools.get_cur_loc - - let loc_ep = Tools.get_prev_loc - - let drop_prev_loc = Tools.drop_prev_loc - - let add_loc bp parse_fun strm = - let x = parse_fun strm in - let ep = loc_ep strm in - let loc = - if (Loc.start_off bp) > (Loc.stop_off ep) - then Loc.join bp - else Loc.merge bp ep - in (x, loc) - - let stream_peek_nth strm n = - let rec loop i = - function - | x :: xs -> if i = 1 then Some x else loop (i - 1) xs - | [] -> None - in loop n (Stream.npeek n strm) - - module Stream = - struct - type 'a t = 'a StreamOrig.t - - exception Failure = StreamOrig.Failure - - exception Error = StreamOrig.Error - - let peek = StreamOrig.peek - - let junk = StreamOrig.junk - - let dup strm = - let peek_nth n = - let rec loop n = - function - | [] -> None - | [ x ] -> if n = 0 then Some x else None - | _ :: l -> loop (n - 1) l - in loop n (Stream.npeek (n + 1) strm) - in Stream.from peek_nth - - end - - let try_parser ps strm = - let strm' = Stream.dup strm in - let r = - try ps strm' - with - | Stream.Error _ | Loc.Exc_located (_, (Stream.Error _)) - -> raise Stream.Failure - | exc -> raise exc - in (njunk strm (StreamOrig.count strm'); r) - - let level_number entry lab = - let rec lookup levn = - function - | [] -> failwith ("unknown level " ^ lab) - | lev :: levs -> - if Tools.is_level_labelled lab lev - then levn - else lookup (succ levn) levs - in - match entry.edesc with - | Dlevels elev -> lookup 0 elev - | Dparser _ -> raise Not_found - - let strict_parsing = ref false - - let strict_parsing_warning = ref false - - let rec top_symb entry = - function - | Sself | Snext -> Snterm entry - | Snterml (e, _) -> Snterm e - | Slist1sep (s, sep) -> Slist1sep ((top_symb entry s), sep) - | _ -> raise Stream.Failure - - let top_tree entry = - function - | Node { node = s; brother = bro; son = son } -> - Node - { node = top_symb entry s; brother = bro; son = son; - } - | LocAct (_, _) | DeadEnd -> raise Stream.Failure - - let entry_of_symb entry = - function - | Sself | Snext -> entry - | Snterm e -> e - | Snterml (e, _) -> e - | _ -> raise Stream.Failure - - let continue entry loc a s son p1 (__strm : _ Stream.t) = - let a = (entry_of_symb entry s).econtinue 0 loc a __strm in - let act = - try p1 __strm - with - | Stream.Failure -> - raise - (Stream.Error (Failed.tree_failed entry a s son)) - in Action.mk (fun _ -> Action.getf act a) - - let skip_if_empty bp strm = - if (loc_bp strm) = bp - then Action.mk (fun _ -> raise Stream.Failure) - else raise Stream.Failure - - let do_recover parser_of_tree entry nlevn alevn loc a s son - (__strm : _ Stream.t) = - try - parser_of_tree entry nlevn alevn (top_tree entry son) - __strm - with - | Stream.Failure -> - (try skip_if_empty loc __strm - with - | Stream.Failure -> - continue entry loc a s son - (parser_of_tree entry nlevn alevn son) __strm) - - let recover parser_of_tree entry nlevn alevn loc a s son strm - = - if !strict_parsing - then - raise (Stream.Error (Failed.tree_failed entry a s son)) - else - (let _ = - if !strict_parsing_warning - then - (let msg = Failed.tree_failed entry a s son - in - (Format.eprintf - "Warning: trying to recover from syntax error"; - if entry.ename <> "" - then Format.eprintf " in [%s]" entry.ename - else (); - Format.eprintf "\n%s%a@." msg Loc.print loc)) - else () - in - do_recover parser_of_tree entry nlevn alevn loc a s - son strm) - - let rec parser_of_tree entry nlevn alevn = - function - | DeadEnd -> - (fun (__strm : _ Stream.t) -> raise Stream.Failure) - | LocAct (act, _) -> (fun (__strm : _ Stream.t) -> act) - | Node - { - node = Sself; - son = LocAct (act, _); - brother = DeadEnd - } -> - (fun (__strm : _ Stream.t) -> - let a = entry.estart alevn __strm - in Action.getf act a) - | Node { node = Sself; son = LocAct (act, _); brother = bro - } -> - let p2 = parser_of_tree entry nlevn alevn bro - in - (fun (__strm : _ Stream.t) -> - match try Some (entry.estart alevn __strm) - with | Stream.Failure -> None - with - | Some a -> Action.getf act a - | _ -> p2 __strm) - | Node { node = s; son = son; brother = DeadEnd } -> - let tokl = - (match s with - | Stoken _ | Skeyword _ -> - Tools.get_token_list entry [] s son - | _ -> None) - in - (match tokl with - | None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn s son - in - (fun strm -> - let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm in - let a = ps __strm in - let act = - try p1 bp a __strm - with - | Stream.Failure -> - raise (Stream.Error "") - in Action.getf act a) - | Some ((tokl, last_tok, son)) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = - parser_cont p1 entry nlevn alevn last_tok son - in parser_of_token_list p1 tokl) - | Node { node = s; son = son; brother = bro } -> - let tokl = - (match s with - | Stoken _ | Skeyword _ -> - Tools.get_token_list entry [] s son - | _ -> None) - in - (match tokl with - | None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = - parser_cont p1 entry nlevn alevn s son in - let p2 = parser_of_tree entry nlevn alevn bro - in - (fun strm -> - let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm - in - match try Some (ps __strm) - with | Stream.Failure -> None - with - | Some a -> - let act = - (try p1 bp a __strm - with - | Stream.Failure -> - raise (Stream.Error "")) - in Action.getf act a - | _ -> p2 __strm) - | Some ((tokl, last_tok, son)) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = - parser_cont p1 entry nlevn alevn last_tok son in - let p1 = parser_of_token_list p1 tokl in - let p2 = parser_of_tree entry nlevn alevn bro - in - (fun (__strm : _ Stream.t) -> - try p1 __strm - with | Stream.Failure -> p2 __strm)) - and - parser_cont p1 entry nlevn alevn s son loc a - (__strm : _ Stream.t) = - try p1 __strm - with - | Stream.Failure -> - (try - recover parser_of_tree entry nlevn alevn loc a s son - __strm - with - | Stream.Failure -> - raise - (Stream.Error (Failed.tree_failed entry a s son))) - and parser_of_token_list p1 tokl = - let rec loop n = - function - | Stoken ((tematch, _)) :: tokl -> - (match tokl with - | [] -> - let ps strm = - (match stream_peek_nth strm n with - | Some ((tok, _)) when tematch tok -> - (njunk strm n; Action.mk tok) - | _ -> raise Stream.Failure) - in - (fun strm -> - let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm in - let a = ps __strm in - let act = - try p1 bp a __strm - with - | Stream.Failure -> - raise (Stream.Error "") - in Action.getf act a) - | _ -> - let ps strm = - (match stream_peek_nth strm n with - | Some ((tok, _)) when tematch tok -> tok - | _ -> raise Stream.Failure) in - let p1 = loop (n + 1) tokl - in - (fun (__strm : _ Stream.t) -> - let tok = ps __strm in - let s = __strm in - let act = p1 s in Action.getf act tok)) - | Skeyword kwd :: tokl -> - (match tokl with - | [] -> - let ps strm = - (match stream_peek_nth strm n with - | Some ((tok, _)) when - Token.match_keyword kwd tok -> - (njunk strm n; Action.mk tok) - | _ -> raise Stream.Failure) - in - (fun strm -> - let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm in - let a = ps __strm in - let act = - try p1 bp a __strm - with - | Stream.Failure -> - raise (Stream.Error "") - in Action.getf act a) - | _ -> - let ps strm = - (match stream_peek_nth strm n with - | Some ((tok, _)) when - Token.match_keyword kwd tok -> tok - | _ -> raise Stream.Failure) in - let p1 = loop (n + 1) tokl - in - (fun (__strm : _ Stream.t) -> - let tok = ps __strm in - let s = __strm in - let act = p1 s in Action.getf act tok)) - | _ -> invalid_arg "parser_of_token_list" - in loop 1 tokl - and parser_of_symbol entry nlevn = - function - | Smeta (_, symbl, act) -> - let act = Obj.magic act entry symbl in - let pl = List.map (parser_of_symbol entry nlevn) symbl - in - Obj.magic - (List.fold_left (fun act p -> Obj.magic act p) act - pl) - | Slist0 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al (__strm : _ Stream.t) = - (match try Some (ps __strm) - with | Stream.Failure -> None - with - | Some a -> loop (a :: al) __strm - | _ -> al) - in - (fun (__strm : _ Stream.t) -> - let a = loop [] __strm in Action.mk (List.rev a)) - | Slist0sep (symb, sep) -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al (__strm : _ Stream.t) = - (match try Some (pt __strm) - with | Stream.Failure -> None - with - | Some v -> - let a = - (try ps __strm - with - | Stream.Failure -> - raise - (Stream.Error - (Failed.symb_failed entry v sep symb))) - in kont (a :: al) __strm - | _ -> al) - in - (fun (__strm : _ Stream.t) -> - match try Some (ps __strm) - with | Stream.Failure -> None - with - | Some a -> - let s = __strm - in Action.mk (List.rev (kont [ a ] s)) - | _ -> Action.mk []) - | Slist1 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al (__strm : _ Stream.t) = - (match try Some (ps __strm) - with | Stream.Failure -> None - with - | Some a -> loop (a :: al) __strm - | _ -> al) - in - (fun (__strm : _ Stream.t) -> - let a = ps __strm in - let s = __strm - in Action.mk (List.rev (loop [ a ] s))) - | Slist1sep (symb, sep) -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al (__strm : _ Stream.t) = - (match try Some (pt __strm) - with | Stream.Failure -> None - with - | Some v -> - let a = - (try ps __strm - with - | Stream.Failure -> - (try parse_top_symb entry symb __strm - with - | Stream.Failure -> - raise - (Stream.Error - (Failed.symb_failed entry v sep - symb)))) - in kont (a :: al) __strm - | _ -> al) - in - (fun (__strm : _ Stream.t) -> - let a = ps __strm in - let s = __strm - in Action.mk (List.rev (kont [ a ] s))) - | Sopt s -> - let ps = parser_of_symbol entry nlevn s - in - (fun (__strm : _ Stream.t) -> - match try Some (ps __strm) - with | Stream.Failure -> None - with - | Some a -> Action.mk (Some a) - | _ -> Action.mk None) - | Stry s -> - let ps = parser_of_symbol entry nlevn s - in try_parser ps - | Stree t -> - let pt = parser_of_tree entry 1 0 t - in - (fun strm -> - let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm in - let (act, loc) = add_loc bp pt __strm - in Action.getf act loc) - | Snterm e -> - (fun (__strm : _ Stream.t) -> e.estart 0 __strm) - | Snterml (e, l) -> - (fun (__strm : _ Stream.t) -> - e.estart (level_number e l) __strm) - | Sself -> - (fun (__strm : _ Stream.t) -> entry.estart 0 __strm) - | Snext -> - (fun (__strm : _ Stream.t) -> entry.estart nlevn __strm) - | Skeyword kwd -> - (fun (__strm : _ Stream.t) -> - match Stream.peek __strm with - | Some ((tok, _)) when Token.match_keyword kwd tok - -> (Stream.junk __strm; Action.mk tok) - | _ -> raise Stream.Failure) - | Stoken ((f, _)) -> - (fun (__strm : _ Stream.t) -> - match Stream.peek __strm with - | Some ((tok, _)) when f tok -> - (Stream.junk __strm; Action.mk tok) - | _ -> raise Stream.Failure) - and parse_top_symb entry symb strm = - parser_of_symbol entry 0 (top_symb entry symb) strm - - let rec start_parser_of_levels entry clevn = - function - | [] -> - (fun _ (__strm : _ Stream.t) -> raise Stream.Failure) - | lev :: levs -> - let p1 = start_parser_of_levels entry (succ clevn) levs - in - (match lev.lprefix with - | DeadEnd -> p1 - | tree -> - let alevn = - (match lev.assoc with - | LeftA | NonA -> succ clevn - | RightA -> clevn) in - let p2 = - parser_of_tree entry (succ clevn) alevn tree - in - (match levs with - | [] -> - (fun levn strm -> - let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm in - let (act, loc) = - add_loc bp p2 __strm in - let strm = __strm in - let a = Action.getf act loc - in entry.econtinue levn loc a strm) - | _ -> - (fun levn strm -> - if levn > clevn - then p1 levn strm - else - (let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm - in - match try - Some - (add_loc bp p2 __strm) - with - | Stream.Failure -> None - with - | Some ((act, loc)) -> - let a = Action.getf act loc - in - entry.econtinue levn loc a - strm - | _ -> p1 levn __strm)))) - - let start_parser_of_entry entry = - match entry.edesc with - | Dlevels [] -> Tools.empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> (fun _ -> p) - - let rec continue_parser_of_levels entry clevn = - function - | [] -> - (fun _ _ _ (__strm : _ Stream.t) -> - raise Stream.Failure) - | lev :: levs -> - let p1 = - continue_parser_of_levels entry (succ clevn) levs - in - (match lev.lsuffix with - | DeadEnd -> p1 - | tree -> - let alevn = - (match lev.assoc with - | LeftA | NonA -> succ clevn - | RightA -> clevn) in - let p2 = - parser_of_tree entry (succ clevn) alevn tree - in - (fun levn bp a strm -> - if levn > clevn - then p1 levn bp a strm - else - (let (__strm : _ Stream.t) = strm - in - try p1 levn bp a __strm - with - | Stream.Failure -> - let (act, loc) = - add_loc bp p2 __strm in - let a = Action.getf2 act a loc - in entry.econtinue levn loc a strm))) - - let continue_parser_of_entry entry = - match entry.edesc with - | Dlevels elev -> - let p = continue_parser_of_levels entry 0 elev - in - (fun levn bp a (__strm : _ Stream.t) -> - try p levn bp a __strm with | Stream.Failure -> a) - | Dparser _ -> - (fun _ _ _ (__strm : _ Stream.t) -> - raise Stream.Failure) - - end - - end - - module Insert = - struct - module Make (Structure : Structure.S) = - struct - module Tools = Tools.Make(Structure) - - module Parser = Parser.Make(Structure) - - open Structure - - open Format - - open Sig.Grammar - - let is_before s1 s2 = - match (s1, s2) with - | ((Skeyword _ | Stoken _), (Skeyword _ | Stoken _)) -> - false - | ((Skeyword _ | Stoken _), _) -> true - | _ -> false - - let rec derive_eps = - function - | Slist0 _ | Slist0sep (_, _) | Sopt _ -> true - | Stry s -> derive_eps s - | Stree t -> tree_derive_eps t - | Slist1 _ | Slist1sep (_, _) | Stoken _ | Skeyword _ -> - false - | Smeta (_, _, _) | Snterm _ | Snterml (_, _) | Snext | - Sself -> false - and tree_derive_eps = - function - | LocAct (_, _) -> true - | Node { node = s; brother = bro; son = son } -> - ((derive_eps s) && (tree_derive_eps son)) || - (tree_derive_eps bro) - | DeadEnd -> false - - let empty_lev lname assoc = - let assoc = match assoc with | Some a -> a | None -> LeftA - in - { - assoc = assoc; - lname = lname; - lsuffix = DeadEnd; - lprefix = DeadEnd; - } - - let change_lev entry lev n lname assoc = - let a = - match assoc with - | None -> lev.assoc - | Some a -> - (if - (a <> lev.assoc) && !(entry.egram.warning_verbose) - then - (eprintf - " Changing associativity of level \"%s\"\n" - n; - flush Pervasives.stderr) - else (); - a) - in - ((match lname with - | Some n -> - if - (lname <> lev.lname) && - !(entry.egram.warning_verbose) - then - (eprintf " Level label \"%s\" ignored\n" n; - flush Pervasives.stderr) - else () - | None -> ()); - { - assoc = a; - lname = lev.lname; - lsuffix = lev.lsuffix; - lprefix = lev.lprefix; - }) - - let change_to_self entry = - function | Snterm e when e == entry -> Sself | x -> x - - let get_level entry position levs = - match position with - | Some First -> ([], empty_lev, levs) - | Some Last -> (levs, empty_lev, []) - | Some (Level n) -> - let rec get = - (function - | [] -> - (eprintf - "No level labelled \"%s\" in entry \"%s\"\n" - n entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend") - | lev :: levs -> - if Tools.is_level_labelled n lev - then ([], (change_lev entry lev n), levs) - else - (let (levs1, rlev, levs2) = get levs - in ((lev :: levs1), rlev, levs2))) - in get levs - | Some (Before n) -> - let rec get = - (function - | [] -> - (eprintf - "No level labelled \"%s\" in entry \"%s\"\n" - n entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend") - | lev :: levs -> - if Tools.is_level_labelled n lev - then ([], empty_lev, (lev :: levs)) - else - (let (levs1, rlev, levs2) = get levs - in ((lev :: levs1), rlev, levs2))) - in get levs - | Some (After n) -> - let rec get = - (function - | [] -> - (eprintf - "No level labelled \"%s\" in entry \"%s\"\n" - n entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend") - | lev :: levs -> - if Tools.is_level_labelled n lev - then ([ lev ], empty_lev, levs) - else - (let (levs1, rlev, levs2) = get levs - in ((lev :: levs1), rlev, levs2))) - in get levs - | None -> - (match levs with - | lev :: levs -> - ([], (change_lev entry lev ""), levs) - | [] -> ([], empty_lev, [])) - - let rec check_gram entry = - function - | Snterm e -> - if ( != ) e.egram entry.egram - then - (eprintf - "\ - Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush Pervasives.stderr; - failwith "Grammar.extend error") - else () - | Snterml (e, _) -> - if ( != ) e.egram entry.egram - then - (eprintf - "\ - Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush Pervasives.stderr; - failwith "Grammar.extend error") - else () - | Smeta (_, sl, _) -> List.iter (check_gram entry) sl - | Slist0sep (s, t) -> - (check_gram entry t; check_gram entry s) - | Slist1sep (s, t) -> - (check_gram entry t; check_gram entry s) - | Slist0 s | Slist1 s | Sopt s | Stry s -> - check_gram entry s - | Stree t -> tree_check_gram entry t - | Snext | Sself | Stoken _ | Skeyword _ -> () - and tree_check_gram entry = - function - | Node { node = n; brother = bro; son = son } -> - (check_gram entry n; - tree_check_gram entry bro; - tree_check_gram entry son) - | LocAct (_, _) | DeadEnd -> () - - let get_initial = - function - | Sself :: symbols -> (true, symbols) - | symbols -> (false, symbols) - - let insert_tokens gram symbols = - let rec insert = - function - | Smeta (_, sl, _) -> List.iter insert sl - | Slist0 s | Slist1 s | Sopt s | Stry s -> insert s - | Slist0sep (s, t) -> (insert s; insert t) - | Slist1sep (s, t) -> (insert s; insert t) - | Stree t -> tinsert t - | Skeyword kwd -> using gram kwd - | Snterm _ | Snterml (_, _) | Snext | Sself | Stoken _ -> - () - and tinsert = - function - | Node { node = s; brother = bro; son = son } -> - (insert s; tinsert bro; tinsert son) - | LocAct (_, _) | DeadEnd -> () - in List.iter insert symbols - - let insert_tree entry gsymbols action tree = - let rec insert symbols tree = - match symbols with - | s :: sl -> insert_in_tree s sl tree - | [] -> - (match tree with - | Node { node = s; son = son; brother = bro } -> - Node - { - node = s; - son = son; - brother = insert [] bro; - } - | LocAct (old_action, action_list) -> - let () = - if !(entry.egram.warning_verbose) - then - eprintf - " Grammar extension: in [%s] some rule has been masked@." - entry.ename - else () - in LocAct (action, (old_action :: action_list)) - | DeadEnd -> LocAct (action, [])) - and insert_in_tree s sl tree = - match try_insert s sl tree with - | Some t -> t - | None -> - Node - { - node = s; - son = insert sl DeadEnd; - brother = tree; - } - and try_insert s sl tree = - match tree with - | Node { node = s1; son = son; brother = bro } -> - if Tools.eq_symbol s s1 - then - (let t = - Node - { - node = s1; - son = insert sl son; - brother = bro; - } - in Some t) - else - if - (is_before s1 s) || - ((derive_eps s) && (not (derive_eps s1))) - then - (let bro = - match try_insert s sl bro with - | Some bro -> bro - | None -> - Node - { - node = s; - son = insert sl DeadEnd; - brother = bro; - } in - let t = - Node { node = s1; son = son; brother = bro; } - in Some t) - else - (match try_insert s sl bro with - | Some bro -> - let t = - Node - { node = s1; son = son; brother = bro; } - in Some t - | None -> None) - | LocAct (_, _) | DeadEnd -> None - in insert gsymbols tree - - let insert_level entry e1 symbols action slev = - match e1 with - | true -> - { - assoc = slev.assoc; - lname = slev.lname; - lsuffix = - insert_tree entry symbols action slev.lsuffix; - lprefix = slev.lprefix; - } - | false -> - { - assoc = slev.assoc; - lname = slev.lname; - lsuffix = slev.lsuffix; - lprefix = - insert_tree entry symbols action slev.lprefix; - } - - let levels_of_rules entry position rules = - let elev = - match entry.edesc with - | Dlevels elev -> elev - | Dparser _ -> - (eprintf "Error: entry not extensible: \"%s\"\n" - entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend") - in - if rules = [] - then elev - else - (let (levs1, make_lev, levs2) = - get_level entry position elev in - let (levs, _) = - List.fold_left - (fun (levs, make_lev) (lname, assoc, level) -> - let lev = make_lev lname assoc in - let lev = - List.fold_left - (fun lev (symbols, action) -> - let symbols = - List.map (change_to_self entry) - symbols - in - (List.iter (check_gram entry) symbols; - let (e1, symbols) = - get_initial symbols - in - (insert_tokens entry.egram symbols; - insert_level entry e1 symbols - action lev))) - lev level - in ((lev :: levs), empty_lev)) - ([], make_lev) rules - in levs1 @ ((List.rev levs) @ levs2)) - - let extend entry (position, rules) = - let elev = levels_of_rules entry position rules - in - (entry.edesc <- Dlevels elev; - entry.estart <- - (fun lev strm -> - let f = Parser.start_parser_of_entry entry - in (entry.estart <- f; f lev strm)); - entry.econtinue <- - fun lev bp a strm -> - let f = Parser.continue_parser_of_entry entry - in (entry.econtinue <- f; f lev bp a strm)) - - end - - end - - module Delete = - struct - exception Rule_not_found of (string * string) - - let _ = - let () = - Printexc.register_printer - (function - | Rule_not_found ((symbols, entry)) -> - let msg = - Printf.sprintf - "rule %S cannot be found in entry\n%s" symbols - entry - in Some msg - | _ -> None) - in () - - module Make (Structure : Structure.S) = - struct - module Tools = Tools.Make(Structure) - - module Parser = Parser.Make(Structure) - - module Print = Print.Make(Structure) - - open Structure - - let raise_rule_not_found entry symbols = - let to_string f x = - let buff = Buffer.create 128 in - let ppf = Format.formatter_of_buffer buff - in - (f ppf x; - Format.pp_print_flush ppf (); - Buffer.contents buff) in - let entry = to_string Print.entry entry in - let symbols = to_string Print.print_rule symbols - in raise (Rule_not_found ((symbols, entry))) - - let delete_rule_in_tree entry = - let rec delete_in_tree symbols tree = - match (symbols, tree) with - | (s :: sl, Node n) -> - if Tools.logically_eq_symbols entry s n.node - then delete_son sl n - else - (match delete_in_tree symbols n.brother with - | Some ((dsl, t)) -> - Some - ((dsl, - (Node - { - node = n.node; - son = n.son; - brother = t; - }))) - | None -> None) - | (_ :: _, _) -> None - | ([], Node n) -> - (match delete_in_tree [] n.brother with - | Some ((dsl, t)) -> - Some - ((dsl, - (Node - { - node = n.node; - son = n.son; - brother = t; - }))) - | None -> None) - | ([], DeadEnd) -> None - | ([], LocAct (_, [])) -> Some (((Some []), DeadEnd)) - | ([], LocAct (_, (action :: list))) -> - Some ((None, (LocAct (action, list)))) - and delete_son sl n = - match delete_in_tree sl n.son with - | Some ((Some dsl, DeadEnd)) -> - Some (((Some (n.node :: dsl)), (n.brother))) - | Some ((Some dsl, t)) -> - let t = - Node - { node = n.node; son = t; brother = n.brother; } - in Some (((Some (n.node :: dsl)), t)) - | Some ((None, t)) -> - let t = - Node - { node = n.node; son = t; brother = n.brother; } - in Some ((None, t)) - | None -> None - in delete_in_tree - - let rec decr_keyw_use gram = - function - | Skeyword kwd -> removing gram kwd - | Smeta (_, sl, _) -> List.iter (decr_keyw_use gram) sl - | Slist0 s | Slist1 s | Sopt s | Stry s -> - decr_keyw_use gram s - | Slist0sep (s1, s2) -> - (decr_keyw_use gram s1; decr_keyw_use gram s2) - | Slist1sep (s1, s2) -> - (decr_keyw_use gram s1; decr_keyw_use gram s2) - | Stree t -> decr_keyw_use_in_tree gram t - | Sself | Snext | Snterm _ | Snterml (_, _) | Stoken _ -> - () - and decr_keyw_use_in_tree gram = - function - | DeadEnd | LocAct (_, _) -> () - | Node n -> - (decr_keyw_use gram n.node; - decr_keyw_use_in_tree gram n.son; - decr_keyw_use_in_tree gram n.brother) - - let rec delete_rule_in_suffix entry symbols = - function - | lev :: levs -> - (match delete_rule_in_tree entry symbols lev.lsuffix - with - | Some ((dsl, t)) -> - ((match dsl with - | Some dsl -> - List.iter (decr_keyw_use entry.egram) dsl - | None -> ()); - (match t with - | DeadEnd when lev.lprefix == DeadEnd -> levs - | _ -> - let lev = - { - assoc = lev.assoc; - lname = lev.lname; - lsuffix = t; - lprefix = lev.lprefix; - } - in lev :: levs)) - | None -> - let levs = - delete_rule_in_suffix entry symbols levs - in lev :: levs) - | [] -> raise_rule_not_found entry symbols - - let rec delete_rule_in_prefix entry symbols = - function - | lev :: levs -> - (match delete_rule_in_tree entry symbols lev.lprefix - with - | Some ((dsl, t)) -> - ((match dsl with - | Some dsl -> - List.iter (decr_keyw_use entry.egram) dsl - | None -> ()); - (match t with - | DeadEnd when lev.lsuffix == DeadEnd -> levs - | _ -> - let lev = - { - assoc = lev.assoc; - lname = lev.lname; - lsuffix = lev.lsuffix; - lprefix = t; - } - in lev :: levs)) - | None -> - let levs = - delete_rule_in_prefix entry symbols levs - in lev :: levs) - | [] -> raise_rule_not_found entry symbols - - let rec delete_rule_in_level_list entry symbols levs = - match symbols with - | Sself :: symbols -> - delete_rule_in_suffix entry symbols levs - | Snterm e :: symbols when e == entry -> - delete_rule_in_suffix entry symbols levs - | _ -> delete_rule_in_prefix entry symbols levs - - let delete_rule entry sl = - match entry.edesc with - | Dlevels levs -> - let levs = delete_rule_in_level_list entry sl levs - in - (entry.edesc <- Dlevels levs; - entry.estart <- - (fun lev strm -> - let f = Parser.start_parser_of_entry entry - in (entry.estart <- f; f lev strm)); - entry.econtinue <- - (fun lev bp a strm -> - let f = Parser.continue_parser_of_entry entry - in (entry.econtinue <- f; f lev bp a strm))) - | Dparser _ -> () - - end - - end - - module Fold : - sig - module Make (Structure : Structure.S) : - sig - open Structure - - val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold - - val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold - - val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) foldsep - - end - - end = - struct - module Make (Structure : Structure.S) = - struct - open Structure - - open Format - - module Parse = Parser.Make(Structure) - - module Fail = Failed.Make(Structure) - - open Sig.Grammar - - module Stream = - struct - type 'a t = 'a Stream.t - - exception Failure = Stream.Failure - - exception Error = Stream.Error - - end - - let sfold0 f e _entry _symbl psymb = - let rec fold accu (__strm : _ Stream.t) = - match try Some (psymb __strm) - with | Stream.Failure -> None - with - | Some a -> fold (f a accu) __strm - | _ -> accu - in fun (__strm : _ Stream.t) -> fold e __strm - - let sfold1 f e _entry _symbl psymb = - let rec fold accu (__strm : _ Stream.t) = - match try Some (psymb __strm) - with | Stream.Failure -> None - with - | Some a -> fold (f a accu) __strm - | _ -> accu - in - fun (__strm : _ Stream.t) -> - let a = psymb __strm - in - try fold (f a e) __strm - with | Stream.Failure -> raise (Stream.Error "") - - let sfold0sep f e entry symbl psymb psep = - let failed = - function - | [ symb; sep ] -> Fail.symb_failed_txt entry sep symb - | _ -> "failed" in - let rec kont accu (__strm : _ Stream.t) = - match try Some (psep __strm) - with | Stream.Failure -> None - with - | Some () -> - let a = - (try psymb __strm - with - | Stream.Failure -> - raise (Stream.Error (failed symbl))) - in kont (f a accu) __strm - | _ -> accu - in - fun (__strm : _ Stream.t) -> - match try Some (psymb __strm) - with | Stream.Failure -> None - with - | Some a -> kont (f a e) __strm - | _ -> e - - let sfold1sep f e entry symbl psymb psep = - let failed = - function - | [ symb; sep ] -> Fail.symb_failed_txt entry sep symb - | _ -> "failed" in - let parse_top = - function - | [ symb; _ ] -> Parse.parse_top_symb entry symb - | _ -> raise Stream.Failure in - let rec kont accu (__strm : _ Stream.t) = - match try Some (psep __strm) - with | Stream.Failure -> None - with - | Some () -> - let a = - (try - try psymb __strm - with - | Stream.Failure -> - let a = - (try parse_top symbl __strm - with - | Stream.Failure -> - raise (Stream.Error (failed symbl))) - in Obj.magic a - with | Stream.Failure -> raise (Stream.Error "")) - in kont (f a accu) __strm - | _ -> accu - in - fun (__strm : _ Stream.t) -> - let a = psymb __strm in kont (f a e) __strm - - end - - end - - module Entry = - struct - module Make (Structure : Structure.S) = - struct - module Dump = Print.MakeDump(Structure) - - module Print = Print.Make(Structure) - - module Tools = Tools.Make(Structure) - - open Format - - open Structure - - open Tools - - type 'a t = internal_entry - - let name e = e.ename - - let print ppf e = fprintf ppf "%a@\n" Print.entry e - - let dump ppf e = fprintf ppf "%a@\n" Dump.entry e - - let mk g n = - { - egram = g; - ename = n; - estart = empty_entry n; - econtinue = - (fun _ _ _ (__strm : _ Stream.t) -> - raise Stream.Failure); - edesc = Dlevels []; - } - - let action_parse entry ts : Action.t = - try entry.estart 0 ts - with - | Stream.Failure -> - Loc.raise (get_prev_loc ts) - (Stream.Error ("illegal begin of " ^ entry.ename)) - | (Loc.Exc_located (_, _) as exc) -> raise exc - | exc -> Loc.raise (get_prev_loc ts) exc - - let lex entry loc cs = entry.egram.glexer loc cs - - let lex_string entry loc str = - lex entry loc (Stream.of_string str) - - let filter entry ts = - keep_prev_loc - (Token.Filter.filter (get_filter entry.egram) ts) - - let parse_tokens_after_filter entry ts = - Action.get (action_parse entry ts) - - let parse_tokens_before_filter entry ts = - parse_tokens_after_filter entry (filter entry ts) - - let parse entry loc cs = - parse_tokens_before_filter entry (lex entry loc cs) - - let parse_string entry loc str = - parse_tokens_before_filter entry (lex_string entry loc str) - - let of_parser g n - (p : (Token.t * token_info) Stream.t -> 'a) : 'a t = - let f ts = Action.mk (p ts) - in - { - egram = g; - ename = n; - estart = (fun _ -> f); - econtinue = - (fun _ _ _ (__strm : _ Stream.t) -> - raise Stream.Failure); - edesc = Dparser f; - } - - let setup_parser e - (p : (Token.t * token_info) Stream.t -> 'a) - = - let f ts = Action.mk (p ts) - in - (e.estart <- (fun _ -> f); - e.econtinue <- - (fun _ _ _ (__strm : _ Stream.t) -> - raise Stream.Failure); - e.edesc <- Dparser f) - - let clear e = - (e.estart <- - (fun _ (__strm : _ Stream.t) -> raise Stream.Failure); - e.econtinue <- - (fun _ _ _ (__strm : _ Stream.t) -> raise Stream.Failure); - e.edesc <- Dlevels []) - - let obj x = x - - end - - end - - module Static = - struct - let uncurry f (x, y) = f x y - - let flip f x y = f y x - - module Make (Lexer : Sig.Lexer) : - Sig.Grammar.Static with module Loc = Lexer.Loc - and module Token = Lexer.Token = - struct - module Structure = Structure.Make(Lexer) - - module Delete = Delete.Make(Structure) - - module Insert = Insert.Make(Structure) - - module Fold = Fold.Make(Structure) - - module Tools = Tools.Make(Structure) - - include Structure - - let gram = - let gkeywords = Hashtbl.create 301 - in - { - gkeywords = gkeywords; - gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); - glexer = Lexer.mk (); - warning_verbose = ref true; - error_verbose = Camlp4_config.verbose; - } - - module Entry = - struct - module E = Entry.Make(Structure) - - type 'a t = 'a E.t - - let mk = E.mk gram - - let of_parser name strm = E.of_parser gram name strm - - let setup_parser = E.setup_parser - - let name = E.name - - let print = E.print - - let clear = E.clear - - let dump = E.dump - - let obj x = x - - end - - let get_filter () = gram.gfilter - - let lex loc cs = gram.glexer loc cs - - let lex_string loc str = lex loc (Stream.of_string str) - - let filter ts = - Tools.keep_prev_loc (Token.Filter.filter gram.gfilter ts) - - let parse_tokens_after_filter entry ts = - Entry.E.parse_tokens_after_filter entry ts - - let parse_tokens_before_filter entry ts = - parse_tokens_after_filter entry (filter ts) - - let parse entry loc cs = - parse_tokens_before_filter entry (lex loc cs) - - let parse_string entry loc str = - parse_tokens_before_filter entry (lex_string loc str) - - let delete_rule = Delete.delete_rule - - let srules e rl = - Stree - (List.fold_left (flip (uncurry (Insert.insert_tree e))) - DeadEnd rl) - - let sfold0 = Fold.sfold0 - - let sfold1 = Fold.sfold1 - - let sfold0sep = Fold.sfold0sep - - let extend = Insert.extend - - end - - end - - module Dynamic = - struct - module Make (Lexer : Sig.Lexer) : - Sig.Grammar.Dynamic with module Loc = Lexer.Loc - and module Token = Lexer.Token = - struct - module Structure = Structure.Make(Lexer) - - module Delete = Delete.Make(Structure) - - module Insert = Insert.Make(Structure) - - module Entry = Entry.Make(Structure) - - module Fold = Fold.Make(Structure) - - module Tools = Tools.Make(Structure) - - include Structure - - let mk () = - let gkeywords = Hashtbl.create 301 - in - { - gkeywords = gkeywords; - gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); - glexer = Lexer.mk (); - warning_verbose = ref true; - error_verbose = Camlp4_config.verbose; - } - - let get_filter g = g.gfilter - - let lex g loc cs = g.glexer loc cs - - let lex_string g loc str = lex g loc (Stream.of_string str) - - let filter g ts = - Tools.keep_prev_loc (Token.Filter.filter g.gfilter ts) - - let parse_tokens_after_filter entry ts = - Entry.parse_tokens_after_filter entry ts - - let parse_tokens_before_filter entry ts = - parse_tokens_after_filter entry (filter entry.egram ts) - - let parse entry loc cs = - parse_tokens_before_filter entry (lex entry.egram loc cs) - - let parse_string entry loc str = - parse_tokens_before_filter entry - (lex_string entry.egram loc str) - - let delete_rule = Delete.delete_rule - - let srules e rl = - let t = - List.fold_left - (fun tree (symbols, action) -> - Insert.insert_tree e symbols action tree) - DeadEnd rl - in Stree t - - let sfold0 = Fold.sfold0 - - let sfold1 = Fold.sfold1 - - let sfold0sep = Fold.sfold0sep - - let extend = Insert.extend - - end - - end - - end - - end - -module Printers = - struct - module DumpCamlp4Ast : - sig - module Id : Sig.Id - - module Make (Syntax : Sig.Syntax) : Sig.Printer(Syntax.Ast).S - - end = - struct - module Id = - struct - let name = "Camlp4Printers.DumpCamlp4Ast" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Syntax) : Sig.Printer(Syntax.Ast).S = - struct - include Syntax - - let with_open_out_file x f = - match x with - | Some file -> - let oc = open_out_bin file - in (f oc; flush oc; close_out oc) - | None -> - (set_binary_mode_out stdout true; f stdout; flush stdout) - - let dump_ast magic ast oc = - (output_string oc magic; output_value oc ast) - - let print_interf ?input_file:(_) ?output_file ast = - with_open_out_file output_file - (dump_ast Camlp4_config.camlp4_ast_intf_magic_number ast) - - let print_implem ?input_file:(_) ?output_file ast = - with_open_out_file output_file - (dump_ast Camlp4_config.camlp4_ast_impl_magic_number ast) - - end - - end - - module DumpOCamlAst : - sig - module Id : Sig.Id - - module Make (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax.Ast).S - - end = - struct - module Id : Sig.Id = - struct - let name = "Camlp4Printers.DumpOCamlAst" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax.Ast).S = - struct - include Syntax - - module Ast2pt = Struct.Camlp4Ast2OCamlAst.Make(Ast) - - let with_open_out_file x f = - match x with - | Some file -> - let oc = open_out_bin file - in (f oc; flush oc; close_out oc) - | None -> - (set_binary_mode_out stdout true; f stdout; flush stdout) - - let dump_pt magic fname pt oc = - (output_string oc magic; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt) - - let print_interf ?(input_file = "-") ?output_file ast = - let pt = Ast2pt.sig_item ast - in - with_open_out_file output_file - (dump_pt Camlp4_config.ocaml_ast_intf_magic_number - input_file pt) - - let print_implem ?(input_file = "-") ?output_file ast = - let pt = Ast2pt.str_item ast - in - with_open_out_file output_file - (dump_pt Camlp4_config.ocaml_ast_impl_magic_number - input_file pt) - - end - - end - - module Null : - sig - module Id : Sig.Id - - module Make (Syntax : Sig.Syntax) : Sig.Printer(Syntax.Ast).S - - end = - struct - module Id = - struct - let name = "Camlp4.Printers.Null" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Syntax) = - struct - include Syntax - - let print_interf ?input_file:(_) ?output_file:(_) _ = () - - let print_implem ?input_file:(_) ?output_file:(_) _ = () - - end - - end - - module OCaml : - sig - module Id : Sig.Id - - module Make (Syntax : Sig.Camlp4Syntax) : - sig - open Format - - include Sig.Camlp4Syntax with module Loc = Syntax.Loc - and module Token = Syntax.Token and module Ast = Syntax.Ast - and module Gram = Syntax.Gram - - type sep = (unit, formatter, unit) format - - type fun_binding = [ | `patt of Ast.patt | `newtype of string ] - - val list' : - (formatter -> 'a -> unit) -> - ('b, formatter, unit) format -> - (unit, formatter, unit) format -> - formatter -> 'a list -> unit - - val list : - (formatter -> 'a -> unit) -> - ('b, formatter, unit) format -> formatter -> 'a list -> unit - - val lex_string : string -> Token.t - - val is_infix : string -> bool - - val is_keyword : string -> bool - - val ocaml_char : string -> string - - val get_expr_args : - Ast.expr -> Ast.expr list -> (Ast.expr * (Ast.expr list)) - - val get_patt_args : - Ast.patt -> Ast.patt list -> (Ast.patt * (Ast.patt list)) - - val get_ctyp_args : - Ast.ctyp -> Ast.ctyp list -> (Ast.ctyp * (Ast.ctyp list)) - - val expr_fun_args : Ast.expr -> ((fun_binding list) * Ast.expr) - - class printer : - ?curry_constr: bool -> - ?comments: bool -> - unit -> - object ('a) - method interf : formatter -> Ast.sig_item -> unit - method implem : formatter -> Ast.str_item -> unit - method sig_item : formatter -> Ast.sig_item -> unit - method str_item : formatter -> Ast.str_item -> unit - val pipe : bool - val semi : bool - val semisep : sep - val no_semisep : sep - method value_val : string - method value_let : string - method andsep : sep - method anti : formatter -> string -> unit - method class_declaration : - formatter -> Ast.class_expr -> unit - method class_expr : formatter -> Ast.class_expr -> unit - method class_sig_item : - formatter -> Ast.class_sig_item -> unit - method class_str_item : - formatter -> Ast.class_str_item -> unit - method class_type : formatter -> Ast.class_type -> unit - method constrain : - formatter -> (Ast.ctyp * Ast.ctyp) -> unit - method ctyp : formatter -> Ast.ctyp -> unit - method ctyp1 : formatter -> Ast.ctyp -> unit - method constructor_type : formatter -> Ast.ctyp -> unit - method dot_expr : formatter -> Ast.expr -> unit - method apply_expr : formatter -> Ast.expr -> unit - method expr : formatter -> Ast.expr -> unit - method expr_list : formatter -> Ast.expr list -> unit - method expr_list_cons : - bool -> formatter -> Ast.expr -> unit - method fun_binding : formatter -> fun_binding -> unit - method functor_arg : - formatter -> (string * Ast.module_type) -> unit - method functor_args : - formatter -> (string * Ast.module_type) list -> unit - method ident : formatter -> Ast.ident -> unit - method numeric : formatter -> string -> string -> unit - method binding : formatter -> Ast.binding -> unit - method record_binding : - formatter -> Ast.rec_binding -> unit - method match_case : formatter -> Ast.match_case -> unit - method match_case_aux : - formatter -> Ast.match_case -> unit - method mk_expr_list : - Ast.expr -> ((Ast.expr list) * (Ast.expr option)) - method mk_patt_list : - Ast.patt -> ((Ast.patt list) * (Ast.patt option)) - method simple_module_expr : - formatter -> Ast.module_expr -> unit - method module_expr : - formatter -> Ast.module_expr -> unit - method module_expr_get_functor_args : - (string * Ast.module_type) list -> - Ast.module_expr -> - (((string * Ast.module_type) list) * Ast. - module_expr * (Ast.module_type option)) - method module_rec_binding : - formatter -> Ast.module_binding -> unit - method module_type : - formatter -> Ast.module_type -> unit - method override_flag : - formatter -> Ast.override_flag -> unit - method mutable_flag : - formatter -> Ast.mutable_flag -> unit - method direction_flag : - formatter -> Ast.direction_flag -> unit - method rec_flag : formatter -> Ast.rec_flag -> unit - method node : formatter -> 'b -> ('b -> Loc.t) -> unit - method patt : formatter -> Ast.patt -> unit - method patt1 : formatter -> Ast.patt -> unit - method patt2 : formatter -> Ast.patt -> unit - method patt3 : formatter -> Ast.patt -> unit - method patt4 : formatter -> Ast.patt -> unit - method patt5 : formatter -> Ast.patt -> unit - method patt_tycon : formatter -> Ast.patt -> unit - method patt_expr_fun_args : - formatter -> (fun_binding * Ast.expr) -> unit - method patt_class_expr_fun_args : - formatter -> (Ast.patt * Ast.class_expr) -> unit - method print_comments_before : - Loc.t -> formatter -> unit - method private_flag : - formatter -> Ast.private_flag -> unit - method virtual_flag : - formatter -> Ast.virtual_flag -> unit - method quoted_string : formatter -> string -> unit - method raise_match_failure : formatter -> Loc.t -> unit - method reset : 'a - method reset_semi : 'a - method semisep : sep - method set_comments : bool -> 'a - method set_curry_constr : bool -> 'a - method set_loc_and_comments : 'a - method set_semisep : sep -> 'a - method simple_ctyp : formatter -> Ast.ctyp -> unit - method simple_expr : formatter -> Ast.expr -> unit - method simple_patt : formatter -> Ast.patt -> unit - method seq : formatter -> Ast.expr -> unit - method string : formatter -> string -> unit - method sum_type : formatter -> Ast.ctyp -> unit - method type_params : formatter -> Ast.ctyp list -> unit - method class_params : formatter -> Ast.ctyp -> unit - method under_pipe : 'a - method under_semi : 'a - method var : formatter -> string -> unit - method with_constraint : - formatter -> Ast.with_constr -> unit - end - - val with_outfile : - string option -> (formatter -> 'a -> unit) -> 'a -> unit - - val print : - string option -> - (printer -> formatter -> 'a -> unit) -> 'a -> unit - - end - - module MakeMore (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax. - Ast).S - - end = - struct - open Format - - module Id = - struct - let name = "Camlp4.Printers.OCaml" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - include Syntax - - type sep = (unit, formatter, unit) format - - type fun_binding = [ | `patt of Ast.patt | `newtype of string ] - - let pp = fprintf - - let cut f = fprintf f "@ " - - let list' elt sep sep' f = - let rec loop = - function - | [] -> () - | x :: xs -> (pp f sep; elt f x; pp f sep'; loop xs) - in - function - | [] -> () - | [ x ] -> (elt f x; pp f sep') - | x :: xs -> (elt f x; pp f sep'; loop xs) - - let list elt sep f = - let rec loop = - function | [] -> () | x :: xs -> (pp f sep; elt f x; loop xs) - in - function - | [] -> () - | [ x ] -> elt f x - | x :: xs -> (elt f x; loop xs) - - let rec list_of_meta_list = - function - | Ast.LNil -> [] - | Ast.LCons (x, xs) -> x :: (list_of_meta_list xs) - | Ast.LAnt _ -> assert false - - let meta_list elt sep f mxs = - let xs = list_of_meta_list mxs in list elt sep f xs - - module CommentFilter = Struct.CommentFilter.Make(Token) - - let comment_filter = CommentFilter.mk () - - let _ = CommentFilter.define (Gram.get_filter ()) comment_filter - - module StringSet = Set.Make(String) - - let infix_lidents = - [ "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or" ] - - let is_infix = - let first_chars = - [ '='; '<'; '>'; '|'; '&'; '$'; '@'; '^'; '+'; '-'; '*'; '/'; - '%'; '\\' ] - and infixes = - List.fold_right StringSet.add infix_lidents StringSet.empty - in - fun s -> - (StringSet.mem s infixes) || - ((s <> "") && (List.mem s.[0] first_chars)) - - let is_keyword = - let keywords = - List.fold_right StringSet.add - [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; - "do"; "done"; "downto"; "else"; "end"; "exception"; - "external"; "false"; "for"; "fun"; "function"; "functor"; - "if"; "in"; "include"; "inherit"; "initializer"; "lazy"; - "let"; "match"; "method"; "module"; "mutable"; "new"; - "object"; "of"; "open"; "parser"; "private"; "rec"; - "sig"; "struct"; "then"; "to"; "true"; "try"; "type"; - "val"; "virtual"; "when"; "while"; "with" ] - StringSet.empty - in fun s -> StringSet.mem s keywords - - module Lexer = Struct.Lexer.Make(Token) - - let _ = let module M = ErrorHandler.Register(Lexer.Error) in () - - open Sig - - let lexer s = - Lexer.from_string ~quotations: !Camlp4_config.quotations Loc. - ghost s - - let lex_string str = - try - let (__strm : _ Stream.t) = lexer str - in - match Stream.peek __strm with - | Some ((tok, _)) -> - (Stream.junk __strm; - (match Stream.peek __strm with - | Some ((EOI, _)) -> (Stream.junk __strm; tok) - | _ -> raise (Stream.Error ""))) - | _ -> raise Stream.Failure - with - | Stream.Failure | Stream.Error _ -> - failwith - (sprintf - "Cannot print %S this string contains more than one token" - str) - | Lexer.Error.E exn -> - failwith - (sprintf - "Cannot print %S this identifier does not respect OCaml lexing rules (%s)" - str (Lexer.Error.to_string exn)) - - let ocaml_char x = Char.escaped (Struct.Token.Eval.char x) - - let rec get_expr_args a al = - match a with - | Ast.ExApp (_, a1, a2) -> get_expr_args a1 (a2 :: al) - | _ -> (a, al) - - let rec get_patt_args a al = - match a with - | Ast.PaApp (_, a1, a2) -> get_patt_args a1 (a2 :: al) - | _ -> (a, al) - - let rec get_ctyp_args a al = - match a with - | Ast.TyApp (_, a1, a2) -> get_ctyp_args a1 (a2 :: al) - | _ -> (a, al) - - let is_irrefut_patt = Ast.is_irrefut_patt - - let rec expr_fun_args = - function - | (Ast.ExFun (_, (Ast.McArr (_, p, (Ast.ExNil _), e))) as ge) - -> - if is_irrefut_patt p - then - (let (pl, e) = expr_fun_args e in (((`patt p) :: pl), e)) - else ([], ge) - | Ast.ExFUN (_, i, e) -> - let (pl, e) = expr_fun_args e in (((`newtype i) :: pl), e) - | ge -> ([], ge) - - let rec class_expr_fun_args = - function - | (Ast.CeFun (_, p, ce) as ge) -> - if is_irrefut_patt p - then - (let (pl, ce) = class_expr_fun_args ce in ((p :: pl), ce)) - else ([], ge) - | ge -> ([], ge) - - let rec do_print_comments_before loc f (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some ((comm, comm_loc)) when Loc.strictly_before comm_loc loc - -> - (Stream.junk __strm; - let s = __strm in - let () = f comm comm_loc - in do_print_comments_before loc f s) - | _ -> () - - class printer ?curry_constr:(init_curry_constr = false) - ?(comments = true) () = - object (o) - val pipe = false - val semi = false - method under_pipe = {< pipe = true; >} - method under_semi = {< semi = true; >} - method reset_semi = {< semi = false; >} - method reset = {< pipe = false; semi = false; >} - val semisep = (";;" : sep) - val no_semisep = ("" : sep) - val mode = if comments then `comments else `no_comments - val curry_constr = init_curry_constr - val var_conversion = false - method andsep : sep = "@]@ @[<2>and@ " - method value_val = "val" - method value_let = "let" - method semisep = semisep - method set_semisep = fun s -> {< semisep = s; >} - method set_comments = - fun b -> - {< mode = if b then `comments else `no_comments; >} - method set_loc_and_comments = {< mode = `loc_and_comments; >} - method set_curry_constr = fun b -> {< curry_constr = b; >} - method print_comments_before = - fun loc f -> - match mode with - | `comments -> - do_print_comments_before loc - (fun c _ -> pp f "%s@ " c) - (CommentFilter.take_stream comment_filter) - | `loc_and_comments -> - let () = pp f "(*loc: %a*)@ " Loc.dump loc - in - do_print_comments_before loc - (fun s -> pp f "%s(*comm_loc: %a*)@ " s Loc.dump) - (CommentFilter.take_stream comment_filter) - | _ -> () - method var = - fun f -> - function - | "" -> pp f "$lid:\"\"$" - | "[]" -> pp f "[]" - | "()" -> pp f "()" - | " True" -> pp f "True" - | " False" -> pp f "False" - | v -> - (match (var_conversion, v) with - | (true, "val") -> pp f "contents" - | (true, "True") -> pp f "true" - | (true, "False") -> pp f "false" - | _ -> - (match lex_string v with - | LIDENT s | UIDENT s | ESCAPED_IDENT s when - is_keyword s -> pp f "%s__" s - | LIDENT s | ESCAPED_IDENT s when - List.mem s infix_lidents -> pp f "( %s )" s - | SYMBOL s -> pp f "( %s )" s - | LIDENT s | UIDENT s | ESCAPED_IDENT s -> - pp_print_string f s - | tok -> - failwith - (sprintf - "Bad token used as an identifier: %s" - (Token.to_string tok)))) - method type_params = - fun f -> - function - | [] -> () - | [ x ] -> pp f "%a@ " o#ctyp x - | l -> pp f "@[<1>(%a)@]@ " (list o#ctyp ",@ ") l - method class_params = - fun f -> - function - | Ast.TyCom (_, t1, t2) -> - pp f "@[<1>%a,@ %a@]" o#class_params t1 - o#class_params t2 - | x -> o#ctyp f x - method override_flag = - fun f -> - function - | Ast.OvOverride -> pp f "!" - | Ast.OvNil -> () - | Ast.OvAnt s -> o#anti f s - method mutable_flag = - fun f -> - function - | Ast.MuMutable -> pp f "mutable@ " - | Ast.MuNil -> () - | Ast.MuAnt s -> o#anti f s - method rec_flag = - fun f -> - function - | Ast.ReRecursive -> pp f "rec@ " - | Ast.ReNil -> () - | Ast.ReAnt s -> o#anti f s - method virtual_flag = - fun f -> - function - | Ast.ViVirtual -> pp f "virtual@ " - | Ast.ViNil -> () - | Ast.ViAnt s -> o#anti f s - method private_flag = - fun f -> - function - | Ast.PrPrivate -> pp f "private@ " - | Ast.PrNil -> () - | Ast.PrAnt s -> o#anti f s - method anti = fun f s -> pp f "$%s$" s - method seq = - fun f -> - function - | Ast.ExSem (_, e1, e2) -> - pp f "%a;@ %a" o#under_semi#seq e1 o#seq e2 - | Ast.ExSeq (_, e) -> o#seq f e - | e -> o#expr f e - method match_case = - fun f -> - function - | Ast.McNil _loc -> - pp f "@[<2>@ _ ->@ %a@]" o#raise_match_failure _loc - | a -> o#match_case_aux f a - method match_case_aux = - fun f -> - function - | Ast.McNil _ -> () - | Ast.McAnt (_, s) -> o#anti f s - | Ast.McOr (_, a1, a2) -> - pp f "%a%a" o#match_case_aux a1 o#match_case_aux a2 - | Ast.McArr (_, p, (Ast.ExNil _), e) -> - pp f "@ | @[<2>%a@ ->@ %a@]" o#patt p - o#under_pipe#expr e - | Ast.McArr (_, p, w, e) -> - pp f "@ | @[<2>%a@ when@ %a@ ->@ %a@]" o#patt p - o#under_pipe#expr w o#under_pipe#expr e - method fun_binding = - fun f -> - function - | `patt p -> o#simple_patt f p - | `newtype i -> pp f "(type %s)" i - method binding = - fun f bi -> - let () = o#node f bi Ast.loc_of_binding - in - match bi with - | Ast.BiNil _ -> () - | Ast.BiAnd (_, b1, b2) -> - (o#binding f b1; pp f o#andsep; o#binding f b2) - | Ast.BiEq (_, p, e) -> - let (pl, e') = - (match p with - | Ast.PaTyc (_, _, _) -> ([], e) - | _ -> expr_fun_args e) - in - (match (p, e') with - | (Ast.PaId (_, (Ast.IdLid (_, _))), - Ast.ExTyc (_, e', t)) -> - pp f "%a :@ %a =@ %a" - (list o#fun_binding "@ ") - ((`patt p) :: pl) o#ctyp t o#expr e' - | (Ast.PaId (_, (Ast.IdLid (_, _))), _) -> - pp f "%a @[<0>%a=@]@ %a" o#simple_patt p - (list' o#fun_binding "" "@ ") pl o#expr e' - | _ -> pp f "%a =@ %a" o#simple_patt p o#expr e) - | Ast.BiAnt (_, s) -> o#anti f s - method record_binding = - fun f bi -> - let () = o#node f bi Ast.loc_of_rec_binding - in - match bi with - | Ast.RbNil _ -> () - | Ast.RbEq (_, i, e) -> - pp f "@ @[<2>%a =@ %a@];" o#var_ident i o#expr e - | Ast.RbSem (_, b1, b2) -> - (o#under_semi#record_binding f b1; - o#under_semi#record_binding f b2) - | Ast.RbAnt (_, s) -> o#anti f s - method mk_patt_list = - function - | Ast.PaApp (_, - (Ast.PaApp (_, (Ast.PaId (_, (Ast.IdUid (_, "::")))), - p1)), - p2) -> - let (pl, c) = o#mk_patt_list p2 in ((p1 :: pl), c) - | Ast.PaId (_, (Ast.IdUid (_, "[]"))) -> ([], None) - | p -> ([], (Some p)) - method mk_expr_list = - function - | Ast.ExApp (_, - (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdUid (_, "::")))), - e1)), - e2) -> - let (el, c) = o#mk_expr_list e2 in ((e1 :: el), c) - | Ast.ExId (_, (Ast.IdUid (_, "[]"))) -> ([], None) - | e -> ([], (Some e)) - method expr_list = - fun f -> - function - | [] -> pp f "[]" - | [ e ] -> pp f "[ %a ]" o#under_semi#expr e - | el -> - pp f "@[<2>[ %a@] ]" (list o#under_semi#expr ";@ ") - el - method expr_list_cons = - fun simple f e -> - let (el, c) = o#mk_expr_list e - in - match c with - | None -> o#expr_list f el - | Some x -> - (if simple - then pp f "@[<2>(%a)@]" - else pp f "@[<2>%a@]") - (list o#under_semi#dot_expr " ::@ ") (el @ [ x ]) - method patt_expr_fun_args = - fun f (p, e) -> - let (pl, e) = expr_fun_args e - in - pp f "%a@ ->@ %a" (list o#fun_binding "@ ") (p :: pl) - o#expr e - method patt_class_expr_fun_args = - fun f (p, ce) -> - let (pl, ce) = class_expr_fun_args ce - in - pp f "%a =@]@ %a" (list o#simple_patt "@ ") (p :: pl) - o#class_expr ce - method constrain = - fun f (t1, t2) -> - pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 - method sum_type = - fun f t -> - match Ast.list_of_ctyp t [] with - | [] -> () - | ts -> - pp f "@[| %a@]" - (list o#constructor_declaration "@ | ") ts - method private constructor_declaration = - fun f t -> - match t with - | Ast.TyCol (_, t1, (Ast.TyArr (_, t2, t3))) -> - pp f "@[<2>%a :@ @[<2>%a@ ->@ %a@]@]" o#ctyp t1 - o#constructor_type t2 o#ctyp t3 - | t -> o#ctyp f t - method string = fun f -> pp f "%s" - method quoted_string = fun f -> pp f "%S" - method numeric = - fun f num suff -> - if num.[0] = '-' - then pp f "(%s%s)" num suff - else pp f "%s%s" num suff - method module_expr_get_functor_args = - fun accu -> - function - | Ast.MeFun (_, s, mt, me) -> - o#module_expr_get_functor_args ((s, mt) :: accu) me - | Ast.MeTyc (_, me, mt) -> - ((List.rev accu), me, (Some mt)) - | me -> ((List.rev accu), me, None) - method functor_args = fun f -> list o#functor_arg "@ " f - method functor_arg = - fun f (s, mt) -> - pp f "@[<2>(%a :@ %a)@]" o#var s o#module_type mt - method module_rec_binding = - fun f -> - function - | Ast.MbNil _ -> () - | Ast.MbColEq (_, s, mt, me) -> - pp f "@[<2>%a :@ %a =@ %a@]" o#var s o#module_type mt - o#module_expr me - | Ast.MbCol (_, s, mt) -> - pp f "@[<2>%a :@ %a@]" o#var s o#module_type mt - | Ast.MbAnd (_, mb1, mb2) -> - (o#module_rec_binding f mb1; - pp f o#andsep; - o#module_rec_binding f mb2) - | Ast.MbAnt (_, s) -> o#anti f s - method class_declaration = - fun f -> - function - | Ast.CeTyc (_, ce, ct) -> - pp f "%a :@ %a" o#class_expr ce o#class_type ct - | ce -> o#class_expr f ce - method raise_match_failure = - fun f _loc -> - let n = Loc.file_name _loc in - let l = Loc.start_line _loc in - let c = (Loc.start_off _loc) - (Loc.start_bol _loc) - in - o#expr f - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, "raise")))), - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "Match_failure")))), - (Ast.ExStr (_loc, - (Ast.safe_string_escaped n))))), - (Ast.ExInt (_loc, (string_of_int l))))), - (Ast.ExInt (_loc, (string_of_int c))))))) - method node : 'a. formatter -> 'a -> ('a -> Loc.t) -> unit = - fun f node loc_of_node -> - o#print_comments_before (loc_of_node node) f - method ident = - fun f i -> - let () = o#node f i Ast.loc_of_ident - in - match i with - | Ast.IdAcc (_, i1, i2) -> - pp f "%a.@,%a" o#ident i1 o#ident i2 - | Ast.IdApp (_, i1, i2) -> - pp f "%a@,(%a)" o#ident i1 o#ident i2 - | Ast.IdAnt (_, s) -> o#anti f s - | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s - method private var_ident = {< var_conversion = true; >}#ident - method expr = - fun f e -> - let () = o#node f e Ast.loc_of_expr - in - match e with - | (Ast.ExLet (_, _, _, _) | Ast.ExLmd (_, _, _, _) as - e) when semi -> pp f "(%a)" o#reset#expr e - | (Ast.ExMat (_, _, _) | Ast.ExTry (_, _, _) | - Ast.ExFun (_, _) - as e) when pipe || semi -> - pp f "(%a)" o#reset#expr e - | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "~-")))), - x) -> pp f "@[<2>-@ %a@]" o#dot_expr x - | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "~-.")))), - x) -> pp f "@[<2>-.@ %a@]" o#dot_expr x - | Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExId (_, (Ast.IdUid (_, "::")))), _)), - _) -> o#expr_list_cons false f e - | Ast.ExApp (_loc, - (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, n)))), - x)), - y) when is_infix n -> - pp f "@[<2>%a@ %s@ %a@]" o#apply_expr x n - o#apply_expr y - | Ast.ExApp (_, x, y) -> - let (a, al) = get_expr_args x [ y ] - in - if - (not curry_constr) && - (Ast.is_expr_constructor a) - then - (match al with - | [ Ast.ExTup (_, _) ] -> - pp f "@[<2>%a@ (%a)@]" o#apply_expr x - o#expr y - | [ _ ] -> - pp f "@[<2>%a@ %a@]" o#apply_expr x - o#apply_expr y - | al -> - pp f "@[<2>%a@ (%a)@]" o#apply_expr a - (list o#under_pipe#apply_expr ",@ ") al) - else - pp f "@[<2>%a@]" (list o#apply_expr "@ ") - (a :: al) - | Ast.ExAss (_, - (Ast.ExAcc (_, e1, - (Ast.ExId (_, (Ast.IdLid (_, "val")))))), - e2) -> - pp f "@[<2>%a :=@ %a@]" o#dot_expr e1 o#expr e2 - | Ast.ExAss (_, e1, e2) -> - pp f "@[<2>%a@ <-@ %a@]" o#dot_expr e1 o#expr e2 - | Ast.ExFun (loc, (Ast.McNil _)) -> - pp f "@[<2>fun@ _@ ->@ %a@]" o#raise_match_failure - loc - | Ast.ExFun (_, (Ast.McArr (_, p, (Ast.ExNil _), e))) - when is_irrefut_patt p -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args - ((`patt p), e) - | Ast.ExFUN (_, i, e) -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args - ((`newtype i), e) - | Ast.ExFun (_, a) -> - pp f "@[function%a@]" o#match_case a - | Ast.ExIfe (_, e1, e2, e3) -> - pp f - "@[@[<2>if@ %a@]@ @[<2>then@ %a@]@ @[<2>else@ %a@]@]" - o#expr e1 o#under_semi#expr e2 o#under_semi#expr - e3 - | Ast.ExLaz (_, e) -> - pp f "@[<2>lazy@ %a@]" o#simple_expr e - | Ast.ExLet (_, r, bi, e) -> - (match e with - | Ast.ExLet (_, _, _, _) -> - pp f "@[<0>@[<2>let %a%a in@]@ %a@]" - o#rec_flag r o#binding bi o#reset_semi#expr - e - | _ -> - pp f - "@[@[<2>let %a%a@]@ @[in@ %a@]@]" - o#rec_flag r o#binding bi o#reset_semi#expr - e) - | Ast.ExOpI (_, i, e) -> - pp f "@[<2>let open %a@]@ @[<2>in@ %a@]" o#ident i - o#reset_semi#expr e - | Ast.ExMat (_, e, a) -> - pp f "@[@[@[<2>match %a@]@ with@]%a@]" - o#expr e o#match_case a - | Ast.ExTry (_, e, a) -> - pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" - o#expr e o#match_case a - | Ast.ExAsf _ -> pp f "@[<2>assert@ false@]" - | Ast.ExAsr (_, e) -> - pp f "@[<2>assert@ %a@]" o#dot_expr e - | Ast.ExLmd (_, s, me, e) -> - pp f "@[<2>let module %a =@ %a@]@ @[<2>in@ %a@]" - o#var s o#module_expr me o#reset_semi#expr e - | Ast.ExObj (_, (Ast.PaNil _), cst) -> - pp f "@[@[object@ %a@]@ end@]" - o#class_str_item cst - | Ast.ExObj (_, (Ast.PaTyc (_, p, t)), cst) -> - pp f - "@[@[object @[<1>(%a :@ %a)@]@ %a@]@ end@]" - o#patt p o#ctyp t o#class_str_item cst - | Ast.ExObj (_, p, cst) -> - pp f - "@[@[object @[<2>(%a)@]@ %a@]@ end@]" - o#patt p o#class_str_item cst - | e -> o#apply_expr f e - method apply_expr = - fun f e -> - let () = o#node f e Ast.loc_of_expr - in - match e with - | Ast.ExNew (_, i) -> pp f "@[<2>new@ %a@]" o#ident i - | e -> o#dot_expr f e - method dot_expr = - fun f e -> - let () = o#node f e Ast.loc_of_expr - in - match e with - | Ast.ExAcc (_, e, - (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> - pp f "@[<2>!@,%a@]" o#simple_expr e - | Ast.ExAcc (_, e1, e2) -> - pp f "@[<2>%a.@,%a@]" o#dot_expr e1 o#dot_expr e2 - | Ast.ExAre (_, e1, e2) -> - pp f "@[<2>%a.@,(%a)@]" o#dot_expr e1 o#expr e2 - | Ast.ExSte (_, e1, e2) -> - pp f "%a.@[<1>[@,%a@]@,]" o#dot_expr e1 o#expr e2 - | Ast.ExSnd (_, e, s) -> - pp f "@[<2>%a#@,%s@]" o#dot_expr e s - | e -> o#simple_expr f e - method simple_expr = - fun f e -> - let () = o#node f e Ast.loc_of_expr - in - match e with - | Ast.ExNil _ -> () - | Ast.ExSeq (_, e) -> pp f "@[(%a)@]" o#seq e - | Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExId (_, (Ast.IdUid (_, "::")))), _)), - _) -> o#expr_list_cons true f e - | Ast.ExTup (_, e) -> pp f "@[<1>(%a)@]" o#expr e - | Ast.ExArr (_, e) -> - pp f "@[<0>@[<2>[|@ %a@]@ |]@]" o#under_semi#expr e - | Ast.ExCoe (_, e, (Ast.TyNil _), t) -> - pp f "@[<2>(%a :>@ %a)@]" o#expr e o#ctyp t - | Ast.ExCoe (_, e, t1, t2) -> - pp f "@[<2>(%a :@ %a :>@ %a)@]" o#expr e o#ctyp t1 - o#ctyp t2 - | Ast.ExTyc (_, e, t) -> - pp f "@[<2>(%a :@ %a)@]" o#expr e o#ctyp t - | Ast.ExAnt (_, s) -> o#anti f s - | Ast.ExFor (_, s, e1, e2, df, e3) -> - pp f - "@[@[@[<2>for %a =@ %a@ %a@ %a@ do@]@ %a@]@ done@]" - o#var s o#expr e1 o#direction_flag df o#expr e2 - o#seq e3 - | Ast.ExInt (_, s) -> o#numeric f s "" - | Ast.ExNativeInt (_, s) -> o#numeric f s "n" - | Ast.ExInt64 (_, s) -> o#numeric f s "L" - | Ast.ExInt32 (_, s) -> o#numeric f s "l" - | Ast.ExFlo (_, s) -> o#numeric f s "" - | Ast.ExChr (_, s) -> pp f "'%s'" (ocaml_char s) - | Ast.ExId (_, i) -> o#var_ident f i - | Ast.ExRec (_, b, (Ast.ExNil _)) -> - pp f "@[@[{%a@]@ }@]" o#record_binding b - | Ast.ExRec (_, b, e) -> - pp f "@[@[{@ (%a)@ with%a@]@ }@]" - o#expr e o#record_binding b - | Ast.ExStr (_, s) -> pp f "\"%s\"" s - | Ast.ExWhi (_, e1, e2) -> - pp f "@[<2>while@ %a@ do@ %a@ done@]" o#expr e1 - o#seq e2 - | Ast.ExLab (_, s, (Ast.ExNil _)) -> pp f "~%s" s - | Ast.ExLab (_, s, e) -> - pp f "@[<2>~%s:@ %a@]" s o#dot_expr e - | Ast.ExOlb (_, s, (Ast.ExNil _)) -> pp f "?%s" s - | Ast.ExOlb (_, s, e) -> - pp f "@[<2>?%s:@ %a@]" s o#dot_expr e - | Ast.ExVrn (_, s) -> pp f "`%a" o#var s - | Ast.ExOvr (_, b) -> - pp f "@[@[{<%a@]@ >}@]" o#record_binding - b - | Ast.ExCom (_, e1, e2) -> - pp f "%a,@ %a" o#simple_expr e1 o#simple_expr e2 - | Ast.ExSem (_, e1, e2) -> - pp f "%a;@ %a" o#under_semi#expr e1 o#expr e2 - | Ast.ExPkg (_, (Ast.MeTyc (_, me, mt))) -> - pp f "@[@[(module %a : %a@])@]" - o#module_expr me o#module_type mt - | Ast.ExPkg (_, me) -> - pp f "@[@[(module %a@])@]" o#module_expr - me - | Ast.ExApp (_, _, _) | Ast.ExAcc (_, _, _) | - Ast.ExAre (_, _, _) | Ast.ExSte (_, _, _) | - Ast.ExAss (_, _, _) | Ast.ExSnd (_, _, _) | - Ast.ExFun (_, _) | Ast.ExFUN (_, _, _) | - Ast.ExMat (_, _, _) | Ast.ExTry (_, _, _) | - Ast.ExIfe (_, _, _, _) | Ast.ExLet (_, _, _, _) | - Ast.ExLmd (_, _, _, _) | Ast.ExOpI (_, _, _) | - Ast.ExAsr (_, _) | Ast.ExAsf _ | Ast.ExLaz (_, _) | - Ast.ExNew (_, _) | Ast.ExObj (_, _, _) -> - pp f "(%a)" o#reset#expr e - method direction_flag = - fun f b -> - match b with - | Ast.DiTo -> pp_print_string f "to" - | Ast.DiDownto -> pp_print_string f "downto" - | Ast.DiAnt s -> o#anti f s - method patt = - fun f p -> - let () = o#node f p Ast.loc_of_patt - in - match p with - | Ast.PaAli (_, p1, p2) -> - pp f "@[<1>(%a@ as@ %a)@]" o#patt p1 o#patt p2 - | Ast.PaEq (_, i, p) -> - pp f "@[<2>%a =@ %a@]" o#var_ident i o#patt p - | Ast.PaSem (_, p1, p2) -> - pp f "%a;@ %a" o#patt p1 o#patt p2 - | p -> o#patt1 f p - method patt1 = - fun f -> - function - | Ast.PaOrp (_, p1, p2) -> - pp f "@[<2>%a@ |@ %a@]" o#patt1 p1 o#patt2 p2 - | p -> o#patt2 f p - method patt2 = fun f p -> o#patt3 f p - method patt3 = - fun f -> - function - | Ast.PaRng (_, p1, p2) -> - pp f "@[<2>%a@ ..@ %a@]" o#patt3 p1 o#patt4 p2 - | Ast.PaCom (_, p1, p2) -> - pp f "%a,@ %a" o#patt3 p1 o#patt3 p2 - | p -> o#patt4 f p - method patt4 = - fun f -> - function - | (Ast.PaApp (_, - (Ast.PaApp (_, - (Ast.PaId (_, (Ast.IdUid (_, "::")))), _)), - _) - as p) -> - let (pl, c) = o#mk_patt_list p - in - (match c with - | None -> - pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl - | Some x -> - pp f "@[<2>%a@]" (list o#patt5 " ::@ ") - (pl @ [ x ])) - | p -> o#patt5 f p - method patt5 = - fun f -> - function - | (Ast.PaApp (_, - (Ast.PaApp (_, - (Ast.PaId (_, (Ast.IdUid (_, "::")))), _)), - _) - as p) -> o#simple_patt f p - | Ast.PaLaz (_, p) -> - pp f "@[<2>lazy %a@]" o#simple_patt p - | Ast.PaApp (_, x, y) -> - let (a, al) = get_patt_args x [ y ] - in - if not (Ast.is_patt_constructor a) - then - Format.eprintf - "WARNING: strange pattern application of a non constructor@." - else - if curry_constr - then - pp f "@[<2>%a@]" (list o#simple_patt "@ ") - (a :: al) - else - (match al with - | [ Ast.PaTup (_, _) ] -> - pp f "@[<2>%a@ (%a)@]" o#simple_patt x - o#patt y - | [ _ ] -> - pp f "@[<2>%a@ %a@]" o#patt5 x - o#simple_patt y - | al -> - pp f "@[<2>%a@ (%a)@]" o#patt5 a - (list o#simple_patt ",@ ") al) - | p -> o#simple_patt f p - method simple_patt = - fun f p -> - let () = o#node f p Ast.loc_of_patt - in - match p with - | Ast.PaNil _ -> () - | Ast.PaId (_, i) -> o#var_ident f i - | Ast.PaAnt (_, s) -> o#anti f s - | Ast.PaAny _ -> pp f "_" - | Ast.PaMod (_, m) -> pp f "(module %s)" m - | Ast.PaTup (_, p) -> pp f "@[<1>(%a)@]" o#patt3 p - | Ast.PaRec (_, p) -> pp f "@[{@ %a@]@ }" o#patt p - | Ast.PaStr (_, s) -> pp f "\"%s\"" s - | Ast.PaTyc (_, p, t) -> - pp f "@[<1>(%a :@ %a)@]" o#patt p o#ctyp t - | Ast.PaNativeInt (_, s) -> o#numeric f s "n" - | Ast.PaInt64 (_, s) -> o#numeric f s "L" - | Ast.PaInt32 (_, s) -> o#numeric f s "l" - | Ast.PaInt (_, s) -> o#numeric f s "" - | Ast.PaFlo (_, s) -> o#numeric f s "" - | Ast.PaChr (_, s) -> pp f "'%s'" (ocaml_char s) - | Ast.PaLab (_, s, (Ast.PaNil _)) -> pp f "~%s" s - | Ast.PaVrn (_, s) -> pp f "`%a" o#var s - | Ast.PaTyp (_, i) -> pp f "@[<2>#%a@]" o#ident i - | Ast.PaArr (_, p) -> pp f "@[<2>[|@ %a@]@ |]" o#patt p - | Ast.PaLab (_, s, p) -> - pp f "@[<2>~%s:@ (%a)@]" s o#patt p - | Ast.PaOlb (_, s, (Ast.PaNil _)) -> pp f "?%s" s - | Ast.PaOlb (_, "", p) -> - pp f "@[<2>?(%a)@]" o#patt_tycon p - | Ast.PaOlb (_, s, p) -> - pp f "@[<2>?%s:@,@[<1>(%a)@]@]" s o#patt_tycon p - | Ast.PaOlbi (_, "", p, e) -> - pp f "@[<2>?(%a =@ %a)@]" o#patt_tycon p o#expr e - | Ast.PaOlbi (_, s, p, e) -> - pp f "@[<2>?%s:@,@[<1>(%a =@ %a)@]@]" s - o#patt_tycon p o#expr e - | (Ast.PaApp (_, _, _) | Ast.PaAli (_, _, _) | - Ast.PaOrp (_, _, _) | Ast.PaRng (_, _, _) | - Ast.PaCom (_, _, _) | Ast.PaSem (_, _, _) | - Ast.PaEq (_, _, _) | Ast.PaLaz (_, _) - as p) -> pp f "@[<1>(%a)@]" o#patt p - method patt_tycon = - fun f -> - function - | Ast.PaTyc (_, p, t) -> - pp f "%a :@ %a" o#patt p o#ctyp t - | p -> o#patt f p - method simple_ctyp = - fun f t -> - let () = o#node f t Ast.loc_of_ctyp - in - match t with - | Ast.TyId (_, i) -> o#ident f i - | Ast.TyAnt (_, s) -> o#anti f s - | Ast.TyAny _ -> pp f "_" - | Ast.TyAnP _ -> pp f "+_" - | Ast.TyAnM _ -> pp f "-_" - | Ast.TyLab (_, s, t) -> - pp f "@[<2>%s:@ %a@]" s o#simple_ctyp t - | Ast.TyOlb (_, s, t) -> - pp f "@[<2>?%s:@ %a@]" s o#simple_ctyp t - | Ast.TyObj (_, (Ast.TyNil _), Ast.RvNil) -> pp f "< >" - | Ast.TyObj (_, (Ast.TyNil _), Ast.RvRowVar) -> - pp f "< .. >" - | Ast.TyObj (_, t, Ast.RvRowVar) -> - pp f "@[<0>@[<2><@ %a;@ ..@]@ >@]" o#ctyp t - | Ast.TyObj (_, t, Ast.RvNil) -> - pp f "@[<0>@[<2><@ %a@]@ >@]" o#ctyp t - | Ast.TyQuo (_, s) -> pp f "'%a" o#var s - | Ast.TyRec (_, t) -> pp f "@[<2>{@ %a@]@ }" o#ctyp t - | Ast.TySum (_, t) -> pp f "@[<0>%a@]" o#sum_type t - | Ast.TyTup (_, t) -> pp f "@[<1>(%a)@]" o#ctyp t - | Ast.TyPkg (_, mt) -> - pp f "@[<2>(module@ %a@])" o#module_type mt - | Ast.TyVrnEq (_, t) -> - pp f "@[<2>[@ %a@]@ ]" o#sum_type t - | Ast.TyVrnInf (_, t) -> - pp f "@[<2>[<@ %a@]@,]" o#sum_type t - | Ast.TyVrnInfSup (_, t1, t2) -> - let (a, al) = get_ctyp_args t2 [] - in - pp f "@[<2>[<@ %a@ >@ %a@]@ ]" o#sum_type t1 - (list o#simple_ctyp "@ ") (a :: al) - | Ast.TyVrnSup (_, t) -> - pp f "@[<2>[>@ %a@]@,]" o#sum_type t - | Ast.TyCls (_, i) -> pp f "@[<2>#%a@]" o#ident i - | Ast.TyVrn (_, s) -> pp f "`%a" o#var s - | Ast.TySta (_, t1, t2) -> - pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2 - | Ast.TyNil _ -> assert false - | t -> pp f "@[<1>(%a)@]" o#ctyp t - method ctyp = - fun f t -> - let () = o#node f t Ast.loc_of_ctyp - in - match t with - | Ast.TyAli (_, t1, t2) -> - pp f "@[<2>%a@ as@ %a@]" o#simple_ctyp t1 - o#simple_ctyp t2 - | Ast.TyArr (_, t1, t2) -> - pp f "@[<2>%a@ ->@ %a@]" o#ctyp1 t1 o#ctyp t2 - | Ast.TyQuP (_, s) -> pp f "+'%a" o#var s - | Ast.TyQuM (_, s) -> pp f "-'%a" o#var s - | Ast.TyOr (_, t1, t2) -> - pp f "%a@ | %a" o#ctyp t1 o#ctyp t2 - | Ast.TyCol (_, t1, (Ast.TyMut (_, t2))) -> - pp f "@[mutable@ %a :@ %a@]" o#ctyp t1 o#ctyp t2 - | Ast.TyCol (_, t1, t2) -> - pp f "@[<2>%a :@ %a@]" o#ctyp t1 o#ctyp t2 - | Ast.TySem (_, t1, t2) -> - pp f "%a;@ %a" o#ctyp t1 o#ctyp t2 - | Ast.TyOf (_, t, (Ast.TyNil _)) -> o#ctyp f t - | Ast.TyOf (_, t1, t2) -> - pp f "@[%a@ @[<3>of@ %a@]@]" o#ctyp t1 - o#constructor_type t2 - | Ast.TyOfAmp (_, t1, t2) -> - pp f "@[%a@ @[<3>of &@ %a@]@]" o#ctyp t1 - o#constructor_type t2 - | Ast.TyAnd (_, t1, t2) -> - pp f "%a@ and %a" o#ctyp t1 o#ctyp t2 - | Ast.TyMut (_, t) -> - pp f "@[<2>mutable@ %a@]" o#ctyp t - | Ast.TyAmp (_, t1, t2) -> - pp f "%a@ &@ %a" o#ctyp t1 o#ctyp t2 - | Ast.TyMan (_, t1, t2) -> - pp f "@[<2>%a =@ %a@]" o#simple_ctyp t1 o#ctyp t2 - | Ast.TyDcl (_, tn, tp, te, cl) -> - (pp f "@[<2>%a%a@]" o#type_params tp o#var tn; - (match te with - | Ast.TyNil _ -> () - | _ -> pp f " =@ %a" o#ctyp te); - if cl <> [] - then pp f "@ %a" (list o#constrain "@ ") cl - else ()) - | t -> o#ctyp1 f t - method ctyp1 = - fun f -> - function - | Ast.TyApp (_, t1, t2) -> - (match get_ctyp_args t1 [ t2 ] with - | (_, [ _ ]) -> - pp f "@[<2>%a@ %a@]" o#simple_ctyp t2 - o#simple_ctyp t1 - | (a, al) -> - pp f "@[<2>(%a)@ %a@]" (list o#ctyp ",@ ") al - o#simple_ctyp a) - | Ast.TyPol (_, t1, t2) -> - let (a, al) = get_ctyp_args t1 [] - in - pp f "@[<2>%a.@ %a@]" (list o#ctyp "@ ") (a :: al) - o#ctyp t2 - | Ast.TyTypePol ((_, t1, t2)) -> - let (a, al) = get_ctyp_args t1 [] - in - pp f "@[<2>type %a.@ %a@]" (list o#ctyp "@ ") - (a :: al) o#ctyp t2 - | Ast.TyPrv (_, t) -> - pp f "@[private@ %a@]" o#simple_ctyp t - | t -> o#simple_ctyp f t - method constructor_type = - fun f t -> - match t with - | Ast.TyAnd (loc, t1, t2) -> - let () = o#node f t (fun _ -> loc) - in - pp f "%a@ * %a" o#constructor_type t1 - o#constructor_type t2 - | Ast.TyArr (_, _, _) -> pp f "(%a)" o#ctyp t - | t -> o#ctyp f t - method sig_item = - fun f sg -> - let () = o#node f sg Ast.loc_of_sig_item - in - match sg with - | Ast.SgNil _ -> () - | Ast.SgSem (_, sg, (Ast.SgNil _)) | - Ast.SgSem (_, (Ast.SgNil _), sg) -> o#sig_item f sg - | Ast.SgSem (_, sg1, sg2) -> - (o#sig_item f sg1; cut f; o#sig_item f sg2) - | Ast.SgExc (_, t) -> - pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep - | Ast.SgExt (_, s, t, sl) -> - pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" - o#var s o#ctyp t (meta_list o#quoted_string "@ ") - sl semisep - | Ast.SgMod (_, s1, (Ast.MtFun (_, s2, mt1, mt2))) -> - let rec loop accu = - (function - | Ast.MtFun (_, s, mt1, mt2) -> - loop ((s, mt1) :: accu) mt2 - | mt -> ((List.rev accu), mt)) in - let (al, mt) = loop [ (s2, mt1) ] mt2 - in - pp f "@[<2>module %a@ @[<0>%a@] :@ %a%(%)@]" - o#var s1 o#functor_args al o#module_type mt - semisep - | Ast.SgMod (_, s, mt) -> - pp f "@[<2>module %a :@ %a%(%)@]" o#var s - o#module_type mt semisep - | Ast.SgMty (_, s, (Ast.MtNil _)) -> - pp f "@[<2>module type %a%(%)@]" o#var s semisep - | Ast.SgMty (_, s, mt) -> - pp f "@[<2>module type %a =@ %a%(%)@]" o#var s - o#module_type mt semisep - | Ast.SgOpn (_, sl) -> - pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep - | Ast.SgTyp (_, t) -> - pp f "@[@[type %a@]%(%)@]" o#ctyp t - semisep - | Ast.SgVal (_, s, t) -> - pp f "@[<2>%s %a :@ %a%(%)@]" o#value_val o#var s - o#ctyp t semisep - | Ast.SgInc (_, mt) -> - pp f "@[<2>include@ %a%(%)@]" o#module_type mt - semisep - | Ast.SgClt (_, ct) -> - pp f "@[<2>class type %a%(%)@]" o#class_type ct - semisep - | Ast.SgCls (_, ce) -> - pp f "@[<2>class %a%(%)@]" o#class_type ce semisep - | Ast.SgRecMod (_, mb) -> - pp f "@[<2>module rec %a%(%)@]" - o#module_rec_binding mb semisep - | Ast.SgDir (_, _, _) -> () - | Ast.SgAnt (_, s) -> pp f "%a%(%)" o#anti s semisep - method str_item = - fun f st -> - let () = o#node f st Ast.loc_of_str_item - in - match st with - | Ast.StNil _ -> () - | Ast.StSem (_, st, (Ast.StNil _)) | - Ast.StSem (_, (Ast.StNil _), st) -> o#str_item f st - | Ast.StSem (_, st1, st2) -> - (o#str_item f st1; cut f; o#str_item f st2) - | Ast.StExc (_, t, Ast.ONone) -> - pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep - | Ast.StExc (_, t, (Ast.OSome sl)) -> - pp f "@[<2>exception@ %a =@ %a%(%)@]" o#ctyp t - o#ident sl semisep - | Ast.StExt (_, s, t, sl) -> - pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" - o#var s o#ctyp t (meta_list o#quoted_string "@ ") - sl semisep - | Ast.StMod (_, s1, (Ast.MeFun (_, s2, mt1, me))) -> - (match o#module_expr_get_functor_args [ (s2, mt1) ] - me - with - | (al, me, Some mt2) -> - pp f - "@[<2>module %a@ @[<0>%a@] :@ %a =@ %a%(%)@]" - o#var s1 o#functor_args al o#module_type mt2 - o#module_expr me semisep - | (al, me, _) -> - pp f "@[<2>module %a@ @[<0>%a@] =@ %a%(%)@]" - o#var s1 o#functor_args al o#module_expr me - semisep) - | Ast.StMod (_, s, (Ast.MeTyc (_, me, mt))) -> - pp f "@[<2>module %a :@ %a =@ %a%(%)@]" o#var s - o#module_type mt o#module_expr me semisep - | Ast.StMod (_, s, me) -> - pp f "@[<2>module %a =@ %a%(%)@]" o#var s - o#module_expr me semisep - | Ast.StMty (_, s, mt) -> - pp f "@[<2>module type %a =@ %a%(%)@]" o#var s - o#module_type mt semisep - | Ast.StOpn (_, sl) -> - pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep - | Ast.StTyp (_, t) -> - pp f "@[@[type %a@]%(%)@]" o#ctyp t - semisep - | Ast.StVal (_, r, bi) -> - pp f "@[<2>%s %a%a%(%)@]" o#value_let o#rec_flag r - o#binding bi semisep - | Ast.StExp (_, e) -> - pp f "@[<2>let _ =@ %a%(%)@]" o#expr e semisep - | Ast.StInc (_, me) -> - pp f "@[<2>include@ %a%(%)@]" o#simple_module_expr - me semisep - | Ast.StClt (_, ct) -> - pp f "@[<2>class type %a%(%)@]" o#class_type ct - semisep - | Ast.StCls (_, ce) -> - pp f "@[class %a%(%)@]" o#class_declaration ce - semisep - | Ast.StRecMod (_, mb) -> - pp f "@[<2>module rec %a%(%)@]" - o#module_rec_binding mb semisep - | Ast.StDir (_, _, _) -> () - | Ast.StAnt (_, s) -> pp f "%a%(%)" o#anti s semisep - | Ast.StExc (_, _, (Ast.OAnt _)) -> assert false - method module_type = - fun f mt -> - let () = o#node f mt Ast.loc_of_module_type - in - match mt with - | Ast.MtNil _ -> assert false - | Ast.MtOf (_, me) -> - pp f "@[<2>module type of@ %a@]" o#module_expr me - | Ast.MtId (_, i) -> o#ident f i - | Ast.MtAnt (_, s) -> o#anti f s - | Ast.MtFun (_, s, mt1, mt2) -> - pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" - o#var s o#module_type mt1 o#module_type mt2 - | Ast.MtQuo (_, s) -> pp f "'%a" o#var s - | Ast.MtSig (_, sg) -> - pp f "@[@[sig@ %a@]@ end@]" o#sig_item sg - | Ast.MtWit (_, mt, wc) -> - pp f "@[<2>%a@ with@ %a@]" o#module_type mt - o#with_constraint wc - method with_constraint = - fun f wc -> - let () = o#node f wc Ast.loc_of_with_constr - in - match wc with - | Ast.WcNil _ -> () - | Ast.WcTyp (_, t1, t2) -> - pp f "@[<2>type@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 - | Ast.WcMod (_, i1, i2) -> - pp f "@[<2>module@ %a =@ %a@]" o#ident i1 o#ident - i2 - | Ast.WcTyS (_, t1, t2) -> - pp f "@[<2>type@ %a :=@ %a@]" o#ctyp t1 o#ctyp t2 - | Ast.WcMoS (_, i1, i2) -> - pp f "@[<2>module@ %a :=@ %a@]" o#ident i1 - o#ident i2 - | Ast.WcAnd (_, wc1, wc2) -> - (o#with_constraint f wc1; - pp f o#andsep; - o#with_constraint f wc2) - | Ast.WcAnt (_, s) -> o#anti f s - method module_expr = - fun f me -> - let () = o#node f me Ast.loc_of_module_expr - in - match me with - | Ast.MeNil _ -> assert false - | Ast.MeTyc (_, (Ast.MeStr (_, st)), - (Ast.MtSig (_, sg))) -> - pp f - "@[<2>@[struct@ %a@]@ end :@ @[sig@ %a@]@ end@]" - o#str_item st o#sig_item sg - | _ -> o#simple_module_expr f me - method simple_module_expr = - fun f me -> - let () = o#node f me Ast.loc_of_module_expr - in - match me with - | Ast.MeNil _ -> assert false - | Ast.MeId (_, i) -> o#ident f i - | Ast.MeAnt (_, s) -> o#anti f s - | Ast.MeApp (_, me1, me2) -> - pp f "@[<2>%a@,(%a)@]" o#module_expr me1 - o#module_expr me2 - | Ast.MeFun (_, s, mt, me) -> - pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" - o#var s o#module_type mt o#module_expr me - | Ast.MeStr (_, st) -> - pp f "@[@[struct@ %a@]@ end@]" o#str_item - st - | Ast.MeTyc (_, me, mt) -> - pp f "@[<1>(%a :@ %a)@]" o#module_expr me - o#module_type mt - | Ast.MePkg (_, - (Ast.ExTyc (_, e, (Ast.TyPkg (_, mt))))) -> - pp f "@[<1>(%s %a :@ %a)@]" o#value_val o#expr e - o#module_type mt - | Ast.MePkg (_, e) -> - pp f "@[<1>(%s %a)@]" o#value_val o#expr e - method class_expr = - fun f ce -> - let () = o#node f ce Ast.loc_of_class_expr - in - match ce with - | Ast.CeApp (_, ce, e) -> - pp f "@[<2>%a@ %a@]" o#class_expr ce o#apply_expr e - | Ast.CeCon (_, Ast.ViNil, i, (Ast.TyNil _)) -> - pp f "@[<2>%a@]" o#ident i - | Ast.CeCon (_, Ast.ViNil, i, t) -> - pp f "@[<2>@[<1>[%a]@]@ %a@]" o#class_params t - o#ident i - | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), - (Ast.TyNil _)) -> pp f "@[<2>virtual@ %a@]" o#var i - | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) - -> - pp f "@[<2>virtual@ @[<1>[%a]@]@ %a@]" - o#class_params t o#var i - | Ast.CeFun (_, p, ce) -> - pp f "@[<2>fun@ %a@ ->@ %a@]" o#simple_patt p - o#class_expr ce - | Ast.CeLet (_, r, bi, ce) -> - pp f "@[<2>let %a%a@]@ @[<2>in@ %a@]" o#rec_flag r - o#binding bi o#class_expr ce - | Ast.CeStr (_, (Ast.PaNil _), cst) -> - pp f "@[@[object %a@]@ end@]" - o#class_str_item cst - | Ast.CeStr (_, p, cst) -> - pp f - "@[@[object @[<1>(%a)@]@ %a@]@ end@]" - o#patt p o#class_str_item cst - | Ast.CeTyc (_, ce, ct) -> - pp f "@[<1>(%a :@ %a)@]" o#class_expr ce - o#class_type ct - | Ast.CeAnt (_, s) -> o#anti f s - | Ast.CeAnd (_, ce1, ce2) -> - (o#class_expr f ce1; - pp f o#andsep; - o#class_expr f ce2) - | Ast.CeEq (_, ce1, (Ast.CeFun (_, p, ce2))) when - is_irrefut_patt p -> - pp f "@[<2>%a@ %a" o#class_expr ce1 - o#patt_class_expr_fun_args (p, ce2) - | Ast.CeEq (_, ce1, ce2) -> - pp f "@[<2>%a =@]@ %a" o#class_expr ce1 - o#class_expr ce2 - | _ -> assert false - method class_type = - fun f ct -> - let () = o#node f ct Ast.loc_of_class_type - in - match ct with - | Ast.CtCon (_, Ast.ViNil, i, (Ast.TyNil _)) -> - pp f "@[<2>%a@]" o#ident i - | Ast.CtCon (_, Ast.ViNil, i, t) -> - pp f "@[<2>[@,%a@]@,]@ %a" o#class_params t - o#ident i - | Ast.CtCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), - (Ast.TyNil _)) -> pp f "@[<2>virtual@ %a@]" o#var i - | Ast.CtCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) - -> - pp f "@[<2>virtual@ [@,%a@]@,]@ %a" o#class_params - t o#var i - | Ast.CtFun (_, t, ct) -> - pp f "@[<2>%a@ ->@ %a@]" o#simple_ctyp t - o#class_type ct - | Ast.CtSig (_, (Ast.TyNil _), csg) -> - pp f "@[@[object@ %a@]@ end@]" - o#class_sig_item csg - | Ast.CtSig (_, t, csg) -> - pp f - "@[@[object @[<1>(%a)@]@ %a@]@ end@]" - o#ctyp t o#class_sig_item csg - | Ast.CtAnt (_, s) -> o#anti f s - | Ast.CtAnd (_, ct1, ct2) -> - (o#class_type f ct1; - pp f o#andsep; - o#class_type f ct2) - | Ast.CtCol (_, ct1, ct2) -> - pp f "%a :@ %a" o#class_type ct1 o#class_type ct2 - | Ast.CtEq (_, ct1, ct2) -> - pp f "%a =@ %a" o#class_type ct1 o#class_type ct2 - | _ -> assert false - method class_sig_item = - fun f csg -> - let () = o#node f csg Ast.loc_of_class_sig_item - in - match csg with - | Ast.CgNil _ -> () - | Ast.CgSem (_, csg, (Ast.CgNil _)) | - Ast.CgSem (_, (Ast.CgNil _), csg) -> - o#class_sig_item f csg - | Ast.CgSem (_, csg1, csg2) -> - (o#class_sig_item f csg1; - cut f; - o#class_sig_item f csg2) - | Ast.CgCtr (_, t1, t2) -> - pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 - o#ctyp t2 no_semisep - | Ast.CgInh (_, ct) -> - pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct - no_semisep - | Ast.CgMth (_, s, pr, t) -> - pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag - pr o#var s o#ctyp t no_semisep - | Ast.CgVir (_, s, pr, t) -> - pp f "@[<2>method virtual %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t no_semisep - | Ast.CgVal (_, s, mu, vi, t) -> - pp f "@[<2>%s %a%a%a :@ %a%(%)@]" o#value_val - o#mutable_flag mu o#virtual_flag vi o#var s - o#ctyp t no_semisep - | Ast.CgAnt (_, s) -> pp f "%a%(%)" o#anti s no_semisep - method class_str_item = - fun f cst -> - let () = o#node f cst Ast.loc_of_class_str_item - in - match cst with - | Ast.CrNil _ -> () - | Ast.CrSem (_, cst, (Ast.CrNil _)) | - Ast.CrSem (_, (Ast.CrNil _), cst) -> - o#class_str_item f cst - | Ast.CrSem (_, cst1, cst2) -> - (o#class_str_item f cst1; - cut f; - o#class_str_item f cst2) - | Ast.CrCtr (_, t1, t2) -> - pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 - o#ctyp t2 no_semisep - | Ast.CrInh (_, ov, ce, "") -> - pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov - o#class_expr ce no_semisep - | Ast.CrInh (_, ov, ce, s) -> - pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" - o#override_flag ov o#class_expr ce o#var s - no_semisep - | Ast.CrIni (_, e) -> - pp f "@[<2>initializer@ %a%(%)@]" o#expr e - no_semisep - | Ast.CrMth (_, s, ov, pr, e, (Ast.TyNil _)) -> - pp f "@[<2>method%a %a%a =@ %a%(%)@]" - o#override_flag ov o#private_flag pr o#var s - o#expr e no_semisep - | Ast.CrMth (_, s, ov, pr, e, t) -> - pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]" - o#override_flag ov o#private_flag pr o#var s - o#ctyp t o#expr e no_semisep - | Ast.CrVir (_, s, pr, t) -> - pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t no_semisep - | Ast.CrVvr (_, s, mu, t) -> - pp f "@[<2>%s virtual %a%a :@ %a%(%)@]" o#value_val - o#mutable_flag mu o#var s o#ctyp t no_semisep - | Ast.CrVal (_, s, ov, mu, e) -> - pp f "@[<2>%s%a %a%a =@ %a%(%)@]" o#value_val - o#override_flag ov o#mutable_flag mu o#var s - o#expr e no_semisep - | Ast.CrAnt (_, s) -> pp f "%a%(%)" o#anti s no_semisep - method implem = - fun f st -> - match st with - | Ast.StExp (_, e) -> - pp f "@[<0>%a%(%)@]@." o#expr e semisep - | st -> pp f "@[%a@]@." o#str_item st - method interf = fun f sg -> pp f "@[%a@]@." o#sig_item sg - end - - let with_outfile output_file fct arg = - let call close f = - ((try fct f arg with | exn -> (close (); raise exn)); - close ()) - in - match output_file with - | None -> call (fun () -> ()) std_formatter - | Some s -> - let oc = open_out s in - let f = formatter_of_out_channel oc - in call (fun () -> close_out oc) f - - let print output_file fct = - let o = new printer () in with_outfile output_file (fct o) - - let print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg - - let print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st - - end - - module MakeMore (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax. - Ast).S = - struct - include Make(Syntax) - - let semisep : sep ref = ref ("@\n" : sep) - - let margin = ref 78 - - let comments = ref true - - let locations = ref false - - let curry_constr = ref false - - let print output_file fct = - let o = - new printer ~comments: !comments ~curry_constr: !curry_constr - () in - let o = o#set_semisep !semisep in - let o = if !locations then o#set_loc_and_comments else o - in - with_outfile output_file - (fun f -> - let () = Format.pp_set_margin f !margin - in Format.fprintf f "@[%a@]@." (fct o)) - - let print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg - - let print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st - - let check_sep s = - if String.contains s '%' - then failwith "-sep Format error, % found in string" - else (Obj.magic (Struct.Token.Eval.string s : string) : sep) - - let _ = - Options.add "-l" (Arg.Int (fun i -> margin := i)) - " line length for pretty printing." - - let _ = - Options.add "-ss" (Arg.Unit (fun () -> semisep := ";;")) - " Print double semicolons." - - let _ = - Options.add "-no_ss" (Arg.Unit (fun () -> semisep := "")) - " Do not print double semicolons (default)." - - let _ = - Options.add "-sep" - (Arg.String (fun s -> semisep := check_sep s)) - " Use this string between phrases." - - let _ = - Options.add "-curry-constr" (Arg.Set curry_constr) - "Use currified constructors." - - let _ = - Options.add "-no_comments" (Arg.Clear comments) - "Do not add comments." - - let _ = - Options.add "-add_locations" (Arg.Set locations) - "Add locations as comment." - - end - - end - - module OCamlr : - sig - module Id : Sig.Id - - module Make (Syntax : Sig.Camlp4Syntax) : - sig - open Format - - include Sig.Camlp4Syntax with module Loc = Syntax.Loc - and module Token = Syntax.Token and module Ast = Syntax.Ast - and module Gram = Syntax.Gram - - class printer : - ?curry_constr: bool -> - ?comments: bool -> - unit -> object ('a) inherit OCaml.Make(Syntax).printer end - - val with_outfile : - string option -> (formatter -> 'a -> unit) -> 'a -> unit - - val print : - string option -> - (printer -> formatter -> 'a -> unit) -> 'a -> unit - - end - - module MakeMore (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax. - Ast).S - - end = - struct - open Format - - module Id = - struct - let name = "Camlp4.Printers.OCamlr" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - include Syntax - - open Sig - - module PP_o = OCaml.Make(Syntax) - - open PP_o - - let pp = fprintf - - let is_keyword = - let keywords = [ "where" ] - and not_keywords = [ "false"; "function"; "true"; "val" ] - in - fun s -> - (not (List.mem s not_keywords)) && - ((is_keyword s) || (List.mem s keywords)) - - class printer ?curry_constr:(init_curry_constr = true) - ?(comments = true) () = - object (o) - inherit - PP_o.printer ~curry_constr: init_curry_constr ~comments () as - super - val! semisep = (";" : sep) - val! no_semisep = (";" : sep) - val mode = if comments then `comments else `no_comments - val curry_constr = init_curry_constr - val first_match_case = true - method andsep : sep = "@]@ @[<2>and@ " - method value_val = "value" - method value_let = "value" - method under_pipe = o - method under_semi = o - method reset_semi = o - method reset = o - method private unset_first_match_case = - {< first_match_case = false; >} - method private set_first_match_case = - {< first_match_case = true; >} - method seq = - fun f e -> - let rec self right f e = - let go_right = self right - and go_left = self false - in - match e with - | Ast.ExLet (_, r, bi, e1) -> - if right - then - pp f "@[<2>let %a%a@];@ %a" o#rec_flag r - o#binding bi go_right e1 - else pp f "(%a)" o#expr e - | Ast.ExSeq (_, e) -> go_right f e - | Ast.ExSem (_, e1, e2) -> - (pp f "%a;@ " go_left e1; - (match (right, e2) with - | (true, Ast.ExLet (_, r, bi, e3)) -> - pp f "@[<2>let %a%a@];@ %a" o#rec_flag r - o#binding bi go_right e3 - | _ -> go_right f e2)) - | e -> o#expr f e - in self true f e - method var = - fun f -> - function - | "" -> pp f "$lid:\"\"$" - | "[]" -> pp f "[]" - | "()" -> pp f "()" - | " True" -> pp f "True" - | " False" -> pp f "False" - | v -> - (match lex_string v with - | LIDENT s | UIDENT s | ESCAPED_IDENT s when - is_keyword s -> pp f "%s__" s - | SYMBOL s -> pp f "( %s )" s - | LIDENT s | UIDENT s | ESCAPED_IDENT s -> - pp_print_string f s - | tok -> - failwith - (sprintf "Bad token used as an identifier: %s" - (Token.to_string tok))) - method type_params = - fun f -> - function - | [] -> () - | [ x ] -> pp f "@ %a" o#ctyp x - | l -> pp f "@ @[<1>%a@]" (list o#ctyp "@ ") l - method match_case = - fun f -> - function - | Ast.McNil _ -> pp f "@ []" - | m -> - pp f "@ [ %a ]" o#set_first_match_case#match_case_aux - m - method match_case_aux = - fun f -> - function - | Ast.McNil _ -> () - | Ast.McAnt (_, s) -> o#anti f s - | Ast.McOr (_, a1, a2) -> - pp f "%a%a" o#match_case_aux a1 - o#unset_first_match_case#match_case_aux a2 - | Ast.McArr (_, p, (Ast.ExNil _), e) -> - let () = if first_match_case then () else pp f "@ | " - in - pp f "@[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr - e - | Ast.McArr (_, p, w, e) -> - let () = if first_match_case then () else pp f "@ | " - in - pp f "@[<2>%a@ when@ %a@ ->@ %a@]" o#patt p - o#under_pipe#expr w o#under_pipe#expr e - method sum_type = - fun f -> - function - | Ast.TyNil _ -> pp f "[]" - | t -> pp f "@[[ %a ]@]" o#ctyp t - method ident = - fun f i -> - let () = o#node f i Ast.loc_of_ident - in - match i with - | Ast.IdApp (_, i1, i2) -> - pp f "%a@ %a" o#dot_ident i1 o#dot_ident i2 - | i -> o#dot_ident f i - method private dot_ident = - fun f i -> - let () = o#node f i Ast.loc_of_ident - in - match i with - | Ast.IdAcc (_, i1, i2) -> - pp f "%a.@,%a" o#dot_ident i1 o#dot_ident i2 - | Ast.IdAnt (_, s) -> o#anti f s - | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s - | i -> pp f "(%a)" o#ident i - method patt4 = - fun f -> - function - | (Ast.PaApp (_, - (Ast.PaApp (_, - (Ast.PaId (_, (Ast.IdUid (_, "::")))), _)), - _) - as p) -> - let (pl, c) = o#mk_patt_list p - in - (match c with - | None -> - pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl - | Some x -> - pp f "@[<2>[ %a ::@ %a ]@]" - (list o#patt ";@ ") pl o#patt x) - | p -> super#patt4 f p - method expr_list_cons = - fun _ f e -> - let (el, c) = o#mk_expr_list e - in - match c with - | None -> o#expr_list f el - | Some x -> - pp f "@[<2>[ %a ::@ %a ]@]" (list o#expr ";@ ") el - o#expr x - method expr = - fun f e -> - let () = o#node f e Ast.loc_of_expr - in - match e with - | Ast.ExAss (_, e1, e2) -> - pp f "@[<2>%a@ :=@ %a@]" o#dot_expr e1 o#expr e2 - | Ast.ExFun (_, (Ast.McArr (_, p, (Ast.ExNil _), e))) - when Ast.is_irrefut_patt p -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args - ((`patt p), e) - | Ast.ExFUN (_, i, e) -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args - ((`newtype i), e) - | Ast.ExFun (_, a) -> - pp f "@[fun%a@]" o#match_case a - | Ast.ExAsf _ -> pp f "@[<2>assert@ False@]" - | e -> super#expr f e - method dot_expr = - fun f e -> - let () = o#node f e Ast.loc_of_expr - in - match e with - | Ast.ExAcc (_, e, - (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> - pp f "@[<2>%a.@,val@]" o#simple_expr e - | e -> super#dot_expr f e - method ctyp = - fun f t -> - let () = o#node f t Ast.loc_of_ctyp - in - match t with - | Ast.TyDcl (_, tn, tp, te, cl) -> - (pp f "@[<2>%a%a@]" o#var tn o#type_params tp; - (match te with - | Ast.TyNil _ -> () - | _ -> pp f " =@ %a" o#ctyp te); - if cl <> [] - then pp f "@ %a" (list o#constrain "@ ") cl - else ()) - | Ast.TyCol (_, t1, (Ast.TyMut (_, t2))) -> - pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2 - | Ast.TyMan (_, t1, t2) -> - pp f "@[<2>%a ==@ %a@]" o#simple_ctyp t1 o#ctyp t2 - | t -> super#ctyp f t - method simple_ctyp = - fun f t -> - let () = o#node f t Ast.loc_of_ctyp - in - match t with - | Ast.TyVrnEq (_, t) -> - pp f "@[<2>[ =@ %a@]@ ]" o#ctyp t - | Ast.TyVrnInf (_, t) -> - pp f "@[<2>[ <@ %a@]@,]" o#ctyp t - | Ast.TyVrnInfSup (_, t1, t2) -> - pp f "@[<2>[ <@ %a@ >@ %a@]@ ]" o#ctyp t1 o#ctyp t2 - | Ast.TyVrnSup (_, t) -> - pp f "@[<2>[ >@ %a@]@,]" o#ctyp t - | Ast.TyMan (_, t1, t2) -> - pp f "@[<2>%a@ ==@ %a@]" o#simple_ctyp t1 - o#simple_ctyp t2 - | Ast.TyLab (_, s, t) -> - pp f "@[<2>~%s:@ %a@]" s o#simple_ctyp t - | t -> super#simple_ctyp f t - method ctyp1 = - fun f -> - function - | Ast.TyApp (_, t1, t2) -> - (match get_ctyp_args t1 [ t2 ] with - | (_, [ _ ]) -> - pp f "@[<2>%a@ %a@]" o#simple_ctyp t1 - o#simple_ctyp t2 - | (a, al) -> - pp f "@[<2>%a@]" (list o#simple_ctyp "@ ") - (a :: al)) - | Ast.TyPol (_, t1, t2) -> - let (a, al) = get_ctyp_args t1 [] - in - pp f "@[<2>! %a.@ %a@]" (list o#ctyp "@ ") - (a :: al) o#ctyp t2 - | t -> super#ctyp1 f t - method constructor_type = - fun f t -> - match t with - | Ast.TyAnd (loc, t1, t2) -> - let () = o#node f t (fun _ -> loc) - in - pp f "%a@ and %a" o#constructor_type t1 - o#constructor_type t2 - | t -> o#ctyp f t - method str_item = - fun f st -> - match st with - | Ast.StExp (_, e) -> - pp f "@[<2>%a%(%)@]" o#expr e semisep - | st -> super#str_item f st - method module_expr = - fun f me -> - let () = o#node f me Ast.loc_of_module_expr - in - match me with - | Ast.MeApp (_, me1, me2) -> - pp f "@[<2>%a@ %a@]" o#module_expr me1 - o#simple_module_expr me2 - | me -> super#module_expr f me - method simple_module_expr = - fun f me -> - let () = o#node f me Ast.loc_of_module_expr - in - match me with - | Ast.MeApp (_, _, _) -> pp f "(%a)" o#module_expr me - | _ -> super#simple_module_expr f me - method implem = fun f st -> pp f "@[%a@]@." o#str_item st - method class_type = - fun f ct -> - let () = o#node f ct Ast.loc_of_class_type - in - match ct with - | Ast.CtFun (_, t, ct) -> - pp f "@[<2>[ %a ] ->@ %a@]" o#simple_ctyp t - o#class_type ct - | Ast.CtCon (_, Ast.ViNil, i, (Ast.TyNil _)) -> - pp f "@[<2>%a@]" o#ident i - | Ast.CtCon (_, Ast.ViNil, i, t) -> - pp f "@[<2>%a [@,%a@]@,]" o#ident i o#class_params - t - | Ast.CtCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), - (Ast.TyNil _)) -> pp f "@[<2>virtual@ %a@]" o#var i - | Ast.CtCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) - -> - pp f "@[<2>virtual@ %a@ [@,%a@]@,]" o#var i - o#class_params t - | ct -> super#class_type f ct - method class_expr = - fun f ce -> - let () = o#node f ce Ast.loc_of_class_expr - in - match ce with - | Ast.CeCon (_, Ast.ViNil, i, (Ast.TyNil _)) -> - pp f "@[<2>%a@]" o#ident i - | Ast.CeCon (_, Ast.ViNil, i, t) -> - pp f "@[<2>%a@ @[<1>[%a]@]@]" o#ident i - o#class_params t - | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), - (Ast.TyNil _)) -> pp f "@[<2>virtual@ %a@]" o#var i - | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) - -> - pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i - o#class_params t - | ce -> super#class_expr f ce - end - - let with_outfile = with_outfile - - let print output_file fct = - let o = new printer () in with_outfile output_file (fct o) - - let print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg - - let print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st - - end - - module MakeMore (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax. - Ast).S = - struct - include Make(Syntax) - - let margin = ref 78 - - let comments = ref true - - let locations = ref false - - let curry_constr = ref true - - let print output_file fct = - let o = - new printer ~comments: !comments ~curry_constr: !curry_constr - () in - let o = if !locations then o#set_loc_and_comments else o - in - with_outfile output_file - (fun f -> - let () = Format.pp_set_margin f !margin - in Format.fprintf f "@[%a@]@." (fct o)) - - let print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg - - let print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st - - let _ = - Options.add "-l" (Arg.Int (fun i -> margin := i)) - " line length for pretty printing." - - let _ = - Options.add "-no_comments" (Arg.Clear comments) - "Do not add comments." - - let _ = - Options.add "-add_locations" (Arg.Set locations) - "Add locations as comment." - - end - - end - - end - -module OCamlInitSyntax = - struct - module Make - (Ast : Sig.Camlp4Ast) - (Gram : - Sig.Grammar.Static with module Loc = Ast.Loc with - type Token.t = Sig.camlp4_token) - (Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst(Ast)) : - Sig.Camlp4Syntax with module Loc = Ast.Loc and module Ast = Ast - and module Token = Gram.Token and module Gram = Gram - and module Quotation = Quotation = - struct - module Loc = Ast.Loc - - module Ast = Ast - - module Gram = Gram - - module Token = Gram.Token - - open Sig - - type warning = Loc.t -> string -> unit - - let default_warning loc txt = - Format.eprintf " %a: %s@." Loc.print loc txt - - let current_warning = ref default_warning - - let print_warning loc txt = !current_warning loc txt - - let a_CHAR = Gram.Entry.mk "a_CHAR" - - let a_FLOAT = Gram.Entry.mk "a_FLOAT" - - let a_INT = Gram.Entry.mk "a_INT" - - let a_INT32 = Gram.Entry.mk "a_INT32" - - let a_INT64 = Gram.Entry.mk "a_INT64" - - let a_LABEL = Gram.Entry.mk "a_LABEL" - - let a_LIDENT = Gram.Entry.mk "a_LIDENT" - - let a_NATIVEINT = Gram.Entry.mk "a_NATIVEINT" - - let a_OPTLABEL = Gram.Entry.mk "a_OPTLABEL" - - let a_STRING = Gram.Entry.mk "a_STRING" - - let a_UIDENT = Gram.Entry.mk "a_UIDENT" - - let a_ident = Gram.Entry.mk "a_ident" - - let amp_ctyp = Gram.Entry.mk "amp_ctyp" - - let and_ctyp = Gram.Entry.mk "and_ctyp" - - let match_case = Gram.Entry.mk "match_case" - - let match_case0 = Gram.Entry.mk "match_case0" - - let binding = Gram.Entry.mk "binding" - - let class_declaration = Gram.Entry.mk "class_declaration" - - let class_description = Gram.Entry.mk "class_description" - - let class_expr = Gram.Entry.mk "class_expr" - - let class_fun_binding = Gram.Entry.mk "class_fun_binding" - - let class_fun_def = Gram.Entry.mk "class_fun_def" - - let class_info_for_class_expr = - Gram.Entry.mk "class_info_for_class_expr" - - let class_info_for_class_type = - Gram.Entry.mk "class_info_for_class_type" - - let class_longident = Gram.Entry.mk "class_longident" - - let class_longident_and_param = - Gram.Entry.mk "class_longident_and_param" - - let class_name_and_param = Gram.Entry.mk "class_name_and_param" - - let class_sig_item = Gram.Entry.mk "class_sig_item" - - let class_signature = Gram.Entry.mk "class_signature" - - let class_str_item = Gram.Entry.mk "class_str_item" - - let class_structure = Gram.Entry.mk "class_structure" - - let class_type = Gram.Entry.mk "class_type" - - let class_type_declaration = Gram.Entry.mk "class_type_declaration" - - let class_type_longident = Gram.Entry.mk "class_type_longident" - - let class_type_longident_and_param = - Gram.Entry.mk "class_type_longident_and_param" - - let class_type_plus = Gram.Entry.mk "class_type_plus" - - let comma_ctyp = Gram.Entry.mk "comma_ctyp" - - let comma_expr = Gram.Entry.mk "comma_expr" - - let comma_ipatt = Gram.Entry.mk "comma_ipatt" - - let comma_patt = Gram.Entry.mk "comma_patt" - - let comma_type_parameter = Gram.Entry.mk "comma_type_parameter" - - let constrain = Gram.Entry.mk "constrain" - - let constructor_arg_list = Gram.Entry.mk "constructor_arg_list" - - let constructor_declaration = Gram.Entry.mk "constructor_declaration" - - let constructor_declarations = - Gram.Entry.mk "constructor_declarations" - - let ctyp = Gram.Entry.mk "ctyp" - - let cvalue_binding = Gram.Entry.mk "cvalue_binding" - - let direction_flag = Gram.Entry.mk "direction_flag" - - let direction_flag_quot = Gram.Entry.mk "direction_flag_quot" - - let dummy = Gram.Entry.mk "dummy" - - let entry_eoi = Gram.Entry.mk "entry_eoi" - - let eq_expr = Gram.Entry.mk "eq_expr" - - let expr = Gram.Entry.mk "expr" - - let expr_eoi = Gram.Entry.mk "expr_eoi" - - let field_expr = Gram.Entry.mk "field_expr" - - let field_expr_list = Gram.Entry.mk "field_expr_list" - - let fun_binding = Gram.Entry.mk "fun_binding" - - let fun_def = Gram.Entry.mk "fun_def" - - let ident = Gram.Entry.mk "ident" - - let implem = Gram.Entry.mk "implem" - - let interf = Gram.Entry.mk "interf" - - let ipatt = Gram.Entry.mk "ipatt" - - let ipatt_tcon = Gram.Entry.mk "ipatt_tcon" - - let label = Gram.Entry.mk "label" - - let label_declaration = Gram.Entry.mk "label_declaration" - - let label_declaration_list = Gram.Entry.mk "label_declaration_list" - - let label_expr = Gram.Entry.mk "label_expr" - - let label_expr_list = Gram.Entry.mk "label_expr_list" - - let label_ipatt = Gram.Entry.mk "label_ipatt" - - let label_ipatt_list = Gram.Entry.mk "label_ipatt_list" - - let label_longident = Gram.Entry.mk "label_longident" - - let label_patt = Gram.Entry.mk "label_patt" - - let label_patt_list = Gram.Entry.mk "label_patt_list" - - let labeled_ipatt = Gram.Entry.mk "labeled_ipatt" - - let let_binding = Gram.Entry.mk "let_binding" - - let meth_list = Gram.Entry.mk "meth_list" - - let meth_decl = Gram.Entry.mk "meth_decl" - - let module_binding = Gram.Entry.mk "module_binding" - - let module_binding0 = Gram.Entry.mk "module_binding0" - - let module_declaration = Gram.Entry.mk "module_declaration" - - let module_expr = Gram.Entry.mk "module_expr" - - let module_longident = Gram.Entry.mk "module_longident" - - let module_longident_with_app = - Gram.Entry.mk "module_longident_with_app" - - let module_rec_declaration = Gram.Entry.mk "module_rec_declaration" - - let module_type = Gram.Entry.mk "module_type" - - let package_type = Gram.Entry.mk "package_type" - - let more_ctyp = Gram.Entry.mk "more_ctyp" - - let name_tags = Gram.Entry.mk "name_tags" - - let opt_as_lident = Gram.Entry.mk "opt_as_lident" - - let opt_class_self_patt = Gram.Entry.mk "opt_class_self_patt" - - let opt_class_self_type = Gram.Entry.mk "opt_class_self_type" - - let opt_class_signature = Gram.Entry.mk "opt_class_signature" - - let opt_class_structure = Gram.Entry.mk "opt_class_structure" - - let opt_comma_ctyp = Gram.Entry.mk "opt_comma_ctyp" - - let opt_dot_dot = Gram.Entry.mk "opt_dot_dot" - - let row_var_flag_quot = Gram.Entry.mk "row_var_flag_quot" - - let opt_eq_ctyp = Gram.Entry.mk "opt_eq_ctyp" - - let opt_expr = Gram.Entry.mk "opt_expr" - - let opt_meth_list = Gram.Entry.mk "opt_meth_list" - - let opt_mutable = Gram.Entry.mk "opt_mutable" - - let mutable_flag_quot = Gram.Entry.mk "mutable_flag_quot" - - let opt_polyt = Gram.Entry.mk "opt_polyt" - - let opt_private = Gram.Entry.mk "opt_private" - - let private_flag_quot = Gram.Entry.mk "private_flag_quot" - - let opt_rec = Gram.Entry.mk "opt_rec" - - let rec_flag_quot = Gram.Entry.mk "rec_flag_quot" - - let opt_sig_items = Gram.Entry.mk "opt_sig_items" - - let opt_str_items = Gram.Entry.mk "opt_str_items" - - let opt_virtual = Gram.Entry.mk "opt_virtual" - - let virtual_flag_quot = Gram.Entry.mk "virtual_flag_quot" - - let opt_override = Gram.Entry.mk "opt_override" - - let override_flag_quot = Gram.Entry.mk "override_flag_quot" - - let opt_when_expr = Gram.Entry.mk "opt_when_expr" - - let patt = Gram.Entry.mk "patt" - - let patt_as_patt_opt = Gram.Entry.mk "patt_as_patt_opt" - - let patt_eoi = Gram.Entry.mk "patt_eoi" - - let patt_tcon = Gram.Entry.mk "patt_tcon" - - let phrase = Gram.Entry.mk "phrase" - - let poly_type = Gram.Entry.mk "poly_type" - - let row_field = Gram.Entry.mk "row_field" - - let sem_expr = Gram.Entry.mk "sem_expr" - - let sem_expr_for_list = Gram.Entry.mk "sem_expr_for_list" - - let sem_patt = Gram.Entry.mk "sem_patt" - - let sem_patt_for_list = Gram.Entry.mk "sem_patt_for_list" - - let semi = Gram.Entry.mk "semi" - - let sequence = Gram.Entry.mk "sequence" - - let do_sequence = Gram.Entry.mk "do_sequence" - - let sig_item = Gram.Entry.mk "sig_item" - - let sig_items = Gram.Entry.mk "sig_items" - - let star_ctyp = Gram.Entry.mk "star_ctyp" - - let str_item = Gram.Entry.mk "str_item" - - let str_items = Gram.Entry.mk "str_items" - - let top_phrase = Gram.Entry.mk "top_phrase" - - let type_constraint = Gram.Entry.mk "type_constraint" - - let type_declaration = Gram.Entry.mk "type_declaration" - - let type_ident_and_parameters = - Gram.Entry.mk "type_ident_and_parameters" - - let type_kind = Gram.Entry.mk "type_kind" - - let type_longident = Gram.Entry.mk "type_longident" - - let type_longident_and_parameters = - Gram.Entry.mk "type_longident_and_parameters" - - let type_parameter = Gram.Entry.mk "type_parameter" - - let type_parameters = Gram.Entry.mk "type_parameters" - - let typevars = Gram.Entry.mk "typevars" - - let use_file = Gram.Entry.mk "use_file" - - let val_longident = Gram.Entry.mk "val_longident" - - let value_let = Gram.Entry.mk "value_let" - - let value_val = Gram.Entry.mk "value_val" - - let with_constr = Gram.Entry.mk "with_constr" - - let expr_quot = Gram.Entry.mk "quotation of expression" - - let patt_quot = Gram.Entry.mk "quotation of pattern" - - let ctyp_quot = Gram.Entry.mk "quotation of type" - - let str_item_quot = Gram.Entry.mk "quotation of structure item" - - let sig_item_quot = Gram.Entry.mk "quotation of signature item" - - let class_str_item_quot = - Gram.Entry.mk "quotation of class structure item" - - let class_sig_item_quot = - Gram.Entry.mk "quotation of class signature item" - - let module_expr_quot = Gram.Entry.mk "quotation of module expression" - - let module_type_quot = Gram.Entry.mk "quotation of module type" - - let class_type_quot = Gram.Entry.mk "quotation of class type" - - let class_expr_quot = Gram.Entry.mk "quotation of class expression" - - let with_constr_quot = Gram.Entry.mk "quotation of with constraint" - - let binding_quot = Gram.Entry.mk "quotation of binding" - - let rec_binding_quot = Gram.Entry.mk "quotation of record binding" - - let match_case_quot = - Gram.Entry.mk "quotation of match_case (try/match/function case)" - - let module_binding_quot = - Gram.Entry.mk "quotation of module rec binding" - - let ident_quot = Gram.Entry.mk "quotation of identifier" - - let prefixop = - Gram.Entry.mk "prefix operator (start with '!', '?', '~')" - - let infixop0 = - Gram.Entry.mk - "infix operator (level 0) (comparison operators, and some others)" - - let infixop1 = - Gram.Entry.mk "infix operator (level 1) (start with '^', '@')" - - let infixop2 = - Gram.Entry.mk "infix operator (level 2) (start with '+', '-')" - - let infixop3 = - Gram.Entry.mk "infix operator (level 3) (start with '*', '/', '%')" - - let infixop4 = - Gram.Entry.mk - "infix operator (level 4) (start with \"**\") (right assoc)" - - let _ = - Gram.extend (top_phrase : 'top_phrase Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (None : 'top_phrase) - | _ -> assert false))) ]) ])) - ()) - - module AntiquotSyntax = - struct - module Loc = Ast.Loc - - module Ast = Sig.Camlp4AstToAst(Ast) - - module Gram = Gram - - let antiquot_expr = Gram.Entry.mk "antiquot_expr" - - let antiquot_patt = Gram.Entry.mk "antiquot_patt" - - let _ = - (Gram.extend (antiquot_expr : 'antiquot_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) (x : 'expr) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (x : 'antiquot_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (antiquot_patt : 'antiquot_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) (x : 'patt) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (x : 'antiquot_patt) - | _ -> assert false))) ]) ])) - ())) - - let parse_expr loc str = Gram.parse_string antiquot_expr loc str - - let parse_patt loc str = Gram.parse_string antiquot_patt loc str - - end - - module Quotation = Quotation - - let wrap directive_handler pa init_loc cs = - let rec loop loc = - let (pl, stopped_at_directive) = pa loc cs - in - match stopped_at_directive with - | Some new_loc -> - let pl = - (match List.rev pl with - | [] -> assert false - | x :: xs -> - (match directive_handler x with - | None -> xs - | Some x -> x :: xs)) - in (List.rev pl) @ (loop new_loc) - | None -> pl - in loop init_loc - - let parse_implem ?(directive_handler = fun _ -> None) _loc cs = - let l = wrap directive_handler (Gram.parse implem) _loc cs - in Ast.stSem_of_list l - - let parse_interf ?(directive_handler = fun _ -> None) _loc cs = - let l = wrap directive_handler (Gram.parse interf) _loc cs - in Ast.sgSem_of_list l - - let print_interf ?input_file:(_) ?output_file:(_) _ = - failwith "No interface printer" - - let print_implem ?input_file:(_) ?output_file:(_) _ = - failwith "No implementation printer" - - end - - end - -module PreCast : - sig - type camlp4_token = - Sig.camlp4_token = - | KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int * string - | INT32 of int32 * string - | INT64 of int64 * string - | NATIVEINT of nativeint * string - | FLOAT of float * string - | CHAR of char * string - | STRING of string * string - | LABEL of string - | OPTLABEL of string - | QUOTATION of Sig.quotation - | ANTIQUOT of string * string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int * string option - | EOI - - module Id : Sig.Id - - module Loc : Sig.Loc - - module Ast : Sig.Camlp4Ast with module Loc = Loc - - module Token : Sig.Token with module Loc = Loc and type t = camlp4_token - - module Lexer : Sig.Lexer with module Loc = Loc and module Token = Token - - module Gram : Sig.Grammar.Static with module Loc = Loc - and module Token = Token - - module Quotation : - Sig.Quotation with module Ast = Sig.Camlp4AstToAst(Ast) - - module DynLoader : Sig.DynLoader - - module AstFilters : Sig.AstFilters with module Ast = Ast - - module Syntax : Sig.Camlp4Syntax with module Loc = Loc - and module Token = Token and module Ast = Ast and module Gram = Gram - and module Quotation = Quotation - - module Printers : - sig - module OCaml : Sig.Printer(Ast).S - - module OCamlr : Sig.Printer(Ast).S - - module DumpOCamlAst : Sig.Printer(Ast).S - - module DumpCamlp4Ast : Sig.Printer(Ast).S - - module Null : Sig.Printer(Ast).S - - end - - module MakeGram (Lexer : Sig.Lexer with module Loc = Loc) : - Sig.Grammar.Static with module Loc = Loc and module Token = Lexer.Token - - module MakeSyntax (U : sig end) : Sig.Syntax - - end = - struct - module Id = - struct let name = "Camlp4.PreCast" - let version = Sys.ocaml_version - end - - type camlp4_token = - Sig.camlp4_token = - | KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int * string - | INT32 of int32 * string - | INT64 of int64 * string - | NATIVEINT of nativeint * string - | FLOAT of float * string - | CHAR of char * string - | STRING of string * string - | LABEL of string - | OPTLABEL of string - | QUOTATION of Sig.quotation - | ANTIQUOT of string * string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int * string option - | EOI - - module Loc = Struct.Loc - - module Ast = Struct.Camlp4Ast.Make(Loc) - - module Token = Struct.Token.Make(Loc) - - module Lexer = Struct.Lexer.Make(Token) - - module Gram = Struct.Grammar.Static.Make(Lexer) - - module DynLoader = Struct.DynLoader - - module Quotation = Struct.Quotation.Make(Ast) - - module MakeSyntax (U : sig end) = - OCamlInitSyntax.Make(Ast)(Gram)(Quotation) - - module Syntax = MakeSyntax(struct end) - - module AstFilters = Struct.AstFilters.Make(Ast) - - module MakeGram = Struct.Grammar.Static.Make - - module Printers = - struct - module OCaml = Printers.OCaml.Make(Syntax) - - module OCamlr = Printers.OCamlr.Make(Syntax) - - module DumpOCamlAst = Printers.DumpOCamlAst.Make(Syntax) - - module DumpCamlp4Ast = Printers.DumpCamlp4Ast.Make(Syntax) - - module Null = Printers.Null.Make(Syntax) - - end - - end - -module Register : - sig - module Plugin - (Id : Sig.Id) (Plugin : functor (Unit : sig end) -> sig end) : - sig end - - module SyntaxPlugin - (Id : Sig.Id) (SyntaxPlugin : functor (Syn : Sig.Syntax) -> sig end) : - sig end - - module SyntaxExtension - (Id : Sig.Id) (SyntaxExtension : Sig.SyntaxExtension) : sig end - - module OCamlSyntaxExtension - (Id : Sig.Id) - (SyntaxExtension : - functor (Syntax : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) : - sig end - - type 'a parser_fun = - ?directive_handler: ('a -> 'a option) -> - PreCast.Loc.t -> char Stream.t -> 'a - - val register_str_item_parser : PreCast.Ast.str_item parser_fun -> unit - - val register_sig_item_parser : PreCast.Ast.sig_item parser_fun -> unit - - val register_parser : - PreCast.Ast.str_item parser_fun -> - PreCast.Ast.sig_item parser_fun -> unit - - val current_parser : - unit -> - ((PreCast.Ast.str_item parser_fun) * - (PreCast.Ast.sig_item parser_fun)) - - module Parser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> Sig.Parser(Ast).S) : - sig end - - module OCamlParser - (Id : Sig.Id) - (Maker : functor (Ast : Sig.Camlp4Ast) -> Sig.Parser(Ast).S) : - sig end - - module OCamlPreCastParser - (Id : Sig.Id) (Parser : Sig.Parser(PreCast.Ast).S) : sig end - - type 'a printer_fun = - ?input_file: string -> ?output_file: string -> 'a -> unit - - val register_str_item_printer : PreCast.Ast.str_item printer_fun -> unit - - val register_sig_item_printer : PreCast.Ast.sig_item printer_fun -> unit - - val register_printer : - PreCast.Ast.str_item printer_fun -> - PreCast.Ast.sig_item printer_fun -> unit - - val current_printer : - unit -> - ((PreCast.Ast.str_item printer_fun) * - (PreCast.Ast.sig_item printer_fun)) - - module Printer - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Syntax) -> Sig.Printer(Syn.Ast).S) : - sig end - - module OCamlPrinter - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Printer(Syn.Ast).S) : - sig end - - module OCamlPreCastPrinter - (Id : Sig.Id) (Printer : Sig.Printer(PreCast.Ast).S) : sig end - - module AstFilter - (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) : - sig end - - val declare_dyn_module : string -> (unit -> unit) -> unit - - val iter_and_take_callbacks : ((string * (unit -> unit)) -> unit) -> unit - - val loaded_modules : (string list) ref - - module CurrentParser : Sig.Parser(PreCast.Ast).S - - module CurrentPrinter : Sig.Printer(PreCast.Ast).S - - val enable_ocaml_printer : unit -> unit - - val enable_ocamlr_printer : unit -> unit - - val enable_null_printer : unit -> unit - - val enable_dump_ocaml_ast_printer : unit -> unit - - val enable_dump_camlp4_ast_printer : unit -> unit - - end = - struct - module PP = Printers - - open PreCast - - type 'a parser_fun = - ?directive_handler: ('a -> 'a option) -> - PreCast.Loc.t -> char Stream.t -> 'a - - type 'a printer_fun = - ?input_file: string -> ?output_file: string -> 'a -> unit - - let sig_item_parser = - ref (fun ?directive_handler:(_) _ _ -> failwith "No interface parser") - - let str_item_parser = - ref - (fun ?directive_handler:(_) _ _ -> - failwith "No implementation parser") - - let sig_item_printer = - ref - (fun ?input_file:(_) ?output_file:(_) _ -> - failwith "No interface printer") - - let str_item_printer = - ref - (fun ?input_file:(_) ?output_file:(_) _ -> - failwith "No implementation printer") - - let callbacks = Queue.create () - - let loaded_modules = ref [] - - let iter_and_take_callbacks f = - let rec loop () = loop (f (Queue.take callbacks)) - in try loop () with | Queue.Empty -> () - - let declare_dyn_module m f = - (loaded_modules := m :: !loaded_modules; Queue.add (m, f) callbacks) - - let register_str_item_parser f = str_item_parser := f - - let register_sig_item_parser f = sig_item_parser := f - - let register_parser f g = (str_item_parser := f; sig_item_parser := g) - - let current_parser () = ((!str_item_parser), (!sig_item_parser)) - - let register_str_item_printer f = str_item_printer := f - - let register_sig_item_printer f = sig_item_printer := f - - let register_printer f g = (str_item_printer := f; sig_item_printer := g) - - let current_printer () = ((!str_item_printer), (!sig_item_printer)) - - module Plugin - (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(struct end) in ()) - - end - - module SyntaxExtension (Id : Sig.Id) (Maker : Sig.SyntaxExtension) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(Syntax) in ()) - - end - - module OCamlSyntaxExtension - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(Syntax) in ()) - - end - - module SyntaxPlugin - (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) -> sig end) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(Syntax) in ()) - - end - - module Printer - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Syntax) -> Sig.Printer(Syn.Ast).S) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(Syntax) - in register_printer M.print_implem M.print_interf) - - end - - module OCamlPrinter - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Printer(Syn.Ast).S) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(Syntax) - in register_printer M.print_implem M.print_interf) - - end - - module OCamlPreCastPrinter - (Id : Sig.Id) (P : Sig.Printer(PreCast.Ast).S) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> register_printer P.print_implem P.print_interf) - - end - - module Parser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> Sig.Parser(Ast).S) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(PreCast.Ast) - in register_parser M.parse_implem M.parse_interf) - - end - - module OCamlParser - (Id : Sig.Id) - (Maker : functor (Ast : Sig.Camlp4Ast) -> Sig.Parser(Ast).S) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(PreCast.Ast) - in register_parser M.parse_implem M.parse_interf) - - end - - module OCamlPreCastParser (Id : Sig.Id) (P : Sig.Parser(PreCast.Ast).S) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> register_parser P.parse_implem P.parse_interf) - - end - - module AstFilter - (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(AstFilters) in ()) - - end - - let _ = sig_item_parser := Syntax.parse_interf - - let _ = str_item_parser := Syntax.parse_implem - - module CurrentParser = - struct - module Ast = Ast - - let parse_interf ?directive_handler loc strm = - !sig_item_parser ?directive_handler loc strm - - let parse_implem ?directive_handler loc strm = - !str_item_parser ?directive_handler loc strm - - end - - module CurrentPrinter = - struct - module Ast = Ast - - let print_interf ?input_file ?output_file ast = - !sig_item_printer ?input_file ?output_file ast - - let print_implem ?input_file ?output_file ast = - !str_item_printer ?input_file ?output_file ast - - end - - let enable_ocaml_printer () = - let module M = OCamlPrinter(PP.OCaml.Id)(PP.OCaml.MakeMore) in () - - let enable_ocamlr_printer () = - let module M = OCamlPrinter(PP.OCamlr.Id)(PP.OCamlr.MakeMore) in () - - let enable_dump_ocaml_ast_printer () = - let module M = OCamlPrinter(PP.DumpOCamlAst.Id)(PP.DumpOCamlAst.Make) - in () - - let enable_dump_camlp4_ast_printer () = - let module M = Printer(PP.DumpCamlp4Ast.Id)(PP.DumpCamlp4Ast.Make) - in () - - let enable_null_printer () = - let module M = Printer(PP.Null.Id)(PP.Null.Make) in () - - end - - diff -Nru ocaml-4.01.0/camlp4/boot/Camlp4.ml4 ocaml-4.05.0/camlp4/boot/Camlp4.ml4 --- ocaml-4.01.0/camlp4/boot/Camlp4.ml4 2012-08-02 08:17:59.000000000 +0000 +++ ocaml-4.05.0/camlp4/boot/Camlp4.ml4 1970-01-01 00:00:00.000000000 +0000 @@ -1,78 +0,0 @@ -module Debug : sig INCLUDE "camlp4/Camlp4/Debug.mli"; end = struct INCLUDE "camlp4/Camlp4/Debug.ml"; end; -module Options : sig INCLUDE "camlp4/Camlp4/Options.mli"; end = struct INCLUDE "camlp4/Camlp4/Options.ml"; end; -module Sig = struct INCLUDE "camlp4/Camlp4/Sig.ml"; end; -module ErrorHandler : sig INCLUDE "camlp4/Camlp4/ErrorHandler.mli"; end = struct INCLUDE "camlp4/Camlp4/ErrorHandler.ml"; end; - -module Struct = struct - module Loc : - sig INCLUDE "camlp4/Camlp4/Struct/Loc.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/Loc.ml"; end; - module Token : - sig INCLUDE "camlp4/Camlp4/Struct/Token.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/Token.ml"; end; - module Lexer = struct INCLUDE "camlp4/boot/Lexer.ml"; end; - module Camlp4Ast = struct INCLUDE "camlp4/Camlp4/Struct/Camlp4Ast.ml"; end; - module DynAst = struct INCLUDE "camlp4/Camlp4/Struct/DynAst.ml"; end; - module Quotation = struct INCLUDE "camlp4/Camlp4/Struct/Quotation.ml"; end; - module AstFilters = struct INCLUDE "camlp4/Camlp4/Struct/AstFilters.ml"; end; - module Camlp4Ast2OCamlAst : - sig INCLUDE "camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml"; end; - module CleanAst = struct INCLUDE "camlp4/Camlp4/Struct/CleanAst.ml"; end; - module CommentFilter : - sig INCLUDE "camlp4/Camlp4/Struct/CommentFilter.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/CommentFilter.ml"; end; - module DynLoader : - sig INCLUDE "camlp4/Camlp4/Struct/DynLoader.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/DynLoader.ml"; end; - module EmptyError : - sig INCLUDE "camlp4/Camlp4/Struct/EmptyError.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/EmptyError.ml"; end; - module EmptyPrinter : - sig INCLUDE "camlp4/Camlp4/Struct/EmptyPrinter.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/EmptyPrinter.ml"; end; - module FreeVars : - sig INCLUDE "camlp4/Camlp4/Struct/FreeVars.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/FreeVars.ml"; end; - module Grammar = struct - module Structure = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Structure.ml"; end; - module Search = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Search.ml"; end; - (* module Find = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Find.ml"; end; *) - module Tools = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Tools.ml"; end; - module Print : - sig INCLUDE "camlp4/Camlp4/Struct/Grammar/Print.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Print.ml"; end; - module Failed = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Failed.ml"; end; - module Parser = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Parser.ml"; end; - module Insert = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Insert.ml"; end; - module Delete = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Delete.ml"; end; - module Fold : - sig INCLUDE "camlp4/Camlp4/Struct/Grammar/Fold.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Fold.ml"; end; - module Entry = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Entry.ml"; end; - module Static = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Static.ml"; end; - module Dynamic = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Dynamic.ml"; end; - end; -end; - -module Printers = struct - module DumpCamlp4Ast : - sig INCLUDE "camlp4/Camlp4/Printers/DumpCamlp4Ast.mli"; end = - struct INCLUDE "camlp4/Camlp4/Printers/DumpCamlp4Ast.ml"; end; - module DumpOCamlAst : - sig INCLUDE "camlp4/Camlp4/Printers/DumpOCamlAst.mli"; end = - struct INCLUDE "camlp4/Camlp4/Printers/DumpOCamlAst.ml"; end; - module Null : - sig INCLUDE "camlp4/Camlp4/Printers/Null.mli"; end = - struct INCLUDE "camlp4/Camlp4/Printers/Null.ml"; end; - module OCaml : - sig INCLUDE "camlp4/Camlp4/Printers/OCaml.mli"; end = - struct INCLUDE "camlp4/Camlp4/Printers/OCaml.ml"; end; - module OCamlr : - sig INCLUDE "camlp4/Camlp4/Printers/OCamlr.mli"; end = - struct INCLUDE "camlp4/Camlp4/Printers/OCamlr.ml"; end; -end; - -module OCamlInitSyntax = struct INCLUDE "camlp4/Camlp4/OCamlInitSyntax.ml"; end; -module PreCast : sig INCLUDE "camlp4/Camlp4/PreCast.mli"; end = struct INCLUDE "camlp4/Camlp4/PreCast.ml"; end; -module Register : sig INCLUDE "camlp4/Camlp4/Register.mli"; end = struct INCLUDE "camlp4/Camlp4/Register.ml"; end; diff -Nru ocaml-4.01.0/camlp4/boot/.ignore ocaml-4.05.0/camlp4/boot/.ignore --- ocaml-4.01.0/camlp4/boot/.ignore 2012-07-26 19:21:54.000000000 +0000 +++ ocaml-4.05.0/camlp4/boot/.ignore 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -camlp4 -camlp4o -camlp4r -SAVED -*.old diff -Nru ocaml-4.01.0/camlp4/build/.ignore ocaml-4.05.0/camlp4/build/.ignore --- ocaml-4.01.0/camlp4/build/.ignore 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/build/.ignore 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -camlp4_config.ml -location.ml -location.mli -terminfo.ml -terminfo.mli diff -Nru ocaml-4.01.0/camlp4/Camlp4/Camlp4Ast.partial.ml ocaml-4.05.0/camlp4/Camlp4/Camlp4Ast.partial.ml --- ocaml-4.01.0/camlp4/Camlp4/Camlp4Ast.partial.ml 2013-08-30 11:39:33.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Camlp4Ast.partial.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,412 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2007 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Note: when you modify these types you must increment - ast magic numbers defined in Camlp4_config.ml. *) - - type loc = Loc.t - and meta_bool = - [ BTrue - | BFalse - | BAnt of string ] - and rec_flag = - [ ReRecursive - | ReNil - | ReAnt of string ] - and direction_flag = - [ DiTo - | DiDownto - | DiAnt of string ] - and mutable_flag = - [ MuMutable - | MuNil - | MuAnt of string ] - and private_flag = - [ PrPrivate - | PrNil - | PrAnt of string ] - and virtual_flag = - [ ViVirtual - | ViNil - | ViAnt of string ] - and override_flag = - [ OvOverride - | OvNil - | OvAnt of string ] - and row_var_flag = - [ RvRowVar - | RvNil - | RvAnt of string ] - and meta_option 'a = - [ ONone - | OSome of 'a - | OAnt of string ] - and meta_list 'a = - [ LNil - | LCons of 'a and meta_list 'a - | LAnt of string ] - and ident = - [ IdAcc of loc and ident and ident (* i . i *) - | IdApp of loc and ident and ident (* i i *) - | IdLid of loc and string (* foo *) - | IdUid of loc and string (* Bar *) - | IdAnt of loc and string (* $s$ *) ] - and ctyp = - [ TyNil of loc - | TyAli of loc and ctyp and ctyp (* t as t *) (* list 'a as 'a *) - | TyAny of loc (* _ *) - | TyApp of loc and ctyp and ctyp (* t t *) (* list 'a *) - | TyArr of loc and ctyp and ctyp (* t -> t *) (* int -> string *) - | TyCls of loc and ident (* #i *) (* #point *) - | TyLab of loc and string and ctyp (* ~s:t *) - | TyId of loc and ident (* i *) (* Lazy.t *) - | TyMan of loc and ctyp and ctyp (* t == t *) (* type t = [ A | B ] == Foo.t *) - (* type t 'a 'b 'c = t constraint t = t constraint t = t *) - | TyDcl of loc and string and list ctyp and ctyp and list (ctyp * ctyp) - (* < (t)? (..)? > *) (* < move : int -> 'a .. > as 'a *) - | TyObj of loc and ctyp and row_var_flag - | TyOlb of loc and string and ctyp (* ?s:t *) - | TyPol of loc and ctyp and ctyp (* ! t . t *) (* ! 'a . list 'a -> 'a *) - | TyTypePol of loc and ctyp and ctyp (* type t . t *) (* type a . list a -> a *) - | TyQuo of loc and string (* 's *) - | TyQuP of loc and string (* +'s *) - | TyQuM of loc and string (* -'s *) - | TyAnP of loc (* +_ *) - | TyAnM of loc (* -_ *) - | TyVrn of loc and string (* `s *) - | TyRec of loc and ctyp (* { t } *) (* { foo : int ; bar : mutable string } *) - | TyCol of loc and ctyp and ctyp (* t : t *) - | TySem of loc and ctyp and ctyp (* t; t *) - | TyCom of loc and ctyp and ctyp (* t, t *) - | TySum of loc and ctyp (* [ t ] *) (* [ A of int and string | B ] *) - | TyOf of loc and ctyp and ctyp (* t of t *) (* A of int *) - | TyAnd of loc and ctyp and ctyp (* t and t *) - | TyOr of loc and ctyp and ctyp (* t | t *) - | TyPrv of loc and ctyp (* private t *) - | TyMut of loc and ctyp (* mutable t *) - | TyTup of loc and ctyp (* ( t ) *) (* (int * string) *) - | TySta of loc and ctyp and ctyp (* t * t *) - | TyVrnEq of loc and ctyp (* [ = t ] *) - | TyVrnSup of loc and ctyp (* [ > t ] *) - | TyVrnInf of loc and ctyp (* [ < t ] *) - | TyVrnInfSup of loc and ctyp and ctyp (* [ < t > t ] *) - | TyAmp of loc and ctyp and ctyp (* t & t *) - | TyOfAmp of loc and ctyp and ctyp (* t of & t *) - | TyPkg of loc and module_type (* (module S) *) - | TyAnt of loc and string (* $s$ *) - ] - and patt = - [ PaNil of loc - | PaId of loc and ident (* i *) - | PaAli of loc and patt and patt (* p as p *) (* (Node x y as n) *) - | PaAnt of loc and string (* $s$ *) - | PaAny of loc (* _ *) - | PaApp of loc and patt and patt (* p p *) (* fun x y -> *) - | PaArr of loc and patt (* [| p |] *) - | PaCom of loc and patt and patt (* p, p *) - | PaSem of loc and patt and patt (* p; p *) - | PaChr of loc and string (* c *) (* 'x' *) - | PaInt of loc and string - | PaInt32 of loc and string - | PaInt64 of loc and string - | PaNativeInt of loc and string - | PaFlo of loc and string - | PaLab of loc and string and patt (* ~s or ~s:(p) *) - (* ?s or ?s:(p) *) - | PaOlb of loc and string and patt - (* ?s:(p = e) or ?(p = e) *) - | PaOlbi of loc and string and patt and expr - | PaOrp of loc and patt and patt (* p | p *) - | PaRng of loc and patt and patt (* p .. p *) - | PaRec of loc and patt (* { p } *) - | PaEq of loc and ident and patt (* i = p *) - | PaStr of loc and string (* s *) - | PaTup of loc and patt (* ( p ) *) - | PaTyc of loc and patt and ctyp (* (p : t) *) - | PaTyp of loc and ident (* #i *) - | PaVrn of loc and string (* `s *) - | PaLaz of loc and patt (* lazy p *) - | PaMod of loc and string (* (module M) *) ] - and expr = - [ ExNil of loc - | ExId of loc and ident (* i *) - | ExAcc of loc and expr and expr (* e.e *) - | ExAnt of loc and string (* $s$ *) - | ExApp of loc and expr and expr (* e e *) - | ExAre of loc and expr and expr (* e.(e) *) - | ExArr of loc and expr (* [| e |] *) - | ExSem of loc and expr and expr (* e; e *) - | ExAsf of loc (* assert False *) - | ExAsr of loc and expr (* assert e *) - | ExAss of loc and expr and expr (* e := e *) - | ExChr of loc and string (* 'c' *) - | ExCoe of loc and expr and ctyp and ctyp (* (e : t) or (e : t :> t) *) - | ExFlo of loc and string (* 3.14 *) - (* for s = e to/downto e do { e } *) - | ExFor of loc and string and expr and expr and direction_flag and expr - | ExFun of loc and match_case (* fun [ mc ] *) - | ExIfe of loc and expr and expr and expr (* if e then e else e *) - | ExInt of loc and string (* 42 *) - | ExInt32 of loc and string - | ExInt64 of loc and string - | ExNativeInt of loc and string - | ExLab of loc and string and expr (* ~s or ~s:e *) - | ExLaz of loc and expr (* lazy e *) - (* let b in e or let rec b in e *) - | ExLet of loc and rec_flag and binding and expr - (* let module s = me in e *) - | ExLmd of loc and string and module_expr and expr - (* match e with [ mc ] *) - | ExMat of loc and expr and match_case - (* new i *) - | ExNew of loc and ident - (* object ((p))? (cst)? end *) - | ExObj of loc and patt and class_str_item - (* ?s or ?s:e *) - | ExOlb of loc and string and expr - (* {< rb >} *) - | ExOvr of loc and rec_binding - (* { rb } or { (e) with rb } *) - | ExRec of loc and rec_binding and expr - (* do { e } *) - | ExSeq of loc and expr - (* e#s *) - | ExSnd of loc and expr and string - (* e.[e] *) - | ExSte of loc and expr and expr - (* s *) (* "foo" *) - | ExStr of loc and string - (* try e with [ mc ] *) - | ExTry of loc and expr and match_case - (* (e) *) - | ExTup of loc and expr - (* e, e *) - | ExCom of loc and expr and expr - (* (e : t) *) - | ExTyc of loc and expr and ctyp - (* `s *) - | ExVrn of loc and string - (* while e do { e } *) - | ExWhi of loc and expr and expr - (* let open i in e *) - | ExOpI of loc and ident and expr - (* fun (type t) -> e *) - (* let f x (type t) y z = e *) - | ExFUN of loc and string and expr - (* (module ME : S) which is represented as (module (ME : S)) *) - | ExPkg of loc and module_expr ] - and module_type = - [ MtNil of loc - (* i *) (* A.B.C *) - | MtId of loc and ident - (* functor (s : mt) -> mt *) - | MtFun of loc and string and module_type and module_type - (* 's *) - | MtQuo of loc and string - (* sig sg end *) - | MtSig of loc and sig_item - (* mt with wc *) - | MtWit of loc and module_type and with_constr - (* module type of m *) - | MtOf of loc and module_expr - | MtAnt of loc and string (* $s$ *) ] - and sig_item = - [ SgNil of loc - (* class cict *) - | SgCls of loc and class_type - (* class type cict *) - | SgClt of loc and class_type - (* sg ; sg *) - | SgSem of loc and sig_item and sig_item - (* # s or # s e *) - | SgDir of loc and string and expr - (* exception t *) - | SgExc of loc and ctyp - (* external s : t = s ... s *) - | SgExt of loc and string and ctyp and meta_list string - (* include mt *) - | SgInc of loc and module_type - (* module s : mt *) - | SgMod of loc and string and module_type - (* module rec mb *) - | SgRecMod of loc and module_binding - (* module type s = mt *) - | SgMty of loc and string and module_type - (* open i *) - | SgOpn of loc and ident - (* type t *) - | SgTyp of loc and ctyp - (* value s : t *) - | SgVal of loc and string and ctyp - | SgAnt of loc and string (* $s$ *) ] - and with_constr = - [ WcNil of loc - (* type t = t *) - | WcTyp of loc and ctyp and ctyp - (* module i = i *) - | WcMod of loc and ident and ident - (* type t := t *) - | WcTyS of loc and ctyp and ctyp - (* module i := i *) - | WcMoS of loc and ident and ident - (* wc and wc *) - | WcAnd of loc and with_constr and with_constr - | WcAnt of loc and string (* $s$ *) ] - and binding = - [ BiNil of loc - (* bi and bi *) (* let a = 42 and c = 43 *) - | BiAnd of loc and binding and binding - (* p = e *) (* let patt = expr *) - | BiEq of loc and patt and expr - | BiAnt of loc and string (* $s$ *) ] - and rec_binding = - [ RbNil of loc - (* rb ; rb *) - | RbSem of loc and rec_binding and rec_binding - (* i = e *) - | RbEq of loc and ident and expr - | RbAnt of loc and string (* $s$ *) ] - and module_binding = - [ MbNil of loc - (* mb and mb *) (* module rec (s : mt) = me and (s : mt) = me *) - | MbAnd of loc and module_binding and module_binding - (* s : mt = me *) - | MbColEq of loc and string and module_type and module_expr - (* s : mt *) - | MbCol of loc and string and module_type - | MbAnt of loc and string (* $s$ *) ] - and match_case = - [ McNil of loc - (* a | a *) - | McOr of loc and match_case and match_case - (* p (when e)? -> e *) - | McArr of loc and patt and expr and expr - | McAnt of loc and string (* $s$ *) ] - and module_expr = - [ MeNil of loc - (* i *) - | MeId of loc and ident - (* me me *) - | MeApp of loc and module_expr and module_expr - (* functor (s : mt) -> me *) - | MeFun of loc and string and module_type and module_expr - (* struct st end *) - | MeStr of loc and str_item - (* (me : mt) *) - | MeTyc of loc and module_expr and module_type - (* (value e) *) - (* (value e : S) which is represented as (value (e : S)) *) - | MePkg of loc and expr - | MeAnt of loc and string (* $s$ *) ] - and str_item = - [ StNil of loc - (* class cice *) - | StCls of loc and class_expr - (* class type cict *) - | StClt of loc and class_type - (* st ; st *) - | StSem of loc and str_item and str_item - (* # s or # s e *) - | StDir of loc and string and expr - (* exception t or exception t = i *) - | StExc of loc and ctyp and meta_option(*FIXME*) ident - (* e *) - | StExp of loc and expr - (* external s : t = s ... s *) - | StExt of loc and string and ctyp and meta_list string - (* include me *) - | StInc of loc and module_expr - (* module s = me *) - | StMod of loc and string and module_expr - (* module rec mb *) - | StRecMod of loc and module_binding - (* module type s = mt *) - | StMty of loc and string and module_type - (* open i *) - | StOpn of loc and ident - (* type t *) - | StTyp of loc and ctyp - (* value (rec)? bi *) - | StVal of loc and rec_flag and binding - | StAnt of loc and string (* $s$ *) ] - and class_type = - [ CtNil of loc - (* (virtual)? i ([ t ])? *) - | CtCon of loc and virtual_flag and ident and ctyp - (* [t] -> ct *) - | CtFun of loc and ctyp and class_type - (* object ((t))? (csg)? end *) - | CtSig of loc and ctyp and class_sig_item - (* ct and ct *) - | CtAnd of loc and class_type and class_type - (* ct : ct *) - | CtCol of loc and class_type and class_type - (* ct = ct *) - | CtEq of loc and class_type and class_type - (* $s$ *) - | CtAnt of loc and string ] - and class_sig_item = - [ CgNil of loc - (* type t = t *) - | CgCtr of loc and ctyp and ctyp - (* csg ; csg *) - | CgSem of loc and class_sig_item and class_sig_item - (* inherit ct *) - | CgInh of loc and class_type - (* method s : t or method private s : t *) - | CgMth of loc and string and private_flag and ctyp - (* value (virtual)? (mutable)? s : t *) - | CgVal of loc and string and mutable_flag and virtual_flag and ctyp - (* method virtual (private)? s : t *) - | CgVir of loc and string and private_flag and ctyp - | CgAnt of loc and string (* $s$ *) ] - and class_expr = - [ CeNil of loc - (* ce e *) - | CeApp of loc and class_expr and expr - (* (virtual)? i ([ t ])? *) - | CeCon of loc and virtual_flag and ident and ctyp - (* fun p -> ce *) - | CeFun of loc and patt and class_expr - (* let (rec)? bi in ce *) - | CeLet of loc and rec_flag and binding and class_expr - (* object ((p))? (cst)? end *) - | CeStr of loc and patt and class_str_item - (* ce : ct *) - | CeTyc of loc and class_expr and class_type - (* ce and ce *) - | CeAnd of loc and class_expr and class_expr - (* ce = ce *) - | CeEq of loc and class_expr and class_expr - (* $s$ *) - | CeAnt of loc and string ] - and class_str_item = - [ CrNil of loc - (* cst ; cst *) - | CrSem of loc and class_str_item and class_str_item - (* type t = t *) - | CrCtr of loc and ctyp and ctyp - (* inherit(!)? ce (as s)? *) - | CrInh of loc and override_flag and class_expr and string - (* initializer e *) - | CrIni of loc and expr - (* method(!)? (private)? s : t = e or method(!)? (private)? s = e *) - | CrMth of loc and string and override_flag and private_flag and expr and ctyp - (* value(!)? (mutable)? s = e *) - | CrVal of loc and string and override_flag and mutable_flag and expr - (* method virtual (private)? s : t *) - | CrVir of loc and string and private_flag and ctyp - (* value virtual (mutable)? s : t *) - | CrVvr of loc and string and mutable_flag and ctyp - | CrAnt of loc and string (* $s$ *) ]; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Debug.ml ocaml-4.05.0/camlp4/Camlp4/Debug.ml --- ocaml-4.01.0/camlp4/Camlp4/Debug.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Debug.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,64 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* camlp4r *) -open Format; - -module Debug = struct value mode _ = False; end; - -type section = string; - -value out_channel = - try - let f = Sys.getenv "CAMLP4_DEBUG_FILE" in - open_out_gen [Open_wronly; Open_creat; Open_append; Open_text] - 0o666 f - with - [ Not_found -> Pervasives.stderr ]; - -module StringSet = Set.Make String; - -value mode = - try - let str = Sys.getenv "CAMLP4_DEBUG" in - let rec loop acc i = - try - let pos = String.index_from str i ':' in - loop (StringSet.add (String.sub str i (pos - i)) acc) (pos + 1) - with - [ Not_found -> - StringSet.add (String.sub str i (String.length str - i)) acc ] in - let sections = loop StringSet.empty 0 in - if StringSet.mem "*" sections then fun _ -> True - else fun x -> StringSet.mem x sections - with [ Not_found -> fun _ -> False ]; - -value formatter = - let header = "camlp4-debug: " in - let at_bol = ref True in - (make_formatter - (fun buf pos len -> - for i = pos to pos + len - 1 do - if at_bol.val then output_string out_channel header else (); - let ch = buf.[i]; - output_char out_channel ch; - at_bol.val := ch = '\n'; - done) - (fun () -> flush out_channel)); - -value printf section fmt = fprintf formatter ("%s: " ^^ fmt) section; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Debug.mli ocaml-4.05.0/camlp4/Camlp4/Debug.mli --- ocaml-4.01.0/camlp4/Camlp4/Debug.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Debug.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* camlp4r *) -type section = string; -value mode : section -> bool; -value printf : section -> format 'a Format.formatter unit -> 'a; diff -Nru ocaml-4.01.0/camlp4/Camlp4/ErrorHandler.ml ocaml-4.05.0/camlp4/Camlp4/ErrorHandler.ml --- ocaml-4.01.0/camlp4/Camlp4/ErrorHandler.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/ErrorHandler.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,171 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* camlp4r *) - -open Format; - -module ObjTools = struct - - value desc obj = - if Obj.is_block obj then - "tag = " ^ string_of_int (Obj.tag obj) - else "int_val = " ^ string_of_int (Obj.obj obj); - - (*Imported from the extlib*) - value rec to_string r = - if Obj.is_int r then - let i = (Obj.magic r : int) - in string_of_int i ^ " | CstTag" ^ string_of_int (i + 1) - else (* Block. *) - let rec get_fields acc = - fun - [ 0 -> acc - | n -> let n = n-1 in get_fields [Obj.field r n :: acc] n ] - in - let rec is_list r = - if Obj.is_int r then - r = Obj.repr 0 (* [] *) - else - let s = Obj.size r and t = Obj.tag r in - t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *) - in - let rec get_list r = - if Obj.is_int r then [] - else let h = Obj.field r 0 and t = get_list (Obj.field r 1) in [h :: t] - in - let opaque name = - (* XXX In future, print the address of value 'r'. Not possible in - * pure OCaml at the moment. - *) - "<" ^ name ^ ">" - in - let s = Obj.size r and t = Obj.tag r in - (* From the tag, determine the type of block. *) - match t with - [ _ when is_list r -> - let fields = get_list r in - "[" ^ String.concat "; " (List.map to_string fields) ^ "]" - | 0 -> - let fields = get_fields [] s in - "(" ^ String.concat ", " (List.map to_string fields) ^ ")" - | x when x = Obj.lazy_tag -> - (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not - * clear if very large constructed values could have the same - * tag. XXX *) - opaque "lazy" - | x when x = Obj.closure_tag -> - opaque "closure" - | x when x = Obj.object_tag -> - let fields = get_fields [] s in - let (_class, id, slots) = - match fields with - [ [h; h'::t] -> (h, h', t) - | _ -> assert False ] - in - (* No information on decoding the class (first field). So just print - * out the ID and the slots. *) - "Object #" ^ to_string id ^ " (" ^ String.concat ", " (List.map to_string slots) ^ ")" - | x when x = Obj.infix_tag -> - opaque "infix" - | x when x = Obj.forward_tag -> - opaque "forward" - | x when x < Obj.no_scan_tag -> - let fields = get_fields [] s in - "Tag" ^ string_of_int t ^ - " (" ^ String.concat ", " (List.map to_string fields) ^ ")" - | x when x = Obj.string_tag -> - "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" - | x when x = Obj.double_tag -> - Camlp4_import.Oprint.float_repres (Obj.magic r : float) - | x when x = Obj.abstract_tag -> - opaque "abstract" - | x when x = Obj.custom_tag -> - opaque "custom" - | x when x = Obj.final_tag -> - opaque "final" - | _ -> - failwith ("ObjTools.to_string: unknown tag (" ^ string_of_int t ^ ")") ]; - - value print ppf x = fprintf ppf "%s" (to_string x); - value print_desc ppf x = fprintf ppf "%s" (desc x); - -end; - -value default_handler ppf x = do { - let x = Obj.repr x; - fprintf ppf "Camlp4: Uncaught exception: %s" - (Obj.obj (Obj.field (Obj.field x 0) 0) : string); - if Obj.size x > 1 then do { - pp_print_string ppf " ("; - for i = 1 to Obj.size x - 1 do - if i > 1 then pp_print_string ppf ", " else (); - ObjTools.print ppf (Obj.field x i); - done; - pp_print_char ppf ')' - } - else (); - fprintf ppf "@." -}; - -value handler = ref (fun ppf default_handler exn -> default_handler ppf exn); - -value register f = - let current_handler = handler.val in - handler.val := - fun ppf default_handler exn -> - try f ppf exn with exn -> current_handler ppf default_handler exn; - -module Register (Error : Sig.Error) = struct - let current_handler = handler.val in - handler.val := - fun ppf default_handler -> - fun [ Error.E x -> Error.print ppf x - | x -> current_handler ppf default_handler x ]; -end; - - -value gen_print ppf default_handler = - fun - [ Out_of_memory -> fprintf ppf "Out of memory" - | Assert_failure (file, line, char) -> - fprintf ppf "Assertion failed, file %S, line %d, char %d" - file line char - | Match_failure (file, line, char) -> - fprintf ppf "Pattern matching failed, file %S, line %d, char %d" - file line char - | Failure str -> fprintf ppf "Failure: %S" str - | Invalid_argument str -> fprintf ppf "Invalid argument: %S" str - | Sys_error str -> fprintf ppf "I/O error: %S" str - | Stream.Failure -> fprintf ppf "Parse failure" - | Stream.Error str -> fprintf ppf "Parse error: %s" str - | x -> handler.val ppf default_handler x ]; - -value print ppf = gen_print ppf default_handler; - -value try_print ppf = gen_print ppf (fun _ -> raise); - -value to_string exn = - let buf = Buffer.create 128 in - let () = bprintf buf "%a" print exn in - Buffer.contents buf; - -value try_to_string exn = - let buf = Buffer.create 128 in - let () = bprintf buf "%a" try_print exn in - Buffer.contents buf; diff -Nru ocaml-4.01.0/camlp4/Camlp4/ErrorHandler.mli ocaml-4.05.0/camlp4/Camlp4/ErrorHandler.mli --- ocaml-4.01.0/camlp4/Camlp4/ErrorHandler.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/ErrorHandler.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) -value print : Format.formatter -> exn -> unit; - -value try_print : Format.formatter -> exn -> unit; - -value to_string : exn -> string; - -value try_to_string : exn -> string; - -value register : (Format.formatter -> exn -> unit) -> unit; - -module Register (Error : Sig.Error) : sig end; - -module ObjTools : sig - value print : Format.formatter -> Obj.t -> unit; - value print_desc : Format.formatter -> Obj.t -> unit; - (*Imported from the extlib*) - value to_string : Obj.t -> string; - value desc : Obj.t -> string; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/OCamlInitSyntax.ml ocaml-4.05.0/camlp4/Camlp4/OCamlInitSyntax.ml --- ocaml-4.01.0/camlp4/Camlp4/OCamlInitSyntax.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/OCamlInitSyntax.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,265 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Camlp4Ast) - (Gram : Sig.Grammar.Static with module Loc = Ast.Loc - with type Token.t = Sig.camlp4_token) - (Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst Ast) -: Sig.Camlp4Syntax with module Loc = Ast.Loc - and module Ast = Ast - and module Token = Gram.Token - and module Gram = Gram - and module Quotation = Quotation -= struct - - module Loc = Ast.Loc; - module Ast = Ast; - module Gram = Gram; - module Token = Gram.Token; - open Sig; - - (* Warnings *) - type warning = Loc.t -> string -> unit; - value default_warning loc txt = Format.eprintf " %a: %s@." Loc.print loc txt; - value current_warning = ref default_warning; - value print_warning loc txt = current_warning.val loc txt; - - value a_CHAR = Gram.Entry.mk "a_CHAR"; - value a_FLOAT = Gram.Entry.mk "a_FLOAT"; - value a_INT = Gram.Entry.mk "a_INT"; - value a_INT32 = Gram.Entry.mk "a_INT32"; - value a_INT64 = Gram.Entry.mk "a_INT64"; - value a_LABEL = Gram.Entry.mk "a_LABEL"; - value a_LIDENT = Gram.Entry.mk "a_LIDENT"; - value a_NATIVEINT = Gram.Entry.mk "a_NATIVEINT"; - value a_OPTLABEL = Gram.Entry.mk "a_OPTLABEL"; - value a_STRING = Gram.Entry.mk "a_STRING"; - value a_UIDENT = Gram.Entry.mk "a_UIDENT"; - value a_ident = Gram.Entry.mk "a_ident"; - value amp_ctyp = Gram.Entry.mk "amp_ctyp"; - value and_ctyp = Gram.Entry.mk "and_ctyp"; - value match_case = Gram.Entry.mk "match_case"; - value match_case0 = Gram.Entry.mk "match_case0"; - value binding = Gram.Entry.mk "binding"; - value class_declaration = Gram.Entry.mk "class_declaration"; - value class_description = Gram.Entry.mk "class_description"; - value class_expr = Gram.Entry.mk "class_expr"; - value class_fun_binding = Gram.Entry.mk "class_fun_binding"; - value class_fun_def = Gram.Entry.mk "class_fun_def"; - value class_info_for_class_expr = Gram.Entry.mk "class_info_for_class_expr"; - value class_info_for_class_type = Gram.Entry.mk "class_info_for_class_type"; - value class_longident = Gram.Entry.mk "class_longident"; - value class_longident_and_param = Gram.Entry.mk "class_longident_and_param"; - value class_name_and_param = Gram.Entry.mk "class_name_and_param"; - value class_sig_item = Gram.Entry.mk "class_sig_item"; - value class_signature = Gram.Entry.mk "class_signature"; - value class_str_item = Gram.Entry.mk "class_str_item"; - value class_structure = Gram.Entry.mk "class_structure"; - value class_type = Gram.Entry.mk "class_type"; - value class_type_declaration = Gram.Entry.mk "class_type_declaration"; - value class_type_longident = Gram.Entry.mk "class_type_longident"; - value class_type_longident_and_param = Gram.Entry.mk "class_type_longident_and_param"; - value class_type_plus = Gram.Entry.mk "class_type_plus"; - value comma_ctyp = Gram.Entry.mk "comma_ctyp"; - value comma_expr = Gram.Entry.mk "comma_expr"; - value comma_ipatt = Gram.Entry.mk "comma_ipatt"; - value comma_patt = Gram.Entry.mk "comma_patt"; - value comma_type_parameter = Gram.Entry.mk "comma_type_parameter"; - value constrain = Gram.Entry.mk "constrain"; - value constructor_arg_list = Gram.Entry.mk "constructor_arg_list"; - value constructor_declaration = Gram.Entry.mk "constructor_declaration"; - value constructor_declarations = Gram.Entry.mk "constructor_declarations"; - value ctyp = Gram.Entry.mk "ctyp"; - value cvalue_binding = Gram.Entry.mk "cvalue_binding"; - value direction_flag = Gram.Entry.mk "direction_flag"; - value direction_flag_quot = Gram.Entry.mk "direction_flag_quot"; - value dummy = Gram.Entry.mk "dummy"; - value entry_eoi = Gram.Entry.mk "entry_eoi"; - value eq_expr = Gram.Entry.mk "eq_expr"; - value expr = Gram.Entry.mk "expr"; - value expr_eoi = Gram.Entry.mk "expr_eoi"; - value field_expr = Gram.Entry.mk "field_expr"; - value field_expr_list = Gram.Entry.mk "field_expr_list"; - value fun_binding = Gram.Entry.mk "fun_binding"; - value fun_def = Gram.Entry.mk "fun_def"; - value ident = Gram.Entry.mk "ident"; - value implem = Gram.Entry.mk "implem"; - value interf = Gram.Entry.mk "interf"; - value ipatt = Gram.Entry.mk "ipatt"; - value ipatt_tcon = Gram.Entry.mk "ipatt_tcon"; - value label = Gram.Entry.mk "label"; - value label_declaration = Gram.Entry.mk "label_declaration"; - value label_declaration_list = Gram.Entry.mk "label_declaration_list"; - value label_expr = Gram.Entry.mk "label_expr"; - value label_expr_list = Gram.Entry.mk "label_expr_list"; - value label_ipatt = Gram.Entry.mk "label_ipatt"; - value label_ipatt_list = Gram.Entry.mk "label_ipatt_list"; - value label_longident = Gram.Entry.mk "label_longident"; - value label_patt = Gram.Entry.mk "label_patt"; - value label_patt_list = Gram.Entry.mk "label_patt_list"; - value labeled_ipatt = Gram.Entry.mk "labeled_ipatt"; - value let_binding = Gram.Entry.mk "let_binding"; - value meth_list = Gram.Entry.mk "meth_list"; - value meth_decl = Gram.Entry.mk "meth_decl"; - value module_binding = Gram.Entry.mk "module_binding"; - value module_binding0 = Gram.Entry.mk "module_binding0"; - value module_declaration = Gram.Entry.mk "module_declaration"; - value module_expr = Gram.Entry.mk "module_expr"; - value module_longident = Gram.Entry.mk "module_longident"; - value module_longident_with_app = Gram.Entry.mk "module_longident_with_app"; - value module_rec_declaration = Gram.Entry.mk "module_rec_declaration"; - value module_type = Gram.Entry.mk "module_type"; - value package_type = Gram.Entry.mk "package_type"; - value more_ctyp = Gram.Entry.mk "more_ctyp"; - value name_tags = Gram.Entry.mk "name_tags"; - value opt_as_lident = Gram.Entry.mk "opt_as_lident"; - value opt_class_self_patt = Gram.Entry.mk "opt_class_self_patt"; - value opt_class_self_type = Gram.Entry.mk "opt_class_self_type"; - value opt_class_signature = Gram.Entry.mk "opt_class_signature"; - value opt_class_structure = Gram.Entry.mk "opt_class_structure"; - value opt_comma_ctyp = Gram.Entry.mk "opt_comma_ctyp"; - value opt_dot_dot = Gram.Entry.mk "opt_dot_dot"; - value row_var_flag_quot = Gram.Entry.mk "row_var_flag_quot"; - value opt_eq_ctyp = Gram.Entry.mk "opt_eq_ctyp"; - value opt_expr = Gram.Entry.mk "opt_expr"; - value opt_meth_list = Gram.Entry.mk "opt_meth_list"; - value opt_mutable = Gram.Entry.mk "opt_mutable"; - value mutable_flag_quot = Gram.Entry.mk "mutable_flag_quot"; - value opt_polyt = Gram.Entry.mk "opt_polyt"; - value opt_private = Gram.Entry.mk "opt_private"; - value private_flag_quot = Gram.Entry.mk "private_flag_quot"; - value opt_rec = Gram.Entry.mk "opt_rec"; - value rec_flag_quot = Gram.Entry.mk "rec_flag_quot"; - value opt_sig_items = Gram.Entry.mk "opt_sig_items"; - value opt_str_items = Gram.Entry.mk "opt_str_items"; - value opt_virtual = Gram.Entry.mk "opt_virtual"; - value virtual_flag_quot = Gram.Entry.mk "virtual_flag_quot"; - value opt_override = Gram.Entry.mk "opt_override"; - value override_flag_quot = Gram.Entry.mk "override_flag_quot"; - value opt_when_expr = Gram.Entry.mk "opt_when_expr"; - value patt = Gram.Entry.mk "patt"; - value patt_as_patt_opt = Gram.Entry.mk "patt_as_patt_opt"; - value patt_eoi = Gram.Entry.mk "patt_eoi"; - value patt_tcon = Gram.Entry.mk "patt_tcon"; - value phrase = Gram.Entry.mk "phrase"; - value poly_type = Gram.Entry.mk "poly_type"; - value row_field = Gram.Entry.mk "row_field"; - value sem_expr = Gram.Entry.mk "sem_expr"; - value sem_expr_for_list = Gram.Entry.mk "sem_expr_for_list"; - value sem_patt = Gram.Entry.mk "sem_patt"; - value sem_patt_for_list = Gram.Entry.mk "sem_patt_for_list"; - value semi = Gram.Entry.mk "semi"; - value sequence = Gram.Entry.mk "sequence"; - value do_sequence = Gram.Entry.mk "do_sequence"; - value sig_item = Gram.Entry.mk "sig_item"; - value sig_items = Gram.Entry.mk "sig_items"; - value star_ctyp = Gram.Entry.mk "star_ctyp"; - value str_item = Gram.Entry.mk "str_item"; - value str_items = Gram.Entry.mk "str_items"; - value top_phrase = Gram.Entry.mk "top_phrase"; - value type_constraint = Gram.Entry.mk "type_constraint"; - value type_declaration = Gram.Entry.mk "type_declaration"; - value type_ident_and_parameters = Gram.Entry.mk "type_ident_and_parameters"; - value type_kind = Gram.Entry.mk "type_kind"; - value type_longident = Gram.Entry.mk "type_longident"; - value type_longident_and_parameters = Gram.Entry.mk "type_longident_and_parameters"; - value type_parameter = Gram.Entry.mk "type_parameter"; - value type_parameters = Gram.Entry.mk "type_parameters"; - value typevars = Gram.Entry.mk "typevars"; - value use_file = Gram.Entry.mk "use_file"; - value val_longident = Gram.Entry.mk "val_longident"; - value value_let = Gram.Entry.mk "value_let"; - value value_val = Gram.Entry.mk "value_val"; - value with_constr = Gram.Entry.mk "with_constr"; - value expr_quot = Gram.Entry.mk "quotation of expression"; - value patt_quot = Gram.Entry.mk "quotation of pattern"; - value ctyp_quot = Gram.Entry.mk "quotation of type"; - value str_item_quot = Gram.Entry.mk "quotation of structure item"; - value sig_item_quot = Gram.Entry.mk "quotation of signature item"; - value class_str_item_quot = Gram.Entry.mk "quotation of class structure item"; - value class_sig_item_quot = Gram.Entry.mk "quotation of class signature item"; - value module_expr_quot = Gram.Entry.mk "quotation of module expression"; - value module_type_quot = Gram.Entry.mk "quotation of module type"; - value class_type_quot = Gram.Entry.mk "quotation of class type"; - value class_expr_quot = Gram.Entry.mk "quotation of class expression"; - value with_constr_quot = Gram.Entry.mk "quotation of with constraint"; - value binding_quot = Gram.Entry.mk "quotation of binding"; - value rec_binding_quot = Gram.Entry.mk "quotation of record binding"; - value match_case_quot = Gram.Entry.mk "quotation of match_case (try/match/function case)"; - value module_binding_quot = Gram.Entry.mk "quotation of module rec binding"; - value ident_quot = Gram.Entry.mk "quotation of identifier"; - value prefixop = Gram.Entry.mk "prefix operator (start with '!', '?', '~')"; - value infixop0 = Gram.Entry.mk "infix operator (level 0) (comparison operators, and some others)"; - value infixop1 = Gram.Entry.mk "infix operator (level 1) (start with '^', '@')"; - value infixop2 = Gram.Entry.mk "infix operator (level 2) (start with '+', '-')"; - value infixop3 = Gram.Entry.mk "infix operator (level 3) (start with '*', '/', '%')"; - value infixop4 = Gram.Entry.mk "infix operator (level 4) (start with \"**\") (right assoc)"; - - EXTEND Gram - top_phrase: - [ [ `EOI -> None ] ] - ; - END; - - module AntiquotSyntax = struct - module Loc = Ast.Loc; - module Ast = Sig.Camlp4AstToAst Ast; - module Gram = Gram; - value antiquot_expr = Gram.Entry.mk "antiquot_expr"; - value antiquot_patt = Gram.Entry.mk "antiquot_patt"; - EXTEND Gram - antiquot_expr: - [ [ x = expr; `EOI -> x ] ] - ; - antiquot_patt: - [ [ x = patt; `EOI -> x ] ] - ; - END; - value parse_expr loc str = Gram.parse_string antiquot_expr loc str; - value parse_patt loc str = Gram.parse_string antiquot_patt loc str; - end; - - module Quotation = Quotation; - - value wrap directive_handler pa init_loc cs = - let rec loop loc = - let (pl, stopped_at_directive) = pa loc cs in - match stopped_at_directive with - [ Some new_loc -> - let pl = - match List.rev pl with - [ [] -> assert False - | [x :: xs] -> - match directive_handler x with - [ None -> xs - | Some x -> [x :: xs] ] ] - in (List.rev pl) @ (loop new_loc) - | None -> pl ] - in loop init_loc; - - value parse_implem ?(directive_handler = fun _ -> None) _loc cs = - let l = wrap directive_handler (Gram.parse implem) _loc cs in - <:str_item< $list:l$ >>; - - value parse_interf ?(directive_handler = fun _ -> None) _loc cs = - let l = wrap directive_handler (Gram.parse interf) _loc cs in - <:sig_item< $list:l$ >>; - - value print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer"; - value print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer"; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Options.ml ocaml-4.05.0/camlp4/Camlp4/Options.ml --- ocaml-4.01.0/camlp4/Camlp4/Options.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Options.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,191 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -type spec_list = list (string * Arg.spec * string); -open Format; - -value rec action_arg s sl = - fun - [ Arg.Unit f -> if s = "" then do { f (); Some sl } else None - | Arg.Bool f -> - if s = "" then - match sl with - [ [s :: sl] -> - try do { f (bool_of_string s); Some sl } with - [ Invalid_argument "bool_of_string" -> None ] - | [] -> None ] - else - try do { f (bool_of_string s); Some sl } with - [ Invalid_argument "bool_of_string" -> None ] - | Arg.Set r -> if s = "" then do { r.val := True; Some sl } else None - | Arg.Clear r -> if s = "" then do { r.val := False; Some sl } else None - | Arg.Rest f -> do { List.iter f [s :: sl]; Some [] } - | Arg.String f -> - if s = "" then - match sl with - [ [s :: sl] -> do { f s; Some sl } - | [] -> None ] - else do { f s; Some sl } - | Arg.Set_string r -> - if s = "" then - match sl with - [ [s :: sl] -> do { r.val := s; Some sl } - | [] -> None ] - else do { r.val := s; Some sl } - | Arg.Int f -> - if s = "" then - match sl with - [ [s :: sl] -> - try do { f (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | [] -> None ] - else - try do { f (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | Arg.Set_int r -> - if s = "" then - match sl with - [ [s :: sl] -> - try do { r.val := (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | [] -> None ] - else - try do { r.val := (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | Arg.Float f -> - if s = "" then - match sl with - [ [s :: sl] -> do { f (float_of_string s); Some sl } - | [] -> None ] - else do { f (float_of_string s); Some sl } - | Arg.Set_float r -> - if s = "" then - match sl with - [ [s :: sl] -> do { r.val := (float_of_string s); Some sl } - | [] -> None ] - else do { r.val := (float_of_string s); Some sl } - | Arg.Tuple specs -> - let rec action_args s sl = - fun - [ [] -> Some sl - | [spec :: spec_list] -> - match action_arg s sl spec with - [ None -> action_args "" [] spec_list - | Some [s :: sl] -> action_args s sl spec_list - | Some sl -> action_args "" sl spec_list - ] - ] in - action_args s sl specs - | Arg.Symbol syms f -> - match (if s = "" then sl else [s :: sl]) with - [ [s :: sl] when List.mem s syms -> do { f s; Some sl } - | _ -> None ] - ]; - -value common_start s1 s2 = - loop 0 where rec loop i = - if i == String.length s1 || i == String.length s2 then i - else if s1.[i] == s2.[i] then loop (i + 1) - else i; - -value parse_arg fold s sl = - fold - (fun (name, action, _) acu -> - let i = common_start s name in - if i == String.length name then - try action_arg (String.sub s i (String.length s - i)) sl action with - [ Arg.Bad _ -> acu ] - else acu) None; - -value rec parse_aux fold anon_fun = - fun - [ [] -> [] - | [s :: sl] -> - if String.length s > 1 && s.[0] = '-' then - match parse_arg fold s sl with - [ Some sl -> parse_aux fold anon_fun sl - | None -> [s :: parse_aux fold anon_fun sl] ] - else do { (anon_fun s : unit); parse_aux fold anon_fun sl } ]; - -value align_doc key s = - let s = - loop 0 where rec loop i = - if i = String.length s then "" - else if s.[i] = ' ' then loop (i + 1) - else String.sub s i (String.length s - i) - in - let (p, s) = - if String.length s > 0 then - if s.[0] = '<' then - loop 0 where rec loop i = - if i = String.length s then ("", s) - else if s.[i] <> '>' then loop (i + 1) - else - let p = String.sub s 0 (i + 1) in - loop (i + 1) where rec loop i = - if i >= String.length s then (p, "") - else if s.[i] = ' ' then loop (i + 1) - else (p, String.sub s i (String.length s - i)) - else ("", s) - else ("", "") - in - let tab = - String.make (max 1 (16 - String.length key - String.length p)) ' ' - in - p ^ tab ^ s; - -value make_symlist l = - match l with - [ [] -> "" - | [h::t] -> (List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t) ^ "}" ]; - -value print_usage_list l = - List.iter - (fun (key, spec, doc) -> - match spec with - [ Arg.Symbol symbs _ -> - let s = make_symlist symbs in - let synt = key ^ " " ^ s in - eprintf " %s %s\n" synt (align_doc synt doc) - | _ -> eprintf " %s %s\n" key (align_doc key doc) ] ) - l; - -value remaining_args argv = - let rec loop l i = - if i == Array.length argv then l else loop [argv.(i) :: l] (i + 1) - in - List.rev (loop [] (Arg.current.val + 1)); - -value init_spec_list = ref []; -value ext_spec_list = ref []; - -value init spec_list = init_spec_list.val := spec_list; - -value add name spec descr = - ext_spec_list.val := [(name, spec, descr) :: ext_spec_list.val]; - -value fold f init = - let spec_list = init_spec_list.val @ ext_spec_list.val in - let specs = Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list in - List.fold_right f specs init; - -value parse anon_fun argv = - let remaining_args = remaining_args argv in - parse_aux fold anon_fun remaining_args; - -value ext_spec_list () = ext_spec_list.val; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Options.mli ocaml-4.05.0/camlp4/Camlp4/Options.mli --- ocaml-4.01.0/camlp4/Camlp4/Options.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Options.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -type spec_list = list (string * Arg.spec * string); -value init : spec_list -> unit; -value add : string -> Arg.spec -> string -> unit; - (** Add an option to the command line options. *) -value print_usage_list : spec_list -> unit; -value ext_spec_list : unit -> spec_list; -value parse : (string -> unit) -> array string -> list string; diff -Nru ocaml-4.01.0/camlp4/Camlp4/PreCast.ml ocaml-4.05.0/camlp4/Camlp4/PreCast.ml --- ocaml-4.01.0/camlp4/Camlp4/PreCast.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/PreCast.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,67 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id = struct - value name = "Camlp4.PreCast"; - value version = Sys.ocaml_version; -end; - -type camlp4_token = Sig.camlp4_token == - [ KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int and string - | INT32 of int32 and string - | INT64 of int64 and string - | NATIVEINT of nativeint and string - | FLOAT of float and string - | CHAR of char and string - | STRING of string and string - | LABEL of string - | OPTLABEL of string - | QUOTATION of Sig.quotation - | ANTIQUOT of string and string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int and option string - | EOI ]; - -module Loc = Struct.Loc; -module Ast = Struct.Camlp4Ast.Make Loc; -module Token = Struct.Token.Make Loc; -module Lexer = Struct.Lexer.Make Token; -module Gram = Struct.Grammar.Static.Make Lexer; -module DynLoader = Struct.DynLoader; -module Quotation = Struct.Quotation.Make Ast; -module MakeSyntax (U : sig end) = OCamlInitSyntax.Make Ast Gram Quotation; -module Syntax = MakeSyntax (struct end); -module AstFilters = Struct.AstFilters.Make Ast; -module MakeGram = Struct.Grammar.Static.Make; - -module Printers = struct - module OCaml = Printers.OCaml.Make Syntax; - module OCamlr = Printers.OCamlr.Make Syntax; - (* module OCamlrr = Printers.OCamlrr.Make Syntax; *) - module DumpOCamlAst = Printers.DumpOCamlAst.Make Syntax; - module DumpCamlp4Ast = Printers.DumpCamlp4Ast.Make Syntax; - module Null = Printers.Null.Make Syntax; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/PreCast.mli ocaml-4.05.0/camlp4/Camlp4/PreCast.mli --- ocaml-4.01.0/camlp4/Camlp4/PreCast.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/PreCast.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -type camlp4_token = Sig.camlp4_token == - [ KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int and string - | INT32 of int32 and string - | INT64 of int64 and string - | NATIVEINT of nativeint and string - | FLOAT of float and string - | CHAR of char and string - | STRING of string and string - | LABEL of string - | OPTLABEL of string - | QUOTATION of Sig.quotation - | ANTIQUOT of string and string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int and option string - | EOI ]; - -module Id : Sig.Id; -module Loc : Sig.Loc; -module Ast : Sig.Camlp4Ast with module Loc = Loc; -module Token : Sig.Token - with module Loc = Loc - and type t = camlp4_token; -module Lexer : Sig.Lexer - with module Loc = Loc - and module Token = Token; -module Gram : Sig.Grammar.Static - with module Loc = Loc - and module Token = Token; -module Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst Ast; -module DynLoader : Sig.DynLoader; -module AstFilters : Sig.AstFilters with module Ast = Ast; -module Syntax : Sig.Camlp4Syntax - with module Loc = Loc - and module Token = Token - and module Ast = Ast - and module Gram = Gram - and module Quotation = Quotation; - -module Printers : sig - module OCaml : (Sig.Printer Ast).S; - module OCamlr : (Sig.Printer Ast).S; - module DumpOCamlAst : (Sig.Printer Ast).S; - module DumpCamlp4Ast : (Sig.Printer Ast).S; - module Null : (Sig.Printer Ast).S; -end; - -module MakeGram (Lexer : Sig.Lexer with module Loc = Loc) - : Sig.Grammar.Static with module Loc = Loc and module Token = Lexer.Token; - -module MakeSyntax (U : sig end) : Sig.Syntax; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml ocaml-4.05.0/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml --- ocaml-4.01.0/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id = struct - value name = "Camlp4Printers.DumpCamlp4Ast"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Syntax) -: (Sig.Printer Syntax.Ast).S -= struct - include Syntax; - - value with_open_out_file x f = - match x with - [ Some file -> do { let oc = open_out_bin file; - f oc; - flush oc; - close_out oc } - | None -> do { set_binary_mode_out stdout True; f stdout; flush stdout } ]; - - value dump_ast magic ast oc = do { - output_string oc magic; - output_value oc ast; - }; - - value print_interf ?input_file:(_) ?output_file ast = - with_open_out_file output_file - (dump_ast Camlp4_config.camlp4_ast_intf_magic_number ast); - - value print_implem ?input_file:(_) ?output_file ast = - with_open_out_file output_file - (dump_ast Camlp4_config.camlp4_ast_impl_magic_number ast); - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli ocaml-4.05.0/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli --- ocaml-4.01.0/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Syntax) : (Sig.Printer Syntax.Ast).S; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/DumpOCamlAst.ml ocaml-4.05.0/camlp4/Camlp4/Printers/DumpOCamlAst.ml --- ocaml-4.01.0/camlp4/Camlp4/Printers/DumpOCamlAst.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Printers/DumpOCamlAst.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id : Sig.Id = struct - value name = "Camlp4Printers.DumpOCamlAst"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Camlp4Syntax) -: (Sig.Printer Syntax.Ast).S -= struct - include Syntax; - module Ast2pt = Struct.Camlp4Ast2OCamlAst.Make Ast; - - value with_open_out_file x f = - match x with - [ Some file -> do { let oc = open_out_bin file; - f oc; - flush oc; - close_out oc } - | None -> do { set_binary_mode_out stdout True; f stdout; flush stdout } ]; - - value dump_pt magic fname pt oc = do { - output_string oc magic; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - }; - - value print_interf ?(input_file = "-") ?output_file ast = - let pt = Ast2pt.sig_item ast in - with_open_out_file output_file (dump_pt Camlp4_config.ocaml_ast_intf_magic_number input_file pt); - - value print_implem ?(input_file = "-") ?output_file ast = - let pt = Ast2pt.str_item ast in - with_open_out_file output_file (dump_pt Camlp4_config.ocaml_ast_impl_magic_number input_file pt); - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/DumpOCamlAst.mli ocaml-4.05.0/camlp4/Camlp4/Printers/DumpOCamlAst.mli --- ocaml-4.01.0/camlp4/Camlp4/Printers/DumpOCamlAst.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Printers/DumpOCamlAst.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/Null.ml ocaml-4.05.0/camlp4/Camlp4/Printers/Null.ml --- ocaml-4.01.0/camlp4/Camlp4/Printers/Null.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Printers/Null.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id = struct - value name = "Camlp4.Printers.Null"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Syntax) = struct - include Syntax; - - value print_interf ?input_file:(_) ?output_file:(_) _ = (); - value print_implem ?input_file:(_) ?output_file:(_) _ = (); -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/Null.mli ocaml-4.05.0/camlp4/Camlp4/Printers/Null.mli --- ocaml-4.01.0/camlp4/Camlp4/Printers/Null.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Printers/Null.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Syntax) : (Sig.Printer Syntax.Ast).S; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/OCaml.ml ocaml-4.05.0/camlp4/Camlp4/Printers/OCaml.ml --- ocaml-4.01.0/camlp4/Camlp4/Printers/OCaml.ml 2013-08-30 11:39:33.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Printers/OCaml.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,1156 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -open Format; - -module Id = struct - value name = "Camlp4.Printers.OCaml"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Camlp4Syntax) = struct - include Syntax; - - type sep = format unit formatter unit; - type fun_binding = [= `patt of Ast.patt | `newtype of string ]; - - value pp = fprintf; - value cut f = fprintf f "@ "; - - value list' elt sep sep' f = - let rec loop = - fun - [ [] -> () - | [x::xs] -> do { pp f sep ; elt f x; pp f sep'; loop xs } ] in - fun - [ [] -> () - | [x] -> do { elt f x; pp f sep' } - | [x::xs] -> do { elt f x; pp f sep'; loop xs } ]; - - value list elt sep f = - let rec loop = - fun - [ [] -> () - | [x::xs] -> do { pp f sep ; elt f x; loop xs } ] in - fun - [ [] -> () - | [x] -> elt f x - | [x::xs] -> do { elt f x; loop xs } ]; - - value rec list_of_meta_list = - fun - [ Ast.LNil -> [] - | Ast.LCons x xs -> [x :: list_of_meta_list xs] - | Ast.LAnt _ -> assert False ]; - - value meta_list elt sep f mxs = - let xs = list_of_meta_list mxs in - list elt sep f xs; - - module CommentFilter = Struct.CommentFilter.Make Token; - value comment_filter = CommentFilter.mk (); - CommentFilter.define (Gram.get_filter ()) comment_filter; - - module StringSet = Set.Make String; - - value infix_lidents = ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"]; - - value is_infix = - let first_chars = ['='; '<'; '>'; '|'; '&'; '$'; '@'; '^'; '+'; '-'; '*'; '/'; '%'; '\\'] - and infixes = - List.fold_right StringSet.add infix_lidents StringSet.empty - in fun s -> (StringSet.mem s infixes - || (s <> "" && List.mem s.[0] first_chars)); - - value is_keyword = - let keywords = (* without infix_lidents *) - List.fold_right StringSet.add - ["and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; - "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; - "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; - "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module"; - "mutable"; "new"; "object"; "of"; "open"; "parser"; "private"; "rec"; "sig"; - "struct"; "then"; "to"; "true"; "try"; "type"; "val"; "virtual"; - "when"; "while"; "with"] StringSet.empty - in fun s -> StringSet.mem s keywords; - - module Lexer = Struct.Lexer.Make Token; - let module M = ErrorHandler.Register Lexer.Error in (); - open Sig; - value lexer s = - Lexer.from_string ~quotations:Camlp4_config.quotations.val Loc.ghost s; - value lex_string str = - try match lexer str with parser - [: `(tok, _); `(EOI, _) :] -> tok - with - [ Stream.Failure | Stream.Error _ -> - failwith (sprintf - "Cannot print %S this string contains more than one token" str) - | Lexer.Error.E exn -> - failwith (sprintf - "Cannot print %S this identifier does not respect OCaml lexing rules (%s)" - str (Lexer.Error.to_string exn)) ]; - - (* This is to be sure character literals are always escaped. *) - value ocaml_char x = Char.escaped (Struct.Token.Eval.char x); - - value rec get_expr_args a al = - match a with - [ <:expr< $a1$ $a2$ >> -> get_expr_args a1 [a2 :: al] - | _ -> (a, al) ]; - - value rec get_patt_args a al = - match a with - [ <:patt< $a1$ $a2$ >> -> get_patt_args a1 [a2 :: al] - | _ -> (a, al) ]; - - value rec get_ctyp_args a al = - match a with - [ <:ctyp< $a1$ $a2$ >> -> get_ctyp_args a1 [a2 :: al] - | _ -> (a, al) ]; - - value is_irrefut_patt = Ast.is_irrefut_patt; - - value rec expr_fun_args = - fun - [ <:expr< fun $p$ -> $e$ >> as ge -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - ([`patt p :: pl], e) - else ([], ge) - | <:expr< fun (type $i$) -> $e$ >> -> - let (pl, e) = expr_fun_args e in - ([`newtype i :: pl], e) - | ge -> ([], ge) ]; - - value rec class_expr_fun_args = - fun - [ <:class_expr< fun $p$ -> $ce$ >> as ge -> - if is_irrefut_patt p then - let (pl, ce) = class_expr_fun_args ce in - ([p :: pl], ce) - else ([], ge) - | ge -> ([], ge) ]; - - value rec do_print_comments_before loc f = - parser - [ [: ` (comm, comm_loc) when Loc.strictly_before comm_loc loc; s :] -> - let () = f comm comm_loc in - do_print_comments_before loc f s - | [: :] -> () ]; - - class printer ?curry_constr:(init_curry_constr = False) ?(comments = True) () = - object (o) - - (** pipe means we are under a match case (try, function) *) - value pipe = False; - value semi = False; - - method under_pipe = {< pipe = True >}; - method under_semi = {< semi = True >}; - method reset_semi = {< semi = False >}; - method reset = {< pipe = False; semi = False >}; - - value semisep : sep = ";;"; - value no_semisep : sep = ""; (* used to mark where ";;" should not occur *) - value mode = if comments then `comments else `no_comments; - value curry_constr = init_curry_constr; - value var_conversion = False; - - method andsep : sep = "@]@ @[<2>and@ "; - method value_val = "val"; - method value_let = "let"; - - method semisep = semisep; - method set_semisep s = {< semisep = s >}; - method set_comments b = {< mode = if b then `comments else `no_comments >}; - method set_loc_and_comments = {< mode = `loc_and_comments >}; - method set_curry_constr b = {< curry_constr = b >}; - - method print_comments_before loc f = - match mode with - [ `comments -> - do_print_comments_before loc (fun c _ -> pp f "%s@ " c) - (CommentFilter.take_stream comment_filter) - | `loc_and_comments -> - let () = pp f "(*loc: %a*)@ " Loc.dump loc in - do_print_comments_before loc - (fun s -> pp f "%s(*comm_loc: %a*)@ " s Loc.dump) - (CommentFilter.take_stream comment_filter) - | _ -> () ]; - - method var f = - fun - [ "" -> pp f "$lid:\"\"$" - | "[]" -> pp f "[]" - | "()" -> pp f "()" - | " True" -> pp f "True" - | " False" -> pp f "False" - | v -> - match (var_conversion, v) with - [ (True, "val") -> pp f "contents" - | (True, "True") -> pp f "true" - | (True, "False") -> pp f "false" - | _ -> - match lex_string v with - [ (LIDENT s | UIDENT s | ESCAPED_IDENT s) when is_keyword s -> - pp f "%s__" s - | (LIDENT s | ESCAPED_IDENT s) when List.mem s infix_lidents -> - pp f "( %s )" s - | SYMBOL s -> - pp f "( %s )" s - | LIDENT s | UIDENT s | ESCAPED_IDENT s -> - pp_print_string f s - | tok -> failwith (sprintf - "Bad token used as an identifier: %s" - (Token.to_string tok)) ] ] ]; - - method type_params f = - fun - [ [] -> () - | [x] -> pp f "%a@ " o#ctyp x - | l -> pp f "@[<1>(%a)@]@ " (list o#ctyp ",@ ") l ]; - - method class_params f = - fun - [ <:ctyp< $t1$, $t2$ >> -> - pp f "@[<1>%a,@ %a@]" o#class_params t1 o#class_params t2 - | x -> o#ctyp f x ]; - - method override_flag f = - fun - [ Ast.OvOverride -> pp f "!" - | Ast.OvNil -> () - | Ast.OvAnt s -> o#anti f s ]; - - method mutable_flag f = fun - [ Ast.MuMutable -> pp f "mutable@ " - | Ast.MuNil -> () - | Ast.MuAnt s -> o#anti f s ]; - - method rec_flag f = fun - [ Ast.ReRecursive -> pp f "rec@ " - | Ast.ReNil -> () - | Ast.ReAnt s -> o#anti f s ]; - - method virtual_flag f = fun - [ Ast.ViVirtual -> pp f "virtual@ " - | Ast.ViNil -> () - | Ast.ViAnt s -> o#anti f s ]; - - method private_flag f = fun - [ Ast.PrPrivate -> pp f "private@ " - | Ast.PrNil -> () - | Ast.PrAnt s -> o#anti f s ]; - - method anti f s = pp f "$%s$" s; - - method seq f = - fun - [ <:expr< $e1$; $e2$ >> -> - pp f "%a;@ %a" o#under_semi#seq e1 o#seq e2 - | <:expr< do { $e$ } >> -> - o#seq f e - | e -> o#expr f e ]; - - (* FIXME when the Format module will fixed. - pp_print_if_newline f (); - pp_print_string f "| "; *) - method match_case f = - fun - [ <:match_case@_loc<>> -> - pp f "@[<2>@ _ ->@ %a@]" o#raise_match_failure _loc - | a -> o#match_case_aux f a ]; - - method match_case_aux f = - fun - [ <:match_case<>> -> () - | <:match_case< $anti:s$ >> -> o#anti f s - | <:match_case< $a1$ | $a2$ >> -> - pp f "%a%a" o#match_case_aux a1 o#match_case_aux a2 - | <:match_case< $p$ -> $e$ >> -> - pp f "@ | @[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr e - | <:match_case< $p$ when $w$ -> $e$ >> -> - pp f "@ | @[<2>%a@ when@ %a@ ->@ %a@]" - o#patt p o#under_pipe#expr w o#under_pipe#expr e ]; - - method fun_binding f = - fun - [ `patt p -> o#simple_patt f p - | `newtype i -> pp f "(type %s)" i ]; - - method binding f bi = - let () = o#node f bi Ast.loc_of_binding in - match bi with - [ <:binding<>> -> () - | <:binding< $b1$ and $b2$ >> -> - do { o#binding f b1; pp f o#andsep; o#binding f b2 } - | <:binding< $p$ = $e$ >> -> - let (pl, e') = - match p with - [ <:patt< ($_$ : $_$) >> -> ([], e) - | _ -> expr_fun_args e ] in - match (p, e') with - [ (<:patt< $lid:_$ >>, <:expr< ($e'$ : $t$) >>) -> - pp f "%a :@ %a =@ %a" - (list o#fun_binding "@ ") [`patt p::pl] o#ctyp t o#expr e' - | (<:patt< $lid:_$ >>, _) -> - pp f "%a @[<0>%a=@]@ %a" o#simple_patt - p (list' o#fun_binding "" "@ ") pl o#expr e' - | _ -> - pp f "%a =@ %a" o#simple_patt p o#expr e ] - | <:binding< $anti:s$ >> -> o#anti f s ]; - - method record_binding f bi = - let () = o#node f bi Ast.loc_of_rec_binding in - match bi with - [ <:rec_binding<>> -> () - | <:rec_binding< $i$ = $e$ >> -> - pp f "@ @[<2>%a =@ %a@];" o#var_ident i o#expr e - | <:rec_binding< $b1$ ; $b2$ >> -> - do { o#under_semi#record_binding f b1; - o#under_semi#record_binding f b2 } - | <:rec_binding< $anti:s$ >> -> o#anti f s ]; - - method mk_patt_list = - fun - [ <:patt< [$p1$ :: $p2$] >> -> - let (pl, c) = o#mk_patt_list p2 in - ([p1 :: pl], c) - | <:patt< [] >> -> ([], None) - | p -> ([], Some p) ]; - - method mk_expr_list = - fun - [ <:expr< [$e1$ :: $e2$] >> -> - let (el, c) = o#mk_expr_list e2 in - ([e1 :: el], c) - | <:expr< [] >> -> ([], None) - | e -> ([], Some e) ]; - - method expr_list f = - fun - [ [] -> pp f "[]" - | [e] -> pp f "[ %a ]" o#under_semi#expr e - | el -> pp f "@[<2>[ %a@] ]" (list o#under_semi#expr ";@ ") el ]; - - method expr_list_cons simple f e = - let (el, c) = o#mk_expr_list e in - match c with - [ None -> o#expr_list f el - | Some x -> - (if simple then pp f "@[<2>(%a)@]" else pp f "@[<2>%a@]") - (list o#under_semi#dot_expr " ::@ ") (el @ [x]) ]; - - method patt_expr_fun_args f (p, e) = - let (pl, e) = expr_fun_args e - in pp f "%a@ ->@ %a" (list o#fun_binding "@ ") [p::pl] o#expr e; - - method patt_class_expr_fun_args f (p, ce) = - let (pl, ce) = class_expr_fun_args ce - in pp f "%a =@]@ %a" (list o#simple_patt "@ ") [p::pl] o#class_expr ce; - - method constrain f (t1, t2) = - pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2; - - method sum_type f t = - match Ast.list_of_ctyp t [] with - [ [] -> () - | ts -> - pp f "@[| %a@]" (list o#constructor_declaration "@ | ") ts ]; - - method private constructor_declaration f t = - match t with - [ <:ctyp< $t1$ : $t2$ -> $t3$ >> -> pp f "@[<2>%a :@ @[<2>%a@ ->@ %a@]@]" o#ctyp t1 o#constructor_type t2 o#ctyp t3 - | t -> o#ctyp f t ]; - - method string f = pp f "%s"; - method quoted_string f = pp f "%S"; - - method numeric f num suff = - if num.[0] = '-' then pp f "(%s%s)" num suff else pp f "%s%s" num suff; - - method module_expr_get_functor_args accu = - fun - [ <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - o#module_expr_get_functor_args [(s, mt)::accu] me - | <:module_expr< ($me$ : $mt$) >> -> (List.rev accu, me, Some mt) - | me -> (List.rev accu, me, None) ]; - - method functor_args f = list o#functor_arg "@ " f; - - method functor_arg f (s, mt) = - pp f "@[<2>(%a :@ %a)@]" o#var s o#module_type mt; - - method module_rec_binding f = - fun - [ <:module_binding<>> -> () - | <:module_binding< $s$ : $mt$ = $me$ >> -> - pp f "@[<2>%a :@ %a =@ %a@]" - o#var s o#module_type mt o#module_expr me - | <:module_binding< $s$ : $mt$ >> -> - pp f "@[<2>%a :@ %a@]" o#var s o#module_type mt - | <:module_binding< $mb1$ and $mb2$ >> -> - do { o#module_rec_binding f mb1; - pp f o#andsep; - o#module_rec_binding f mb2 } - | <:module_binding< $anti:s$ >> -> o#anti f s ]; - - method class_declaration f = - fun - [ <:class_expr< ( $ce$ : $ct$ ) >> -> - pp f "%a :@ %a" o#class_expr ce o#class_type ct - | ce -> o#class_expr f ce ]; - - method raise_match_failure f _loc = - let n = Loc.file_name _loc in - let l = Loc.start_line _loc in - let c = Loc.start_off _loc - Loc.start_bol _loc in - o#expr f <:expr< raise (Match_failure $`str:n$ $`int:l$ $`int:c$) >>; - - method node : ! 'a . formatter -> 'a -> ('a -> Loc.t) -> unit = - fun f node loc_of_node -> - o#print_comments_before (loc_of_node node) f; - - method ident f i = - let () = o#node f i Ast.loc_of_ident in - match i with - [ <:ident< $i1$.$i2$ >> -> pp f "%a.@,%a" o#ident i1 o#ident i2 - | <:ident< $i1$ $i2$ >> -> pp f "%a@,(%a)" o#ident i1 o#ident i2 - | <:ident< $anti:s$ >> -> o#anti f s - | <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> o#var f s ]; - - method private var_ident = {< var_conversion = True >}#ident; - - method expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ ((<:expr< let $rec:_$ $_$ in $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >>) as e) when semi -> - pp f "(%a)" o#reset#expr e - | ((<:expr< match $_$ with [ $_$ ] >> | - <:expr< try $_$ with [ $_$ ] >> | - <:expr< fun [ $_$ ] >>) as e) when pipe || semi -> - pp f "(%a)" o#reset#expr e - - | <:expr< - $x$ >> -> - (* If you want to remove the space take care of - !r *) - pp f "@[<2>-@ %a@]" o#dot_expr x - | <:expr< -. $x$ >> -> - pp f "@[<2>-.@ %a@]" o#dot_expr x (* same note as above *) - | <:expr< [$_$ :: $_$] >> -> o#expr_list_cons False f e - | <:expr@_loc< $lid:n$ $x$ $y$ >> when is_infix n -> - pp f "@[<2>%a@ %s@ %a@]" o#apply_expr x n o#apply_expr y - | <:expr< $x$ $y$ >> -> - let (a, al) = get_expr_args x [y] in - if (not curry_constr) && Ast.is_expr_constructor a then - match al with - [ [ <:expr< ($tup:_$) >> ] -> - pp f "@[<2>%a@ (%a)@]" o#apply_expr x o#expr y - | [_] -> pp f "@[<2>%a@ %a@]" o#apply_expr x o#apply_expr y - | al -> - pp f "@[<2>%a@ (%a)@]" o#apply_expr a - (* The #apply_expr below may put too much parens. - However using #expr would be wrong: PR#5056. *) - (list o#under_pipe#apply_expr ",@ ") al ] - else pp f "@[<2>%a@]" (list o#apply_expr "@ ") [a::al] - | <:expr< $e1$.val := $e2$ >> -> - pp f "@[<2>%a :=@ %a@]" o#dot_expr e1 o#expr e2 - | <:expr< $e1$ := $e2$ >> -> - pp f "@[<2>%a@ <-@ %a@]" o#dot_expr e1 o#expr e2 - | <:expr@loc< fun [] >> -> - pp f "@[<2>fun@ _@ ->@ %a@]" o#raise_match_failure loc - | <:expr< fun $p$ -> $e$ >> when is_irrefut_patt p -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`patt p, e) - | <:expr< fun (type $i$) -> $e$ >> -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`newtype i, e) - | <:expr< fun [ $a$ ] >> -> - pp f "@[function%a@]" o#match_case a - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - pp f "@[@[<2>if@ %a@]@ @[<2>then@ %a@]@ @[<2>else@ %a@]@]" - o#expr e1 o#under_semi#expr e2 o#under_semi#expr e3 - | <:expr< lazy $e$ >> -> pp f "@[<2>lazy@ %a@]" o#simple_expr e - | <:expr< let $rec:r$ $bi$ in $e$ >> -> - match e with - [ <:expr< let $rec:_$ $_$ in $_$ >> -> - pp f "@[<0>@[<2>let %a%a in@]@ %a@]" - o#rec_flag r o#binding bi o#reset_semi#expr e - | _ -> - pp f "@[@[<2>let %a%a@]@ @[in@ %a@]@]" - o#rec_flag r o#binding bi o#reset_semi#expr e ] - | <:expr< let open $i$ in $e$ >> -> - pp f "@[<2>let open %a@]@ @[<2>in@ %a@]" - o#ident i o#reset_semi#expr e - | <:expr< match $e$ with [ $a$ ] >> -> - pp f "@[@[@[<2>match %a@]@ with@]%a@]" - o#expr e o#match_case a - | <:expr< try $e$ with [ $a$ ] >> -> - pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" - o#expr e o#match_case a - | <:expr< assert False >> -> pp f "@[<2>assert@ false@]" - | <:expr< assert $e$ >> -> pp f "@[<2>assert@ %a@]" o#dot_expr e - | <:expr< let module $s$ = $me$ in $e$ >> -> - pp f "@[<2>let module %a =@ %a@]@ @[<2>in@ %a@]" o#var s o#module_expr me o#reset_semi#expr e - | <:expr< object $cst$ end >> -> - pp f "@[@[object@ %a@]@ end@]" o#class_str_item cst - | <:expr< object ($p$ : $t$) $cst$ end >> -> - pp f "@[@[object @[<1>(%a :@ %a)@]@ %a@]@ end@]" - o#patt p o#ctyp t o#class_str_item cst - | <:expr< object ($p$) $cst$ end >> -> - pp f "@[@[object @[<2>(%a)@]@ %a@]@ end@]" - o#patt p o#class_str_item cst - | e -> o#apply_expr f e ]; - - method apply_expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr< new $i$ >> -> pp f "@[<2>new@ %a@]" o#ident i - | e -> o#dot_expr f e ]; - - method dot_expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr< $e$.val >> -> pp f "@[<2>!@,%a@]" o#simple_expr e - | <:expr< $e1$ . $e2$ >> -> pp f "@[<2>%a.@,%a@]" o#dot_expr e1 o#dot_expr e2 - | <:expr< $e1$ .( $e2$ ) >> -> - pp f "@[<2>%a.@,(%a)@]" o#dot_expr e1 o#expr e2 - | <:expr< $e1$ .[ $e2$ ] >> -> - pp f "%a.@[<1>[@,%a@]@,]" o#dot_expr e1 o#expr e2 - | <:expr< $e$ # $s$ >> -> pp f "@[<2>%a#@,%s@]" o#dot_expr e s - | e -> o#simple_expr f e ]; - - method simple_expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr<>> -> () - | <:expr< do { $e$ } >> -> - pp f "@[(%a)@]" o#seq e - | <:expr< [$_$ :: $_$] >> -> o#expr_list_cons True f e - | <:expr< ( $tup:e$ ) >> -> - pp f "@[<1>(%a)@]" o#expr e - | <:expr< [| $e$ |] >> -> - pp f "@[<0>@[<2>[|@ %a@]@ |]@]" o#under_semi#expr e - | <:expr< ($e$ :> $t$) >> -> - pp f "@[<2>(%a :>@ %a)@]" o#expr e o#ctyp t - | <:expr< ($e$ : $t1$ :> $t2$) >> -> - pp f "@[<2>(%a :@ %a :>@ %a)@]" o#expr e o#ctyp t1 o#ctyp t2 - | <:expr< ($e$ : $t$) >> -> - pp f "@[<2>(%a :@ %a)@]" o#expr e o#ctyp t - | <:expr< $anti:s$ >> -> o#anti f s - | <:expr< for $s$ = $e1$ $to:df$ $e2$ do { $e3$ } >> -> - pp f "@[@[@[<2>for %a =@ %a@ %a@ %a@ do@]@ %a@]@ done@]" - o#var s o#expr e1 o#direction_flag df o#expr e2 o#seq e3 - | <:expr< $int:s$ >> -> o#numeric f s "" - | <:expr< $nativeint:s$ >> -> o#numeric f s "n" - | <:expr< $int64:s$ >> -> o#numeric f s "L" - | <:expr< $int32:s$ >> -> o#numeric f s "l" - | <:expr< $flo:s$ >> -> o#numeric f s "" - | <:expr< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) - | <:expr< $id:i$ >> -> o#var_ident f i - | <:expr< { $b$ } >> -> - pp f "@[@[{%a@]@ }@]" o#record_binding b - | <:expr< { ($e$) with $b$ } >> -> - pp f "@[@[{@ (%a)@ with%a@]@ }@]" - o#expr e o#record_binding b - | <:expr< $str:s$ >> -> pp f "\"%s\"" s - | <:expr< while $e1$ do { $e2$ } >> -> - pp f "@[<2>while@ %a@ do@ %a@ done@]" o#expr e1 o#seq e2 - | <:expr< ~ $s$ >> -> pp f "~%s" s - | <:expr< ~ $s$ : $e$ >> -> pp f "@[<2>~%s:@ %a@]" s o#dot_expr e - | <:expr< ? $s$ >> -> pp f "?%s" s - | <:expr< ? $s$ : $e$ >> -> pp f "@[<2>?%s:@ %a@]" s o#dot_expr e - | <:expr< ` $lid:s$ >> -> pp f "`%a" o#var s - | <:expr< {< $b$ >} >> -> - pp f "@[@[{<%a@]@ >}@]" o#record_binding b - | <:expr< $e1$, $e2$ >> -> - pp f "%a,@ %a" o#simple_expr e1 o#simple_expr e2 - | <:expr< $e1$; $e2$ >> -> - pp f "%a;@ %a" o#under_semi#expr e1 o#expr e2 - | <:expr< (module $me$ : $mt$) >> -> - pp f "@[@[(module %a : %a@])@]" - o#module_expr me o#module_type mt - | <:expr< (module $me$) >> -> - pp f "@[@[(module %a@])@]" o#module_expr me - | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | - <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | - <:expr< $_$ # $_$ >> | - <:expr< fun [ $_$ ] >> | <:expr< fun (type $_$) -> $_$ >> | <:expr< match $_$ with [ $_$ ] >> | - <:expr< try $_$ with [ $_$ ] >> | - <:expr< if $_$ then $_$ else $_$ >> | - <:expr< let $rec:_$ $_$ in $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >> | - <:expr< let open $_$ in $_$ >> | - <:expr< assert $_$ >> | <:expr< assert False >> | - <:expr< lazy $_$ >> | <:expr< new $_$ >> | - <:expr< object ($_$) $_$ end >> -> - pp f "(%a)" o#reset#expr e ]; - - method direction_flag f b = - match b with - [ Ast.DiTo -> pp_print_string f "to" - | Ast.DiDownto -> pp_print_string f "downto" - | Ast.DiAnt s -> o#anti f s ]; - - method patt f p = - let () = o#node f p Ast.loc_of_patt in match p with - [ <:patt< ( $p1$ as $p2$ ) >> -> pp f "@[<1>(%a@ as@ %a)@]" o#patt p1 o#patt p2 - | <:patt< $i$ = $p$ >> -> pp f "@[<2>%a =@ %a@]" o#var_ident i o#patt p - | <:patt< $p1$; $p2$ >> -> pp f "%a;@ %a" o#patt p1 o#patt p2 - | p -> o#patt1 f p ]; - - method patt1 f = fun - [ <:patt< $p1$ | $p2$ >> -> pp f "@[<2>%a@ |@ %a@]" o#patt1 p1 o#patt2 p2 - | p -> o#patt2 f p ]; - - method patt2 f = fun - [ (* <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p - | *) p -> o#patt3 f p ]; - - method patt3 f = fun - [ <:patt< $p1$ .. $p2$ >> -> pp f "@[<2>%a@ ..@ %a@]" o#patt3 p1 o#patt4 p2 - | <:patt< $p1$, $p2$ >> -> pp f "%a,@ %a" o#patt3 p1 o#patt3 p2 - | p -> o#patt4 f p ]; - - method patt4 f = fun - [ <:patt< [$_$ :: $_$] >> as p -> - let (pl, c) = o#mk_patt_list p in - match c with - [ None -> pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl - | Some x -> pp f "@[<2>%a@]" (list o#patt5 " ::@ ") (pl @ [x]) ] - | p -> o#patt5 f p ]; - - method patt5 f = fun - [ <:patt< [$_$ :: $_$] >> as p -> o#simple_patt f p - | <:patt< lazy $p$ >> -> - pp f "@[<2>lazy %a@]" o#simple_patt p - | <:patt< $x$ $y$ >> -> - let (a, al) = get_patt_args x [y] in - if not (Ast.is_patt_constructor a) then - Format.eprintf "WARNING: strange pattern application of a non constructor@." - else if curry_constr then - pp f "@[<2>%a@]" (list o#simple_patt "@ ") [a::al] - else - match al with - [ [ <:patt< ($tup:_$) >> ] -> - pp f "@[<2>%a@ (%a)@]" o#simple_patt x o#patt y - | [_] -> pp f "@[<2>%a@ %a@]" o#patt5 x o#simple_patt y - | al -> pp f "@[<2>%a@ (%a)@]" o#patt5 a - (list o#simple_patt ",@ ") al ] - | p -> o#simple_patt f p ]; - - method simple_patt f p = - let () = o#node f p Ast.loc_of_patt in - match p with - [ <:patt<>> -> () - | <:patt< $id:i$ >> -> o#var_ident f i - | <:patt< $anti:s$ >> -> o#anti f s - | <:patt< _ >> -> pp f "_" - | <:patt< ( module $m$ ) >> -> pp f "(module %s)" m - | <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p - | <:patt< { $p$ } >> -> pp f "@[{@ %a@]@ }" o#patt p - | <:patt< $str:s$ >> -> pp f "\"%s\"" s - | <:patt< ( $p$ : $t$ ) >> -> pp f "@[<1>(%a :@ %a)@]" o#patt p o#ctyp t - | <:patt< $nativeint:s$ >> -> o#numeric f s "n" - | <:patt< $int64:s$ >> -> o#numeric f s "L" - | <:patt< $int32:s$ >> -> o#numeric f s "l" - | <:patt< $int:s$ >> -> o#numeric f s "" - | <:patt< $flo:s$ >> -> o#numeric f s "" - | <:patt< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) - | <:patt< ~ $s$ >> -> pp f "~%s" s - | <:patt< ` $uid:s$ >> -> pp f "`%a" o#var s - | <:patt< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i - | <:patt< [| $p$ |] >> -> pp f "@[<2>[|@ %a@]@ |]" o#patt p - | <:patt< ~ $s$ : ($p$) >> -> pp f "@[<2>~%s:@ (%a)@]" s o#patt p - | <:patt< ? $s$ >> -> pp f "?%s" s - | <:patt< ?($p$) >> -> - pp f "@[<2>?(%a)@]" o#patt_tycon p - | <:patt< ? $s$ : ($p$) >> -> - pp f "@[<2>?%s:@,@[<1>(%a)@]@]" s o#patt_tycon p - | <:patt< ?($p$ = $e$) >> -> - pp f "@[<2>?(%a =@ %a)@]" o#patt_tycon p o#expr e - | <:patt< ? $s$ : ($p$ = $e$) >> -> - pp f "@[<2>?%s:@,@[<1>(%a =@ %a)@]@]" s o#patt_tycon p o#expr e - | <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> | - <:patt< $_$ .. $_$ >> | <:patt< $_$, $_$ >> | - <:patt< $_$; $_$ >> | <:patt< $_$ = $_$ >> | <:patt< lazy $_$ >> as p -> - pp f "@[<1>(%a)@]" o#patt p - ]; - - method patt_tycon f = - fun - [ <:patt< ( $p$ : $t$ ) >> -> pp f "%a :@ %a" o#patt p o#ctyp t - | p -> o#patt f p ]; - - method simple_ctyp f t = - let () = o#node f t Ast.loc_of_ctyp in - match t with - [ <:ctyp< $id:i$ >> -> o#ident f i - | <:ctyp< $anti:s$ >> -> o#anti f s - | <:ctyp< _ >> -> pp f "_" - | Ast.TyAnP _ -> pp f "+_" - | Ast.TyAnM _ -> pp f "-_" - | <:ctyp< ~ $s$ : $t$ >> -> pp f "@[<2>%s:@ %a@]" s o#simple_ctyp t - | <:ctyp< ? $s$ : $t$ >> -> pp f "@[<2>?%s:@ %a@]" s o#simple_ctyp t - | <:ctyp< < > >> -> pp f "< >" - | <:ctyp< < .. > >> -> pp f "< .. >" - | <:ctyp< < $t$ .. > >> -> pp f "@[<0>@[<2><@ %a;@ ..@]@ >@]" o#ctyp t - | <:ctyp< < $t$ > >> -> pp f "@[<0>@[<2><@ %a@]@ >@]" o#ctyp t - | <:ctyp< '$s$ >> -> pp f "'%a" o#var s - | <:ctyp< { $t$ } >> -> pp f "@[<2>{@ %a@]@ }" o#ctyp t - | <:ctyp< [ $t$ ] >> -> pp f "@[<0>%a@]" o#sum_type t - | <:ctyp< ( $tup:t$ ) >> -> pp f "@[<1>(%a)@]" o#ctyp t - | <:ctyp< (module $mt$) >> -> pp f "@[<2>(module@ %a@])" o#module_type mt - | <:ctyp< [ = $t$ ] >> -> pp f "@[<2>[@ %a@]@ ]" o#sum_type t - | <:ctyp< [ < $t$ ] >> -> pp f "@[<2>[<@ %a@]@,]" o#sum_type t - | <:ctyp< [ < $t1$ > $t2$ ] >> -> - let (a, al) = get_ctyp_args t2 [] in - pp f "@[<2>[<@ %a@ >@ %a@]@ ]" o#sum_type t1 - (list o#simple_ctyp "@ ") [a::al] - | <:ctyp< [ > $t$ ] >> -> pp f "@[<2>[>@ %a@]@,]" o#sum_type t - | <:ctyp< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i - | <:ctyp< `$s$ >> -> pp f "`%a" o#var s - | <:ctyp< $t1$ * $t2$ >> -> pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2 - | <:ctyp<>> -> assert False - | t -> pp f "@[<1>(%a)@]" o#ctyp t ]; - - method ctyp f t = - let () = o#node f t Ast.loc_of_ctyp in - match t with - [ <:ctyp< $t1$ as $t2$ >> -> pp f "@[<2>%a@ as@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 - | <:ctyp< $t1$ -> $t2$ >> -> pp f "@[<2>%a@ ->@ %a@]" o#ctyp1 t1 o#ctyp t2 - | <:ctyp< +'$s$ >> -> pp f "+'%a" o#var s - | <:ctyp< -'$s$ >> -> pp f "-'%a" o#var s - | <:ctyp< $t1$ | $t2$ >> -> pp f "%a@ | %a" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$ : mutable $t2$ >> -> - pp f "@[mutable@ %a :@ %a@]" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$ : $t2$ >> -> pp f "@[<2>%a :@ %a@]" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$; $t2$ >> -> pp f "%a;@ %a" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t$ of $<:ctyp<>>$ >> -> o#ctyp f t - | <:ctyp< $t1$ of $t2$ >> -> - pp f "@[%a@ @[<3>of@ %a@]@]" o#ctyp t1 o#constructor_type t2 - | <:ctyp< $t1$ of & $t2$ >> -> - pp f "@[%a@ @[<3>of &@ %a@]@]" o#ctyp t1 o#constructor_type t2 - | <:ctyp< $t1$ and $t2$ >> -> pp f "%a@ and %a" o#ctyp t1 o#ctyp t2 - | <:ctyp< mutable $t$ >> -> pp f "@[<2>mutable@ %a@]" o#ctyp t - | <:ctyp< $t1$ & $t2$ >> -> pp f "%a@ &@ %a" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$ == $t2$ >> -> - pp f "@[<2>%a =@ %a@]" o#simple_ctyp t1 o#ctyp t2 - | Ast.TyDcl _ tn tp te cl -> do { - pp f "@[<2>%a%a@]" o#type_params tp o#var tn; - match te with - [ <:ctyp<>> -> () - | _ -> pp f " =@ %a" o#ctyp te ]; - if cl <> [] then pp f "@ %a" (list o#constrain "@ ") cl else (); - } - | t -> o#ctyp1 f t ]; - - method ctyp1 f = fun - [ <:ctyp< $t1$ $t2$ >> -> - match get_ctyp_args t1 [t2] with - [ (_, [_]) -> pp f "@[<2>%a@ %a@]" o#simple_ctyp t2 o#simple_ctyp t1 - | (a, al) -> pp f "@[<2>(%a)@ %a@]" (list o#ctyp ",@ ") al o#simple_ctyp a ] - | <:ctyp< ! $t1$ . $t2$ >> -> - let (a, al) = get_ctyp_args t1 [] in - pp f "@[<2>%a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 - | Ast.TyTypePol (_,t1,t2) -> - let (a, al) = get_ctyp_args t1 [] in - pp f "@[<2>type %a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 - | <:ctyp< private $t$ >> -> pp f "@[private@ %a@]" o#simple_ctyp t - | t -> o#simple_ctyp f t ]; - - method constructor_type f t = - match t with - [ <:ctyp@loc< $t1$ and $t2$ >> -> - let () = o#node f t (fun _ -> loc) in - pp f "%a@ * %a" o#constructor_type t1 o#constructor_type t2 - | <:ctyp< $_$ -> $_$ >> -> pp f "(%a)" o#ctyp t - | t -> o#ctyp f t ]; - - - method sig_item f sg = - let () = o#node f sg Ast.loc_of_sig_item in - match sg with - [ <:sig_item<>> -> () - | <:sig_item< $sg$; $<:sig_item<>>$ >> | - <:sig_item< $<:sig_item<>>$; $sg$ >> -> - o#sig_item f sg - | <:sig_item< $sg1$; $sg2$ >> -> - do { o#sig_item f sg1; cut f; o#sig_item f sg2 } - | <:sig_item< exception $t$ >> -> - pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep - | <:sig_item< external $s$ : $t$ = $sl$ >> -> - pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" - o#var s o#ctyp t (meta_list o#quoted_string "@ ") sl semisep - | <:sig_item< module $s1$ ($s2$ : $mt1$) : $mt2$ >> -> - let rec loop accu = - fun - [ <:module_type< functor ($s$ : $mt1$) -> $mt2$ >> -> - loop [(s, mt1)::accu] mt2 - | mt -> (List.rev accu, mt) ] in - let (al, mt) = loop [(s2, mt1)] mt2 in - pp f "@[<2>module %a@ @[<0>%a@] :@ %a%(%)@]" - o#var s1 o#functor_args al o#module_type mt semisep - | <:sig_item< module $s$ : $mt$ >> -> - pp f "@[<2>module %a :@ %a%(%)@]" - o#var s o#module_type mt semisep - | <:sig_item< module type $s$ = $ <:module_type<>> $ >> -> - pp f "@[<2>module type %a%(%)@]" o#var s semisep - | <:sig_item< module type $s$ = $mt$ >> -> - pp f "@[<2>module type %a =@ %a%(%)@]" - o#var s o#module_type mt semisep - | <:sig_item< open $sl$ >> -> - pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep - | <:sig_item< type $t$ >> -> - pp f "@[@[type %a@]%(%)@]" o#ctyp t semisep - | <:sig_item< value $s$ : $t$ >> -> - pp f "@[<2>%s %a :@ %a%(%)@]" - o#value_val o#var s o#ctyp t semisep - | <:sig_item< include $mt$ >> -> - pp f "@[<2>include@ %a%(%)@]" o#module_type mt semisep - | <:sig_item< class type $ct$ >> -> - pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep - | <:sig_item< class $ce$ >> -> - pp f "@[<2>class %a%(%)@]" o#class_type ce semisep - | <:sig_item< module rec $mb$ >> -> - pp f "@[<2>module rec %a%(%)@]" - o#module_rec_binding mb semisep - | <:sig_item< # $_$ $_$ >> -> () - | <:sig_item< $anti:s$ >> -> - pp f "%a%(%)" o#anti s semisep ]; - - method str_item f st = - let () = o#node f st Ast.loc_of_str_item in - match st with - [ <:str_item<>> -> () - | <:str_item< $st$; $<:str_item<>>$ >> | - <:str_item< $<:str_item<>>$; $st$ >> -> - o#str_item f st - | <:str_item< $st1$; $st2$ >> -> - do { o#str_item f st1; cut f; o#str_item f st2 } - | <:str_item< exception $t$ >> -> - pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep - | <:str_item< exception $t$ = $sl$ >> -> - pp f "@[<2>exception@ %a =@ %a%(%)@]" o#ctyp t o#ident sl semisep - | <:str_item< external $s$ : $t$ = $sl$ >> -> - pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" - o#var s o#ctyp t (meta_list o#quoted_string "@ ") sl semisep - | <:str_item< module $s1$ ($s2$ : $mt1$) = $me$ >> -> - match o#module_expr_get_functor_args [(s2, mt1)] me with - [ (al, me, Some mt2) -> - pp f "@[<2>module %a@ @[<0>%a@] :@ %a =@ %a%(%)@]" - o#var s1 o#functor_args al o#module_type mt2 - o#module_expr me semisep - | (al, me, _) -> - pp f "@[<2>module %a@ @[<0>%a@] =@ %a%(%)@]" - o#var s1 o#functor_args al o#module_expr me semisep ] - | <:str_item< module $s$ : $mt$ = $me$ >> -> - pp f "@[<2>module %a :@ %a =@ %a%(%)@]" - o#var s o#module_type mt o#module_expr me semisep - | <:str_item< module $s$ = $me$ >> -> - pp f "@[<2>module %a =@ %a%(%)@]" o#var s o#module_expr me semisep - | <:str_item< module type $s$ = $mt$ >> -> - pp f "@[<2>module type %a =@ %a%(%)@]" - o#var s o#module_type mt semisep - | <:str_item< open $sl$ >> -> - pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep - | <:str_item< type $t$ >> -> - pp f "@[@[type %a@]%(%)@]" o#ctyp t semisep - | <:str_item< value $rec:r$ $bi$ >> -> - pp f "@[<2>%s %a%a%(%)@]" o#value_let o#rec_flag r o#binding bi semisep - | <:str_item< $exp:e$ >> -> - pp f "@[<2>let _ =@ %a%(%)@]" o#expr e semisep - | <:str_item< include $me$ >> -> - pp f "@[<2>include@ %a%(%)@]" o#simple_module_expr me semisep - | <:str_item< class type $ct$ >> -> - pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep - | <:str_item< class $ce$ >> -> - pp f "@[class %a%(%)@]" o#class_declaration ce semisep - | <:str_item< module rec $mb$ >> -> - pp f "@[<2>module rec %a%(%)@]" o#module_rec_binding mb semisep - | <:str_item< # $_$ $_$ >> -> () - | <:str_item< $anti:s$ >> -> pp f "%a%(%)" o#anti s semisep - | Ast.StExc _ _ (Ast.OAnt _) -> assert False ]; - - method module_type f mt = - let () = o#node f mt Ast.loc_of_module_type in - match mt with - [ <:module_type<>> -> assert False - | <:module_type< module type of $me$ >> -> - pp f "@[<2>module type of@ %a@]" o#module_expr me - | <:module_type< $id:i$ >> -> o#ident f i - | <:module_type< $anti:s$ >> -> o#anti f s - | <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> - pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" - o#var s o#module_type mt1 o#module_type mt2 - | <:module_type< '$s$ >> -> pp f "'%a" o#var s - | <:module_type< sig $sg$ end >> -> - pp f "@[@[sig@ %a@]@ end@]" o#sig_item sg - | <:module_type< $mt$ with $wc$ >> -> - pp f "@[<2>%a@ with@ %a@]" o#module_type mt o#with_constraint wc ]; - - method with_constraint f wc = - let () = o#node f wc Ast.loc_of_with_constr in - match wc with - [ <:with_constr<>> -> () - | <:with_constr< type $t1$ = $t2$ >> -> - pp f "@[<2>type@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 - | <:with_constr< module $i1$ = $i2$ >> -> - pp f "@[<2>module@ %a =@ %a@]" o#ident i1 o#ident i2 - | <:with_constr< type $t1$ := $t2$ >> -> - pp f "@[<2>type@ %a :=@ %a@]" o#ctyp t1 o#ctyp t2 - | <:with_constr< module $i1$ := $i2$ >> -> - pp f "@[<2>module@ %a :=@ %a@]" o#ident i1 o#ident i2 - | <:with_constr< $wc1$ and $wc2$ >> -> - do { o#with_constraint f wc1; pp f o#andsep; o#with_constraint f wc2 } - | <:with_constr< $anti:s$ >> -> o#anti f s ]; - - method module_expr f me = - let () = o#node f me Ast.loc_of_module_expr in - match me with - [ <:module_expr<>> -> assert False - | <:module_expr< ( struct $st$ end : sig $sg$ end ) >> -> - pp f "@[<2>@[struct@ %a@]@ end :@ @[sig@ %a@]@ end@]" - o#str_item st o#sig_item sg - | _ -> o#simple_module_expr f me ]; - - method simple_module_expr f me = - let () = o#node f me Ast.loc_of_module_expr in - match me with - [ <:module_expr<>> -> assert False - | <:module_expr< $id:i$ >> -> o#ident f i - | <:module_expr< $anti:s$ >> -> o#anti f s - | <:module_expr< $me1$ $me2$ >> -> - pp f "@[<2>%a@,(%a)@]" o#module_expr me1 o#module_expr me2 - | <:module_expr< functor ( $s$ : $mt$ ) -> $me$ >> -> - pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" o#var s o#module_type mt o#module_expr me - | <:module_expr< struct $st$ end >> -> - pp f "@[@[struct@ %a@]@ end@]" o#str_item st - | <:module_expr< ( $me$ : $mt$ ) >> -> - pp f "@[<1>(%a :@ %a)@]" o#module_expr me o#module_type mt - | <:module_expr< (value $e$ : $mt$ ) >> -> - pp f "@[<1>(%s %a :@ %a)@]" o#value_val o#expr e o#module_type mt - | <:module_expr< (value $e$ ) >> -> - pp f "@[<1>(%s %a)@]" o#value_val o#expr e - ]; - - method class_expr f ce = - let () = o#node f ce Ast.loc_of_class_expr in - match ce with - [ <:class_expr< $ce$ $e$ >> -> - pp f "@[<2>%a@ %a@]" o#class_expr ce o#apply_expr e - | <:class_expr< $id:i$ >> -> - pp f "@[<2>%a@]" o#ident i - | <:class_expr< $id:i$ [ $t$ ] >> -> - pp f "@[<2>@[<1>[%a]@]@ %a@]" o#class_params t o#ident i - | <:class_expr< virtual $lid:i$ >> -> - pp f "@[<2>virtual@ %a@]" o#var i - | <:class_expr< virtual $lid:i$ [ $t$ ] >> -> - pp f "@[<2>virtual@ @[<1>[%a]@]@ %a@]" o#class_params t o#var i - | <:class_expr< fun $p$ -> $ce$ >> -> - pp f "@[<2>fun@ %a@ ->@ %a@]" o#simple_patt p o#class_expr ce - | <:class_expr< let $rec:r$ $bi$ in $ce$ >> -> - pp f "@[<2>let %a%a@]@ @[<2>in@ %a@]" - o#rec_flag r o#binding bi o#class_expr ce - | <:class_expr< object $cst$ end >> -> - pp f "@[@[object %a@]@ end@]" o#class_str_item cst - | <:class_expr< object ($p$) $cst$ end >> -> - pp f "@[@[object @[<1>(%a)@]@ %a@]@ end@]" - o#patt p o#class_str_item cst - | <:class_expr< ( $ce$ : $ct$ ) >> -> - pp f "@[<1>(%a :@ %a)@]" o#class_expr ce o#class_type ct - | <:class_expr< $anti:s$ >> -> o#anti f s - | <:class_expr< $ce1$ and $ce2$ >> -> - do { o#class_expr f ce1; pp f o#andsep; o#class_expr f ce2 } - | <:class_expr< $ce1$ = fun $p$ -> $ce2$ >> when is_irrefut_patt p -> - pp f "@[<2>%a@ %a" o#class_expr ce1 - o#patt_class_expr_fun_args (p, ce2) - | <:class_expr< $ce1$ = $ce2$ >> -> - pp f "@[<2>%a =@]@ %a" o#class_expr ce1 o#class_expr ce2 - | _ -> assert False ]; - - method class_type f ct = - let () = o#node f ct Ast.loc_of_class_type in - match ct with - [ <:class_type< $id:i$ >> -> - pp f "@[<2>%a@]" o#ident i - | <:class_type< $id:i$ [ $t$ ] >> -> - pp f "@[<2>[@,%a@]@,]@ %a" o#class_params t o#ident i - | <:class_type< virtual $lid:i$ >> -> - pp f "@[<2>virtual@ %a@]" o#var i - | <:class_type< virtual $lid:i$ [ $t$ ] >> -> - pp f "@[<2>virtual@ [@,%a@]@,]@ %a" o#class_params t o#var i - | <:class_type< [ $t$ ] -> $ct$ >> -> - pp f "@[<2>%a@ ->@ %a@]" o#simple_ctyp t o#class_type ct - | <:class_type< object $csg$ end >> -> - pp f "@[@[object@ %a@]@ end@]" o#class_sig_item csg - | <:class_type< object ($t$) $csg$ end >> -> - pp f "@[@[object @[<1>(%a)@]@ %a@]@ end@]" - o#ctyp t o#class_sig_item csg - | <:class_type< $anti:s$ >> -> o#anti f s - | <:class_type< $ct1$ and $ct2$ >> -> - do { o#class_type f ct1; pp f o#andsep; o#class_type f ct2 } - | <:class_type< $ct1$ : $ct2$ >> -> - pp f "%a :@ %a" o#class_type ct1 o#class_type ct2 - | <:class_type< $ct1$ = $ct2$ >> -> - pp f "%a =@ %a" o#class_type ct1 o#class_type ct2 - | _ -> assert False ]; - - method class_sig_item f csg = - let () = o#node f csg Ast.loc_of_class_sig_item in - match csg with - [ <:class_sig_item<>> -> () - | <:class_sig_item< $csg$; $<:class_sig_item<>>$ >> | - <:class_sig_item< $<:class_sig_item<>>$; $csg$ >> -> - o#class_sig_item f csg - | <:class_sig_item< $csg1$; $csg2$ >> -> - do { o#class_sig_item f csg1; cut f; o#class_sig_item f csg2 } - | <:class_sig_item< constraint $t1$ = $t2$ >> -> - pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep - | <:class_sig_item< inherit $ct$ >> -> - pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct no_semisep - | <:class_sig_item< method $private:pr$ $s$ : $t$ >> -> - pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag pr o#var s - o#ctyp t no_semisep - | <:class_sig_item< method virtual $private:pr$ $s$ : $t$ >> -> - pp f "@[<2>method virtual %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t no_semisep - | <:class_sig_item< value $mutable:mu$ $virtual:vi$ $s$ : $t$ >> -> - pp f "@[<2>%s %a%a%a :@ %a%(%)@]" - o#value_val o#mutable_flag mu o#virtual_flag vi o#var s o#ctyp t - no_semisep - | <:class_sig_item< $anti:s$ >> -> - pp f "%a%(%)" o#anti s no_semisep ]; - - method class_str_item f cst = - let () = o#node f cst Ast.loc_of_class_str_item in - match cst with - [ <:class_str_item<>> -> () - | <:class_str_item< $cst$; $<:class_str_item<>>$ >> | - <:class_str_item< $<:class_str_item<>>$; $cst$ >> -> - o#class_str_item f cst - | <:class_str_item< $cst1$; $cst2$ >> -> - do { o#class_str_item f cst1; cut f; o#class_str_item f cst2 } - | <:class_str_item< constraint $t1$ = $t2$ >> -> - pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep - | <:class_str_item< inherit $override:ov$ $ce$ >> -> - pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov o#class_expr ce no_semisep - | <:class_str_item< inherit $override:ov$ $ce$ as $lid:s$ >> -> - pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s no_semisep - | <:class_str_item< initializer $e$ >> -> - pp f "@[<2>initializer@ %a%(%)@]" o#expr e no_semisep - | <:class_str_item< method $override:ov$ $private:pr$ $s$ = $e$ >> -> - pp f "@[<2>method%a %a%a =@ %a%(%)@]" - o#override_flag ov o#private_flag pr o#var s o#expr e no_semisep - | <:class_str_item< method $override:ov$ $private:pr$ $s$ : $t$ = $e$ >> -> - pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]" - o#override_flag ov o#private_flag pr o#var s o#ctyp t o#expr e no_semisep - | <:class_str_item< method virtual $private:pr$ $s$ : $t$ >> -> - pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t no_semisep - | <:class_str_item< value virtual $mutable:mu$ $s$ : $t$ >> -> - pp f "@[<2>%s virtual %a%a :@ %a%(%)@]" - o#value_val o#mutable_flag mu o#var s o#ctyp t no_semisep - | <:class_str_item< value $override:ov$ $mutable:mu$ $s$ = $e$ >> -> - pp f "@[<2>%s%a %a%a =@ %a%(%)@]" - o#value_val o#override_flag ov o#mutable_flag mu o#var s o#expr e no_semisep - | <:class_str_item< $anti:s$ >> -> - pp f "%a%(%)" o#anti s no_semisep ]; - - method implem f st = - match st with - [ <:str_item< $exp:e$ >> -> pp f "@[<0>%a%(%)@]@." o#expr e semisep - | st -> pp f "@[%a@]@." o#str_item st ]; - - method interf f sg = pp f "@[%a@]@." o#sig_item sg; - end; - - value with_outfile output_file fct arg = - let call close f = do { - try fct f arg with [ exn -> do { close (); raise exn } ]; - close () - } in - match output_file with - [ None -> call (fun () -> ()) std_formatter - | Some s -> - let oc = open_out s in - let f = formatter_of_out_channel oc in - call (fun () -> close_out oc) f ]; - - value print output_file fct = - let o = new printer () in - with_outfile output_file (fct o); - - value print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg; - - value print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st; - -end; - -module MakeMore (Syntax : Sig.Camlp4Syntax) -: (Sig.Printer Syntax.Ast).S -= struct - - include Make Syntax; - - value semisep : ref sep = ref ("@\n" : sep); - value margin = ref 78; - value comments = ref True; - value locations = ref False; - value curry_constr = ref False; - - value print output_file fct = - let o = new printer ~comments:comments.val - ~curry_constr:curry_constr.val () in - let o = o#set_semisep semisep.val in - let o = if locations.val then o#set_loc_and_comments else o in - with_outfile output_file - (fun f -> - let () = Format.pp_set_margin f margin.val in - Format.fprintf f "@[%a@]@." (fct o)); - - value print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg; - - value print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st; - - value check_sep s = - if String.contains s '%' then failwith "-sep Format error, % found in string" - else (Obj.magic (Struct.Token.Eval.string s : string) : sep); - - Options.add "-l" (Arg.Int (fun i -> margin.val := i)) - " line length for pretty printing."; - - Options.add "-ss" (Arg.Unit (fun () -> semisep.val := ";;")) - " Print double semicolons."; - - Options.add "-no_ss" (Arg.Unit (fun () -> semisep.val := "")) - " Do not print double semicolons (default)."; - - Options.add "-sep" (Arg.String (fun s -> semisep.val := check_sep s)) - " Use this string between phrases."; - - Options.add "-curry-constr" (Arg.Set curry_constr) "Use currified constructors."; - - Options.add "-no_comments" (Arg.Clear comments) "Do not add comments."; - - Options.add "-add_locations" (Arg.Set locations) "Add locations as comment."; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/OCaml.mli ocaml-4.05.0/camlp4/Camlp4/Printers/OCaml.mli --- ocaml-4.01.0/camlp4/Camlp4/Printers/OCaml.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Printers/OCaml.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,167 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Camlp4Syntax) : sig - open Format; - include Sig.Camlp4Syntax - with module Loc = Syntax.Loc - and module Token = Syntax.Token - and module Ast = Syntax.Ast - and module Gram = Syntax.Gram; - - type sep = format unit formatter unit; - type fun_binding = [= `patt of Ast.patt | `newtype of string ]; - - value list' : - (formatter -> 'a -> unit) -> - format 'b formatter unit -> - format unit formatter unit -> - formatter -> list 'a -> unit; - - value list : - (formatter -> 'a -> unit) -> - format 'b formatter unit -> - formatter -> list 'a -> unit; - - value lex_string : string -> Token.t; - value is_infix : string -> bool; - value is_keyword : string -> bool; - value ocaml_char : string -> string; - value get_expr_args : - Ast.expr -> list Ast.expr -> (Ast.expr * list Ast.expr); - value get_patt_args : - Ast.patt -> list Ast.patt -> (Ast.patt * list Ast.patt); - value get_ctyp_args : - Ast.ctyp -> list Ast.ctyp -> (Ast.ctyp * list Ast.ctyp); - value expr_fun_args : Ast.expr -> (list fun_binding * Ast.expr); - - (** - [new printer ~curry_constr:True ~comments:False] - Default values: curry_constr = False - comments = True - *) - class printer : - [?curry_constr: bool] -> [?comments: bool] -> [unit] -> - object ('a) - method interf : formatter -> Ast.sig_item -> unit; - method implem : formatter -> Ast.str_item -> unit; - method sig_item : formatter -> Ast.sig_item -> unit; - method str_item : formatter -> Ast.str_item -> unit; - - value pipe : bool; - value semi : bool; - value semisep : sep; - value no_semisep : sep; - method value_val : string; - method value_let : string; - method andsep : sep; - method anti : formatter -> string -> unit; - method class_declaration : - formatter -> Ast.class_expr -> unit; - method class_expr : formatter -> Ast.class_expr -> unit; - method class_sig_item : - formatter -> Ast.class_sig_item -> unit; - method class_str_item : - formatter -> Ast.class_str_item -> unit; - method class_type : formatter -> Ast.class_type -> unit; - method constrain : - formatter -> (Ast.ctyp * Ast.ctyp) -> unit; - method ctyp : formatter -> Ast.ctyp -> unit; - method ctyp1 : formatter -> Ast.ctyp -> unit; - method constructor_type : formatter -> Ast.ctyp -> unit; - method dot_expr : formatter -> Ast.expr -> unit; - method apply_expr : formatter -> Ast.expr -> unit; - method expr : formatter -> Ast.expr -> unit; - method expr_list : formatter -> list Ast.expr -> unit; - method expr_list_cons : bool -> formatter -> Ast.expr -> unit; - method fun_binding : formatter -> fun_binding -> unit; - method functor_arg : - formatter -> (string * Ast.module_type) -> unit; - method functor_args : - formatter -> - list (string * Ast.module_type) -> unit; - method ident : formatter -> Ast.ident -> unit; - method numeric : formatter -> string -> string -> unit; - method binding : formatter -> Ast.binding -> unit; - method record_binding : formatter -> Ast.rec_binding -> unit; - method match_case : formatter -> Ast.match_case -> unit; - method match_case_aux : formatter -> Ast.match_case -> unit; - method mk_expr_list : Ast.expr -> (list Ast.expr * option Ast.expr); - method mk_patt_list : Ast.patt -> (list Ast.patt * option Ast.patt); - method simple_module_expr : formatter -> Ast.module_expr -> unit; - method module_expr : formatter -> Ast.module_expr -> unit; - method module_expr_get_functor_args : - list (string * Ast.module_type) -> - Ast.module_expr -> - (list (string * Ast.module_type) * - Ast.module_expr * - option Ast.module_type); - method module_rec_binding : formatter -> Ast.module_binding -> unit; - method module_type : formatter -> Ast.module_type -> unit; - method override_flag : formatter -> Ast.override_flag -> unit; - method mutable_flag : formatter -> Ast.mutable_flag -> unit; - method direction_flag : formatter -> Ast.direction_flag -> unit; - method rec_flag : formatter -> Ast.rec_flag -> unit; - method node : formatter -> 'b -> ('b -> Loc.t) -> unit; - method patt : formatter -> Ast.patt -> unit; - method patt1 : formatter -> Ast.patt -> unit; - method patt2 : formatter -> Ast.patt -> unit; - method patt3 : formatter -> Ast.patt -> unit; - method patt4 : formatter -> Ast.patt -> unit; - method patt5 : formatter -> Ast.patt -> unit; - method patt_tycon : formatter -> Ast.patt -> unit; - method patt_expr_fun_args : - formatter -> (fun_binding * Ast.expr) -> unit; - method patt_class_expr_fun_args : - formatter -> (Ast.patt * Ast.class_expr) -> unit; - method print_comments_before : Loc.t -> formatter -> unit; - method private_flag : formatter -> Ast.private_flag -> unit; - method virtual_flag : formatter -> Ast.virtual_flag -> unit; - method quoted_string : formatter -> string -> unit; - method raise_match_failure : formatter -> Loc.t -> unit; - method reset : 'a; - method reset_semi : 'a; - method semisep : sep; - method set_comments : bool -> 'a; - method set_curry_constr : bool -> 'a; - method set_loc_and_comments : 'a; - method set_semisep : sep -> 'a; - method simple_ctyp : formatter -> Ast.ctyp -> unit; - method simple_expr : formatter -> Ast.expr -> unit; - method simple_patt : formatter -> Ast.patt -> unit; - method seq : formatter -> Ast.expr -> unit; - method string : formatter -> string -> unit; - method sum_type : formatter -> Ast.ctyp -> unit; - method type_params : formatter -> list Ast.ctyp -> unit; - method class_params : formatter -> Ast.ctyp -> unit; - method under_pipe : 'a; - method under_semi : 'a; - method var : formatter -> string -> unit; - method with_constraint : formatter -> Ast.with_constr -> unit; - end; - - value with_outfile : - option string -> (formatter -> 'a -> unit) -> 'a -> unit; - - value print : - option string -> (printer -> formatter -> 'a -> unit) -> 'a -> unit; -end; - -module MakeMore (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/OCamlr.ml ocaml-4.05.0/camlp4/Camlp4/Printers/OCamlr.ml --- ocaml-4.01.0/camlp4/Camlp4/Printers/OCamlr.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Printers/OCamlr.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,324 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -open Format; - -module Id = struct - value name = "Camlp4.Printers.OCamlr"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Camlp4Syntax) = struct - include Syntax; - open Sig; - - module PP_o = OCaml.Make Syntax; - - open PP_o; - - value pp = fprintf; - - value is_keyword = - let keywords = ["where"] - and not_keywords = ["false"; "function"; "true"; "val"] - in fun s -> not (List.mem s not_keywords) - && (is_keyword s || List.mem s keywords); - - class printer ?curry_constr:(init_curry_constr = True) ?(comments = True) () = - object (o) - inherit PP_o.printer ~curry_constr:init_curry_constr ~comments () as super; - - value! semisep : sep = ";"; - value! no_semisep : sep = ";"; - value mode = if comments then `comments else `no_comments; - value curry_constr = init_curry_constr; - value first_match_case = True; - - method andsep : sep = "@]@ @[<2>and@ "; - method value_val = "value"; - method value_let = "value"; - method under_pipe = o; - method under_semi = o; - method reset_semi = o; - method reset = o; - method private unset_first_match_case = {< first_match_case = False >}; - method private set_first_match_case = {< first_match_case = True >}; - - method seq f e = - let rec self right f e = - let go_right = self right and go_left = self False in - match e with - [ <:expr< let $rec:r$ $bi$ in $e1$ >> -> - if right then - pp f "@[<2>let %a%a@];@ %a" - o#rec_flag r o#binding bi go_right e1 - else - pp f "(%a)" o#expr e - | <:expr< do { $e$ } >> -> go_right f e - | <:expr< $e1$; $e2$ >> -> do { - pp f "%a;@ " go_left e1; - match (right, e2) with - [ (True, <:expr< let $rec:r$ $bi$ in $e3$ >>) -> - pp f "@[<2>let %a%a@];@ %a" - o#rec_flag r o#binding bi go_right e3 - | _ -> go_right f e2 ] } - | e -> o#expr f e ] - in self True f e; - - method var f = - fun - [ "" -> pp f "$lid:\"\"$" - | "[]" -> pp f "[]" - | "()" -> pp f "()" - | " True" -> pp f "True" - | " False" -> pp f "False" - | v -> - match lex_string v with - [ (LIDENT s | UIDENT s | ESCAPED_IDENT s) when is_keyword s -> - pp f "%s__" s - | SYMBOL s -> - pp f "( %s )" s - | LIDENT s | UIDENT s | ESCAPED_IDENT s -> - pp_print_string f s - | tok -> failwith (sprintf - "Bad token used as an identifier: %s" - (Token.to_string tok)) ] ]; - - method type_params f = - fun - [ [] -> () - | [x] -> pp f "@ %a" o#ctyp x - | l -> pp f "@ @[<1>%a@]" (list o#ctyp "@ ") l ]; - - method match_case f = - fun - [ <:match_case<>> -> pp f "@ []" - | m -> pp f "@ [ %a ]" o#set_first_match_case#match_case_aux m ]; - - method match_case_aux f = - fun - [ <:match_case<>> -> () - | <:match_case< $anti:s$ >> -> o#anti f s - | <:match_case< $a1$ | $a2$ >> -> - pp f "%a%a" o#match_case_aux a1 o#unset_first_match_case#match_case_aux a2 - | <:match_case< $p$ -> $e$ >> -> - let () = if first_match_case then () else pp f "@ | " in - pp f "@[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr e - | <:match_case< $p$ when $w$ -> $e$ >> -> - let () = if first_match_case then () else pp f "@ | " in - pp f "@[<2>%a@ when@ %a@ ->@ %a@]" - o#patt p o#under_pipe#expr w o#under_pipe#expr e ]; - - method sum_type f = - fun - [ <:ctyp<>> -> pp f "[]" - | t -> pp f "@[[ %a ]@]" o#ctyp t - ]; - - method ident f i = - let () = o#node f i Ast.loc_of_ident in - match i with - [ <:ident< $i1$ $i2$ >> -> pp f "%a@ %a" o#dot_ident i1 o#dot_ident i2 - | i -> o#dot_ident f i ]; - - method private dot_ident f i = - let () = o#node f i Ast.loc_of_ident in - match i with - [ <:ident< $i1$.$i2$ >> -> pp f "%a.@,%a" o#dot_ident i1 o#dot_ident i2 - | <:ident< $anti:s$ >> -> o#anti f s - | <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> o#var f s - | i -> pp f "(%a)" o#ident i ]; - - method patt4 f = fun - [ <:patt< [$_$ :: $_$] >> as p -> - let (pl, c) = o#mk_patt_list p in - match c with - [ None -> pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl - | Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#patt ";@ ") pl o#patt x ] - | p -> super#patt4 f p ]; - - method expr_list_cons _ f e = - let (el, c) = o#mk_expr_list e in - match c with - [ None -> o#expr_list f el - | Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#expr ";@ ") el o#expr x ]; - - method expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr< $e1$ := $e2$ >> -> - pp f "@[<2>%a@ :=@ %a@]" o#dot_expr e1 o#expr e2 - | <:expr< fun $p$ -> $e$ >> when Ast.is_irrefut_patt p -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`patt p, e) - | <:expr< fun (type $i$) -> $e$ >> -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`newtype i, e) - | <:expr< fun [ $a$ ] >> -> - pp f "@[fun%a@]" o#match_case a - | <:expr< assert False >> -> pp f "@[<2>assert@ False@]" - | e -> super#expr f e ]; - - method dot_expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr< $e$.val >> -> pp f "@[<2>%a.@,val@]" o#simple_expr e - | e -> super#dot_expr f e ]; - - method ctyp f t = - let () = o#node f t Ast.loc_of_ctyp in - match t with - [ Ast.TyDcl _ tn tp te cl -> do { - pp f "@[<2>%a%a@]" o#var tn o#type_params tp; - match te with - [ <:ctyp<>> -> () - | _ -> pp f " =@ %a" o#ctyp te ]; - if cl <> [] then pp f "@ %a" (list o#constrain "@ ") cl else (); - } - | <:ctyp< $t1$ : mutable $t2$ >> -> - pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$ == $t2$ >> -> - pp f "@[<2>%a ==@ %a@]" o#simple_ctyp t1 o#ctyp t2 - | t -> super#ctyp f t ]; - - method simple_ctyp f t = - let () = o#node f t Ast.loc_of_ctyp in - match t with - [ <:ctyp< [ = $t$ ] >> -> pp f "@[<2>[ =@ %a@]@ ]" o#ctyp t - | <:ctyp< [ < $t$ ] >> -> pp f "@[<2>[ <@ %a@]@,]" o#ctyp t - | <:ctyp< [ < $t1$ > $t2$ ] >> -> - pp f "@[<2>[ <@ %a@ >@ %a@]@ ]" o#ctyp t1 o#ctyp t2 - | <:ctyp< [ > $t$ ] >> -> pp f "@[<2>[ >@ %a@]@,]" o#ctyp t - | <:ctyp< $t1$ == $t2$ >> -> - pp f "@[<2>%a@ ==@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 - | <:ctyp< ~ $s$ : $t$ >> -> pp f "@[<2>~%s:@ %a@]" s o#simple_ctyp t - | t -> super#simple_ctyp f t ]; - - method ctyp1 f = fun - [ <:ctyp< $t1$ $t2$ >> -> - match get_ctyp_args t1 [t2] with - [ (_, [_]) -> pp f "@[<2>%a@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 - | (a, al) -> pp f "@[<2>%a@]" (list o#simple_ctyp "@ ") [a::al] ] - | <:ctyp< ! $t1$ . $t2$ >> -> - let (a, al) = get_ctyp_args t1 [] in - pp f "@[<2>! %a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 - | t -> super#ctyp1 f t ]; - - method constructor_type f t = - match t with - [ <:ctyp@loc< $t1$ and $t2$ >> -> - let () = o#node f t (fun _ -> loc) in - pp f "%a@ and %a" o#constructor_type t1 o#constructor_type t2 - | t -> o#ctyp f t ]; - - method str_item f st = - match st with - [ <:str_item< $exp:e$ >> -> pp f "@[<2>%a%(%)@]" o#expr e semisep - | st -> super#str_item f st ]; - - method module_expr f me = - let () = o#node f me Ast.loc_of_module_expr in - match me with - [ <:module_expr< $me1$ $me2$ >> -> - pp f "@[<2>%a@ %a@]" o#module_expr me1 o#simple_module_expr me2 - | me -> super#module_expr f me ]; - - method simple_module_expr f me = - let () = o#node f me Ast.loc_of_module_expr in - match me with - [ <:module_expr< $_$ $_$ >> -> - pp f "(%a)" o#module_expr me - | _ -> super#simple_module_expr f me ]; - - method implem f st = pp f "@[%a@]@." o#str_item st; - - method class_type f ct = - let () = o#node f ct Ast.loc_of_class_type in - match ct with - [ <:class_type< [ $t$ ] -> $ct$ >> -> - pp f "@[<2>[ %a ] ->@ %a@]" o#simple_ctyp t o#class_type ct - | <:class_type< $id:i$ >> -> - pp f "@[<2>%a@]" o#ident i - | <:class_type< $id:i$ [ $t$ ] >> -> - pp f "@[<2>%a [@,%a@]@,]" o#ident i o#class_params t - | <:class_type< virtual $lid:i$ >> -> - pp f "@[<2>virtual@ %a@]" o#var i - | <:class_type< virtual $lid:i$ [ $t$ ] >> -> - pp f "@[<2>virtual@ %a@ [@,%a@]@,]" o#var i o#class_params t - | ct -> super#class_type f ct ]; - - method class_expr f ce = - let () = o#node f ce Ast.loc_of_class_expr in - match ce with - [ <:class_expr< $id:i$ >> -> - pp f "@[<2>%a@]" o#ident i - | <:class_expr< $id:i$ [ $t$ ] >> -> - pp f "@[<2>%a@ @[<1>[%a]@]@]" o#ident i o#class_params t - | <:class_expr< virtual $lid:i$ >> -> - pp f "@[<2>virtual@ %a@]" o#var i - | <:class_expr< virtual $lid:i$ [ $t$ ] >> -> - pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i o#class_params t - | ce -> super#class_expr f ce ]; - end; - - value with_outfile = with_outfile; - - value print output_file fct = - let o = new printer () in - with_outfile output_file (fct o); - - value print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg; - - value print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st; - -end; - -module MakeMore (Syntax : Sig.Camlp4Syntax) -: (Sig.Printer Syntax.Ast).S -= struct - - include Make Syntax; - - value margin = ref 78; - value comments = ref True; - value locations = ref False; - value curry_constr = ref True; - - value print output_file fct = - let o = new printer ~comments:comments.val - ~curry_constr:curry_constr.val () in - let o = if locations.val then o#set_loc_and_comments else o in - with_outfile output_file - (fun f -> - let () = Format.pp_set_margin f margin.val in - Format.fprintf f "@[%a@]@." (fct o)); - - value print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg; - - value print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st; - - Options.add "-l" (Arg.Int (fun i -> margin.val := i)) - " line length for pretty printing."; - - Options.add "-no_comments" (Arg.Clear comments) "Do not add comments."; - - Options.add "-add_locations" (Arg.Set locations) "Add locations as comment."; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/OCamlr.mli ocaml-4.05.0/camlp4/Camlp4/Printers/OCamlr.mli --- ocaml-4.01.0/camlp4/Camlp4/Printers/OCamlr.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Printers/OCamlr.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Camlp4Syntax) : sig - open Format; - include Sig.Camlp4Syntax - with module Loc = Syntax.Loc - and module Token = Syntax.Token - and module Ast = Syntax.Ast - and module Gram = Syntax.Gram; - - (** - [new printer ~curry_constr:c ~comments:False] - Default values: curry_constr = True - comments = True - *) - class printer : - [?curry_constr: bool] -> [?comments: bool] -> [unit] -> - object ('a) - inherit (OCaml.Make Syntax).printer; - end; - - value with_outfile : - option string -> (formatter -> 'a -> unit) -> 'a -> unit; - - value print : - option string -> (printer -> formatter -> 'a -> unit) -> 'a -> unit; -end; - -module MakeMore (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers.mlpack ocaml-4.05.0/camlp4/Camlp4/Printers.mlpack --- ocaml-4.01.0/camlp4/Camlp4/Printers.mlpack 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Printers.mlpack 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -DumpCamlp4Ast -DumpOCamlAst -Null -OCaml -OCamlr diff -Nru ocaml-4.01.0/camlp4/Camlp4/Register.ml ocaml-4.05.0/camlp4/Camlp4/Register.ml --- ocaml-4.01.0/camlp4/Camlp4/Register.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Register.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,171 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module PP = Printers; -open PreCast; - -type parser_fun 'a = - ?directive_handler:('a -> option 'a) -> PreCast.Loc.t -> Stream.t char -> 'a; - -type printer_fun 'a = - ?input_file:string -> ?output_file:string -> 'a -> unit; - -value sig_item_parser = ref (fun ?directive_handler:(_) _ _ -> failwith "No interface parser"); -value str_item_parser = ref (fun ?directive_handler:(_) _ _ -> failwith "No implementation parser"); - -value sig_item_printer = ref (fun ?input_file:(_) ?output_file:(_) _ -> failwith "No interface printer"); -value str_item_printer = ref (fun ?input_file:(_) ?output_file:(_) _ -> failwith "No implementation printer"); - -value callbacks = Queue.create (); - -value loaded_modules = ref []; - -value iter_and_take_callbacks f = - let rec loop () = loop (f (Queue.take callbacks)) in - try loop () with [ Queue.Empty -> () ]; - -value declare_dyn_module m f = - begin - (* let () = Format.eprintf "declare_dyn_module: %s@." m in *) - loaded_modules.val := [ m :: loaded_modules.val ]; - Queue.add (m, f) callbacks; - end; - -value register_str_item_parser f = str_item_parser.val := f; -value register_sig_item_parser f = sig_item_parser.val := f; -value register_parser f g = - do { str_item_parser.val := f; sig_item_parser.val := g }; -value current_parser () = (str_item_parser.val, sig_item_parser.val); - -value register_str_item_printer f = str_item_printer.val := f; -value register_sig_item_printer f = sig_item_printer.val := f; -value register_printer f g = - do { str_item_printer.val := f; sig_item_printer.val := g }; -value current_printer () = (str_item_printer.val, sig_item_printer.val); - -module Plugin (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = struct - declare_dyn_module Id.name (fun _ -> let module M = Maker (struct end) in ()); -end; - -module SyntaxExtension (Id : Sig.Id) (Maker : Sig.SyntaxExtension) = struct - declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ()); -end; - -module OCamlSyntaxExtension - (Id : Sig.Id) (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) = -struct - declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ()); -end; - -module SyntaxPlugin (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) -> sig end) = struct - declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ()); -end; - -module Printer - (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) - -> (Sig.Printer Syn.Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - let module M = Maker Syntax in - register_printer M.print_implem M.print_interf); -end; - -module OCamlPrinter - (Id : Sig.Id) (Maker : functor (Syn : Sig.Camlp4Syntax) - -> (Sig.Printer Syn.Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - let module M = Maker Syntax in - register_printer M.print_implem M.print_interf); -end; - -module OCamlPreCastPrinter - (Id : Sig.Id) (P : (Sig.Printer PreCast.Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - register_printer P.print_implem P.print_interf); -end; - -module Parser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) - -> (Sig.Parser Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - let module M = Maker PreCast.Ast in - register_parser M.parse_implem M.parse_interf); -end; - -module OCamlParser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Camlp4Ast) - -> (Sig.Parser Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - let module M = Maker PreCast.Ast in - register_parser M.parse_implem M.parse_interf); -end; - -module OCamlPreCastParser - (Id : Sig.Id) (P : (Sig.Parser PreCast.Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - register_parser P.parse_implem P.parse_interf); -end; - -module AstFilter - (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) = -struct - declare_dyn_module Id.name (fun _ -> let module M = Maker AstFilters in ()); -end; - -sig_item_parser.val := Syntax.parse_interf; -str_item_parser.val := Syntax.parse_implem; - -module CurrentParser = struct - module Ast = Ast; - value parse_interf ?directive_handler loc strm = - sig_item_parser.val ?directive_handler loc strm; - value parse_implem ?directive_handler loc strm = - str_item_parser.val ?directive_handler loc strm; -end; - -module CurrentPrinter = struct - module Ast = Ast; - value print_interf ?input_file ?output_file ast = - sig_item_printer.val ?input_file ?output_file ast; - value print_implem ?input_file ?output_file ast = - str_item_printer.val ?input_file ?output_file ast; -end; - -value enable_ocaml_printer () = - let module M = OCamlPrinter PP.OCaml.Id PP.OCaml.MakeMore in (); - -value enable_ocamlr_printer () = - let module M = OCamlPrinter PP.OCamlr.Id PP.OCamlr.MakeMore in (); - -(* value enable_ocamlrr_printer () = - let module M = OCamlPrinter PP.OCamlrr.Id PP.OCamlrr.MakeMore in (); *) - -value enable_dump_ocaml_ast_printer () = - let module M = OCamlPrinter PP.DumpOCamlAst.Id PP.DumpOCamlAst.Make in (); - -value enable_dump_camlp4_ast_printer () = - let module M = Printer PP.DumpCamlp4Ast.Id PP.DumpCamlp4Ast.Make in (); - -value enable_null_printer () = - let module M = Printer PP.Null.Id PP.Null.Make in (); diff -Nru ocaml-4.01.0/camlp4/Camlp4/Register.mli ocaml-4.05.0/camlp4/Camlp4/Register.mli --- ocaml-4.01.0/camlp4/Camlp4/Register.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Register.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,95 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Plugin - (Id : Sig.Id) (Plugin : functor (Unit : sig end) -> sig end) : sig end; - -module SyntaxPlugin - (Id : Sig.Id) (SyntaxPlugin : functor (Syn : Sig.Syntax) -> sig end) : - sig end; - -module SyntaxExtension - (Id : Sig.Id) (SyntaxExtension : Sig.SyntaxExtension) : sig end; - -module OCamlSyntaxExtension - (Id : Sig.Id) - (SyntaxExtension : functor (Syntax : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) - : sig end; - -(** {6 Registering Parsers} *) - -type parser_fun 'a = - ?directive_handler:('a -> option 'a) -> PreCast.Loc.t -> Stream.t char -> 'a; - -value register_str_item_parser : parser_fun PreCast.Ast.str_item -> unit; -value register_sig_item_parser : parser_fun PreCast.Ast.sig_item -> unit; -value register_parser : parser_fun PreCast.Ast.str_item -> parser_fun PreCast.Ast.sig_item -> unit; -value current_parser : unit -> (parser_fun PreCast.Ast.str_item * parser_fun PreCast.Ast.sig_item); - -module Parser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> (Sig.Parser Ast).S) : sig end; - -module OCamlParser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Camlp4Ast) -> (Sig.Parser Ast).S) : sig end; - -module OCamlPreCastParser - (Id : Sig.Id) (Parser : (Sig.Parser PreCast.Ast).S) : sig end; - -(** {6 Registering Printers} *) - -type printer_fun 'a = - ?input_file:string -> ?output_file:string -> 'a -> unit; - -value register_str_item_printer : printer_fun PreCast.Ast.str_item -> unit; -value register_sig_item_printer : printer_fun PreCast.Ast.sig_item -> unit; -value register_printer : printer_fun PreCast.Ast.str_item -> printer_fun PreCast.Ast.sig_item -> unit; -value current_printer : unit -> (printer_fun PreCast.Ast.str_item * printer_fun PreCast.Ast.sig_item); - -module Printer - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Syntax) -> (Sig.Printer Syn.Ast).S) : - sig end; - -module OCamlPrinter - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Camlp4Syntax) -> (Sig.Printer Syn.Ast).S) : - sig end; - -module OCamlPreCastPrinter - (Id : Sig.Id) (Printer : (Sig.Printer PreCast.Ast).S) : - sig end; - -(** {6 Registering Filters} *) - -module AstFilter - (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) : sig end; - -value declare_dyn_module : string -> (unit -> unit) -> unit; -value iter_and_take_callbacks : ((string * (unit -> unit)) -> unit) -> unit; -value loaded_modules : ref (list string); - -module CurrentParser : (Sig.Parser PreCast.Ast).S; -module CurrentPrinter : (Sig.Printer PreCast.Ast).S; - -value enable_ocaml_printer : unit -> unit; -value enable_ocamlr_printer : unit -> unit; -(* value enable_ocamlrr_printer : unit -> unit; *) -value enable_null_printer : unit -> unit; -value enable_dump_ocaml_ast_printer : unit -> unit; -value enable_dump_camlp4_ast_printer : unit -> unit; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Sig.ml ocaml-4.05.0/camlp4/Camlp4/Sig.ml --- ocaml-4.01.0/camlp4/Camlp4/Sig.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Sig.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,1445 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -(** Camlp4 signature repository *) - -(** {6 Basic signatures} *) - -(** Signature with just a type. *) -module type Type = sig - type t; -end; - -(** Signature for errors modules, an Error modules can be registred with - the {!ErrorHandler.Register} functor in order to be well printed. *) -module type Error = sig - type t; - exception E of t; - value to_string : t -> string; - value print : Format.formatter -> t -> unit; -end; - -(** A signature for extensions identifiers. *) -module type Id = sig - - (** The name of the extension, typically the module name. *) - value name : string; - - (** The version of the extension, typically $ Id$ with a versionning system. *) - value version : string; - -end; - -(** A signature for warnings abstract from locations. *) -module Warning (Loc : Type) = struct - module type S = sig - type warning = Loc.t -> string -> unit; - value default_warning : warning; - value current_warning : ref warning; - value print_warning : warning; - end; -end; - -(** {6 Advanced signatures} *) - -(** A signature for locations. *) -module type Loc = sig - - (** The type of locations. Note that, as for OCaml locations, - character numbers in locations refer to character numbers in the - parsed character stream, while line numbers refer to line - numbers in the source file. The source file and the parsed - character stream differ, for instance, when the parsed character - stream contains a line number directive. The line number - directive will only update the file-name field and the - line-number field of the position. It makes therefore no sense - to use character numbers with the source file if the sources - contain line number directives. *) - type t; - - (** Return a start location for the given file name. - This location starts at the begining of the file. *) - value mk : string -> t; - - (** The [ghost] location can be used when no location - information is available. *) - value ghost : t; - - (** {6 Conversion functions} *) - - (** Return a location where both positions are set the given position. *) - value of_lexing_position : Lexing.position -> t; - - (** Return an OCaml location. *) - value to_ocaml_location : t -> Camlp4_import.Location.t; - - (** Return a location from an OCaml location. *) - value of_ocaml_location : Camlp4_import.Location.t -> t; - - (** Return a location from ocamllex buffer. *) - value of_lexbuf : Lexing.lexbuf -> t; - - (** Return a location from [(file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost)]. *) - value of_tuple : (string * int * int * int * int * int * int * bool) -> t; - - (** Return [(file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost)]. *) - value to_tuple : t -> (string * int * int * int * int * int * int * bool); - - (** [merge loc1 loc2] Return a location that starts at [loc1] and end at - [loc2]. *) - value merge : t -> t -> t; - - (** The stop pos becomes equal to the start pos. *) - value join : t -> t; - - (** [move selector n loc] - Return the location where positions are moved. - Affected positions are chosen with [selector]. - Returned positions have their character offset plus [n]. *) - value move : [= `start | `stop | `both ] -> int -> t -> t; - - (** [shift n loc] Return the location where the new start position is the old - stop position, and where the new stop position character offset is the - old one plus [n]. *) - value shift : int -> t -> t; - - (** [move_line n loc] Return the location with the old line count plus [n]. - The "begin of line" of both positions become the current offset. *) - value move_line : int -> t -> t; - - (** {6 Accessors} *) - - (** Return the file name *) - value file_name : t -> string; - - (** Return the line number of the begining of this location. *) - value start_line : t -> int; - - (** Return the line number of the ending of this location. *) - value stop_line : t -> int; - - (** Returns the number of characters from the begining of the stream - to the begining of the line of location's begining. *) - value start_bol : t -> int; - - (** Returns the number of characters from the begining of the stream - to the begining of the line of location's ending. *) - value stop_bol : t -> int; - - (** Returns the number of characters from the begining of the stream - of the begining of this location. *) - value start_off : t -> int; - - (** Return the number of characters from the begining of the stream - of the ending of this location. *) - value stop_off : t -> int; - - (** Return the start position as a Lexing.position. *) - value start_pos : t -> Lexing.position; - - (** Return the stop position as a Lexing.position. *) - value stop_pos : t -> Lexing.position; - - (** Generally, return true if this location does not come - from an input stream. *) - value is_ghost : t -> bool; - - (** Return the associated ghost location. *) - value ghostify : t -> t; - - (** Return the location with the give file name *) - value set_file_name : string -> t -> t; - - (** [strictly_before loc1 loc2] True if the stop position of [loc1] is - strictly_before the start position of [loc2]. *) - value strictly_before : t -> t -> bool; - - (** Return the location with an absolute file name. *) - value make_absolute : t -> t; - - (** Print the location into the formatter in a format suitable for error - reporting. *) - value print : Format.formatter -> t -> unit; - - (** Print the location in a short format useful for debugging. *) - value dump : Format.formatter -> t -> unit; - - (** Same as {!print} but return a string instead of printting it. *) - value to_string : t -> string; - - (** [Exc_located loc e] is an encapsulation of the exception [e] with - the input location [loc]. To be used in quotation expanders - and in grammars to specify some input location for an error. - Do not raise this exception directly: rather use the following - function [Loc.raise]. *) - exception Exc_located of t and exn; - - (** [raise loc e], if [e] is already an [Exc_located] exception, - re-raise it, else raise the exception [Exc_located loc e]. *) - value raise : t -> exn -> 'a; - - (** The name of the location variable used in grammars and in - the predefined quotations for OCaml syntax trees. Default: [_loc]. *) - value name : ref string; - -end; - -(** Abstract syntax tree minimal signature. - Types of this signature are abstract. - See the {!Camlp4Ast} signature for a concrete definition. *) -module type Ast = sig - - (** {6 Syntactic categories as abstract types} *) - - type loc; - type meta_bool; - type meta_option 'a; - type meta_list 'a; - type ctyp; - type patt; - type expr; - type module_type; - type sig_item; - type with_constr; - type module_expr; - type str_item; - type class_type; - type class_sig_item; - type class_expr; - type class_str_item; - type match_case; - type ident; - type binding; - type rec_binding; - type module_binding; - type rec_flag; - type direction_flag; - type mutable_flag; - type private_flag; - type virtual_flag; - type row_var_flag; - type override_flag; - - (** {6 Location accessors} *) - - value loc_of_ctyp : ctyp -> loc; - value loc_of_patt : patt -> loc; - value loc_of_expr : expr -> loc; - value loc_of_module_type : module_type -> loc; - value loc_of_module_expr : module_expr -> loc; - value loc_of_sig_item : sig_item -> loc; - value loc_of_str_item : str_item -> loc; - value loc_of_class_type : class_type -> loc; - value loc_of_class_sig_item : class_sig_item -> loc; - value loc_of_class_expr : class_expr -> loc; - value loc_of_class_str_item : class_str_item -> loc; - value loc_of_with_constr : with_constr -> loc; - value loc_of_binding : binding -> loc; - value loc_of_rec_binding : rec_binding -> loc; - value loc_of_module_binding : module_binding -> loc; - value loc_of_match_case : match_case -> loc; - value loc_of_ident : ident -> loc; - - (** {6 Traversals} *) - - (** This class is the base class for map traversal on the Ast. - To make a custom traversal class one just extend it like that: - - This example swap pairs expression contents: - open Camlp4.PreCast; - [class swap = object - inherit Ast.map as super; - method expr e = - match super#expr e with - \[ <:expr\@_loc< ($e1$, $e2$) >> -> <:expr< ($e2$, $e1$) >> - | e -> e \]; - end; - value _loc = Loc.ghost; - value map = (new swap)#expr; - assert (map <:expr< fun x -> (x, 42) >> = <:expr< fun x -> (42, x) >>);] - *) - class map : object ('self_type) - method string : string -> string; - method list : ! 'a 'b . ('self_type -> 'a -> 'b) -> list 'a -> list 'b; - method meta_bool : meta_bool -> meta_bool; - method meta_option : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_option 'a -> meta_option 'b; - method meta_list : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_list 'a -> meta_list 'b; - method loc : loc -> loc; - method expr : expr -> expr; - method patt : patt -> patt; - method ctyp : ctyp -> ctyp; - method str_item : str_item -> str_item; - method sig_item : sig_item -> sig_item; - - method module_expr : module_expr -> module_expr; - method module_type : module_type -> module_type; - method class_expr : class_expr -> class_expr; - method class_type : class_type -> class_type; - method class_sig_item : class_sig_item -> class_sig_item; - method class_str_item : class_str_item -> class_str_item; - method with_constr : with_constr -> with_constr; - method binding : binding -> binding; - method rec_binding : rec_binding -> rec_binding; - method module_binding : module_binding -> module_binding; - method match_case : match_case -> match_case; - method ident : ident -> ident; - method override_flag : override_flag -> override_flag; - method mutable_flag : mutable_flag -> mutable_flag; - method private_flag : private_flag -> private_flag; - method virtual_flag : virtual_flag -> virtual_flag; - method direction_flag : direction_flag -> direction_flag; - method rec_flag : rec_flag -> rec_flag; - method row_var_flag : row_var_flag -> row_var_flag; - - method unknown : ! 'a. 'a -> 'a; - end; - - (** Fold style traversal *) - class fold : object ('self_type) - method string : string -> 'self_type; - method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type; - method meta_bool : meta_bool -> 'self_type; - method meta_option : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_option 'a -> 'self_type; - method meta_list : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_list 'a -> 'self_type; - method loc : loc -> 'self_type; - method expr : expr -> 'self_type; - method patt : patt -> 'self_type; - method ctyp : ctyp -> 'self_type; - method str_item : str_item -> 'self_type; - method sig_item : sig_item -> 'self_type; - method module_expr : module_expr -> 'self_type; - method module_type : module_type -> 'self_type; - method class_expr : class_expr -> 'self_type; - method class_type : class_type -> 'self_type; - method class_sig_item : class_sig_item -> 'self_type; - method class_str_item : class_str_item -> 'self_type; - method with_constr : with_constr -> 'self_type; - method binding : binding -> 'self_type; - method rec_binding : rec_binding -> 'self_type; - method module_binding : module_binding -> 'self_type; - method match_case : match_case -> 'self_type; - method ident : ident -> 'self_type; - method rec_flag : rec_flag -> 'self_type; - method direction_flag : direction_flag -> 'self_type; - method mutable_flag : mutable_flag -> 'self_type; - method private_flag : private_flag -> 'self_type; - method virtual_flag : virtual_flag -> 'self_type; - method row_var_flag : row_var_flag -> 'self_type; - method override_flag : override_flag -> 'self_type; - - method unknown : ! 'a. 'a -> 'self_type; - end; - -end; - - -(** Signature for OCaml syntax trees. *) (* - This signature is an extension of {!Ast} - It provides: - - Types for all kinds of structure. - - Map: A base class for map traversals. - - Map classes and functions for common kinds. - - == Core language == - ctyp :: Representaion of types - patt :: The type of patterns - expr :: The type of expressions - match_case :: The type of cases for match/function/try constructions - ident :: The type of identifiers (including path like Foo(X).Bar.y) - binding :: The type of let bindings - rec_binding :: The type of record definitions - - == Modules == - module_type :: The type of module types - sig_item :: The type of signature items - str_item :: The type of structure items - module_expr :: The type of module expressions - module_binding :: The type of recursive module definitions - with_constr :: The type of `with' constraints - - == Classes == - class_type :: The type of class types - class_sig_item :: The type of class signature items - class_expr :: The type of class expressions - class_str_item :: The type of class structure items - *) -module type Camlp4Ast = sig - - (** The inner module for locations *) - module Loc : Loc; - - INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; - - value loc_of_ctyp : ctyp -> loc; - value loc_of_patt : patt -> loc; - value loc_of_expr : expr -> loc; - value loc_of_module_type : module_type -> loc; - value loc_of_module_expr : module_expr -> loc; - value loc_of_sig_item : sig_item -> loc; - value loc_of_str_item : str_item -> loc; - value loc_of_class_type : class_type -> loc; - value loc_of_class_sig_item : class_sig_item -> loc; - value loc_of_class_expr : class_expr -> loc; - value loc_of_class_str_item : class_str_item -> loc; - value loc_of_with_constr : with_constr -> loc; - value loc_of_binding : binding -> loc; - value loc_of_rec_binding : rec_binding -> loc; - value loc_of_module_binding : module_binding -> loc; - value loc_of_match_case : match_case -> loc; - value loc_of_ident : ident -> loc; - - module Meta : sig - module type META_LOC = sig - (* The first location is where to put the returned pattern. - Generally it's _loc to match with <:patt< ... >> quotations. - The second location is the one to treat. *) - value meta_loc_patt : loc -> loc -> patt; - (* The first location is where to put the returned expression. - Generally it's _loc to match with <:expr< ... >> quotations. - The second location is the one to treat. *) - value meta_loc_expr : loc -> loc -> expr; - end; - module MetaLoc : sig - value meta_loc_patt : loc -> loc -> patt; - value meta_loc_expr : loc -> loc -> expr; - end; - module MetaGhostLoc : sig - value meta_loc_patt : loc -> 'a -> patt; - value meta_loc_expr : loc -> 'a -> expr; - end; - module MetaLocVar : sig - value meta_loc_patt : loc -> 'a -> patt; - value meta_loc_expr : loc -> 'a -> expr; - end; - module Make (MetaLoc : META_LOC) : sig - module Expr : sig - value meta_string : loc -> string -> expr; - value meta_int : loc -> string -> expr; - value meta_float : loc -> string -> expr; - value meta_char : loc -> string -> expr; - value meta_bool : loc -> bool -> expr; - value meta_list : (loc -> 'a -> expr) -> loc -> list 'a -> expr; - value meta_binding : loc -> binding -> expr; - value meta_rec_binding : loc -> rec_binding -> expr; - value meta_class_expr : loc -> class_expr -> expr; - value meta_class_sig_item : loc -> class_sig_item -> expr; - value meta_class_str_item : loc -> class_str_item -> expr; - value meta_class_type : loc -> class_type -> expr; - value meta_ctyp : loc -> ctyp -> expr; - value meta_expr : loc -> expr -> expr; - value meta_ident : loc -> ident -> expr; - value meta_match_case : loc -> match_case -> expr; - value meta_module_binding : loc -> module_binding -> expr; - value meta_module_expr : loc -> module_expr -> expr; - value meta_module_type : loc -> module_type -> expr; - value meta_patt : loc -> patt -> expr; - value meta_sig_item : loc -> sig_item -> expr; - value meta_str_item : loc -> str_item -> expr; - value meta_with_constr : loc -> with_constr -> expr; - value meta_rec_flag : loc -> rec_flag -> expr; - value meta_mutable_flag : loc -> mutable_flag -> expr; - value meta_virtual_flag : loc -> virtual_flag -> expr; - value meta_private_flag : loc -> private_flag -> expr; - value meta_row_var_flag : loc -> row_var_flag -> expr; - value meta_override_flag : loc -> override_flag -> expr; - value meta_direction_flag : loc -> direction_flag -> expr; - end; - module Patt : sig - value meta_string : loc -> string -> patt; - value meta_int : loc -> string -> patt; - value meta_float : loc -> string -> patt; - value meta_char : loc -> string -> patt; - value meta_bool : loc -> bool -> patt; - value meta_list : (loc -> 'a -> patt) -> loc -> list 'a -> patt; - value meta_binding : loc -> binding -> patt; - value meta_rec_binding : loc -> rec_binding -> patt; - value meta_class_expr : loc -> class_expr -> patt; - value meta_class_sig_item : loc -> class_sig_item -> patt; - value meta_class_str_item : loc -> class_str_item -> patt; - value meta_class_type : loc -> class_type -> patt; - value meta_ctyp : loc -> ctyp -> patt; - value meta_expr : loc -> expr -> patt; - value meta_ident : loc -> ident -> patt; - value meta_match_case : loc -> match_case -> patt; - value meta_module_binding : loc -> module_binding -> patt; - value meta_module_expr : loc -> module_expr -> patt; - value meta_module_type : loc -> module_type -> patt; - value meta_patt : loc -> patt -> patt; - value meta_sig_item : loc -> sig_item -> patt; - value meta_str_item : loc -> str_item -> patt; - value meta_with_constr : loc -> with_constr -> patt; - value meta_rec_flag : loc -> rec_flag -> patt; - value meta_mutable_flag : loc -> mutable_flag -> patt; - value meta_virtual_flag : loc -> virtual_flag -> patt; - value meta_private_flag : loc -> private_flag -> patt; - value meta_row_var_flag : loc -> row_var_flag -> patt; - value meta_override_flag : loc -> override_flag -> patt; - value meta_direction_flag : loc -> direction_flag -> patt; - end; - end; - end; - - (** See {!Ast.map}. *) - class map : object ('self_type) - method string : string -> string; - method list : ! 'a 'b . ('self_type -> 'a -> 'b) -> list 'a -> list 'b; - method meta_bool : meta_bool -> meta_bool; - method meta_option : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_option 'a -> meta_option 'b; - method meta_list : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_list 'a -> meta_list 'b; - method loc : loc -> loc; - method expr : expr -> expr; - method patt : patt -> patt; - method ctyp : ctyp -> ctyp; - method str_item : str_item -> str_item; - method sig_item : sig_item -> sig_item; - - method module_expr : module_expr -> module_expr; - method module_type : module_type -> module_type; - method class_expr : class_expr -> class_expr; - method class_type : class_type -> class_type; - method class_sig_item : class_sig_item -> class_sig_item; - method class_str_item : class_str_item -> class_str_item; - method with_constr : with_constr -> with_constr; - method binding : binding -> binding; - method rec_binding : rec_binding -> rec_binding; - method module_binding : module_binding -> module_binding; - method match_case : match_case -> match_case; - method ident : ident -> ident; - method mutable_flag : mutable_flag -> mutable_flag; - method private_flag : private_flag -> private_flag; - method virtual_flag : virtual_flag -> virtual_flag; - method direction_flag : direction_flag -> direction_flag; - method rec_flag : rec_flag -> rec_flag; - method row_var_flag : row_var_flag -> row_var_flag; - method override_flag : override_flag -> override_flag; - - method unknown : ! 'a. 'a -> 'a; - end; - - (** See {!Ast.fold}. *) - class fold : object ('self_type) - method string : string -> 'self_type; - method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type; - method meta_bool : meta_bool -> 'self_type; - method meta_option : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_option 'a -> 'self_type; - method meta_list : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_list 'a -> 'self_type; - method loc : loc -> 'self_type; - method expr : expr -> 'self_type; - method patt : patt -> 'self_type; - method ctyp : ctyp -> 'self_type; - method str_item : str_item -> 'self_type; - method sig_item : sig_item -> 'self_type; - method module_expr : module_expr -> 'self_type; - method module_type : module_type -> 'self_type; - method class_expr : class_expr -> 'self_type; - method class_type : class_type -> 'self_type; - method class_sig_item : class_sig_item -> 'self_type; - method class_str_item : class_str_item -> 'self_type; - method with_constr : with_constr -> 'self_type; - method binding : binding -> 'self_type; - method rec_binding : rec_binding -> 'self_type; - method module_binding : module_binding -> 'self_type; - method match_case : match_case -> 'self_type; - method ident : ident -> 'self_type; - method rec_flag : rec_flag -> 'self_type; - method direction_flag : direction_flag -> 'self_type; - method mutable_flag : mutable_flag -> 'self_type; - method private_flag : private_flag -> 'self_type; - method virtual_flag : virtual_flag -> 'self_type; - method row_var_flag : row_var_flag -> 'self_type; - method override_flag : override_flag -> 'self_type; - - method unknown : ! 'a. 'a -> 'self_type; - end; - - value map_expr : (expr -> expr) -> map; - value map_patt : (patt -> patt) -> map; - value map_ctyp : (ctyp -> ctyp) -> map; - value map_str_item : (str_item -> str_item) -> map; - value map_sig_item : (sig_item -> sig_item) -> map; - value map_loc : (loc -> loc) -> map; - - value ident_of_expr : expr -> ident; - value ident_of_patt : patt -> ident; - value ident_of_ctyp : ctyp -> ident; - - value biAnd_of_list : list binding -> binding; - value rbSem_of_list : list rec_binding -> rec_binding; - value paSem_of_list : list patt -> patt; - value paCom_of_list : list patt -> patt; - value tyOr_of_list : list ctyp -> ctyp; - value tyAnd_of_list : list ctyp -> ctyp; - value tyAmp_of_list : list ctyp -> ctyp; - value tySem_of_list : list ctyp -> ctyp; - value tyCom_of_list : list ctyp -> ctyp; - value tySta_of_list : list ctyp -> ctyp; - value stSem_of_list : list str_item -> str_item; - value sgSem_of_list : list sig_item -> sig_item; - value crSem_of_list : list class_str_item -> class_str_item; - value cgSem_of_list : list class_sig_item -> class_sig_item; - value ctAnd_of_list : list class_type -> class_type; - value ceAnd_of_list : list class_expr -> class_expr; - value wcAnd_of_list : list with_constr -> with_constr; - value meApp_of_list : list module_expr -> module_expr; - value mbAnd_of_list : list module_binding -> module_binding; - value mcOr_of_list : list match_case -> match_case; - value idAcc_of_list : list ident -> ident; - value idApp_of_list : list ident -> ident; - value exSem_of_list : list expr -> expr; - value exCom_of_list : list expr -> expr; - - value list_of_ctyp : ctyp -> list ctyp -> list ctyp; - value list_of_binding : binding -> list binding -> list binding; - value list_of_rec_binding : rec_binding -> list rec_binding -> list rec_binding; - value list_of_with_constr : with_constr -> list with_constr -> list with_constr; - value list_of_patt : patt -> list patt -> list patt; - value list_of_expr : expr -> list expr -> list expr; - value list_of_str_item : str_item -> list str_item -> list str_item; - value list_of_sig_item : sig_item -> list sig_item -> list sig_item; - value list_of_class_sig_item : class_sig_item -> list class_sig_item -> list class_sig_item; - value list_of_class_str_item : class_str_item -> list class_str_item -> list class_str_item; - value list_of_class_type : class_type -> list class_type -> list class_type; - value list_of_class_expr : class_expr -> list class_expr -> list class_expr; - value list_of_module_expr : module_expr -> list module_expr -> list module_expr; - value list_of_module_binding : module_binding -> list module_binding -> list module_binding; - value list_of_match_case : match_case -> list match_case -> list match_case; - value list_of_ident : ident -> list ident -> list ident; - - (** Like [String.escape] but takes care to not - escape antiquotations strings. *) - value safe_string_escaped : string -> string; - - (** Returns True if the given pattern is irrefutable. *) - value is_irrefut_patt : patt -> bool; - - value is_constructor : ident -> bool; - value is_patt_constructor : patt -> bool; - value is_expr_constructor : expr -> bool; - - value ty_of_stl : (Loc.t * string * list ctyp) -> ctyp; - value ty_of_sbt : (Loc.t * string * bool * ctyp) -> ctyp; - value bi_of_pe : (patt * expr) -> binding; - value pel_of_binding : binding -> list (patt * expr); - value binding_of_pel : list (patt * expr) -> binding; - value sum_type_of_list : list (Loc.t * string * list ctyp) -> ctyp; - value record_type_of_list : list (Loc.t * string * bool * ctyp) -> ctyp; -end; - -(** This functor is a restriction functor. - It takes a Camlp4Ast module and gives the Ast one. - Typical use is for [with] constraints. - Example: ... with module Ast = Camlp4.Sig.Camlp4AstToAst Camlp4Ast *) -module Camlp4AstToAst (M : Camlp4Ast) : Ast - with type loc = M.loc - and type meta_bool = M.meta_bool - and type meta_option 'a = M.meta_option 'a - and type meta_list 'a = M.meta_list 'a - and type ctyp = M.ctyp - and type patt = M.patt - and type expr = M.expr - and type module_type = M.module_type - and type sig_item = M.sig_item - and type with_constr = M.with_constr - and type module_expr = M.module_expr - and type str_item = M.str_item - and type class_type = M.class_type - and type class_sig_item = M.class_sig_item - and type class_expr = M.class_expr - and type class_str_item = M.class_str_item - and type binding = M.binding - and type rec_binding = M.rec_binding - and type module_binding = M.module_binding - and type match_case = M.match_case - and type ident = M.ident - and type rec_flag = M.rec_flag - and type direction_flag = M.direction_flag - and type mutable_flag = M.mutable_flag - and type private_flag = M.private_flag - and type virtual_flag = M.virtual_flag - and type row_var_flag = M.row_var_flag - and type override_flag = M.override_flag -= M; - -(** Concrete definition of Camlp4 ASTs abstracted from locations. - Since the Ast contains locations, this functor produces Ast types - for a given location type. *) -module MakeCamlp4Ast (Loc : Type) = struct - - INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; - -end; - -(** {6 Filters} *) - -(** A type for stream filters. *) -type stream_filter 'a 'loc = Stream.t ('a * 'loc) -> Stream.t ('a * 'loc); - -(** Registerinng and folding of Ast filters. - Two kinds of filters must be handled: - - Implementation filters: str_item -> str_item. - - Interface filters: sig_item -> sig_item. *) -module type AstFilters = sig - - module Ast : Camlp4Ast; - - type filter 'a = 'a -> 'a; - - value register_sig_item_filter : (filter Ast.sig_item) -> unit; - value register_str_item_filter : (filter Ast.str_item) -> unit; - value register_topphrase_filter : (filter Ast.str_item) -> unit; - - value fold_interf_filters : ('a -> filter Ast.sig_item -> 'a) -> 'a -> 'a; - value fold_implem_filters : ('a -> filter Ast.str_item -> 'a) -> 'a -> 'a; - value fold_topphrase_filters : ('a -> filter Ast.str_item -> 'a) -> 'a -> 'a; - -end; - -(** ASTs as one single dynamic type *) -module type DynAst = sig - module Ast : Ast; - type tag 'a; - - value ctyp_tag : tag Ast.ctyp; - value patt_tag : tag Ast.patt; - value expr_tag : tag Ast.expr; - value module_type_tag : tag Ast.module_type; - value sig_item_tag : tag Ast.sig_item; - value with_constr_tag : tag Ast.with_constr; - value module_expr_tag : tag Ast.module_expr; - value str_item_tag : tag Ast.str_item; - value class_type_tag : tag Ast.class_type; - value class_sig_item_tag : tag Ast.class_sig_item; - value class_expr_tag : tag Ast.class_expr; - value class_str_item_tag : tag Ast.class_str_item; - value match_case_tag : tag Ast.match_case; - value ident_tag : tag Ast.ident; - value binding_tag : tag Ast.binding; - value rec_binding_tag : tag Ast.rec_binding; - value module_binding_tag : tag Ast.module_binding; - - value string_of_tag : tag 'a -> string; - - module Pack (X : sig type t 'a; end) : sig - type pack; - value pack : tag 'a -> X.t 'a -> pack; - value unpack : tag 'a -> pack -> X.t 'a; - value print_tag : Format.formatter -> pack -> unit; - end; -end; - - -(** {6 Quotation operations} *) - -(** The generic quotation type. - To see how fields are used here is an example: - <:q_name@q_loc> - The last one, q_shift is equal to the length of "<:q_name@q_loc<". *) -type quotation = - { q_name : string ; - q_loc : string ; - q_shift : int ; - q_contents : string }; - -(** The signature for a quotation expander registery. *) -module type Quotation = sig - module Ast : Ast; - module DynAst : DynAst with module Ast = Ast; - open Ast; - - (** The [loc] is the initial location. The option string is the optional name - for the location variable. The string is the quotation contents. *) - type expand_fun 'a = loc -> option string -> string -> 'a; - - (** [add name exp] adds the quotation [name] associated with the - expander [exp]. *) - value add : string -> DynAst.tag 'a -> expand_fun 'a -> unit; - - (** [find name] returns the expander of the given quotation name. *) - value find : string -> DynAst.tag 'a -> expand_fun 'a; - - (** [default] holds the default quotation name. *) - value default : ref string; - - (** [parse_quotation_result parse_function loc position_tag quotation quotation_result] - It's a parser wrapper, this function handles the error reporting for you. *) - value parse_quotation_result : - (loc -> string -> 'a) -> loc -> quotation -> string -> string -> 'a; - - (** function translating quotation names; default = identity *) - value translate : ref (string -> string); - - value expand : loc -> quotation -> DynAst.tag 'a -> 'a; - - (** [dump_file] optionally tells Camlp4 to dump the - result of an expander if this result is syntactically incorrect. - If [None] (default), this result is not dumped. If [Some fname], the - result is dumped in the file [fname]. *) - value dump_file : ref (option string); - - module Error : Error; - -end; - -(** {6 Tokens} *) - -(** A signature for tokens. *) -module type Token = sig - - module Loc : Loc; - - type t; - - value to_string : t -> string; - - value print : Format.formatter -> t -> unit; - - value match_keyword : string -> t -> bool; - - value extract_string : t -> string; - - module Filter : sig - - type token_filter = stream_filter t Loc.t; - - (** The type for this filter chain. - A basic implementation just store the [is_keyword] function given - by [mk] and use it in the [filter] function. *) - type t; - - (** The given predicate function returns true if the given string - is a keyword. This function can be used in filters to translate - identifier tokens to keyword tokens. *) - value mk : (string -> bool) -> t; - - (** This function allows to register a new filter to the token filter chain. - You can choose to not support these and raise an exception. *) - value define_filter : t -> (token_filter -> token_filter) -> unit; - - (** This function filter the given stream and return a filtered stream. - A basic implementation just match identifiers against the [is_keyword] - function to produce token keywords instead. *) - value filter : t -> token_filter; - - (** Called by the grammar system when a keyword is used. - The boolean argument is True when it's the first time that keyword - is used. If you do not care about this information just return [()]. *) - value keyword_added : t -> string -> bool -> unit; - - (** Called by the grammar system when a keyword is no longer used. - If you do not care about this information just return [()]. *) - value keyword_removed : t -> string -> unit; - end; - - module Error : Error; -end; - -(** This signature describes tokens for the OCaml and the Revised - syntax lexing rules. For some tokens the data constructor holds two - representations with the evaluated one and the source one. For example - the INT data constructor holds an integer and a string, this string can - contains more information that's needed for a good pretty-printing - ("42", "4_2", "0000042", "0b0101010"...). - - The meaning of the tokens are: -- [KEYWORD s] is the keyword [s]. -- [LIDENT s] is the ident [s] starting with a lowercase letter. -- [UIDENT s] is the ident [s] starting with an uppercase letter. -- [INT i s] (resp. [INT32 i s], [INT64 i s] and [NATIVEINT i s]) - the integer constant [i] whose string source is [s]. -- [FLOAT f s] is the float constant [f] whose string source is [s]. -- [STRING s s'] is the string constant [s] whose string source is [s']. -- [CHAR c s] is the character constant [c] whose string source is [s]. -- [QUOTATION q] is a quotation [q], see {!Quotation.t} for more information. -- [ANTIQUOT n s] is an antiquotation [n] holding the string [s]. -- [EOI] is the end of input. - - Warning: the second string associated with the constructor [STRING] is - the string found in the source without any interpretation. In particular, - the backslashes are not interpreted. For example, if the input is ["\n"] - the string is *not* a string with one element containing the character - "return", but a string of two elements: the backslash and the character - ["n"]. To interpret a string use the first string of the [STRING] - constructor (or if you need to compute it use the module - {!Camlp4.Struct.Token.Eval}. Same thing for the constructor [CHAR]. *) -type camlp4_token = - [ KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int and string - | INT32 of int32 and string - | INT64 of int64 and string - | NATIVEINT of nativeint and string - | FLOAT of float and string - | CHAR of char and string - | STRING of string and string - | LABEL of string - | OPTLABEL of string - | QUOTATION of quotation - | ANTIQUOT of string and string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int and option string - | EOI ]; - -(** A signature for specialized tokens. *) -module type Camlp4Token = Token with type t = camlp4_token; - -(** {6 Dynamic loaders} *) - -(** A signature for dynamic loaders. *) -module type DynLoader = sig - type t; - exception Error of string and string; - - (** [mk ?ocaml_stdlib ?camlp4_stdlib] - The stdlib flag is true by default. - To disable it use: [mk ~ocaml_stdlib:False] *) - value mk : ?ocaml_stdlib: bool -> ?camlp4_stdlib: bool -> unit -> t; - - (** Fold over the current load path list. *) - value fold_load_path : t -> (string -> 'a -> 'a) -> 'a -> 'a; - - (** [load f] Load the file [f]. If [f] is not an absolute path name, - the load path list used to find the directory of [f]. *) - value load : t -> string -> unit; - - (** [include_dir d] Add the directory [d] in the current load path - list (like the common -I option). *) - value include_dir : t -> string -> unit; - - (** [find_in_path f] Returns the full path of the file [f] if - [f] is in the current load path, raises [Not_found] otherwise. *) - value find_in_path : t -> string -> string; - - (** [is_native] [True] if we are in native code, [False] for bytecode. *) - value is_native : bool; -end; - -(** A signature for grammars. *) -module Grammar = struct - - (** Internal signature for sematantic actions of grammars, - not for the casual user. These functions are unsafe. *) - module type Action = sig - type t ; - - value mk : 'a -> t; - value get : t -> 'a; - value getf : t -> ('a -> 'b); - value getf2 : t -> ('a -> 'b -> 'c); - end; - - type assoc = - [ NonA - | RightA - | LeftA ]; - - type position = - [ First - | Last - | Before of string - | After of string - | Level of string ]; - - (** Common signature for {!Sig.Grammar.Static} and {!Sig.Grammar.Dynamic}. *) - module type Structure = sig - module Loc : Loc; - module Action : Action; - module Token : Token with module Loc = Loc; - - type gram; - type internal_entry; - type tree; - - type token_pattern = ((Token.t -> bool) * string); - type token_info; - type token_stream = Stream.t (Token.t * token_info); - - value token_location : token_info -> Loc.t; - - type symbol = - [ Smeta of string and list symbol and Action.t - | Snterm of internal_entry - | Snterml of internal_entry and string - | Slist0 of symbol - | Slist0sep of symbol and symbol - | Slist1 of symbol - | Slist1sep of symbol and symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree ]; - - type production_rule = (list symbol * Action.t); - type single_extend_statment = - (option string * option assoc * list production_rule); - type extend_statment = - (option position * list single_extend_statment); - type delete_statment = list symbol; - - type fold 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; - - type foldsep 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; - - end; - - (** Signature for Camlp4 grammars. Here the dynamic means that you can produce as - many grammar values as needed with a single grammar module. - If you do not need many grammar values it's preferable to use a static one. *) - module type Dynamic = sig - include Structure; - - (** Make a new grammar. *) - value mk : unit -> gram; - - module Entry : sig - (** The abstract type of grammar entries. The type parameter is the type - of the semantic actions that are associated with this entry. *) - type t 'a; - - (** Make a new entry from the given name. *) - value mk : gram -> string -> t 'a; - - (** Make a new entry from a name and an hand made token parser. *) - value of_parser : - gram -> string -> (token_stream -> 'a) -> t 'a; - - (** Clear the entry and setup this parser instead. *) - value setup_parser : - t 'a -> (token_stream -> 'a) -> unit; - - (** Get the entry name. *) - value name : t 'a -> string; - - (** Print the given entry into the given formatter. *) - value print : Format.formatter -> t 'a -> unit; - - (** Same as {!print} but show the left-factorization. *) - value dump : Format.formatter -> t 'a -> unit; - - (**/**) - value obj : t 'a -> internal_entry; - value clear : t 'a -> unit; - (**/**) - end; - - (** [get_filter g] Get the {!Token.Filter} associated to the [g]. *) - value get_filter : gram -> Token.Filter.t; - - type not_filtered 'a; - - (** This function is called by the EXTEND ... END syntax. *) - value extend : Entry.t 'a -> extend_statment -> unit; - - (** The delete rule. *) - value delete_rule : Entry.t 'a -> delete_statment -> unit; - - value srules : Entry.t 'a -> list (list symbol * Action.t) -> symbol; - value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; - (* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *) - - (** Use the lexer to produce a non filtered token stream from a char stream. *) - value lex : gram -> Loc.t -> Stream.t char -> not_filtered (Stream.t (Token.t * Loc.t)); - - (** Token stream from string. *) - value lex_string : gram -> Loc.t -> string -> not_filtered (Stream.t (Token.t * Loc.t)); - - (** Filter a token stream using the {!Token.Filter} module *) - value filter : gram -> not_filtered (Stream.t (Token.t * Loc.t)) -> token_stream; - - (** Lex, filter and parse a stream of character. *) - value parse : Entry.t 'a -> Loc.t -> Stream.t char -> 'a; - - (** Same as {!parse} but from a string. *) - value parse_string : Entry.t 'a -> Loc.t -> string -> 'a; - - (** Parse a token stream that is not filtered yet. *) - value parse_tokens_before_filter : - Entry.t 'a -> not_filtered (Stream.t (Token.t * Loc.t)) -> 'a; - - (** Parse a token stream that is already filtered. *) - value parse_tokens_after_filter : - Entry.t 'a -> token_stream -> 'a; - - end; - - (** Signature for Camlp4 grammars. Here the static means that there is only - one grammar value by grammar module. If you do not need to store the grammar - value it's preferable to use a static one. *) - module type Static = sig - include Structure; - - module Entry : sig - (** The abstract type of grammar entries. The type parameter is the type - of the semantic actions that are associated with this entry. *) - type t 'a; - - (** Make a new entry from the given name. *) - value mk : string -> t 'a; - - (** Make a new entry from a name and an hand made token parser. *) - value of_parser : - string -> (token_stream -> 'a) -> t 'a; - - (** Clear the entry and setup this parser instead. *) - value setup_parser : - t 'a -> (token_stream -> 'a) -> unit; - - (** Get the entry name. *) - value name : t 'a -> string; - - (** Print the given entry into the given formatter. *) - value print : Format.formatter -> t 'a -> unit; - - (** Same as {!print} but show the left-factorization. *) - value dump : Format.formatter -> t 'a -> unit; - - (**/**) - value obj : t 'a -> internal_entry; - value clear : t 'a -> unit; - (**/**) - end; - - (** Get the {!Token.Filter} associated to the grammar module. *) - value get_filter : unit -> Token.Filter.t; - - type not_filtered 'a; - - (** This function is called by the EXTEND ... END syntax. *) - value extend : Entry.t 'a -> extend_statment -> unit; - - (** The delete rule. *) - value delete_rule : Entry.t 'a -> delete_statment -> unit; - value srules : Entry.t 'a -> list (list symbol * Action.t) -> symbol; - value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; - (* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *) - - (** Use the lexer to produce a non filtered token stream from a char stream. *) - value lex : Loc.t -> Stream.t char -> not_filtered (Stream.t (Token.t * Loc.t)); - - (** Token stream from string. *) - value lex_string : Loc.t -> string -> not_filtered (Stream.t (Token.t * Loc.t)); - - (** Filter a token stream using the {!Token.Filter} module *) - value filter : not_filtered (Stream.t (Token.t * Loc.t)) -> token_stream; - - (** Lex, filter and parse a stream of character. *) - value parse : Entry.t 'a -> Loc.t -> Stream.t char -> 'a; - - (** Same as {!parse} but from a string. *) - value parse_string : Entry.t 'a -> Loc.t -> string -> 'a; - - (** Parse a token stream that is not filtered yet. *) - value parse_tokens_before_filter : - Entry.t 'a -> not_filtered (Stream.t (Token.t * Loc.t)) -> 'a; - - (** Parse a token stream that is already filtered. *) - value parse_tokens_after_filter : - Entry.t 'a -> token_stream -> 'a; - - end; - -end; - -(** A signature for lexers. *) -module type Lexer = sig - module Loc : Loc; - module Token : Token with module Loc = Loc; - module Error : Error; - - (** The constructor for a lexing function. The character stream is the input - stream to be lexed. The result is a stream of pairs of a token and - a location. - The lexer do not use global (mutable) variables: instantiations - of [Lexer.mk ()] do not perturb each other. *) - value mk : unit -> (Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t)); -end; - - -(** A signature for parsers abstract from ASTs. *) -module Parser (Ast : Ast) = struct - module type SIMPLE = sig - (** The parse function for expressions. - The underlying expression grammar entry is generally "expr; EOI". *) - value parse_expr : Ast.loc -> string -> Ast.expr; - - (** The parse function for patterns. - The underlying pattern grammar entry is generally "patt; EOI". *) - value parse_patt : Ast.loc -> string -> Ast.patt; - end; - - module type S = sig - - (** Called when parsing an implementation (ml file) to build the syntax - tree; the returned list contains the phrases (structure items) as a - single "declare" node (a list of structure items); if the parser - encounter a directive it stops (since the directive may change the - syntax), the given [directive_handler] function evaluates it and - the parsing starts again. *) - value parse_implem : ?directive_handler:(Ast.str_item -> option Ast.str_item) -> - Ast.loc -> Stream.t char -> Ast.str_item; - - (** Same as {!parse_implem} but for interface (mli file). *) - value parse_interf : ?directive_handler:(Ast.sig_item -> option Ast.sig_item) -> - Ast.loc -> Stream.t char -> Ast.sig_item; - end; -end; - -(** A signature for printers abstract from ASTs. *) -module Printer (Ast : Ast) = struct - module type S = sig - - value print_interf : ?input_file:string -> ?output_file:string -> - Ast.sig_item -> unit; - value print_implem : ?input_file:string -> ?output_file:string -> - Ast.str_item -> unit; - - end; -end; - -(** A syntax module is a sort of constistent bunch of modules and values. - In such a module you have a parser, a printer, and also modules for - locations, syntax trees, tokens, grammars, quotations, anti-quotations. - There is also the main grammar entries. *) -module type Syntax = sig - module Loc : Loc; - module Ast : Ast with type loc = Loc.t; - module Token : Token with module Loc = Loc; - module Gram : Grammar.Static with module Loc = Loc and module Token = Token; - module Quotation : Quotation with module Ast = Ast; - - module AntiquotSyntax : (Parser Ast).SIMPLE; - - include (Warning Loc).S; - include (Parser Ast).S; - include (Printer Ast).S; -end; - -(** A syntax module is a sort of constistent bunch of modules and values. - In such a module you have a parser, a printer, and also modules for - locations, syntax trees, tokens, grammars, quotations, anti-quotations. - There is also the main grammar entries. *) -module type Camlp4Syntax = sig - module Loc : Loc; - - module Ast : Camlp4Ast with module Loc = Loc; - module Token : Camlp4Token with module Loc = Loc; - - module Gram : Grammar.Static with module Loc = Loc and module Token = Token; - module Quotation : Quotation with module Ast = Camlp4AstToAst Ast; - - module AntiquotSyntax : (Parser Ast).SIMPLE; - - include (Warning Loc).S; - include (Parser Ast).S; - include (Printer Ast).S; - - value interf : Gram.Entry.t (list Ast.sig_item * option Loc.t); - value implem : Gram.Entry.t (list Ast.str_item * option Loc.t); - value top_phrase : Gram.Entry.t (option Ast.str_item); - value use_file : Gram.Entry.t (list Ast.str_item * option Loc.t); - value a_CHAR : Gram.Entry.t string; - value a_FLOAT : Gram.Entry.t string; - value a_INT : Gram.Entry.t string; - value a_INT32 : Gram.Entry.t string; - value a_INT64 : Gram.Entry.t string; - value a_LABEL : Gram.Entry.t string; - value a_LIDENT : Gram.Entry.t string; - value a_NATIVEINT : Gram.Entry.t string; - value a_OPTLABEL : Gram.Entry.t string; - value a_STRING : Gram.Entry.t string; - value a_UIDENT : Gram.Entry.t string; - value a_ident : Gram.Entry.t string; - value amp_ctyp : Gram.Entry.t Ast.ctyp; - value and_ctyp : Gram.Entry.t Ast.ctyp; - value match_case : Gram.Entry.t Ast.match_case; - value match_case0 : Gram.Entry.t Ast.match_case; - value match_case_quot : Gram.Entry.t Ast.match_case; - value binding : Gram.Entry.t Ast.binding; - value binding_quot : Gram.Entry.t Ast.binding; - value rec_binding_quot : Gram.Entry.t Ast.rec_binding; - value class_declaration : Gram.Entry.t Ast.class_expr; - value class_description : Gram.Entry.t Ast.class_type; - value class_expr : Gram.Entry.t Ast.class_expr; - value class_expr_quot : Gram.Entry.t Ast.class_expr; - value class_fun_binding : Gram.Entry.t Ast.class_expr; - value class_fun_def : Gram.Entry.t Ast.class_expr; - value class_info_for_class_expr : Gram.Entry.t Ast.class_expr; - value class_info_for_class_type : Gram.Entry.t Ast.class_type; - value class_longident : Gram.Entry.t Ast.ident; - value class_longident_and_param : Gram.Entry.t Ast.class_expr; - value class_name_and_param : Gram.Entry.t (string * Ast.ctyp); - value class_sig_item : Gram.Entry.t Ast.class_sig_item; - value class_sig_item_quot : Gram.Entry.t Ast.class_sig_item; - value class_signature : Gram.Entry.t Ast.class_sig_item; - value class_str_item : Gram.Entry.t Ast.class_str_item; - value class_str_item_quot : Gram.Entry.t Ast.class_str_item; - value class_structure : Gram.Entry.t Ast.class_str_item; - value class_type : Gram.Entry.t Ast.class_type; - value class_type_declaration : Gram.Entry.t Ast.class_type; - value class_type_longident : Gram.Entry.t Ast.ident; - value class_type_longident_and_param : Gram.Entry.t Ast.class_type; - value class_type_plus : Gram.Entry.t Ast.class_type; - value class_type_quot : Gram.Entry.t Ast.class_type; - value comma_ctyp : Gram.Entry.t Ast.ctyp; - value comma_expr : Gram.Entry.t Ast.expr; - value comma_ipatt : Gram.Entry.t Ast.patt; - value comma_patt : Gram.Entry.t Ast.patt; - value comma_type_parameter : Gram.Entry.t Ast.ctyp; - value constrain : Gram.Entry.t (Ast.ctyp * Ast.ctyp); - value constructor_arg_list : Gram.Entry.t Ast.ctyp; - value constructor_declaration : Gram.Entry.t Ast.ctyp; - value constructor_declarations : Gram.Entry.t Ast.ctyp; - value ctyp : Gram.Entry.t Ast.ctyp; - value ctyp_quot : Gram.Entry.t Ast.ctyp; - value cvalue_binding : Gram.Entry.t Ast.expr; - value direction_flag : Gram.Entry.t Ast.direction_flag; - value direction_flag_quot : Gram.Entry.t Ast.direction_flag; - value dummy : Gram.Entry.t unit; - value eq_expr : Gram.Entry.t (string -> Ast.patt -> Ast.patt); - value expr : Gram.Entry.t Ast.expr; - value expr_eoi : Gram.Entry.t Ast.expr; - value expr_quot : Gram.Entry.t Ast.expr; - value field_expr : Gram.Entry.t Ast.rec_binding; - value field_expr_list : Gram.Entry.t Ast.rec_binding; - value fun_binding : Gram.Entry.t Ast.expr; - value fun_def : Gram.Entry.t Ast.expr; - value ident : Gram.Entry.t Ast.ident; - value ident_quot : Gram.Entry.t Ast.ident; - value ipatt : Gram.Entry.t Ast.patt; - value ipatt_tcon : Gram.Entry.t Ast.patt; - value label : Gram.Entry.t string; - value label_declaration : Gram.Entry.t Ast.ctyp; - value label_declaration_list : Gram.Entry.t Ast.ctyp; - value label_expr : Gram.Entry.t Ast.rec_binding; - value label_expr_list : Gram.Entry.t Ast.rec_binding; - value label_ipatt : Gram.Entry.t Ast.patt; - value label_ipatt_list : Gram.Entry.t Ast.patt; - value label_longident : Gram.Entry.t Ast.ident; - value label_patt : Gram.Entry.t Ast.patt; - value label_patt_list : Gram.Entry.t Ast.patt; - value labeled_ipatt : Gram.Entry.t Ast.patt; - value let_binding : Gram.Entry.t Ast.binding; - value meth_list : Gram.Entry.t (Ast.ctyp * Ast.row_var_flag); - value meth_decl : Gram.Entry.t Ast.ctyp; - value module_binding : Gram.Entry.t Ast.module_binding; - value module_binding0 : Gram.Entry.t Ast.module_expr; - value module_binding_quot : Gram.Entry.t Ast.module_binding; - value module_declaration : Gram.Entry.t Ast.module_type; - value module_expr : Gram.Entry.t Ast.module_expr; - value module_expr_quot : Gram.Entry.t Ast.module_expr; - value module_longident : Gram.Entry.t Ast.ident; - value module_longident_with_app : Gram.Entry.t Ast.ident; - value module_rec_declaration : Gram.Entry.t Ast.module_binding; - value module_type : Gram.Entry.t Ast.module_type; - value package_type : Gram.Entry.t Ast.module_type; - value module_type_quot : Gram.Entry.t Ast.module_type; - value more_ctyp : Gram.Entry.t Ast.ctyp; - value name_tags : Gram.Entry.t Ast.ctyp; - value opt_as_lident : Gram.Entry.t string; - value opt_class_self_patt : Gram.Entry.t Ast.patt; - value opt_class_self_type : Gram.Entry.t Ast.ctyp; - value opt_comma_ctyp : Gram.Entry.t Ast.ctyp; - value opt_dot_dot : Gram.Entry.t Ast.row_var_flag; - value row_var_flag_quot : Gram.Entry.t Ast.row_var_flag; - value opt_eq_ctyp : Gram.Entry.t Ast.ctyp; - value opt_expr : Gram.Entry.t Ast.expr; - value opt_meth_list : Gram.Entry.t Ast.ctyp; - value opt_mutable : Gram.Entry.t Ast.mutable_flag; - value mutable_flag_quot : Gram.Entry.t Ast.mutable_flag; - value opt_override : Gram.Entry.t Ast.override_flag; - value override_flag_quot : Gram.Entry.t Ast.override_flag; - value opt_polyt : Gram.Entry.t Ast.ctyp; - value opt_private : Gram.Entry.t Ast.private_flag; - value private_flag_quot : Gram.Entry.t Ast.private_flag; - value opt_rec : Gram.Entry.t Ast.rec_flag; - value rec_flag_quot : Gram.Entry.t Ast.rec_flag; - value opt_virtual : Gram.Entry.t Ast.virtual_flag; - value virtual_flag_quot : Gram.Entry.t Ast.virtual_flag; - value opt_when_expr : Gram.Entry.t Ast.expr; - value patt : Gram.Entry.t Ast.patt; - value patt_as_patt_opt : Gram.Entry.t Ast.patt; - value patt_eoi : Gram.Entry.t Ast.patt; - value patt_quot : Gram.Entry.t Ast.patt; - value patt_tcon : Gram.Entry.t Ast.patt; - value phrase : Gram.Entry.t Ast.str_item; - value poly_type : Gram.Entry.t Ast.ctyp; - value row_field : Gram.Entry.t Ast.ctyp; - value sem_expr : Gram.Entry.t Ast.expr; - value sem_expr_for_list : Gram.Entry.t (Ast.expr -> Ast.expr); - value sem_patt : Gram.Entry.t Ast.patt; - value sem_patt_for_list : Gram.Entry.t (Ast.patt -> Ast.patt); - value semi : Gram.Entry.t unit; - value sequence : Gram.Entry.t Ast.expr; - value do_sequence : Gram.Entry.t Ast.expr; - value sig_item : Gram.Entry.t Ast.sig_item; - value sig_item_quot : Gram.Entry.t Ast.sig_item; - value sig_items : Gram.Entry.t Ast.sig_item; - value star_ctyp : Gram.Entry.t Ast.ctyp; - value str_item : Gram.Entry.t Ast.str_item; - value str_item_quot : Gram.Entry.t Ast.str_item; - value str_items : Gram.Entry.t Ast.str_item; - value type_constraint : Gram.Entry.t unit; - value type_declaration : Gram.Entry.t Ast.ctyp; - value type_ident_and_parameters : Gram.Entry.t (string * list Ast.ctyp); - value type_kind : Gram.Entry.t Ast.ctyp; - value type_longident : Gram.Entry.t Ast.ident; - value type_longident_and_parameters : Gram.Entry.t Ast.ctyp; - value type_parameter : Gram.Entry.t Ast.ctyp; - value type_parameters : Gram.Entry.t (Ast.ctyp -> Ast.ctyp); - value typevars : Gram.Entry.t Ast.ctyp; - value val_longident : Gram.Entry.t Ast.ident; - value value_let : Gram.Entry.t unit; - value value_val : Gram.Entry.t unit; - value with_constr : Gram.Entry.t Ast.with_constr; - value with_constr_quot : Gram.Entry.t Ast.with_constr; - value prefixop : Gram.Entry.t Ast.expr; - value infixop0 : Gram.Entry.t Ast.expr; - value infixop1 : Gram.Entry.t Ast.expr; - value infixop2 : Gram.Entry.t Ast.expr; - value infixop3 : Gram.Entry.t Ast.expr; - value infixop4 : Gram.Entry.t Ast.expr; -end; - -(** A signature for syntax extension (syntax -> syntax functors). *) -module type SyntaxExtension = functor (Syn : Syntax) - -> (Syntax with module Loc = Syn.Loc - and module Ast = Syn.Ast - and module Token = Syn.Token - and module Gram = Syn.Gram - and module Quotation = Syn.Quotation); diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/AstFilters.ml ocaml-4.05.0/camlp4/Camlp4/Struct/AstFilters.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/AstFilters.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/AstFilters.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Ast : Sig.Camlp4Ast) -: Sig.AstFilters with module Ast = Ast -= struct - - module Ast = Ast; - - type filter 'a = 'a -> 'a; - - value interf_filters = Queue.create (); - value fold_interf_filters f i = Queue.fold f i interf_filters; - value implem_filters = Queue.create (); - value fold_implem_filters f i = Queue.fold f i implem_filters; - value topphrase_filters = Queue.create (); - value fold_topphrase_filters f i = Queue.fold f i topphrase_filters; - - value register_sig_item_filter f = Queue.add f interf_filters; - value register_str_item_filter f = Queue.add f implem_filters; - value register_topphrase_filter f = Queue.add f topphrase_filters; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml 2013-08-30 11:39:33.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,1238 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2002-2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -module Make (Ast : Sig.Camlp4Ast) = struct - open Format; - open Camlp4_import.Parsetree; - open Camlp4_import.Longident; - open Camlp4_import.Asttypes; - open Ast; - - value constructors_arity () = - debug ast2pt "constructors_arity: %b@." Camlp4_config.constructors_arity.val in - Camlp4_config.constructors_arity.val; - - value error loc str = Loc.raise loc (Failure str); - - value char_of_char_token loc s = - try Token.Eval.char s with [ Failure _ as exn -> Loc.raise loc exn ] - ; - - value string_of_string_token loc s = - try Token.Eval.string s - with [ Failure _ as exn -> Loc.raise loc exn ] - ; - - value remove_underscores s = - let l = String.length s in - let rec remove src dst = - if src >= l then - if dst >= l then s else String.sub s 0 dst - else - match s.[src] with - [ '_' -> remove (src + 1) dst - | c -> do { s.[dst] := c; remove (src + 1) (dst + 1) } ] - in remove 0 0 - ; - - value mkloc = Loc.to_ocaml_location; - value mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc); - - value with_loc txt loc = Camlp4_import.Location.mkloc txt (mkloc loc); - - value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc}; - value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc}; - value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc}; - value mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc}; - value mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc}; - value mksig loc d = {psig_desc = d; psig_loc = mkloc loc}; - value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc}; - value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc}; - value mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc}; - value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc}; - value mkcl loc d = {pcl_desc = d; pcl_loc = mkloc loc}; - value mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; }; - value mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; }; - - value mkpolytype t = - match t.ptyp_desc with - [ Ptyp_poly _ _ -> t - | _ -> { (t) with ptyp_desc = Ptyp_poly [] t } ] - ; - - value mkvirtual = fun - [ <:virtual_flag< virtual >> -> Virtual - | <:virtual_flag<>> -> Concrete - | _ -> assert False ]; - - value mkdirection = fun - [ <:direction_flag< to >> -> Upto - | <:direction_flag< downto >> -> Downto - | _ -> assert False ]; - - value lident s = Lident s; - value lident_with_loc s loc = with_loc (Lident s) loc; - - - value ldot l s = Ldot l s; - value lapply l s = Lapply l s; - - value conv_con = - let t = Hashtbl.create 73 in - do { - List.iter (fun (s, s') -> Hashtbl.add t s s') - [("True", "true"); ("False", "false"); (" True", "True"); - (" False", "False")]; - fun s -> try Hashtbl.find t s with [ Not_found -> s ] - } - ; - - value conv_lab = - let t = Hashtbl.create 73 in - do { - List.iter (fun (s, s') -> Hashtbl.add t s s') [("val", "contents")]; - fun s -> try Hashtbl.find t s with [ Not_found -> s ] - } - ; - - value array_function_no_loc str name = - ldot (lident str) (if Camlp4_config.unsafe.val then "unsafe_" ^ name else name) - ; - value array_function loc str name = with_loc (array_function_no_loc str name) loc; - value mkrf = - fun - [ <:rec_flag< rec >> -> Recursive - | <:rec_flag<>> -> Nonrecursive - | _ -> assert False ]; - - value mkli sloc s list = with_loc (loop lident list) sloc - where rec loop f = - fun - [ [i :: il] -> loop (ldot (f i)) il - | [] -> f s ] - ; - - value rec ctyp_fa al = - fun - [ TyApp _ f a -> ctyp_fa [a :: al] f - | f -> (f, al) ] - ; - - value ident_tag ?(conv_lid = fun x -> x) i = - - let rec self i acc = - match i with - [ <:ident< $lid:"*predef*"$.$lid:"option"$ >> -> - (ldot (lident "*predef*") "option", `lident) - | <:ident< $i1$.$i2$ >> -> - self i2 (Some (self i1 acc)) - | <:ident< $i1$ $i2$ >> -> - let i' = Lapply (fst (self i1 None)) (fst (self i2 None)) in - let x = - match acc with - [ None -> i' - | _ -> error (loc_of_ident i) "invalid long identifier" ] - in (x, `app) - | <:ident< $uid:s$ >> -> - let x = - match acc with - [ None -> lident s - | Some (acc, `uident | `app) -> ldot acc s - | _ -> error (loc_of_ident i) "invalid long identifier" ] - in (x, `uident) - | <:ident< $lid:s$ >> -> - let x = - match acc with - [ None -> lident (conv_lid s) - | Some (acc, `uident | `app) -> ldot acc (conv_lid s) - | _ -> error (loc_of_ident i) "invalid long identifier" ] - in (x, `lident) - | _ -> error (loc_of_ident i) "invalid long identifier" ] - in self i None; - - value ident_noloc ?conv_lid i = fst (ident_tag ?conv_lid i); - value ident ?conv_lid i = - with_loc (ident_noloc ?conv_lid i) (loc_of_ident i); - - value long_lident msg id = - match ident_tag id with - [ (i, `lident) -> with_loc i (loc_of_ident id) - | _ -> error (loc_of_ident id) msg ] - ; - - value long_type_ident = long_lident "invalid long identifier type"; - value long_class_ident = long_lident "invalid class name"; - - value long_uident_noloc ?(conv_con = fun x -> x) i = - match ident_tag i with - [ (Ldot i s, `uident) -> ldot i (conv_con s) - | (Lident s, `uident) -> lident (conv_con s) - | (i, `app) -> i - | _ -> error (loc_of_ident i) "uppercase identifier expected" ] - ; - - value long_uident ?conv_con i = - with_loc (long_uident_noloc ?conv_con i) (loc_of_ident i); - - value rec ctyp_long_id_prefix t = - match t with - [ <:ctyp< $id:i$ >> -> ident_noloc i - | <:ctyp< $m1$ $m2$ >> -> - let li1 = ctyp_long_id_prefix m1 in - let li2 = ctyp_long_id_prefix m2 in - Lapply li1 li2 - | t -> error (loc_of_ctyp t) "invalid module expression" ] - ; - - value ctyp_long_id t = - match t with - [ <:ctyp< $id:i$ >> -> - (False, long_type_ident i) - | TyApp loc _ _ -> - error loc "invalid type name" - | TyCls _ i -> (True, ident i) - | t -> error (loc_of_ctyp t) "invalid type" ] - ; - - value rec ty_var_list_of_ctyp = - fun - [ <:ctyp< $t1$ $t2$ >> -> ty_var_list_of_ctyp t1 @ ty_var_list_of_ctyp t2 - | <:ctyp< '$s$ >> -> [s] - | _ -> assert False ]; - - value predef_option loc = - TyId (loc, IdAcc (loc, IdLid (loc, "*predef*"), IdLid (loc, "option"))); - - value rec ctyp = - fun - [ TyId loc i -> - let li = long_type_ident i in - mktyp loc (Ptyp_constr li []) - | TyAli loc t1 t2 -> - let (t, i) = - match (t1, t2) with - [ (t, TyQuo _ s) -> (t, s) - | (TyQuo _ s, t) -> (t, s) - | _ -> error loc "invalid alias type" ] - in - mktyp loc (Ptyp_alias (ctyp t) i) - | TyAny loc -> mktyp loc Ptyp_any - | TyApp loc _ _ as f -> - let (f, al) = ctyp_fa [] f in - let (is_cls, li) = ctyp_long_id f in - if is_cls then mktyp loc (Ptyp_class li (List.map ctyp al) []) - else mktyp loc (Ptyp_constr li (List.map ctyp al)) - | TyArr loc (TyLab _ lab t1) t2 -> - mktyp loc (Ptyp_arrow lab (ctyp t1) (ctyp t2)) - | TyArr loc (TyOlb loc1 lab t1) t2 -> - let t1 = TyApp loc1 (predef_option loc1) t1 in - mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2)) - | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2)) - | <:ctyp@loc< < $fl$ > >> -> mktyp loc (Ptyp_object (meth_list fl [])) - | <:ctyp@loc< < $fl$ .. > >> -> - mktyp loc (Ptyp_object (meth_list fl [mkfield loc Pfield_var])) - | TyCls loc id -> - mktyp loc (Ptyp_class (ident id) [] []) - | <:ctyp@loc< (module $pt$) >> -> - let (i, cs) = package_type pt in - mktyp loc (Ptyp_package i cs) - | TyLab loc _ _ -> error loc "labelled type not allowed here" - | TyMan loc _ _ -> error loc "manifest type not allowed here" - | TyOlb loc _ _ -> error loc "labelled type not allowed here" - | TyPol loc t1 t2 -> mktyp loc (Ptyp_poly (ty_var_list_of_ctyp t1) (ctyp t2)) - | TyQuo loc s -> mktyp loc (Ptyp_var s) - | TyRec loc _ -> error loc "record type not allowed here" - | TySum loc _ -> error loc "sum type not allowed here" - | TyPrv loc _ -> error loc "private type not allowed here" - | TyMut loc _ -> error loc "mutable type not allowed here" - | TyOr loc _ _ -> error loc "type1 | type2 not allowed here" - | TyAnd loc _ _ -> error loc "type1 and type2 not allowed here" - | TyOf loc _ _ -> error loc "type1 of type2 not allowed here" - | TyCol loc _ _ -> error loc "type1 : type2 not allowed here" - | TySem loc _ _ -> error loc "type1 ; type2 not allowed here" - | <:ctyp@loc< ($t1$ * $t2$) >> -> - mktyp loc (Ptyp_tuple (List.map ctyp (list_of_ctyp t1 (list_of_ctyp t2 [])))) - | <:ctyp@loc< [ = $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) True None) - | <:ctyp@loc< [ > $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) False None) - | <:ctyp@loc< [ < $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) True (Some [])) - | <:ctyp@loc< [ < $t$ > $t'$ ] >> -> - mktyp loc (Ptyp_variant (row_field t) True (Some (name_tags t'))) - | TyAnt loc _ -> error loc "antiquotation not allowed here" - | TyOfAmp _ _ _ |TyAmp _ _ _ |TySta _ _ _ | - TyCom _ _ _ |TyVrn _ _ |TyQuM _ _ |TyQuP _ _ |TyDcl _ _ _ _ _ | - TyAnP _ | TyAnM _ | TyTypePol _ _ _ | - TyObj _ _ (RvAnt _) | TyNil _ | TyTup _ _ -> - assert False ] - and row_field = fun - [ <:ctyp<>> -> [] - | <:ctyp< `$i$ >> -> [Rtag i True []] - | <:ctyp< `$i$ of & $t$ >> -> [Rtag i True (List.map ctyp (list_of_ctyp t []))] - | <:ctyp< `$i$ of $t$ >> -> [Rtag i False (List.map ctyp (list_of_ctyp t []))] - | <:ctyp< $t1$ | $t2$ >> -> row_field t1 @ row_field t2 - | t -> [Rinherit (ctyp t)] ] - and name_tags = fun - [ <:ctyp< $t1$ $t2$ >> -> name_tags t1 @ name_tags t2 - | <:ctyp< `$s$ >> -> [s] - | _ -> assert False ] - and meth_list fl acc = - match fl with - [ <:ctyp<>> -> acc - | <:ctyp< $t1$; $t2$ >> -> meth_list t1 (meth_list t2 acc) - | <:ctyp@loc< $lid:lab$ : $t$ >> -> - [mkfield loc (Pfield lab (mkpolytype (ctyp t))) :: acc] - | _ -> assert False ] - - and package_type_constraints wc acc = - match wc with - [ <:with_constr<>> -> acc - | <:with_constr< type $id:id$ = $ct$ >> -> - [(ident id, ctyp ct) :: acc] - | <:with_constr< $wc1$ and $wc2$ >> -> - package_type_constraints wc1 (package_type_constraints wc2 acc) - | _ -> error (loc_of_with_constr wc) "unexpected `with constraint' for a package type" ] - - and package_type : module_type -> package_type = - fun - [ <:module_type< $id:i$ with $wc$ >> -> - (long_uident i, package_type_constraints wc []) - | <:module_type< $id:i$ >> -> (long_uident i, []) - | mt -> error (loc_of_module_type mt) "unexpected package type" ] - ; - - value mktype loc tl cl tk tp tm = - let (params, variance) = List.split tl in - {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; - ptype_private = tp; ptype_manifest = tm; ptype_loc = mkloc loc; - ptype_variance = variance} - ; - value mkprivate' m = if m then Private else Public; - value mkprivate = fun - [ <:private_flag< private >> -> Private - | <:private_flag<>> -> Public - | _ -> assert False ]; - value mktrecord = - fun - [ <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : mutable $t$ >> -> - (with_loc s sloc, Mutable, mkpolytype (ctyp t), mkloc loc) - | <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : $t$ >> -> - (with_loc s sloc, Immutable, mkpolytype (ctyp t), mkloc loc) - | _ -> assert False (*FIXME*) ]; - value mkvariant = - fun - [ <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ >> -> - (with_loc (conv_con s) sloc, [], None, mkloc loc) - | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ of $t$ >> -> - (with_loc (conv_con s) sloc, List.map ctyp (list_of_ctyp t []), None, mkloc loc) - | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : ($t$ -> $u$) >> -> - (with_loc (conv_con s) sloc, List.map ctyp (list_of_ctyp t []), Some (ctyp u), mkloc loc) - | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : $t$ >> -> - (with_loc (conv_con s) sloc, [], Some (ctyp t), mkloc loc) - - | _ -> assert False (*FIXME*) ]; - value rec type_decl tl cl loc m pflag = - fun - [ <:ctyp< $t1$ == $t2$ >> -> - type_decl tl cl loc (Some (ctyp t1)) pflag t2 - | <:ctyp@_loc< private $t$ >> -> - if pflag then - error _loc "multiple private keyword used, use only one instead" - else - type_decl tl cl loc m True t - | <:ctyp< { $t$ } >> -> - mktype loc tl cl - (Ptype_record (List.map mktrecord (list_of_ctyp t []))) (mkprivate' pflag) m - | <:ctyp< [ $t$ ] >> -> - mktype loc tl cl - (Ptype_variant (List.map mkvariant (list_of_ctyp t []))) (mkprivate' pflag) m - | t -> - if m <> None then - error loc "only one manifest type allowed by definition" else - let m = - match t with - [ <:ctyp<>> -> None - | _ -> Some (ctyp t) ] - in - mktype loc tl cl Ptype_abstract (mkprivate' pflag) m ] - ; - - value type_decl tl cl t loc = type_decl tl cl loc None False t; - - value mkvalue_desc loc t p = {pval_type = ctyp t; pval_prim = p; pval_loc = mkloc loc}; - - value rec list_of_meta_list = - fun - [ Ast.LNil -> [] - | Ast.LCons x xs -> [x :: list_of_meta_list xs] - | Ast.LAnt _ -> assert False ]; - - value mkmutable = fun - [ <:mutable_flag< mutable >> -> Mutable - | <:mutable_flag<>> -> Immutable - | _ -> assert False ]; - - value paolab lab p = - match (lab, p) with - [ ("", <:patt< $lid:i$ >> | <:patt< ($lid:i$ : $_$) >>) -> i - | ("", p) -> error (loc_of_patt p) "bad ast in label" - | _ -> lab ] - ; - - value opt_private_ctyp = - fun - [ <:ctyp< private $t$ >> -> (Ptype_abstract, Private, ctyp t) - | t -> (Ptype_abstract, Public, ctyp t) ]; - - value rec type_parameters t acc = - match t with - [ <:ctyp< $t1$ $t2$ >> -> type_parameters t1 (type_parameters t2 acc) - | <:ctyp< +'$s$ >> -> [(s, (True, False)) :: acc] - | <:ctyp< -'$s$ >> -> [(s, (False, True)) :: acc] - | <:ctyp< '$s$ >> -> [(s, (False, False)) :: acc] - | _ -> assert False ]; - - value rec optional_type_parameters t acc = - match t with - [ <:ctyp< $t1$ $t2$ >> -> optional_type_parameters t1 (optional_type_parameters t2 acc) - | <:ctyp@loc< +'$s$ >> -> [(Some (with_loc s loc), (True, False)) :: acc] - | Ast.TyAnP _loc -> [(None, (True, False)) :: acc] - | <:ctyp@loc< -'$s$ >> -> [(Some (with_loc s loc), (False, True)) :: acc] - | Ast.TyAnM _loc -> [(None, (False, True)) :: acc] - | <:ctyp@loc< '$s$ >> -> [(Some (with_loc s loc), (False, False)) :: acc] - | Ast.TyAny _loc -> [(None, (False, False)) :: acc] - | _ -> assert False ]; - - value rec class_parameters t acc = - match t with - [ <:ctyp< $t1$, $t2$ >> -> class_parameters t1 (class_parameters t2 acc) - | <:ctyp@loc< +'$s$ >> -> [(with_loc s loc, (True, False)) :: acc] - | <:ctyp@loc< -'$s$ >> -> [(with_loc s loc, (False, True)) :: acc] - | <:ctyp@loc< '$s$ >> -> [(with_loc s loc, (False, False)) :: acc] - | _ -> assert False ]; - - value rec type_parameters_and_type_name t acc = - match t with - [ <:ctyp< $t1$ $t2$ >> -> - type_parameters_and_type_name t1 - (optional_type_parameters t2 acc) - | <:ctyp< $id:i$ >> -> (ident i, acc) - | _ -> assert False ]; - - value mkwithtyp pwith_type loc id_tpl ct = - let (id, tpl) = type_parameters_and_type_name id_tpl [] in - let (params, variance) = List.split tpl in - let (kind, priv, ct) = opt_private_ctyp ct in - (id, pwith_type - {ptype_params = params; ptype_cstrs = []; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = Some ct; - ptype_loc = mkloc loc; ptype_variance = variance}); - - value rec mkwithc wc acc = - match wc with - [ <:with_constr<>> -> acc - | <:with_constr@loc< type $id_tpl$ = $ct$ >> -> - [mkwithtyp (fun x -> Pwith_type x) loc id_tpl ct :: acc] - | <:with_constr< module $i1$ = $i2$ >> -> - [(long_uident i1, Pwith_module (long_uident i2)) :: acc] - | <:with_constr@loc< type $id_tpl$ := $ct$ >> -> - [mkwithtyp (fun x -> Pwith_typesubst x) loc id_tpl ct :: acc] - | <:with_constr< module $i1$ := $i2$ >> (*WcMoS _ i1 i2*) -> - [(long_uident i1, Pwith_modsubst (long_uident i2)) :: acc] - | <:with_constr< $wc1$ and $wc2$ >> -> mkwithc wc1 (mkwithc wc2 acc) - | <:with_constr@loc< $anti:_$ >> -> - error loc "bad with constraint (antiquotation)" ]; - - value rec patt_fa al = - fun - [ PaApp _ f a -> patt_fa [a :: al] f - | f -> (f, al) ] - ; - - value rec deep_mkrangepat loc c1 c2 = - if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1)) - else - mkghpat loc - (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) - (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) - ; - - value rec mkrangepat loc c1 c2 = - if c1 > c2 then mkrangepat loc c2 c1 - else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1)) - else - mkpat loc - (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) - (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) - ; - - value rec patt = - fun - [ <:patt@loc< $id:(<:ident@sloc< $lid:s$ >>)$ >> -> - mkpat loc (Ppat_var (with_loc s sloc)) - | <:patt@loc< $id:i$ >> -> - let p = Ppat_construct (long_uident ~conv_con i) - None (constructors_arity ()) - in mkpat loc p - | PaAli loc p1 p2 -> - let (p, i) = - match (p1, p2) with - [ (p, <:patt< $id:(<:ident@sloc< $lid:s$ >>)$ >>) -> (p, with_loc s sloc) - | (<:patt< $id:(<:ident@sloc< $lid:s$ >>)$ >>, p) -> (p, with_loc s sloc) - | _ -> error loc "invalid alias pattern" ] - in - mkpat loc (Ppat_alias (patt p) i) - | PaAnt loc _ -> error loc "antiquotation not allowed here" - | PaAny loc -> mkpat loc Ppat_any - | <:patt@loc< $id:(<:ident@sloc< $uid:s$ >>)$ ($tup:<:patt@loc_any< _ >>$) >> -> - mkpat loc (Ppat_construct (lident_with_loc (conv_con s) sloc) - (Some (mkpat loc_any Ppat_any)) False) - | PaApp loc _ _ as f -> - let (f, al) = patt_fa [] f in - let al = List.map patt al in - match (patt f).ppat_desc with - [ Ppat_construct li None _ -> - if constructors_arity () then - mkpat loc (Ppat_construct li (Some (mkpat loc (Ppat_tuple al))) True) - else - let a = - match al with - [ [a] -> a - | _ -> mkpat loc (Ppat_tuple al) ] - in - mkpat loc (Ppat_construct li (Some a) False) - | Ppat_variant s None -> - let a = - if constructors_arity () then - mkpat loc (Ppat_tuple al) - else - match al with - [ [a] -> a - | _ -> mkpat loc (Ppat_tuple al) ] - in mkpat loc (Ppat_variant s (Some a)) - | _ -> - error (loc_of_patt f) - "this is not a constructor, it cannot be applied in a pattern" ] - | PaArr loc p -> mkpat loc (Ppat_array (List.map patt (list_of_patt p []))) - | PaChr loc s -> - mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s))) - | PaInt loc s -> - let i = try int_of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int" - ] in mkpat loc (Ppat_constant (Const_int i)) - | PaInt32 loc s -> - let i32 = try Int32.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32" - ] in mkpat loc (Ppat_constant (Const_int32 i32)) - | PaInt64 loc s -> - let i64 = try Int64.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64" - ] in mkpat loc (Ppat_constant (Const_int64 i64)) - | PaNativeInt loc s -> - let nati = try Nativeint.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint" - ] in mkpat loc (Ppat_constant (Const_nativeint nati)) - | PaFlo loc s -> mkpat loc (Ppat_constant (Const_float (remove_underscores s))) - | PaLab loc _ _ -> error loc "labeled pattern not allowed here" - | PaOlb loc _ _ | PaOlbi loc _ _ _ -> error loc "labeled pattern not allowed here" - | PaOrp loc p1 p2 -> mkpat loc (Ppat_or (patt p1) (patt p2)) - | PaRng loc p1 p2 -> - match (p1, p2) with - [ (PaChr loc1 c1, PaChr loc2 c2) -> - let c1 = char_of_char_token loc1 c1 in - let c2 = char_of_char_token loc2 c2 in - mkrangepat loc c1 c2 - | _ -> error loc "range pattern allowed only for characters" ] - | PaRec loc p -> - let ps = list_of_patt p [] in - let is_wildcard = fun [ <:patt< _ >> -> True | _ -> False ] in - let (wildcards,ps) = List.partition is_wildcard ps in - let is_closed = if wildcards = [] then Closed else Open in - mkpat loc (Ppat_record (List.map mklabpat ps, is_closed)) - | PaStr loc s -> - mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s))) - | <:patt@loc< ($p1$, $p2$) >> -> - mkpat loc (Ppat_tuple - (List.map patt (list_of_patt p1 (list_of_patt p2 [])))) - | <:patt@loc< ($tup:_$) >> -> error loc "singleton tuple pattern" - | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t)) - | PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i)) - | PaVrn loc s -> mkpat loc (Ppat_variant (conv_con s) None) - | PaLaz loc p -> mkpat loc (Ppat_lazy (patt p)) - | PaMod loc m -> mkpat loc (Ppat_unpack (with_loc m loc)) - | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p -> - error (loc_of_patt p) "invalid pattern" ] - and mklabpat = - fun - [ <:patt< $i$ = $p$ >> -> (ident ~conv_lid:conv_lab i, patt p) - | p -> error (loc_of_patt p) "invalid pattern" ]; - - value rec expr_fa al = - fun - [ ExApp _ f a -> expr_fa [a :: al] f - | f -> (f, al) ] - ; - - value rec class_expr_fa al = - fun - [ CeApp _ ce a -> class_expr_fa [a :: al] ce - | ce -> (ce, al) ] - ; - - - value rec sep_expr_acc l = - fun - [ ExAcc _ e1 e2 -> sep_expr_acc (sep_expr_acc l e2) e1 - | <:expr@loc< $uid:s$ >> as e -> - match l with - [ [] -> [(loc, [], e)] - | [(loc', sl, e) :: l] -> [(Loc.merge loc loc', [s :: sl], e) :: l] ] - | <:expr< $id:(<:ident< $_$.$_$ >> as i)$ >> -> - let rec normalize_acc = - fun - [ <:ident@_loc< $i1$.$i2$ >> -> - <:expr< $normalize_acc i1$.$normalize_acc i2$ >> - | <:ident@_loc< $i1$ $i2$ >> -> - <:expr< $normalize_acc i1$ $normalize_acc i2$ >> - | <:ident@_loc< $anti:_$ >> | <:ident@_loc< $uid:_$ >> | - <:ident@_loc< $lid:_$ >> as i -> <:expr< $id:i$ >> ] - in sep_expr_acc l (normalize_acc i) - | e -> [(loc_of_expr e, [], e) :: l] ] - ; - - value override_flag loc = - fun [ <:override_flag< ! >> -> Override - | <:override_flag<>> -> Fresh - | _ -> error loc "antiquotation not allowed here" - ]; - - value list_of_opt_ctyp ot acc = - match ot with - [ <:ctyp<>> -> acc - | t -> list_of_ctyp t acc ]; - -value varify_constructors var_names = - let rec loop t = - let desc = - match t.ptyp_desc with - [ - Ptyp_any -> Ptyp_any - | Ptyp_var x -> Ptyp_var x - | Ptyp_arrow label core_type core_type' -> - Ptyp_arrow label (loop core_type) (loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr ({ txt = Lident s }) [] when List.mem s var_names -> - Ptyp_var ("&" ^ s) - | Ptyp_constr longident lst -> - Ptyp_constr longident (List.map loop lst) - | Ptyp_object lst -> - Ptyp_object (List.map loop_core_field lst) - | Ptyp_class longident lst lbl_list -> - Ptyp_class (longident, List.map loop lst, lbl_list) - | Ptyp_alias core_type string -> - Ptyp_alias(loop core_type, string) - | Ptyp_variant row_field_list flag lbl_lst_option -> - Ptyp_variant(List.map loop_row_field row_field_list, flag, lbl_lst_option) - | Ptyp_poly string_lst core_type -> - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package longident lst -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) -] - in - {(t) with ptyp_desc = desc} - and loop_core_field t = - let desc = - match t.pfield_desc with - [ Pfield(n,typ) -> - Pfield(n,loop typ) - | Pfield_var -> - Pfield_var] - in - { (t) with pfield_desc=desc} - and loop_row_field x = - match x with - [ Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) ] - in - loop; - - - - value rec expr = - fun - [ <:expr@loc< $x$.val >> -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc "!" loc))) [("", expr x)]) - | ExAcc loc _ _ | <:expr@loc< $id:<:ident< $_$ . $_$ >>$ >> as e -> - let (e, l) = - match sep_expr_acc [] e with - [ [(loc, ml, <:expr@sloc< $uid:s$ >>) :: l] -> - let ca = constructors_arity () in - (mkexp loc (Pexp_construct (mkli sloc (conv_con s) ml) None ca), l) - | [(loc, ml, <:expr@sloc< $lid:s$ >>) :: l] -> - (mkexp loc (Pexp_ident (mkli sloc s ml)), l) - | [(_, [], e) :: l] -> (expr e, l) - | _ -> error loc "bad ast in expression" ] - in - let (_, e) = - List.fold_left - (fun (loc_bp, e1) (loc_ep, ml, e2) -> - match e2 with - [ <:expr@sloc< $lid:s$ >> -> - let loc = Loc.merge loc_bp loc_ep - in (loc, mkexp loc (Pexp_field e1 (mkli sloc (conv_lab s) ml))) - | _ -> error (loc_of_expr e2) "lowercase identifier expected" ]) - (loc, e) l - in - e - | ExAnt loc _ -> error loc "antiquotation not allowed here" - | ExApp loc _ _ as f -> - let (f, al) = expr_fa [] f in - let al = List.map label_expr al in - match (expr f).pexp_desc with - [ Pexp_construct li None _ -> - let al = List.map snd al in - if constructors_arity () then - mkexp loc (Pexp_construct li (Some (mkexp loc (Pexp_tuple al))) True) - else - let a = - match al with - [ [a] -> a - | _ -> mkexp loc (Pexp_tuple al) ] - in - mkexp loc (Pexp_construct li (Some a) False) - | Pexp_variant s None -> - let al = List.map snd al in - let a = - if constructors_arity () then - mkexp loc (Pexp_tuple al) - else - match al with - [ [a] -> a - | _ -> mkexp loc (Pexp_tuple al) ] - in mkexp loc (Pexp_variant s (Some a)) - | _ -> mkexp loc (Pexp_apply (expr f) al) ] - | ExAre loc e1 e2 -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "get"))) - [("", expr e1); ("", expr e2)]) - | ExArr loc e -> mkexp loc (Pexp_array (List.map expr (list_of_expr e []))) - | ExAsf loc -> mkexp loc Pexp_assertfalse - | ExAss loc e v -> - let e = - match e with - [ <:expr@loc< $x$.val >> -> - Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc ":=" loc))) - [("", expr x); ("", expr v)] - | ExAcc loc _ _ -> - match (expr e).pexp_desc with - [ Pexp_field e lab -> Pexp_setfield e lab (expr v) - | _ -> error loc "bad record access" ] - | ExAre loc e1 e2 -> - Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "set"))) - [("", expr e1); ("", expr e2); ("", expr v)] - | <:expr< $id:(<:ident@lloc< $lid:lab$ >>)$ >> -> Pexp_setinstvar (with_loc lab lloc) (expr v) - | ExSte loc e1 e2 -> - Pexp_apply - (mkexp loc (Pexp_ident (array_function loc "String" "set"))) - [("", expr e1); ("", expr e2); ("", expr v)] - | _ -> error loc "bad left part of assignment" ] - in - mkexp loc e - | ExAsr loc e -> mkexp loc (Pexp_assert (expr e)) - | ExChr loc s -> - mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s))) - | ExCoe loc e t1 t2 -> - let t1 = - match t1 with - [ <:ctyp<>> -> None - | t -> Some (ctyp t) ] in - mkexp loc (Pexp_constraint (expr e) t1 (Some (ctyp t2))) - | ExFlo loc s -> mkexp loc (Pexp_constant (Const_float (remove_underscores s))) - | ExFor loc i e1 e2 df el -> - let e3 = ExSeq loc el in - mkexp loc (Pexp_for (with_loc i loc) (expr e1) (expr e2) (mkdirection df) (expr e3)) - | <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> -> - mkexp loc - (Pexp_function lab None - [(patt_of_lab loc lab po, when_expr e w)]) - | <:expr@loc< fun [ $PaOlbi _ lab p e1$ when $w$ -> $e2$ ] >> -> - let lab = paolab lab p in - mkexp loc - (Pexp_function ("?" ^ lab) (Some (expr e1)) [(patt p, when_expr e2 w)]) - | <:expr@loc< fun [ $PaOlb _ lab p$ when $w$ -> $e$ ] >> -> - let lab = paolab lab p in - mkexp loc - (Pexp_function ("?" ^ lab) None [(patt_of_lab loc lab p, when_expr e w)]) - | ExFun loc a -> mkexp loc (Pexp_function "" None (match_case a [])) - | ExIfe loc e1 e2 e3 -> - mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3))) - | ExInt loc s -> - let i = try int_of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int" - ] in mkexp loc (Pexp_constant (Const_int i)) - | ExInt32 loc s -> - let i32 = try Int32.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32" - ] in mkexp loc (Pexp_constant (Const_int32 i32)) - | ExInt64 loc s -> - let i64 = try Int64.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64" - ] in mkexp loc (Pexp_constant (Const_int64 i64)) - | ExNativeInt loc s -> - let nati = try Nativeint.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint" - ] in mkexp loc (Pexp_constant (Const_nativeint nati)) - | ExLab loc _ _ -> error loc "labeled expression not allowed here" - | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e)) - | ExLet loc rf bi e -> - mkexp loc (Pexp_let (mkrf rf) (binding bi []) (expr e)) - | ExLmd loc i me e -> mkexp loc (Pexp_letmodule (with_loc i loc) (module_expr me) (expr e)) - | ExMat loc e a -> mkexp loc (Pexp_match (expr e) (match_case a [])) - | ExNew loc id -> mkexp loc (Pexp_new (long_type_ident id)) - | ExObj loc po cfl -> - let p = - match po with - [ <:patt<>> -> <:patt@loc< _ >> - | p -> p ] - in - let cil = class_str_item cfl [] in - mkexp loc (Pexp_object { pcstr_pat = patt p; pcstr_fields = cil }) - | ExOlb loc _ _ -> error loc "labeled expression not allowed here" - | ExOvr loc iel -> mkexp loc (Pexp_override (mkideexp iel [])) - | ExRec loc lel eo -> - match lel with - [ <:rec_binding<>> -> error loc "empty record" - | _ -> - let eo = - match eo with - [ <:expr<>> -> None - | e -> Some (expr e) ] in - mkexp loc (Pexp_record (mklabexp lel []) eo) ] - | ExSeq _loc e -> - let rec loop = - fun - [ [] -> expr <:expr< () >> - | [e] -> expr e - | [e :: el] -> - let _loc = Loc.merge (loc_of_expr e) _loc in - mkexp _loc (Pexp_sequence (expr e) (loop el)) ] - in - loop (list_of_expr e []) - | ExSnd loc e s -> mkexp loc (Pexp_send (expr e) s) - | ExSte loc e1 e2 -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (array_function loc "String" "get"))) - [("", expr e1); ("", expr e2)]) - | ExStr loc s -> - mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) - | ExTry loc e a -> mkexp loc (Pexp_try (expr e) (match_case a [])) - | <:expr@loc< ($e1$, $e2$) >> -> - mkexp loc (Pexp_tuple (List.map expr (list_of_expr e1 (list_of_expr e2 [])))) - | <:expr@loc< ($tup:_$) >> -> error loc "singleton tuple" - | ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (Some (ctyp t)) None) - | <:expr@loc< () >> -> - mkexp loc (Pexp_construct (lident_with_loc "()" loc) None True) - | <:expr@loc< $lid:s$ >> -> - mkexp loc (Pexp_ident (lident_with_loc s loc)) - | <:expr@loc< $uid:s$ >> -> - (* let ca = constructors_arity () in *) - mkexp loc (Pexp_construct (lident_with_loc (conv_con s) loc) None True) - | ExVrn loc s -> mkexp loc (Pexp_variant (conv_con s) None) - | ExWhi loc e1 el -> - let e2 = ExSeq loc el in - mkexp loc (Pexp_while (expr e1) (expr e2)) - | <:expr@loc< let open $i$ in $e$ >> -> - mkexp loc (Pexp_open Fresh (long_uident i) (expr e)) - | <:expr@loc< (module $me$ : $pt$) >> -> - mkexp loc (Pexp_constraint (mkexp loc (Pexp_pack (module_expr me)), - Some (mktyp loc (Ptyp_package (package_type pt))), None)) - | <:expr@loc< (module $me$) >> -> - mkexp loc (Pexp_pack (module_expr me)) - | ExFUN loc i e -> - mkexp loc (Pexp_newtype i (expr e)) - | <:expr@loc< $_$,$_$ >> -> error loc "expr, expr: not allowed here" - | <:expr@loc< $_$;$_$ >> -> - error loc "expr; expr: not allowed here, use do {...} or [|...|] to surround them" - | ExId _ _ | ExNil _ as e -> error (loc_of_expr e) "invalid expr" ] - and patt_of_lab _loc lab = - fun - [ <:patt<>> -> patt <:patt< $lid:lab$ >> - | p -> patt p ] - and expr_of_lab _loc lab = - fun - [ <:expr<>> -> expr <:expr< $lid:lab$ >> - | e -> expr e ] - and label_expr = - fun - [ ExLab loc lab eo -> (lab, expr_of_lab loc lab eo) - | ExOlb loc lab eo -> ("?" ^ lab, expr_of_lab loc lab eo) - | e -> ("", expr e) ] - and binding x acc = - match x with - [ <:binding< $x$ and $y$ >> -> - binding x (binding y acc) - | <:binding@_loc< $pat:( <:patt@sloc< $lid:bind_name$ >> )$ = ($e$ : $TyTypePol _ vs ty$) >> -> - (* this code is not pretty because it is temporary *) - let rec id_to_string x = - match x with - [ <:ctyp< $lid:x$ >> -> [x] - | <:ctyp< $x$ $y$ >> -> (id_to_string x) @ (id_to_string y) - | _ -> assert False] - in - let vars = id_to_string vs in - let ampersand_vars = List.map (fun x -> "&" ^ x) vars in - let ty' = varify_constructors vars (ctyp ty) in - let mkexp = mkexp _loc in - let mkpat = mkpat _loc in - let e = mkexp (Pexp_constraint (expr e) (Some (ctyp ty)) None) in - let rec mk_newtypes x = - match x with - [ [newtype :: []] -> mkexp (Pexp_newtype(newtype, e)) - | [newtype :: newtypes] -> - mkexp(Pexp_newtype (newtype,mk_newtypes newtypes)) - | [] -> assert False] - in - let pat = - mkpat (Ppat_constraint (mkpat (Ppat_var (with_loc bind_name sloc)), - mktyp _loc (Ptyp_poly ampersand_vars ty'))) - in - let e = mk_newtypes vars in - [( pat, e) :: acc] - | <:binding@_loc< $p$ = ($e$ : ! $vs$ . $ty$) >> -> - [(patt <:patt< ($p$ : ! $vs$ . $ty$ ) >>, expr e) :: acc] - | <:binding< $p$ = $e$ >> -> [(patt p, expr e) :: acc] - | <:binding<>> -> acc - | _ -> assert False ] - and match_case x acc = - match x with - [ <:match_case< $x$ | $y$ >> -> match_case x (match_case y acc) - | <:match_case< $pat:p$ when $w$ -> $e$ >> -> - [(patt p, when_expr e w) :: acc] - | <:match_case<>> -> acc - | _ -> assert False ] - and when_expr e w = - match w with - [ <:expr<>> -> expr e - | w -> mkexp (loc_of_expr w) (Pexp_when (expr w) (expr e)) ] - and mklabexp x acc = - match x with - [ <:rec_binding< $x$; $y$ >> -> - mklabexp x (mklabexp y acc) - | <:rec_binding< $i$ = $e$ >> -> [(ident ~conv_lid:conv_lab i, expr e) :: acc] - | _ -> assert False ] - and mkideexp x acc = - match x with - [ <:rec_binding<>> -> acc - | <:rec_binding< $x$; $y$ >> -> - mkideexp x (mkideexp y acc) - | <:rec_binding< $id:( <:ident@sloc< $lid:s$ >>)$ = $e$ >> -> [(with_loc s sloc, expr e) :: acc] - | _ -> assert False ] - and mktype_decl x acc = - match x with - [ <:ctyp< $x$ and $y$ >> -> - mktype_decl x (mktype_decl y acc) - | Ast.TyDcl cloc c tl td cl -> - let cl = - List.map - (fun (t1, t2) -> - let loc = Loc.merge (loc_of_ctyp t1) (loc_of_ctyp t2) in - (ctyp t1, ctyp t2, mkloc loc)) - cl - in - [(with_loc c cloc, - type_decl (List.fold_right optional_type_parameters tl []) cl td cloc) :: acc] - | _ -> assert False ] - and module_type = - fun - [ <:module_type@loc<>> -> error loc "abstract/nil module type not allowed here" - | <:module_type@loc< $id:i$ >> -> mkmty loc (Pmty_ident (long_uident i)) - | <:module_type@loc< functor ($n$ : $nt$) -> $mt$ >> -> - mkmty loc (Pmty_functor (with_loc n loc) (module_type nt) (module_type mt)) - | <:module_type@loc< '$_$ >> -> error loc "module type variable not allowed here" - | <:module_type@loc< sig $sl$ end >> -> - mkmty loc (Pmty_signature (sig_item sl [])) - | <:module_type@loc< $mt$ with $wc$ >> -> - mkmty loc (Pmty_with (module_type mt) (mkwithc wc [])) - | <:module_type@loc< module type of $me$ >> -> - mkmty loc (Pmty_typeof (module_expr me)) - | <:module_type< $anti:_$ >> -> assert False ] - and sig_item s l = - match s with - [ <:sig_item<>> -> l - | SgCls loc cd -> - [mksig loc (Psig_class - (List.map class_info_class_type (list_of_class_type cd []))) :: l] - | SgClt loc ctd -> - [mksig loc (Psig_class_type - (List.map class_info_class_type (list_of_class_type ctd []))) :: l] - | <:sig_item< $sg1$; $sg2$ >> -> sig_item sg1 (sig_item sg2 l) - | SgDir _ _ _ -> l - | <:sig_item@loc< exception $uid:s$ >> -> - [mksig loc (Psig_exception (with_loc (conv_con s) loc) []) :: l] - | <:sig_item@loc< exception $uid:s$ of $t$ >> -> - [mksig loc (Psig_exception (with_loc (conv_con s) loc) - (List.map ctyp (list_of_ctyp t []))) :: l] - | SgExc _ _ -> assert False (*FIXME*) - | SgExt loc n t sl -> [mksig loc (Psig_value (with_loc n loc) (mkvalue_desc loc t (list_of_meta_list sl))) :: l] - | SgInc loc mt -> [mksig loc (Psig_include (module_type mt)) :: l] - | SgMod loc n mt -> [mksig loc (Psig_module (with_loc n loc) (module_type mt)) :: l] - | SgRecMod loc mb -> - [mksig loc (Psig_recmodule (module_sig_binding mb [])) :: l] - | SgMty loc n mt -> - let si = - match mt with - [ MtQuo _ _ -> Pmodtype_abstract - | _ -> Pmodtype_manifest (module_type mt) ] - in - [mksig loc (Psig_modtype (with_loc n loc) si) :: l] - | SgOpn loc id -> - [mksig loc (Psig_open Fresh (long_uident id)) :: l] - | SgTyp loc tdl -> [mksig loc (Psig_type (mktype_decl tdl [])) :: l] - | SgVal loc n t -> [mksig loc (Psig_value (with_loc n loc) (mkvalue_desc loc t [])) :: l] - | <:sig_item@loc< $anti:_$ >> -> error loc "antiquotation in sig_item" ] - and module_sig_binding x acc = - match x with - [ <:module_binding< $x$ and $y$ >> -> - module_sig_binding x (module_sig_binding y acc) - | <:module_binding@loc< $s$ : $mt$ >> -> - [(with_loc s loc, module_type mt) :: acc] - | _ -> assert False ] - and module_str_binding x acc = - match x with - [ <:module_binding< $x$ and $y$ >> -> - module_str_binding x (module_str_binding y acc) - | <:module_binding@loc< $s$ : $mt$ = $me$ >> -> - [(with_loc s loc, module_type mt, module_expr me) :: acc] - | _ -> assert False ] - and module_expr = - fun - [ <:module_expr@loc<>> -> error loc "nil module expression" - | <:module_expr@loc< $id:i$ >> -> mkmod loc (Pmod_ident (long_uident i)) - | <:module_expr@loc< $me1$ $me2$ >> -> - mkmod loc (Pmod_apply (module_expr me1) (module_expr me2)) - | <:module_expr@loc< functor ($n$ : $mt$) -> $me$ >> -> - mkmod loc (Pmod_functor (with_loc n loc) (module_type mt) (module_expr me)) - | <:module_expr@loc< struct $sl$ end >> -> - mkmod loc (Pmod_structure (str_item sl [])) - | <:module_expr@loc< ($me$ : $mt$) >> -> - mkmod loc (Pmod_constraint (module_expr me) (module_type mt)) - | <:module_expr@loc< (value $e$ : $pt$) >> -> - mkmod loc (Pmod_unpack ( - mkexp loc (Pexp_constraint (expr e, - Some (mktyp loc (Ptyp_package (package_type pt))), - None)))) - | <:module_expr@loc< (value $e$) >> -> - mkmod loc (Pmod_unpack (expr e)) - | <:module_expr@loc< $anti:_$ >> -> error loc "antiquotation in module_expr" ] - and str_item s l = - match s with - [ <:str_item<>> -> l - | StCls loc cd -> - [mkstr loc (Pstr_class - (List.map class_info_class_expr (list_of_class_expr cd []))) :: l] - | StClt loc ctd -> - [mkstr loc (Pstr_class_type - (List.map class_info_class_type (list_of_class_type ctd []))) :: l] - | <:str_item< $st1$; $st2$ >> -> str_item st1 (str_item st2 l) - | StDir _ _ _ -> l - | <:str_item@loc< exception $uid:s$ >> -> - [mkstr loc (Pstr_exception (with_loc (conv_con s) loc) []) :: l ] - | <:str_item@loc< exception $uid:s$ of $t$ >> -> - [mkstr loc (Pstr_exception (with_loc (conv_con s) loc) - (List.map ctyp (list_of_ctyp t []))) :: l ] - | <:str_item@loc< exception $uid:s$ = $i$ >> -> - [mkstr loc (Pstr_exn_rebind (with_loc (conv_con s) loc) (long_uident ~conv_con i)) :: l ] - | <:str_item@loc< exception $uid:_$ of $_$ = $_$ >> -> - error loc "type in exception alias" - | StExc _ _ _ -> assert False (*FIXME*) - | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l] - | StExt loc n t sl -> [mkstr loc (Pstr_primitive (with_loc n loc) (mkvalue_desc loc t (list_of_meta_list sl))) :: l] - | StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l] - | StMod loc n me -> [mkstr loc (Pstr_module (with_loc n loc) (module_expr me)) :: l] - | StRecMod loc mb -> - [mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l] - | StMty loc n mt -> [mkstr loc (Pstr_modtype (with_loc n loc) (module_type mt)) :: l] - | StOpn loc id -> - [mkstr loc (Pstr_open Fresh (long_uident id)) :: l] - | StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l] - | StVal loc rf bi -> - [mkstr loc (Pstr_value (mkrf rf) (binding bi [])) :: l] - | <:str_item@loc< $anti:_$ >> -> error loc "antiquotation in str_item" ] - and class_type = - fun - [ CtCon loc ViNil id tl -> - mkcty loc - (Pcty_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl []))) - | CtFun loc (TyLab _ lab t) ct -> - mkcty loc (Pcty_fun lab (ctyp t) (class_type ct)) - | CtFun loc (TyOlb loc1 lab t) ct -> - let t = TyApp loc1 (predef_option loc1) t in - mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct)) - | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct)) - | CtSig loc t_o ctfl -> - let t = - match t_o with - [ <:ctyp<>> -> <:ctyp@loc< _ >> - | t -> t ] - in - let cil = class_sig_item ctfl [] in - mkcty loc (Pcty_signature { - pcsig_self = ctyp t; - pcsig_fields = cil; - pcsig_loc = mkloc loc; - }) - | CtCon loc _ _ _ -> - error loc "invalid virtual class inside a class type" - | CtAnt _ _ | CtEq _ _ _ | CtCol _ _ _ | CtAnd _ _ _ | CtNil _ -> - assert False ] - - and class_info_class_expr ci = - match ci with - [ CeEq _ (CeCon loc vir (IdLid nloc name) params) ce -> - let (loc_params, (params, variance)) = - match params with - [ <:ctyp<>> -> (loc, ([], [])) - | t -> (loc_of_ctyp t, List.split (class_parameters t [])) ] - in - {pci_virt = mkvirtual vir; - pci_params = (params, mkloc loc_params); - pci_name = with_loc name nloc; - pci_expr = class_expr ce; - pci_loc = mkloc loc; - pci_variance = variance} - | ce -> error (loc_of_class_expr ce) "bad class definition" ] - and class_info_class_type ci = - match ci with - [ CtEq _ (CtCon loc vir (IdLid nloc name) params) ct | - CtCol _ (CtCon loc vir (IdLid nloc name) params) ct -> - let (loc_params, (params, variance)) = - match params with - [ <:ctyp<>> -> (loc, ([], [])) - | t -> (loc_of_ctyp t, List.split (class_parameters t [])) ] - in - {pci_virt = mkvirtual vir; - pci_params = (params, mkloc loc_params); - pci_name = with_loc name nloc; - pci_expr = class_type ct; - pci_loc = mkloc loc; - pci_variance = variance} - | ct -> error (loc_of_class_type ct) - "bad class/class type declaration/definition" ] - and class_sig_item c l = - match c with - [ <:class_sig_item<>> -> l - | CgCtr loc t1 t2 -> [mkctf loc (Pctf_cstr (ctyp t1, ctyp t2)) :: l] - | <:class_sig_item< $csg1$; $csg2$ >> -> - class_sig_item csg1 (class_sig_item csg2 l) - | CgInh loc ct -> [mkctf loc (Pctf_inher (class_type ct)) :: l] - | CgMth loc s pf t -> - [mkctf loc (Pctf_meth (s, mkprivate pf, mkpolytype (ctyp t))) :: l] - | CgVal loc s b v t -> - [mkctf loc (Pctf_val (s, mkmutable b, mkvirtual v, ctyp t)) :: l] - | CgVir loc s b t -> - [mkctf loc (Pctf_virt (s, mkprivate b, mkpolytype (ctyp t))) :: l] - | CgAnt _ _ -> assert False ] - and class_expr = - fun - [ CeApp loc _ _ as c -> - let (ce, el) = class_expr_fa [] c in - let el = List.map label_expr el in - mkcl loc (Pcl_apply (class_expr ce) el) - | CeCon loc ViNil id tl -> - mkcl loc - (Pcl_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl []))) - | CeFun loc (PaLab _ lab po) ce -> - mkcl loc - (Pcl_fun lab None (patt_of_lab loc lab po) (class_expr ce)) - | CeFun loc (PaOlbi _ lab p e) ce -> - let lab = paolab lab p in - mkcl loc (Pcl_fun ("?" ^ lab) (Some (expr e)) (patt p) (class_expr ce)) - | CeFun loc (PaOlb _ lab p) ce -> - let lab = paolab lab p in - mkcl loc - (Pcl_fun ("?" ^ lab) None (patt_of_lab loc lab p) (class_expr ce)) - | CeFun loc p ce -> mkcl loc (Pcl_fun "" None (patt p) (class_expr ce)) - | CeLet loc rf bi ce -> - mkcl loc (Pcl_let (mkrf rf) (binding bi []) (class_expr ce)) - | CeStr loc po cfl -> - let p = - match po with - [ <:patt<>> -> <:patt@loc< _ >> - | p -> p ] - in - let cil = class_str_item cfl [] in - mkcl loc (Pcl_structure { - pcstr_pat = patt p; - pcstr_fields = cil; - }) - | CeTyc loc ce ct -> - mkcl loc (Pcl_constraint (class_expr ce) (class_type ct)) - | CeCon loc _ _ _ -> - error loc "invalid virtual class inside a class expression" - | CeAnt _ _ | CeEq _ _ _ | CeAnd _ _ _ | CeNil _ -> assert False ] - and class_str_item c l = - match c with - [ CrNil _ -> l - | CrCtr loc t1 t2 -> [mkcf loc (Pcf_constr (ctyp t1, ctyp t2)) :: l] - | <:class_str_item< $cst1$; $cst2$ >> -> - class_str_item cst1 (class_str_item cst2 l) - | CrInh loc ov ce pb -> - let opb = if pb = "" then None else Some pb in - [mkcf loc (Pcf_inher (override_flag loc ov) (class_expr ce) opb) :: l] - | CrIni loc e -> [mkcf loc (Pcf_init (expr e)) :: l] - | CrMth loc s ov pf e t -> - let t = - match t with - [ <:ctyp<>> -> None - | t -> Some (mkpolytype (ctyp t)) ] in - let e = mkexp loc (Pexp_poly (expr e) t) in - [mkcf loc (Pcf_meth (with_loc s loc, mkprivate pf, override_flag loc ov, e)) :: l] - | CrVal loc s ov mf e -> - [mkcf loc (Pcf_val (with_loc s loc, mkmutable mf, override_flag loc ov, expr e)) :: l] - | CrVir loc s pf t -> - [mkcf loc (Pcf_virt (with_loc s loc, mkprivate pf, mkpolytype (ctyp t))) :: l] - | CrVvr loc s mf t -> - [mkcf loc (Pcf_valvirt (with_loc s loc, mkmutable mf, ctyp t)) :: l] - | CrAnt _ _ -> assert False ]; - - value sig_item ast = sig_item ast []; - value str_item ast = str_item ast []; - - value directive = - fun - [ <:expr<>> -> Pdir_none - | ExStr _ s -> Pdir_string s - | ExInt _ i -> Pdir_int (int_of_string i) - | <:expr< True >> -> Pdir_bool True - | <:expr< False >> -> Pdir_bool False - | e -> Pdir_ident (ident_noloc (ident_of_expr e)) ] - ; - - value phrase = - fun - [ StDir _ d dp -> Ptop_dir d (directive dp) - | si -> Ptop_def (str_item si) ] - ; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli ocaml-4.05.0/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2002-2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -module Make (Camlp4Ast : Sig.Camlp4Ast) : sig - open Camlp4Ast; - - (** {6 Useful functions} *) - - value sig_item : sig_item -> Camlp4_import.Parsetree.signature; - value str_item : str_item -> Camlp4_import.Parsetree.structure; - value phrase : str_item -> Camlp4_import.Parsetree.toplevel_phrase; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Camlp4Ast.mlast ocaml-4.05.0/camlp4/Camlp4/Struct/Camlp4Ast.mlast --- ocaml-4.01.0/camlp4/Camlp4/Struct/Camlp4Ast.mlast 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Camlp4Ast.mlast 1970-01-01 00:00:00.000000000 +0000 @@ -1,544 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Loc : Sig.Loc) -: Sig.Camlp4Ast with module Loc = Loc -= struct - module Loc = Loc; - - module Ast = struct - include Sig.MakeCamlp4Ast Loc; - - value safe_string_escaped s = - if String.length s > 2 && s.[0] = '\\' && s.[1] = '$' then s - else String.escaped s; - end; - - include Ast; - - external loc_of_ctyp : ctyp -> Loc.t = "%field0"; - external loc_of_patt : patt -> Loc.t = "%field0"; - external loc_of_expr : expr -> Loc.t = "%field0"; - external loc_of_module_type : module_type -> Loc.t = "%field0"; - external loc_of_module_expr : module_expr -> Loc.t = "%field0"; - external loc_of_sig_item : sig_item -> Loc.t = "%field0"; - external loc_of_str_item : str_item -> Loc.t = "%field0"; - external loc_of_class_type : class_type -> Loc.t = "%field0"; - external loc_of_class_sig_item : class_sig_item -> Loc.t = "%field0"; - external loc_of_class_expr : class_expr -> Loc.t = "%field0"; - external loc_of_class_str_item : class_str_item -> Loc.t = "%field0"; - external loc_of_with_constr : with_constr -> Loc.t = "%field0"; - external loc_of_binding : binding -> Loc.t = "%field0"; - external loc_of_rec_binding : rec_binding -> Loc.t = "%field0"; - external loc_of_module_binding : module_binding -> Loc.t = "%field0"; - external loc_of_match_case : match_case -> Loc.t = "%field0"; - external loc_of_ident : ident -> Loc.t = "%field0"; - - value ghost = Loc.ghost; - - value rec is_module_longident = - fun - [ <:ident< $_$.$i$ >> -> is_module_longident i - | <:ident< $i1$ $i2$ >> -> - is_module_longident i1 && is_module_longident i2 - | <:ident< $uid:_$ >> -> True - | _ -> False ]; - - value ident_of_expr = - let error () = - invalid_arg "ident_of_expr: this expression is not an identifier" in - let rec self = - fun - [ <:expr@_loc< $e1$ $e2$ >> -> <:ident< $self e1$ $self e2$ >> - | <:expr@_loc< $e1$.$e2$ >> -> <:ident< $self e1$.$self e2$ >> - | <:expr< $lid:_$ >> -> error () - | <:expr< $id:i$ >> -> if is_module_longident i then i else error () - | _ -> error () ] in - fun - [ <:expr< $id:i$ >> -> i - | <:expr< $_$ $_$ >> -> error () - | t -> self t ]; - - value ident_of_ctyp = - let error () = - invalid_arg "ident_of_ctyp: this type is not an identifier" in - let rec self = - fun - [ <:ctyp@_loc< $t1$ $t2$ >> -> <:ident< $self t1$ $self t2$ >> - | <:ctyp< $lid:_$ >> -> error () - | <:ctyp< $id:i$ >> -> if is_module_longident i then i else error () - | _ -> error () ] in - fun - [ <:ctyp< $id:i$ >> -> i - | t -> self t ]; - - value ident_of_patt = - let error () = - invalid_arg "ident_of_patt: this pattern is not an identifier" in - let rec self = - fun - [ <:patt@_loc< $p1$ $p2$ >> -> <:ident< $self p1$ $self p2$ >> - | <:patt< $lid:_$ >> -> error () - | <:patt< $id:i$ >> -> if is_module_longident i then i else error () - | _ -> error () ] in - fun - [ <:patt< $id:i$ >> -> i - | p -> self p ]; - - value rec is_irrefut_patt = - fun - [ <:patt< $lid:_$ >> -> True - | <:patt< () >> -> True - | <:patt< _ >> -> True - | <:patt<>> -> True (* why not *) - | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y - | <:patt< { $p$ } >> -> is_irrefut_patt p - | <:patt< $_$ = $p$ >> -> is_irrefut_patt p - | <:patt< $p1$; $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 - | <:patt< $p1$, $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 - | <:patt< $p1$ | $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 (* could be more fine grained *) - | <:patt< $p1$ $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 - | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p - | <:patt< ($tup:pl$) >> -> is_irrefut_patt pl - | <:patt< ? $_$ >> -> True - | <:patt< ? $_$ : ($p$) >> -> is_irrefut_patt p - | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p - | <:patt< ~ $_$ >> -> True - | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p - | <:patt< lazy $p$ >> -> is_irrefut_patt p - | <:patt< $id:_$ >> -> False (* here one need to know the arity of constructors *) - | <:patt< (module $_$) >> -> True - | <:patt< `$_$ >> | <:patt< $str:_$ >> | <:patt< $_$ .. $_$ >> | - <:patt< $flo:_$ >> | <:patt< $nativeint:_$ >> | <:patt< $int64:_$ >> | - <:patt< $int32:_$ >> | <:patt< $int:_$ >> | <:patt< $chr:_$ >> | - <:patt< #$_$ >> | <:patt< [| $_$ |] >> | <:patt< $anti:_$ >> -> False - ]; - - value rec is_constructor = - fun - [ <:ident< $_$.$i$ >> -> is_constructor i - | <:ident< $uid:_$ >> -> True - | <:ident< $lid:_$ >> | <:ident< $_$ $_$ >> -> False - | <:ident< $anti:_$ >> -> assert False ]; - - value is_patt_constructor = - fun - [ <:patt< $id:i$ >> -> is_constructor i - | <:patt< `$_$ >> -> True - | _ -> False ]; - - value rec is_expr_constructor = - fun - [ <:expr< $id:i$ >> -> is_constructor i - | <:expr< $e1$.$e2$ >> -> is_expr_constructor e1 && is_expr_constructor e2 - | <:expr< `$_$ >> -> True - | _ -> False ]; - - value rec tyOr_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ | $tyOr_of_list ts$ >> ]; - - value rec tyAnd_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ and $tyAnd_of_list ts$ >> ]; - - value rec tySem_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ ; $tySem_of_list ts$ >> ]; - - value rec tyCom_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$, $tyCom_of_list ts$ >> ]; - - value rec tyAmp_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ & $tyAmp_of_list ts$ >> ]; - - value rec tySta_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ * $tySta_of_list ts$ >> ]; - - value rec stSem_of_list = - fun - [ [] -> <:str_item@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_str_item t in <:str_item< $t$ ; $stSem_of_list ts$ >> ]; - - value rec sgSem_of_list = - fun - [ [] -> <:sig_item@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_sig_item t in <:sig_item< $t$ ; $sgSem_of_list ts$ >> ]; - - value rec biAnd_of_list = - fun - [ [] -> <:binding@ghost<>> - | [b] -> b - | [b::bs] -> - let _loc = loc_of_binding b in <:binding< $b$ and $biAnd_of_list bs$ >> ]; - - value rec rbSem_of_list = - fun - [ [] -> <:rec_binding@ghost<>> - | [b] -> b - | [b::bs] -> - let _loc = loc_of_rec_binding b in - <:rec_binding< $b$; $rbSem_of_list bs$ >> ]; - - value rec wcAnd_of_list = - fun - [ [] -> <:with_constr@ghost<>> - | [w] -> w - | [w::ws] -> - let _loc = loc_of_with_constr w in - <:with_constr< $w$ and $wcAnd_of_list ws$ >> ]; - - value rec idAcc_of_list = - fun - [ [] -> assert False - | [i] -> i - | [i::is] -> - let _loc = loc_of_ident i in - <:ident< $i$ . $idAcc_of_list is$ >> ]; - - value rec idApp_of_list = - fun - [ [] -> assert False - | [i] -> i - | [i::is] -> - let _loc = loc_of_ident i in - <:ident< $i$ $idApp_of_list is$ >> ]; - - value rec mcOr_of_list = - fun - [ [] -> <:match_case@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_match_case x in - <:match_case< $x$ | $mcOr_of_list xs$ >> ]; - - value rec mbAnd_of_list = - fun - [ [] -> <:module_binding@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_module_binding x in - <:module_binding< $x$ and $mbAnd_of_list xs$ >> ]; - - value rec meApp_of_list = - fun - [ [] -> assert False - | [x] -> x - | [x::xs] -> - let _loc = loc_of_module_expr x in - <:module_expr< $x$ $meApp_of_list xs$ >> ]; - - value rec ceAnd_of_list = - fun - [ [] -> <:class_expr@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_class_expr x in - <:class_expr< $x$ and $ceAnd_of_list xs$ >> ]; - - value rec ctAnd_of_list = - fun - [ [] -> <:class_type@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_class_type x in - <:class_type< $x$ and $ctAnd_of_list xs$ >> ]; - - value rec cgSem_of_list = - fun - [ [] -> <:class_sig_item@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_class_sig_item x in - <:class_sig_item< $x$; $cgSem_of_list xs$ >> ]; - - value rec crSem_of_list = - fun - [ [] -> <:class_str_item@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_class_str_item x in - <:class_str_item< $x$; $crSem_of_list xs$ >> ]; - - value rec paSem_of_list = - fun - [ [] -> <:patt@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_patt x in - <:patt< $x$; $paSem_of_list xs$ >> ]; - - value rec paCom_of_list = - fun - [ [] -> <:patt@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_patt x in - <:patt< $x$, $paCom_of_list xs$ >> ]; - - value rec exSem_of_list = - fun - [ [] -> <:expr@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_expr x in - <:expr< $x$; $exSem_of_list xs$ >> ]; - - value rec exCom_of_list = - fun - [ [] -> <:expr@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_expr x in - <:expr< $x$, $exCom_of_list xs$ >> ]; - - value ty_of_stl = - fun - [ (_loc, s, []) -> <:ctyp< $uid:s$ >> - | (_loc, s, tl) -> <:ctyp< $uid:s$ of $tyAnd_of_list tl$ >> ]; - - value ty_of_sbt = - fun - [ (_loc, s, True, t) -> <:ctyp< $lid:s$ : mutable $t$ >> - | (_loc, s, False, t) -> <:ctyp< $lid:s$ : $t$ >> ]; - - value bi_of_pe (p, e) = let _loc = loc_of_patt p in <:binding< $p$ = $e$ >>; - value sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l); - value record_type_of_list l = tySem_of_list (List.map ty_of_sbt l); - value binding_of_pel l = biAnd_of_list (List.map bi_of_pe l); - - value rec pel_of_binding = - fun - [ <:binding< $b1$ and $b2$ >> -> pel_of_binding b1 @ pel_of_binding b2 - | <:binding< $p$ = $e$ >> -> [(p, e)] - | _ -> assert False ]; - - value rec list_of_binding x acc = - match x with - [ <:binding< $b1$ and $b2$ >> -> - list_of_binding b1 (list_of_binding b2 acc) - | t -> [t :: acc] ]; - - value rec list_of_rec_binding x acc = - match x with - [ <:rec_binding< $b1$; $b2$ >> -> - list_of_rec_binding b1 (list_of_rec_binding b2 acc) - | t -> [t :: acc] ]; - - value rec list_of_with_constr x acc = - match x with - [ <:with_constr< $w1$ and $w2$ >> -> - list_of_with_constr w1 (list_of_with_constr w2 acc) - | t -> [t :: acc] ]; - - value rec list_of_ctyp x acc = - match x with - [ <:ctyp<>> -> acc - | <:ctyp< $x$ & $y$ >> | <:ctyp< $x$, $y$ >> | - <:ctyp< $x$ * $y$ >> | <:ctyp< $x$; $y$ >> | - <:ctyp< $x$ and $y$ >> | <:ctyp< $x$ | $y$ >> -> - list_of_ctyp x (list_of_ctyp y acc) - | x -> [x :: acc] ]; - - value rec list_of_patt x acc = - match x with - [ <:patt<>> -> acc - | <:patt< $x$, $y$ >> | <:patt< $x$; $y$ >> -> - list_of_patt x (list_of_patt y acc) - | x -> [x :: acc] ]; - - value rec list_of_expr x acc = - match x with - [ <:expr<>> -> acc - | <:expr< $x$, $y$ >> | <:expr< $x$; $y$ >> -> - list_of_expr x (list_of_expr y acc) - | x -> [x :: acc] ]; - - value rec list_of_str_item x acc = - match x with - [ <:str_item<>> -> acc - | <:str_item< $x$; $y$ >> -> - list_of_str_item x (list_of_str_item y acc) - | x -> [x :: acc] ]; - - value rec list_of_sig_item x acc = - match x with - [ <:sig_item<>> -> acc - | <:sig_item< $x$; $y$ >> -> - list_of_sig_item x (list_of_sig_item y acc) - | x -> [x :: acc] ]; - - value rec list_of_class_sig_item x acc = - match x with - [ <:class_sig_item<>> -> acc - | <:class_sig_item< $x$; $y$ >> -> - list_of_class_sig_item x (list_of_class_sig_item y acc) - | x -> [x :: acc] ]; - - value rec list_of_class_str_item x acc = - match x with - [ <:class_str_item<>> -> acc - | <:class_str_item< $x$; $y$ >> -> - list_of_class_str_item x (list_of_class_str_item y acc) - | x -> [x :: acc] ]; - - value rec list_of_class_type x acc = - match x with - [ <:class_type< $x$ and $y$ >> -> - list_of_class_type x (list_of_class_type y acc) - | x -> [x :: acc] ]; - - value rec list_of_class_expr x acc = - match x with - [ <:class_expr< $x$ and $y$ >> -> - list_of_class_expr x (list_of_class_expr y acc) - | x -> [x :: acc] ]; - - value rec list_of_module_expr x acc = - match x with - [ <:module_expr< $x$ $y$ >> -> - list_of_module_expr x (list_of_module_expr y acc) - | x -> [x :: acc] ]; - - value rec list_of_match_case x acc = - match x with - [ <:match_case<>> -> acc - | <:match_case< $x$ | $y$ >> -> - list_of_match_case x (list_of_match_case y acc) - | x -> [x :: acc] ]; - - value rec list_of_ident x acc = - match x with - [ <:ident< $x$ . $y$ >> | <:ident< $x$ $y$ >> -> - list_of_ident x (list_of_ident y acc) - | x -> [x :: acc] ]; - - value rec list_of_module_binding x acc = - match x with - [ <:module_binding< $x$ and $y$ >> -> - list_of_module_binding x (list_of_module_binding y acc) - | x -> [x :: acc] ]; - - module Camlp4Trash = struct - INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; - end; - - module Meta = struct - - module type META_LOC = sig - (** The first location is where to put the returned pattern. - Generally it's _loc to match with <:patt< ... >> quotations. - The second location is the one to treat. *) - value meta_loc_patt : Loc.t -> Loc.t -> Ast.patt; - (** The first location is where to put the returned expression. - Generally it's _loc to match with <:expr< ... >> quotations. - The second location is the one to treat. *) - value meta_loc_expr : Loc.t -> Loc.t -> Ast.expr; - end; - - module MetaLoc = struct - value meta_loc_patt _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in - <:patt< Loc.of_tuple - ($`str:a$, $`int:b$, $`int:c$, $`int:d$, - $`int:e$, $`int:f$, $`int:g$, - $if h then <:patt< True >> else <:patt< False >> $) >>; - value meta_loc_expr _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in - <:expr< Loc.of_tuple - ($`str:a$, $`int:b$, $`int:c$, $`int:d$, - $`int:e$, $`int:f$, $`int:g$, - $if h then <:expr< True >> else <:expr< False >> $) >>; - end; - - module MetaGhostLoc = struct - value meta_loc_patt _loc _ = <:patt< Loc.ghost >>; - value meta_loc_expr _loc _ = <:expr< Loc.ghost >>; - end; - - module MetaLocVar = struct - value meta_loc_patt _loc _ = <:patt< $lid:Loc.name.val$ >>; - value meta_loc_expr _loc _ = <:expr< $lid:Loc.name.val$ >>; - end; - - module Make (MetaLoc : META_LOC) = struct - open MetaLoc; - - value meta_loc = meta_loc_expr; - module Expr = Camlp4Filters.MetaGeneratorExpr Ast; - value meta_loc = meta_loc_patt; - module Patt = Camlp4Filters.MetaGeneratorPatt Ast; - end; - - end; - - class map = Camlp4MapGenerator.generated; - - class fold = Camlp4FoldGenerator.generated; - - value map_expr f = object - inherit map as super; - method expr x = f (super#expr x); - end; - value map_patt f = object - inherit map as super; - method patt x = f (super#patt x); - end; - value map_ctyp f = object - inherit map as super; - method ctyp x = f (super#ctyp x); - end; - value map_str_item f = object - inherit map as super; - method str_item x = f (super#str_item x); - end; - value map_sig_item f = object - inherit map as super; - method sig_item x = f (super#sig_item x); - end; - value map_loc f = object - inherit map as super; - method loc x = f (super#loc x); - end; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/CleanAst.ml ocaml-4.05.0/camlp4/Camlp4/Struct/CleanAst.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/CleanAst.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/CleanAst.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,145 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -(** This module is suppose to contain nils elimination. *) -module Make (Ast : Sig.Camlp4Ast) = struct - - class clean_ast = object - - inherit Ast.map as super; - - method with_constr wc = - match super#with_constr wc with - [ <:with_constr< $ <:with_constr<>> $ and $wc$ >> | - <:with_constr< $wc$ and $ <:with_constr<>> $ >> -> wc - | wc -> wc ]; - - method expr e = - match super#expr e with - [ <:expr< let $rec:_$ $ <:binding<>> $ in $e$ >> | - <:expr< { ($e$) with $ <:rec_binding<>> $ } >> | - <:expr< $ <:expr<>> $, $e$ >> | - <:expr< $e$, $ <:expr<>> $ >> | - <:expr< $ <:expr<>> $; $e$ >> | - <:expr< $e$; $ <:expr<>> $ >> -> e - | e -> e ]; - - method patt p = - match super#patt p with - [ <:patt< ( $p$ as $ <:patt<>> $ ) >> | - <:patt< $ <:patt<>> $ | $p$ >> | - <:patt< $p$ | $ <:patt<>> $ >> | - <:patt< $ <:patt<>> $, $p$ >> | - <:patt< $p$, $ <:patt<>> $ >> | - <:patt< $ <:patt<>> $; $p$ >> | - <:patt< $p$; $ <:patt<>> $ >> -> p - | p -> p ]; - - method match_case mc = - match super#match_case mc with - [ <:match_case< $ <:match_case<>> $ | $mc$ >> | - <:match_case< $mc$ | $ <:match_case<>> $ >> -> mc - | mc -> mc ]; - - method binding bi = - match super#binding bi with - [ <:binding< $ <:binding<>> $ and $bi$ >> | - <:binding< $bi$ and $ <:binding<>> $ >> -> bi - | bi -> bi ]; - - method rec_binding rb = - match super#rec_binding rb with - [ <:rec_binding< $ <:rec_binding<>> $ ; $bi$ >> | - <:rec_binding< $bi$ ; $ <:rec_binding<>> $ >> -> bi - | bi -> bi ]; - - method module_binding mb = - match super#module_binding mb with - [ <:module_binding< $ <:module_binding<>> $ and $mb$ >> | - <:module_binding< $mb$ and $ <:module_binding<>> $ >> -> mb - | mb -> mb ]; - - method ctyp t = - match super#ctyp t with - [ <:ctyp< ! $ <:ctyp<>> $ . $t$ >> | - <:ctyp< $ <:ctyp<>> $ as $t$ >> | - <:ctyp< $t$ as $ <:ctyp<>> $ >> | - <:ctyp< $t$ -> $ <:ctyp<>> $ >> | - <:ctyp< $ <:ctyp<>> $ -> $t$ >> | - <:ctyp< $ <:ctyp<>> $ | $t$ >> | - <:ctyp< $t$ | $ <:ctyp<>> $ >> | - <:ctyp< $t$ of $ <:ctyp<>> $ >> | - <:ctyp< $ <:ctyp<>> $ and $t$ >> | - <:ctyp< $t$ and $ <:ctyp<>> $ >> | - <:ctyp< $t$; $ <:ctyp<>> $ >> | - <:ctyp< $ <:ctyp<>> $; $t$ >> | - <:ctyp< $ <:ctyp<>> $, $t$ >> | - <:ctyp< $t$, $ <:ctyp<>> $ >> | - <:ctyp< $t$ & $ <:ctyp<>> $ >> | - <:ctyp< $ <:ctyp<>> $ & $t$ >> | - <:ctyp< $ <:ctyp<>> $ * $t$ >> | - <:ctyp< $t$ * $ <:ctyp<>> $ >> -> t - | t -> t ]; - - method sig_item sg = - match super#sig_item sg with - [ <:sig_item< $ <:sig_item<>> $; $sg$ >> | - <:sig_item< $sg$; $ <:sig_item<>> $ >> -> sg - | <:sig_item@loc< type $ <:ctyp<>> $ >> -> <:sig_item@loc<>> - | sg -> sg ]; - - method str_item st = - match super#str_item st with - [ <:str_item< $ <:str_item<>> $; $st$ >> | - <:str_item< $st$; $ <:str_item<>> $ >> -> st - | <:str_item@loc< type $ <:ctyp<>> $ >> -> <:str_item@loc<>> - | <:str_item@loc< value $rec:_$ $ <:binding<>> $ >> -> <:str_item@loc<>> - | st -> st ]; - - method module_type mt = - match super#module_type mt with - [ <:module_type< $mt$ with $ <:with_constr<>> $ >> -> mt - | mt -> mt ]; - - method class_expr ce = - match super#class_expr ce with - [ <:class_expr< $ <:class_expr<>> $ and $ce$ >> | - <:class_expr< $ce$ and $ <:class_expr<>> $ >> -> ce - | ce -> ce ]; - - method class_type ct = - match super#class_type ct with - [ <:class_type< $ <:class_type<>> $ and $ct$ >> | - <:class_type< $ct$ and $ <:class_type<>> $ >> -> ct - | ct -> ct ]; - - method class_sig_item csg = - match super#class_sig_item csg with - [ <:class_sig_item< $ <:class_sig_item<>> $; $csg$ >> | - <:class_sig_item< $csg$; $ <:class_sig_item<>> $ >> -> csg - | csg -> csg ]; - - method class_str_item cst = - match super#class_str_item cst with - [ <:class_str_item< $ <:class_str_item<>> $; $cst$ >> | - <:class_str_item< $cst$; $ <:class_str_item<>> $ >> -> cst - | cst -> cst ]; - - end; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/CommentFilter.ml ocaml-4.05.0/camlp4/Camlp4/Struct/CommentFilter.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/CommentFilter.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/CommentFilter.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Token : Sig.Camlp4Token) = struct - open Token; - - type t = (Stream.t (string * Loc.t) * Queue.t (string * Loc.t)); - - value mk () = - let q = Queue.create () in - let f _ = - debug comments "take...@\n" in - try Some (Queue.take q) with [ Queue.Empty -> None ] - in (Stream.from f, q); - - value filter (_, q) = - let rec self = - parser - [ [: ` (Sig.COMMENT x, loc); xs :] -> - do { Queue.add (x, loc) q; - debug comments "add: %S at %a@\n" x Loc.dump loc in - self xs } - | [: ` x; xs :] -> - (* debug comments "Found %a at %a@." Token.print x Loc.dump loc in *) - [: ` x; self xs :] - | [: :] -> [: :] ] - in self; - - value take_list (_, q) = - let rec self accu = - if Queue.is_empty q then accu else self [Queue.take q :: accu] - in self []; - - value take_stream = fst; - - value define token_fiter comments_strm = - debug comments "Define a comment filter@\n" in - Token.Filter.define_filter token_fiter - (fun previous strm -> previous (filter comments_strm strm)); - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/CommentFilter.mli ocaml-4.05.0/camlp4/Camlp4/Struct/CommentFilter.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/CommentFilter.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/CommentFilter.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Token : Sig.Camlp4Token) : sig - open Token; - - type t; - - value mk : unit -> t; - - value define : Token.Filter.t -> t -> unit; - - value filter : t -> Stream.t (Token.t * Loc.t) -> Stream.t (Token.t * Loc.t); - - value take_list : t -> list (string * Loc.t); - - value take_stream : t -> Stream.t (string * Loc.t); -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/DynAst.ml ocaml-4.05.0/camlp4/Camlp4/Struct/DynAst.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/DynAst.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/DynAst.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,91 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2007 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Ast) : Sig.DynAst with module Ast = Ast = struct - module Ast = Ast; - type tag 'a = - [ Tag_ctyp - | Tag_patt - | Tag_expr - | Tag_module_type - | Tag_sig_item - | Tag_with_constr - | Tag_module_expr - | Tag_str_item - | Tag_class_type - | Tag_class_sig_item - | Tag_class_expr - | Tag_class_str_item - | Tag_match_case - | Tag_ident - | Tag_binding - | Tag_rec_binding - | Tag_module_binding ]; - - value string_of_tag = - fun - [ Tag_ctyp -> "ctyp" - | Tag_patt -> "patt" - | Tag_expr -> "expr" - | Tag_module_type -> "module_type" - | Tag_sig_item -> "sig_item" - | Tag_with_constr -> "with_constr" - | Tag_module_expr -> "module_expr" - | Tag_str_item -> "str_item" - | Tag_class_type -> "class_type" - | Tag_class_sig_item -> "class_sig_item" - | Tag_class_expr -> "class_expr" - | Tag_class_str_item -> "class_str_item" - | Tag_match_case -> "match_case" - | Tag_ident -> "ident" - | Tag_binding -> "binding" - | Tag_rec_binding -> "rec_binding" - | Tag_module_binding -> "module_binding" ]; - - value ctyp_tag = Tag_ctyp; - value patt_tag = Tag_patt; - value expr_tag = Tag_expr; - value module_type_tag = Tag_module_type; - value sig_item_tag = Tag_sig_item; - value with_constr_tag = Tag_with_constr; - value module_expr_tag = Tag_module_expr; - value str_item_tag = Tag_str_item; - value class_type_tag = Tag_class_type; - value class_sig_item_tag = Tag_class_sig_item; - value class_expr_tag = Tag_class_expr; - value class_str_item_tag = Tag_class_str_item; - value match_case_tag = Tag_match_case; - value ident_tag = Tag_ident; - value binding_tag = Tag_binding; - value rec_binding_tag = Tag_rec_binding; - value module_binding_tag = Tag_module_binding; - - type dyn; - external dyn_tag : tag 'a -> tag dyn = "%identity"; - - module Pack(X : sig type t 'a; end) = struct - (* These Obj.* hacks should be avoided with GADTs *) - type pack = (tag dyn * Obj.t); - exception Pack_error; - value pack tag v = (dyn_tag tag, Obj.repr v); - value unpack (tag : tag 'a) (tag', obj) = - if dyn_tag tag = tag' then (Obj.obj obj : X.t 'a) else raise Pack_error; - value print_tag f (tag, _) = Format.pp_print_string f (string_of_tag tag); - end; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/DynLoader.ml ocaml-4.05.0/camlp4/Camlp4/Struct/DynLoader.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/DynLoader.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/DynLoader.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,84 +0,0 @@ -(* camlp4r pa_macro.cmo *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2001-2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - - -type t = Queue.t string; - -exception Error of string and string; - -value include_dir x y = Queue.add y x; - -value fold_load_path x f acc = Queue.fold (fun x y -> f y x) acc x; - -value mk ?(ocaml_stdlib = True) ?(camlp4_stdlib = True) () = - let q = Queue.create () in do { - if ocaml_stdlib then include_dir q Camlp4_config.ocaml_standard_library else (); - if camlp4_stdlib then do { - include_dir q Camlp4_config.camlp4_standard_library; - include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Parsers"); - include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Printers"); - include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Filters"); - } else (); - include_dir q "."; - q -}; - -(* Load files in core *) - -value find_in_path x name = - if not (Filename.is_implicit name) then - if Sys.file_exists name then name else raise Not_found - else - let res = - fold_load_path x - (fun dir -> - fun - [ None -> - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then Some fullname else None - | x -> x ]) None - in match res with [ None -> raise Not_found | Some x -> x ]; - -value load = - let _initialized = ref False in - fun _path file -> - do { - if not _initialized.val then - try do { - Dynlink.init (); - Dynlink.allow_unsafe_modules True; - _initialized.val := True - } - with - [ Dynlink.Error e -> - raise (Error "Camlp4's dynamic loader initialization" (Dynlink.error_message e)) ] - else (); - let fname = - try find_in_path _path file with - [ Not_found -> raise (Error file "file not found in path") ] - in - try Dynlink.loadfile fname with - [ Dynlink.Error e -> raise (Error fname (Dynlink.error_message e)) ] - }; - - -value is_native = Dynlink.is_native; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/DynLoader.mli ocaml-4.05.0/camlp4/Camlp4/Struct/DynLoader.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/DynLoader.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/DynLoader.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -include Sig.DynLoader; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyError.ml ocaml-4.05.0/camlp4/Camlp4/Struct/EmptyError.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyError.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/EmptyError.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -type t = unit; -exception E of t; -value print _ = assert False; -value to_string _ = assert False; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyError.mli ocaml-4.05.0/camlp4/Camlp4/Struct/EmptyError.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyError.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/EmptyError.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -include Sig.Error; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyPrinter.ml ocaml-4.05.0/camlp4/Camlp4/Struct/EmptyPrinter.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyPrinter.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/EmptyPrinter.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Ast) = struct - value print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer"; - value print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer"; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyPrinter.mli ocaml-4.05.0/camlp4/Camlp4/Struct/EmptyPrinter.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyPrinter.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/EmptyPrinter.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006-2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Ast) : (Sig.Printer Ast).S; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/FreeVars.ml ocaml-4.05.0/camlp4/Camlp4/Struct/FreeVars.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/FreeVars.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/FreeVars.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,127 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Camlp4Ast) = struct - - module S = Set.Make String; - - class c_fold_pattern_vars ['accu] f init = - object - inherit Ast.fold as super; - value acc = init; - method acc : 'accu = acc; - method patt = - fun - [ <:patt< $lid:s$ >> | <:patt< ~ $s$ >> | <:patt< ? $s$ >> -> - {< acc = f s acc >} - | p -> super#patt p ]; - end; - - value fold_pattern_vars f p init = ((new c_fold_pattern_vars f init)#patt p)#acc; - - value rec fold_binding_vars f bi acc = - match bi with - [ <:binding< $bi1$ and $bi2$ >> -> - fold_binding_vars f bi1 (fold_binding_vars f bi2 acc) - | <:binding< $p$ = $_$ >> -> fold_pattern_vars f p acc - | <:binding<>> -> acc - | <:binding< $anti:_$ >> -> assert False ]; - - class fold_free_vars ['accu] (f : string -> 'accu -> 'accu) ?(env_init = S.empty) free_init = - object (o) - inherit Ast.fold as super; - value free : 'accu = free_init; - value env : S.t = env_init; - - method free = free; - method set_env env = {< env = env >}; - method add_atom s = {< env = S.add s env >}; - method add_patt p = {< env = fold_pattern_vars S.add p env >}; - method add_binding bi = {< env = fold_binding_vars S.add bi env >}; - - method expr = - fun - [ <:expr< $lid:s$ >> | <:expr< ~ $s$ >> | <:expr< ? $s$ >> -> - if S.mem s env then o else {< free = f s free >} - - | <:expr< let $bi$ in $e$ >> -> - (((o#add_binding bi)#expr e)#set_env env)#binding bi - - | <:expr< let rec $bi$ in $e$ >> -> - (((o#add_binding bi)#expr e)#binding bi)#set_env env - - | <:expr< for $s$ = $e1$ $to:_$ $e2$ do { $e3$ } >> -> - ((((o#expr e1)#expr e2)#add_atom s)#expr e3)#set_env env - - | <:expr< $id:_$ >> | <:expr< new $_$ >> -> o - - | <:expr< object ($p$) $cst$ end >> -> - ((o#add_patt p)#class_str_item cst)#set_env env - - | e -> super#expr e ]; - - method match_case = - fun - [ <:match_case< $p$ when $e1$ -> $e2$ >> -> - (((o#add_patt p)#expr e1)#expr e2)#set_env env - | m -> super#match_case m ]; - - method str_item = - fun - [ <:str_item< external $s$ : $t$ = $_$ >> -> - (o#ctyp t)#add_atom s - | <:str_item< value $bi$ >> -> - (o#binding bi)#add_binding bi - | <:str_item< value rec $bi$ >> -> - (o#add_binding bi)#binding bi - | st -> super#str_item st ]; - - method class_expr = - fun - [ <:class_expr< fun $p$ -> $ce$ >> -> - ((o#add_patt p)#class_expr ce)#set_env env - | <:class_expr< let $bi$ in $ce$ >> -> - (((o#binding bi)#add_binding bi)#class_expr ce)#set_env env - | <:class_expr< let rec $bi$ in $ce$ >> -> - (((o#add_binding bi)#binding bi)#class_expr ce)#set_env env - | <:class_expr< object ($p$) $cst$ end >> -> - ((o#add_patt p)#class_str_item cst)#set_env env - | ce -> super#class_expr ce ]; - - method class_str_item = - fun - [ <:class_str_item< inherit $override:_$ $_$ >> as cst -> super#class_str_item cst - | <:class_str_item< inherit $override:_$ $ce$ as $s$ >> -> - (o#class_expr ce)#add_atom s - | <:class_str_item< value $override:_$ $mutable:_$ $s$ = $e$ >> -> - (o#expr e)#add_atom s - | <:class_str_item< value virtual $mutable:_$ $s$ : $t$ >> -> - (o#ctyp t)#add_atom s - | cst -> super#class_str_item cst ]; - - method module_expr = fun - [ <:module_expr< struct $st$ end >> -> - (o#str_item st)#set_env env - | me -> super#module_expr me ]; - - end; - - value free_vars env_init e = - let fold = new fold_free_vars S.add ~env_init S.empty in (fold#expr e)#free; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/FreeVars.mli ocaml-4.05.0/camlp4/Camlp4/Struct/FreeVars.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/FreeVars.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/FreeVars.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,48 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Camlp4Ast) : sig - module S : Set.S with type elt = string; - - value fold_binding_vars : (string -> 'accu -> 'accu) -> Ast.binding -> 'accu -> 'accu; - - class c_fold_pattern_vars ['accu] : [string -> 'accu -> 'accu] -> ['accu] -> - object - inherit Ast.fold; - value acc : 'accu; - method acc : 'accu; - end; - - value fold_pattern_vars : (string -> 'accu -> 'accu) -> Ast.patt -> 'accu -> 'accu; - - class fold_free_vars ['accu] : [string -> 'accu -> 'accu] -> [?env_init:S.t] -> ['accu] -> - object ('self_type) - inherit Ast.fold; - value free : 'accu; - value env : S.t; - method free : 'accu; - method set_env : S.t -> 'self_type; - method add_atom : string -> 'self_type; - method add_patt : Ast.patt -> 'self_type; - method add_binding : Ast.binding -> 'self_type; - end; - - value free_vars : S.t -> Ast.expr -> S.t; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Delete.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Delete.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Delete.ml 2012-10-25 12:28:15.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Delete.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,187 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -exception Rule_not_found of (string * string); - -let () = - Printexc.register_printer - (fun - [ Rule_not_found (symbols, entry) -> - let msg = Printf.sprintf "rule %S cannot be found in entry\n%s" symbols entry in - Some msg - | _ -> None ]) in () -; - -module Make (Structure : Structure.S) = struct - module Tools = Tools.Make Structure; - module Parser = Parser.Make Structure; - module Print = Print.Make Structure; - open Structure; - -value raise_rule_not_found entry symbols = - let to_string f x = - let buff = Buffer.create 128 in - let ppf = Format.formatter_of_buffer buff in - do { - f ppf x; - Format.pp_print_flush ppf (); - Buffer.contents buff - } in - let entry = to_string Print.entry entry in - let symbols = to_string Print.print_rule symbols in - raise (Rule_not_found (symbols, entry)) -; - -(* Deleting a rule *) - -(* [delete_rule_in_tree] returns - [Some (dsl, t)] if success - [dsl] = - Some (list of deleted nodes) if branch deleted - None if action replaced by previous version of action - [t] = remaining tree - [None] if failure *) - -value delete_rule_in_tree entry = - let rec delete_in_tree symbols tree = - match (symbols, tree) with - [ ([s :: sl], Node n) -> - if Tools.logically_eq_symbols entry s n.node then delete_son sl n - else - match delete_in_tree symbols n.brother with - [ Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None ] - | ([_ :: _], _) -> None - | ([], Node n) -> - match delete_in_tree [] n.brother with - [ Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None ] - | ([], DeadEnd) -> None - | ([], LocAct _ []) -> Some (Some [], DeadEnd) - | ([], LocAct _ [action :: list]) -> Some (None, LocAct action list) ] - and delete_son sl n = - match delete_in_tree sl n.son with - [ Some (Some dsl, DeadEnd) -> Some (Some [n.node :: dsl], n.brother) - | Some (Some dsl, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (Some [n.node :: dsl], t) - | Some (None, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (None, t) - | None -> None ] - in - delete_in_tree -; -value rec decr_keyw_use gram = - fun - [ Skeyword kwd -> removing gram kwd - | Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl - | Slist0 s | Slist1 s | Sopt s | Stry s -> decr_keyw_use gram s - | Slist0sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 } - | Slist1sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 } - | Stree t -> decr_keyw_use_in_tree gram t - | Sself | Snext | Snterm _ | Snterml _ _ | Stoken _ -> () ] -and decr_keyw_use_in_tree gram = - fun - [ DeadEnd | LocAct _ _ -> () - | Node n -> - do { - decr_keyw_use gram n.node; - decr_keyw_use_in_tree gram n.son; - decr_keyw_use_in_tree gram n.brother - } ] -; -value rec delete_rule_in_suffix entry symbols = - fun - [ [lev :: levs] -> - match delete_rule_in_tree entry symbols lev.lsuffix with - [ Some (dsl, t) -> - do { - match dsl with - [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () ]; - match t with - [ DeadEnd when lev.lprefix == DeadEnd -> levs - | _ -> - let lev = - {assoc = lev.assoc; lname = lev.lname; lsuffix = t; - lprefix = lev.lprefix} - in - [lev :: levs] ] - } - | None -> - let levs = delete_rule_in_suffix entry symbols levs in - [lev :: levs] ] - | [] -> raise_rule_not_found entry symbols ] -; - -value rec delete_rule_in_prefix entry symbols = - fun - [ [lev :: levs] -> - match delete_rule_in_tree entry symbols lev.lprefix with - [ Some (dsl, t) -> - do { - match dsl with - [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () ]; - match t with - [ DeadEnd when lev.lsuffix == DeadEnd -> levs - | _ -> - let lev = - {assoc = lev.assoc; lname = lev.lname; - lsuffix = lev.lsuffix; lprefix = t} - in - [lev :: levs] ] - } - | None -> - let levs = delete_rule_in_prefix entry symbols levs in - [lev :: levs] ] - | [] -> raise_rule_not_found entry symbols ] -; - -value rec delete_rule_in_level_list entry symbols levs = - match symbols with - [ [Sself :: symbols] -> delete_rule_in_suffix entry symbols levs - | [Snterm e :: symbols] when e == entry -> - delete_rule_in_suffix entry symbols levs - | _ -> delete_rule_in_prefix entry symbols levs ] -; - - -value delete_rule entry sl = - match entry.edesc with - [ Dlevels levs -> - let levs = delete_rule_in_level_list entry sl levs in - do { - entry.edesc := Dlevels levs; - entry.estart := - fun lev strm -> - let f = Parser.start_parser_of_entry entry in - do { entry.estart := f; f lev strm }; - entry.econtinue := - fun lev bp a strm -> - let f = Parser.continue_parser_of_entry entry in - do { entry.econtinue := f; f lev bp a strm } - } - | Dparser _ -> () ] -; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Dynamic.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Dynamic.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Dynamic.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Dynamic.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,73 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Lexer : Sig.Lexer) -: Sig.Grammar.Dynamic with module Loc = Lexer.Loc - and module Token = Lexer.Token -= struct - module Structure = Structure.Make Lexer; - module Delete = Delete.Make Structure; - module Insert = Insert.Make Structure; - module Entry = Entry.Make Structure; - module Fold = Fold.Make Structure; - module Tools = Tools.Make Structure; - include Structure; - - value mk () = - let gkeywords = Hashtbl.create 301 in - { - gkeywords = gkeywords; - gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); - glexer = Lexer.mk (); - warning_verbose = ref True; (* FIXME *) - error_verbose = Camlp4_config.verbose - }; - - value get_filter g = g.gfilter; - - value lex g loc cs = g.glexer loc cs; - - value lex_string g loc str = lex g loc (Stream.of_string str); - - value filter g ts = Tools.keep_prev_loc (Token.Filter.filter g.gfilter ts); - - value parse_tokens_after_filter entry ts = Entry.parse_tokens_after_filter entry ts; - - value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry.egram ts); - - value parse entry loc cs = parse_tokens_before_filter entry (lex entry.egram loc cs); - - value parse_string entry loc str = - parse_tokens_before_filter entry (lex_string entry.egram loc str); - - value delete_rule = Delete.delete_rule; - - value srules e rl = - let t = - List.fold_left - (fun tree (symbols, action) -> Insert.insert_tree e symbols action tree) - DeadEnd rl - in - Stree t; - value sfold0 = Fold.sfold0; - value sfold1 = Fold.sfold1; - value sfold0sep = Fold.sfold0sep; - (* value sfold1sep = Fold.sfold1sep; *) - - value extend = Insert.extend; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Entry.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Entry.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Entry.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Entry.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,92 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - module Dump = Print.MakeDump Structure; - module Print = Print.Make Structure; - module Tools = Tools.Make Structure; - open Format; - open Structure; - open Tools; - - type t 'a = internal_entry; - - value name e = e.ename; - - value print ppf e = fprintf ppf "%a@\n" Print.entry e; - value dump ppf e = fprintf ppf "%a@\n" Dump.entry e; - - (* value find e s = Find.entry e s; *) - - value mk g n = - { egram = g; - ename = n; - estart = empty_entry n; - econtinue _ _ _ = parser []; - edesc = Dlevels [] }; - - value action_parse entry ts : Action.t = - try entry.estart 0 ts with - [ Stream.Failure -> - Loc.raise (get_prev_loc ts) - (Stream.Error ("illegal begin of " ^ entry.ename)) - | Loc.Exc_located _ _ as exc -> raise exc - | exc -> Loc.raise (get_prev_loc ts) exc ]; - - value lex entry loc cs = entry.egram.glexer loc cs; - - value lex_string entry loc str = lex entry loc (Stream.of_string str); - - value filter entry ts = - keep_prev_loc (Token.Filter.filter (get_filter entry.egram) ts); - - value parse_tokens_after_filter entry ts = Action.get (action_parse entry ts); - - value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry ts); - - value parse entry loc cs = parse_tokens_before_filter entry (lex entry loc cs); - - value parse_string entry loc str = - parse_tokens_before_filter entry (lex_string entry loc str); - - value of_parser g n (p : Stream.t (Token.t * token_info) -> 'a) : t 'a = - let f ts = Action.mk (p ts) in - { egram = g; - ename = n; - estart _ = f; - econtinue _ _ _ = parser []; - edesc = Dparser f }; - - value setup_parser e (p : Stream.t (Token.t * token_info) -> 'a) = - let f ts = Action.mk (p ts) in do { - e.estart := fun _ -> f; - e.econtinue := fun _ _ _ -> parser []; - e.edesc := Dparser f - }; - - value clear e = - do { - e.estart := fun _ -> parser []; - e.econtinue := fun _ _ _ -> parser []; - e.edesc := Dlevels [] - }; - - value obj x = x; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Failed.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Failed.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Failed.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Failed.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,132 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - module Tools = Tools.Make Structure; - module Search = Search.Make Structure; - module Print = Print.Make Structure; - open Structure; - open Format; - -value rec name_of_symbol entry = - fun - [ Snterm e -> "[" ^ e.ename ^ "]" - | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]" - | Sself | Snext -> "[" ^ entry.ename ^ "]" - | Stoken (_, descr) -> descr - | Skeyword kwd -> "\"" ^ kwd ^ "\"" - | _ -> "???" ] -; - - -value rec name_of_symbol_failed entry = - fun - [ Slist0 s | Slist0sep s _ | - Slist1 s | Slist1sep s _ | - Sopt s | Stry s -> name_of_symbol_failed entry s - | Stree t -> name_of_tree_failed entry t - | s -> name_of_symbol entry s ] -and name_of_tree_failed entry = - fun - [ Node {node = s; brother = bro; son = son} -> - let tokl = - match s with - [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son - | _ -> None ] - in - match tokl with - [ None -> - let txt = name_of_symbol_failed entry s in - let txt = - match (s, son) with - [ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son - | _ -> txt ] - in - let txt = - match bro with - [ DeadEnd | LocAct _ _ -> txt - | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro ] - in - txt - | Some (tokl, _, _) -> - List.fold_left - (fun s tok -> - (if s = "" then "" else s ^ " then ") ^ - match tok with - [ Stoken (_, descr) -> descr - | Skeyword kwd -> kwd - | _ -> assert False ]) - "" tokl ] - | DeadEnd | LocAct _ _ -> "???" ] -; -value magic _s x = debug magic "Obj.magic: %s@." _s in Obj.magic x; -value tree_failed entry prev_symb_result prev_symb tree = - let txt = name_of_tree_failed entry tree in - let txt = - match prev_symb with - [ Slist0 s -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | Slist1 s -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | Slist0sep s sep -> - match magic "tree_failed: 'a -> list 'b" prev_symb_result with - [ [] -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | _ -> - let txt1 = name_of_symbol_failed entry sep in - txt1 ^ " or " ^ txt ^ " expected" ] - | Slist1sep s sep -> - match magic "tree_failed: 'a -> list 'b" prev_symb_result with - [ [] -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | _ -> - let txt1 = name_of_symbol_failed entry sep in - txt1 ^ " or " ^ txt ^ " expected" ] - | Stry _(*NP: not sure about this*) | Sopt _ | Stree _ -> txt ^ " expected" - | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb ] - in - do { - if entry.egram.error_verbose.val then do { - let tree = Search.tree_in_entry prev_symb tree entry.edesc; - let ppf = err_formatter; - fprintf ppf "@[@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename; - fprintf ppf "@["; - Print.print_level ppf pp_force_newline (Print.flatten_tree tree); - fprintf ppf "@]@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "@]@." - } - else (); - txt ^ " (in [" ^ entry.ename ^ "])" - } -; -value symb_failed entry prev_symb_result prev_symb symb = - let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in - tree_failed entry prev_symb_result prev_symb tree -; - -value symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Find.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Find.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Find.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Find.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* - value entry e s = - let rec find_levels = - fun - [ [] -> None - | [lev :: levs] -> - match find_tree lev.lsuffix with - [ None -> - match find_tree lev.lprefix with - [ None -> find_levels levs - | x -> x ] - | x -> x ] ] - and symbol = - fun - [ Snterm e -> if e.ename = s then Some e else None - | Snterml e _ -> if e.ename = s then Some e else None - | Smeta _ sl _ -> find_symbol_list sl - | Slist0 s -> find_symbol s - | Slist0sep s _ -> find_symbol s - | Slist1 s -> find_symbol s - | Slist1sep s _ -> find_symbol s - | Sopt s -> find_symbol s - | Stree t -> find_tree t - | Sself | Snext | Stoken _ | Stoken_fun _ -> None ] - and symbol_list = - fun - [ [s :: sl] -> - match find_symbol s with - [ None -> find_symbol_list sl - | x -> x ] - | [] -> None ] - and tree = - fun - [ Node {node = s; brother = bro; son = son} -> - match find_symbol s with - [ None -> - match find_tree bro with - [ None -> find_tree son - | x -> x ] - | x -> x ] - | LocAct _ _ | DeadEnd -> None ] - in - match e.edesc with - [ Dlevels levs -> - match find_levels levs with - [ Some e -> e - | None -> raise Not_found ] - | Dparser _ -> raise Not_found ] - ; -*) diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Fold.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Fold.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Fold.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Fold.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,95 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - - - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Structure : Structure.S) = struct - open Structure; - open Format; - module Parse = Parser.Make Structure; - module Fail = Failed.Make Structure; - open Sig.Grammar; - - (* Prevent from implict usage. *) - module Stream = struct - type t 'a = Stream.t 'a; - exception Failure = Stream.Failure; - exception Error = Stream.Error; - end; - - value sfold0 f e _entry _symbl psymb = - let rec fold accu = - parser - [ [: a = psymb; s :] -> fold (f a accu) s - | [: :] -> accu ] - in - parser [: a = fold e :] -> a - ; - - value sfold1 f e _entry _symbl psymb = - let rec fold accu = - parser - [ [: a = psymb; s :] -> fold (f a accu) s - | [: :] -> accu ] - in - parser [: a = psymb; a = fold (f a e) :] -> a - ; - - value sfold0sep f e entry symbl psymb psep = - let failed = - fun - [ [symb; sep] -> Fail.symb_failed_txt entry sep symb - | _ -> "failed" ] - in - let rec kont accu = - parser - [ [: () = psep; a = psymb ?? failed symbl; s :] -> kont (f a accu) s - | [: :] -> accu ] - in - parser - [ [: a = psymb; s :] -> kont (f a e) s - | [: :] -> e ] - ; - - value sfold1sep f e entry symbl psymb psep = - let failed = - fun - [ [symb; sep] -> Fail.symb_failed_txt entry sep symb - | _ -> "failed" ] - in - let parse_top = - fun - [ [symb; _] -> Parse.parse_top_symb entry symb (* FIXME context *) - | _ -> raise Stream.Failure ] - in - let rec kont accu = - parser - [ [: () = psep; - a = - parser - [ [: a = psymb :] -> a - | [: a = parse_top symbl :] -> Obj.magic a - | [: :] -> raise (Stream.Error (failed symbl)) ]; - s :] -> - kont (f a accu) s - | [: :] -> accu ] - in - parser [: a = psymb; s :] -> kont (f a e) s - ; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Fold.mli ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Fold.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Fold.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Fold.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - - - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) : sig - open Structure; - - value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; - (* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *) -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Insert.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Insert.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Insert.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Insert.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,323 +0,0 @@ -(* -*- camlp4r -*- *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - module Tools = Tools.Make Structure; - module Parser = Parser.Make Structure; - open Structure; - open Format; - open Sig.Grammar; - - value is_before s1 s2 = - match (s1, s2) with - [ (Skeyword _ | Stoken _, Skeyword _ | Stoken _) -> False - | (Skeyword _ | Stoken _, _) -> True - | _ -> False ] - ; - value rec derive_eps = - fun - [ Slist0 _ | Slist0sep _ _ | Sopt _ -> True - | Stry s -> derive_eps s - | Stree t -> tree_derive_eps t - | Slist1 _ | Slist1sep _ _ | Stoken _ | Skeyword _ -> - (* For sure we cannot derive epsilon from these *) - False - | Smeta _ _ _ | Snterm _ | Snterml _ _ | Snext | Sself -> - (* Approximation *) - False ] - and tree_derive_eps = - fun - [ LocAct _ _ -> True - | Node {node = s; brother = bro; son = son} -> - derive_eps s && tree_derive_eps son || tree_derive_eps bro - | DeadEnd -> False ] - ; - - value empty_lev lname assoc = - let assoc = - match assoc with - [ Some a -> a - | None -> LeftA ] - in - {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} - ; - value change_lev entry lev n lname assoc = - let a = - match assoc with - [ None -> lev.assoc - | Some a -> - do { - if a <> lev.assoc && entry.egram.warning_verbose.val then do { - eprintf " Changing associativity of level \"%s\"\n" n; - flush Pervasives.stderr - } - else (); - a - } ] - in - do { - match lname with - [ Some n -> - if lname <> lev.lname && entry.egram.warning_verbose.val then do { - eprintf " Level label \"%s\" ignored\n" n; flush Pervasives.stderr - } - else () - | None -> () ]; - {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; - lprefix = lev.lprefix} - } - ; - value change_to_self entry = - fun - [ Snterm e when e == entry -> Sself - | x -> x ] - ; - - - value get_level entry position levs = - match position with - [ Some First -> ([], empty_lev, levs) - | Some Last -> (levs, empty_lev, []) - | Some (Level n) -> - let rec get = - fun - [ [] -> - do { - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if Tools.is_level_labelled n lev then ([], change_lev entry lev n, levs) - else - let (levs1, rlev, levs2) = get levs in - ([lev :: levs1], rlev, levs2) ] - in - get levs - | Some (Before n) -> - let rec get = - fun - [ [] -> - do { - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if Tools.is_level_labelled n lev then ([], empty_lev, [lev :: levs]) - else - let (levs1, rlev, levs2) = get levs in - ([lev :: levs1], rlev, levs2) ] - in - get levs - | Some (After n) -> - let rec get = - fun - [ [] -> - do { - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if Tools.is_level_labelled n lev then ([lev], empty_lev, levs) - else - let (levs1, rlev, levs2) = get levs in - ([lev :: levs1], rlev, levs2) ] - in - get levs - | None -> - match levs with - [ [lev :: levs] -> ([], change_lev entry lev "", levs) - | [] -> ([], empty_lev, []) ] ] - ; - - value rec check_gram entry = - fun - [ Snterm e -> - if e.egram != entry.egram then do { - eprintf "\ - Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush Pervasives.stderr; - failwith "Grammar.extend error" - } - else () - | Snterml e _ -> - if e.egram != entry.egram then do { - eprintf "\ - Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush Pervasives.stderr; - failwith "Grammar.extend error" - } - else () - | Smeta _ sl _ -> List.iter (check_gram entry) sl - | Slist0sep s t -> do { check_gram entry t; check_gram entry s } - | Slist1sep s t -> do { check_gram entry t; check_gram entry s } - | Slist0 s | Slist1 s | Sopt s | Stry s -> check_gram entry s - | Stree t -> tree_check_gram entry t - | Snext | Sself | Stoken _ | Skeyword _ -> () ] - and tree_check_gram entry = - fun - [ Node {node = n; brother = bro; son = son} -> - do { - check_gram entry n; - tree_check_gram entry bro; - tree_check_gram entry son - } - | LocAct _ _ | DeadEnd -> () ] - ; - value get_initial = - fun - [ [Sself :: symbols] -> (True, symbols) - | symbols -> (False, symbols) ] - ; - - - value insert_tokens gram symbols = - let rec insert = - fun - [ Smeta _ sl _ -> List.iter insert sl - | Slist0 s | Slist1 s | Sopt s | Stry s -> insert s - | Slist0sep s t -> do { insert s; insert t } - | Slist1sep s t -> do { insert s; insert t } - | Stree t -> tinsert t - | Skeyword kwd -> using gram kwd - | Snterm _ | Snterml _ _ | Snext | Sself | Stoken _ -> () ] - and tinsert = - fun - [ Node {node = s; brother = bro; son = son} -> - do { insert s; tinsert bro; tinsert son } - | LocAct _ _ | DeadEnd -> () ] - in - List.iter insert symbols - ; - - value insert_tree entry gsymbols action tree = - let rec insert symbols tree = - match symbols with - [ [s :: sl] -> insert_in_tree s sl tree - | [] -> - match tree with - [ Node {node = s; son = son; brother = bro} -> - Node {node = s; son = son; brother = insert [] bro} - | LocAct old_action action_list -> - let () = - if entry.egram.warning_verbose.val then - eprintf " Grammar extension: in [%s] some rule has been masked@." - entry.ename - else () - in LocAct action [old_action :: action_list] - | DeadEnd -> LocAct action [] ] ] - and insert_in_tree s sl tree = - match try_insert s sl tree with - [ Some t -> t - | None -> Node {node = s; son = insert sl DeadEnd; brother = tree} ] - and try_insert s sl tree = - match tree with - [ Node {node = s1; son = son; brother = bro} -> - if Tools.eq_symbol s s1 then - let t = Node {node = s1; son = insert sl son; brother = bro} in - Some t - else if is_before s1 s || derive_eps s && not (derive_eps s1) then - let bro = - match try_insert s sl bro with - [ Some bro -> bro - | None -> - Node {node = s; son = insert sl DeadEnd; brother = bro} ] - in - let t = Node {node = s1; son = son; brother = bro} in - Some t - else - match try_insert s sl bro with - [ Some bro -> - let t = Node {node = s1; son = son; brother = bro} in - Some t - | None -> None ] - | LocAct _ _ | DeadEnd -> None ] - in - insert gsymbols tree - ; - value insert_level entry e1 symbols action slev = - match e1 with - [ True -> - {assoc = slev.assoc; lname = slev.lname; - lsuffix = insert_tree entry symbols action slev.lsuffix; - lprefix = slev.lprefix} - | False -> - {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; - lprefix = insert_tree entry symbols action slev.lprefix} ] - ; - - value levels_of_rules entry position rules = - let elev = - match entry.edesc with - [ Dlevels elev -> elev - | Dparser _ -> - do { - eprintf "Error: entry not extensible: \"%s\"\n" entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend" - } ] - in - if rules = [] then elev - else - let (levs1, make_lev, levs2) = get_level entry position elev in - let (levs, _) = - List.fold_left - (fun (levs, make_lev) (lname, assoc, level) -> - let lev = make_lev lname assoc in - let lev = - List.fold_left - (fun lev (symbols, action) -> - let symbols = List.map (change_to_self entry) symbols in - do { - List.iter (check_gram entry) symbols; - let (e1, symbols) = get_initial symbols; - insert_tokens entry.egram symbols; - insert_level entry e1 symbols action lev - }) - lev level - in - ([lev :: levs], empty_lev)) - ([], make_lev) rules - in - levs1 @ List.rev levs @ levs2 - ; - - value extend entry (position, rules) = - let elev = levels_of_rules entry position rules in - do { - entry.edesc := Dlevels elev; - entry.estart := - fun lev strm -> - let f = Parser.start_parser_of_entry entry in - do { entry.estart := f; f lev strm }; - entry.econtinue := - fun lev bp a strm -> - let f = Parser.continue_parser_of_entry entry in - do { entry.econtinue := f; f lev bp a strm } - }; - - end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Parser.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Parser.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Parser.ml 2012-07-20 09:26:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Parser.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,431 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - module Tools = Tools.Make Structure; - module Failed = Failed.Make Structure; - module Print = Print.Make Structure; - open Structure; - open Sig.Grammar; - - module StreamOrig = Stream; - - value njunk strm n = - for i = 1 to n do Stream.junk strm done; - - value loc_bp = Tools.get_cur_loc; - value loc_ep = Tools.get_prev_loc; - value drop_prev_loc = Tools.drop_prev_loc; - - value add_loc bp parse_fun strm = - let x = parse_fun strm in - let ep = loc_ep strm in - let loc = - if Loc.start_off bp > Loc.stop_off ep then - (* If nothing has been consumed, create a 0-length location. *) - Loc.join bp - else - Loc.merge bp ep - in - (x, loc); - - value stream_peek_nth strm n = - let rec loop i = fun - [ [x :: xs] -> if i = 1 then Some x else loop (i - 1) xs - | [] -> None ] - in - loop n (Stream.npeek n strm); - - (* We don't want Stream's functions to be used implictly. *) - module Stream = struct - type t 'a = StreamOrig.t 'a; - exception Failure = StreamOrig.Failure; - exception Error = StreamOrig.Error; - value peek = StreamOrig.peek; - value junk = StreamOrig.junk; - - value dup strm = - (* This version of peek_nth is off-by-one from Stream.peek_nth *) - let peek_nth n = - loop n (Stream.npeek (n + 1) strm) where rec loop n = - fun - [ [] -> None - | [x] -> if n = 0 then Some x else None - | [_ :: l] -> loop (n - 1) l ] - in - Stream.from peek_nth; - end; - - value try_parser ps strm = - let strm' = Stream.dup strm in - let r = - try ps strm' - with - [ Stream.Error _ | Loc.Exc_located _ (Stream.Error _) -> - raise Stream.Failure - | exc -> raise exc ] - in do { - njunk strm (StreamOrig.count strm'); - r; - }; - - value level_number entry lab = - let rec lookup levn = - fun - [ [] -> failwith ("unknown level " ^ lab) - | [lev :: levs] -> - if Tools.is_level_labelled lab lev then levn else lookup (succ levn) levs ] - in - match entry.edesc with - [ Dlevels elev -> lookup 0 elev - | Dparser _ -> raise Not_found ] - ; - value strict_parsing = ref False; - value strict_parsing_warning = ref False; - - value rec top_symb entry = - fun - [ Sself | Snext -> Snterm entry - | Snterml e _ -> Snterm e - | Slist1sep s sep -> Slist1sep (top_symb entry s) sep - | _ -> raise Stream.Failure ] - ; - - value top_tree entry = - fun - [ Node {node = s; brother = bro; son = son} -> - Node {node = top_symb entry s; brother = bro; son = son} - | LocAct _ _ | DeadEnd -> raise Stream.Failure ] - ; - - value entry_of_symb entry = - fun - [ Sself | Snext -> entry - | Snterm e -> e - | Snterml e _ -> e - | _ -> raise Stream.Failure ] - ; - - value continue entry loc a s son p1 = - parser - [: a = (entry_of_symb entry s).econtinue 0 loc a; - act = p1 ?? Failed.tree_failed entry a s son :] -> - Action.mk (fun _ -> Action.getf act a) - ; - - (* PR#4603, PR#4330, PR#4551: - Here loc_bp replaced get_loc_ep to fix all these bugs. - If you do change it again look at these bugs. *) - value skip_if_empty bp strm = - if loc_bp strm = bp then Action.mk (fun _ -> raise Stream.Failure) - else - raise Stream.Failure - ; - - value do_recover parser_of_tree entry nlevn alevn loc a s son = - parser - [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) :] -> a - | [: a = skip_if_empty loc :] -> a - | [: a = - continue entry loc a s son - (parser_of_tree entry nlevn alevn son) :] -> - a ] - ; - - - value recover parser_of_tree entry nlevn alevn loc a s son strm = - if strict_parsing.val then raise (Stream.Error (Failed.tree_failed entry a s son)) - else - let _ = - if strict_parsing_warning.val then begin - let msg = Failed.tree_failed entry a s son; - Format.eprintf "Warning: trying to recover from syntax error"; - if entry.ename <> "" then Format.eprintf " in [%s]" entry.ename else (); - Format.eprintf "\n%s%a@." msg Loc.print loc; - end else () in - do_recover parser_of_tree entry nlevn alevn loc a s son strm - ; - - value rec parser_of_tree entry nlevn alevn = - fun - [ DeadEnd -> parser [] - | LocAct act _ -> parser [: :] -> act - | Node {node = Sself; son = LocAct act _; brother = DeadEnd} -> - parser [: a = entry.estart alevn :] -> Action.getf act a - | Node {node = Sself; son = LocAct act _; brother = bro} -> - let p2 = parser_of_tree entry nlevn alevn bro in - parser - [ [: a = entry.estart alevn :] -> Action.getf act a - | [: a = p2 :] -> a ] - | Node {node = s; son = son; brother = DeadEnd} -> - let tokl = - match s with - [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son - | _ -> None ] - in - match tokl with - [ None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn s son in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [: a = ps; act = p1 bp a :] -> Action.getf act a - | Some (tokl, last_tok, son) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn last_tok son in - parser_of_token_list p1 tokl ] - | Node {node = s; son = son; brother = bro} -> - let tokl = - match s with - [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son - | _ -> None ] - in - match tokl with - [ None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn s son in - let p2 = parser_of_tree entry nlevn alevn bro in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [ [: a = ps; act = p1 bp a :] -> Action.getf act a - | [: a = p2 :] -> a ] - | Some (tokl, last_tok, son) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn last_tok son in - let p1 = parser_of_token_list p1 tokl in - let p2 = parser_of_tree entry nlevn alevn bro in - parser - [ [: a = p1 :] -> a - | [: a = p2 :] -> a ] ] ] - and parser_cont p1 entry nlevn alevn s son loc a = - parser - [ [: a = p1 :] -> a - | [: a = recover parser_of_tree entry nlevn alevn loc a s son :] -> a - | [: :] -> raise (Stream.Error (Failed.tree_failed entry a s son)) ] - and parser_of_token_list p1 tokl = - loop 1 tokl where rec loop n = - fun - [ [Stoken (tematch, _) :: tokl] -> - match tokl with - [ [] -> - let ps strm = - match stream_peek_nth strm n with - [ Some (tok, _) when tematch tok -> (njunk strm n; Action.mk tok) - | _ -> raise Stream.Failure ] - in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [: a = ps; act = p1 bp a :] -> Action.getf act a - | _ -> - let ps strm = - match stream_peek_nth strm n with - [ Some (tok, _) when tematch tok -> tok - | _ -> raise Stream.Failure ] - in - let p1 = loop (n + 1) tokl in - parser [: tok = ps; s :] -> - let act = p1 s in Action.getf act tok ] - | [Skeyword kwd :: tokl] -> - match tokl with - [ [] -> - let ps strm = - match stream_peek_nth strm n with - [ Some (tok, _) when Token.match_keyword kwd tok -> - (njunk strm n; Action.mk tok) - | _ -> raise Stream.Failure ] - in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [: a = ps; act = p1 bp a :] -> Action.getf act a - | _ -> - let ps strm = - match stream_peek_nth strm n with - [ Some (tok, _) when Token.match_keyword kwd tok -> tok - | _ -> raise Stream.Failure ] - in - let p1 = loop (n + 1) tokl in - parser [: tok = ps; s :] -> - let act = p1 s in Action.getf act tok ] - | _ -> invalid_arg "parser_of_token_list" ] - and parser_of_symbol entry nlevn = - fun - [ Smeta _ symbl act -> - let act = Obj.magic act entry symbl in - let pl = List.map (parser_of_symbol entry nlevn) symbl in - Obj.magic (List.fold_left (fun act p -> Obj.magic act p) act pl) - | Slist0 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al = - parser - [ [: a = ps; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = loop [] :] -> Action.mk (List.rev a) - | Slist0sep symb sep -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al = - parser - [ [: v = pt; a = ps ?? Failed.symb_failed entry v sep symb; - s :] -> - kont [a :: al] s - | [: :] -> al ] - in - parser - [ [: a = ps; s :] -> Action.mk (List.rev (kont [a] s)) - | [: :] -> Action.mk [] ] - | Slist1 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al = - parser - [ [: a = ps; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = ps; s :] -> Action.mk (List.rev (loop [a] s)) - | Slist1sep symb sep -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al = - parser - [ [: v = pt; - a = - parser - [ [: a = ps :] -> a - | [: a = parse_top_symb entry symb :] -> a - | [: :] -> - raise (Stream.Error (Failed.symb_failed entry v sep symb)) ]; - s :] -> - kont [a :: al] s - | [: :] -> al ] - in - parser [: a = ps; s :] -> Action.mk (List.rev (kont [a] s)) - | Sopt s -> - let ps = parser_of_symbol entry nlevn s in - parser - [ [: a = ps :] -> Action.mk (Some a) - | [: :] -> Action.mk None ] - | Stry s -> - let ps = parser_of_symbol entry nlevn s in - try_parser ps - | Stree t -> - let pt = parser_of_tree entry 1 0 t in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [: (act, loc) = add_loc bp pt :] -> - Action.getf act loc - | Snterm e -> parser [: a = e.estart 0 :] -> a - | Snterml e l -> - parser [: a = e.estart (level_number e l) :] -> a - | Sself -> parser [: a = entry.estart 0 :] -> a - | Snext -> parser [: a = entry.estart nlevn :] -> a - | Skeyword kwd -> - parser - [: `(tok, _) when Token.match_keyword kwd tok :] -> - Action.mk tok - | Stoken (f, _) -> - parser - [: `(tok,_) when f tok :] -> Action.mk tok ] - and parse_top_symb entry symb strm = - parser_of_symbol entry 0 (top_symb entry symb) strm; - - value rec start_parser_of_levels entry clevn = - fun - [ [] -> fun _ -> parser [] - | [lev :: levs] -> - let p1 = start_parser_of_levels entry (succ clevn) levs in - match lev.lprefix with - [ DeadEnd -> p1 - | tree -> - let alevn = - match lev.assoc with - [ LeftA | NonA -> succ clevn - | RightA -> clevn ] - in - let p2 = parser_of_tree entry (succ clevn) alevn tree in - match levs with - [ [] -> - fun levn strm -> - let bp = loc_bp strm in - match strm with parser - [: (act, loc) = add_loc bp p2; strm :] -> - let a = Action.getf act loc in - entry.econtinue levn loc a strm - | _ -> - fun levn strm -> - if levn > clevn then p1 levn strm - else - let bp = loc_bp strm in - match strm with parser - [ [: (act, loc) = add_loc bp p2 :] -> - let a = Action.getf act loc in - entry.econtinue levn loc a strm - | [: act = p1 levn :] -> act ] ] ] ] - ; - - value start_parser_of_entry entry = - debug gram "start_parser_of_entry: @[<2>%a@]@." Print.entry entry in - match entry.edesc with - [ Dlevels [] -> Tools.empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> fun _ -> p ] - ; - value rec continue_parser_of_levels entry clevn = - fun - [ [] -> fun _ _ _ -> parser [] - | [lev :: levs] -> - let p1 = continue_parser_of_levels entry (succ clevn) levs in - match lev.lsuffix with - [ DeadEnd -> p1 - | tree -> - let alevn = - match lev.assoc with - [ LeftA | NonA -> succ clevn - | RightA -> clevn ] - in - let p2 = parser_of_tree entry (succ clevn) alevn tree in - fun levn bp a strm -> - if levn > clevn then p1 levn bp a strm - else - match strm with parser - [ [: act = p1 levn bp a :] -> act - | [: (act, loc) = add_loc bp p2 :] -> - let a = Action.getf2 act a loc in - entry.econtinue levn loc a strm ] ] ] - ; - - value continue_parser_of_entry entry = - debug gram "continue_parser_of_entry: @[<2>%a@]@." Print.entry entry in - match entry.edesc with - [ Dlevels elev -> - let p = continue_parser_of_levels entry 0 elev in - fun levn bp a -> - parser - [ [: a = p levn bp a :] -> a - | [: :] -> a ] - | Dparser _ -> fun _ _ _ -> parser [] ] - ; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Parser.mli ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Parser.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Parser.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Parser.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2007 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - - - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) : sig - open Structure; - value add_loc : - Loc.t -> (token_stream -> 'b) -> token_stream -> ('b * Loc.t); - value level_number : internal_entry -> string -> int; - value strict_parsing : ref bool; - value strict_parsing_warning : ref bool; - value top_symb : - internal_entry -> symbol -> symbol; - value top_tree : - internal_entry -> tree -> tree; - value entry_of_symb : - internal_entry -> symbol -> internal_entry; - value continue : - internal_entry -> Loc.t -> Action.t -> symbol -> tree -> efun -> efun; - value do_recover : - (internal_entry -> 'a -> 'b -> tree -> efun) -> internal_entry -> - 'a -> 'b -> Loc.t -> Action.t -> symbol -> tree -> efun; - value recover : - (internal_entry -> 'a -> 'b -> tree -> efun) -> internal_entry -> - 'a -> 'b -> Loc.t -> Action.t -> symbol -> tree -> efun; - value parser_of_tree : - internal_entry -> int -> int -> tree -> efun; - value parser_cont : - efun -> internal_entry -> int -> int -> symbol -> tree -> Loc.t -> Action.t -> efun; - value parser_of_token_list : - (Loc.t -> Action.t -> efun) -> list symbol -> efun; - value parser_of_symbol : - internal_entry -> int -> symbol -> efun; - value parse_top_symb : - internal_entry -> symbol -> efun; - value start_parser_of_levels : - internal_entry -> int -> list level -> int -> efun; - value start_parser_of_entry : - internal_entry -> int -> efun; - value continue_parser_of_levels : - internal_entry -> int -> list level -> int -> Loc.t -> 'a -> efun; - value continue_parser_of_entry : - internal_entry -> int -> Loc.t -> Action.t -> efun; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Print.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Print.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Print.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Print.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,270 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - open Structure; - open Format; - open Sig.Grammar; - - value rec flatten_tree = - fun - [ DeadEnd -> [] - | LocAct _ _ -> [[]] - | Node {node = n; brother = b; son = s} -> - [ [n :: l] | l <- flatten_tree s ] @ flatten_tree b ]; - - value rec print_symbol ppf = - fun - [ Smeta n sl _ -> print_meta ppf n sl - | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s - | Slist0sep s t -> - fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t - | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s - | Slist1sep s t -> - fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t - | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stry s -> fprintf ppf "TRY %a" print_symbol1 s - | Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l - | Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s -> - print_symbol1 ppf s ] - and print_meta ppf n sl = - loop 0 sl where rec loop i = - fun - [ [] -> () - | [s :: sl] -> - let j = - try String.index_from n i ' ' with [ Not_found -> String.length n ] - in - do { - fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; - if sl = [] then () - else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl } - } ] - and print_symbol1 ppf = - fun - [ Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken (_, descr) -> pp_print_string ppf descr - | Skeyword s -> fprintf ppf "%S" s - | Stree t -> print_level ppf pp_print_space (flatten_tree t) - | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stry _ as s -> - fprintf ppf "(%a)" print_symbol s ] - and print_rule ppf symbols = - do { - fprintf ppf "@["; - let _ = - List.fold_left - (fun sep symbol -> - do { - fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ " - }) - (fun _ -> ()) symbols - in - fprintf ppf "@]" - } - and print_level ppf pp_print_space rules = - do { - fprintf ppf "@[[ "; - let _ = - List.fold_left - (fun sep rule -> - do { - fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space () - }) - (fun _ -> ()) rules - in - fprintf ppf " ]@]" - } - ; - - value levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - let rules = - [ [Sself :: t] | t <- flatten_tree lev.lsuffix ] @ - flatten_tree lev.lprefix - in - do { - fprintf ppf "%t@[" sep; - match lev.lname with - [ Some n -> fprintf ppf "%S@;<1 2>" n - | None -> () ]; - match lev.assoc with - [ LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA" ]; - fprintf ppf "@]@;<1 2>"; - print_level ppf pp_force_newline rules; - fun ppf -> fprintf ppf "@,| " - }) - (fun _ -> ()) elev - in - (); - - value entry ppf e = - do { - fprintf ppf "@[%s: [ " e.ename; - match e.edesc with - [ Dlevels elev -> levels ppf elev - | Dparser _ -> fprintf ppf "" ]; - fprintf ppf " ]@]" - }; - -end; - -module MakeDump (Structure : Structure.S) = struct - open Structure; - open Format; - open Sig.Grammar; - - type brothers = [ Bro of symbol and list brothers ]; - - value rec print_tree ppf tree = - let rec get_brothers acc = - fun - [ DeadEnd -> List.rev acc - | LocAct _ _ -> List.rev acc - | Node {node = n; brother = b; son = s} -> get_brothers [Bro n (get_brothers [] s) :: acc] b ] - and print_brothers ppf brothers = - if brothers = [] then fprintf ppf "@ []" - else - List.iter (fun [ Bro n xs -> do { - fprintf ppf "@ @[- %a" print_symbol n; - match xs with - [ [] -> () - | [_] -> try print_children ppf (get_children [] xs) - with [ Exit -> fprintf ppf ":%a" print_brothers xs ] - | _ -> fprintf ppf ":%a" print_brothers xs ]; - fprintf ppf "@]"; - }]) brothers - and print_children ppf = List.iter (fprintf ppf ";@ %a" print_symbol) - and get_children acc = - fun - [ [] -> List.rev acc - | [Bro n x] -> get_children [n::acc] x - | _ -> raise Exit ] - in print_brothers ppf (get_brothers [] tree) - and print_symbol ppf = - fun - [ Smeta n sl _ -> print_meta ppf n sl - | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s - | Slist0sep s t -> - fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t - | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s - | Slist1sep s t -> - fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t - | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stry s -> fprintf ppf "TRY %a" print_symbol1 s - | Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l - | Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s -> - print_symbol1 ppf s ] - and print_meta ppf n sl = - loop 0 sl where rec loop i = - fun - [ [] -> () - | [s :: sl] -> - let j = - try String.index_from n i ' ' with [ Not_found -> String.length n ] - in - do { - fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; - if sl = [] then () - else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl } - } ] - and print_symbol1 ppf = - fun - [ Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken (_, descr) -> pp_print_string ppf descr - | Skeyword s -> fprintf ppf "%S" s - | Stree t -> print_tree ppf t - | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stry _ as s -> - fprintf ppf "(%a)" print_symbol s ] - and print_rule ppf symbols = - do { - fprintf ppf "@["; - let _ = - List.fold_left - (fun sep symbol -> - do { - fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ " - }) - (fun _ -> ()) symbols - in - fprintf ppf "@]" - } - and print_level ppf pp_print_space rules = - do { - fprintf ppf "@[[ "; - let _ = - List.fold_left - (fun sep rule -> - do { - fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space () - }) - (fun _ -> ()) rules - in - fprintf ppf " ]@]" - } - ; - - value levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - do { - fprintf ppf "%t@[" sep; - match lev.lname with - [ Some n -> fprintf ppf "%S@;<1 2>" n - | None -> () ]; - match lev.assoc with - [ LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA" ]; - fprintf ppf "@]@;<1 2>"; - fprintf ppf "@[suffix:@ "; - print_tree ppf lev.lsuffix; - fprintf ppf "@]@ @[prefix:@ "; - print_tree ppf lev.lprefix; - fprintf ppf "@]"; - fun ppf -> fprintf ppf "@,| " - }) - (fun _ -> ()) elev - in - (); - - value entry ppf e = - do { - fprintf ppf "@[%s: [ " e.ename; - match e.edesc with - [ Dlevels elev -> levels ppf elev - | Dparser _ -> fprintf ppf "" ]; - fprintf ppf " ]@]" - }; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Print.mli ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Print.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Print.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Print.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) : sig - value flatten_tree : Structure.tree -> list (list Structure.symbol); - value print_symbol : Format.formatter -> Structure.symbol -> unit; - value print_meta : - Format.formatter -> string -> list Structure.symbol -> unit; - value print_symbol1 : Format.formatter -> Structure.symbol -> unit; - value print_rule : Format.formatter -> list Structure.symbol -> unit; - value print_level : - Format.formatter -> - (Format.formatter -> unit -> unit) -> - list (list Structure.symbol) -> unit; - value levels : Format.formatter -> list Structure.level -> unit; - value entry : Format.formatter -> Structure.internal_entry -> unit; -end; - -module MakeDump (Structure : Structure.S) : sig - value print_symbol : Format.formatter -> Structure.symbol -> unit; - value print_meta : - Format.formatter -> string -> list Structure.symbol -> unit; - value print_symbol1 : Format.formatter -> Structure.symbol -> unit; - value print_rule : Format.formatter -> list Structure.symbol -> unit; - value print_level : - Format.formatter -> - (Format.formatter -> unit -> unit) -> - list (list Structure.symbol) -> unit; - value levels : Format.formatter -> list Structure.level -> unit; - value entry : Format.formatter -> Structure.internal_entry -> unit; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Search.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Search.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Search.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Search.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,95 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Structure : Structure.S) = struct - open Structure; -value tree_in_entry prev_symb tree = - fun - [ Dlevels levels -> - let rec search_levels = - fun - [ [] -> tree - | [level :: levels] -> - match search_level level with - [ Some tree -> tree - | None -> search_levels levels ] ] - and search_level level = - match search_tree level.lsuffix with - [ Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd}) - | None -> search_tree level.lprefix ] - and search_tree t = - if tree <> DeadEnd && t == tree then Some t - else - match t with - [ Node n -> - match search_symbol n.node with - [ Some symb -> - Some (Node {node = symb; son = n.son; brother = DeadEnd}) - | None -> - match search_tree n.son with - [ Some t -> - Some (Node {node = n.node; son = t; brother = DeadEnd}) - | None -> search_tree n.brother ] ] - | LocAct _ _ | DeadEnd -> None ] - and search_symbol symb = - match symb with - [ Snterm _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stry _ | Stoken _ | Stree _ | Skeyword _ - when symb == prev_symb -> - Some symb - | Slist0 symb -> - match search_symbol symb with - [ Some symb -> Some (Slist0 symb) - | None -> None ] - | Slist0sep symb sep -> - match search_symbol symb with - [ Some symb -> Some (Slist0sep symb sep) - | None -> - match search_symbol sep with - [ Some sep -> Some (Slist0sep symb sep) - | None -> None ] ] - | Slist1 symb -> - match search_symbol symb with - [ Some symb -> Some (Slist1 symb) - | None -> None ] - | Slist1sep symb sep -> - match search_symbol symb with - [ Some symb -> Some (Slist1sep symb sep) - | None -> - match search_symbol sep with - [ Some sep -> Some (Slist1sep symb sep) - | None -> None ] ] - | Sopt symb -> - match search_symbol symb with - [ Some symb -> Some (Sopt symb) - | None -> None ] - | Stry symb -> - match search_symbol symb with - [ Some symb -> Some (Stry symb) - | None -> None ] - | Stree t -> - match search_tree t with - [ Some t -> Some (Stree t) - | None -> None ] - | _ -> None ] - in - search_levels levels - | Dparser _ -> tree ] -; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Static.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Static.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Static.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Static.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,84 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring -*) - -value uncurry f (x,y) = f x y; -value flip f x y = f y x; - -module Make (Lexer : Sig.Lexer) -: Sig.Grammar.Static with module Loc = Lexer.Loc - and module Token = Lexer.Token -= struct - module Structure = Structure.Make Lexer; - module Delete = Delete.Make Structure; - module Insert = Insert.Make Structure; - module Fold = Fold.Make Structure; - module Tools = Tools.Make Structure; - include Structure; - - value gram = - let gkeywords = Hashtbl.create 301 in - { - gkeywords = gkeywords; - gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); - glexer = Lexer.mk (); - warning_verbose = ref True; (* FIXME *) - error_verbose = Camlp4_config.verbose - }; - - module Entry = struct - module E = Entry.Make Structure; - type t 'a = E.t 'a; - value mk = E.mk gram; - value of_parser name strm = E.of_parser gram name strm; - value setup_parser = E.setup_parser; - value name = E.name; - value print = E.print; - value clear = E.clear; - value dump = E.dump; - value obj x = x; - end; - - value get_filter () = gram.gfilter; - - value lex loc cs = gram.glexer loc cs; - - value lex_string loc str = lex loc (Stream.of_string str); - - value filter ts = Tools.keep_prev_loc (Token.Filter.filter gram.gfilter ts); - - value parse_tokens_after_filter entry ts = Entry.E.parse_tokens_after_filter entry ts; - - value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter ts); - - value parse entry loc cs = parse_tokens_before_filter entry (lex loc cs); - - value parse_string entry loc str = parse_tokens_before_filter entry (lex_string loc str); - - value delete_rule = Delete.delete_rule; - - value srules e rl = - Stree (List.fold_left (flip (uncurry (Insert.insert_tree e))) DeadEnd rl); - value sfold0 = Fold.sfold0; - value sfold1 = Fold.sfold1; - value sfold0sep = Fold.sfold0sep; - (* value sfold1sep = Fold.sfold1sep; *) - - value extend = Insert.extend; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Structure.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Structure.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Structure.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Structure.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,294 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -open Sig.Grammar; - -module type S = sig - module Loc : Sig.Loc; - module Token : Sig.Token with module Loc = Loc; - module Lexer : Sig.Lexer - with module Loc = Loc - and module Token = Token; - module Action : Sig.Grammar.Action; - - type gram = - { gfilter : Token.Filter.t; - gkeywords : Hashtbl.t string (ref int); - glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); - warning_verbose : ref bool; - error_verbose : ref bool }; - - type token_info = { prev_loc : Loc.t - ; cur_loc : Loc.t - ; prev_loc_only : bool - }; - - type token_stream = Stream.t (Token.t * token_info); - - type efun = token_stream -> Action.t; - - type token_pattern = ((Token.t -> bool) * string); - - type internal_entry = - { egram : gram; - ename : string; - estart : mutable int -> efun; - econtinue : mutable int -> Loc.t -> Action.t -> efun; - edesc : mutable desc } - and desc = - [ Dlevels of list level - | Dparser of token_stream -> Action.t ] - and level = - { assoc : assoc ; - lname : option string ; - lsuffix : tree ; - lprefix : tree } - and symbol = - [ Smeta of string and list symbol and Action.t - | Snterm of internal_entry - | Snterml of internal_entry and string - | Slist0 of symbol - | Slist0sep of symbol and symbol - | Slist1 of symbol - | Slist1sep of symbol and symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree ] - and tree = - [ Node of node - | LocAct of Action.t and list Action.t - | DeadEnd ] - and node = - { node : symbol ; - son : tree ; - brother : tree }; - - type production_rule = (list symbol * Action.t); - type single_extend_statment = - (option string * option assoc * list production_rule); - type extend_statment = - (option position * list single_extend_statment); - type delete_statment = list symbol; - - type fold 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; - - type foldsep 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; - - (* Accessors *) - value get_filter : gram -> Token.Filter.t; - - (* Useful functions *) - value using : gram -> string -> unit; - value removing : gram -> string -> unit; -end; - -module Make (Lexer : Sig.Lexer) = struct - module Loc = Lexer.Loc; - module Token = Lexer.Token; - module Action : Sig.Grammar.Action = struct - type t = Obj.t ; - value mk = Obj.repr; - value get = Obj.obj ; - value getf = Obj.obj ; - value getf2 = Obj.obj ; - end; - module Lexer = Lexer; - - type gram = - { gfilter : Token.Filter.t; - gkeywords : Hashtbl.t string (ref int); - glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); - warning_verbose : ref bool; - error_verbose : ref bool }; - - type token_info = { prev_loc : Loc.t - ; cur_loc : Loc.t - ; prev_loc_only : bool - }; - - type token_stream = Stream.t (Token.t * token_info); - - type efun = token_stream -> Action.t; - - type token_pattern = ((Token.t -> bool) * string); - - type internal_entry = - { egram : gram; - ename : string; - estart : mutable int -> efun; - econtinue : mutable int -> Loc.t -> Action.t -> efun; - edesc : mutable desc } - and desc = - [ Dlevels of list level - | Dparser of token_stream -> Action.t ] - and level = - { assoc : assoc ; - lname : option string ; - lsuffix : tree ; - lprefix : tree } - and symbol = - [ Smeta of string and list symbol and Action.t - | Snterm of internal_entry - | Snterml of internal_entry and string - | Slist0 of symbol - | Slist0sep of symbol and symbol - | Slist1 of symbol - | Slist1sep of symbol and symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree ] - and tree = - [ Node of node - | LocAct of Action.t and list Action.t - | DeadEnd ] - and node = - { node : symbol ; - son : tree ; - brother : tree }; - - type production_rule = (list symbol * Action.t); - type single_extend_statment = - (option string * option assoc * list production_rule); - type extend_statment = - (option position * list single_extend_statment); - type delete_statment = list symbol; - - type fold 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; - - type foldsep 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; - - value get_filter g = g.gfilter; - value token_location r = r.cur_loc; - - type not_filtered 'a = 'a; - value using { gkeywords = table; gfilter = filter } kwd = - let r = try Hashtbl.find table kwd with - [ Not_found -> - let r = ref 0 in do { Hashtbl.add table kwd r; r } ] - in do { Token.Filter.keyword_added filter kwd (r.val = 0); - incr r }; - - value removing { gkeywords = table; gfilter = filter } kwd = - let r = Hashtbl.find table kwd in - let () = decr r in - if r.val = 0 then do { - Token.Filter.keyword_removed filter kwd; - Hashtbl.remove table kwd - } else (); -end; - -(* -value iter_entry f e = - let treated = ref [] in - let rec do_entry e = - if List.memq e treated.val then () - else do { - treated.val := [e :: treated.val]; - f e; - match e.edesc with - [ Dlevels ll -> List.iter do_level ll - | Dparser _ -> () ] - } - and do_level lev = do { do_tree lev.lsuffix; do_tree lev.lprefix } - and do_tree = - fun - [ Node n -> do_node n - | LocAct _ _ | DeadEnd -> () ] - and do_node n = do { do_symbol n.node; do_tree n.son; do_tree n.brother } - and do_symbol = - fun - [ Smeta _ sl _ -> List.iter do_symbol sl - | Snterm e | Snterml e _ -> do_entry e - | Slist0 s | Slist1 s | Sopt s | Stry s -> do_symbol s - | Slist0sep s1 s2 | Slist1sep s1 s2 -> do { do_symbol s1; do_symbol s2 } - | Stree t -> do_tree t - | Sself | Snext | Stoken _ | Stoken_fun _ -> () ] - in - do_entry e -; - -value fold_entry f e init = - let treated = ref [] in - let rec do_entry accu e = - if List.memq e treated.val then accu - else do { - treated.val := [e :: treated.val]; - let accu = f e accu in - match e.edesc with - [ Dlevels ll -> List.fold_left do_level accu ll - | Dparser _ -> accu ] - } - and do_level accu lev = - let accu = do_tree accu lev.lsuffix in - do_tree accu lev.lprefix - and do_tree accu = - fun - [ Node n -> do_node accu n - | LocAct _ _ | DeadEnd -> accu ] - and do_node accu n = - let accu = do_symbol accu n.node in - let accu = do_tree accu n.son in - do_tree accu n.brother - and do_symbol accu = - fun - [ Smeta _ sl _ -> List.fold_left do_symbol accu sl - | Snterm e | Snterml e _ -> do_entry accu e - | Slist0 s | Slist1 s | Sopt s | Stry s -> do_symbol accu s - | Slist0sep s1 s2 | Slist1sep s1 s2 -> - let accu = do_symbol accu s1 in - do_symbol accu s2 - | Stree t -> do_tree accu t - | Sself | Snext | Stoken _ | Stoken_fun _ -> accu ] - in - do_entry init e -; - -value is_level_labelled n lev = - match lev.lname with - [ Some n1 -> n = n1 - | None -> False ] -; - -value tokens g con = - let list = ref [] in - do { - Hashtbl.iter - (fun (p_con, p_prm) c -> - if p_con = con then list.val := [(p_prm, c.val) :: list.val] else ()) - g.gtokens; - list.val - } -; -*) diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Tools.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Tools.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Tools.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar/Tools.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,132 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -(* PR#5090: don't do lookahead on get_prev_loc. *) -value get_prev_loc_only = ref False; - -module Make (Structure : Structure.S) = struct - open Structure; - - value empty_entry ename _ = - raise (Stream.Error ("entry [" ^ ename ^ "] is empty")); - - value rec stream_map f = parser - [ [: ` x; strm :] -> [: ` (f x); stream_map f strm :] - | [: :] -> [: :] ]; - - value keep_prev_loc strm = - match Stream.peek strm with - [ None -> [: :] - | Some (tok0,init_loc) -> - let rec go prev_loc strm1 = - if get_prev_loc_only.val then - [: `(tok0, {prev_loc; cur_loc = prev_loc; prev_loc_only = True}); - go prev_loc strm1 :] - else - match strm1 with parser - [ [: `(tok,cur_loc); strm :] -> - [: `(tok, {prev_loc; cur_loc; prev_loc_only = False}); - go cur_loc strm :] - | [: :] -> [: :] ] - in go init_loc strm ]; - - value drop_prev_loc strm = stream_map (fun (tok,r) -> (tok,r.cur_loc)) strm; - - value get_cur_loc strm = - match Stream.peek strm with - [ Some (_,r) -> r.cur_loc - | None -> Loc.ghost ]; - - value get_prev_loc strm = - begin - get_prev_loc_only.val := True; - let result = match Stream.peek strm with - [ Some (_, {prev_loc; prev_loc_only = True}) -> - begin Stream.junk strm; prev_loc end - | Some (_, {prev_loc; prev_loc_only = False}) -> prev_loc - | None -> Loc.ghost ]; - get_prev_loc_only.val := False; - result - end; - - value is_level_labelled n lev = - match lev.lname with - [ Some n1 -> n = n1 - | None -> False ]; - - value warning_verbose = ref True; - - value rec get_token_list entry tokl last_tok tree = - match tree with - [ Node {node = (Stoken _ | Skeyword _ as tok); son = son; brother = DeadEnd} -> - get_token_list entry [last_tok :: tokl] tok son - | _ -> - if tokl = [] then None - else Some (List.rev [last_tok :: tokl], last_tok, tree) ]; - - value is_antiquot s = - let len = String.length s in - len > 1 && s.[0] = '$'; - - value eq_Stoken_ids s1 s2 = - not (is_antiquot s1) && not (is_antiquot s2) && s1 = s2; - - value logically_eq_symbols entry = - let rec eq_symbols s1 s2 = - match (s1, s2) with - [ (Snterm e1, Snterm e2) -> e1.ename = e2.ename - | (Snterm e1, Sself) -> e1.ename = entry.ename - | (Sself, Snterm e2) -> entry.ename = e2.ename - | (Snterml e1 l1, Snterml e2 l2) -> e1.ename = e2.ename && l1 = l2 - | (Slist0 s1, Slist0 s2) | - (Slist1 s1, Slist1 s2) | - (Sopt s1, Sopt s2) | - (Stry s1, Stry s2) -> eq_symbols s1 s2 - | (Slist0sep s1 sep1, Slist0sep s2 sep2) | - (Slist1sep s1 sep1, Slist1sep s2 sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | (Stree t1, Stree t2) -> eq_trees t1 t2 - | (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2 - | _ -> s1 = s2 ] - and eq_trees t1 t2 = - match (t1, t2) with - [ (Node n1, Node n2) -> - eq_symbols n1.node n2.node && eq_trees n1.son n2.son && - eq_trees n1.brother n2.brother - | (LocAct _ _ | DeadEnd, LocAct _ _ | DeadEnd) -> True - | _ -> False ] - in - eq_symbols; - - value rec eq_symbol s1 s2 = - match (s1, s2) with - [ (Snterm e1, Snterm e2) -> e1 == e2 - | (Snterml e1 l1, Snterml e2 l2) -> e1 == e2 && l1 = l2 - | (Slist0 s1, Slist0 s2) | - (Slist1 s1, Slist1 s2) | - (Sopt s1, Sopt s2) | - (Stry s1, Stry s2) -> eq_symbol s1 s2 - | (Slist0sep s1 sep1, Slist0sep s2 sep2) | - (Slist1sep s1 sep1, Slist1sep s2 sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | (Stree _, Stree _) -> False - | (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2 - | _ -> s1 = s2 ] - ; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar.mlpack ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar.mlpack --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar.mlpack 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Grammar.mlpack 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -Delete -Dynamic -Entry -Failed -Find -Fold -Insert -Parser -Print -Search -Static -Structure -Tools diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/.ignore ocaml-4.05.0/camlp4/Camlp4/Struct/.ignore --- ocaml-4.01.0/camlp4/Camlp4/Struct/.ignore 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/.ignore 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -Lexer.ml -Camlp4Ast.tmp.ml diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Lexer.mll ocaml-4.05.0/camlp4/Camlp4/Struct/Lexer.mll --- ocaml-4.01.0/camlp4/Camlp4/Struct/Lexer.mll 2013-08-30 11:39:33.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Lexer.mll 1970-01-01 00:00:00.000000000 +0000 @@ -1,495 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006-2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -(* The lexer definition *) - - -{ - -(** A lexical analyzer. *) - -(* FIXME interface module Make (Token : Token) |+ Note that this Token sig is not in Sig +| *) -(* : Sig.Lexer. S with module Loc = Token.Loc and module Token = Token; *) - -(* type context = -{ loc : Loc.t ; - in_comment : bool ; - |+* FIXME When True, all lexers built by [Plexer.make ()] do not lex the - quotation syntax any more. Default is False (quotations are - lexed). +| - quotations : bool }; - -value default_context : context; - -value mk : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); - -value mk' : context -> Stream.t char -> Stream.t (Token.t * Loc.t); *) -(* FIXME Beware the context argument must be given like that: - * mk' { (default_context) with ... = ... } strm - *) - -module TokenEval = Token.Eval -module Make (Token : Sig.Camlp4Token) -= struct - module Loc = Token.Loc - module Token = Token - - open Lexing - open Sig - - (* Error report *) - module Error = struct - - type t = - | Illegal_character of char - | Illegal_escape of string - | Unterminated_comment - | Unterminated_string - | Unterminated_quotation - | Unterminated_antiquot - | Unterminated_string_in_comment - | Comment_start - | Comment_not_end - | Literal_overflow of string - - exception E of t - - open Format - - let print ppf = - function - | Illegal_character c -> - fprintf ppf "Illegal character (%s)" (Char.escaped c) - | Illegal_escape s -> - fprintf ppf "Illegal backslash escape in string or character (%s)" s - | Unterminated_comment -> - fprintf ppf "Comment not terminated" - | Unterminated_string -> - fprintf ppf "String literal not terminated" - | Unterminated_string_in_comment -> - fprintf ppf "This comment contains an unterminated string literal" - | Unterminated_quotation -> - fprintf ppf "Quotation not terminated" - | Unterminated_antiquot -> - fprintf ppf "Antiquotation not terminated" - | Literal_overflow ty -> - fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty - | Comment_start -> - fprintf ppf "this is the start of a comment" - | Comment_not_end -> - fprintf ppf "this is not the end of a comment" - - let to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b - end;; - - let module M = ErrorHandler.Register(Error) in () - - open Error - - (* To store some context information: - * loc : position of the beginning of a string, quotation and comment - * in_comment: are we in a comment? - * quotations: shall we lex quotation? - * If quotations is false it's a SYMBOL token. - * antiquots : shall we lex antiquotations. - *) - - type context = - { loc : Loc.t ; - in_comment : bool ; - quotations : bool ; - antiquots : bool ; - lexbuf : lexbuf ; - buffer : Buffer.t } - - let default_context lb = - { loc = Loc.ghost ; - in_comment = false ; - quotations = true ; - antiquots = false ; - lexbuf = lb ; - buffer = Buffer.create 256 } - - (* To buffer string literals, quotations and antiquotations *) - - let store c = Buffer.add_string c.buffer (Lexing.lexeme c.lexbuf) - let istore_char c i = Buffer.add_char c.buffer (Lexing.lexeme_char c.lexbuf i) - let buff_contents c = - let contents = Buffer.contents c.buffer in - Buffer.reset c.buffer; contents - - let loc c = Loc.merge c.loc (Loc.of_lexbuf c.lexbuf) - let quotations c = c.quotations - let antiquots c = c.antiquots - let is_in_comment c = c.in_comment - let in_comment c = { (c) with in_comment = true } - let set_start_p c = c.lexbuf.lex_start_p <- Loc.start_pos c.loc - let move_start_p shift c = - let p = c.lexbuf.lex_start_p in - c.lexbuf.lex_start_p <- { (p) with pos_cnum = p.pos_cnum + shift } - - let update_loc c = { (c) with loc = Loc.of_lexbuf c.lexbuf } - let with_curr_loc f c = f (update_loc c) c.lexbuf - let parse_nested f c = - with_curr_loc f c; - set_start_p c; - buff_contents c - let shift n c = { (c) with loc = Loc.move `both n c.loc } - let store_parse f c = store c ; f c c.lexbuf - let parse f c = f c c.lexbuf - let mk_quotation quotation c name loc shift = - let s = parse_nested quotation (update_loc c) in - let contents = String.sub s 0 (String.length s - 2) in - QUOTATION { q_name = name ; - q_loc = loc ; - q_shift = shift ; - q_contents = contents } - - - (* Update the current location with file name and line number. *) - - let update_loc c file line absolute chars = - let lexbuf = c.lexbuf in - let pos = lexbuf.lex_curr_p in - let new_file = match file with - | None -> pos.pos_fname - | Some s -> s - in - lexbuf.lex_curr_p <- { pos with - pos_fname = new_file; - pos_lnum = if absolute then line else pos.pos_lnum + line; - pos_bol = pos.pos_cnum - chars; - } - - (* To convert integer literals, copied from "../parsing/lexer.mll" *) - - let cvt_int_literal s = - - int_of_string ("-" ^ s) - let cvt_int32_literal s = - Int32.neg (Int32.of_string ("-" ^ s)) - let cvt_int64_literal s = - Int64.neg (Int64.of_string ("-" ^ s)) - let cvt_nativeint_literal s = - Nativeint.neg (Nativeint.of_string ("-" ^ s)) - - - let err error loc = - raise(Loc.Exc_located(loc, Error.E error)) - - let warn error loc = - Format.eprintf "Warning: %a: %a@." Loc.print loc Error.print error - - } - - let newline = ('\010' | '\013' | "\013\010") - let blank = [' ' '\009' '\012'] - let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] - let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] - let identchar = - ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] - let ident = (lowercase|uppercase) identchar* - let locname = ident - let not_star_symbolchar = - ['$' '!' '%' '&' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~' '\\'] - let symbolchar = '*' | not_star_symbolchar - let quotchar = - ['!' '%' '&' '+' '-' '.' '/' ':' '=' '?' '@' '^' '|' '~' '\\' '*'] - let hexa_char = ['0'-'9' 'A'-'F' 'a'-'f'] - let decimal_literal = - ['0'-'9'] ['0'-'9' '_']* - let hex_literal = - '0' ['x' 'X'] hexa_char ['0'-'9' 'A'-'F' 'a'-'f' '_']* - let oct_literal = - '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* - let bin_literal = - '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* - let int_literal = - decimal_literal | hex_literal | oct_literal | bin_literal - let float_literal = - ['0'-'9'] ['0'-'9' '_']* - ('.' ['0'-'9' '_']* )? - (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? - - (* Delimitors are extended (from 3.09) in a conservative way *) - - (* These chars that can't start an expression or a pattern: *) - let safe_delimchars = ['%' '&' '/' '@' '^'] - - (* These symbols are unsafe since "[<", "[|", etc. exsist. *) - let delimchars = safe_delimchars | ['|' '<' '>' ':' '=' '.'] - - let left_delims = ['(' '[' '{'] - let right_delims = [')' ']' '}'] - - let left_delimitor = - (* At least a safe_delimchars *) - left_delims delimchars* safe_delimchars (delimchars|left_delims)* - - (* A '(' or a new super '(' without "(<" *) - | '(' (['|' ':'] delimchars*)? - (* Old brackets, no new brackets starting with "[|" or "[:" *) - | '[' ['|' ':']? - (* Old "[<","{<" and new ones *) - | ['[' '{'] delimchars* '<' - (* Old brace and new ones *) - | '{' (['|' ':'] delimchars*)? - - let right_delimitor = - (* At least a safe_delimchars *) - (delimchars|right_delims)* safe_delimchars (delimchars|right_delims)* right_delims - (* A ')' or a new super ')' without ">)" *) - | (delimchars* ['|' ':'])? ')' - (* Old brackets, no new brackets ending with "|]" or ":]" *) - | ['|' ':']? ']' - (* Old ">]",">}" and new ones *) - | '>' delimchars* [']' '}'] - (* Old brace and new ones *) - | (delimchars* ['|' ':'])? '}' - - - rule token c = parse - | newline { update_loc c None 1 false 0; NEWLINE } - | blank + as x { BLANKS x } - | "~" (lowercase identchar * as x) ':' { LABEL x } - | "?" (lowercase identchar * as x) ':' { OPTLABEL x } - | lowercase identchar * as x { LIDENT x } - | uppercase identchar * as x { UIDENT x } - | int_literal as i - { try INT(cvt_int_literal i, i) - with Failure _ -> err (Literal_overflow "int") (Loc.of_lexbuf lexbuf) } - | float_literal as f - { try FLOAT(float_of_string f, f) - with Failure _ -> err (Literal_overflow "float") (Loc.of_lexbuf lexbuf) } - | (int_literal as i) "l" - { try INT32(cvt_int32_literal i, i) - with Failure _ -> err (Literal_overflow "int32") (Loc.of_lexbuf lexbuf) } - | (int_literal as i) "L" - { try INT64(cvt_int64_literal i, i) - with Failure _ -> err (Literal_overflow "int64") (Loc.of_lexbuf lexbuf) } - | (int_literal as i) "n" - { try NATIVEINT(cvt_nativeint_literal i, i) - with Failure _ -> err (Literal_overflow "nativeint") (Loc.of_lexbuf lexbuf) } - | '"' - { with_curr_loc string c; - let s = buff_contents c in STRING (TokenEval.string s, s) } - | "'" (newline as x) "'" - { update_loc c None 1 false 1; CHAR (TokenEval.char x, x) } - | "'" ( [^ '\\' '\010' '\013'] - | '\\' (['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] - |['0'-'9'] ['0'-'9'] ['0'-'9'] - |'x' hexa_char hexa_char) - as x) "'" { CHAR (TokenEval.char x, x) } - | "'\\" (_ as c) - { err (Illegal_escape (String.make 1 c)) (Loc.of_lexbuf lexbuf) } - | "(*" - { store c; COMMENT(parse_nested comment (in_comment c)) } - | "(*)" - { warn Comment_start (Loc.of_lexbuf lexbuf) ; - parse comment (in_comment c); COMMENT (buff_contents c) } - | "*)" - { warn Comment_not_end (Loc.of_lexbuf lexbuf) ; - move_start_p (-1) c; SYMBOL "*" } - | "<<" (quotchar* as beginning) - { if quotations c - then (move_start_p (-String.length beginning); - mk_quotation quotation c "" "" 2) - else parse (symbolchar_star ("<<" ^ beginning)) c } - | "<<>>" - { if quotations c - then QUOTATION { q_name = ""; q_loc = ""; q_shift = 2; q_contents = "" } - else parse (symbolchar_star "<<>>") c } - | "<@" - { if quotations c then with_curr_loc maybe_quotation_at c - else parse (symbolchar_star "<@") c } - | "<:" - { if quotations c then with_curr_loc maybe_quotation_colon c - else parse (symbolchar_star "<:") c } - | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* - ("\"" ([^ '\010' '\013' '"' ] * as name) "\"")? - [^ '\010' '\013'] * newline - { let inum = int_of_string num - in update_loc c name inum true 0; LINE_DIRECTIVE(inum, name) } - | '(' (not_star_symbolchar as op) ')' - { ESCAPED_IDENT (String.make 1 op) } - | '(' (not_star_symbolchar symbolchar* not_star_symbolchar as op) ')' - { ESCAPED_IDENT op } - | '(' (not_star_symbolchar symbolchar* as op) blank+ ')' - { ESCAPED_IDENT op } - | '(' blank+ (symbolchar* not_star_symbolchar as op) ')' - { ESCAPED_IDENT op } - | '(' blank+ (symbolchar+ as op) blank+ ')' - { ESCAPED_IDENT op } - | ( "#" | "`" | "'" | "," | "." | ".." | ":" | "::" - | ":=" | ":>" | ";" | ";;" | "_" - | left_delimitor | right_delimitor ) as x { SYMBOL x } - | '$' { if antiquots c - then with_curr_loc dollar (shift 1 c) - else parse (symbolchar_star "$") c } - | ['~' '?' '!' '=' '<' '>' '|' '&' '@' '^' '+' '-' '*' '/' '%' '\\'] symbolchar * - as x { SYMBOL x } - | eof - { let pos = lexbuf.lex_curr_p in - lexbuf.lex_curr_p <- { pos with pos_bol = pos.pos_bol + 1 ; - pos_cnum = pos.pos_cnum + 1 }; EOI } - | _ as c { err (Illegal_character c) (Loc.of_lexbuf lexbuf) } - - and comment c = parse - "(*" - { store c; with_curr_loc comment c; parse comment c } - | "*)" { store c } - | '<' (':' ident)? ('@' locname)? '<' - { store c; - if quotations c then with_curr_loc quotation c; parse comment c } - | ident { store_parse comment c } - | "\"" - { store c; - begin try with_curr_loc string c - with Loc.Exc_located(_, Error.E Unterminated_string) -> - err Unterminated_string_in_comment (loc c) - end; - Buffer.add_char c.buffer '"'; - parse comment c } - | "''" { store_parse comment c } - | "'''" { store_parse comment c } - | "'" newline "'" - { update_loc c None 1 false 1; store_parse comment c } - | "'" [^ '\\' '\'' '\010' '\013' ] "'" { store_parse comment c } - | "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r' ' '] "'" { store_parse comment c } - | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { store_parse comment c } - | "'\\" 'x' hexa_char hexa_char "'" { store_parse comment c } - | eof - { err Unterminated_comment (loc c) } - | newline - { update_loc c None 1 false 0; store_parse comment c } - | _ { store_parse comment c } - - and string c = parse - '"' { set_start_p c } - | '\\' newline ([' ' '\t'] * as space) - { update_loc c None 1 false (String.length space); - store_parse string c } - | '\\' ['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] { store_parse string c } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_parse string c } - | '\\' 'x' hexa_char hexa_char { store_parse string c } - | '\\' (_ as x) - { if is_in_comment c - then store_parse string c - else begin - warn (Illegal_escape (String.make 1 x)) (Loc.of_lexbuf lexbuf); - store_parse string c - end } - | newline - { update_loc c None 1 false 0; store_parse string c } - | eof { err Unterminated_string (loc c) } - | _ { store_parse string c } - - and symbolchar_star beginning c = parse - | symbolchar* as tok { move_start_p (-String.length beginning) c ; - SYMBOL(beginning ^ tok) } - - and maybe_quotation_at c = parse - | (ident as loc) '<' - { mk_quotation quotation c "" loc (1 + String.length loc) } - | symbolchar* as tok { SYMBOL("<@" ^ tok) } - - and maybe_quotation_colon c = parse - | (ident as name) '<' - { mk_quotation quotation c name "" (1 + String.length name) } - | (ident as name) '@' (locname as loc) '<' - { mk_quotation quotation c name loc - (2 + String.length loc + String.length name) } - | symbolchar* as tok { SYMBOL("<:" ^ tok) } - - and quotation c = parse - | '<' (':' ident)? ('@' locname)? '<' { store c ; - with_curr_loc quotation c ; - parse quotation c } - | ">>" { store c } - | eof { err Unterminated_quotation (loc c) } - | newline { update_loc c None 1 false 0 ; - store_parse quotation c } - | _ { store_parse quotation c } - - and dollar c = parse - | '$' { set_start_p c; ANTIQUOT("", "") } - | ('`'? (identchar*|['.' '!']+) as name) ':' - { with_curr_loc (antiquot name) (shift (1 + String.length name) c) } - | _ { store_parse (antiquot "") c } - - and antiquot name c = parse - | '$' { set_start_p c; ANTIQUOT(name, buff_contents c) } - | eof { err Unterminated_antiquot (loc c) } - | newline - { update_loc c None 1 false 0; store_parse (antiquot name) c } - | '<' (':' ident)? ('@' locname)? '<' - { store c; with_curr_loc quotation c; parse (antiquot name) c } - | _ { store_parse (antiquot name) c } - - { - - let lexing_store s buff max = - let rec self n s = - if n >= max then n - else - match Stream.peek s with - | Some x -> - Stream.junk s; - buff.[n] <- x; - succ n - | _ -> n - in - self 0 s - - let from_context c = - let next _ = - let tok = with_curr_loc token c in - let loc = Loc.of_lexbuf c.lexbuf in - Some ((tok, loc)) - in Stream.from next - - let from_lexbuf ?(quotations = true) lb = - let c = { (default_context lb) with - loc = Loc.of_lexbuf lb; - antiquots = !Camlp4_config.antiquotations; - quotations = quotations } - in from_context c - - let setup_loc lb loc = - let start_pos = Loc.start_pos loc in - lb.lex_abs_pos <- start_pos.pos_cnum; - lb.lex_curr_p <- start_pos - - let from_string ?quotations loc str = - let lb = Lexing.from_string str in - setup_loc lb loc; - from_lexbuf ?quotations lb - - let from_stream ?quotations loc strm = - let lb = Lexing.from_function (lexing_store strm) in - setup_loc lb loc; - from_lexbuf ?quotations lb - - let mk () loc strm = - from_stream ~quotations:!Camlp4_config.quotations loc strm -end -} diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Loc.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Loc.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Loc.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Loc.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,307 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* camlp4r *) - -open Format; - -(* FIXME - Study these 2 others implementations which change the ghost - handling: - - type pos = ... the same ... - - 1/ - - type loc = { - file_name : string; - start : pos; - stop : pos - }; - - type t = - [ Nowhere - | Ghost of loc (* the closest non ghost loc *) - | Concrete of loc ]; - - 2/ - - type loc = { - file_name : string; - start : pos; - stop : pos - }; - - type t = option loc; - - 3/ - - type t = { - file_name : option string; - start : pos; - stop : pos - }; - -*) - -type pos = { - line : int; - bol : int; - off : int -}; - -type t = { - file_name : string; - start : pos; - stop : pos; - ghost : bool -}; - -(* Debug section *) -value dump_sel f x = - let s = - match x with - [ `start -> "`start" - | `stop -> "`stop" - | `both -> "`both" - | _ -> "" ] - in pp_print_string f s; -value dump_pos f x = - fprintf f "@[{ line = %d ;@ bol = %d ;@ off = %d } : pos@]" - x.line x.bol x.off; -value dump_long f x = - fprintf f - "@[{ file_name = %s ;@ start = %a (%d-%d);@ stop = %a (%d);@ ghost = %b@ } : Loc.t@]" - x.file_name dump_pos x.start (x.start.off - x.start.bol) - (x.stop.off - x.start.bol) dump_pos x.stop - (x.stop.off - x.stop.bol) x.ghost; -value dump f x = - fprintf f "[%S: %d:%d-%d %d:%d%t]" - x.file_name x.start.line (x.start.off - x.start.bol) - (x.stop.off - x.start.bol) x.stop.line (x.stop.off - x.stop.bol) - (fun o -> if x.ghost then fprintf o " (ghost)" else ()); - -value start_pos = { line = 1 ; bol = 0 ; off = 0 }; - -value ghost = - { file_name = "ghost-location"; - start = start_pos; - stop = start_pos; - ghost = True }; - -value mk file_name = - debug loc "mk %s@\n" file_name in - { file_name = file_name; - start = start_pos; - stop = start_pos; - ghost = False }; - -value of_tuple (file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost) = - { file_name = file_name; - start = { line = start_line ; bol = start_bol ; off = start_off }; - stop = { line = stop_line ; bol = stop_bol ; off = stop_off }; - ghost = ghost }; - -value to_tuple - { file_name = file_name; - start = { line = start_line ; bol = start_bol ; off = start_off }; - stop = { line = stop_line ; bol = stop_bol ; off = stop_off }; - ghost = ghost } = - (file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost); - -value pos_of_lexing_position p = - let pos = - { line = p.Lexing.pos_lnum ; - bol = p.Lexing.pos_bol ; - off = p.Lexing.pos_cnum } in - debug loc "pos_of_lexing_position: %a@\n" dump_pos pos in - pos; - -value pos_to_lexing_position p file_name = - (* debug loc "pos_to_lexing_position: %a@\n" dump_pos p in *) - { Lexing. - pos_fname = file_name; - pos_lnum = p.line ; - pos_bol = p.bol ; - pos_cnum = p.off }; - -value better_file_name a b = - match (a, b) with - [ ("", "") -> a - | ("", x) -> x - | (x, "") -> x - | ("-", x) -> x - | (x, "-") -> x - | (x, _) -> x ]; - -value of_lexbuf lb = - let start = Lexing.lexeme_start_p lb - and stop = Lexing.lexeme_end_p lb in - let loc = - { file_name = better_file_name start.Lexing.pos_fname stop.Lexing.pos_fname; - start = pos_of_lexing_position start; - stop = pos_of_lexing_position stop; - ghost = False } in - debug loc "of_lexbuf: %a@\n" dump loc in - loc; - -value of_lexing_position pos = - let loc = - { file_name = pos.Lexing.pos_fname; - start = pos_of_lexing_position pos; - stop = pos_of_lexing_position pos; - ghost = False } in - debug loc "of_lexing_position: %a@\n" dump loc in - loc; - -value to_ocaml_location x = - debug loc "to_ocaml_location: %a@\n" dump x in - { Camlp4_import.Location. - loc_start = pos_to_lexing_position x.start x.file_name; - loc_end = pos_to_lexing_position x.stop x.file_name; - loc_ghost = x.ghost }; - -value of_ocaml_location { Camlp4_import.Location.loc_start = a; loc_end = b; loc_ghost = g } = - let res = - { file_name = better_file_name a.Lexing.pos_fname b.Lexing.pos_fname; - start = pos_of_lexing_position a; - stop = pos_of_lexing_position b; - ghost = g } in - debug loc "of_ocaml_location: %a@\n" dump res in - res; - -value start_pos x = pos_to_lexing_position x.start x.file_name; -value stop_pos x = pos_to_lexing_position x.stop x.file_name; - -value merge a b = - if a == b then - debug loc "trivial merge@\n" in - a - else - let r = - match (a.ghost, b.ghost) with - [ (False, False) -> - (* FIXME if a.file_name <> b.file_name then - raise (Invalid_argument - (sprintf "Loc.merge: Filenames must be equal: %s <> %s" - a.file_name b.file_name)) *) - (* else *) - { (a) with stop = b.stop } - | (True, True) -> { (a) with stop = b.stop } - | (True, _) -> { (a) with stop = b.stop } - | (_, True) -> { (b) with start = a.start } ] - in debug loc "@[merge %a@ %a@ %a@]@\n" dump a dump b dump r in r; - -value join x = { (x) with stop = x.start }; - -value map f start_stop_both x = - match start_stop_both with - [ `start -> { (x) with start = f x.start } - | `stop -> { (x) with stop = f x.stop } - | `both -> { (x) with start = f x.start; stop = f x.stop } ]; - -value move_pos chars x = { (x) with off = x.off + chars }; - -value move s chars x = - debug loc "move %a %d %a@\n" dump_sel s chars dump x in - map (move_pos chars) s x; - -value move_line lines x = - debug loc "move_line %d %a@\n" lines dump x in - let move_line_pos x = - { (x) with line = x.line + lines ; bol = x.off } - in map move_line_pos `both x; - -value shift width x = - { (x) with start = x.stop ; stop = move_pos width x.stop }; - -value file_name x = x.file_name; -value start_line x = x.start.line; -value stop_line x = x.stop.line; -value start_bol x = x.start.bol; -value stop_bol x = x.stop.bol; -value start_off x = x.start.off; -value stop_off x = x.stop.off; -value is_ghost x = x.ghost; - -value set_file_name s x = - debug loc "set_file_name: %a@\n" dump x in - { (x) with file_name = s }; - -value ghostify x = - debug loc "ghostify: %a@\n" dump x in - { (x) with ghost = True }; - -value make_absolute x = - debug loc "make_absolute: %a@\n" dump x in - let pwd = Sys.getcwd () in - if Filename.is_relative x.file_name then - { (x) with file_name = Filename.concat pwd x.file_name } - else x; - -value strictly_before x y = - let b = x.stop.off < y.start.off && x.file_name = y.file_name in - debug loc "%a [strictly_before] %a => %b@\n" dump x dump y b in - b; - -value to_string x = do { - let (a, b) = (x.start, x.stop) in - let res = sprintf "File \"%s\", line %d, characters %d-%d" - x.file_name a.line (a.off - a.bol) (b.off - a.bol) in - if x.start.line <> x.stop.line then - sprintf "%s (end at line %d, character %d)" - res x.stop.line (b.off - b.bol) - else res -}; - -value print out x = pp_print_string out (to_string x); - -value check x msg = - if ((start_line x) > (stop_line x) || - (start_bol x) > (stop_bol x) || - (start_off x) > (stop_off x) || - (start_line x) < 0 || (stop_line x) < 0 || - (start_bol x) < 0 || (stop_bol x) < 0 || - (start_off x) < 0 || (stop_off x) < 0) - (* Here, we don't check - (start_off x) < (start_bol x) || (stop_off x) < (start_bol x) - since the lexer is called on antiquotations, with off=0, but line and bolpos - have "correct" values *) - then do { - eprintf "*** Warning: (%s) strange positions ***\n%a@\n" msg print x; - False - } - else True; - -exception Exc_located of t and exn; - -ErrorHandler.register - (fun ppf -> - fun [ Exc_located loc exn -> - fprintf ppf "%a:@\n%a" print loc ErrorHandler.print exn - | exn -> raise exn ]); - -value name = ref "_loc"; - -value raise loc exc = - match exc with - [ Exc_located _ _ -> raise exc - | _ -> raise (Exc_located loc exc) ] -; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Loc.mli ocaml-4.05.0/camlp4/Camlp4/Struct/Loc.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/Loc.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Loc.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -include Sig.Loc; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Quotation.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Quotation.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Quotation.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Quotation.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,167 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2002-2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -module Make (Ast : Sig.Camlp4Ast) -: Sig.Quotation with module Ast = Ast -= struct - module Ast = Ast; - module DynAst = DynAst.Make Ast; - module Loc = Ast.Loc; - open Format; - open Sig; - - type expand_fun 'a = Loc.t -> option string -> string -> 'a; - - module Exp_key = DynAst.Pack(struct - type t 'a = unit; - end); - - module Exp_fun = DynAst.Pack(struct - type t 'a = expand_fun 'a; - end); - - value expanders_table = - (ref [] : ref (list ((string * Exp_key.pack) * Exp_fun.pack))); - - value default = ref ""; - value translate = ref (fun x -> x); - - value expander_name name = - match translate.val name with - [ "" -> default.val - | name -> name ]; - - value find name tag = - let key = (expander_name name, Exp_key.pack tag ()) in - Exp_fun.unpack tag (List.assoc key expanders_table.val); - - value add name tag f = - let elt = ((name, Exp_key.pack tag ()), Exp_fun.pack tag f) in - expanders_table.val := [elt :: expanders_table.val]; - - value dump_file = ref None; - - module Error = struct - type error = - [ Finding - | Expanding - | ParsingResult of Loc.t and string - | Locating ]; - type t = (string * string * error * exn); - exception E of t; - - value print ppf (name, position, ctx, exn) = - let name = if name = "" then default.val else name in - let pp x = fprintf ppf "@?@[<2>While %s %S in a position of %S:" x name position in - let () = - match ctx with - [ Finding -> begin - pp "finding quotation"; - if expanders_table.val = [] then - fprintf ppf "@ There is no quotation expander available." - else - begin - fprintf ppf "@ @[Available quotation expanders are:@\n"; - List.iter begin fun ((s,t),_) -> - fprintf ppf "@[<2>%s@ (in@ a@ position@ of %a)@]@ " - s Exp_key.print_tag t - end expanders_table.val; - fprintf ppf "@]" - end - end - | Expanding -> pp "expanding quotation" - | Locating -> pp "parsing" - | ParsingResult loc str -> - let () = pp "parsing result of quotation" in - match dump_file.val with - [ Some dump_file -> - let () = fprintf ppf " dumping result...\n" in - try - let oc = open_out_bin dump_file in - begin - output_string oc str; - output_string oc "\n"; - flush oc; - close_out oc; - fprintf ppf "%a:" Loc.print (Loc.set_file_name dump_file loc); - end - with _ -> - fprintf ppf - "Error while dumping result in file %S; dump aborted" - dump_file - | None -> - fprintf ppf - "\n(consider setting variable Quotation.dump_file, or using the -QD option)" - ] - ] - in fprintf ppf "@\n%a@]@." ErrorHandler.print exn; - - value to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b; - end; - let module M = ErrorHandler.Register Error in (); - open Error; - - value expand_quotation loc expander pos_tag quot = - debug quot "expand_quotation: name: %s, str: %S@." quot.q_name quot.q_contents in - let loc_name_opt = if quot.q_loc = "" then None else Some quot.q_loc in - try expander loc loc_name_opt quot.q_contents with - [ Loc.Exc_located _ (Error.E _) as exc -> - raise exc - | Loc.Exc_located iloc exc -> - let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in - raise (Loc.Exc_located iloc exc1) - | exc -> - let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in - raise (Loc.Exc_located loc exc1) ]; - - value parse_quotation_result parse loc quot pos_tag str = - try parse loc str with - [ Loc.Exc_located iloc (Error.E (n, pos_tag, Expanding, exc)) -> - let ctx = ParsingResult iloc quot.q_contents in - let exc1 = Error.E (n, pos_tag, ctx, exc) in - raise (Loc.Exc_located iloc exc1) - | Loc.Exc_located iloc (Error.E _ as exc) -> - raise (Loc.Exc_located iloc exc) - | Loc.Exc_located iloc exc -> - let ctx = ParsingResult iloc quot.q_contents in - let exc1 = Error.E (quot.q_name, pos_tag, ctx, exc) in - raise (Loc.Exc_located iloc exc1) ]; - - value expand loc quotation tag = - let pos_tag = DynAst.string_of_tag tag in - let name = quotation.q_name in - debug quot "handle_quotation: name: %s, str: %S@." name quotation.q_contents in - let expander = - try find name tag - with - [ Loc.Exc_located _ (Error.E _) as exc -> raise exc - | Loc.Exc_located qloc exc -> - raise (Loc.Exc_located qloc (Error.E (name, pos_tag, Finding, exc))) - | exc -> - raise (Loc.Exc_located loc (Error.E (name, pos_tag, Finding, exc))) ] - in - let loc = Loc.join (Loc.move `start quotation.q_shift loc) in - expand_quotation loc expander pos_tag quotation; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Token.ml ocaml-4.05.0/camlp4/Camlp4/Struct/Token.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Token.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Token.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,244 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -open Format; - -module Make (Loc : Sig.Loc) -: Sig.Camlp4Token with module Loc = Loc -= struct - module Loc = Loc; - open Sig; - type t = camlp4_token; - type token = t; - - value to_string = - fun - [ KEYWORD s -> sprintf "KEYWORD %S" s - | SYMBOL s -> sprintf "SYMBOL %S" s - | LIDENT s -> sprintf "LIDENT %S" s - | UIDENT s -> sprintf "UIDENT %S" s - | INT _ s -> sprintf "INT %s" s - | INT32 _ s -> sprintf "INT32 %sd" s - | INT64 _ s -> sprintf "INT64 %sd" s - | NATIVEINT _ s-> sprintf "NATIVEINT %sd" s - | FLOAT _ s -> sprintf "FLOAT %s" s - | CHAR _ s -> sprintf "CHAR '%s'" s - | STRING _ s -> sprintf "STRING \"%s\"" s - (* here it's not %S since the string is already escaped *) - | LABEL s -> sprintf "LABEL %S" s - | OPTLABEL s -> sprintf "OPTLABEL %S" s - | ANTIQUOT n s -> sprintf "ANTIQUOT %s: %S" n s - | QUOTATION x -> sprintf "QUOTATION { q_name=%S; q_loc=%S; q_shift=%d; q_contents=%S }" - x.q_name x.q_loc x.q_shift x.q_contents - | COMMENT s -> sprintf "COMMENT %S" s - | BLANKS s -> sprintf "BLANKS %S" s - | NEWLINE -> sprintf "NEWLINE" - | EOI -> sprintf "EOI" - | ESCAPED_IDENT s -> sprintf "ESCAPED_IDENT %S" s - | LINE_DIRECTIVE i None -> sprintf "LINE_DIRECTIVE %d" i - | LINE_DIRECTIVE i (Some s) -> sprintf "LINE_DIRECTIVE %d %S" i s ]; - - value print ppf x = pp_print_string ppf (to_string x); - - value match_keyword kwd = - fun - [ KEYWORD kwd' when kwd = kwd' -> True - | _ -> False ]; - - value extract_string = - fun - [ KEYWORD s | SYMBOL s | LIDENT s | UIDENT s | INT _ s | INT32 _ s | - INT64 _ s | NATIVEINT _ s | FLOAT _ s | CHAR _ s | STRING _ s | - LABEL s | OPTLABEL s | COMMENT s | BLANKS s | ESCAPED_IDENT s -> s - | tok -> - invalid_arg ("Cannot extract a string from this token: "^ - to_string tok) ]; - - module Error = struct - type t = - [ Illegal_token of string - | Keyword_as_label of string - | Illegal_token_pattern of string and string - | Illegal_constructor of string ]; - - exception E of t; - - value print ppf = - fun - [ Illegal_token s -> - fprintf ppf "Illegal token (%s)" s - | Keyword_as_label kwd -> - fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd - | Illegal_token_pattern p_con p_prm -> - fprintf ppf "Illegal token pattern: %s %S" p_con p_prm - | Illegal_constructor con -> - fprintf ppf "Illegal constructor %S" con ]; - - value to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b; - end; - let module M = ErrorHandler.Register Error in (); - - module Filter = struct - type token_filter = stream_filter t Loc.t; - - type t = - { is_kwd : string -> bool; - filter : mutable token_filter }; - - value err error loc = - raise (Loc.Exc_located loc (Error.E error)); - - value keyword_conversion tok is_kwd = - match tok with - [ SYMBOL s | LIDENT s | UIDENT s when is_kwd s -> KEYWORD s - | ESCAPED_IDENT s -> LIDENT s - | _ -> tok ]; - - value check_keyword_as_label tok loc is_kwd = - let s = - match tok with - [ LABEL s -> s - | OPTLABEL s -> s - | _ -> "" ] - in if s <> "" && is_kwd s then err (Error.Keyword_as_label s) loc else (); - - value check_unknown_keywords tok loc = - match tok with - [ SYMBOL s -> err (Error.Illegal_token s) loc - | _ -> () ]; - - value error_no_respect_rules p_con p_prm = - raise (Error.E (Error.Illegal_token_pattern p_con p_prm)); - - value check_keyword _ = True; - (* FIXME let lb = Lexing.from_string s in - let next () = token default_context lb in - try - match next () with - [ SYMBOL _ | UIDENT _ | LIDENT _ -> (next () = EOI) - | _ -> False ] - with [ Stream.Error _ -> False ]; *) - - value error_on_unknown_keywords = ref False; - - value rec ignore_layout = - parser - [ [: `(COMMENT _ | BLANKS _ | NEWLINE | LINE_DIRECTIVE _ _, _); s :] -> - ignore_layout s - | [: ` x; s :] -> [: ` x; ignore_layout s :] - | [: :] -> [: :] ]; - - value mk is_kwd = - { is_kwd = is_kwd; - filter = ignore_layout }; - - value filter x = - let f tok loc = do { - let tok = keyword_conversion tok x.is_kwd; - check_keyword_as_label tok loc x.is_kwd; - if error_on_unknown_keywords.val - then check_unknown_keywords tok loc else (); - debug token "@[Lexer before filter:@ %a@ at@ %a@]@." - print tok Loc.dump loc in - (tok, loc) - } in - let rec filter = - parser - [ [: `(tok, loc); s :] -> [: ` f tok loc; filter s :] - | [: :] -> [: :] ] - in - let rec tracer = (* FIXME add a debug block construct *) - parser - [ [: `((_tok, _loc) as x); xs :] -> - debug token "@[Lexer after filter:@ %a@ at@ %a@]@." - print _tok Loc.dump _loc in - [: ` x; tracer xs :] - | [: :] -> [: :] ] - in fun strm -> tracer (x.filter (filter strm)); - - value define_filter x f = x.filter := f x.filter; - - value keyword_added _ _ _ = (); - value keyword_removed _ _ = (); - end; - -end; - -(* Char and string tokens to real chars and string *) -module Eval = struct - - value valch x = Char.code x - Char.code '0'; - value valch_hex x = - let d = Char.code x in - if d >= 97 then d - 87 - else if d >= 65 then d - 55 - else d - 48; - - value rec skip_indent = parser - [ [: `' ' | '\t'; s :] -> skip_indent s - | [: :] -> () ]; - - value skip_opt_linefeed = parser - [ [: `'\010' :] -> () - | [: :] -> () ]; - - value chr c = - if c < 0 || c > 255 then failwith "invalid char token" else Char.chr c; - - value rec backslash = parser - [ [: `'\010' :] -> '\010' - | [: `'\013' :] -> '\013' - | [: `'n' :] -> '\n' - | [: `'r' :] -> '\r' - | [: `'t' :] -> '\t' - | [: `'b' :] -> '\b' - | [: `'\\' :] -> '\\' - | [: `'"' :] -> '"' - | [: `'\'' :] -> '\'' - | [: `' ' :] -> ' ' - | [: `('0'..'9' as c1); `('0'..'9' as c2); `('0'..'9' as c3) :] -> - chr (100 * (valch c1) + 10 * (valch c2) + (valch c3)) - | [: `'x'; `('0'..'9' | 'a'..'f' | 'A'..'F' as c1) ; - `('0'..'9' | 'a'..'f' | 'A'..'F' as c2) :] -> - chr (16 * (valch_hex c1) + (valch_hex c2)) ]; - - value rec backslash_in_string strict store = parser - [ [: `'\010'; s :] -> skip_indent s - | [: `'\013'; s :] -> do { skip_opt_linefeed s; skip_indent s } - | [: x = backslash :] -> store x - | [: `c when not strict :] -> do { store '\\'; store c } - | [: :] -> failwith "invalid string token" ]; - - value char s = - if String.length s = 1 then s.[0] - else if String.length s = 0 then failwith "invalid char token" - else match Stream.of_string s with parser - [ [: `'\\'; x = backslash :] -> x - | [: :] -> failwith "invalid char token" ]; - - value string ?strict s = - let buf = Buffer.create 23 in - let store = Buffer.add_char buf in - let rec parse = parser - [ [: `'\\'; _ = backslash_in_string (strict <> None) store; s :] -> parse s - | [: `c; s :] -> do { store c; parse s } - | [: :] -> Buffer.contents buf ] - in parse (Stream.of_string s); -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Token.mli ocaml-4.05.0/camlp4/Camlp4/Struct/Token.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/Token.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct/Token.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Loc : Sig.Loc) : Sig.Camlp4Token with module Loc = Loc; - -module Eval : sig - value char : string -> char; - (** Convert a char token, where the escape sequences (backslashes) - remain to be interpreted; raise [Failure] if an - incorrect backslash sequence is found; [Token.Eval.char (Char.escaped c)] - returns [c] *) - - value string : ?strict:unit -> string -> string; - (** [Taken.Eval.string strict s] - Convert a string token, where the escape sequences (backslashes) - remain to be interpreted; raise [Failure] if [strict] and an - incorrect backslash sequence is found; - [Token.Eval.string strict (String.escaped s)] returns [s] *) -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct.mlpack ocaml-4.05.0/camlp4/Camlp4/Struct.mlpack --- ocaml-4.01.0/camlp4/Camlp4/Struct.mlpack 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4/Struct.mlpack 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ -AstFilters -Camlp4Ast -Camlp4Ast2OCamlAst -CleanAst -CommentFilter -DynLoader -EmptyError -EmptyPrinter -FreeVars -Lexer -Loc -Quotation -Token -Grammar -DynAst diff -Nru ocaml-4.01.0/camlp4/Camlp4Bin.ml ocaml-4.05.0/camlp4/Camlp4Bin.ml --- ocaml-4.01.0/camlp4/Camlp4Bin.ml 2013-08-30 11:39:33.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4Bin.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,325 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -open Camlp4; -open PreCast.Syntax; -open PreCast; -open Format; -module CleanAst = Camlp4.Struct.CleanAst.Make Ast; -module SSet = Set.Make String; - -value pa_r = "Camlp4OCamlRevisedParser"; -value pa_rr = "Camlp4OCamlReloadedParser"; -value pa_o = "Camlp4OCamlParser"; -value pa_rp = "Camlp4OCamlRevisedParserParser"; -value pa_op = "Camlp4OCamlParserParser"; -value pa_g = "Camlp4GrammarParser"; -value pa_m = "Camlp4MacroParser"; -value pa_qb = "Camlp4QuotationCommon"; -value pa_q = "Camlp4QuotationExpander"; -value pa_rq = "Camlp4OCamlRevisedQuotationExpander"; -value pa_oq = "Camlp4OCamlOriginalQuotationExpander"; -value pa_l = "Camlp4ListComprehension"; - -open Register; - -value dyn_loader = ref (fun []); -value rcall_callback = ref (fun () -> ()); -value loaded_modules = ref SSet.empty; -value add_to_loaded_modules name = - loaded_modules.val := SSet.add name loaded_modules.val; - -value (objext,libext) = - if DynLoader.is_native then (".cmxs",".cmxs") - else (".cmo",".cma"); - -value rewrite_and_load n x = - let dyn_loader = dyn_loader.val () in - let find_in_path = DynLoader.find_in_path dyn_loader in - let real_load name = do { - add_to_loaded_modules name; - DynLoader.load dyn_loader name - } in - let load = List.iter begin fun n -> - if SSet.mem n loaded_modules.val || List.mem n Register.loaded_modules.val then () - else begin - add_to_loaded_modules n; - DynLoader.load dyn_loader (n ^ objext); - end - end in - do { - match (n, String.lowercase x) with - [ ("Parsers"|"", "pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" | "camlp4ocamlrevisedparser.cmo") -> load [pa_r] - | ("Parsers"|"", "rr" | "reloaded" | "ocamlreloaded" | "camlp4ocamlreloadedparser.cmo") -> load [pa_rr] - | ("Parsers"|"", "pa_o.cmo" | "o" | "ocaml" | "camlp4ocamlparser.cmo") -> load [pa_r; pa_o] - | ("Parsers"|"", "pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo") -> load [pa_r; pa_rp] - | ("Parsers"|"", "pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo") -> load [pa_r; pa_o; pa_rp; pa_op] - | ("Parsers"|"", "pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | "camlp4grammarparser.cmo") -> load [pa_g] - | ("Parsers"|"", "pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo") -> load [pa_m] - | ("Parsers"|"", "q" | "camlp4quotationexpander.cmo") -> load [pa_qb; pa_q] - | ("Parsers"|"", "q_mlast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo") -> load [pa_qb; pa_rq] - | ("Parsers"|"", "oq" | "camlp4ocamloriginalquotationexpander.cmo") -> load [pa_r; pa_o; pa_qb; pa_oq] - | ("Parsers"|"", "rf") -> load [pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m] - | ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m] - | ("Parsers"|"", "comp" | "camlp4listcomprehension.cmo") -> load [pa_l] - | ("Filters"|"", "lift" | "camlp4astlifter.cmo") -> load ["Camlp4AstLifter"] - | ("Filters"|"", "exn" | "camlp4exceptiontracer.cmo") -> load ["Camlp4ExceptionTracer"] - | ("Filters"|"", "prof" | "camlp4profiler.cmo") -> load ["Camlp4Profiler"] - (* map is now an alias of fold since fold handles map too *) - | ("Filters"|"", "map" | "camlp4mapgenerator.cmo") -> load ["Camlp4FoldGenerator"] - | ("Filters"|"", "fold" | "camlp4foldgenerator.cmo") -> load ["Camlp4FoldGenerator"] - | ("Filters"|"", "meta" | "camlp4metagenerator.cmo") -> load ["Camlp4MetaGenerator"] - | ("Filters"|"", "trash" | "camlp4trashremover.cmo") -> load ["Camlp4TrashRemover"] - | ("Filters"|"", "striploc" | "camlp4locationstripper.cmo") -> load ["Camlp4LocationStripper"] - | ("Printers"|"", "pr_r.cmo" | "r" | "ocamlr" | "camlp4ocamlrevisedprinter.cmo") -> - Register.enable_ocamlr_printer () - | ("Printers"|"", "pr_o.cmo" | "o" | "ocaml" | "camlp4ocamlprinter.cmo") -> - Register.enable_ocaml_printer () - | ("Printers"|"", "pr_dump.cmo" | "p" | "dumpocaml" | "camlp4ocamlastdumper.cmo") -> - Register.enable_dump_ocaml_ast_printer () - | ("Printers"|"", "d" | "dumpcamlp4" | "camlp4astdumper.cmo") -> - Register.enable_dump_camlp4_ast_printer () - | ("Printers"|"", "a" | "auto" | "camlp4autoprinter.cmo") -> - load ["Camlp4AutoPrinter"] - | _ -> - let y = "Camlp4"^n^"/"^x^objext in - real_load (try find_in_path y with [ Not_found -> x ]) ]; - rcall_callback.val (); - }; - -value print_warning = eprintf "%a:\n%s@." Loc.print; - -value rec parse_file dyn_loader name pa getdir = - let directive_handler = Some (fun ast -> - match getdir ast with - [ Some x -> - match x with - [ (_, "load", s) -> do { rewrite_and_load "" s; None } - | (_, "directory", s) -> do { DynLoader.include_dir dyn_loader s; None } - | (_, "use", s) -> Some (parse_file dyn_loader s pa getdir) - | (_, "default_quotation", s) -> do { Quotation.default.val := s; None } - | (loc, _, _) -> Loc.raise loc (Stream.Error "bad directive") ] - | None -> None ]) in - let loc = Loc.mk name - in do { - current_warning.val := print_warning; - let ic = if name = "-" then stdin else open_in_bin name; - let cs = Stream.of_channel ic; - let clear () = if name = "-" then () else close_in ic; - let phr = - try pa ?directive_handler loc cs - with x -> do { clear (); raise x }; - clear (); - phr - }; - -value output_file = ref None; - -value process dyn_loader name pa pr clean fold_filters getdir = - let ast = parse_file dyn_loader name pa getdir in - let ast = fold_filters (fun t filter -> filter t) ast in - let ast = clean ast in - pr ?input_file:(Some name) ?output_file:output_file.val ast; - -value gind = - fun - [ <:sig_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s) - | _ -> None ]; - -value gimd = - fun - [ <:str_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s) - | _ -> None ]; - -value process_intf dyn_loader name = - process dyn_loader name CurrentParser.parse_interf CurrentPrinter.print_interf - (new CleanAst.clean_ast)#sig_item - AstFilters.fold_interf_filters gind; -value process_impl dyn_loader name = - process dyn_loader name CurrentParser.parse_implem CurrentPrinter.print_implem - (new CleanAst.clean_ast)#str_item - AstFilters.fold_implem_filters gimd; - -value just_print_the_version () = - do { printf "%s@." Camlp4_config.version; exit 0 }; - -value print_version () = - do { eprintf "Camlp4 version %s@." Camlp4_config.version; exit 0 }; - -value print_stdlib () = - do { printf "%s@." Camlp4_config.camlp4_standard_library; exit 0 }; - -value usage ini_sl ext_sl = - do { - eprintf "\ -Usage: camlp4 [load-options] [--] [other-options]\n\ -Options:\n\ -.ml Parse this implementation file\n\ -.mli Parse this interface file\n\ -.%s Load this module inside the Camlp4 core@." -(if DynLoader.is_native then "cmxs " else "(cmo|cma)") -; - Options.print_usage_list ini_sl; - (* loop (ini_sl @ ext_sl) where rec loop = - fun - [ [(y, _, _) :: _] when y = "-help" -> () - | [_ :: sl] -> loop sl - | [] -> eprintf " -help Display this list of options.@." ]; *) - if ext_sl <> [] then do { - eprintf "Options added by loaded object files:@."; - Options.print_usage_list ext_sl; - } - else (); - }; - -value warn_noassert () = - do { - eprintf "\ -camlp4 warning: option -noassert is obsolete\n\ -You should give the -noassert option to the ocaml compiler instead.@."; - }; - -type file_kind = - [ Intf of string - | Impl of string - | Str of string - | ModuleImpl of string - | IncludeDir of string ]; - -value search_stdlib = ref True; -value print_loaded_modules = ref False; -value (task, do_task) = - let t = ref None in - let task f x = - let () = Camlp4_config.current_input_file.val := x in - t.val := Some (if t.val = None then (fun _ -> f x) - else (fun usage -> usage ())) in - let do_task usage = match t.val with [ Some f -> f usage | None -> () ] in - (task, do_task); -value input_file x = - let dyn_loader = dyn_loader.val () in - do { - rcall_callback.val (); - match x with - [ Intf file_name -> task (process_intf dyn_loader) file_name - | Impl file_name -> task (process_impl dyn_loader) file_name - | Str s -> - begin - let (f, o) = Filename.open_temp_file "from_string" ".ml"; - output_string o s; - close_out o; - task (process_impl dyn_loader) f; - at_exit (fun () -> Sys.remove f); - end - | ModuleImpl file_name -> rewrite_and_load "" file_name - | IncludeDir dir -> DynLoader.include_dir dyn_loader dir ]; - rcall_callback.val (); - }; - -value initial_spec_list = - [("-I", Arg.String (fun x -> input_file (IncludeDir x)), - " Add directory in search patch for object files."); - ("-where", Arg.Unit print_stdlib, - "Print camlp4 library directory and exit."); - ("-nolib", Arg.Clear search_stdlib, - "No automatic search for object files in library directory."); - ("-intf", Arg.String (fun x -> input_file (Intf x)), - " Parse as an interface, whatever its extension."); - ("-impl", Arg.String (fun x -> input_file (Impl x)), - " Parse as an implementation, whatever its extension."); - ("-str", Arg.String (fun x -> input_file (Str x)), - " Parse as an implementation."); - ("-unsafe", Arg.Set Camlp4_config.unsafe, - "Generate unsafe accesses to array and strings."); - ("-noassert", Arg.Unit warn_noassert, - "Obsolete, do not use this option."); - ("-verbose", Arg.Set Camlp4_config.verbose, - "More verbose in parsing errors."); - ("-loc", Arg.Set_string Loc.name, - " Name of the location variable (default: " ^ Loc.name.val ^ ")."); - ("-QD", Arg.String (fun x -> Quotation.dump_file.val := Some x), - " Dump quotation expander result in case of syntax error."); - ("-o", Arg.String (fun x -> output_file.val := Some x), - " Output on instead of standard output."); - ("-v", Arg.Unit print_version, - "Print Camlp4 version and exit."); - ("-version", Arg.Unit just_print_the_version, - "Print Camlp4 version number and exit."); - ("-vnum", Arg.Unit just_print_the_version, - "Print Camlp4 version number and exit."); - ("-no_quot", Arg.Clear Camlp4_config.quotations, - "Don't parse quotations, allowing to use, e.g. \"<:>\" as token."); - ("-loaded-modules", Arg.Set print_loaded_modules, "Print the list of loaded modules."); - ("-parser", Arg.String (rewrite_and_load "Parsers"), - " Load the parser Camlp4Parsers/.cm(o|a|xs)"); - ("-printer", Arg.String (rewrite_and_load "Printers"), - " Load the printer Camlp4Printers/.cm(o|a|xs)"); - ("-filter", Arg.String (rewrite_and_load "Filters"), - " Load the filter Camlp4Filters/.cm(o|a|xs)"); - ("-ignore", Arg.String ignore, "ignore the next argument"); - ("--", Arg.Unit ignore, "Deprecated, does nothing") -]; - -Options.init initial_spec_list; - -value anon_fun name = - input_file - (if Filename.check_suffix name ".mli" then Intf name - else if Filename.check_suffix name ".ml" then Impl name - else if Filename.check_suffix name objext then ModuleImpl name - else if Filename.check_suffix name libext then ModuleImpl name - else raise (Arg.Bad ("don't know what to do with " ^ name))); - -value main argv = - let usage () = do { usage initial_spec_list (Options.ext_spec_list ()); exit 0 } in - try do { - let dynloader = DynLoader.mk ~ocaml_stdlib:search_stdlib.val - ~camlp4_stdlib:search_stdlib.val (); - dyn_loader.val := fun () -> dynloader; - let call_callback () = - Register.iter_and_take_callbacks - (fun (name, module_callback) -> - let () = add_to_loaded_modules name in - module_callback ()); - call_callback (); - rcall_callback.val := call_callback; - match Options.parse anon_fun argv with - [ [] -> () - | ["-help"|"--help"|"-h"|"-?" :: _] -> usage () - | [s :: _] -> - do { eprintf "%s: unknown or misused option\n" s; - eprintf "Use option -help for usage@."; - exit 2 } ]; - do_task usage; - call_callback (); - if print_loaded_modules.val then do { - SSet.iter (eprintf "%s@.") loaded_modules.val; - } else () - } - with - [ Arg.Bad s -> do { eprintf "Error: %s\n" s; - eprintf "Use option -help for usage@."; - exit 2 } - | Arg.Help _ -> usage () - | exc -> do { eprintf "@[%a@]@." ErrorHandler.print exc; exit 2 } ]; - -main Sys.argv; diff -Nru ocaml-4.01.0/camlp4/Camlp4_config.ml ocaml-4.05.0/camlp4/Camlp4_config.ml --- ocaml-4.01.0/camlp4/Camlp4_config.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4_config.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -let ocaml_standard_library = Camlp4_import.Config.standard_library;; - -let camlp4_standard_library = - try Sys.getenv "CAMLP4LIB" - with Not_found -> - Filename.concat ocaml_standard_library "camlp4";; - -let version = Sys.ocaml_version;; -let program_name = ref "camlp4";; -let constructors_arity = ref true;; -let unsafe = ref false;; -let verbose = ref false;; -let antiquotations = ref false;; -let quotations = ref true;; -let inter_phrases = ref None;; -let camlp4_ast_impl_magic_number = "Camlp42006M002";; -let camlp4_ast_intf_magic_number = "Camlp42006N002";; -let ocaml_ast_intf_magic_number = Camlp4_import.Config.ast_intf_magic_number;; -let ocaml_ast_impl_magic_number = Camlp4_import.Config.ast_impl_magic_number;; -let current_input_file = ref "";; diff -Nru ocaml-4.01.0/camlp4/Camlp4_config.mli ocaml-4.05.0/camlp4/Camlp4_config.mli --- ocaml-4.01.0/camlp4/Camlp4_config.mli 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4_config.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -val version : string;; -val ocaml_standard_library : string;; -val camlp4_standard_library : string;; -val ocaml_ast_impl_magic_number : string;; -val ocaml_ast_intf_magic_number : string;; -val camlp4_ast_impl_magic_number : string;; -val camlp4_ast_intf_magic_number : string;; -val program_name : string ref;; -val unsafe : bool ref;; -val verbose : bool ref;; -val quotations : bool ref;; -val antiquotations : bool ref;; -val constructors_arity : bool ref;; -val inter_phrases : (string option) ref;; -val current_input_file : string ref;; diff -Nru ocaml-4.01.0/camlp4/Camlp4Filters/Camlp4AstLifter.ml ocaml-4.05.0/camlp4/Camlp4Filters/Camlp4AstLifter.ml --- ocaml-4.01.0/camlp4/Camlp4Filters/Camlp4AstLifter.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4Filters/Camlp4AstLifter.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - - -open Camlp4; - -module Id = struct - value name = "Camlp4AstLifter"; - value version = Sys.ocaml_version; -end; - -module Make (AstFilters : Camlp4.Sig.AstFilters) = struct - open AstFilters; - - module MetaLoc = struct - module Ast = Ast; - value meta_loc_patt _loc _ = <:patt< loc >>; - value meta_loc_expr _loc _ = <:expr< loc >>; - end; - module MetaAst = Ast.Meta.Make MetaLoc; - - register_str_item_filter (fun ast -> - let _loc = Ast.loc_of_str_item ast in - <:str_item< let loc = Loc.ghost in $exp:MetaAst.Expr.meta_str_item _loc ast$ >>); - -end; - -let module M = Camlp4.Register.AstFilter Id Make in (); diff -Nru ocaml-4.01.0/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml ocaml-4.05.0/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml --- ocaml-4.01.0/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml 2012-07-17 15:31:12.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - - -open Camlp4; - -module Id = struct - value name = "Camlp4ExceptionTracer"; - value version = Sys.ocaml_version; -end; - -module Make (AstFilters : Camlp4.Sig.AstFilters) = struct - open AstFilters; - open Ast; - - value add_debug_expr e = - (* let _loc = Loc.make_absolute (MLast.loc_of_expr e) in *) - let _loc = Ast.loc_of_expr e in - let msg = "camlp4-debug: exc: %s at " ^ Loc.to_string _loc ^ "@." in - <:expr< - try $e$ - with - [ Stream.Failure | Exit as exc -> raise exc - | exc -> do { - if Debug.mode "exc" then - Format.eprintf $`str:msg$ (Printexc.to_string exc) else (); - raise exc - } ] >>; - - value rec map_match_case = - fun - [ <:match_case@_loc< $m1$ | $m2$ >> -> - <:match_case< $map_match_case m1$ | $map_match_case m2$ >> - | <:match_case@_loc< $p$ when $w$ -> $e$ >> -> - <:match_case@_loc< $p$ when $w$ -> $add_debug_expr e$ >> - | m -> m ]; - - value filter = object - inherit Ast.map as super; - method expr = fun - [ <:expr@_loc< fun [ $m$ ] >> -> <:expr< fun [ $map_match_case m$ ] >> - | x -> super#expr x ]; - method str_item = fun - [ <:str_item< module Debug = $_$ >> as st -> st - | st -> super#str_item st ]; - end; - - register_str_item_filter filter#str_item; - -end; - -let module M = Camlp4.Register.AstFilter Id Make in (); diff -Nru ocaml-4.01.0/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml ocaml-4.05.0/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml --- ocaml-4.01.0/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml 2013-08-30 11:39:33.000000000 +0000 +++ ocaml-4.05.0/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,609 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006-2007 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 LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - - -open Camlp4; - -module Id = struct - value name = "Camlp4FoldGenerator"; - value version = Sys.ocaml_version; -end; - -module Make (AstFilters : Camlp4.Sig.AstFilters) = struct - open AstFilters; - module StringMap = Map.Make String; - open Ast; - - value _loc = Loc.ghost; - - value sf = Printf.sprintf; - - value xik i k = - let i = - if i < 0 then assert False - else if i = 0 then "" - else sf "_i%d" i - in - let k = - if k < 1 then assert False - else if k = 1 then "" - else sf "_k%d" k - in - sf "_x%s%s" i k; - value exik i k = <:expr< $lid:xik i k$ >>; - value pxik i k = <:patt< $lid:xik i k$ >>; - value elidk y k = <:expr< $lid:sf "%s_%d" y k$ >>; - value plidk y k = <:patt< $lid:sf "%s_%d" y k$ >>; - - value xs s = "_x_" ^ s; - value xsk = sf "_x_%s_%d"; - value exsk s k = <:expr< $lid:xsk s k$>>; - - value rec apply_expr accu = - fun - [ [] -> accu - | [x :: xs] -> - let _loc = Ast.loc_of_expr x - in apply_expr <:expr< $accu$ $x$ >> xs ]; - - value rec apply_patt accu = - fun - [ [] -> accu - | [x :: xs] -> - let _loc = Ast.loc_of_patt x - in apply_patt <:patt< $accu$ $x$ >> xs ]; - - value rec apply_ctyp accu = - fun - [ [] -> accu - | [x :: xs] -> - let _loc = Ast.loc_of_ctyp x - in apply_ctyp <:ctyp< $accu$ $x$ >> xs ]; - - value opt_map f = fun [ Some x -> Some (f x) | None -> None ]; - - value list_init f n = - let rec self m = - if m = n then [] - else [f m :: self (succ m)] - in self 0; - - value rec lid_of_ident sep = - fun - [ <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> s - | <:ident< $i1$.$i2$ >> -> lid_of_ident sep i1 ^ sep ^ lid_of_ident sep i2 - | _ -> assert False ]; - - type type_decl = (string * Ast.ident * list Ast.ctyp * Ast.ctyp * bool); - - value builtin_types = - let tyMap = StringMap.empty in - let tyMap = - let abstr = ["string"; "int"; "float"; "int32"; "int64"; "nativeint"; "char"] in - List.fold_right - (fun name -> StringMap.add name (name, <:ident< $lid:name$ >>, [], <:ctyp<>>, False)) - abstr tyMap - in - let tyMap = - let concr = - [("bool", <:ident>, [], <:ctyp< [ False | True ] >>, False); - ("list", <:ident>, [ <:ctyp< 'a >> ], <:ctyp< [ $uid:"[]"$ | $uid:"::"$ of 'a and list 'a ] >>, False); - ("option", <:ident