├── tests ├── basic │ ├── arrays.reference │ ├── bdd.reference │ ├── takc.reference │ ├── taku.reference │ ├── boyer.reference │ ├── fib.reference │ ├── nucleic.reference │ ├── float.reference │ ├── quicksort.reference │ ├── float.ml │ ├── maps.reference │ ├── tailcalls.reference │ ├── recvalues.reference │ ├── almabench.reference │ ├── includestruct.reference │ ├── fft.reference │ ├── sets.reference │ ├── soli.reference │ ├── equality.reference │ ├── tailcalls.ml │ ├── recvalues.ml │ ├── fib.ml │ ├── takc.ml │ ├── taku.ml │ ├── maps.ml │ ├── sets.ml │ ├── sieve.ml │ └── includestruct.ml └── test.ml ├── .gitignore ├── src ├── libocamlnat.clib ├── ocamlnat.ml ├── toplevel │ ├── topmain.mli │ ├── toperrors.mli │ ├── topdirs.mli │ ├── genprintval.mli │ └── topfind.mli ├── asmcomp │ ├── linscan.mli │ ├── scheduling.mli │ ├── arm │ │ ├── reload.ml │ │ ├── scheduling.ml │ │ └── arch.ml │ ├── mips │ │ ├── reload.ml │ │ ├── scheduling.ml │ │ ├── selection.ml │ │ └── arch.ml │ ├── alpha │ │ ├── reload.ml │ │ └── scheduling.ml │ ├── ia64 │ │ ├── reload.ml │ │ └── scheduling.ml │ ├── power │ │ ├── reload.ml │ │ └── scheduling.ml │ ├── sparc │ │ ├── reload.ml │ │ ├── scheduling.ml │ │ └── arch.ml │ ├── coloring.mli │ ├── split.mli │ ├── comballoc.mli │ ├── closure.mli │ ├── reload.mli │ ├── selection.mli │ ├── spill.mli │ ├── interf.mli │ ├── liveness.mli │ ├── printlinear.mli │ ├── amd64 │ │ └── scheduling.ml │ ├── debuginfo.mli │ ├── i386 │ │ └── scheduling.ml │ ├── hppa │ │ ├── reload.ml │ │ ├── scheduling.ml │ │ └── arch.ml │ ├── printcmm.mli │ ├── interval.mli │ ├── reloadgen.mli │ ├── printmach.mli │ ├── cmmgen.mli │ ├── linearize.mli │ ├── debuginfo.ml │ ├── proc.mli │ ├── emitaux.mli │ ├── schedgen.mli │ ├── reg.mli │ ├── printlinear.ml │ ├── clambda.ml │ └── clambda.mli ├── jitcomp │ ├── jitgen.mli │ ├── jit.mli │ ├── jitlink.mli │ ├── jitlink.ml │ └── jitaux.mli ├── typing │ ├── unused_var.mli │ ├── annot.mli │ ├── path.mli │ ├── oprint.mli │ ├── includeclass.mli │ ├── stypes.mli │ ├── primitive.mli │ ├── datarepr.mli │ ├── includecore.mli │ ├── path.ml │ ├── mtype.mli │ ├── includemod.mli │ ├── ident.mli │ ├── predef.mli │ ├── typemod.mli │ ├── subst.mli │ ├── parmatch.mli │ └── primitive.ml ├── bytecomp │ ├── printlambda.mli │ ├── translclass.mli │ ├── typeopt.mli │ ├── simplif.mli │ ├── translobj.mli │ ├── matching.mli │ ├── translmod.mli │ ├── translcore.mli │ └── switch.mli ├── parsing │ ├── printast.mli │ ├── longident.mli │ ├── parse.mli │ ├── syntaxerr.mli │ ├── linenum.mli │ ├── lexer.mli │ ├── asttypes.mli │ ├── longident.ml │ ├── syntaxerr.ml │ ├── location.mli │ ├── parse.ml │ └── linenum.mll ├── utils │ ├── terminfo.ml │ ├── terminfo.mli │ ├── ccomp.mli │ ├── tbl.mli │ ├── consistbl.ml │ ├── consistbl.mli │ └── clflags.mli └── jitrun │ └── camlnat.h ├── configure ├── AUTHORS ├── Makefile ├── INSTALL ├── README ├── _tags └── _oasis /tests/basic/arrays.reference: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/basic/bdd.reference: -------------------------------------------------------------------------------- 1 | OK 2 | -------------------------------------------------------------------------------- /tests/basic/takc.reference: -------------------------------------------------------------------------------- 1 | 14000 2 | -------------------------------------------------------------------------------- /tests/basic/taku.reference: -------------------------------------------------------------------------------- 1 | 14000 2 | -------------------------------------------------------------------------------- /tests/basic/boyer.reference: -------------------------------------------------------------------------------- 1 | Proved! 2 | -------------------------------------------------------------------------------- /tests/basic/fib.reference: -------------------------------------------------------------------------------- 1 | 165580141 2 | -------------------------------------------------------------------------------- /tests/basic/nucleic.reference: -------------------------------------------------------------------------------- 1 | 33.7976 2 | -------------------------------------------------------------------------------- /tests/basic/float.reference: -------------------------------------------------------------------------------- 1 | 1./.0. = inf 2 | -------------------------------------------------------------------------------- /tests/basic/quicksort.reference: -------------------------------------------------------------------------------- 1 | OK 2 | OK 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | setup.data 3 | src/utils/config.ml 4 | *.native 5 | -------------------------------------------------------------------------------- /tests/basic/float.ml: -------------------------------------------------------------------------------- 1 | Printf.printf "1./.0. = %f\n" (1.0 /. 0.0);; 2 | -------------------------------------------------------------------------------- /tests/basic/maps.reference: -------------------------------------------------------------------------------- 1 | Union+concat 2 | 3 X1 3 | 4 YY 4 | 5 X2 5 | Inter 6 | 4 Y 7 | -------------------------------------------------------------------------------- /tests/basic/tailcalls.reference: -------------------------------------------------------------------------------- 1 | 10000001 2 | 10000001 3 | 10000001 4 | 11 5 | 11 6 | -------------------------------------------------------------------------------- /tests/basic/recvalues.reference: -------------------------------------------------------------------------------- 1 | Test 1: passed 2 | Test 2: passed 3 | Test 3: passed 4 | foo 5 | Test 4: passed 6 | -------------------------------------------------------------------------------- /src/libocamlnat.clib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a570f614a9bf57e9c669dbf0b481ce17) 3 | jitrun/mem.o 4 | jitrun/str.o 5 | jitrun/sym.o 6 | # OASIS_STOP 7 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: ed33e59fe00e48bc31edf413bbc8b8d6) 5 | set -e 6 | 7 | ocaml setup.ml -configure $* 8 | # OASIS_STOP 9 | -------------------------------------------------------------------------------- /tests/basic/almabench.reference: -------------------------------------------------------------------------------- 1 | 0 17.00 -26.06 2 | 1 12.34 1.29 3 | 2 6.83 22.95 4 | 3 0.04 -1.26 5 | 4 2.30 12.54 6 | 5 2.93 14.35 7 | 6 21.27 -16.57 8 | 7 20.41 -19.04 9 | -------------------------------------------------------------------------------- /tests/basic/includestruct.reference: -------------------------------------------------------------------------------- 1 | 1, 2 2 | 2, 3 3 | 124, 457 4 | 0 5 | 2 6 | 2 7 | 1 8 | 3 9 | F is called 10 | A 11 | 42 12 | A 13 | 42 14 | foo1 15 | foo1 16 | -------------------------------------------------------------------------------- /tests/basic/fft.reference: -------------------------------------------------------------------------------- 1 | 16... ok 2 | 32... ok 3 | 64... ok 4 | 128... ok 5 | 256... ok 6 | 512... ok 7 | 1024... ok 8 | 2048... ok 9 | 4096... ok 10 | 8192... ok 11 | 16384... ok 12 | 32768... ok 13 | 65536... ok 14 | 131072... ok 15 | 262144... ok 16 | 524288... ok 17 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: f59f3bdd770be485bf9fe2ee785f6a21) *) 3 | Authors of ocamlnat 4 | Benedikt Meurer 5 | Marcell Fischbach 6 | 7 | Current maintainers of ocamlnat 8 | Benedikt Meurer 9 | (* OASIS_STOP *) 10 | -------------------------------------------------------------------------------- /tests/basic/sets.reference: -------------------------------------------------------------------------------- 1 | -10 true false 2 | -9 false false 3 | -8 false false 4 | -7 false true 5 | -6 false false 6 | -5 false false 7 | -4 false false 8 | -3 false true 9 | -2 true false 10 | -1 false false 11 | 0 true false 12 | 1 false true 13 | 2 true false 14 | 3 false false 15 | 4 true false 16 | 5 false true 17 | 6 true false 18 | 7 false false 19 | 8 false false 20 | 9 false true 21 | 10 false false 22 | false 23 | true 24 | true 25 | false 26 | -------------------------------------------------------------------------------- /tests/basic/soli.reference: -------------------------------------------------------------------------------- 1 | 500 2 | 1000 3 | 1500 4 | 2000 5 | 2500 6 | 3000 7 | 3500 8 | 4000 9 | 4500 10 | 5000 11 | 5500 12 | 6000 13 | 6500 14 | 7000 15 | 7500 16 | 8000 17 | 8500 18 | 9000 19 | 9500 20 | 10000 21 | 10500 22 | 11000 23 | 11500 24 | 12000 25 | 12500 26 | 13000 27 | 13500 28 | 14000 29 | 14500 30 | 15000 31 | 15500 32 | 16000 33 | 16500 34 | 17000 35 | 17500 36 | 18000 37 | 18500 38 | 19000 39 | 19500 40 | 20000 41 | 42 | ......... 43 | ... ... 44 | ... ... 45 | . . 46 | . $ . 47 | . . 48 | ... ... 49 | ... ... 50 | ......... 51 | -------------------------------------------------------------------------------- /src/ocamlnat.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* ocamlnat *) 4 | (* *) 5 | (* Benedikt Meurer, University of Siegen *) 6 | (* *) 7 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 8 | (* Universität Siegen. All rights reserved. This file is distri- *) 9 | (* buted under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* The main startup file *) 14 | 15 | let _ = Topmain.main() 16 | -------------------------------------------------------------------------------- /src/toplevel/topmain.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* ocamlnat *) 4 | (* *) 5 | (* Benedikt Meurer, University of Siegen *) 6 | (* *) 7 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 8 | (* Universität Siegen. All rights reserved. This file is distri- *) 9 | (* buted under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* Start the [ocamlnat] toplevel loop *) 14 | 15 | val main: unit -> unit 16 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | override SETUP?=env OCAMLFIND_IGNORE_DUPS_IN=src/toplevel ocaml setup.ml 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb) 5 | 6 | SETUP = ocaml setup.ml 7 | 8 | build: setup.data 9 | $(SETUP) -build $(BUILDFLAGS) 10 | 11 | doc: setup.data build 12 | $(SETUP) -doc $(DOCFLAGS) 13 | 14 | test: setup.data build 15 | $(SETUP) -test $(TESTFLAGS) 16 | 17 | all: 18 | $(SETUP) -all $(ALLFLAGS) 19 | 20 | install: setup.data 21 | $(SETUP) -install $(INSTALLFLAGS) 22 | 23 | uninstall: setup.data 24 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 25 | 26 | reinstall: setup.data 27 | $(SETUP) -reinstall $(REINSTALLFLAGS) 28 | 29 | clean: 30 | $(SETUP) -clean $(CLEANFLAGS) 31 | 32 | distclean: 33 | $(SETUP) -distclean $(DISTCLEANFLAGS) 34 | 35 | setup.data: 36 | $(SETUP) -configure $(CONFIGUREFLAGS) 37 | 38 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 39 | 40 | # OASIS_STOP 41 | -------------------------------------------------------------------------------- /src/toplevel/toperrors.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* ocamlnat *) 4 | (* *) 5 | (* Benedikt Meurer, University of Siegen *) 6 | (* *) 7 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 8 | (* Universität Siegen. All rights reserved. This file is distri- *) 9 | (* buted under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* Error report *) 14 | 15 | val report_error: Format.formatter -> exn -> unit 16 | -------------------------------------------------------------------------------- /tests/basic/equality.reference: -------------------------------------------------------------------------------- 1 | Test 1 passed. 2 | Test 2 passed. 3 | Test 3 passed. 4 | Test 4 passed. 5 | Test 5 passed. 6 | Test 6 passed. 7 | Test 7 passed. 8 | Test 8 passed. 9 | Test 9 passed. 10 | Test 10 passed. 11 | Test 11 passed. 12 | Test 12 passed. 13 | Test 13 passed. 14 | Test 14 passed. 15 | Test 15 passed. 16 | Test 16 passed. 17 | Test 17 passed. 18 | Test 18 passed. 19 | Test 19 passed. 20 | Test 20 passed. 21 | Test 21 passed. 22 | Test 22 passed. 23 | Test 23 passed. 24 | Test 24 passed. 25 | Test 25 passed. 26 | Test 26 passed. 27 | Test 27 passed. 28 | Test 28 passed. 29 | Test 29 passed. 30 | Test 30 passed. 31 | Test 31 passed. 32 | Test 32 passed. 33 | Test 33 passed. 34 | Test 34 passed. 35 | Test 35 passed. 36 | Test 36 passed. 37 | Test 37 passed. 38 | Test 38 passed. 39 | Test 39 passed. 40 | Test 40 passed. 41 | Test 41 passed. 42 | Test 42 passed. 43 | Test 43 passed. 44 | Test 50 passed. 45 | Test 51 passed. 46 | Test 52 passed. 47 | Test 53 passed. 48 | Test 54 passed. 49 | Test 55 passed. 50 | -------------------------------------------------------------------------------- /src/asmcomp/linscan.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Marcell Fischbach, University of Siegen *) 6 | (* Benedikt Meurer, University of Siegen *) 7 | (* *) 8 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 9 | (* Universität Siegen. All rights reserved. This file is distri- *) 10 | (* buted under the terms of the Q Public License version 1.0. *) 11 | (* *) 12 | (***********************************************************************) 13 | 14 | (* Linear scan register allocation. *) 15 | 16 | val allocate_registers: unit -> unit 17 | -------------------------------------------------------------------------------- /src/asmcomp/scheduling.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: scheduling.mli 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Instruction scheduling *) 16 | 17 | val fundecl: Linearize.fundecl -> Linearize.fundecl 18 | -------------------------------------------------------------------------------- /src/asmcomp/arm/reload.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1998 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: reload.ml 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Reloading for the ARM *) 16 | 17 | let fundecl f = 18 | (new Reloadgen.reload_generic)#fundecl f 19 | -------------------------------------------------------------------------------- /src/asmcomp/mips/reload.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: reload.ml 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Reloading for the Mips *) 16 | 17 | let fundecl f = 18 | (new Reloadgen.reload_generic)#fundecl f 19 | -------------------------------------------------------------------------------- /src/asmcomp/alpha/reload.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: reload.ml 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Reloading for the Alpha *) 16 | 17 | let fundecl f = 18 | (new Reloadgen.reload_generic)#fundecl f 19 | -------------------------------------------------------------------------------- /src/asmcomp/ia64/reload.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2000 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: reload.ml 3235 2000-07-16 02:57:31Z xleroy $ *) 14 | 15 | (* Reloading for the IA64. *) 16 | 17 | let fundecl f = 18 | (new Reloadgen.reload_generic)#fundecl f 19 | -------------------------------------------------------------------------------- /src/asmcomp/power/reload.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: reload.ml 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Reloading for the PowerPC *) 16 | 17 | let fundecl f = 18 | (new Reloadgen.reload_generic)#fundecl f 19 | -------------------------------------------------------------------------------- /src/asmcomp/sparc/reload.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: reload.ml 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Reloading for the Sparc *) 16 | 17 | let fundecl f = 18 | (new Reloadgen.reload_generic)#fundecl f 19 | -------------------------------------------------------------------------------- /src/asmcomp/coloring.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: coloring.mli 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Register allocation by coloring of the interference graph *) 16 | 17 | val allocate_registers: unit -> unit 18 | -------------------------------------------------------------------------------- /src/asmcomp/split.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: split.mli 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Renaming of registers at reload points to split live ranges. *) 16 | 17 | val fundecl: Mach.fundecl -> Mach.fundecl 18 | -------------------------------------------------------------------------------- /src/asmcomp/comballoc.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1999 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: comballoc.mli 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Combine heap allocations occurring in the same basic block *) 16 | 17 | val fundecl: Mach.fundecl -> Mach.fundecl 18 | -------------------------------------------------------------------------------- /src/jitcomp/jitgen.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* ocamlnat *) 4 | (* *) 5 | (* Benedikt Meurer, University of Siegen *) 6 | (* *) 7 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 8 | (* Universität Siegen. All rights reserved. This file is distri- *) 9 | (* buted under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* From lambda to assembly code *) 14 | 15 | val compile: ?toplevel:(string -> bool) -> 16 | Format.formatter -> 17 | int * Lambda.lambda -> 18 | unit 19 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: 2f5c2f2cd6138dac01e7f216e0ae52f7) *) 3 | This is the INSTALL file for the ocamlnat distribution. 4 | 5 | This package uses OASIS to generate its build system. See section OASIS for 6 | full information. 7 | 8 | Dependencies 9 | ============ 10 | 11 | In order to compile this package, you will need: 12 | * ocaml (>= 3.12.1) for all, test main 13 | * findlib 14 | * oUnit (>= 1.1.0) for executable test 15 | 16 | Installing 17 | ========== 18 | 19 | 1. Uncompress source directory and got to the root of the package 20 | 2. Run 'ocaml setup.ml -configure' 21 | 3. Run 'ocaml setup.ml -build' 22 | 4. Run 'ocaml setup.ml -install' 23 | 24 | Uninstalling 25 | ============ 26 | 27 | 1. Go to the root of the package 28 | 2. Run 'ocaml setup.ml -uninstall' 29 | 30 | OASIS 31 | ===== 32 | 33 | OASIS is a software that helps to write setup.ml using a simple '_oasis' 34 | configuration file. The generated setup only depends on standard OCaml 35 | installation, no additional library is required. 36 | 37 | (* OASIS_STOP *) 38 | -------------------------------------------------------------------------------- /src/asmcomp/closure.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: closure.mli 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | (* Introduction of closures, uncurrying, recognition of direct calls *) 16 | 17 | val intro: int -> Lambda.lambda -> Clambda.ulambda 18 | -------------------------------------------------------------------------------- /src/asmcomp/reload.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: reload.mli 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | (* Insert load/stores for pseudoregs that got assigned to stack locations. *) 16 | 17 | val fundecl: Mach.fundecl -> Mach.fundecl * bool 18 | -------------------------------------------------------------------------------- /src/jitcomp/jit.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* ocamlnat *) 4 | (* *) 5 | (* Benedikt Meurer, University of Siegen *) 6 | (* *) 7 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 8 | (* Universität Siegen. All rights reserved. This file is distri- *) 9 | (* buted under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* JIT emission of x86-64 (AMD 64) assembly code *) 14 | 15 | val fundecl: Linearize.fundecl -> unit 16 | val data: Cmm.data_item list -> unit 17 | val begin_assembly: unit -> unit 18 | val end_assembly: unit -> unit 19 | -------------------------------------------------------------------------------- /tests/basic/tailcalls.ml: -------------------------------------------------------------------------------- 1 | let rec tailcall4 a b c d = 2 | if a < 0 3 | then b 4 | else tailcall4 (a-1) (b+1) (c+2) (d+3) 5 | 6 | let rec tailcall8 a b c d e f g h = 7 | if a < 0 8 | then b 9 | else tailcall8 (a-1) (b+1) (c+2) (d+3) (e+4) (f+5) (g+6) (h+7) 10 | 11 | let rec tailcall16 a b c d e f g h i j k l m n o p = 12 | if a < 0 13 | then b 14 | else tailcall16 (a-1) (b+1) (c+2) (d+3) (e+4) (f+5) (g+6) (h+7) 15 | (i+8) (j+9) (k+10) (l+11) (m+12) (n+13) (o+14) (p+15) 16 | 17 | let indtailcall8 fn a b c d e f g h = 18 | fn a b c d e f g h 19 | 20 | let indtailcall16 fn a b c d e f g h i j k l m n o p = 21 | fn a b c d e f g h i j k l m n o p 22 | 23 | let _ = 24 | print_int (tailcall4 10000000 0 0 0); print_newline(); 25 | print_int (tailcall8 10000000 0 0 0 0 0 0 0); print_newline(); 26 | print_int (tailcall16 10000000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline(); 27 | print_int (indtailcall8 tailcall8 10 0 0 0 0 0 0 0); print_newline(); 28 | print_int (indtailcall16 tailcall16 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline() 29 | -------------------------------------------------------------------------------- /src/typing/unused_var.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Damien Doligez, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2004 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: unused_var.mli 7307 2006-01-04 16:55:50Z doligez $ *) 14 | 15 | val warn : Format.formatter -> Parsetree.structure -> Parsetree.structure;; 16 | (* Warn on unused variables; return the second argument. *) 17 | -------------------------------------------------------------------------------- /src/asmcomp/selection.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: selection.mli 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Selection of pseudo-instructions, assignment of pseudo-registers, 16 | sequentialization. *) 17 | 18 | val fundecl: Cmm.fundecl -> Mach.fundecl 19 | -------------------------------------------------------------------------------- /src/asmcomp/spill.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: spill.mli 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | (* Insertion of moves to suggest possible spilling / reloading points 16 | before register allocation. *) 17 | 18 | val fundecl: Mach.fundecl -> Mach.fundecl 19 | -------------------------------------------------------------------------------- /src/bytecomp/printlambda.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: printlambda.mli 2908 2000-03-06 22:12:09Z weis $ *) 14 | 15 | open Lambda 16 | 17 | open Format 18 | 19 | val structured_constant: formatter -> structured_constant -> unit 20 | val lambda: formatter -> lambda -> unit 21 | -------------------------------------------------------------------------------- /src/asmcomp/interf.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: interf.mli 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Construction of the interference graph. 16 | Annotate pseudoregs with interference lists and preference lists. *) 17 | 18 | val build_graph: Mach.fundecl -> unit 19 | -------------------------------------------------------------------------------- /src/asmcomp/liveness.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: liveness.mli 3123 2000-04-21 08:13:22Z weis $ *) 14 | 15 | (* Liveness analysis. 16 | Annotate mach code with the set of regs live at each point. *) 17 | 18 | open Format 19 | 20 | val fundecl: formatter -> Mach.fundecl -> unit 21 | -------------------------------------------------------------------------------- /src/asmcomp/mips/scheduling.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: scheduling.ml 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | open Schedgen (* to create a dependency *) 16 | 17 | (* No scheduling is needed for the Mips, the assembler 18 | does it better than us. *) 19 | 20 | let fundecl f = f 21 | -------------------------------------------------------------------------------- /src/asmcomp/printlinear.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: printlinear.mli 3123 2000-04-21 08:13:22Z weis $ *) 14 | 15 | (* Pretty-printing of linearized machine code *) 16 | 17 | open Format 18 | open Linearize 19 | 20 | val instr: formatter -> instruction -> unit 21 | val fundecl: formatter -> fundecl -> unit 22 | -------------------------------------------------------------------------------- /src/asmcomp/amd64/scheduling.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2000 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: scheduling.ml 5634 2003-06-30 08:28:48Z xleroy $ *) 14 | 15 | open Schedgen (* to create a dependency *) 16 | 17 | (* Scheduling is turned off because the processor schedules dynamically 18 | much better than what we could do. *) 19 | 20 | let fundecl f = f 21 | -------------------------------------------------------------------------------- /src/asmcomp/ia64/scheduling.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2000 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: scheduling.ml 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | open Schedgen (* to create a dependency *) 16 | 17 | (* We don't schedule here on the linearized code, but instead schedule the 18 | assembly code generated in Emit. *) 19 | 20 | let fundecl f = f 21 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: b537351d35a71d57f2c99db1ce31fa2d) *) 3 | This is the README file for the ocamlnat distribution. 4 | 5 | (c) 1996-2011 INRIA Rocquencourt 6 | 7 | (c) 2010-2011 Benedikt Meurer 8 | 9 | (c) 2011 University of Siegen 10 | 11 | A native toplevel for the OCaml language 12 | 13 | The native toplevel permits interactive use of OCaml system through a 14 | read-eval-print loop, similar to the standard OCaml toplevel that ships with 15 | OCaml. But while the standard OCaml toplevel makes use of the byte code 16 | compiler and runtime to compile and execute the toplevel phrases, ocamlnat 17 | uses the optimizing native code compiler and its runtime for compilation and 18 | code execution, which is up to 100 times faster than the byte code runtime. 19 | ocamlnat currently supports amd64 and i386 systems running either Linux or 20 | Mac OS X. It may also work with Microsoft Windows, but we don't officially 21 | support it. 22 | 23 | See the files INSTALL for building and installation instructions. See the 24 | file LICENSE for copying conditions. 25 | 26 | Home page: http://benediktmeurer.de/ocamlnat 27 | 28 | 29 | (* OASIS_STOP *) 30 | -------------------------------------------------------------------------------- /src/parsing/printast.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Damien Doligez, projet Para, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1999 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: printast.mli 2908 2000-03-06 22:12:09Z weis $ *) 14 | 15 | open Parsetree;; 16 | open Format;; 17 | 18 | val interface : formatter -> signature_item list -> unit;; 19 | val implementation : formatter -> structure_item list -> unit;; 20 | val top_phrase : formatter -> toplevel_phrase -> unit;; 21 | -------------------------------------------------------------------------------- /tests/basic/recvalues.ml: -------------------------------------------------------------------------------- 1 | (* Recursive value definitions *) 2 | 3 | let _ = 4 | let rec x = 1 :: x in 5 | if match x with 6 | 1 :: x' -> x == x' 7 | | _ -> false 8 | then print_string "Test 1: passed\n" 9 | else print_string "Test 1: FAILED\n"; 10 | let one = 1 in 11 | let rec y = (one, one+1) :: y in 12 | if match y with 13 | (1,2) :: y' -> y == y' 14 | | _ -> false 15 | then print_string "Test 2: passed\n" 16 | else print_string "Test 2: FAILED\n"; 17 | let rec z = (Gc.minor(); (one, one+1)) :: z in 18 | (* Trash the minor generation *) 19 | for i = 0 to 50000 do ignore (ref 0) done; 20 | if match z with 21 | (1,2) :: z' -> z == z' 22 | | _ -> false 23 | then print_string "Test 3: passed\n" 24 | else print_string "Test 3: FAILED\n"; 25 | ;; 26 | 27 | let rec s = "bar" 28 | and idx = 1 29 | and x1 = let f x = Printf.printf "%s\n" x in f "foo"; s, x4 30 | and x2 = [| x1; x1 |] 31 | and x3 = (fun () -> fst (x2.(idx))) :: x3 32 | and x4 = {contents = x3} 33 | ;; 34 | 35 | Gc.minor ();; 36 | if (List.hd (!(snd (x2.(0))))) () == s 37 | then print_string "Test 4: passed\n" 38 | else print_string "Test 4: FAILED\n" 39 | -------------------------------------------------------------------------------- /src/parsing/longident.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: longident.mli 9324 2009-08-27 08:19:08Z xleroy $ *) 14 | 15 | (* Long identifiers, used in parsetree. *) 16 | 17 | type t = 18 | Lident of string 19 | | Ldot of t * string 20 | | Lapply of t * t 21 | 22 | val flatten: t -> string list 23 | val last: t -> string 24 | val parse: string -> t 25 | -------------------------------------------------------------------------------- /tests/basic/fib.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: fib.ml 10713 2010-10-08 11:53:19Z doligez $ *) 14 | 15 | let rec fib n = 16 | if n < 2 then 1 else fib(n-1) + fib(n-2) 17 | 18 | let _ = 19 | let n = 20 | if Array.length Sys.argv >= 2 21 | then int_of_string Sys.argv.(1) 22 | else 40 in 23 | print_int(fib n); print_newline(); exit 0 24 | 25 | -------------------------------------------------------------------------------- /src/typing/annot.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Damien Doligez, projet Gallium, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2007 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: annot.mli 8958 2008-07-29 15:42:44Z doligez $ *) 14 | 15 | (* Data types for annotations (Stypes.ml) *) 16 | 17 | type call = Tail | Stack | Inline;; 18 | 19 | type ident = 20 | | Iref_internal of Location.t (* defining occurrence *) 21 | | Iref_external 22 | | Idef of Location.t (* scope *) 23 | ;; 24 | -------------------------------------------------------------------------------- /tests/basic/takc.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: takc.ml 10713 2010-10-08 11:53:19Z doligez $ *) 14 | 15 | let rec tak x y z = 16 | if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y) 17 | else z 18 | 19 | let rec repeat n = 20 | if n <= 0 then 0 else tak 18 12 6 + repeat(n-1) 21 | 22 | let _ = print_int (repeat 2000); print_newline(); exit 0 23 | 24 | -------------------------------------------------------------------------------- /tests/basic/taku.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: taku.ml 10713 2010-10-08 11:53:19Z doligez $ *) 14 | 15 | let rec tak (x, y, z) = 16 | if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y)) 17 | else z 18 | 19 | let rec repeat n = 20 | if n <= 0 then 0 else tak(18,12,6) + repeat(n-1) 21 | 22 | let _ = print_int (repeat 2000); print_newline(); exit 0 23 | -------------------------------------------------------------------------------- /src/parsing/parse.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: parse.mli 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | (* Entry points in the parser *) 16 | 17 | val implementation : Lexing.lexbuf -> Parsetree.structure 18 | val interface : Lexing.lexbuf -> Parsetree.signature 19 | val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase 20 | val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list 21 | -------------------------------------------------------------------------------- /src/typing/path.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: path.mli 5640 2003-07-01 13:05:43Z xleroy $ *) 14 | 15 | (* Access paths *) 16 | 17 | type t = 18 | Pident of Ident.t 19 | | Pdot of t * string * int 20 | | Papply of t * t 21 | 22 | val same: t -> t -> bool 23 | val isfree: Ident.t -> t -> bool 24 | val binding_time: t -> int 25 | 26 | val nopos: int 27 | 28 | val name: t -> string 29 | val head: t -> Ident.t 30 | -------------------------------------------------------------------------------- /src/asmcomp/debuginfo.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2006 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | type kind = Dinfo_call | Dinfo_raise 14 | 15 | type t = { 16 | dinfo_kind: kind; 17 | dinfo_file: string; 18 | dinfo_line: int; 19 | dinfo_char_start: int; 20 | dinfo_char_end: int 21 | } 22 | 23 | val none: t 24 | 25 | val to_string: t -> string 26 | 27 | val from_location: kind -> Location.t -> t 28 | 29 | val from_call: Lambda.lambda_event -> t 30 | val from_raise: Lambda.lambda_event -> t 31 | -------------------------------------------------------------------------------- /src/parsing/syntaxerr.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1997 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: syntaxerr.mli 9316 2009-07-15 14:06:37Z xleroy $ *) 14 | 15 | (* Auxiliary type for reporting syntax errors *) 16 | 17 | open Format 18 | 19 | type error = 20 | Unclosed of Location.t * string * Location.t * string 21 | | Applicative_path of Location.t 22 | | Other of Location.t 23 | 24 | exception Error of error 25 | exception Escape_error 26 | 27 | val report_error: formatter -> error -> unit 28 | -------------------------------------------------------------------------------- /src/asmcomp/i386/scheduling.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: scheduling.ml 2779 2000-02-04 12:43:18Z xleroy $ *) 14 | 15 | open Schedgen (* to create a dependency *) 16 | 17 | (* Scheduling is turned off because our model does not fit the 486 18 | nor the Pentium very well. In particular, it messes up with the 19 | float reg stack. The Pentiums Pro / II / III / etc schedule 20 | at run-time much better than what we could do. *) 21 | 22 | let fundecl f = f 23 | -------------------------------------------------------------------------------- /src/jitcomp/jitlink.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* ocamlnat *) 4 | (* *) 5 | (* Benedikt Meurer, University of Siegen *) 6 | (* *) 7 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 8 | (* Universität Siegen. All rights reserved. This file is distri- *) 9 | (* buted under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* Linker functionality *) 14 | 15 | val loadfile: string -> unit 16 | 17 | (* Error report *) 18 | 19 | type error = 20 | Cannot_generate_cmxs 21 | | File_not_found of string 22 | | Unsupported_file of string 23 | | Undefined_global of string 24 | | Dynamic_linking_failed of string * Dynlink.error 25 | 26 | exception Error of error 27 | 28 | open Format 29 | 30 | val report_error: formatter -> error -> unit 31 | -------------------------------------------------------------------------------- /src/bytecomp/translclass.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: translclass.mli 7372 2006-04-05 02:28:13Z garrigue $ *) 14 | 15 | open Typedtree 16 | open Lambda 17 | 18 | val transl_class : 19 | Ident.t list -> Ident.t -> 20 | int -> string list -> class_expr -> Asttypes.virtual_flag -> lambda;; 21 | 22 | type error = Illegal_class_expr | Tags of string * string 23 | 24 | exception Error of Location.t * error 25 | 26 | open Format 27 | 28 | val report_error: formatter -> error -> unit 29 | -------------------------------------------------------------------------------- /src/utils/terminfo.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: terminfo.ml 6045 2004-01-01 16:42:43Z doligez $ *) 14 | 15 | (* Basic interface to the terminfo database *) 16 | 17 | type status = 18 | | Uninitialised 19 | | Bad_term 20 | | Good_term of int 21 | ;; 22 | external setup : out_channel -> status = "caml_terminfo_setup";; 23 | external backup : int -> unit = "caml_terminfo_backup";; 24 | external standout : bool -> unit = "caml_terminfo_standout";; 25 | external resume : int -> unit = "caml_terminfo_resume";; 26 | -------------------------------------------------------------------------------- /src/bytecomp/typeopt.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1998 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: typeopt.mli 2873 2000-02-28 15:45:50Z xleroy $ *) 14 | 15 | (* Auxiliaries for type-based optimizations, e.g. array kinds *) 16 | 17 | val has_base_type : Typedtree.expression -> Path.t -> bool 18 | val maybe_pointer : Typedtree.expression -> bool 19 | val array_kind : Typedtree.expression -> Lambda.array_kind 20 | val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind 21 | val bigarray_kind_and_layout : 22 | Typedtree.expression -> Lambda.bigarray_kind * Lambda.bigarray_layout 23 | -------------------------------------------------------------------------------- /src/utils/terminfo.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: terminfo.mli 6045 2004-01-01 16:42:43Z doligez $ *) 14 | 15 | (* Basic interface to the terminfo database *) 16 | 17 | type status = 18 | | Uninitialised 19 | | Bad_term 20 | | Good_term of int (* number of lines of the terminal *) 21 | ;; 22 | external setup : out_channel -> status = "caml_terminfo_setup";; 23 | external backup : int -> unit = "caml_terminfo_backup";; 24 | external standout : bool -> unit = "caml_terminfo_standout";; 25 | external resume : int -> unit = "caml_terminfo_resume";; 26 | -------------------------------------------------------------------------------- /src/bytecomp/simplif.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: simplif.mli 10667 2010-09-02 13:29:21Z xclerc $ *) 14 | 15 | (* Elimination of useless Llet(Alias) bindings. 16 | Transformation of let-bound references into variables. 17 | Simplification over staticraise/staticcatch constructs. 18 | Generation of tail-call annotations if -annot is set. *) 19 | 20 | open Lambda 21 | 22 | val simplify_lambda: lambda -> lambda 23 | 24 | (* To be filled by asmcomp/selectgen.ml *) 25 | val is_tail_native_heuristic: (int -> bool) ref 26 | (* # arguments -> can tailcall *) 27 | -------------------------------------------------------------------------------- /src/asmcomp/hppa/reload.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: reload.ml 8768 2008-01-11 16:13:18Z doligez $ *) 14 | 15 | (* Reloading for the HPPA *) 16 | 17 | 18 | open Cmm 19 | open Arch 20 | open Reg 21 | open Mach 22 | open Proc 23 | 24 | class reload = object (self) 25 | 26 | inherit Reloadgen.reload_generic as super 27 | 28 | method reload_operation op arg res = 29 | match op with 30 | Iintop(Idiv | Imod) 31 | | Iintop_imm((Idiv | Imod), _) -> (arg, res) 32 | | _ -> super#reload_operation op arg res 33 | end 34 | 35 | 36 | 37 | let fundecl f = 38 | (new reload)#fundecl f 39 | -------------------------------------------------------------------------------- /src/typing/oprint.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2002 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: oprint.mli 10486 2010-05-31 13:18:11Z xclerc $ *) 14 | 15 | open Format 16 | open Outcometree 17 | 18 | val out_value : (formatter -> out_value -> unit) ref 19 | val out_type : (formatter -> out_type -> unit) ref 20 | val out_class_type : (formatter -> out_class_type -> unit) ref 21 | val out_module_type : (formatter -> out_module_type -> unit) ref 22 | val out_sig_item : (formatter -> out_sig_item -> unit) ref 23 | val out_signature : (formatter -> out_sig_item list -> unit) ref 24 | val out_phrase : (formatter -> out_phrase -> unit) ref 25 | 26 | val parenthesized_ident : string -> bool 27 | -------------------------------------------------------------------------------- /src/bytecomp/translobj.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: translobj.mli 9153 2008-12-03 18:09:09Z doligez $ *) 14 | 15 | open Lambda 16 | 17 | val oo_prim: string -> lambda 18 | 19 | val share: structured_constant -> lambda 20 | val meth: lambda -> string -> lambda * lambda list 21 | 22 | val reset_labels: unit -> unit 23 | val transl_label_init: lambda -> lambda 24 | val transl_store_label_init: 25 | Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda 26 | 27 | val method_ids: IdentSet.t ref (* reset when starting a new wrapper *) 28 | 29 | val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda 30 | val oo_add_class: Ident.t -> Env.t * bool 31 | -------------------------------------------------------------------------------- /src/parsing/linenum.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1997 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: linenum.mli 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* An auxiliary lexer for determining the line number corresponding to 16 | a file position, honoring the directives # linenum "filename" *) 17 | 18 | val for_position: string -> int -> string * int * int 19 | (* [Linenum.for_position file loc] returns a triple describing 20 | the location [loc] in the file named [file]. 21 | First result is name of actual source file. 22 | Second result is line number in that source file. 23 | Third result is position of beginning of that line in [file]. *) 24 | -------------------------------------------------------------------------------- /src/asmcomp/printcmm.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: printcmm.mli 3123 2000-04-21 08:13:22Z weis $ *) 14 | 15 | (* Pretty-printing of C-- code *) 16 | 17 | open Format 18 | 19 | val machtype_component : formatter -> Cmm.machtype_component -> unit 20 | val machtype : formatter -> Cmm.machtype_component array -> unit 21 | val comparison : Cmm.comparison -> string 22 | val chunk : Cmm.memory_chunk -> string 23 | val operation : Cmm.operation -> string 24 | val expression : formatter -> Cmm.expression -> unit 25 | val fundecl : formatter -> Cmm.fundecl -> unit 26 | val data : formatter -> Cmm.data_item list -> unit 27 | val phrase : formatter -> Cmm.phrase -> unit 28 | -------------------------------------------------------------------------------- /src/parsing/lexer.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: lexer.mli 5961 2003-11-21 16:01:13Z xleroy $ *) 14 | 15 | (* The lexical analyzer *) 16 | 17 | val token: Lexing.lexbuf -> Parser.token 18 | val skip_sharp_bang: Lexing.lexbuf -> unit 19 | 20 | type error = 21 | | Illegal_character of char 22 | | Illegal_escape of string 23 | | Unterminated_comment 24 | | Unterminated_string 25 | | Unterminated_string_in_comment 26 | | Keyword_as_label of string 27 | | Literal_overflow of string 28 | ;; 29 | 30 | exception Error of error * Location.t 31 | 32 | open Format 33 | 34 | val report_error: formatter -> error -> unit 35 | 36 | val in_comment : unit -> bool;; 37 | -------------------------------------------------------------------------------- /src/utils/ccomp.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: ccomp.mli 8768 2008-01-11 16:13:18Z doligez $ *) 14 | 15 | (* Compiling C files and building C libraries *) 16 | 17 | val command: string -> int 18 | val run_command: string -> unit 19 | val compile_file: string -> int 20 | val create_archive: string -> string list -> int 21 | val expand_libname: string -> string 22 | val quote_files: string list -> string 23 | val quote_optfile: string option -> string 24 | (*val make_link_options: string list -> string*) 25 | 26 | type link_mode = 27 | | Exe 28 | | Dll 29 | | MainDll 30 | | Partial 31 | 32 | val call_linker: link_mode -> string -> string list -> string -> bool 33 | -------------------------------------------------------------------------------- /src/typing/includeclass.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1997 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: includeclass.mli 2908 2000-03-06 22:12:09Z weis $ *) 14 | 15 | (* Inclusion checks for the class language *) 16 | 17 | open Types 18 | open Typedtree 19 | open Ctype 20 | open Format 21 | 22 | val class_types: 23 | Env.t -> class_type -> class_type -> class_match_failure list 24 | val class_type_declarations: 25 | Env.t -> cltype_declaration -> cltype_declaration -> 26 | class_match_failure list 27 | val class_declarations: 28 | Env.t -> class_declaration -> class_declaration -> 29 | class_match_failure list 30 | 31 | val report_error: formatter -> class_match_failure list -> unit 32 | -------------------------------------------------------------------------------- /src/asmcomp/interval.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Marcell Fischbach, University of Siegen *) 6 | (* Benedikt Meurer, University of Siegen *) 7 | (* *) 8 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 9 | (* Universität Siegen. All rights reserved. This file is distri- *) 10 | (* buted under the terms of the Q Public License version 1.0. *) 11 | (* *) 12 | (***********************************************************************) 13 | 14 | (* Live intervals for the linear scan register allocator. *) 15 | 16 | type range = 17 | { 18 | mutable rbegin: int; 19 | mutable rend: int; 20 | } 21 | 22 | type t = 23 | { 24 | mutable reg: Reg.t; 25 | mutable ibegin: int; 26 | mutable iend: int; 27 | mutable ranges: range list; 28 | } 29 | 30 | val all_intervals: unit -> t list 31 | val all_fixed_intervals: unit -> t list 32 | val overlap: t -> t -> bool 33 | val is_live: t -> int -> bool 34 | val remove_expired_ranges: t -> int -> unit 35 | val build_intervals: Mach.fundecl -> unit 36 | -------------------------------------------------------------------------------- /src/typing/stypes.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Damien Doligez, projet Moscova, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2003 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: stypes.mli 8958 2008-07-29 15:42:44Z doligez $ *) 14 | 15 | (* Recording and dumping (partial) type information *) 16 | 17 | (* Clflags.save_types must be true *) 18 | 19 | open Typedtree;; 20 | 21 | type annotation = 22 | | Ti_pat of pattern 23 | | Ti_expr of expression 24 | | Ti_class of class_expr 25 | | Ti_mod of module_expr 26 | | An_call of Location.t * Annot.call 27 | | An_ident of Location.t * string * Annot.ident 28 | ;; 29 | 30 | val record : annotation -> unit;; 31 | val record_phrase : Location.t -> unit;; 32 | val dump : string -> unit;; 33 | 34 | val get_location : annotation -> Location.t;; 35 | val get_info : unit -> annotation list;; 36 | -------------------------------------------------------------------------------- /src/asmcomp/reloadgen.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1997 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: reloadgen.mli 10450 2010-05-21 12:00:49Z doligez $ *) 14 | 15 | class reload_generic : object 16 | method reload_operation : 17 | Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array * Reg.t array 18 | method reload_test : Mach.test -> Reg.t array -> Reg.t array 19 | (* Can be overridden to reflect instructions that can operate 20 | directly on stack locations *) 21 | method makereg : Reg.t -> Reg.t 22 | (* Can be overridden to avoid creating new registers of some class 23 | (i.e. if all "registers" of that class are actually on stack) *) 24 | method fundecl : Mach.fundecl -> Mach.fundecl * bool 25 | (* The entry point *) 26 | end 27 | -------------------------------------------------------------------------------- /tests/basic/maps.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: maps.ml 10713 2010-10-08 11:53:19Z doligez $ *) 14 | 15 | module IntMap = Map.Make(struct type t = int let compare x y = x-y end) 16 | 17 | let m1 = IntMap.add 4 "Y" (IntMap.singleton 3 "X1") 18 | let m2 = IntMap.add 4 "Y" (IntMap.singleton 5 "X2") 19 | 20 | let show m = IntMap.iter (fun k v -> Printf.printf "%d %s\n" k v) m 21 | 22 | let () = 23 | print_endline "Union+concat"; 24 | show (IntMap.merge (fun _ l r -> match l, r with Some x, None | None, Some x -> Some x | Some x, Some y -> Some (x ^ x) | _ -> assert false) m1 m2); 25 | print_endline "Inter"; 26 | show (IntMap.merge (fun _ l r -> match l, r with Some x, Some y when x = y -> Some x | _ -> None) m1 m2); 27 | () 28 | 29 | -------------------------------------------------------------------------------- /src/typing/primitive.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: primitive.mli 8930 2008-07-24 05:35:22Z frisch $ *) 14 | 15 | (* Description of primitive functions *) 16 | 17 | type description = 18 | { prim_name: string; (* Name of primitive or C function *) 19 | prim_arity: int; (* Number of arguments *) 20 | prim_alloc: bool; (* Does it allocates or raise? *) 21 | prim_native_name: string; (* Name of C function for the nat. code gen. *) 22 | prim_native_float: bool } (* Does the above operate on unboxed floats? *) 23 | 24 | val parse_declaration: int -> string list -> description 25 | 26 | val description_list: description -> string list 27 | 28 | val native_name: description -> string 29 | val byte_name: description -> string 30 | -------------------------------------------------------------------------------- /src/utils/tbl.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: tbl.mli 10285 2010-04-20 14:11:28Z xleroy $ *) 14 | 15 | (* Association tables from any ordered type to any type. 16 | We use the generic ordering to compare keys. *) 17 | 18 | type ('a, 'b) t 19 | 20 | val empty: ('a, 'b) t 21 | val add: 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t 22 | val find: 'a -> ('a, 'b) t -> 'b 23 | val mem: 'a -> ('a, 'b) t -> bool 24 | val remove: 'a -> ('a, 'b) t -> ('a, 'b) t 25 | val iter: ('a -> 'b -> unit) -> ('a, 'b) t -> unit 26 | val map: ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t 27 | val fold: ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c 28 | 29 | open Format 30 | 31 | val print: (formatter -> 'a -> unit) -> (formatter -> 'b -> unit) -> 32 | formatter -> ('a, 'b) t -> unit 33 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | : include 2 | : pkg_dynlink, pkg_findlib 3 | : oasis_executable_ocamlnat_native 4 | "src/ocamlnat.native": linkall 5 | 6 | # OASIS_START 7 | # DO NOT EDIT (digest: 2128cd3c6a2bfd2a063fbc10ba6eff64) 8 | # Executable test 9 | : pkg_oUnit 10 | : pkg_oUnit 11 | # Executable ocamlnat 12 | : oasis_executable_ocamlnat_ccopt 13 | "src/jitrun/mem.c": oasis_executable_ocamlnat_ccopt 14 | "src/jitrun/str.c": oasis_executable_ocamlnat_ccopt 15 | "src/jitrun/sym.c": oasis_executable_ocamlnat_ccopt 16 | "src/ocamlnat.native": oasis_executable_ocamlnat_byte 17 | : oasis_executable_ocamlnat_byte 18 | "src/jitrun/mem.c": oasis_executable_ocamlnat_byte 19 | "src/jitrun/str.c": oasis_executable_ocamlnat_byte 20 | "src/jitrun/sym.c": oasis_executable_ocamlnat_byte 21 | "src/ocamlnat.native": oasis_executable_ocamlnat_native 22 | : oasis_executable_ocamlnat_native 23 | "src/jitrun/mem.c": oasis_executable_ocamlnat_native 24 | "src/jitrun/str.c": oasis_executable_ocamlnat_native 25 | "src/jitrun/sym.c": oasis_executable_ocamlnat_native 26 | "src/ocamlnat.native": use_libocamlnat 27 | "src/ocamlnat.native": pkg_findlib 28 | "src/ocamlnat.native": pkg_dynlink 29 | : pkg_findlib 30 | : pkg_dynlink 31 | "src/jitrun/mem.c": pkg_findlib 32 | "src/jitrun/mem.c": pkg_dynlink 33 | "src/jitrun/str.c": pkg_findlib 34 | "src/jitrun/str.c": pkg_dynlink 35 | "src/jitrun/sym.c": pkg_findlib 36 | "src/jitrun/sym.c": pkg_dynlink 37 | # OASIS_STOP 38 | -------------------------------------------------------------------------------- /src/parsing/asttypes.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: asttypes.mli 10250 2010-04-08 03:58:41Z garrigue $ *) 14 | 15 | (* Auxiliary a.s.t. types used by parsetree and typedtree. *) 16 | 17 | type constant = 18 | Const_int of int 19 | | Const_char of char 20 | | Const_string of string 21 | | Const_float of string 22 | | Const_int32 of int32 23 | | Const_int64 of int64 24 | | Const_nativeint of nativeint 25 | 26 | type rec_flag = Nonrecursive | Recursive | Default 27 | 28 | type direction_flag = Upto | Downto 29 | 30 | type private_flag = Private | Public 31 | 32 | type mutable_flag = Immutable | Mutable 33 | 34 | type virtual_flag = Virtual | Concrete 35 | 36 | type override_flag = Override | Fresh 37 | 38 | type closed_flag = Closed | Open 39 | 40 | type label = string 41 | -------------------------------------------------------------------------------- /src/toplevel/topdirs.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* ocamlnat *) 4 | (* *) 5 | (* Benedikt Meurer, University of Siegen *) 6 | (* *) 7 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 8 | (* Universität Siegen. All rights reserved. This file is distri- *) 9 | (* buted under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* The toplevel directives *) 14 | 15 | open Format 16 | 17 | val dir_quit : unit -> unit 18 | val dir_directory : string -> unit 19 | val dir_cd : string -> unit 20 | val dir_load : formatter -> string -> unit 21 | val dir_use : formatter -> string -> unit 22 | val dir_install_printer : formatter -> Longident.t -> unit 23 | val dir_remove_printer : formatter -> Longident.t -> unit 24 | val dir_trace : formatter -> Longident.t -> unit 25 | val dir_untrace : formatter -> Longident.t -> unit 26 | val dir_untrace_all : formatter -> unit -> unit 27 | 28 | type 'a printer_type_new = Format.formatter -> 'a -> unit 29 | type 'a printer_type_old = 'a -> unit 30 | 31 | (* For topmain.ml. Maybe shouldn't be there *) 32 | val load_file : formatter -> string -> bool 33 | -------------------------------------------------------------------------------- /src/typing/datarepr.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: datarepr.mli 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | (* Compute constructor and label descriptions from type declarations, 16 | determining their representation. *) 17 | 18 | open Asttypes 19 | open Types 20 | 21 | val constructor_descrs: 22 | type_expr -> (string * type_expr list) list -> private_flag -> 23 | (string * constructor_description) list 24 | val exception_descr: 25 | Path.t -> type_expr list -> constructor_description 26 | val label_descrs: 27 | type_expr -> (string * mutable_flag * type_expr) list -> 28 | record_representation -> private_flag -> 29 | (string * label_description) list 30 | 31 | exception Constr_not_found 32 | 33 | val find_constr_by_tag: 34 | constructor_tag -> (string * type_expr list) list -> string * type_expr list 35 | -------------------------------------------------------------------------------- /src/asmcomp/printmach.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: printmach.mli 3123 2000-04-21 08:13:22Z weis $ *) 14 | 15 | (* Pretty-printing of pseudo machine code *) 16 | 17 | open Format 18 | 19 | val reg: formatter -> Reg.t -> unit 20 | val regs: formatter -> Reg.t array -> unit 21 | val regset: formatter -> Reg.Set.t -> unit 22 | val regsetaddr: formatter -> Reg.Set.t -> unit 23 | val operation: Mach.operation -> Reg.t array -> formatter -> Reg.t array -> unit 24 | val test: Mach.test -> formatter -> Reg.t array -> unit 25 | val instr: formatter -> Mach.instruction -> unit 26 | val fundecl: formatter -> Mach.fundecl -> unit 27 | val phase: string -> formatter -> Mach.fundecl -> unit 28 | val interferences: formatter -> unit -> unit 29 | val intervals: formatter -> unit -> unit 30 | val preferences: formatter -> unit -> unit 31 | 32 | val print_live: bool ref 33 | -------------------------------------------------------------------------------- /src/asmcomp/mips/selection.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1997 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: selection.ml 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Instruction selection for the Mips processor *) 16 | 17 | open Misc 18 | open Cmm 19 | open Reg 20 | open Arch 21 | open Mach 22 | 23 | class selector = object 24 | 25 | inherit Selectgen.selector_generic 26 | 27 | method is_immediate (n : int) = true 28 | 29 | method select_addressing = function 30 | Cconst_symbol s -> 31 | (Ibased(s, 0), Ctuple []) 32 | | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -> 33 | (Ibased(s, n), Ctuple []) 34 | | Cop(Cadda, [arg; Cconst_int n]) -> 35 | (Iindexed n, arg) 36 | | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> 37 | (Iindexed n, Cop(Cadda, [arg1; arg2])) 38 | | arg -> 39 | (Iindexed 0, arg) 40 | 41 | end 42 | 43 | let fundecl f = (new selector)#emit_fundecl f 44 | -------------------------------------------------------------------------------- /src/asmcomp/cmmgen.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: cmmgen.mli 10424 2010-05-19 11:29:38Z xleroy $ *) 14 | 15 | (* Translation from closed lambda to C-- *) 16 | 17 | val compunit: int -> Clambda.ulambda -> Cmm.phrase list 18 | 19 | val apply_function: int -> Cmm.phrase 20 | val send_function: int -> Cmm.phrase 21 | val curry_function: int -> Cmm.phrase list 22 | val generic_functions: bool -> Cmx_format.unit_infos list -> Cmm.phrase list 23 | val entry_point: string list -> Cmm.phrase 24 | val global_table: string list -> Cmm.phrase 25 | val reference_symbols: string list -> Cmm.phrase 26 | val globals_map: (string * Digest.t * Digest.t * string list) list -> 27 | Cmm.phrase 28 | val frame_table: string list -> Cmm.phrase 29 | val data_segment_table: string list -> Cmm.phrase 30 | val code_segment_table: string list -> Cmm.phrase 31 | val predef_exception: string -> Cmm.phrase 32 | val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase 33 | -------------------------------------------------------------------------------- /tests/basic/sets.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: sets.ml 10713 2010-10-08 11:53:19Z doligez $ *) 14 | 15 | module IntSet = Set.Make(struct type t = int let compare x y = x-y end) 16 | 17 | let even = List.fold_right IntSet.add [0; -2; 2; 4; 6; -10] IntSet.empty 18 | 19 | let odd = List.fold_right IntSet.add [9; -7; 5; 1; -3] IntSet.empty 20 | 21 | let _ = 22 | for i = -10 to 10 do 23 | Printf.printf "%d %B %B\n" i (IntSet.mem i even) (IntSet.mem i odd) 24 | done 25 | 26 | module PowerSet(BaseSet: Set.S) 27 | (SetOrd: functor(S: Set.S) -> Set.OrderedType) = 28 | Set.Make(SetOrd(BaseSet)) 29 | 30 | module IntSetSet = PowerSet(IntSet)(functor (S: Set.S) -> S) 31 | 32 | let setofset = List.fold_right IntSetSet.add [even; odd] IntSetSet.empty 33 | 34 | let _ = 35 | List.iter 36 | (fun s -> Printf.printf "%B\n" (IntSetSet.mem s setofset)) 37 | [IntSet.empty; even; odd; IntSet.union even odd] 38 | 39 | let _ = exit 0 40 | -------------------------------------------------------------------------------- /src/jitrun/camlnat.h: -------------------------------------------------------------------------------- 1 | /***********************************************************************/ 2 | /* */ 3 | /* ocamlnat */ 4 | /* */ 5 | /* Benedikt Meurer, University of Siegen */ 6 | /* */ 7 | /* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, */ 8 | /* Universität Siegen. All rights reserved. This file is distri- */ 9 | /* buted under the terms of the Q Public License version 1.0. */ 10 | /* */ 11 | /***********************************************************************/ 12 | 13 | #ifndef CAMLNAT_H 14 | #define CAMLNAT_H 15 | 16 | #include 17 | #include 18 | #include 19 | #include 20 | #include 21 | #ifdef __APPLE__ 22 | #include 23 | #endif 24 | #include 25 | #include 26 | #include 27 | #ifdef HAS_MMAP 28 | # include 29 | # include 30 | #endif 31 | #ifdef HAS_UNISTD 32 | # include 33 | #endif 34 | #ifdef _WIN32 35 | # include 36 | #endif 37 | 38 | /* Externals */ 39 | 40 | #define Not_in_heap 0 41 | #define In_heap 1 42 | #define In_young 2 43 | #define In_static_data 4 44 | #define In_code_area 8 45 | 46 | extern value caml_natdynlink_loadsym(value); 47 | extern void caml_register_frametable(intnat *); 48 | extern void caml_register_dyn_global(void *); 49 | extern int caml_page_table_add(int, void *, void *); 50 | 51 | #endif /* !CAMLNAT_H */ 52 | -------------------------------------------------------------------------------- /src/bytecomp/matching.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: matching.mli 8974 2008-08-01 16:57:10Z mauny $ *) 14 | 15 | (* Compilation of pattern-matching *) 16 | 17 | open Typedtree 18 | open Lambda 19 | 20 | val for_function: 21 | Location.t -> int ref option -> lambda -> (pattern * lambda) list -> 22 | partial -> lambda 23 | val for_trywith: 24 | lambda -> (pattern * lambda) list -> lambda 25 | val for_let: 26 | Location.t -> lambda -> pattern -> lambda -> lambda 27 | val for_multiple_match: 28 | Location.t -> lambda list -> (pattern * lambda) list -> partial -> 29 | lambda 30 | 31 | val for_tupled_function: 32 | Location.t -> Ident.t list -> (pattern list * lambda) list -> 33 | partial -> lambda 34 | 35 | exception Cannot_flatten 36 | 37 | val flatten_pattern: int -> pattern -> pattern list 38 | 39 | val make_test_sequence: 40 | lambda option -> primitive -> primitive -> lambda -> 41 | (Asttypes.constant * lambda) list -> lambda 42 | 43 | val inline_lazy_force : lambda -> Location.t -> lambda 44 | -------------------------------------------------------------------------------- /src/parsing/longident.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: longident.ml 9324 2009-08-27 08:19:08Z xleroy $ *) 14 | 15 | type t = 16 | Lident of string 17 | | Ldot of t * string 18 | | Lapply of t * t 19 | 20 | let rec flat accu = function 21 | Lident s -> s :: accu 22 | | Ldot(lid, s) -> flat (s :: accu) lid 23 | | Lapply(l1, l2) -> Misc.fatal_error "Longident.flat" 24 | 25 | let flatten lid = flat [] lid 26 | 27 | let last = function 28 | Lident s -> s 29 | | Ldot(lid, s) -> s 30 | | Lapply(l1, l2) -> Misc.fatal_error "Longident.last" 31 | 32 | let rec split_at_dots s pos = 33 | try 34 | let dot = String.index_from s pos '.' in 35 | String.sub s pos (dot - pos) :: split_at_dots s (dot + 1) 36 | with Not_found -> 37 | [String.sub s pos (String.length s - pos)] 38 | 39 | let parse s = 40 | match split_at_dots s 0 with 41 | [] -> Lident "" (* should not happen, but don't put assert false 42 | so as not to crash the toplevel (see Genprintval) *) 43 | | hd :: tl -> List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl 44 | -------------------------------------------------------------------------------- /src/bytecomp/translmod.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: translmod.mli 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | (* Translation from typed abstract syntax to lambda terms, 16 | for the module language *) 17 | 18 | open Typedtree 19 | open Lambda 20 | 21 | val transl_implementation: string -> structure * module_coercion -> lambda 22 | val transl_store_phrases: string -> structure -> int * lambda 23 | val transl_store_implementation: 24 | string -> structure * module_coercion -> int * lambda 25 | val transl_toplevel_definition: structure -> lambda 26 | val transl_package: 27 | Ident.t option list -> Ident.t -> module_coercion -> lambda 28 | val transl_store_package: 29 | Ident.t option list -> Ident.t -> module_coercion -> int * lambda 30 | 31 | val toplevel_name: Ident.t -> string 32 | val nat_toplevel_name: Ident.t -> Ident.t * int 33 | 34 | val primitive_declarations: Primitive.description list ref 35 | 36 | type error = 37 | Circular_dependency of Ident.t 38 | 39 | exception Error of Location.t * error 40 | 41 | val report_error: Format.formatter -> error -> unit 42 | -------------------------------------------------------------------------------- /src/typing/includecore.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: includecore.mli 10455 2010-05-21 15:13:47Z garrigue $ *) 14 | 15 | (* Inclusion checks for the core language *) 16 | 17 | open Types 18 | open Typedtree 19 | 20 | exception Dont_match 21 | 22 | type type_mismatch = 23 | Arity 24 | | Privacy 25 | | Kind 26 | | Constraint 27 | | Manifest 28 | | Variance 29 | | Field_type of string 30 | | Field_mutable of string 31 | | Field_arity of string 32 | | Field_names of int * string * string 33 | | Field_missing of bool * string 34 | | Record_representation of bool 35 | 36 | val value_descriptions: 37 | Env.t -> value_description -> value_description -> module_coercion 38 | val type_declarations: 39 | Env.t -> Ident.t -> 40 | type_declaration -> type_declaration -> type_mismatch list 41 | val exception_declarations: 42 | Env.t -> exception_declaration -> exception_declaration -> bool 43 | (* 44 | val class_types: 45 | Env.t -> class_type -> class_type -> bool 46 | *) 47 | 48 | val report_type_mismatch: 49 | string -> string -> string -> Format.formatter -> type_mismatch list -> unit 50 | -------------------------------------------------------------------------------- /src/toplevel/genprintval.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: genprintval.mli 4694 2002-04-18 07:27:47Z garrigue $ *) 14 | 15 | (* Printing of values *) 16 | 17 | open Types 18 | open Format 19 | 20 | module type OBJ = 21 | sig 22 | type t 23 | val obj : t -> 'a 24 | val is_block : t -> bool 25 | val tag : t -> int 26 | val size : t -> int 27 | val field : t -> int -> t 28 | end 29 | 30 | module type EVALPATH = 31 | sig 32 | type value 33 | val eval_path: Path.t -> value 34 | exception Error 35 | val same_value: value -> value -> bool 36 | end 37 | 38 | module type S = 39 | sig 40 | type t 41 | val install_printer : 42 | Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit 43 | val remove_printer : Path.t -> unit 44 | val outval_of_untyped_exception : t -> Outcometree.out_value 45 | val outval_of_value : 46 | int -> int -> 47 | (int -> t -> Types.type_expr -> Outcometree.out_value option) -> 48 | Env.t -> t -> type_expr -> Outcometree.out_value 49 | end 50 | 51 | module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) : 52 | (S with type t = O.t) 53 | -------------------------------------------------------------------------------- /tests/basic/sieve.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: sieve.ml 10713 2010-10-08 11:53:19Z doligez $ *) 14 | 15 | (* Eratosthene's sieve *) 16 | 17 | (* interval min max = [min; min+1; ...; max-1; max] *) 18 | 19 | let rec interval min max = 20 | if min > max then [] else min :: interval (min + 1) max 21 | 22 | 23 | (* filter p L returns the list of the elements in list L 24 | that satisfy predicate p *) 25 | 26 | let rec filter p = function 27 | [] -> [] 28 | | a::r -> if p a then a :: filter p r else filter p r 29 | 30 | 31 | (* Application: removing all numbers multiple of n from a list of integers *) 32 | 33 | let remove_multiples_of n = 34 | filter (fun m -> m mod n <> 0) 35 | 36 | 37 | (* The sieve itself *) 38 | 39 | let sieve max = 40 | let rec filter_again = function 41 | [] -> [] 42 | | n::r as l -> 43 | if n*n > max then l else n :: filter_again (remove_multiples_of n r) 44 | in 45 | filter_again (interval 2 max) 46 | 47 | 48 | let rec do_list f = function 49 | [] -> () 50 | | a::l -> f a; do_list f l 51 | 52 | 53 | let _ = 54 | do_list (fun n -> print_int n; print_string " ") (sieve 50000); 55 | print_newline(); 56 | exit 0 57 | -------------------------------------------------------------------------------- /src/asmcomp/arm/scheduling.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: scheduling.ml 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | open Mach 16 | 17 | (* Instruction scheduling for the Sparc *) 18 | 19 | class scheduler = object 20 | 21 | inherit Schedgen.scheduler_generic 22 | 23 | (* Scheduling -- based roughly on the Strong ARM *) 24 | 25 | method oper_latency = function 26 | Ireload -> 2 27 | | Iload(_, _) -> 2 28 | | Iconst_symbol _ -> 2 (* turned into a load *) 29 | | Iconst_float _ -> 2 (* turned into a load *) 30 | | Iintop(Imul) -> 3 31 | | Iintop_imm(Imul, _) -> 3 32 | (* No data available for floatops, let's make educated guesses *) 33 | | Iaddf -> 3 34 | | Isubf -> 3 35 | | Imulf -> 5 36 | | Idivf -> 15 37 | | _ -> 1 38 | 39 | (* Issue cycles. Rough approximations *) 40 | 41 | method oper_issue_cycles = function 42 | Ialloc _ -> 4 43 | | Iintop(Icomp _) -> 3 44 | | Iintop(Icheckbound) -> 2 45 | | Iintop_imm(Idiv, _) -> 4 46 | | Iintop_imm(Imod, _) -> 6 47 | | Iintop_imm(Icomp _, _) -> 3 48 | | Iintop_imm(Icheckbound, _) -> 2 49 | | _ -> 1 50 | 51 | end 52 | 53 | let fundecl f = (new scheduler)#schedule_fundecl f 54 | -------------------------------------------------------------------------------- /src/typing/path.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: path.ml 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | type t = 16 | Pident of Ident.t 17 | | Pdot of t * string * int 18 | | Papply of t * t 19 | 20 | let nopos = -1 21 | 22 | let rec same p1 p2 = 23 | match (p1, p2) with 24 | (Pident id1, Pident id2) -> Ident.same id1 id2 25 | | (Pdot(p1, s1, pos1), Pdot(p2, s2, pos2)) -> s1 = s2 && same p1 p2 26 | | (Papply(fun1, arg1), Papply(fun2, arg2)) -> 27 | same fun1 fun2 && same arg1 arg2 28 | | (_, _) -> false 29 | 30 | let rec isfree id = function 31 | Pident id' -> Ident.same id id' 32 | | Pdot(p, s, pos) -> isfree id p 33 | | Papply(p1, p2) -> isfree id p1 || isfree id p2 34 | 35 | let rec binding_time = function 36 | Pident id -> Ident.binding_time id 37 | | Pdot(p, s, pos) -> binding_time p 38 | | Papply(p1, p2) -> max (binding_time p1) (binding_time p2) 39 | 40 | let rec name = function 41 | Pident id -> Ident.name id 42 | | Pdot(p, s, pos) -> name p ^ "." ^ s 43 | | Papply(p1, p2) -> name p1 ^ "(" ^ name p2 ^ ")" 44 | 45 | let rec head = function 46 | Pident id -> id 47 | | Pdot(p, s, pos) -> head p 48 | | Papply(p1, p2) -> assert false 49 | -------------------------------------------------------------------------------- /src/asmcomp/linearize.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: linearize.mli 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | (* Transformation of Mach code into a list of pseudo-instructions. *) 16 | 17 | type label = int 18 | val new_label: unit -> label 19 | 20 | type instruction = 21 | { mutable desc: instruction_desc; 22 | mutable next: instruction; 23 | arg: Reg.t array; 24 | res: Reg.t array; 25 | dbg: Debuginfo.t; 26 | live: Reg.Set.t } 27 | 28 | and instruction_desc = 29 | Lend 30 | | Lop of Mach.operation 31 | | Lreloadretaddr 32 | | Lreturn 33 | | Llabel of label 34 | | Lbranch of label 35 | | Lcondbranch of Mach.test * label 36 | | Lcondbranch3 of label option * label option * label option 37 | | Lswitch of label array 38 | | Lsetuptrap of label 39 | | Lpushtrap 40 | | Lpoptrap 41 | | Lraise 42 | 43 | val has_fallthrough : instruction_desc -> bool 44 | val end_instr: instruction 45 | val instr_cons: 46 | instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction 47 | val invert_test: Mach.test -> Mach.test 48 | 49 | type fundecl = 50 | { fun_name: string; 51 | fun_body: instruction; 52 | fun_fast: bool } 53 | 54 | val fundecl: Mach.fundecl -> fundecl 55 | -------------------------------------------------------------------------------- /src/asmcomp/debuginfo.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2006 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | open Lexing 14 | open Location 15 | 16 | type kind = Dinfo_call | Dinfo_raise 17 | 18 | type t = { 19 | dinfo_kind: kind; 20 | dinfo_file: string; 21 | dinfo_line: int; 22 | dinfo_char_start: int; 23 | dinfo_char_end: int 24 | } 25 | 26 | let none = { 27 | dinfo_kind = Dinfo_call; 28 | dinfo_file = ""; 29 | dinfo_line = 0; 30 | dinfo_char_start = 0; 31 | dinfo_char_end = 0 32 | } 33 | 34 | let to_string d = 35 | if d == none 36 | then "" 37 | else Printf.sprintf "{%s:%d,%d-%d}" 38 | d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end 39 | 40 | let from_location kind loc = 41 | if loc.loc_ghost then none else 42 | { dinfo_kind = kind; 43 | dinfo_file = loc.loc_start.pos_fname; 44 | dinfo_line = loc.loc_start.pos_lnum; 45 | dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol; 46 | dinfo_char_end = 47 | if loc.loc_end.pos_fname = loc.loc_start.pos_fname 48 | then loc.loc_end.pos_cnum - loc.loc_start.pos_bol 49 | else loc.loc_start.pos_cnum - loc.loc_start.pos_bol } 50 | 51 | let from_call ev = from_location Dinfo_call ev.Lambda.lev_loc 52 | let from_raise ev = from_location Dinfo_raise ev.Lambda.lev_loc 53 | -------------------------------------------------------------------------------- /src/parsing/syntaxerr.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1997 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: syntaxerr.ml 9316 2009-07-15 14:06:37Z xleroy $ *) 14 | 15 | (* Auxiliary type for reporting syntax errors *) 16 | 17 | open Format 18 | 19 | type error = 20 | Unclosed of Location.t * string * Location.t * string 21 | | Applicative_path of Location.t 22 | | Other of Location.t 23 | 24 | exception Error of error 25 | exception Escape_error 26 | 27 | let report_error ppf = function 28 | | Unclosed(opening_loc, opening, closing_loc, closing) -> 29 | if String.length !Location.input_name = 0 30 | && Location.highlight_locations ppf opening_loc closing_loc 31 | then fprintf ppf "Syntax error: '%s' expected, \ 32 | the highlighted '%s' might be unmatched" closing opening 33 | else begin 34 | fprintf ppf "%aSyntax error: '%s' expected@." 35 | Location.print_error closing_loc closing; 36 | fprintf ppf "%aThis '%s' might be unmatched" 37 | Location.print_error opening_loc opening 38 | end 39 | | Applicative_path loc -> 40 | fprintf ppf "%aSyntax error: applicative paths of the form F(X).t are not supported when the option -no-app-func is set." 41 | Location.print_error loc 42 | | Other loc -> 43 | fprintf ppf "%aSyntax error" Location.print_error loc 44 | -------------------------------------------------------------------------------- /src/bytecomp/translcore.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: translcore.mli 8232 2007-05-16 08:21:41Z doligez $ *) 14 | 15 | (* Translation from typed abstract syntax to lambda terms, 16 | for the core language *) 17 | 18 | open Asttypes 19 | open Types 20 | open Typedtree 21 | open Lambda 22 | 23 | val name_pattern: string -> (pattern * 'a) list -> Ident.t 24 | 25 | val transl_exp: expression -> lambda 26 | val transl_apply: lambda -> (expression option * optional) list 27 | -> Location.t -> lambda 28 | val transl_let: 29 | rec_flag -> (pattern * expression) list -> lambda -> lambda 30 | val transl_primitive: Primitive.description -> lambda 31 | val transl_exception: 32 | Ident.t -> Path.t option -> exception_declaration -> lambda 33 | 34 | val check_recursive_lambda: Ident.t list -> lambda -> bool 35 | 36 | type error = 37 | Illegal_letrec_pat 38 | | Illegal_letrec_expr 39 | | Free_super_var 40 | 41 | exception Error of Location.t * error 42 | 43 | open Format 44 | 45 | val report_error: formatter -> error -> unit 46 | 47 | (* Forward declaration -- to be filled in by Translmod.transl_module *) 48 | val transl_module : 49 | (module_coercion -> Path.t option -> module_expr -> lambda) ref 50 | val transl_object : 51 | (Ident.t -> string list -> class_expr -> lambda) ref 52 | -------------------------------------------------------------------------------- /src/asmcomp/hppa/scheduling.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: scheduling.ml 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Instruction scheduling for the HPPA *) 16 | 17 | open Arch 18 | open Mach 19 | 20 | class scheduler = object (self) 21 | 22 | inherit Schedgen.scheduler_generic 23 | 24 | (* Latencies (in cycles). Roughly based on the ``Mustang'' chips. *) 25 | 26 | method oper_latency = function 27 | Ireload -> 2 28 | | Iload(_, _) -> 2 29 | | Iconst_float _ -> 2 (* turned into a load *) 30 | | Iintop Imul -> 2 (* ends up with a load *) 31 | | Iaddf | Isubf | Imulf -> 3 32 | | Idivf -> 12 33 | | _ -> 1 34 | 35 | (* Issue cycles. Rough approximations. *) 36 | 37 | method oper_issue_cycles = function 38 | Iconst_float _ -> 3 39 | | Iconst_symbol _ -> 2 40 | | Iload(_, Ibased(_, _)) -> 2 41 | | Istore(_, Ibased(_, _)) -> 2 42 | | Ialloc _ -> 5 43 | | Iintop Imul -> 10 44 | | Iintop Ilsl -> 3 45 | | Iintop Ilsr -> 2 46 | | Iintop Iasr -> 3 47 | | Iintop(Icomp _) -> 2 48 | | Iintop(Icheckbound) -> 2 49 | | Iintop_imm(Idiv, _) -> 4 50 | | Iintop_imm(Imod, _) -> 5 51 | | Iintop_imm(Icomp _, _) -> 2 52 | | Iintop_imm(Icheckbound, _) -> 2 53 | | Ifloatofint -> 4 54 | | Iintoffloat -> 4 55 | | _ -> 1 56 | 57 | end 58 | 59 | let fundecl f = (new scheduler)#schedule_fundecl f 60 | -------------------------------------------------------------------------------- /tests/basic/includestruct.ml: -------------------------------------------------------------------------------- 1 | (* Test for "include " inside structures *) 2 | 3 | module A = 4 | struct 5 | type t = int 6 | let x = (1 : t) 7 | let y = (2 : t) 8 | let f (z : t) = (x + z : t) 9 | end 10 | 11 | module B = 12 | struct 13 | include A 14 | type u = t * t 15 | let p = ((x, y) : u) 16 | let g ((x, y) : u) = ((f x, f y) : u) 17 | end 18 | 19 | let _ = 20 | let print_pair (x,y) = 21 | print_int x; print_string ", "; print_int y; print_newline() in 22 | print_pair B.p; 23 | print_pair (B.g B.p); 24 | print_pair (B.g (123, 456)) 25 | 26 | module H = 27 | struct 28 | include A 29 | let f (z : t) = (x - 1 : t) 30 | end 31 | 32 | let _ = 33 | print_int (H.f H.x); print_newline() 34 | 35 | module C = 36 | struct 37 | include (A : sig type t val f : t -> int val x : t end) 38 | let z = f x 39 | end 40 | 41 | let _ = 42 | print_int C.z; print_newline(); 43 | print_int (C.f C.x); print_newline() 44 | 45 | (* Toplevel inclusion *) 46 | 47 | include A 48 | 49 | let _ = 50 | print_int x; print_newline(); 51 | print_int (f y); print_newline() 52 | 53 | (* With a functor *) 54 | 55 | module F(X: sig end) = 56 | struct 57 | let _ = print_string "F is called"; print_newline() 58 | type t = A | B of int 59 | let print_t = function A -> print_string "A" 60 | | B x -> print_int x 61 | end 62 | 63 | module D = 64 | struct 65 | include F(struct end) 66 | let test() = print_t A; print_newline(); print_t (B 42); print_newline() 67 | end 68 | 69 | let _ = 70 | D.test(); 71 | D.print_t D.A; print_newline(); D.print_t (D.B 42); print_newline() 72 | 73 | (* Exceptions and classes *) 74 | 75 | module E = 76 | struct 77 | exception Exn of string 78 | class c = object method m = 1 end 79 | end 80 | 81 | module G = 82 | struct 83 | include E 84 | let _ = 85 | begin try raise (Exn "foo") with Exn s -> print_string s end; 86 | print_int ((new c)#m); print_newline() 87 | end 88 | 89 | let _ = 90 | begin try raise (G.Exn "foo") with G.Exn s -> print_string s end; 91 | print_int ((new G.c)#m); print_newline() 92 | 93 | -------------------------------------------------------------------------------- /src/asmcomp/proc.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: proc.mli 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | (* Processor descriptions *) 16 | 17 | (* Instruction selection *) 18 | val word_addressed: bool 19 | 20 | (* Registers available for register allocation *) 21 | val num_register_classes: int 22 | val register_class: Reg.t -> int 23 | val num_available_registers: int array 24 | val first_available_register: int array 25 | val register_name: int -> string 26 | val phys_reg: int -> Reg.t 27 | val rotate_registers: bool 28 | 29 | (* Calling conventions *) 30 | val loc_arguments: Reg.t array -> Reg.t array * int 31 | val loc_results: Reg.t array -> Reg.t array 32 | val loc_parameters: Reg.t array -> Reg.t array 33 | val loc_external_arguments: Reg.t array -> Reg.t array * int 34 | val loc_external_results: Reg.t array -> Reg.t array 35 | val loc_exn_bucket: Reg.t 36 | 37 | (* Maximal register pressures for pre-spilling *) 38 | val safe_register_pressure: Mach.operation -> int 39 | val max_register_pressure: Mach.operation -> int array 40 | 41 | (* Registers destroyed by operations *) 42 | val destroyed_at_oper: Mach.instruction_desc -> Reg.t array 43 | val destroyed_at_raise: Reg.t array 44 | 45 | (* Info for laying out the stack frame *) 46 | val num_stack_slots: int array 47 | val contains_calls: bool ref 48 | 49 | (* Calling the assembler *) 50 | val assemble_file: string -> string -> int 51 | -------------------------------------------------------------------------------- /src/typing/mtype.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: mtype.mli 6196 2004-04-09 13:32:28Z xleroy $ *) 14 | 15 | (* Operations on module types *) 16 | 17 | open Types 18 | 19 | val scrape: Env.t -> module_type -> module_type 20 | (* Expand toplevel module type abbreviations 21 | till hitting a "hard" module type (signature, functor, 22 | or abstract module type ident. *) 23 | val freshen: module_type -> module_type 24 | (* Return an alpha-equivalent copy of the given module type 25 | where bound identifiers are fresh. *) 26 | val strengthen: Env.t -> module_type -> Path.t -> module_type 27 | (* Strengthen abstract type components relative to the 28 | given path. *) 29 | val nondep_supertype: Env.t -> Ident.t -> module_type -> module_type 30 | (* Return the smallest supertype of the given type 31 | in which the given ident does not appear. 32 | Raise [Not_found] if no such type exists. *) 33 | val no_code_needed: Env.t -> module_type -> bool 34 | val no_code_needed_sig: Env.t -> signature -> bool 35 | (* Determine whether a module needs no implementation code, 36 | i.e. consists only of type definitions. *) 37 | val enrich_modtype: Env.t -> Path.t -> module_type -> module_type 38 | val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration 39 | val type_paths: Env.t -> Path.t -> module_type -> Path.t list 40 | -------------------------------------------------------------------------------- /src/utils/consistbl.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2002 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: consistbl.ml 5275 2002-11-18 10:41:26Z xleroy $ *) 14 | 15 | (* Consistency tables: for checking consistency of module CRCs *) 16 | 17 | type t = (string, Digest.t * string) Hashtbl.t 18 | 19 | let create () = Hashtbl.create 13 20 | 21 | let clear = Hashtbl.clear 22 | 23 | exception Inconsistency of string * string * string 24 | 25 | exception Not_available of string 26 | 27 | let check tbl name crc source = 28 | try 29 | let (old_crc, old_source) = Hashtbl.find tbl name in 30 | if crc <> old_crc then raise(Inconsistency(name, source, old_source)) 31 | with Not_found -> 32 | Hashtbl.add tbl name (crc, source) 33 | 34 | let check_noadd tbl name crc source = 35 | try 36 | let (old_crc, old_source) = Hashtbl.find tbl name in 37 | if crc <> old_crc then raise(Inconsistency(name, source, old_source)) 38 | with Not_found -> 39 | raise (Not_available name) 40 | 41 | let set tbl name crc source = Hashtbl.add tbl name (crc, source) 42 | 43 | let source tbl name = snd (Hashtbl.find tbl name) 44 | 45 | let extract tbl = 46 | Hashtbl.fold (fun name (crc, auth) accu -> (name, crc) :: accu) tbl [] 47 | 48 | let filter p tbl = 49 | let to_remove = ref [] in 50 | Hashtbl.iter 51 | (fun name (crc, auth) -> 52 | if not (p name) then to_remove := name :: !to_remove) 53 | tbl; 54 | List.iter 55 | (fun name -> 56 | while Hashtbl.mem tbl name do Hashtbl.remove tbl name done) 57 | !to_remove 58 | -------------------------------------------------------------------------------- /src/typing/includemod.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: includemod.mli 10447 2010-05-21 03:36:52Z garrigue $ *) 14 | 15 | (* Inclusion checks for the module language *) 16 | 17 | open Types 18 | open Typedtree 19 | open Format 20 | 21 | val modtypes: Env.t -> module_type -> module_type -> module_coercion 22 | val signatures: Env.t -> signature -> signature -> module_coercion 23 | val compunit: string -> signature -> string -> signature -> module_coercion 24 | val type_declarations: 25 | Env.t -> Ident.t -> type_declaration -> type_declaration -> unit 26 | 27 | type error = 28 | Missing_field of Ident.t 29 | | Value_descriptions of Ident.t * value_description * value_description 30 | | Type_declarations of Ident.t * type_declaration 31 | * type_declaration * Includecore.type_mismatch list 32 | | Exception_declarations of 33 | Ident.t * exception_declaration * exception_declaration 34 | | Module_types of module_type * module_type 35 | | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration 36 | | Modtype_permutation 37 | | Interface_mismatch of string * string 38 | | Class_type_declarations of 39 | Ident.t * cltype_declaration * cltype_declaration * 40 | Ctype.class_match_failure list 41 | | Class_declarations of 42 | Ident.t * class_declaration * class_declaration * 43 | Ctype.class_match_failure list 44 | | Unbound_modtype_path of Path.t 45 | 46 | exception Error of error list 47 | 48 | val report_error: formatter -> error list -> unit 49 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.2 2 | Name: ocamlnat 3 | Version: 0.2.0+dev 4 | OCamlVersion: >= 3.12.1 5 | LicenseFile: LICENSE 6 | License: QPL 7 | BuildType: ocamlbuild (0.2) 8 | Authors: 9 | Benedikt Meurer , 10 | Marcell Fischbach 11 | Maintainers: Benedikt Meurer 12 | Copyrights: 13 | (c) 1996-2011 INRIA Rocquencourt, 14 | (c) 2010-2011 Benedikt Meurer, 15 | (c) 2011 University of Siegen 16 | Homepage: http://benediktmeurer.de/ocamlnat 17 | Plugins: DevFiles (0.2), StdFiles (0.2) 18 | BuildTools: ocamlbuild 19 | 20 | Synopsis: A native toplevel for the OCaml language 21 | Description: 22 | The native toplevel permits interactive use of OCaml system through 23 | a read-eval-print loop, similar to the standard OCaml toplevel that 24 | ships with OCaml. But while the standard OCaml toplevel makes use 25 | of the byte code compiler and runtime to compile and execute the 26 | toplevel phrases, ocamlnat uses the optimizing native code compiler 27 | and its runtime for compilation and code execution, which is up to 28 | 100 times faster than the byte code runtime. 29 | 30 | ocamlnat currently supports amd64 and i386 systems running either 31 | Linux or Mac OS X. It may also work with Microsoft Windows, but we 32 | don't officially support it. 33 | 34 | XStdFilesAUTHORSFileName: AUTHORS 35 | XStdFilesINSTALLFileName: INSTALL 36 | XStdFilesREADMEFileName: README 37 | 38 | Flag final 39 | Default: true 40 | Description: Toggle final/debug configuration 41 | 42 | Executable ocamlnat 43 | Path: src 44 | MainIs: ocamlnat.ml 45 | CSources: jitrun/camlnat.h, jitrun/mem.c, jitrun/str.c, jitrun/sym.c 46 | if flag(final) 47 | CCOpt: -DNDEBUG 48 | ByteOpt: -noassert -unsafe 49 | NativeOpt: -noassert -nodynlink -unsafe 50 | BuildDepends: dynlink, findlib (>= 1.2.7) 51 | CompiledObject: native 52 | 53 | Executable test 54 | Path: tests 55 | MainIs: test.ml 56 | Install: false 57 | BuildDepends: oUnit (>= 1.1.0) 58 | CompiledObject: best 59 | 60 | Test main 61 | TestTools: ocamlnat, test 62 | Command: $test -ocamlnat $ocamlnat 63 | WorkingDirectory: tests 64 | 65 | SourceRepository master 66 | Type: git 67 | Branch: master 68 | Browser: https://github.com/bmeurer/ocamlnat 69 | Location: git://github.com/bmeurer/ocamlnat.git 70 | -------------------------------------------------------------------------------- /src/asmcomp/emitaux.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: emitaux.mli 9540 2010-01-20 16:26:46Z doligez $ *) 14 | 15 | (* Common functions for emitting assembly code *) 16 | 17 | val output_channel: out_channel ref 18 | val emit_string: string -> unit 19 | val emit_int: int -> unit 20 | val emit_nativeint: nativeint -> unit 21 | val emit_int32: int32 -> unit 22 | val emit_symbol: char -> string -> unit 23 | val emit_printf: ('a, out_channel, unit) format -> 'a 24 | val emit_char: char -> unit 25 | val emit_string_literal: string -> unit 26 | val emit_string_directive: string -> string -> unit 27 | val emit_bytes_directive: string -> string -> unit 28 | val emit_float64_directive: string -> string -> unit 29 | val emit_float64_split_directive: string -> string -> unit 30 | val emit_float32_directive: string -> string -> unit 31 | 32 | type frame_descr = 33 | { fd_lbl: int; (* Return address *) 34 | fd_frame_size: int; (* Size of stack frame *) 35 | fd_live_offset: int list; (* Offsets/regs of live addresses *) 36 | fd_debuginfo: Debuginfo.t } (* Location, if any *) 37 | 38 | val frame_descriptors : frame_descr list ref 39 | 40 | type emit_frame_actions = 41 | { efa_label: int -> unit; 42 | efa_16: int -> unit; 43 | efa_32: int32 -> unit; 44 | efa_word: int -> unit; 45 | efa_align: int -> unit; 46 | efa_label_rel: int -> int32 -> unit; 47 | efa_def_label: int -> unit; 48 | efa_string: string -> unit } 49 | 50 | val emit_frames: emit_frame_actions -> unit 51 | 52 | val is_generic_function: string -> bool 53 | -------------------------------------------------------------------------------- /src/asmcomp/schedgen.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1997 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: schedgen.mli 10450 2010-05-21 12:00:49Z doligez $ *) 14 | 15 | (* Instruction scheduling *) 16 | 17 | type code_dag_node = 18 | { instr: Linearize.instruction; 19 | delay: int; 20 | mutable sons: (code_dag_node * int) list; 21 | mutable date: int; 22 | mutable length: int; 23 | mutable ancestors: int; 24 | mutable emitted_ancestors: int } 25 | 26 | class virtual scheduler_generic : object 27 | (* Can be overridden by processor description *) 28 | method virtual oper_issue_cycles : Mach.operation -> int 29 | (* Number of cycles needed to issue the given operation *) 30 | method virtual oper_latency : Mach.operation -> int 31 | (* Number of cycles needed to complete the given operation *) 32 | method reload_retaddr_issue_cycles : int 33 | (* Number of cycles needed to issue a Lreloadretaddr operation *) 34 | method reload_retaddr_latency : int 35 | (* Number of cycles needed to complete a Lreloadretaddr operation *) 36 | method oper_in_basic_block : Mach.operation -> bool 37 | (* Says whether the given operation terminates a basic block *) 38 | method is_store : Mach.operation -> bool 39 | (* Says whether the given operation is a memory store *) 40 | method is_load : Mach.operation -> bool 41 | (* Says whether the given operation is a memory load *) 42 | method is_checkbound : Mach.operation -> bool 43 | (* Says whether the given operation is a checkbound *) 44 | (* Entry point *) 45 | method schedule_fundecl : Linearize.fundecl -> Linearize.fundecl 46 | end 47 | -------------------------------------------------------------------------------- /src/asmcomp/power/scheduling.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: scheduling.ml 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | (* Instruction scheduling for the Power PC *) 16 | 17 | open Arch 18 | open Mach 19 | 20 | class scheduler = object 21 | 22 | inherit Schedgen.scheduler_generic 23 | 24 | (* Latencies (in cycles). Based roughly on the "common model". *) 25 | 26 | method oper_latency = function 27 | Ireload -> 2 28 | | Iload(_, _) -> 2 29 | | Iconst_float _ -> 2 (* turned into a load *) 30 | | Iconst_symbol _ -> 1 31 | | Iintop Imul -> 9 32 | | Iintop_imm(Imul, _) -> 5 33 | | Iintop(Idiv | Imod) -> 36 34 | | Iaddf | Isubf -> 4 35 | | Imulf -> 5 36 | | Idivf -> 33 37 | | Ispecific(Imultaddf | Imultsubf) -> 5 38 | | _ -> 1 39 | 40 | method reload_retaddr_latency = 12 41 | (* If we can have that many cycles between the reloadretaddr and the 42 | return, we can expect that the blr branch will be completely folded. *) 43 | 44 | (* Issue cycles. Rough approximations. *) 45 | 46 | method oper_issue_cycles = function 47 | Iconst_float _ | Iconst_symbol _ -> 2 48 | | Iload(_, Ibased(_, _)) -> 2 49 | | Istore(_, Ibased(_, _)) -> 2 50 | | Ialloc _ -> 4 51 | | Iintop(Imod) -> 40 (* assuming full stall *) 52 | | Iintop(Icomp _) -> 4 53 | | Iintop_imm(Idiv, _) -> 2 54 | | Iintop_imm(Imod, _) -> 4 55 | | Iintop_imm(Icomp _, _) -> 4 56 | | Ifloatofint -> 9 57 | | Iintoffloat -> 4 58 | | _ -> 1 59 | 60 | method reload_retaddr_issue_cycles = 3 61 | (* load then stalling mtlr *) 62 | 63 | end 64 | 65 | let fundecl f = (new scheduler)#schedule_fundecl f 66 | -------------------------------------------------------------------------------- /src/typing/ident.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: ident.mli 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | (* Identifiers (unique names) *) 16 | 17 | type t 18 | 19 | val create: string -> t 20 | val create_persistent: string -> t 21 | val create_predef_exn: string -> t 22 | val rename: t -> t 23 | val name: t -> string 24 | val unique_name: t -> string 25 | val unique_toplevel_name: t -> string 26 | val persistent: t -> bool 27 | val equal: t -> t -> bool 28 | (* Compare identifiers by name. *) 29 | val same: t -> t -> bool 30 | (* Compare identifiers by binding location. 31 | Two identifiers are the same either if they are both 32 | non-persistent and have been created by the same call to 33 | [new], or if they are both persistent and have the same 34 | name. *) 35 | val hide: t -> t 36 | (* Return an identifier with same name as the given identifier, 37 | but stamp different from any stamp returned by new. 38 | When put in a 'a tbl, this identifier can only be looked 39 | up by name. *) 40 | 41 | val make_global: t -> unit 42 | val global: t -> bool 43 | val is_predef_exn: t -> bool 44 | 45 | val binding_time: t -> int 46 | val current_time: unit -> int 47 | val set_current_time: int -> unit 48 | val reinit: unit -> unit 49 | 50 | val print: Format.formatter -> t -> unit 51 | 52 | type 'a tbl 53 | (* Association tables from identifiers to type 'a. *) 54 | 55 | val empty: 'a tbl 56 | val add: t -> 'a -> 'a tbl -> 'a tbl 57 | val find_same: t -> 'a tbl -> 'a 58 | val find_name: string -> 'a tbl -> 'a 59 | val keys: 'a tbl -> t list 60 | -------------------------------------------------------------------------------- /src/parsing/location.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: location.mli 8705 2007-12-04 13:38:58Z doligez $ *) 14 | 15 | (* Source code locations (ranges of positions), used in parsetree. *) 16 | 17 | open Format 18 | 19 | type t = { 20 | loc_start: Lexing.position; 21 | loc_end: Lexing.position; 22 | loc_ghost: bool; 23 | } 24 | 25 | (* Note on the use of Lexing.position in this module. 26 | If [pos_fname = ""], then use [!input_name] instead. 27 | If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and 28 | re-parse the file to get the line and character numbers. 29 | Else all fields are correct. 30 | *) 31 | 32 | val none : t 33 | (** An arbitrary value of type [t]; describes an empty ghost range. *) 34 | val in_file : string -> t;; 35 | (** Return an empty ghost range located in a given file. *) 36 | val init : Lexing.lexbuf -> string -> unit 37 | (** Set the file name and line number of the [lexbuf] to be the start 38 | of the named file. *) 39 | val curr : Lexing.lexbuf -> t 40 | (** Get the location of the current token from the [lexbuf]. *) 41 | 42 | val symbol_rloc: unit -> t 43 | val symbol_gloc: unit -> t 44 | val rhs_loc: int -> t 45 | 46 | val input_name: string ref 47 | val input_lexbuf: Lexing.lexbuf option ref 48 | 49 | val get_pos_info : Lexing.position -> string * int * int (* file, line, char *) 50 | val print_error: formatter -> t -> unit 51 | val print_error_cur_file: formatter -> unit 52 | val print_warning: t -> formatter -> Warnings.t -> unit 53 | val prerr_warning: t -> Warnings.t -> unit 54 | val echo_eof: unit -> unit 55 | val reset: unit -> unit 56 | 57 | val highlight_locations: formatter -> t -> t -> bool 58 | -------------------------------------------------------------------------------- /src/typing/predef.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: predef.mli 7702 2006-10-24 20:54:58Z weis $ *) 14 | 15 | (* Predefined type constructors (with special typing rules in typecore) *) 16 | 17 | open Types 18 | 19 | val type_int: type_expr 20 | val type_char: type_expr 21 | val type_string: type_expr 22 | val type_float: type_expr 23 | val type_bool: type_expr 24 | val type_unit: type_expr 25 | val type_exn: type_expr 26 | val type_array: type_expr -> type_expr 27 | val type_list: type_expr -> type_expr 28 | val type_option: type_expr -> type_expr 29 | val type_nativeint: type_expr 30 | val type_int32: type_expr 31 | val type_int64: type_expr 32 | val type_lazy_t: type_expr -> type_expr 33 | 34 | val path_int: Path.t 35 | val path_char: Path.t 36 | val path_string: Path.t 37 | val path_float: Path.t 38 | val path_bool: Path.t 39 | val path_unit: Path.t 40 | val path_exn: Path.t 41 | val path_array: Path.t 42 | val path_list: Path.t 43 | val path_format6: Path.t 44 | val path_option: Path.t 45 | val path_nativeint: Path.t 46 | val path_int32: Path.t 47 | val path_int64: Path.t 48 | val path_lazy_t: Path.t 49 | 50 | val path_match_failure: Path.t 51 | val path_assert_failure : Path.t 52 | val path_undefined_recursive_module : Path.t 53 | 54 | (* To build the initial environment. Since there is a nasty mutual 55 | recursion between predef and env, we break it by parameterizing 56 | over Env.t, Env.add_type and Env.add_exception. *) 57 | 58 | val build_initial_env: 59 | (Ident.t -> type_declaration -> 'a -> 'a) -> 60 | (Ident.t -> exception_declaration -> 'a -> 'a) -> 61 | 'a -> 'a 62 | 63 | (* To initialize linker tables *) 64 | 65 | val builtin_values: (string * Ident.t) list 66 | -------------------------------------------------------------------------------- /src/typing/typemod.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: typemod.mli 10419 2010-05-18 17:18:24Z frisch $ *) 14 | 15 | (* Type-checking of the module language *) 16 | 17 | open Types 18 | open Format 19 | 20 | val type_module: 21 | Env.t -> Parsetree.module_expr -> Typedtree.module_expr 22 | val type_structure: 23 | Env.t -> Parsetree.structure -> Location.t -> 24 | Typedtree.structure * signature * Env.t 25 | val type_implementation: 26 | string -> string -> string -> Env.t -> Parsetree.structure -> 27 | Typedtree.structure * Typedtree.module_coercion 28 | val transl_signature: 29 | Env.t -> Parsetree.signature -> signature 30 | val check_nongen_schemes: 31 | Env.t -> Typedtree.structure -> unit 32 | 33 | val simplify_signature: signature -> signature 34 | 35 | val package_units: 36 | string list -> string -> string -> Typedtree.module_coercion 37 | 38 | type error = 39 | Cannot_apply of module_type 40 | | Not_included of Includemod.error list 41 | | Cannot_eliminate_dependency of module_type 42 | | Signature_expected 43 | | Structure_expected of module_type 44 | | With_no_component of Longident.t 45 | | With_mismatch of Longident.t * Includemod.error list 46 | | Repeated_name of string * string 47 | | Non_generalizable of type_expr 48 | | Non_generalizable_class of Ident.t * class_declaration 49 | | Non_generalizable_module of module_type 50 | | Implementation_is_required of string 51 | | Interface_not_compiled of string 52 | | Not_allowed_in_functor_body 53 | | With_need_typeconstr 54 | 55 | exception Error of Location.t * error 56 | 57 | val report_error: formatter -> error -> unit 58 | -------------------------------------------------------------------------------- /src/asmcomp/mips/arch.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: arch.ml 5304 2002-11-29 15:03:37Z xleroy $ *) 14 | 15 | (* Specific operations for the Mips processor *) 16 | 17 | open Misc 18 | open Format 19 | 20 | (* Machine-specific command-line options *) 21 | 22 | let command_line_options = [] 23 | 24 | (* Addressing modes *) 25 | 26 | type addressing_mode = 27 | Ibased of string * int (* symbol + displ *) 28 | | Iindexed of int (* reg + displ *) 29 | 30 | (* Specific operations *) 31 | 32 | type specific_operation = unit (* none *) 33 | 34 | (* Sizes, endianness *) 35 | 36 | let big_endian = 37 | match Config.system with 38 | "ultrix" -> false 39 | | "irix" -> true 40 | | _ -> fatal_error "Arch_mips.big_endian" 41 | 42 | let size_addr = 4 43 | let size_int = 4 44 | let size_float = 8 45 | 46 | (* Operations on addressing modes *) 47 | 48 | let identity_addressing = Iindexed 0 49 | 50 | let offset_addressing addr delta = 51 | match addr with 52 | Ibased(s, n) -> Ibased(s, n + delta) 53 | | Iindexed n -> Iindexed(n + delta) 54 | 55 | let num_args_addressing = function 56 | Ibased(s, n) -> 0 57 | | Iindexed n -> 1 58 | 59 | (* Printing operations and addressing modes *) 60 | 61 | let print_addressing printreg addr ppf arg = 62 | match addr with 63 | | Ibased(s, n) -> 64 | let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in 65 | fprintf ppf "\"%s\"%s" s idx 66 | | Iindexed n -> 67 | let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in 68 | fprintf ppf "%a%s" printreg arg.(0) idx 69 | 70 | let print_specific_operation printreg op ppf arg = 71 | fatal_error "Arch_mips.print_specific_operation" 72 | -------------------------------------------------------------------------------- /src/asmcomp/reg.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: reg.mli 9210 2009-03-31 09:44:50Z xleroy $ *) 14 | 15 | (* Pseudo-registers *) 16 | 17 | type t = 18 | { mutable name: string; (* Name (for printing) *) 19 | stamp: int; (* Unique stamp *) 20 | typ: Cmm.machtype_component; (* Type of contents *) 21 | mutable loc: location; (* Actual location *) 22 | mutable spill: bool; (* "true" to force stack allocation *) 23 | mutable interf: t list; (* Other regs live simultaneously *) 24 | mutable prefer: (t * int) list; (* Preferences for other regs *) 25 | mutable degree: int; (* Number of other regs live sim. *) 26 | mutable spill_cost: int; (* Estimate of spilling cost *) 27 | mutable visited: bool } (* For graph walks *) 28 | 29 | and location = 30 | Unknown 31 | | Reg of int 32 | | Stack of stack_location 33 | 34 | and stack_location = 35 | Local of int 36 | | Incoming of int 37 | | Outgoing of int 38 | 39 | val dummy: t 40 | val create: Cmm.machtype_component -> t 41 | val createv: Cmm.machtype -> t array 42 | val createv_like: t array -> t array 43 | val clone: t -> t 44 | val at_location: Cmm.machtype_component -> location -> t 45 | 46 | module Set: Set.S with type elt = t 47 | module Map: Map.S with type key = t 48 | 49 | val add_set_array: Set.t -> t array -> Set.t 50 | val diff_set_array: Set.t -> t array -> Set.t 51 | val inter_set_array: Set.t -> t array -> Set.t 52 | val set_of_array: t array -> Set.t 53 | 54 | val reset: unit -> unit 55 | val all_registers: unit -> t list 56 | val num_registers: unit -> int 57 | val reinit: unit -> unit 58 | -------------------------------------------------------------------------------- /src/asmcomp/sparc/scheduling.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: scheduling.ml 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | open Cmm 16 | open Mach 17 | 18 | (* Instruction scheduling for the Sparc *) 19 | 20 | class scheduler = object 21 | 22 | inherit Schedgen.scheduler_generic 23 | 24 | (* Latencies (in cycles). *) 25 | 26 | (* UltraSPARC issues two integer operations, plus a single load or store, 27 | per cycle. At most one of the integer instructions may be a shift. 28 | Most integer operations have one cycle latency. Unsigned loads take 29 | two cycles. Signed loads take three cycles. Conditional moves have 30 | two cycle latency and may not issue in the same cycle as any other 31 | instruction. Floating point issue rules are complicated, but in 32 | general independent add and multiply can dual issue with four cycle 33 | latency. *) 34 | 35 | method oper_latency = function 36 | Ireload -> 2 37 | | Iload((Byte_signed|Sixteen_signed|Thirtytwo_signed), _) -> 3 38 | | Iload(_, _) -> 2 39 | | Iconst_float _ -> 2 (* turned into a load *) 40 | | Inegf | Iabsf | Iaddf | Isubf | Imulf -> 4 41 | | Idivf -> 15 42 | | _ -> 1 43 | 44 | (* Issue cycles. Rough approximations. *) 45 | 46 | method oper_issue_cycles = function 47 | Iconst_float _ -> 2 48 | | Iconst_symbol _ -> 2 49 | | Ialloc _ -> 6 50 | | Iintop(Icomp _) -> 4 51 | | Iintop(Icheckbound) -> 2 52 | | Iintop_imm(Idiv, _) -> 5 53 | | Iintop_imm(Imod, _) -> 5 54 | | Iintop_imm(Icomp _, _) -> 4 55 | | Iintop_imm(Icheckbound, _) -> 2 56 | | Inegf -> 2 57 | | Iabsf -> 2 58 | | Ifloatofint -> 6 59 | | Iintoffloat -> 6 60 | | _ -> 1 61 | 62 | end 63 | 64 | let fundecl f = (new scheduler)#schedule_fundecl f 65 | -------------------------------------------------------------------------------- /src/toplevel/topfind.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* ocamlnat *) 4 | (* *) 5 | (* Benedikt Meurer, University of Siegen *) 6 | (* *) 7 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 8 | (* Universität Siegen. All rights reserved. This file is distri- *) 9 | (* buted under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* Load packages from toploops and scripts *) 14 | 15 | val predicates: string list ref 16 | (* The list of predicates used for package loading. *) 17 | 18 | val add_predicates: string list -> unit 19 | (* Adds predicates to the list of predicates. *) 20 | 21 | val syntax: string -> unit 22 | (* Emulates the [-syntax] option. *) 23 | 24 | val standard_syntax: unit -> unit 25 | (* Adds predicates that select the standard syntax. Same as 26 | [syntax "camlp4o"]. *) 27 | 28 | val revised_syntax: unit -> unit 29 | (* Adds predicates that select the revised syntax. Same as 30 | [syntax "camlp4r"]. *) 31 | 32 | val don't_load: string list -> unit 33 | (* The packages named in pkglist are added to the list of packages which 34 | are already loaded. *) 35 | 36 | val don't_load_deeply: string list -> unit 37 | (* The packages named in pkglist and all direct and indirect ancestors 38 | are added to the list of packages which are already loaded. *) 39 | 40 | val load: string list -> unit 41 | (* The packages from the passed package list are loaded, from left to 42 | right, but packages that have already been loaded are left out. *) 43 | 44 | val load_deeply: string list -> unit 45 | (* The packages from the passed package list and all direct or indirect 46 | ancestors are loaded in topological order. Packages that have already 47 | been loaded are left out. *) 48 | 49 | val reset: unit -> unit 50 | (* All entries in the list of loaded packages that have been added by 51 | [load] or [load_deeply] functions are removed from this list. This 52 | means that if you execute the same [load] or [load_deeply] functions 53 | again, the packages will be reloaded. *) 54 | 55 | val announce: unit -> unit 56 | (* Output the startup message. *) 57 | -------------------------------------------------------------------------------- /src/asmcomp/hppa/arch.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: arch.ml 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | (* Specific operations for the HP PA-RISC processor *) 16 | 17 | open Misc 18 | open Format 19 | 20 | (* Machine-specific command-line options *) 21 | 22 | let command_line_options = [] 23 | 24 | (* Specific operations *) 25 | 26 | type specific_operation = 27 | Ishift1add 28 | | Ishift2add 29 | | Ishift3add 30 | 31 | (* Addressing modes *) 32 | 33 | type addressing_mode = 34 | Ibased of string * int (* symbol + displ *) 35 | | Iindexed of int (* reg + displ *) 36 | 37 | (* Sizes, endianness *) 38 | 39 | let big_endian = true 40 | 41 | let size_addr = 4 42 | let size_int = 4 43 | let size_float = 8 44 | 45 | (* Operations on addressing modes *) 46 | 47 | let identity_addressing = Iindexed 0 48 | 49 | let offset_addressing addr delta = 50 | match addr with 51 | Ibased(s, n) -> Ibased(s, n + delta) 52 | | Iindexed n -> Iindexed(n + delta) 53 | 54 | let num_args_addressing = function 55 | Ibased(s, n) -> 0 56 | | Iindexed n -> 1 57 | 58 | (* Printing operations and addressing modes *) 59 | 60 | let print_addressing printreg addr ppf arg = 61 | match addr with 62 | | Ibased(s, n) -> 63 | let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in 64 | fprintf ppf "\"%s\"%s" s idx 65 | | Iindexed n -> 66 | let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in 67 | fprintf ppf "%a%s" printreg arg.(0) idx 68 | 69 | let print_specific_operation printreg op ppf arg = 70 | match op with 71 | | Ishift1add -> fprintf ppf "%a << 1 + %a" printreg arg.(0) printreg arg.(1) 72 | | Ishift2add -> fprintf ppf "%a << 2 + %a" printreg arg.(0) printreg arg.(1) 73 | | Ishift3add -> fprintf ppf "%a << 3 + %a" printreg arg.(0) printreg arg.(1) 74 | -------------------------------------------------------------------------------- /src/typing/subst.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: subst.mli 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | (* Substitutions *) 16 | 17 | open Types 18 | 19 | type t 20 | 21 | (* 22 | Substitutions are used to translate a type from one context to 23 | another. This requires substituing paths for identifiers, and 24 | possibly also lowering the level of non-generic variables so that 25 | it be inferior to the maximum level of the new context. 26 | 27 | Substitutions can also be used to create a "clean" copy of a type. 28 | Indeed, non-variable node of a type are duplicated, with their 29 | levels set to generic level. That way, the resulting type is 30 | well-formed (decreasing levels), even if the original one was not. 31 | *) 32 | 33 | val identity: t 34 | 35 | val add_type: Ident.t -> Path.t -> t -> t 36 | val add_module: Ident.t -> Path.t -> t -> t 37 | val add_modtype: Ident.t -> module_type -> t -> t 38 | val for_saving: t -> t 39 | val reset_for_saving: unit -> unit 40 | 41 | val module_path: t -> Path.t -> Path.t 42 | val type_path: t -> Path.t -> Path.t 43 | 44 | val type_expr: t -> type_expr -> type_expr 45 | val class_type: t -> class_type -> class_type 46 | val value_description: t -> value_description -> value_description 47 | val type_declaration: t -> type_declaration -> type_declaration 48 | val exception_declaration: 49 | t -> exception_declaration -> exception_declaration 50 | val class_declaration: t -> class_declaration -> class_declaration 51 | val cltype_declaration: t -> cltype_declaration -> cltype_declaration 52 | val modtype: t -> module_type -> module_type 53 | val signature: t -> signature -> signature 54 | val modtype_declaration: t -> modtype_declaration -> modtype_declaration 55 | 56 | (* Composition of substitutions: 57 | apply (compose s1 s2) x = apply s2 (apply s1 x) *) 58 | val compose: t -> t -> t 59 | -------------------------------------------------------------------------------- /src/typing/parmatch.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: parmatch.mli 8906 2008-07-09 13:03:38Z mauny $ *) 14 | 15 | (* Detection of partial matches and unused match cases. *) 16 | open Types 17 | open Typedtree 18 | 19 | val top_pretty : Format.formatter -> pattern -> unit 20 | val pretty_pat : pattern -> unit 21 | val pretty_line : pattern list -> unit 22 | val pretty_matrix : pattern list list -> unit 23 | 24 | val omega : pattern 25 | val omegas : int -> pattern list 26 | val omega_list : 'a list -> pattern list 27 | val normalize_pat : pattern -> pattern 28 | val all_record_args : 29 | (label_description * pattern) list -> (label_description * pattern) list 30 | 31 | val le_pat : pattern -> pattern -> bool 32 | val le_pats : pattern list -> pattern list -> bool 33 | val compat : pattern -> pattern -> bool 34 | val compats : pattern list -> pattern list -> bool 35 | exception Empty 36 | val lub : pattern -> pattern -> pattern 37 | val lubs : pattern list -> pattern list -> pattern list 38 | 39 | val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list 40 | 41 | (* Those to functions recombine one pattern and its arguments: 42 | For instance: 43 | (_,_)::p1::p2::rem -> (p1, p2)::rem 44 | The second one will replace mutable arguments by '_' 45 | *) 46 | val set_args : pattern -> pattern list -> pattern list 47 | val set_args_erase_mutable : pattern -> pattern list -> pattern list 48 | 49 | val pat_of_constr : pattern -> constructor_description -> pattern 50 | val complete_constrs : 51 | pattern -> constructor_tag list -> constructor_description list 52 | 53 | val pressure_variants: Env.t -> pattern list -> unit 54 | val check_partial: Location.t -> (pattern * expression) list -> partial 55 | val check_unused: Env.t -> (pattern * expression) list -> unit 56 | 57 | (* Irrefutability tests *) 58 | val irrefutable : pattern -> bool 59 | val fluid : pattern -> bool 60 | -------------------------------------------------------------------------------- /tests/test.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* ocamlnat *) 4 | (* *) 5 | (* Benedikt Meurer, University of Siegen *) 6 | (* *) 7 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 8 | (* Universität Siegen. All rights reserved. This file is distri- *) 9 | (* buted under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | open OUnit 14 | 15 | let ocamlnat = ref "ocamlnat" 16 | 17 | let readfile fn = 18 | let ic = open_in fn in 19 | begin try 20 | let n = in_channel_length ic in 21 | let b = Buffer.create n in 22 | Buffer.add_channel b ic n; 23 | close_in ic; 24 | b 25 | with exn -> 26 | close_in ic; 27 | raise exn 28 | end 29 | 30 | let test_basic options dirname filename = 31 | filename >:: begin fun () -> 32 | let path = Filename.concat dirname filename in 33 | let reference = readfile (path ^ ".reference") in 34 | let result = Buffer.create (Buffer.length reference) in 35 | assert_command 36 | ~foutput:(Stream.iter (Buffer.add_char result)) 37 | ~use_stderr:true 38 | !ocamlnat 39 | (options @ [path ^ ".ml"]); 40 | assert_equal result reference 41 | end 42 | 43 | let suite_basic dirname = 44 | let tests = List.map 45 | (fun fn -> Filename.chop_suffix fn ".reference") 46 | (List.filter 47 | (fun fn -> Filename.check_suffix fn ".reference") 48 | (Array.to_list (Sys.readdir dirname))) in 49 | dirname >::: 50 | [ 51 | "safe/gc" >::: 52 | (List.map (test_basic ["-regalloc"; "gc"] dirname) tests); 53 | "unsafe/gc" >::: 54 | (List.map (test_basic ["-regalloc"; "gc"; "-unsafe"] dirname) tests); 55 | "safe/ls" >::: 56 | (List.map (test_basic ["-regalloc"; "ls"] dirname) tests); 57 | "unsafe/ls" >::: 58 | (List.map (test_basic ["-regalloc"; "ls"; "-unsafe"] dirname) tests); 59 | ] 60 | 61 | let suite = 62 | "ocamlnat" >::: 63 | [ 64 | suite_basic "basic"; 65 | ] 66 | 67 | let _ = 68 | run_test_tt_main 69 | ~arg_specs:["-ocamlnat", 70 | Arg.String (fun fn -> ocamlnat := fn), 71 | "fn Path to ocamlnat"] 72 | suite 73 | 74 | -------------------------------------------------------------------------------- /src/asmcomp/alpha/scheduling.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: scheduling.ml 2553 1999-11-17 18:59:06Z xleroy $ *) 14 | 15 | open Arch 16 | open Mach 17 | 18 | (* The Digital Unix assembler does scheduling better than us. 19 | However, the Linux-Alpha assembler does not do scheduling, so we do 20 | a feeble attempt here. *) 21 | 22 | class scheduler = object (self) 23 | 24 | inherit Schedgen.scheduler_generic as super 25 | 26 | (* Latencies (in cycles). Based on the 21064, with some poetic license. *) 27 | 28 | method oper_latency = function 29 | Ireload -> 3 30 | | Iload(_, _) -> 3 31 | | Iconst_symbol _ -> 3 (* turned into a load *) 32 | | Iconst_float _ -> 3 (* ends up in a load *) 33 | | Iintop(Imul) -> 23 34 | | Iintop_imm(Imul, _) -> 23 35 | | Iaddf -> 6 36 | | Isubf -> 6 37 | | Imulf -> 6 38 | | Idivf -> 63 39 | | _ -> 2 40 | (* Most arithmetic instructions can be executed back-to-back in 1 cycle. 41 | However, some combinations (arith; load or arith; store) require 2 42 | cycles. Also, by claiming 2 cycles instead of 1, we might favor 43 | dual issue. *) 44 | 45 | (* Issue cycles. Rough approximations. *) 46 | 47 | method oper_issue_cycles = function 48 | Iconst_float _ -> 4 (* load from $gp, then load *) 49 | | Ialloc _ -> 4 50 | | Iintop(Icheckbound) -> 2 51 | | Iintop_imm(Idiv, _) -> 3 52 | | Iintop_imm(Imod, _) -> 5 53 | | Iintop_imm(Icheckbound, _) -> 2 54 | | Ifloatofint -> 10 55 | | Iintoffloat -> 10 56 | | _ -> 1 57 | 58 | (* Say that reloadgp is not part of a basic block (prevents moving it 59 | past an operation that uses $gp) *) 60 | 61 | method oper_in_basic_block = function 62 | Ispecific(Ireloadgp _) -> false 63 | | op -> super#oper_in_basic_block op 64 | 65 | end 66 | 67 | let fundecl = 68 | if digital_asm 69 | then (fun f -> f) 70 | else (new scheduler)#schedule_fundecl 71 | -------------------------------------------------------------------------------- /src/parsing/parse.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: parse.ml 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | (* Entry points in the parser *) 16 | 17 | open Location 18 | 19 | (* Skip tokens to the end of the phrase *) 20 | 21 | let rec skip_phrase lexbuf = 22 | try 23 | match Lexer.token lexbuf with 24 | Parser.SEMISEMI | Parser.EOF -> () 25 | | _ -> skip_phrase lexbuf 26 | with 27 | | Lexer.Error (Lexer.Unterminated_comment, _) -> () 28 | | Lexer.Error (Lexer.Unterminated_string, _) -> () 29 | | Lexer.Error (Lexer.Unterminated_string_in_comment, _) -> () 30 | | Lexer.Error (Lexer.Illegal_character _, _) -> skip_phrase lexbuf 31 | ;; 32 | 33 | let maybe_skip_phrase lexbuf = 34 | if Parsing.is_current_lookahead Parser.SEMISEMI 35 | || Parsing.is_current_lookahead Parser.EOF 36 | then () 37 | else skip_phrase lexbuf 38 | 39 | let wrap parsing_fun lexbuf = 40 | try 41 | let ast = parsing_fun Lexer.token lexbuf in 42 | Parsing.clear_parser(); 43 | ast 44 | with 45 | | Lexer.Error(Lexer.Unterminated_comment, _) as err -> raise err 46 | | Lexer.Error(Lexer.Unterminated_string, _) as err -> raise err 47 | | Lexer.Error(Lexer.Unterminated_string_in_comment, _) as err -> raise err 48 | | Lexer.Error(Lexer.Illegal_character _, _) as err -> 49 | if !Location.input_name = "" then skip_phrase lexbuf; 50 | raise err 51 | | Syntaxerr.Error _ as err -> 52 | if !Location.input_name = "" then maybe_skip_phrase lexbuf; 53 | raise err 54 | | Parsing.Parse_error | Syntaxerr.Escape_error -> 55 | let loc = Location.curr lexbuf in 56 | if !Location.input_name = "" 57 | then maybe_skip_phrase lexbuf; 58 | raise(Syntaxerr.Error(Syntaxerr.Other loc)) 59 | ;; 60 | 61 | let implementation = wrap Parser.implementation 62 | and interface = wrap Parser.interface 63 | and toplevel_phrase = wrap Parser.toplevel_phrase 64 | and use_file = wrap Parser.use_file 65 | -------------------------------------------------------------------------------- /src/asmcomp/sparc/arch.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: arch.ml 5303 2002-11-29 15:03:08Z xleroy $ *) 14 | 15 | (* Specific operations for the Sparc processor *) 16 | 17 | open Misc 18 | open Format 19 | 20 | (* SPARC V8 adds multiply and divide. 21 | SPARC V9 adds double precision float operations, conditional 22 | move, and more instructions that are only useful in 64 bit mode. 23 | Sun calls 32 bit V9 "V8+". *) 24 | type arch_version = SPARC_V7 | SPARC_V8 | SPARC_V9 25 | 26 | let arch_version = ref SPARC_V7 27 | 28 | let command_line_options = 29 | [ "-march=v8", Arg.Unit (fun () -> arch_version := SPARC_V8), 30 | " Generate code for SPARC V8 processors"; 31 | "-march=v9", Arg.Unit (fun () -> arch_version := SPARC_V9), 32 | " Generate code for SPARC V9 processors" ] 33 | 34 | type specific_operation = unit (* None worth mentioning *) 35 | 36 | (* Addressing modes *) 37 | 38 | type addressing_mode = 39 | Ibased of string * int (* symbol + displ *) 40 | | Iindexed of int (* reg + displ *) 41 | 42 | (* Sizes, endianness *) 43 | 44 | let big_endian = true 45 | 46 | let size_addr = 4 47 | let size_int = 4 48 | let size_float = 8 49 | 50 | (* Operations on addressing modes *) 51 | 52 | let identity_addressing = Iindexed 0 53 | 54 | let offset_addressing addr delta = 55 | match addr with 56 | Ibased(s, n) -> Ibased(s, n + delta) 57 | | Iindexed n -> Iindexed(n + delta) 58 | 59 | let num_args_addressing = function 60 | Ibased(s, n) -> 0 61 | | Iindexed n -> 1 62 | 63 | (* Printing operations and addressing modes *) 64 | 65 | let print_addressing printreg addr ppf arg = 66 | match addr with 67 | | Ibased(s, n) -> 68 | let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in 69 | fprintf ppf "\"%s\"%s" s idx 70 | | Iindexed n -> 71 | let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in 72 | fprintf ppf "%a%s" printreg arg.(0) idx 73 | 74 | let print_specific_operation printreg op ppf arg = 75 | Misc.fatal_error "Arch_sparc.print_specific_operation" 76 | -------------------------------------------------------------------------------- /src/jitcomp/jitlink.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* ocamlnat *) 4 | (* *) 5 | (* Benedikt Meurer, University of Siegen *) 6 | (* *) 7 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 8 | (* Universität Siegen. All rights reserved. This file is distri- *) 9 | (* buted under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* Linker functionality *) 14 | 15 | open Misc 16 | 17 | type error = 18 | Cannot_generate_cmxs 19 | | File_not_found of string 20 | | Unsupported_file of string 21 | | Undefined_global of string 22 | | Dynamic_linking_failed of string * Dynlink.error 23 | 24 | exception Error of error 25 | 26 | (* Load in-core a .cmxs file *) 27 | 28 | let loadfile name0 = 29 | try 30 | let name = (try find_in_path !Config.load_path name0 31 | with Not_found -> raise (Error(File_not_found name0))) in 32 | if Filename.check_suffix name ".cmxs" then begin 33 | (* .cmxs files can be loaded directly *) 34 | Dynlink.loadfile name 35 | end else if Filename.check_suffix name ".cmxa" then begin 36 | (* Need to generate a temporary .cmxs file first *) 37 | let temp = (Filename.basename (Filename.chop_extension name0)) in 38 | let cmxs = Filename.temp_file temp ".cmxs" in 39 | let cmd = Printf.sprintf "%s -linkall -shared -o %s %s" 40 | (Filename.quote "ocamlopt") 41 | (Filename.quote cmxs) 42 | (Filename.quote name) in 43 | if Ccomp.command cmd != 0 then raise (Error Cannot_generate_cmxs); 44 | try_finally 45 | (fun () -> Dynlink.loadfile cmxs) 46 | (fun () -> try Sys.remove cmxs with Sys_error _ -> ()) 47 | end else 48 | raise (Error(Unsupported_file name)) 49 | with 50 | Dynlink.Error error -> raise (Error(Dynamic_linking_failed(name0, error))) 51 | 52 | (* Error report *) 53 | 54 | open Format 55 | 56 | let report_error ppf = function 57 | | Cannot_generate_cmxs -> 58 | fprintf ppf "Failed to generate temporary cmxs file" 59 | | File_not_found name -> 60 | fprintf ppf "File not found `%s'" name 61 | | Unsupported_file name -> 62 | fprintf ppf "Unsupported file `%s'" name 63 | | Undefined_global s -> 64 | fprintf ppf "Reference to undefined global `%s'" s 65 | | Dynamic_linking_failed(name, error) -> 66 | fprintf ppf "Error while loading `%s' - %s" 67 | name (Dynlink.error_message error) 68 | -------------------------------------------------------------------------------- /src/parsing/linenum.mll: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1997 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: linenum.mll 9547 2010-01-22 12:48:24Z doligez $ *) 14 | 15 | (* An auxiliary lexer for determining the line number corresponding to 16 | a file position, honoring the directives # linenum "filename" *) 17 | 18 | { 19 | let filename = ref "" 20 | let linenum = ref 0 21 | let linebeg = ref 0 22 | 23 | let parse_sharp_line s = 24 | try 25 | (* Update the line number and file name *) 26 | let l1 = ref 0 in 27 | while let c = s.[!l1] in c < '0' || c > '9' do incr l1 done; 28 | let l2 = ref (!l1 + 1) in 29 | while let c = s.[!l2] in c >= '0' && c <= '9' do incr l2 done; 30 | linenum := int_of_string(String.sub s !l1 (!l2 - !l1)); 31 | let f1 = ref (!l2 + 1) in 32 | while !f1 < String.length s && s.[!f1] <> '"' do incr f1 done; 33 | let f2 = ref (!f1 + 1) in 34 | while !f2 < String.length s && s.[!f2] <> '"' do incr f2 done; 35 | if !f1 < String.length s then 36 | filename := String.sub s (!f1 + 1) (!f2 - !f1 - 1) 37 | with Failure _ | Invalid_argument _ -> 38 | Misc.fatal_error "Linenum.parse_sharp_line" 39 | } 40 | 41 | rule skip_line = parse 42 | "#" [' ' '\t']* ['0'-'9']+ [' ' '\t']* 43 | ("\"" [^ '\n' '\r' '"' (* '"' *) ] * "\"")? 44 | [^ '\n' '\r'] * 45 | ('\n' | '\r' | "\r\n") 46 | { parse_sharp_line(Lexing.lexeme lexbuf); 47 | linebeg := Lexing.lexeme_start lexbuf; 48 | Lexing.lexeme_end lexbuf } 49 | | [^ '\n' '\r'] * 50 | ('\n' | '\r' | "\r\n") 51 | { incr linenum; 52 | linebeg := Lexing.lexeme_start lexbuf; 53 | Lexing.lexeme_end lexbuf } 54 | | [^ '\n' '\r'] * eof 55 | { incr linenum; 56 | linebeg := Lexing.lexeme_start lexbuf; 57 | raise End_of_file } 58 | 59 | { 60 | 61 | let for_position file loc = 62 | let ic = open_in_bin file in 63 | let lb = Lexing.from_channel ic in 64 | filename := file; 65 | linenum := 1; 66 | linebeg := 0; 67 | begin try 68 | while skip_line lb <= loc do () done 69 | with End_of_file -> () 70 | end; 71 | close_in ic; 72 | (!filename, !linenum - 1, !linebeg) 73 | 74 | } 75 | -------------------------------------------------------------------------------- /src/asmcomp/printlinear.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: printlinear.ml 7812 2007-01-29 12:11:18Z xleroy $ *) 14 | 15 | (* Pretty-printing of linearized machine code *) 16 | 17 | open Format 18 | open Mach 19 | open Printmach 20 | open Linearize 21 | 22 | let label ppf l = 23 | Format.fprintf ppf "L%i" l 24 | 25 | let instr ppf i = 26 | begin match i.desc with 27 | | Lend -> () 28 | | Lop op -> 29 | begin match op with 30 | | Ialloc _ | Icall_ind | Icall_imm _ | Iextcall(_, _) -> 31 | fprintf ppf "@[<1>{%a}@]@," regsetaddr i.live 32 | | _ -> () 33 | end; 34 | operation op i.arg ppf i.res 35 | | Lreloadretaddr -> 36 | fprintf ppf "reload retaddr" 37 | | Lreturn -> 38 | fprintf ppf "return %a" regs i.arg 39 | | Llabel lbl -> 40 | fprintf ppf "%a:" label lbl 41 | | Lbranch lbl -> 42 | fprintf ppf "goto %a" label lbl 43 | | Lcondbranch(tst, lbl) -> 44 | fprintf ppf "if %a goto %a" (test tst) i.arg label lbl 45 | | Lcondbranch3(lbl0, lbl1, lbl2) -> 46 | fprintf ppf "switch3 %a" reg i.arg.(0); 47 | let case n = function 48 | | None -> () 49 | | Some lbl -> 50 | fprintf ppf "@,case %i: goto %a" n label lbl in 51 | case 0 lbl0; case 1 lbl1; case 2 lbl2; 52 | fprintf ppf "@,endswitch" 53 | | Lswitch lblv -> 54 | fprintf ppf "switch %a" reg i.arg.(0); 55 | for i = 0 to Array.length lblv - 1 do 56 | fprintf ppf "case %i: goto %a" i label lblv.(i) 57 | done; 58 | fprintf ppf "@,endswitch" 59 | | Lsetuptrap lbl -> 60 | fprintf ppf "setup trap %a" label lbl 61 | | Lpushtrap -> 62 | fprintf ppf "push trap" 63 | | Lpoptrap -> 64 | fprintf ppf "pop trap" 65 | | Lraise -> 66 | fprintf ppf "raise %a" reg i.arg.(0) 67 | end; 68 | if i.dbg != Debuginfo.none then 69 | fprintf ppf " %s" (Debuginfo.to_string i.dbg) 70 | 71 | let rec all_instr ppf i = 72 | match i.desc with 73 | | Lend -> () 74 | | _ -> fprintf ppf "%a@,%a" instr i all_instr i.next 75 | 76 | let fundecl ppf f = 77 | fprintf ppf "@[%s:@,%a@]" f.fun_name all_instr f.fun_body 78 | -------------------------------------------------------------------------------- /src/asmcomp/clambda.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: clambda.ml 7812 2007-01-29 12:11:18Z xleroy $ *) 14 | 15 | (* A variant of the "lambda" code with direct / indirect calls explicit 16 | and closures explicit too *) 17 | 18 | open Asttypes 19 | open Lambda 20 | 21 | type function_label = string 22 | 23 | type ulambda = 24 | Uvar of Ident.t 25 | | Uconst of structured_constant 26 | | Udirect_apply of function_label * ulambda list * Debuginfo.t 27 | | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t 28 | | Uclosure of (function_label * int * Ident.t list * ulambda) list 29 | * ulambda list 30 | | Uoffset of ulambda * int 31 | | Ulet of Ident.t * ulambda * ulambda 32 | | Uletrec of (Ident.t * ulambda) list * ulambda 33 | | Uprim of primitive * ulambda list * Debuginfo.t 34 | | Uswitch of ulambda * ulambda_switch 35 | | Ustaticfail of int * ulambda list 36 | | Ucatch of int * Ident.t list * ulambda * ulambda 37 | | Utrywith of ulambda * Ident.t * ulambda 38 | | Uifthenelse of ulambda * ulambda * ulambda 39 | | Usequence of ulambda * ulambda 40 | | Uwhile of ulambda * ulambda 41 | | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda 42 | | Uassign of Ident.t * ulambda 43 | | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t 44 | 45 | and ulambda_switch = 46 | { us_index_consts: int array; 47 | us_actions_consts : ulambda array; 48 | us_index_blocks: int array; 49 | us_actions_blocks: ulambda array} 50 | 51 | (* Description of known functions *) 52 | 53 | type function_description = 54 | { fun_label: function_label; (* Label of direct entry point *) 55 | fun_arity: int; (* Number of arguments *) 56 | mutable fun_closed: bool; (* True if environment not used *) 57 | mutable fun_inline: (Ident.t list * ulambda) option } 58 | 59 | (* Approximation of values *) 60 | 61 | type value_approximation = 62 | Value_closure of function_description * value_approximation 63 | | Value_tuple of value_approximation array 64 | | Value_unknown 65 | | Value_integer of int 66 | | Value_constptr of int 67 | -------------------------------------------------------------------------------- /src/asmcomp/clambda.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: clambda.mli 7812 2007-01-29 12:11:18Z xleroy $ *) 14 | 15 | (* A variant of the "lambda" code with direct / indirect calls explicit 16 | and closures explicit too *) 17 | 18 | open Asttypes 19 | open Lambda 20 | 21 | type function_label = string 22 | 23 | type ulambda = 24 | Uvar of Ident.t 25 | | Uconst of structured_constant 26 | | Udirect_apply of function_label * ulambda list * Debuginfo.t 27 | | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t 28 | | Uclosure of (function_label * int * Ident.t list * ulambda) list 29 | * ulambda list 30 | | Uoffset of ulambda * int 31 | | Ulet of Ident.t * ulambda * ulambda 32 | | Uletrec of (Ident.t * ulambda) list * ulambda 33 | | Uprim of primitive * ulambda list * Debuginfo.t 34 | | Uswitch of ulambda * ulambda_switch 35 | | Ustaticfail of int * ulambda list 36 | | Ucatch of int * Ident.t list * ulambda * ulambda 37 | | Utrywith of ulambda * Ident.t * ulambda 38 | | Uifthenelse of ulambda * ulambda * ulambda 39 | | Usequence of ulambda * ulambda 40 | | Uwhile of ulambda * ulambda 41 | | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda 42 | | Uassign of Ident.t * ulambda 43 | | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t 44 | 45 | and ulambda_switch = 46 | { us_index_consts: int array; 47 | us_actions_consts: ulambda array; 48 | us_index_blocks: int array; 49 | us_actions_blocks: ulambda array} 50 | 51 | (* Description of known functions *) 52 | 53 | type function_description = 54 | { fun_label: function_label; (* Label of direct entry point *) 55 | fun_arity: int; (* Number of arguments *) 56 | mutable fun_closed: bool; (* True if environment not used *) 57 | mutable fun_inline: (Ident.t list * ulambda) option } 58 | 59 | (* Approximation of values *) 60 | 61 | type value_approximation = 62 | Value_closure of function_description * value_approximation 63 | | Value_tuple of value_approximation array 64 | | Value_unknown 65 | | Value_integer of int 66 | | Value_constptr of int 67 | -------------------------------------------------------------------------------- /src/jitcomp/jitaux.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* ocamlnat *) 4 | (* *) 5 | (* Benedikt Meurer, University of Siegen *) 6 | (* *) 7 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 8 | (* Universität Siegen. All rights reserved. This file is distri- *) 9 | (* buted under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* Common functions for jitting code *) 14 | 15 | open Linearize 16 | 17 | (* Native addressing *) 18 | 19 | module Addr : 20 | sig 21 | include module type of Nativeint 22 | 23 | external of_int64: int64 -> t = "%int64_to_nativeint" 24 | external to_int64: t -> int64 = "%int64_of_nativeint" 25 | 26 | val add_int: t -> int -> t 27 | val sub_int: t -> int -> t 28 | end 29 | 30 | (* Execution *) 31 | 32 | type evaluation_outcome = Result of Obj.t | Exception of exn 33 | 34 | val jit_execsym: string -> evaluation_outcome 35 | val jit_loadsym: string -> Obj.t 36 | 37 | (* Sections *) 38 | 39 | val jit_text: unit -> unit 40 | val jit_data: unit -> unit 41 | 42 | (* Labels and symbols *) 43 | 44 | val jit_label: label -> unit 45 | val jit_symbol: string -> unit 46 | val jit_global: string -> unit 47 | 48 | (* Tags *) 49 | 50 | module Tag : 51 | sig 52 | type t 53 | 54 | external is_label: t -> bool = "%obj_is_int" 55 | val is_symbol: t -> bool 56 | 57 | external of_label: label -> t = "%identity" 58 | val of_symbol: string -> t 59 | 60 | val to_addr: t -> Addr.t 61 | end 62 | 63 | (* Relocations *) 64 | 65 | type relocfn = (*S*)Addr.t -> (*P*)Addr.t -> (*A*)int32 -> int32 66 | type reloc = 67 | R_ABS_32 of Tag.t (* 32bit absolute *) 68 | | R_ABS_64 of Tag.t (* 64bit absolute *) 69 | | R_REL_32 of Tag.t (* 32bit relative *) 70 | | R_FUN_32 of Tag.t * relocfn (* 32bit custom *) 71 | val jit_reloc: reloc -> unit 72 | 73 | val jit_int8: int -> unit 74 | val jit_int8n: nativeint -> unit 75 | val jit_int16: int -> unit 76 | val jit_int16n: nativeint -> unit 77 | val jit_int32: int -> unit 78 | val jit_int32l: int32 -> unit 79 | val jit_int32n: nativeint -> unit 80 | val jit_int64: int -> unit 81 | val jit_int64L: int64 -> unit 82 | val jit_int64n: nativeint -> unit 83 | val jit_ascii: string -> unit 84 | val jit_asciz: string -> unit 85 | 86 | val jit_fill: int -> int -> unit 87 | val jit_align: int -> int -> unit 88 | 89 | val data: Cmm.data_item list -> unit 90 | 91 | val begin_assembly: unit -> unit 92 | val end_assembly: unit -> unit 93 | -------------------------------------------------------------------------------- /src/utils/consistbl.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2002 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: consistbl.mli 5275 2002-11-18 10:41:26Z xleroy $ *) 14 | 15 | (* Consistency tables: for checking consistency of module CRCs *) 16 | 17 | type t 18 | 19 | val create: unit -> t 20 | 21 | val clear: t -> unit 22 | 23 | val check: t -> string -> Digest.t -> string -> unit 24 | (* [check tbl name crc source] 25 | checks consistency of ([name], [crc]) with infos previously 26 | stored in [tbl]. If no CRC was previously associated with 27 | [name], record ([name], [crc]) in [tbl]. 28 | [source] is the name of the file from which the information 29 | comes from. This is used for error reporting. *) 30 | 31 | val check_noadd: t -> string -> Digest.t -> string -> unit 32 | (* Same as [check], but raise [Not_available] if no CRC was previously 33 | associated with [name]. *) 34 | 35 | val set: t -> string -> Digest.t -> string -> unit 36 | (* [set tbl name crc source] forcefully associates [name] with 37 | [crc] in [tbl], even if [name] already had a different CRC 38 | associated with [name] in [tbl]. *) 39 | 40 | val source: t -> string -> string 41 | (* [source tbl name] returns the file name associated with [name] 42 | if the latter has an associated CRC in [tbl]. 43 | Raise [Not_found] otherwise. *) 44 | 45 | val extract: t -> (string * Digest.t) list 46 | (* Return all bindings ([name], [crc]) contained in the given 47 | table. *) 48 | 49 | val filter: (string -> bool) -> t -> unit 50 | (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs 51 | such that [pred name] is [false]. *) 52 | 53 | exception Inconsistency of string * string * string 54 | (* Raised by [check] when a CRC mismatch is detected. 55 | First string is the name of the compilation unit. 56 | Second string is the source that caused the inconsistency. 57 | Third string is the source that set the CRC. *) 58 | 59 | exception Not_available of string 60 | (* Raised by [check_noadd] when a name doesn't have an associated CRC. *) 61 | -------------------------------------------------------------------------------- /src/asmcomp/arm/arch.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1998 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: arch.ml 5304 2002-11-29 15:03:37Z xleroy $ *) 14 | 15 | (* Specific operations for the ARM processor *) 16 | 17 | open Misc 18 | open Format 19 | 20 | (* Machine-specific command-line options *) 21 | 22 | let command_line_options = [] 23 | 24 | (* Addressing modes *) 25 | 26 | type addressing_mode = 27 | Iindexed of int (* reg + displ *) 28 | 29 | (* We do not support the reg + shifted reg addressing mode, because 30 | what we really need is reg + shifted reg + displ, 31 | and this is decomposed in two instructions (reg + shifted reg -> tmp, 32 | then addressing tmp + displ). *) 33 | 34 | (* Specific operations *) 35 | 36 | type specific_operation = 37 | Ishiftarith of arith_operation * int 38 | | Ishiftcheckbound of int 39 | | Irevsubimm of int 40 | 41 | and arith_operation = 42 | Ishiftadd 43 | | Ishiftsub 44 | | Ishiftsubrev 45 | 46 | (* Sizes, endianness *) 47 | 48 | let big_endian = false 49 | 50 | let size_addr = 4 51 | let size_int = 4 52 | let size_float = 8 53 | 54 | (* Operations on addressing modes *) 55 | 56 | let identity_addressing = Iindexed 0 57 | 58 | let offset_addressing (Iindexed n) delta = Iindexed(n + delta) 59 | 60 | let num_args_addressing (Iindexed n) = 1 61 | 62 | (* Printing operations and addressing modes *) 63 | 64 | let print_addressing printreg addr ppf arg = 65 | match addr with 66 | | Iindexed n -> 67 | printreg ppf arg.(0); 68 | if n <> 0 then fprintf ppf " + %i" n 69 | 70 | let print_specific_operation printreg op ppf arg = 71 | match op with 72 | | Ishiftarith(op, shift) -> 73 | let op_name = function 74 | | Ishiftadd -> "+" 75 | | Ishiftsub -> "-" 76 | | Ishiftsubrev -> "-rev" in 77 | let shift_mark = 78 | if shift >= 0 79 | then sprintf "<< %i" shift 80 | else sprintf ">> %i" (-shift) in 81 | fprintf ppf "%a %s %a %s" 82 | printreg arg.(0) (op_name op) printreg arg.(1) shift_mark 83 | | Ishiftcheckbound n -> 84 | fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) 85 | | Irevsubimm n -> 86 | fprintf ppf "%i %s %a" n "-" printreg arg.(0) 87 | -------------------------------------------------------------------------------- /src/typing/primitive.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* $Id: primitive.ml 8930 2008-07-24 05:35:22Z frisch $ *) 14 | 15 | (* Description of primitive functions *) 16 | 17 | open Misc 18 | 19 | type description = 20 | { prim_name: string; (* Name of primitive or C function *) 21 | prim_arity: int; (* Number of arguments *) 22 | prim_alloc: bool; (* Does it allocates or raise? *) 23 | prim_native_name: string; (* Name of C function for the nat. code gen. *) 24 | prim_native_float: bool } (* Does the above operate on unboxed floats? *) 25 | 26 | let parse_declaration arity decl = 27 | match decl with 28 | | name :: "noalloc" :: name2 :: "float" :: _ -> 29 | {prim_name = name; prim_arity = arity; prim_alloc = false; 30 | prim_native_name = name2; prim_native_float = true} 31 | | name :: "noalloc" :: name2 :: _ -> 32 | {prim_name = name; prim_arity = arity; prim_alloc = false; 33 | prim_native_name = name2; prim_native_float = false} 34 | | name :: name2 :: "float" :: _ -> 35 | {prim_name = name; prim_arity = arity; prim_alloc = true; 36 | prim_native_name = name2; prim_native_float = true} 37 | | name :: "noalloc" :: _ -> 38 | {prim_name = name; prim_arity = arity; prim_alloc = false; 39 | prim_native_name = ""; prim_native_float = false} 40 | | name :: name2 :: _ -> 41 | {prim_name = name; prim_arity = arity; prim_alloc = true; 42 | prim_native_name = name2; prim_native_float = false} 43 | | name :: _ -> 44 | {prim_name = name; prim_arity = arity; prim_alloc = true; 45 | prim_native_name = ""; prim_native_float = false} 46 | | [] -> 47 | fatal_error "Primitive.parse_declaration" 48 | 49 | let description_list p = 50 | let list = [p.prim_name] in 51 | let list = if not p.prim_alloc then "noalloc" :: list else list in 52 | let list = 53 | if p.prim_native_name <> "" then p.prim_native_name :: list else list 54 | in 55 | let list = if p.prim_native_float then "float" :: list else list in 56 | List.rev list 57 | 58 | let native_name p = 59 | if p.prim_native_name <> "" 60 | then p.prim_native_name 61 | else p.prim_name 62 | 63 | let byte_name p = 64 | p.prim_name 65 | -------------------------------------------------------------------------------- /src/bytecomp/switch.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* Objective Caml *) 4 | (* *) 5 | (* Luc Maranget, projet Moscova, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2000 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* 14 | This module transforms generic switches in combinations 15 | of if tests and switches. 16 | *) 17 | 18 | (* For detecting action sharing, object style *) 19 | 20 | type 'a t_store = 21 | {act_get : unit -> 'a array ; act_store : 'a -> int} 22 | val mk_store : ('a -> 'a -> bool) -> 'a t_store 23 | 24 | (* Arguments to the Make functor *) 25 | module type S = 26 | sig 27 | (* type of basic tests *) 28 | type primitive 29 | (* basic tests themselves *) 30 | val eqint : primitive 31 | val neint : primitive 32 | val leint : primitive 33 | val ltint : primitive 34 | val geint : primitive 35 | val gtint : primitive 36 | (* type of actions *) 37 | type act 38 | 39 | (* Various constructors, for making a binder, 40 | adding one integer, etc. *) 41 | val bind : act -> (act -> act) -> act 42 | val make_offset : act -> int -> act 43 | val make_prim : primitive -> act list -> act 44 | val make_isout : act -> act -> act 45 | val make_isin : act -> act -> act 46 | val make_if : act -> act -> act -> act 47 | (* construct an actual switch : 48 | make_switch arg cases acts 49 | NB: cases is in the value form *) 50 | val make_switch : 51 | act -> int array -> act array -> act 52 | end 53 | 54 | 55 | (* 56 | Make.zyva mk_const arg low high cases actions where 57 | - mk_const takes an integer sends a constant action. 58 | - arg is the argument of the switch. 59 | - low, high are the interval limits. 60 | - cases is a list of sub-interval and action indices 61 | - actions is an array of actions. 62 | 63 | All these arguments specify a switch construct and zyva 64 | returns an action that performs the switch, 65 | *) 66 | module Make : 67 | functor (Arg : S) -> 68 | sig 69 | val zyva : 70 | (int * int) -> 71 | (int -> Arg.act) -> 72 | Arg.act -> 73 | (int * int * int) array -> 74 | Arg.act array -> 75 | Arg.act 76 | val test_sequence : 77 | (int -> Arg.act) -> 78 | Arg.act -> 79 | (int * int * int) array -> 80 | Arg.act array -> 81 | Arg.act 82 | end 83 | -------------------------------------------------------------------------------- /src/utils/clflags.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* ocamlnat *) 4 | (* *) 5 | (* Benedikt Meurer, University of Siegen *) 6 | (* *) 7 | (* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) 8 | (* Universität Siegen. All rights reserved. This file is distri- *) 9 | (* buted under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* Command-line parameters *) 14 | 15 | val objfiles : string list ref 16 | val ccobjs : string list ref 17 | val dllibs : string list ref 18 | val compile_only : bool ref 19 | val output_name : string option ref 20 | val include_dirs : string list ref 21 | val no_std_include : bool ref 22 | val print_types : bool ref 23 | val make_archive : bool ref 24 | val debug : bool ref 25 | val fast : bool ref 26 | val link_everything : bool ref 27 | val custom_runtime : bool ref 28 | val output_c_object : bool ref 29 | val ccopts : string list ref 30 | val classic : bool ref 31 | val nopervasives : bool ref 32 | val preprocessor : string option ref 33 | val annotations : bool ref 34 | val use_threads : bool ref 35 | val use_vmthreads : bool ref 36 | val noassert : bool ref 37 | val verbose : bool ref 38 | val noprompt : bool ref 39 | val init_file : string option ref 40 | val use_prims : string ref 41 | val use_runtime : string ref 42 | val principal : bool ref 43 | val recursive_types : bool ref 44 | val strict_sequence : bool ref 45 | val applicative_functors : bool ref 46 | val make_runtime : bool ref 47 | val gprofile : bool ref 48 | val c_compiler : string option ref 49 | val no_auto_link : bool ref 50 | val dllpaths : string list ref 51 | val make_package : bool ref 52 | val for_package : string option ref 53 | val dump_parsetree : bool ref 54 | val dump_rawlambda : bool ref 55 | val dump_lambda : bool ref 56 | val dump_instr : bool ref 57 | val keep_asm_file : bool ref 58 | val optimize_for_speed : bool ref 59 | val register_allocator : string ref 60 | val dump_cmm : bool ref 61 | val dump_selection : bool ref 62 | val dump_live : bool ref 63 | val dump_spill : bool ref 64 | val dump_split : bool ref 65 | val dump_interf : bool ref 66 | val dump_prefer : bool ref 67 | val dump_interval : bool ref 68 | val dump_regalloc : bool ref 69 | val dump_reload : bool ref 70 | val dump_scheduling : bool ref 71 | val dump_linear : bool ref 72 | val keep_startup_file : bool ref 73 | val dump_combine : bool ref 74 | val native_code : bool ref 75 | val inline_threshold : int ref 76 | val dont_write_files : bool ref 77 | val std_include_flag : string -> string 78 | val std_include_dir : unit -> string list 79 | val shared : bool ref 80 | val dlcode : bool ref 81 | --------------------------------------------------------------------------------