6502/llvm-6502
1
0
Fork 0
mirror of https://github.com/c64scene-ar/llvm-6502.git synced 2025-01-26 23:32:58 +00:00
Code Issues Projects Releases Wiki Activity

Adding ocaml language bindings for the vmcore and bitwriter libraries. These are

Browse Source 
built atop the C language bindings, and user programs can link with them as 
such:

  # Bytecode
  ocamlc -cc g++ llvm.cma llvmbitwriter.cma -o example example.ml
  # Native
  ocamlopt -cc g++ llvm.cmxa llvmbitwriter.cmxa -o example.opt example.ml

The vmcore.ml test exercises most/all of the APIs thus far bound. Unfortunately,
they're not yet numerous enough to write hello world. But:

  $ cat example.ml
  (* example.ml *)
  
  open Llvm
  open Llvm_bitwriter
  
  let _ =
    let filename = Sys.argv.(1) in
    let m = create_module filename in
    
    let v = make_int_constant i32_type 42 false in
    let g = define_global "hello_world" v m in
    
    if not (write_bitcode_file m filename) then exit 1;
    
    dispose_module m;

  $ ocamlc -cc g++ llvm.cma llvm_bitwriter.cma -o example example.ml
  File "example.ml", line 11, characters 6-7:
  Warning Y: unused variable g.
  $ ./example example.bc
  $ llvm-dis < example.bc
  ; ModuleID = '<stdin>'
  @hello_world = global i32 42            ; <i32*> [#uses=0]

The ocaml test cases provide effective tests for the C interfaces.


git-svn-id: https://llvm.org/svn/llvm-project/llvm/trunk@42093 91177308-0d34-0410-b5e6-96231b3b80d8
This commit is contained in:
Gordon Henriksen 2007-09-18 12:49:39 +00:00
parent 54c7e12164
commit 8ef426baa3
16 changed files with 1213 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile
View File

@ -20,7 +20,7 @@ LEVEL := .
DIRS := lib/System lib/Support utils lib/VMCore lib tools/llvm-config \
tools runtime docs
OPTIONAL_DIRS := examples projects
OPTIONAL_DIRS := examples projects bindings
EXTRA_DIST := test llvm.spec include win32 Xcode
include $(LEVEL)/Makefile.config
@ -46,7 +46,7 @@ endif
# build LLVM.
ifeq ($(MAKECMDGOALS),install)
DIRS := $(filter-out utils, $(DIRS))
OPTIONAL_DIRS :=
OPTIONAL_DIRS := $(filter bindings, $(OPTIONAL_DIRS))
endif
# Include the main makefile machinery.

18
bindings/Makefile Normal file
View File

@ -0,0 +1,18 @@
##===- bindings/Makefile -----------------------------------*- Makefile -*-===##
#
# The LLVM Compiler Infrastructure
#
# This file was developed by Gordon Henriksen and is distributed under the
# University of Illinois Open Source License. See LICENSE.TXT for details.
#
##===----------------------------------------------------------------------===##
LEVEL := ..
include $(LEVEL)/Makefile.config
ifdef OCAMLC
PARALLEL_DIRS += ocaml
endif
include $(LEVEL)/Makefile.common

3
bindings/README.txt Normal file
View File

@ -0,0 +1,3 @@
This directory contains bindings for the LLVM compiler infrastructure to allow
programs written in languages other than C or C++ to take advantage of the LLVM
infrastructure--for instance, a self-hosted compiler front-end.

13
bindings/ocaml/Makefile Normal file
View File

@ -0,0 +1,13 @@
##===- bindings/ocaml/Makefile -----------------------------*- Makefile -*-===##
#
# The LLVM Compiler Infrastructure
#
# This file was developed by Gordon Henriksen and is distributed under the
# University of Illinois Open Source License. See LICENSE.TXT for details.
#
##===----------------------------------------------------------------------===##
LEVEL := ../..
DIRS = llvm bitwriter
include $(LEVEL)/Makefile.common

23
bindings/ocaml/bitwriter/Makefile Normal file
View File

@ -0,0 +1,23 @@
##===- bindings/ocaml/llvm/Makefile ------------------------*- Makefile -*-===##
#
# The LLVM Compiler Infrastructure
#
# This file was developed by the LLVM research group and is distributed under
# the University of Illinois Open Source License. See LICENSE.TXT for details.
#
##===----------------------------------------------------------------------===##
#
# This is the makefile for the llvm-ml interface. Reference materials on
# installing ocaml libraries:
#
# https://fedoraproject.org/wiki/Packaging/OCaml
# http://pkg-ocaml-maint.alioth.debian.org/ocaml_packaging_policy.txt
#
##===----------------------------------------------------------------------===##
LEVEL := ../../..
LIBRARYNAME := llvm_bitwriter
DONT_BUILD_RELINKED := 1
UsedComponents := bitwriter
include ../Makefile.ocaml

31
bindings/ocaml/bitwriter/bitwriter_ocaml.c Normal file
View File

@ -0,0 +1,31 @@
/*===-- bitwriter_ocaml.c - LLVM Ocaml Glue ---------------------*- C++ -*-===*\
|* *|
|* The LLVM Compiler Infrastructure *|
|* *|
|* This file was developed by Gordon Henriksen and is distributed under the *|
|* University of Illinois Open Source License. See LICENSE.TXT for details. *|
|* *|
|*===----------------------------------------------------------------------===*|
|* *|
|* This file glues LLVM's ocaml interface to its C interface. These functions *|
|* are by and large transparent wrappers to the corresponding C functions. *|
|* *|
|* Note that these functions intentionally take liberties with the CAMLparamX *|
|* macros, since most of the parameters are not GC heap objects. *|
|* *|
\*===----------------------------------------------------------------------===*/
#include "llvm-c/BitWriter.h"
#include "llvm-c/Core.h"
#include "caml/alloc.h"
#include "caml/mlvalues.h"
#include "caml/memory.h"
/*===-- Modules -----------------------------------------------------------===*/
/* Llvm.llmodule -> string -> bool */
CAMLprim value llvm_write_bitcode_file(value M, value Path) {
CAMLparam1(Path);
int res = LLVMWriteBitcodeToFile((LLVMModuleRef) M, String_val(Path));
CAMLreturn(Val_bool(res == 0));
}

18
bindings/ocaml/bitwriter/llvm_bitwriter.ml Normal file
View File

@ -0,0 +1,18 @@
(*===-- llvm_bitwriter.ml - LLVM Ocaml Interface ----------------*- C++ -*-===*
*
* The LLVM Compiler Infrastructure
*
* This file was developed by Gordon Henriksen and is distributed under the
* University of Illinois Open Source License. See LICENSE.TXT for details.
*
*===----------------------------------------------------------------------===
*
* This interface provides an ocaml API for the LLVM intermediate
* representation, the classes in the VMCore library.
*
*===----------------------------------------------------------------------===*)
(* Writes the bitcode for module the given path. Returns true if successful. *)
external write_bitcode_file : Llvm.llmodule -> string -> bool
= "llvm_write_bitcode_file"

18
bindings/ocaml/bitwriter/llvm_bitwriter.mli Normal file
View File

@ -0,0 +1,18 @@
(*===-- llvm_bitwriter.mli - LLVM Ocaml Interface ---------------*- C++ -*-===*
*
* The LLVM Compiler Infrastructure
*
* This file was developed by Gordon Henriksen and is distributed under the
* University of Illinois Open Source License. See LICENSE.TXT for details.
*
*===----------------------------------------------------------------------===
*
* This interface provides an ocaml API for the LLVM bitcode writer, the
* classes in the classes in the Bitwriter library.
*
*===----------------------------------------------------------------------===*)
(* Writes the bitcode for module the given path. Returns true if successful. *)
external write_bitcode_file : Llvm.llmodule -> string -> bool
= "llvm_write_bitcode_file"

24
bindings/ocaml/llvm/Makefile Normal file
View File

@ -0,0 +1,24 @@
##===- bindings/ocaml/bitwriter/Makefile -------------------*- Makefile -*-===##
#
# The LLVM Compiler Infrastructure
#
# This file was developed by the LLVM research group and is distributed under
# the University of Illinois Open Source License. See LICENSE.TXT for details.
#
##===----------------------------------------------------------------------===##
#
# This is the makefile for the llvm-ml interface. Reference materials on
# installing ocaml libraries:
#
# https://fedoraproject.org/wiki/Packaging/OCaml
# http://pkg-ocaml-maint.alioth.debian.org/ocaml_packaging_policy.txt
#
##===----------------------------------------------------------------------===##
LEVEL := ../../..
LIBRARYNAME := llvm
DONT_BUILD_RELINKED := 1
UsedComponents := core
UsedOcamLibs := llvm
include ../Makefile.ocaml

228
bindings/ocaml/llvm/llvm.ml Normal file
View File

@ -0,0 +1,228 @@
(*===-- tools/ml/llvm.ml - LLVM Ocaml Interface ---------------------------===*
*
* The LLVM Compiler Infrastructure
*
* This file was developed by Gordon Henriksen and is distributed under the
* University of Illinois Open Source License. See LICENSE.TXT for details.
*
*===----------------------------------------------------------------------===
*
* This interface provides an ocaml API for the LLVM intermediate
* representation, the classes in the VMCore library.
*
*===----------------------------------------------------------------------===*)
(* These abstract types correlate directly to the LLVM VMCore classes. *)
type llmodule
type lltype
type llvalue
type type_kind =
Void_type
| Float_type
| Double_type
| X86fp80_type
| Fp128_type
| Ppc_fp128_type
| Label_type
| Integer_type
| Function_type
| Struct_type
| Array_type
| Pointer_type
| Opaque_type
| Vector_type
type linkage =
External_linkage
| Link_once_linkage
| Weak_linkage
| Appending_linkage
| Internal_linkage
| Dllimport_linkage
| Dllexport_linkage
| External_weak_linkage
| Ghost_linkage
type visibility =
Default_visibility
| Hidden_visibility
| Protected_visibility
(*===-- Modules -----------------------------------------------------------===*)
(* Creates a module with the supplied module ID. Modules are not garbage
collected; it is mandatory to call dispose_module to free memory. *)
external create_module : string -> llmodule = "llvm_create_module"
(* Disposes a module. All references to subordinate objects are invalidated;
referencing them will invoke undefined behavior. *)
external dispose_module : llmodule -> unit = "llvm_dispose_module"
(* Adds a named type to the module's symbol table. Returns true if successful.
If such a name already exists, then no entry is added and returns false. *)
external add_type_name : string -> lltype -> llmodule -> bool
= "llvm_add_type_name"
(*===-- Types -------------------------------------------------------------===*)
external classify_type : lltype -> type_kind = "llvm_classify_type"
external refine_abstract_type : lltype -> lltype -> unit
= "llvm_refine_abstract_type"
(*--... Operations on integer types ........................................--*)
external _i1_type : unit -> lltype = "llvm_i1_type"
external _i8_type : unit -> lltype = "llvm_i8_type"
external _i16_type : unit -> lltype = "llvm_i16_type"
external _i32_type : unit -> lltype = "llvm_i32_type"
external _i64_type : unit -> lltype = "llvm_i64_type"
let i1_type = _i1_type ()
let i8_type = _i8_type ()
let i16_type = _i16_type ()
let i32_type = _i32_type ()
let i64_type = _i64_type ()
external make_integer_type : int -> lltype = "llvm_make_integer_type"
external integer_bitwidth : lltype -> int = "llvm_integer_bitwidth"
(*--... Operations on real types ...........................................--*)
external _float_type : unit -> lltype = "llvm_float_type"
external _double_type : unit -> lltype = "llvm_double_type"
external _x86fp80_type : unit -> lltype = "llvm_x86fp80_type"
external _fp128_type : unit -> lltype = "llvm_fp128_type"
external _ppc_fp128_type : unit -> lltype = "llvm_ppc_fp128_type"
let float_type = _float_type ()
let double_type = _double_type ()
let x86fp80_type = _x86fp80_type ()
let fp128_type = _fp128_type ()
let ppc_fp128_type = _ppc_fp128_type ()
(*--... Operations on function types .......................................--*)
(* FIXME: handle parameter attributes *)
external make_function_type : lltype -> lltype array -> bool -> lltype
= "llvm_make_function_type"
external is_var_arg : lltype -> bool = "llvm_is_var_arg"
external return_type : lltype -> lltype = "llvm_return_type"
external param_types : lltype -> lltype array = "llvm_param_types"
(*--... Operations on struct types .........................................--*)
external make_struct_type : lltype array -> bool -> lltype
= "llvm_make_struct_type"
external element_types : lltype -> lltype array = "llvm_element_types"
external is_packed : lltype -> bool = "llvm_is_packed"
(*--... Operations on pointer, vector, and array types .....................--*)
external make_array_type : lltype -> int -> lltype = "llvm_make_array_type"
external make_pointer_type : lltype -> lltype = "llvm_make_pointer_type"
external make_vector_type : lltype -> int -> lltype = "llvm_make_vector_type"
external element_type : lltype -> lltype = "llvm_element_type"
external array_length : lltype -> int = "llvm_array_length"
external vector_size : lltype -> int = "llvm_vector_size"
(*--... Operations on other types ..........................................--*)
external make_opaque_type : unit -> lltype = "llvm_make_opaque_type"
external _void_type : unit -> lltype = "llvm_void_type"
external _label_type : unit -> lltype = "llvm_label_type"
let void_type = _void_type ()
let label_type = _label_type ()
(*===-- Values ------------------------------------------------------------===*)
external type_of : llvalue -> lltype = "llvm_type_of"
external value_name : llvalue -> string = "llvm_value_name"
external set_value_name : string -> llvalue -> unit = "llvm_set_value_name"
(*--... Operations on constants of (mostly) any type .......................--*)
external make_null : lltype -> llvalue = "llvm_make_null"
external make_all_ones : lltype -> llvalue = "llvm_make_all_ones"
external make_undef : lltype -> llvalue = "llvm_make_undef"
external is_null : llvalue -> bool = "llvm_is_null"
(*--... Operations on scalar constants .....................................--*)
external make_int_constant : lltype -> int -> bool -> llvalue
= "llvm_make_int_constant"
external make_real_constant : lltype -> float -> llvalue
= "llvm_make_real_constant"
(*--... Operations on composite constants ..................................--*)
external make_string_constant : string -> bool -> llvalue
= "llvm_make_string_constant"
external make_array_constant : lltype -> llvalue array -> llvalue
= "llvm_make_array_constant"
external make_struct_constant : llvalue array -> bool -> llvalue
= "llvm_make_struct_constant"
external make_vector_constant : llvalue array -> llvalue
= "llvm_make_vector_constant"
(*--... Operations on global variables, functions, and aliases (globals) ...--*)
external is_declaration : llvalue -> bool = "llvm_is_declaration"
external linkage : llvalue -> linkage = "llvm_linkage"
external set_linkage : linkage -> llvalue -> unit = "llvm_set_linkage"
external section : llvalue -> string = "llvm_section"
external set_section : string -> llvalue -> unit = "llvm_set_section"
external visibility : llvalue -> visibility = "llvm_visibility"
external set_visibility : visibility -> llvalue -> unit = "llvm_set_visibility"
external alignment : llvalue -> int = "llvm_alignment"
external set_alignment : int -> llvalue -> unit = "llvm_set_alignment"
(*--... Operations on global variables .....................................--*)
external declare_global : lltype -> string -> llmodule -> llvalue
= "llvm_declare_global"
external define_global : string -> llvalue -> llmodule -> llvalue
= "llvm_define_global"
external delete_global : llvalue -> unit = "llvm_delete_global"
external global_initializer : llvalue -> llvalue = "llvm_global_initializer"
external set_initializer : llvalue -> llvalue -> unit = "llvm_set_initializer"
external remove_initializer : llvalue -> unit = "llvm_remove_initializer"
external is_thread_local : llvalue -> bool = "llvm_is_thread_local"
external set_thread_local : bool -> llvalue -> unit = "llvm_set_thread_local"
(*===-- Non-Externs -------------------------------------------------------===*)
(* These functions are built using the externals, so must be declared late. *)
let concat2 sep arr =
let s = ref "" in
if 0 < Array.length arr then begin
s := !s ^ arr.(0);
for i = 1 to (Array.length arr) - 1 do
s := !s ^ sep ^ arr.(i)
done
end;
!s
let rec string_of_lltype ty =
match classify_type ty with
Integer_type -> "i" ^ string_of_int (integer_bitwidth ty)
| Pointer_type -> (string_of_lltype (element_type ty)) ^ "*"
| Struct_type ->
let s = "{ " ^ (concat2 ", " (
Array.map string_of_lltype (element_types ty)
)) ^ " }" in
if is_packed ty
then "<" ^ s ^ ">"
else s
| Array_type -> "[" ^ (string_of_int (array_length ty)) ^
" x " ^ (string_of_lltype (element_type ty)) ^ "]"
| Vector_type -> "<" ^ (string_of_int (vector_size ty)) ^
" x " ^ (string_of_lltype (element_type ty)) ^ ">"
| Opaque_type -> "opaque"
| Function_type -> string_of_lltype (return_type ty) ^
" (" ^ (concat2 ", " (
Array.map string_of_lltype (param_types ty)
)) ^ ")"
| Label_type -> "label"
| Ppc_fp128_type -> "ppc_fp128"
| Fp128_type -> "fp128"
| X86fp80_type -> "x86_fp80"
| Double_type -> "double"
| Float_type -> "float"
| Void_type -> "void"

170
bindings/ocaml/llvm/llvm.mli Normal file
View File

@ -0,0 +1,170 @@
(*===-- tools/ml/llvm.ml - LLVM Ocaml Interface ---------------------------===*
*
* The LLVM Compiler Infrastructure
*
* This file was developed by Gordon Henriksen and is distributed under the
* University of Illinois Open Source License. See LICENSE.TXT for details.
*
*===----------------------------------------------------------------------===
*
* This interface provides an ocaml API for the LLVM intermediate
* representation, the classes in the VMCore library.
*
*===----------------------------------------------------------------------===*)
(* These abstract types correlate directly to the LLVM VMCore classes. *)
type llmodule
type lltype
type llvalue
type type_kind =
Void_type
| Float_type
| Double_type
| X86fp80_type
| Fp128_type
| Ppc_fp128_type
| Label_type
| Integer_type
| Function_type
| Struct_type
| Array_type
| Pointer_type
| Opaque_type
| Vector_type
type linkage =
External_linkage
| Link_once_linkage
| Weak_linkage
| Appending_linkage
| Internal_linkage
| Dllimport_linkage
| Dllexport_linkage
| External_weak_linkage
| Ghost_linkage
type visibility =
Default_visibility
| Hidden_visibility
| Protected_visibility
(*===-- Modules -----------------------------------------------------------===*)
(* Creates a module with the supplied module ID. Modules are not garbage
collected; it is mandatory to call dispose_module to free memory. *)
external create_module : string -> llmodule = "llvm_create_module"
(* Disposes a module. All references to subordinate objects are invalidated;
referencing them will invoke undefined behavior. *)
external dispose_module : llmodule -> unit = "llvm_dispose_module"
(* Adds a named type to the module's symbol table. Returns true if successful.
If such a name already exists, then no entry is added and returns false. *)
external add_type_name : string -> lltype -> llmodule -> bool
= "llvm_add_type_name"
(*===-- Types -------------------------------------------------------------===*)
external classify_type : lltype -> type_kind = "llvm_classify_type"
external refine_abstract_type : lltype -> lltype -> unit
= "llvm_refine_abstract_type"
val string_of_lltype : lltype -> string
(*--... Operations on integer types ........................................--*)
val i1_type : lltype
val i8_type : lltype
val i16_type : lltype
val i32_type : lltype
val i64_type : lltype
external make_integer_type : int -> lltype = "llvm_make_integer_type"
external integer_bitwidth : lltype -> int = "llvm_integer_bitwidth"
(*--... Operations on real types ...........................................--*)
val float_type : lltype
val double_type : lltype
val x86fp80_type : lltype
val fp128_type : lltype
val ppc_fp128_type : lltype
(*--... Operations on function types .......................................--*)
(* FIXME: handle parameter attributes *)
external make_function_type : lltype -> lltype array -> bool -> lltype
= "llvm_make_function_type"
external is_var_arg : lltype -> bool = "llvm_is_var_arg"
external return_type : lltype -> lltype = "llvm_return_type"
external param_types : lltype -> lltype array = "llvm_param_types"
(*--... Operations on struct types .........................................--*)
external make_struct_type : lltype array -> bool -> lltype
= "llvm_make_struct_type"
external element_types : lltype -> lltype array = "llvm_element_types"
external is_packed : lltype -> bool = "llvm_is_packed"
(*--... Operations on pointer, vector, and array types .....................--*)
external make_array_type : lltype -> int -> lltype = "llvm_make_array_type"
external make_pointer_type : lltype -> lltype = "llvm_make_pointer_type"
external make_vector_type : lltype -> int -> lltype = "llvm_make_vector_type"
external element_type : lltype -> lltype = "llvm_element_type"
external array_length : lltype -> int = "llvm_array_length"
external vector_size : lltype -> int = "llvm_vector_size"
(*--... Operations on other types ..........................................--*)
external make_opaque_type : unit -> lltype = "llvm_make_opaque_type"
val void_type : lltype
val label_type : lltype
(*===-- Values ------------------------------------------------------------===*)
external type_of : llvalue -> lltype = "llvm_type_of"
external value_name : llvalue -> string = "llvm_value_name"
external set_value_name : string -> llvalue -> unit = "llvm_set_value_name"
(*--... Operations on constants of (mostly) any type .......................--*)
external make_null : lltype -> llvalue = "llvm_make_null"
external make_all_ones : lltype -> llvalue = "llvm_make_all_ones"
external make_undef : lltype -> llvalue = "llvm_make_undef"
external is_null : llvalue -> bool = "llvm_is_null"
(*--... Operations on scalar constants .....................................--*)
external make_int_constant : lltype -> int -> bool -> llvalue
= "llvm_make_int_constant"
external make_real_constant : lltype -> float -> llvalue
= "llvm_make_real_constant"
(*--... Operations on composite constants ..................................--*)
external make_string_constant : string -> bool -> llvalue
= "llvm_make_string_constant"
external make_array_constant : lltype -> llvalue array -> llvalue
= "llvm_make_array_constant"
external make_struct_constant : llvalue array -> bool -> llvalue
= "llvm_make_struct_constant"
external make_vector_constant : llvalue array -> llvalue
= "llvm_make_vector_constant"
(*--... Operations on global variables, functions, and aliases (globals) ...--*)
external is_declaration : llvalue -> bool = "llvm_is_declaration"
external linkage : llvalue -> linkage = "llvm_linkage"
external set_linkage : linkage -> llvalue -> unit = "llvm_set_linkage"
external section : llvalue -> string = "llvm_section"
external set_section : string -> llvalue -> unit = "llvm_set_section"
external visibility : llvalue -> visibility = "llvm_visibility"
external set_visibility : visibility -> llvalue -> unit = "llvm_set_visibility"
external alignment : llvalue -> int = "llvm_alignment"
external set_alignment : int -> llvalue -> unit = "llvm_set_alignment"
(*--... Operations on global variables .....................................--*)
external declare_global : lltype -> string -> llmodule -> llvalue
= "llvm_declare_global"
external define_global : string -> llvalue -> llmodule -> llvalue
= "llvm_define_global"
external delete_global : llvalue -> unit = "llvm_delete_global"
external global_initializer : llvalue -> llvalue = "llvm_global_initializer"
external set_initializer : llvalue -> llvalue -> unit = "llvm_set_initializer"
external remove_initializer : llvalue -> unit = "llvm_remove_initializer"
external is_thread_local : llvalue -> bool = "llvm_is_thread_local"
external set_thread_local : bool -> llvalue -> unit = "llvm_set_thread_local"

410
bindings/ocaml/llvm/llvm_ocaml.c Normal file
View File

@ -0,0 +1,410 @@
/*===-- llvm_ocaml.h - LLVM Ocaml Glue --------------------------*- C++ -*-===*\
|* *|
|* The LLVM Compiler Infrastructure *|
|* *|
|* This file was developed by Gordon Henriksen and is distributed under the *|
|* University of Illinois Open Source License. See LICENSE.TXT for details. *|
|* *|
|*===----------------------------------------------------------------------===*|
|* *|
|* This file glues LLVM's ocaml interface to its C interface. These functions *|
|* are by and large transparent wrappers to the corresponding C functions. *|
|* *|
|* Note that these functions intentionally take liberties with the CAMLparamX *|
|* macros, since most of the parameters are not GC heap objects. *|
|* *|
\*===----------------------------------------------------------------------===*/
#include "llvm-c/Core.h"
#include "caml/alloc.h"
#include "caml/mlvalues.h"
#include "caml/memory.h"
#include "stdio.h"
/*===-- Modules -----------------------------------------------------------===*/
/* string -> llmodule */
CAMLprim value llvm_create_module(value ModuleID) {
return (value) LLVMModuleCreateWithName(String_val(ModuleID));
}
/* llmodule -> unit */
CAMLprim value llvm_dispose_module(value M) {
LLVMDisposeModule((LLVMModuleRef) M);
return Val_unit;
}
/* string -> lltype -> llmodule -> bool */
CAMLprim value llvm_add_type_name(value Name, value Ty, value M) {
int res = LLVMAddTypeName((LLVMModuleRef) M,
String_val(Name), (LLVMTypeRef) Ty);
return Val_bool(res == 0);
}
/*===-- Types -------------------------------------------------------------===*/
/* lltype -> type_kind */
CAMLprim value llvm_classify_type(value Ty) {
return Val_int(LLVMGetTypeKind((LLVMTypeRef) Ty));
}
/* lltype -> lltype -> unit */
CAMLprim value llvm_refine_abstract_type(value ConcreteTy, value AbstractTy) {
LLVMRefineAbstractType((LLVMTypeRef) AbstractTy, (LLVMTypeRef) ConcreteTy);
return (value) Val_unit;
}
/*--... Operations on integer types ........................................--*/
/* unit -> lltype */
CAMLprim value llvm_i1_type (value Unit) { return (value) LLVMInt1Type(); }
CAMLprim value llvm_i8_type (value Unit) { return (value) LLVMInt8Type(); }
CAMLprim value llvm_i16_type(value Unit) { return (value) LLVMInt16Type(); }
CAMLprim value llvm_i32_type(value Unit) { return (value) LLVMInt32Type(); }
CAMLprim value llvm_i64_type(value Unit) { return (value) LLVMInt64Type(); }
/* int -> lltype */
CAMLprim value llvm_make_integer_type(value Width) {
return (value) LLVMCreateIntegerType(Int_val(Width));
}
/* lltype -> int */
CAMLprim value llvm_integer_bitwidth(value IntegerTy) {
return Val_int(LLVMGetIntegerTypeWidth((LLVMTypeRef) IntegerTy));
}
/*--... Operations on real types ...........................................--*/
/* unit -> lltype */
CAMLprim value llvm_float_type(value Unit) {
return (value) LLVMFloatType();
}
/* unit -> lltype */
CAMLprim value llvm_double_type(value Unit) {
return (value) LLVMDoubleType();
}
/* unit -> lltype */
CAMLprim value llvm_x86fp80_type(value Unit) {
return (value) LLVMX86FP80Type();
}
/* unit -> lltype */
CAMLprim value llvm_fp128_type(value Unit) {
return (value) LLVMFP128Type();
}
/* unit -> lltype */
CAMLprim value llvm_ppc_fp128_type(value Unit) {
return (value) LLVMPPCFP128Type();
}
/*--... Operations on function types .......................................--*/
/* lltype -> lltype array -> bool -> lltype */
CAMLprim value llvm_make_function_type(value RetTy, value ParamTys,
value IsVarArg) {
return (value) LLVMCreateFunctionType((LLVMTypeRef) RetTy,
(LLVMTypeRef *) ParamTys,
Wosize_val(ParamTys),
Bool_val(IsVarArg));
}
/* lltype -> bool */
CAMLprim value llvm_is_var_arg(value FunTy) {
return Val_bool(LLVMIsFunctionVarArg((LLVMTypeRef) FunTy));
}
/* lltype -> lltype */
CAMLprim value llvm_return_type(value FunTy) {
return (value) LLVMGetFunctionReturnType((LLVMTypeRef) FunTy);
}
/* lltype -> lltype array */
CAMLprim value llvm_param_types(value FunTy) {
unsigned Count = LLVMGetFunctionParamCount((LLVMTypeRef) FunTy);
LLVMTypeRef *FunTys = alloca(Count * sizeof(LLVMTypeRef));
/* copy into an ocaml array */
unsigned i;
value ParamTys = caml_alloc(Count, 0);
LLVMGetFunctionParamTypes((LLVMTypeRef) FunTy, FunTys);
for (i = 0; i != Count; ++i)
Store_field(ParamTys, i, (value) FunTys[i]);
return ParamTys;
}
/*--... Operations on struct types .........................................--*/
/* lltype array -> bool -> lltype */
CAMLprim value llvm_make_struct_type(value ElementTypes, value Packed) {
return (value) LLVMCreateStructType((LLVMTypeRef *) ElementTypes,
Wosize_val(ElementTypes),
Bool_val(Packed));
}
/* lltype -> lltype array */
CAMLprim value llvm_element_types(value StructTy) {
unsigned Count = LLVMGetStructElementCount((LLVMTypeRef) StructTy);
LLVMTypeRef *Tys = alloca(Count * sizeof(LLVMTypeRef));
/* copy into an ocaml array */
unsigned i;
value ElementTys = caml_alloc(Count, 0);
LLVMGetStructElementTypes((LLVMTypeRef) StructTy, Tys);
for (i = 0; i != Count; ++i)
Store_field(ElementTys, i, (value) Tys[i]);
return ElementTys;
}
CAMLprim value llvm_is_packed(value StructTy) {
return Val_bool(LLVMIsPackedStruct((LLVMTypeRef) StructTy));
}
/*--... Operations on array, pointer, and vector types .....................--*/
/* lltype -> int -> lltype */
CAMLprim value llvm_make_array_type(value ElementTy, value Count) {
return (value) LLVMCreateArrayType((LLVMTypeRef) ElementTy, Int_val(Count));
}
/* lltype -> lltype */
CAMLprim value llvm_make_pointer_type(value ElementTy) {
return (value) LLVMCreatePointerType((LLVMTypeRef) ElementTy);
}
/* lltype -> int -> lltype */
CAMLprim value llvm_make_vector_type(value ElementTy, value Count) {
return (value) LLVMCreateVectorType((LLVMTypeRef) ElementTy, Int_val(Count));
}
/* lltype -> lltype */
CAMLprim value llvm_element_type(value Ty) {
return (value) LLVMGetElementType((LLVMTypeRef) Ty);
}
/* lltype -> int */
CAMLprim value llvm_array_length(value ArrayTy) {
return Val_int(LLVMGetArrayLength((LLVMTypeRef) ArrayTy));
}
/* lltype -> int */
CAMLprim value llvm_vector_size(value VectorTy) {
return Val_int(LLVMGetVectorSize((LLVMTypeRef) VectorTy));
}
/*--... Operations on other types ..........................................--*/
/* unit -> lltype */
CAMLprim value llvm_void_type (value Unit) { return (value) LLVMVoidType(); }
CAMLprim value llvm_label_type(value Unit) { return (value) LLVMLabelType(); }
/* unit -> lltype */
CAMLprim value llvm_make_opaque_type(value Unit) {
return (value) LLVMCreateOpaqueType();
}
/*===-- VALUES ------------------------------------------------------------===*/
/* llvalue -> lltype */
CAMLprim value llvm_type_of(value Val) {
return (value) LLVMGetTypeOfValue((LLVMValueRef) Val);
}
/* llvalue -> string */
CAMLprim value llvm_value_name(value Val) {
return caml_copy_string(LLVMGetValueName((LLVMValueRef) Val));
}
/* string -> llvalue -> unit */
CAMLprim value llvm_set_value_name(value Name, value Val) {
LLVMSetValueName((LLVMValueRef) Val, String_val(Name));
return Val_unit;
}
/*--... Operations on constants of (mostly) any type .......................--*/
/* lltype -> llvalue */
CAMLprim value llvm_make_null(value Ty) {
return (value) LLVMGetNull((LLVMTypeRef) Ty);
}
/* lltype -> llvalue */
CAMLprim value llvm_make_all_ones(value Ty) {
return (value) LLVMGetAllOnes((LLVMTypeRef) Ty);
}
/* lltype -> llvalue */
CAMLprim value llvm_make_undef(value Ty) {
return (value) LLVMGetUndef((LLVMTypeRef) Ty);
}
/* llvalue -> bool */
CAMLprim value llvm_is_null(value Val) {
return Val_bool(LLVMIsNull((LLVMValueRef) Val));
}
/*--... Operations on scalar constants .....................................--*/
/* lltype -> int -> bool -> llvalue */
CAMLprim value llvm_make_int_constant(value IntTy, value N, value SExt) {
/* GCC warns if we use the ternary operator. */
unsigned long long N2;
if (Bool_val(SExt))
N2 = (intnat) Int_val(N);
else
N2 = (uintnat) Int_val(N);
return (value) LLVMGetIntConstant((LLVMTypeRef) IntTy, N2, Bool_val(SExt));
}
/* lltype -> float -> llvalue */
CAMLprim value llvm_make_real_constant(value RealTy, value N) {
return (value) LLVMGetRealConstant((LLVMTypeRef) RealTy, Double_val(N));
}
/*--... Operations on composite constants ..................................--*/
/* string -> bool -> llvalue */
CAMLprim value llvm_make_string_constant(value Str, value NullTerminate) {
return (value) LLVMGetStringConstant(String_val(Str),
Wosize_val(Str),
Bool_val(NullTerminate) == 0);
}
/* lltype -> llvalue array -> llvalue */
CAMLprim value llvm_make_array_constant(value ElementTy, value ElementVals) {
return (value) LLVMGetArrayConstant((LLVMTypeRef) ElementTy,
(LLVMValueRef*) Op_val(ElementVals),
Wosize_val(ElementVals));
}
/* llvalue array -> bool -> llvalue */
CAMLprim value llvm_make_struct_constant(value ElementVals, value Packed) {
return (value) LLVMGetStructConstant((LLVMValueRef*) Op_val(ElementVals),
Wosize_val(ElementVals),
Bool_val(Packed));
}
/* llvalue array -> llvalue */
CAMLprim value llvm_make_vector_constant(value ElementVals) {
return (value) LLVMGetVectorConstant((LLVMValueRef*) Op_val(ElementVals),
Wosize_val(ElementVals));
}
/*--... Operations on global variables, functions, and aliases (globals) ...--*/
/* llvalue -> bool */
CAMLprim value llvm_is_declaration(value Global) {
return Val_bool(LLVMIsDeclaration((LLVMValueRef) Global));
}
/* llvalue -> linkage */
CAMLprim value llvm_linkage(value Global) {
return Val_int(LLVMGetLinkage((LLVMValueRef) Global));
}
/* linkage -> llvalue -> unit */
CAMLprim value llvm_set_linkage(value Linkage, value Global) {
LLVMSetLinkage((LLVMValueRef) Global, Int_val(Linkage));
return Val_unit;
}
/* llvalue -> string */
CAMLprim value llvm_section(value Global) {
return caml_copy_string(LLVMGetSection((LLVMValueRef) Global));
}
/* string -> llvalue -> unit */
CAMLprim value llvm_set_section(value Section, value Global) {
LLVMSetSection((LLVMValueRef) Global, String_val(Section));
return Val_unit;
}
/* llvalue -> visibility */
CAMLprim value llvm_visibility(value Global) {
return Val_int(LLVMGetVisibility((LLVMValueRef) Global));
}
/* visibility -> llvalue -> unit */
CAMLprim value llvm_set_visibility(value Viz, value Global) {
LLVMSetVisibility((LLVMValueRef) Global, Int_val(Viz));
return Val_unit;
}
/* llvalue -> int */
CAMLprim value llvm_alignment(value Global) {
return Val_int(LLVMGetAlignment((LLVMValueRef) Global));
}
/* int -> llvalue -> unit */
CAMLprim value llvm_set_alignment(value Bytes, value Global) {
LLVMSetAlignment((LLVMValueRef) Global, Int_val(Bytes));
return Val_unit;
}
/*--... Operations on global variables .....................................--*/
/* lltype -> string -> llmodule -> llvalue */
CAMLprim value llvm_add_global(value Ty, value Name, value M) {
return (value) LLVMAddGlobal((LLVMModuleRef) M,
(LLVMTypeRef) Ty, String_val(Name));
}
/* lltype -> string -> llmodule -> llvalue */
CAMLprim value llvm_declare_global(value Ty, value Name, value M) {
return (value) LLVMAddGlobal((LLVMModuleRef) M,
(LLVMTypeRef) Ty, String_val(Name));
}
/* string -> llvalue -> llmodule -> llvalue */
CAMLprim value llvm_define_global(value Name, value ConstantVal, value M) {
LLVMValueRef Initializer = (LLVMValueRef) ConstantVal;
LLVMValueRef GlobalVar = LLVMAddGlobal((LLVMModuleRef) M,
LLVMGetTypeOfValue(Initializer),
String_val(Name));
LLVMSetInitializer(GlobalVar, Initializer);
return (value) GlobalVar;
}
/* llvalue -> unit */
CAMLprim value llvm_delete_global(value GlobalVar) {
LLVMDeleteGlobal((LLVMValueRef) GlobalVar);
return Val_unit;
}
/* llvalue -> llvalue */
CAMLprim value llvm_global_initializer(value GlobalVar) {
return (value) LLVMGetInitializer((LLVMValueRef) GlobalVar);
}
/* llvalue -> llvalue -> unit */
CAMLprim value llvm_set_initializer(value ConstantVal, value GlobalVar) {
LLVMSetInitializer((LLVMValueRef) GlobalVar, (LLVMValueRef) ConstantVal);
return Val_unit;
}
/* llvalue -> unit */
CAMLprim value llvm_remove_initializer(value GlobalVar) {
LLVMSetInitializer((LLVMValueRef) GlobalVar, NULL);
return Val_unit;
}
/* llvalue -> bool */
CAMLprim value llvm_is_thread_local(value GlobalVar) {
return Val_bool(LLVMIsThreadLocal((LLVMValueRef) GlobalVar));
}
/* bool -> llvalue -> unit */
CAMLprim value llvm_set_thread_local(value IsThreadLocal, value GlobalVar) {
LLVMSetThreadLocal((LLVMValueRef) GlobalVar, Bool_val(IsThreadLocal));
return Val_unit;
}

16
test/Bindings/Ocaml/bitwriter.ml Normal file
View File

@ -0,0 +1,16 @@
(* RUN: %ocamlc llvm.cma llvm_bitwriter.cma %s -o %t
* RUN: ./%t %t.bc
* RUN: llvm-dis < %t.bc | grep caml_int_ty
*)
(* Note that this takes a moment to link, so it's best to keep the number of
individual tests low. *)
let test x = if not x then exit 1 else ()
let _ =
let m = Llvm.create_module "ocaml_test_module" in
ignore (Llvm.add_type_name "caml_int_ty" Llvm.i32_type m);
test (Llvm_bitwriter.write_bitcode_file m Sys.argv.(1))

3
test/Bindings/Ocaml/ocaml.exp Normal file
View File

@ -0,0 +1,3 @@
load_lib llvm.exp
RunLLVMTests [lsort [glob -nocomplain $srcdir/$subdir/*.{ll,llx,c,cpp,tr,ml}]]

233
test/Bindings/Ocaml/vmcore.ml Normal file
View File

@ -0,0 +1,233 @@
(* RUN: %ocamlc llvm.cma llvm_bitwriter.cma %s -o %t
* RUN: ./%t %t.bc
* RUN: llvm-dis < %t.bc > %t.ll
*)
(* Note: It takes several seconds for ocamlc to link an executable with
libLLVMCore.a, so it's better to write a big test than a bunch of
little ones. *)
open Llvm
open Llvm_bitwriter
(* Tiny unit test framework *)
let exit_status = ref 0
let case_num = ref 0
let all_done () =
prerr_endline "";
exit !exit_status
let group name =
prerr_endline "";
case_num := 0;
prerr_string (" " ^ name ^ "... ")
let insist cond =
incr case_num;
prerr_char ' ';
if not cond then begin
exit_status := 10;
prerr_char '!'
end;
prerr_int !case_num
let suite name f =
prerr_endline (name ^ ":");
f ()
(*===-- Fixture -----------------------------------------------------------===*)
let filename = Sys.argv.(1)
let m = create_module filename
(*===-- Types -------------------------------------------------------------===*)
let test_types () =
(* RUN: grep {Ty01.*void} < %t.ll
*)
group "void";
insist (add_type_name "Ty01" void_type m);
insist (Void_type == classify_type void_type);
(* RUN: grep {Ty02.*i1} < %t.ll
*)
group "i1";
insist (add_type_name "Ty02" i1_type m);
insist (Integer_type == classify_type i1_type);
(* RUN: grep {Ty03.*i32} < %t.ll
*)
group "i32";
insist (add_type_name "Ty03" i32_type m);
(* RUN: grep {Ty04.*i42} < %t.ll
*)
group "i42";
let ty = make_integer_type 42 in
insist (add_type_name "Ty04" ty m);
(* RUN: grep {Ty05.*float} < %t.ll
*)
group "float";
insist (add_type_name "Ty05" float_type m);
insist (Float_type == classify_type float_type);
(* RUN: grep {Ty06.*double} < %t.ll
*)
group "double";
insist (add_type_name "Ty06" double_type m);
insist (Double_type == classify_type double_type);
(* RUN: grep {Ty07.*i32.*i1, double} < %t.ll
*)
group "function";
let ty = make_function_type i32_type [| i1_type; double_type |] false in
insist (add_type_name "Ty07" ty m);
insist (Function_type = classify_type ty);
insist (not (is_var_arg ty));
insist (i32_type == return_type ty);
insist (double_type == (param_types ty).(1));
(* RUN: grep {Ty08.*\.\.\.} < %t.ll
*)
group "vararg";
let ty = make_function_type void_type [| i32_type |] true in
insist (add_type_name "Ty08" ty m);
insist (is_var_arg ty);
(* RUN: grep {Ty09.*\\\[7 x i8\\\]} < %t.ll
*)
group "array";
let ty = make_array_type i8_type 7 in
insist (add_type_name "Ty09" ty m);
insist (7 = array_length ty);
insist (i8_type == element_type ty);
insist (Array_type == classify_type ty);
(* RUN: grep {Ty10.*float\*} < %t.ll
*)
group "pointer";
let ty = make_pointer_type float_type in
insist (add_type_name "Ty10" ty m);
insist (float_type == element_type ty);
insist (Pointer_type == classify_type ty);
(* RUN: grep {Ty11.*\<4 x i16\>} < %t.ll
*)
group "vector";
let ty = make_vector_type i16_type 4 in
insist (add_type_name "Ty11" ty m);
insist (i16_type == element_type ty);
insist (4 = vector_size ty);
(* RUN: grep {Ty12.*opaque} < %t.ll
*)
group "opaque";
let ty = make_opaque_type () in
insist (add_type_name "Ty12" ty m);
insist (ty == ty);
insist (ty <> make_opaque_type ())
(*===-- Global Values -----------------------------------------------------===*)
let test_global_values () =
let (++) x f = f x; x in
let zero32 = make_null i32_type in
(* RUN: grep {GVal01} < %t.ll
*)
group "naming";
let g = define_global "TEMPORARY" zero32 m in
prerr_endline "";
prerr_endline (value_name g);
insist ("TEMPORARY" = value_name g);
set_value_name "GVal01" g;
insist ("GVal01" = value_name g);
(* RUN: grep {GVal02.*linkonce} < %t.ll
*)
group "linkage";
let g = define_global "GVal02" zero32 m ++
set_linkage Link_once_linkage in
insist (Link_once_linkage = linkage g);
(* RUN: grep {GVal03.*Hanalei} < %t.ll
*)
group "section";
let g = define_global "GVal03" zero32 m ++
set_section "Hanalei" in
insist ("Hanalei" = section g);
(* RUN: grep {GVal04.*hidden} < %t.ll
*)
group "visibility";
let g = define_global "GVal04" zero32 m ++
set_visibility Hidden_visibility in
insist (Hidden_visibility = visibility g);
(* RUN: grep {GVal05.*align 128} < %t.ll
*)
group "alignment";
let g = define_global "GVal05" zero32 m ++
set_alignment 128 in
insist (128 = alignment g)
(*===-- Global Variables --------------------------------------------------===*)
let test_global_variables () =
let (++) x f = f x; x in
let fourty_two32 = make_int_constant i32_type 42 false in
(* RUN: grep {GVar01.*external} < %t.ll
*)
group "declarations";
let g = declare_global i32_type "GVar01" m in
insist (is_declaration g);
(* RUN: grep {GVar02.*42} < %t.ll
* RUN: grep {GVar03.*42} < %t.ll
*)
group "definitions";
let g = define_global "GVar02" fourty_two32 m in
let g2 = declare_global i32_type "GVar03" m ++
set_initializer fourty_two32 in
insist (not (is_declaration g));
insist (not (is_declaration g2));
insist ((global_initializer g) == (global_initializer g2));
(* RUN: grep {GVar04.*thread_local} < %t.ll
*)
group "threadlocal";
let g = define_global "GVar04" fourty_two32 m ++
set_thread_local true in
insist (is_thread_local g);
(* RUN: grep -v {GVar05} < %t.ll
*)
let g = define_global "GVar05" fourty_two32 m in
delete_global g
(*===-- Writer ------------------------------------------------------------===*)
let test_writer () =
group "writer";
insist (write_bitcode_file m filename);
dispose_module m
(*===-- Driver ------------------------------------------------------------===*)
let _ =
suite "types" test_types;
suite "global values" test_global_values;
suite "global variables" test_global_variables;
suite "writer" test_writer;
all_done ()

4
test/lib/llvm.exp
View File

@ -43,7 +43,7 @@ proc execOneLine { test PRS outcome lineno line } {
# cases.
proc substitute { line test tmpFile } {
global srcroot objroot srcdir objdir subdir target_triplet prcontext
global llvmgcc llvmgxx llvmgcc_version llvmgccmajvers
global llvmgcc llvmgxx llvmgcc_version llvmgccmajvers ocamlc
global gccpath gxxpath compile_c compile_cxx link shlibext llvmlibsdir
set path [file join $srcdir $subdir]
@ -64,6 +64,8 @@ proc substitute { line test tmpFile } {
regsub -all {%link} $new_line "$link" new_line
#replace %shlibext with shared library extension
regsub -all {%shlibext} $new_line "$shlibext" new_line
#replace %ocamlc with ocaml compiler command
regsub -all {%ocamlc} $new_line "$ocamlc" new_line
#replace %llvmlibsdir with configure library directory
regsub -all {%llvmlibsdir} $new_line "$llvmlibsdir" new_line
#replace %p with path to source,