本文总结OCaml与C的交互：在C中如何分配和修改ocaml value，如何将ocaml value转换为C struct， 以及异常处理。
章节目录
OCaml中调用C函数示例
value类型
C中表示OCaml数据类型
C中操作Ocaml values
与垃圾收集器和谐相处
从C到OCaml的回调
完整示例:Win32下的kill
OCaml中调用C函数示例
先以最简单的hello world开始:
hello.ml
external print_hello: unit -> unit = "caml_print_hello" let _ = print_hello ();;
hello_stubs.c
#include <stdio.h> #include <caml/mlvalues.h> #include <caml/memory.h> CAMLprim value caml_print_hello (value unit) { CAMLparam1(unit); printf("Hello world!\n"); fflush(stdout); CAMLreturn (Val_unit); }
编译并运行:
字节码： ocamlc -custom -o hello.exe hello.ml hello_stubs.c 本地代码: ocamlopt -o hello.exe hello.ml hello_stubs.c 执行： hello.exe Hello world!
或者在toplevel中使用:
生成自定义的toplevel: ocamlmktop -o hellotop.exe -custom hello_stubs.c hello.ml 执行： hellotop.exe 输入 Hello.print_hello();; Hello world! - : unit = ()
OCaml中声明函数
在OCaml中使用 external 关键字声明C函数:
external name : type = C-function-name
C函数名不需要与OCaml的函数名相同。
外部函数在接口文件.mli中可以作为一般val声明:
val name : type
这隐藏了使用C函数进行实现的细节,当然也可以显式声明为外部函数:
external name : type = C-function-name
后面的方法更高效，因为它允许模块的使用者直接调用C函数，而不是先调 用相应的Caml函数。
C中实现函数
如果函数参数小于等于5个，则C函数接受指定个数的value类型参数，并返 回一个value类型的结果。value类型用来表示Caml values。它编码了几种 基本类型(整数，浮点数，字符串，…),还有Caml数据结构。 后面会介绍 value类型相关的转换函数和宏。
超过5个参数的函数需要实现两个C函数。第一个用于字节码编译器ocamlc, 接受2个参数:指向Caml values数组的指针和表示参数个数的整数。 另一个用于本地代码编译器ocamlopt,直接接受所有参数。例如,下面这个 接受7个参数的函数add_nat：
CAMLprim value add_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2, value carry_in) { ... } CAMLprim value add_nat_bytecode(value *argv, int argn) { return add_nat_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); }
在OCaml中必须指明这两个函数：
external name : type = bytecode-C-function-name native-code-C-function-name
例如，add_nat声明如下:
external add_nat: nat -> int -> int -> int -> nat -> int -> int -> int -> int = "add_nat_bytecode" "add_nat_native"
实现一个函数实际上有两个步骤：
1，解码指定的Caml value参数到C value, 编码返回值到一个Caml value；
2，从参数计算出结果。
除了非常简单的函数，最好采用两个分离的C函数来实现这两个步骤。 第一个函数完成实际的运算，接受C值作为参数并返回一个C值。 第二个函数，也叫做"stub code"，通过转换Caml values参数到C values, 调用第一个函数，转换返回的C value到Caml value，来对第一个函数进行简 单地包装。例如，以下的stub code:
CAMLprim value input(value channel, value buffer, value offset, value length) { return Val_long(getblock((struct channel*) channel, &Byte(buffer, Long_val(offset)), Long_val(length))); }
(这里的Val_long,Long_val是value类型的转换宏，后面将会讨论。 CAMLprim宏用来保证这个函数是导出的，并且可以被Caml访问).主要工作 都有getblock来完成。
使用C代码操作OCaml values,可以使用以下头文件：
| 头文件 | 提供功能 |
| caml/mlvalues.h | 定义value类型和转换宏 |
| caml/alloc.h | 分配函数(用于创建结构化的Caml对象) |
| caml/memory.h | 各种内存相关的函数和宏(主要是GC接口) |
| caml/fail.h | 引发异常的函数 |
| caml/callback.h | 从C到Caml的回调 |
| caml/custom.h | 自定义块的操作 |
| caml/intext.h | 对自定义块进行用户定义的序列化和反序列化操作 |
| caml/threads.h | 多线程操作 |
value类型
一个value类型的对象可以是：
- 一个整数
- 一个指向堆中内存块的指针 (比如caml_alloc_*分配的内存块)
- 一个指向堆外的对象的指针 (比如malloc分配的内存块，或者一个C变量)。
整型value
整型values使用31-bit有符号整数(64位架构上使用63-bit)。它们属于 unboxed(unallocated，不进行内存分配，也就是直接存放在cpu寄存器中)。 ocaml中char, bool, int都用整型表示。
块
堆(ocaml中存放数据的堆，除了整型value都在此堆上分配、释放)上 的块被垃圾收集器管理，因此有一些严格的限制。每个块都有一个头包含 这个块的大小(以word为单位)和这个块的tag。 tag表示块的内容如何组织。 一个小于No_scan_tag 的tag表示一个结构化的块，包含了结构良好的value， 它会被垃圾收集器循环遍历扫描每个字段。一个大于等于No_scan_tag 的tag是一个原始块，它的内容不会被垃圾收集器扫描。
| Tag | 块的内容 |
| 0 to No_scan_tag - 1 | 结构化的块(Caml对象的数组)。每个字段为一个value |
| Closure_tag | 一个函数闭包。第一个字段为指向代码的指针，后面的字段为环境中的value |
| String_tag | 一个字符串 |
| Double_tag | 一个双精度浮点数 |
| Double_array_tag | 一个双精度浮点数组 |
| Abstract_tag | 一个抽象数据类型 |
| Custom_tag | 一个抽象数据类型，包含了用户定义的析构，比较，哈希，序列化和反序列化相关函数。 |
堆外的指针
任何在堆外以字对齐的指针都可以安全地和value类型相互转换。这包括 malloc返回的指针，使用&操作符获得的C变量指针(最小为一个字)。
注意：如果malloc返回的指针转换为value类型并返回到Caml，使用free进 行显式内存回收是很危险的，因为这个指针在Caml中可能仍然有效。更糟 的是，使用free回收内存可以比Caml堆重分配晚，原先指向Caml堆外面的指针 现在指向了Caml堆内部，造成垃圾收集器混乱。为了避免这些问题，推荐把 指针封装为一个Caml块，可以用Abstract_tag或Custom_tag。
示例:inspector
知道了OCaml value在C中的表示方式,就可以在C中编写函数查看这些底层 表示. 此示例实现读取value并输出value的类型.
inspect_stubs.c
#include <stdio.h> #include <caml/mlvalues.h> #include <caml/memory.h> /* 缩进显示 */ void margin(int n) { while (n-- > 0) printf("."); return; } /* * 输出OCaml value的类型 * v, OCaml value * m, 缩进宽度 */ void print_block(value v, int m) { int size, i; margin(m); if (Is_long(v)) { printf("直接量 (%d)\n", Long_val(v)); return; } printf ("内存块: 大小=%d - ", size = Wosize_val(v)); switch (Tag_val(v)) { case Closure_tag: printf ("闭包:包含 %d 个自由变量\n", size - 1); margin(m+4); printf("代码指针: %p\n", Code_val(v)); for (i = 1; i < size; i++) print_block(Field(v,i), m+4); break; case String_tag: printf ("字符串: %s (%s)\n", String_val(v), (char *) v); break; case Double_tag: printf ("浮点数: %g\n", Double_val(v)); break; case Double_array_tag: printf ("浮点数组: "); for (i = 0; i < size / Double_wosize; i ++ ) printf(" %g", Double_field(v, i)); printf("\n"); break; case Abstract_tag: printf ("抽象类型\n"); break; case Custom_tag: printf ("抽象类型,包含用户自定义的析构函数...\n"); break; default: if (Tag_val(v) >= No_scan_tag) { printf ("未知tag"); break; } printf ("structured block (tag = %d):\n", Tag_val(v)); for (i = 0; i < size; i++) print_block(Field(v, i), m+4); } return; } /* 包装函数 */ CAMLprim value inspect_block (value v) { CAMLparam1(v); print_block (v, 4); fflush(stdout); CAMLreturn (v); }
inspector.ml
external inspect : 'a -> 'a = "inspect_block";; print_endline "使用Inspector.inspect查看OCaml value\n"
注意这两个文件都用cp936编码保存(虽然ocaml要求源文件都用utf-8编码),否 则cmd会显示乱码.编译并执行:
ocamlmktop -custom -o inspector.exe inspector.ml inspect_stubs.c inspector.exe
进行测试:
# Inspector.inspect 5;; (* 测试整数 *) ....直接量 (5) - : int = 5 # Inspector.inspect "string";; (* 字符串 *) ....内存块: 大小=2 - 字符串: string (string) - : string = "string" # Inspector.inspect false;; ....直接量 (0) - : bool = false # Inspector.inspect [1; 2; 3];; (* 列表 *) ....内存块: 大小=2 - structured block (tag = 0): ........直接量 (1) ........内存块: 大小=2 - structured block (tag = 0): ............直接量 (2) ............内存块: 大小=2 - structured block (tag = 0): ................直接量 (3) ................直接量 (0) - : int list = [1; 2; 3] # Inspector.inspect [|1; 2; 3|];; (* 数组 *) ....内存块: 大小=3 - structured block (tag = 0): ........直接量 (1) ........直接量 (2) ........直接量 (3) - : int array = [|1; 2; 3|] # Inspector.inspect 3.14;; (* 浮点数 *) ....内存块: 大小=2 - 浮点数: 3.14 - : float = 3.14 # Inspector.inspect [| 1.11; 2.22; 3.33 |];; (* 浮点数组 *) ....内存块: 大小=6 - 浮点数组: 1.11 2.22 3.33 - : float array = [|1.11; 2.22; 3.33|] # let add x y = x + y;; val add : int -> int -> int = <fun> # Inspector.inspect add;; (* 函数 *) ....内存块: 大小=1 - 闭包:包含 0 个自由变量 ........代码指针: 002EC9A8 - : int -> int -> int = <fun> # let add1 = add 5;; val add1 : int -> int = <fun> # Inspector.inspect add1;; (* 柯里化函数 *) ....内存块: 大小=3 - 闭包:包含 2 个自由变量 ........代码指针: 002EC9A4 ........内存块: 大小=1 - 闭包:包含 0 个自由变量 ............代码指针: 002EC9A8 ........直接量 (5) - : int -> int = <fun> # type point = { x : int; y : int};; type point = { x : int; y : int; } # Inspector.inspect { x = 600; y = 480 } ;; (* 测试record *) ....内存块: 大小=2 - structured block (tag = 0): ........直接量 (600) ........直接量 (480) - : point = {x = 600; y = 480}
这就是所有的OCaml数据类型了,与C做一下比较: char, bool, int都作为int直接量,与C的char, bool, int相似;Tag为0的 块与C的数组相似; OCaml中的浮点数使用块来实现,不过专门提供了Double_tag作 优化.string也有一个专门的Tag表示,函数也是数据类型的一种, OCaml中的用户自定义类型(record)是使用array实现的. Abstract类型用 来表示只知道这个类型,但不知道其具体实现,用于在接口中隐藏类型的实现.
C中表示OCaml数据类型
下面讲解OCaml数据类型如何编码为value类型.
原子(Atomic)类型
| Caml类型 | 编码方式 |
| int | Unboxed整数 |
| char | Unboxed整数(ASCII码) |
| float | tag为Double_tag的块 |
| string | tag为String_tag的块 |
| int32 | tag为Custom_tag的块 |
| int64 | tag为Custom_tag的块 |
| nativeint | tag为Custom_tag的块 |
Tuples和records
tuples为指向块的指针,使用tag 0. records也是tag为0的块.record类型中字段的顺序决定了record的布局:第 一个声明的字段存储在块中的字段0处,与字段关联的值存放在字段1中.
为了优化,所有字段都为float类型的record作为一个浮点数数组表示,使用 Double_array_tag.
数组(arrays)
整数或指针数组表示为tuples,一个指向tag为0的块的指针. 它们使用 Field宏进行访问,caml_modify函数修改.
浮点数数组(float array 类型)有一个特殊的,未封装的,更有效率的表 示.这些数组表示为指向tag为 Double_array_tag 的块的指针.通过 Double_field 和 Store_double_field 进行访问和修改.
具体(Concrete)数据类型
| 具体项 | 表示 |
| () | Val_int(0) |
| false | Val_int(0) |
| true | Val_int(1) |
| [] | Val_int(0) |
| h::t | tag=0,size=2的块;第一个字段包含h,第二个字段为t |
可以使用inspector查看这些值:
# Inspector.inspect ();; ....直接量 (0) - : unit = () # Inspector.inspect false;; ....直接量 (0) - : bool = false # Inspector.inspect true;; ....直接量 (1) - : bool = true # Inspector.inspect [];; ....直接量 (0) - : 'a list = [] # Inspector.inspect (1::[]);; ....内存块: 大小=2 - structured block (tag = 0): ........直接量 (1) ........直接量 (0) - : int list = [1]
C中操作Ocaml values
类型测试
- Is_long(v) 如果v是整数直接量返回true,否则为false
- Is_block(v) 如果v指向一个块则返回true,否则返回false
操作整数
- Val_long(l) 转换C long int l到OCaml value
- Val_int(i) 转换 C int i到OCaml value
- Val_bool(x) 转换C整数x到OCaml bool value
- Long_val(v) 转换OCaml v到C long int
- Int_Val(v) 转换OCaml v到C int
- Bool_Val(v) 如果OCaml bool v的值为false返回0, true返回1
- Value_true, Value_false表示OCaml bool true和false
访问块
- Wosize_val(v) 返回块v的size(以word为单位),不包含header.
- Tag_val(v) 返回块v的tag
- Field(v, n) 返回结构化块v第n个字段的value.字段的序号从0到 Wosize_val(v)-1
- Store_field(b, n, v) 存储value v到value b的第n个字段中,b必须为 结构化块.
- Code_val(v) 返回闭包v的代码部分
- caml_string_length(v) 返回string v的长度
- Byte(v, n) 返回string v的第n个字符,类型为 char.
- Byte_u(v, n) 返回string v的第n个字符,类型为 unsigend char.
- String_val(v) 返回指向string v的第一个字符的指针,类型为 char*. 这个指针是一个有效的C字符串:字符串的最后一个字符为空字 符null.但是OCaml字符串中可以包含空字符,这会让大多数操作字符串的 C函数失败.
- Double_val(v) 返回一个浮点数,类型为 double
- Double_field(v, n) 返回浮点数组v(tag为Double_array_tag的块)的第 n个元素.
- Store_double_field(v, n, d) 存储双精度浮点数d到浮点数组v的第n个 元素中.
- Data_custom_val(v) 返回一个指向自定义块v的数据部分的指针.指针的 类型为 void *,需要转换为自定义块包含的类型.
- Int32_val(v) 返回 int32 v 包含的32位整数
- Int64_val(v) 返回 int64 v 包含的64位整数
- Nativeint_val(v) 返回 nativeint v 包含的长整型
表达式Field(v, n), Byte(v, n)和Byte_u(v, n)是一个有效的左值.因此 它们可以通过赋值修改value v中的值. 赋值给Field(v, n)时要注意避免垃圾 收集器产生问题.
分配OCaml块
以下函数在OCaml堆上分配内存.
简单接口
- Atom(t) 返回一个tag为t的"atom"(大小为0的块).
- caml_alloc(n, t) 返回一个tag为t,大小为n的块.如果t小于 No_scan_tag,为了满足GC的约束,块中的字段被初始化为有效的value.
- caml_alloc_tuple(n) 返回一个n个字的块,tag为0
- caml_alloc_string(n) 返回一个长度为n的字符串value.字符串初始化 为垃圾数据.
- caml_copy_string(s) 返回一个null结束的C字符串(char *)的拷贝
- caml_copy_double(d) 返回一个值为 double d的浮点value
- caml_copy_int32(i), copy_int64(i)和caml_copy_nativeint(i)返回一 个OCaml类型为 int32, int64 和 nativeint 的value,分别使用 整数i初始化.
- caml_alloc_array(f, a) 分配一个value数组,在输入数组a的每个元素 上调用函数f生成的value(类似OCaml中的map). 数组a是一个以空指针 结尾的指针数组. (不要使用这个函数构造浮点数组)
- caml_copy_string_array(p) 分配一个字符串数组,从字符串数组指针 p(char **)复制.p必须以NULL结尾.
底层接口
以下函数比caml_alloc更有效率,但更难使用.
从分配函数的观点来看,块可以按照大小分为:大小为0的块,小块(size小于等于 Max_young_wosize),大块(size大于Max_young_wosize).
- caml_alloc_small(n, t) 返回一个大小为n(单位为word,n <= Max_young_wosize),tag为t的小块.如果这个块是一个结构化块 (t <No_scan_tag),那么这个块的字段(分配后包含的是垃圾) 必须在下次分配前初始化(在块的字段上直接赋值)为合法的value.
- caml_alloc_shr(n, t) 返回一个大小为n, tag为t的块.大小可以大于 Max_young_wosize.(也可以小于它,但是它没有caml_alloc_small有效 率.) 如果是一个结构化块,必须在下次分配前使用合法的value进行初始化 (使用caml_initialize函数).
为什么结构化的块需要在下次分配前初始化呢?前面已经讲过,结构化的块会被 垃圾收集器遍历每个字段.当进行分配内存的时候,有可能触发GC,如果没有 初始化,GC就会访问垃圾数据,造成错误.
引发异常
两个引发标准异常的函数:
- caml_failwith(s) 参数s是一个空字符结尾的C字符串(类型为char*), 引发 Failure s异常.
- caml_invalid_argument(s) 引发 Invalid_argument s异常
在C中引发任意异常要复杂一点:异常标识符在OCaml中动态分配,然后注册 给C进行通信,C中获得此异常标识符后,就可以使用下面的函数引发异常:
- caml_raise_constant(id) 引发没有参数的异常id
- caml_raise_with_arg(id, v) 引发带有参数value v的异常id
- caml_raise_with_args(id, n, v) 引发带有参数value v[ 0 ],…,v[n-1]的异常id
- caml_raise_with_string(id, s) s是一个空字符结尾的C字符串,引发带有参数s的拷贝的异常id.
与垃圾收集器和谐相处
关于OCaml GC的详细信息,参考ocaml-ora ch.9 Garbage Collection。
堆中不使用的块被垃圾收集器自动清理.这就需要C代码在操作堆上分配的块时, 进行一些合作.
简单接口
本节描述的所有宏都在 memory.h 中声明.
规则1 一个参数类型或本地变量类型为value的函数必须调用CAMLparam 宏并使用CAMLreturn, CAMLreturn0 或 CAMLreturnT.
有6个 CAMLparam 宏: CAMLparam0 至 CAMLparam5, 分别接受0-5个参数.如果value 类型的函数参数小于等于5个, 直接在这些参数上使用相应的宏.如果超过5个,在前5个参数上使用CAMLparam5,在剩下的参数上使用CAMLxparam 宏.
CAMLreturn 宏用来代替C关键字return.所有x类型为 value 的 return x 必须使用 CAMLreturn (x) 代替, 或者用 CAMLreturnT (t, x) (t是x的类型);所有不带参数的return 使用CAMLreturn0 代替. 如果你的C函数返回void,必须使用 CAMLreturn0 . 示例:
void foo (value v1, value v2, value v3) { CAMLparam3 (v1, v2, v3); ... CAMLreturn0; }
规则2 类型为value的局部变量必须使用CAMLlocal宏声明.values数组 使用CAMLlocalN声明.这些宏必须在函数开头使用,不能在嵌套块中.
CAMLlocal1 至 CAMLlocal5 声明和初始化1-5个类型为 value 的局部变量. CAMLlocalN(x, n) 声明和初始化一个类型为 value [n]的局部变量. 如果需要超过5个局部变量,可以多次调用这些宏. 示 例:
value bar (value v1, value v2, value v3) { CAMLparam3 (v1, v2, v3); CAMLlocal1(result); result = caml_alloc (3, 0); ... CAMLreturn(result); }
规则3 给结构化块的字段赋值必须使用Store_field宏(一般块)或Store_double_field宏(包含浮点数的数组或records).其它类型的赋值不要使用Store_field和Store_double_field.
Store_field (b, n, v) 存储value v到value b的第n个字段,b 必须为块(Is_block (b)必须为true).
示例:
value bar (value v1, value v2, value v3) { CAMLparam3 (v1, v2, v3); CAMLlocal1 (result); result = caml_alloc (3, 0); Store_field (result, 0, v1); Store_field (result, 1, v2); Store_field (result, 2, v3); CAMLreturn (result); }
规则4 包含values的全局变量必须使用函数 caml_register_global_root注册到垃圾收集器
使用 caml_register_global_root(&v) 注册全局变量v时,要在一个 有效值第一次存储到v之前或之后调用. 在注册和存储value之间不要 调用任何OCaml runtime函数或宏.
一个注册过的全局变量v可以调用 caml_remove_global_root(&v) 反注 册.
如果全局变量v的内容注册之后不会修改,可以使用性能更好的 caml_register_generational_global_root(&v) 和caml_remove_generational_global_root(&v) 进行注册和反注册. 如果需要这册许多全局变量,这能改善性能.
底层接口
现在讲解底层分配函数caml_alloc_small和caml_alloc_shr的相关规则.如 果你只使用caml_alloc则可以忽略这部分.
规则5 在使用底层函数分配一个结构化块(块的tag小于No_scan_tag)之后,这个块的所有字段在下次分配操作之前必须包含有效值.如果这个块使 用caml_alloc_small分配,可以对块的字段进行直接赋值:
Field(v, n) = vn;
如果使用caml_alloc_shr分配块,使用caml_initialize函数填充:
caml_initialize(&Field(v, n), vn);
下一次分配可能会触发垃圾收集器.垃圾收集器假定所有的结构化块包含 有效的value.新创建的块包含随机数据,一般不能表示为有效value.
如果你需要在字段获得它们的值之前进行分配操作,首先使用一个常量 value进行初始化(如 Val_unit),然后分配,然后修改字段为正确的 value.
规则6 对块的字段进行赋值,例如
Field(v, n) = w;
只有在块v是最后一个使用 caml_alloc_small 分配的时候才安全;也就是说在分配v和对v的字段进行赋值之间没有其它的分配操作.其它情况下,不要直接赋值.如果一个块使用caml_alloc_shr分配,用caml_initialize进行第一次赋值.
其它情况下,你是更新一个已经包含有效值的字段;这时,使用 caml_modify 函数:
caml_modify(&Field(v, n), w);
为了展示以上规则,这个C函数构造并返回一个列表,包含参数指定的两个 整数.首先,我们使用简单分配函数:
//注意OCaml中列表的内存表示,可以使用前面的inspector程序查看 value alloc_list_int (int i1, int i2) { CAMLparam0 (); CAMLlocal2 (result, r); r = caml_alloc(2, 0); Store_field(r, 0, Val_int(i2)); Store_field(r, 1, Val_int(0)); result = caml_alloc(2, 0); Store_field(result, 0, Val_int(i1)); Store_field(result, 1, r); CAMLreturn (result); }
下面使用底层分配函数 caml_alloc_small :
value alloc_list_int (int i1, int i2) { CAMLparam0 (); CAMLlocal2 (result, r); r = caml_alloc_small(2, 0); Field(r, 0) = Val_int(i2); Field(r, 1) = Val_int(0); result = caml_alloc_small(2, 0); Field(result, 0) = Val_int(i1); Field(result, 1) = r CAMLreturn (result); }
前两个例子中,列表自底向上构造.这里使用另一种方法,自顶向下. 它的效率比较低,但是展示了 caml_modify 的用法.
value alloc_list_int (int i1, int i2) { CAMLparam0 (); CAMLlocal2 (tail, r); r = caml_alloc_small(2, 0); Field(r, 0) = Val_int(i1); Field(r, 1) = Val_int(0); tail = caml_alloc_small(2, 0);
Field(tail, 0) = Val_int(i2); Field(tail, 1) = Val_int(0); caml_modify(&Field(r, 1), tail); CAMLreturn (result); }
从C到OCaml的回调
至此,我们讲解了如何从OCaml中调用C函数.这一节,我们展示C函数如何调用 OCaml函数,包括回调(OCaml调用C,C又调用OCaml)和C作为主程序.
从C中调用OCaml闭包
OCaml中调用函数称为应用,因为函数就是表达式,调用函数,就是把表达式 应用到参数上. 比如计算一个数的平方用数学方式来描述:一个数字 x的平方就是x * x,提供x的值,套用这个公式就能计算出结果. 用 OCaml描述:let square x = x * x ,这个表达式叫做let binding. square只是x * x的别名(调用square 2也可以用(fun x -> x * x) 2), square 2就是把x * x应用到2上.
C函数可以应用OCaml函数式value(闭包)到OCaml values.以下函数提供 调用方法:
- caml_callback(f, a) 应用函数式value f到value a, 返回f返回的value.
- caml_callback2(f, a, b) 应用函数式value f到a和b
- caml_callback3(f, a, b, c) 应用函数式value f到a, b, c
- caml_callbackN(f, n, args) 应用函数式value f到包含n个参数的 value数组args
如果函数f没有返回,而引发了一个异常,这个异常会传播到下个OCaml代码, 跳过C代码.也就是说,如果一个OCaml函数f调用C函数g,回调一个OCaml函数 h,h引发一个异常,这时g的执行中断,异常被传递回f.
如果C代码希望捕获异常,它可以调用caml_callback_exn, caml_callback2_exn,caml_callback3_exn,caml_callbackN_exn. 这些函数接受的参数与不带_exn的函数相同,但会捕获异常并返回到C代 码.caml_callback*_exn函数返回的value v必须使用Is_exception_result(v) 测试.返回"false"则没有异常,value v 是OCaml函数返回的结果.如果返回"true",则有异常,它(异常描述符)的value可以使用Extract_exception(v) 获得.
注册OCaml闭包给C函数
callback 函数的主要问题在于获得一个要调用的OCaml函数的闭包. 为此,OCaml提供了一个简单的注册机制,OCaml代码可以注册OCaml函数到一 个全局名字,然后C代码可以通过这个全局名字获得相应的闭包.
在OCaml中,通过使用 Callback.register n v注册.n是一个全局名字(任 意字符串),v是一个OCaml value.例如:
let f x = print_string " f is applied to "; print_int x; print_newline() let _ = Callback.register "test function" f
在C中,使用 caml_named_value (n)获得对应value的指针. 如果名字n 没有对应的value,返回一个空指针. 例如:下面的C包装器调用了上面的 OCaml函数f:
void call_caml_f(int arg) { caml_callback(*caml_named_value("test function"), Val_int(arg)); }
caml_named_value 返回的指针是固定的,因此可以安全地使用C变量进行 缓存,避免重复的名字查找.另一方面,指针指向的value可以在垃圾收集时 修改,因此在使用指针时必须重新计算. 下面是一个更有效率的包装方式:
void call_caml_f(int arg) { static value *closure_f = NULL; if (closure_f == NULL) { closure_f = caml_named_value("test function"); } caml_callback(*closure_f, Value_int(arg)); }
注册OCaml异常给C函数
上面的注册机制也可以用来实现从OCaml到C中的异常标识符通信. OCaml代码使用 Callback.register_exception n exn,注册异常. 例如:
exception Error of string let _ = Callback.register_exception "test exception" (Error "any string")
C代码使用 caml_named_value 获得异常标识符, 然后将它作为 raise_constant,raise_with_arg, 和raise_with_string 的参数引发异常. 例如,下面的C函数使用给定的参数引发Error 异常:
void raise_error(char *msg) { caml_raise_with_string(*caml_named_value("test exception", msg); }
C作为主程序
一般情况下,混合OCaml和C的程序依靠执行OCaml的初始化代码启动.然后可 能会调用C代码.我们说主程序为OCaml代码.在一些程序中,需要使用C代码 来完成主程序的角色,当需要时调用OCaml函数. 这可以通过以下步骤完 成:
- 程序的C部分必须提供一个 main 函数,它将覆盖OCaml运行时提供的 main 函数.将和一般的C程序一样从用户定义的main 函数执行.
- 在某个地方,C代码必须调用 caml_main(argv) 来初始化OCaml代码. argv 参数是一个以NULL结尾的C字符串数组(类型char **),它表示 命令行参数,和传递给main 的第二个参数一样.OCaml数组 Sys.argv 将从这个参数初始化. 在字节码编译器中,argv[ 0] 和 argv[ 1] 也用来查找包含字节码的文件.
- 调用 caml_main 初始化OCaml运行时系统,加载字节码(在字节码编 译的情况下),并执行OCaml程序的初始化代码.一般来说,这些初始化代 码使用Camlback.register 注册回调函数.一旦OCaml初始化代码完 成,将返回到调用caml_main 的C代码中继续执行.
- 这时C代码可以通过回调机制调用OCaml函数.
嵌入OCaml代码到C代码中
字节码编译器在自定义运行时(custom runtime)模式中(ocamlc -custom)只是添加字节码到 包含自定义运行时的可执行文件中. 这有两个步骤.首先,最终链接必须通 过ocamlc 完成. 第二,OCaml运行时必须能通过命令行参数找到可执行 文件的名字.当使用caml_main(argv) 时,argv[ 0] 和 argv[ 1] 必须包含可执行文件的名字.
另一个嵌入字节码到C代码的方法是使用 ocamlc 的 -output-obj 选 项.它告诉ocamlc 编译器输出一个包含OCaml字节码的C对象文件 (.o 文件, windows下为.obj), 和caml_startup 函数. 这个C对象文件可 以使用标准C编译器链接,或存储进一个C library中.
caml_startup 函数必须从主C程序中调用,为了初始化OCaml运行时和执 行OCaml初始化代码. 和 caml_main 一样,它接受一个包含命令行参数 的 argv 参数.与 caml_main 不同的是, 这个argv参数只是用来 初始化Sys.argv,不会用来查找可执行文件的名字.
-output-obj 选项也可以用来获得C源代码文件. 另外,它还能直接产生 一个包含OCaml代码、OCaml运行时系统和其它传递给ocamlc 的静态C 代码(.o, .a,或者 .obj, .lib) 的共享库(.so文件, Windows下为.dll)。 这种方式和一个普通的链接步骤很类似，只不过它产生一个共享库，可 以在需要的时候运行OCaml代码。-output-obj 这三种行为通过 输出文件的扩展名来选择(使用-o)。
本地编译器 ocamlopt 也支持 -output-obj 选项， 可以输出一个C 对象文件或一个包含命令行上指定的所有OCaml模块的本地代码的共享库 和OCaml起始代码。和字节码编译器一样调用caml_startup 进行初始化。
在最终的链接阶段，除了所有 -output-obj 产生的文件外，你还需要 提供OCaml的运行时库(字节码用 libcamlrun.a, 本地代码用 libasmrun.a, vc编译器为.lib)，和所有依赖的OCaml库所对应的的C库。例如， 假设你的程序的OCaml部分使用了Unix库，使用ocamlc, 你需要：
ocamlc -output-obj -o camlcode.o unix.cma (其它 .cmo 和 .cma 文件) cc -o myproj (C对象文件或库) camlcode.o -L/usr/local/lib/ocaml -lunix -lcamlrun
使用 ocamlopt ,你需要:
ocamlopt -output-obj -o camlcode.o unix.cmxa (其它 .cmx 和 .cmxa 文件) cc -o myprog (C对象文件或库) camlcode.o -L/usr/local/lib/ocaml -lunix -lasmrun
注意: 在Windows NT下,OCaml产生的对象文件使用/MD选项编译,因此所有 其它需要链接的对象文件都要使用/MD选项编译. (参见 config/Makefile.vc中的BYTECCCOMPOPTS 和NATIVECCCOMPOPTS )
完整示例:Win32下的kill
本示例通过包装win32的API来实现Windows中结束进程的功能. 通过 kill <pid> 或 kill -n <process name> 来调用.
在Windows下,结束进程要用的函数有 OpenProcess 和 TerminateProcess,我们把这两个函数包装给OCaml.
win32_process_stubs.c,包装Win32 API给OCaml:
#include <Windows.h> #include <stdio.h> #include <tchar.h> #include <psapi.h> #include <caml/mlvalues.h> #include <caml/memory.h> #include <caml/callback.h> #include <caml/fail.h> static const desired_access_table[] = { DELETE, READ_CONTROL, SYNCHRONIZE, WRITE_DAC, WRITE_OWNER, PROCESS_ALL_ACCESS, PROCESS_CREATE_PROCESS, PROCESS_CREATE_THREAD, PROCESS_DUP_HANDLE, PROCESS_QUERY_INFORMATION, PROCESS_QUERY_LIMITED_INFORMATION, PROCESS_SET_INFORMATION, PROCESS_SET_QUOTA, PROCESS_SUSPEND_RESUME, PROCESS_TERMINATE, PROCESS_VM_OPERATION, PROCESS_VM_READ, PROCESS_VM_WRITE, }; DWORD get_desired_access(value da_list) { DWORD desired_access = 0; value v; while (da_list != Val_emptylist){ v = Field(da_list, 0); desired_access |= desired_access_table[Long_val(v)]; da_list = Field(da_list, 1); } return desired_access; } /* Handle 类型 */ #define Handle_val(v) (*((HANDLE*)(v))) value alloc_handle (HANDLE h) { value val; val = alloc_small(sizeof(HANDLE)/sizeof(value), Abstract_tag); Handle_val(val) = h; return val; } CAMLprim value is_null_handle(value handle) { return Val_bool(Handle_val(handle) == NULL); } /* 抛出OCaml Win32Error异常 */ void raise_win32_error(int id) { int systemLocal = MAKELANGID(LANG_NEUTRAL, SUBLANG_NEUTRAL); LPVOID lpMsgBuf = NULL; value error_result[2]; int ret = FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL,id,systemLocal, (LPTSTR)&lpMsgBuf, 0, NULL); if(!ret) { //Is it a network-related error? HMODULE hDll=LoadLibraryEx(TEXT("newmsg.dll"),NULL, DONT_RESOLVE_DLL_REFERENCES); if(hDll!=NULL) { ret=FormatMessage( FORMAT_MESSAGE_FROM_HMODULE|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL,id,systemLocal, (LPTSTR)&lpMsgBuf,0,NULL); FreeLibrary(hDll); } } error_result[0] = Val_long(id); if (lpMsgBuf) { error_result[1] = caml_copy_string(lpMsgBuf); LocalFree(lpMsgBuf); } else { error_result[1] = caml_copy_string("\r\n"); //找不到错误消息则为空字符串 } caml_raise_with_args(*caml_named_value("win32 exception"), 2, error_result); } __inline void raise_last_win32_error() { raise_win32_error(GetLastError()); } /* 进程相关函数 */ CAMLprim value open_process(value da, value inherit, value pid) { CAMLparam3(da, inherit, pid); CAMLlocal1(result); HANDLE hproc = OpenProcess(get_desired_access(da), Bool_val(inherit), Long_val(pid)); if (NULL == hproc) { raise_last_win32_error(); } result = alloc_handle(hproc); CAMLreturn(result); } void terminate_process(value handle, value exit_code) { if (!(TerminateProcess(Handle_val(handle), Long_val(exit_code)))) { raise_last_win32_error(); } } void close_handle(value handle) { if (!CloseHandle(Handle_val(handle))) { raise_last_win32_error(); } } /* 枚举所有进程 */ /* pid, 进程id proc_name, 保存进程名的字符串 size, proc_name的缓冲区大小 */ void get_proc_name(DWORD pid, char *proc_name, int size) { HANDLE hProcess ; if (pid == 0) { strncpy(proc_name, "System Idle Process", size); return; } else if (pid == 4) { strncpy(proc_name, "System", size); return; } strncpy(proc_name, "<unknown>", size); hProcess = OpenProcess( PROCESS_QUERY_INFORMATION | PROCESS_VM_READ, FALSE, pid ); // Get the process name. if (NULL != hProcess ) { HMODULE hMod; DWORD cbNeeded; if ( EnumProcessModules( hProcess, &hMod, sizeof(hMod), &cbNeeded) ) { GetModuleBaseName( hProcess, hMod, proc_name, size ); } } CloseHandle( hProcess ); } /* 枚举所有进程,返回类型为(pid, pname) array; pid为进程id, pname为进程映像名 */ CAMLprim value enum_all_proc () { #define MAX_PROC 1024 DWORD all_proc_id[MAX_PROC], cbNeeded, cProcesses, pid; unsigned int i; char proc_name[MAX_PATH]; CAMLparam0 (); CAMLlocal2 (result, proc_info); if (!EnumProcesses(all_proc_id, sizeof(all_proc_id), &cbNeeded)){ raise_last_win32_error(); } cProcesses = cbNeeded / sizeof(DWORD); /* 生成(int, string) array的进程列表 */ result = caml_alloc(cProcesses, 0); //result要用Store_field初始化?我看了alloc.c中caml_alloc_array的代码, //它也没有用Store_field进行初始化,故我这里也没有初始化. //后面直接用caml_modify for (i = 0; i < cProcesses; i++) { pid = all_proc_id[i]; get_proc_name(pid, proc_name, MAX_PATH); proc_info = caml_alloc(2, 0); Store_field(proc_info, 0, Val_long(pid)); Store_field(proc_info, 1, caml_copy_string(proc_name)); caml_modify(&Field(result, i), proc_info); } CAMLreturn (result); } /* 打开特权 */ void EnablePrivilege(LPSTR name) { HANDLE hToken; BOOL rv; TOKEN_PRIVILEGES priv = {1,{0,0,SE_PRIVILEGE_ENABLED}}; LookupPrivilegeValue(0,name,&priv.Privileges[0].Luid); OpenProcessToken(GetCurrentProcess(),TOKEN_ADJUST_PRIVILEGES,&hToken); if (!AdjustTokenPrivileges(hToken,FALSE,&priv,sizeof priv,0,0)){ CloseHandle(hToken); raise_last_win32_error(); } CloseHandle(hToken); } /* 包装给OCaml */ void enable_privilege(value v) { EnablePrivilege(String_val(v)); }
process.ml, 包装函数的接口:
(* 进程访问权限 *) type process_desired_access = | DELETE | READ_CONTROL | SYNCHRONIZE | WRITE_DAC | WRITE_OWNER | PROCESS_ALL_ACCESS | PROCESS_CREATE_PROCESS | PROCESS_CREATE_THREAD | PROCESS_DUP_HANDLE | PROCESS_QUERY_INFORMATION | PROCESS_QUERY_LIMITED_INFORMATION | PROCESS_SET_INFORMATION | PROCESS_SET_QUOTA | PROCESS_SUSPEND_RESUME | PROCESS_TERMINATE | PROCESS_VM_OPERATION | PROCESS_VM_READ | PROCESS_VM_WRITE type privilege_constants = | SE_CREATE_TOKEN | SE_ASSIGNPRIMARYTOKEN | SE_LOCK_MEMORY | SE_INCREASE_QUOTA | SE_UNSOLICITED_INPUT | SE_MACHINE_ACCOUNT | SE_TCB | SE_SECURITY | SE_TAKE_OWNERSHIP | SE_LOAD_DRIVER | SE_SYSTEM_PROFILE | SE_SYSTEMTIME | SE_PROF_SINGLE_PROCESS | SE_INC_BASE_PRIORITY | SE_CREATE_PAGEFILE | SE_CREATE_PERMANENT | SE_BACKUP | SE_RESTORE | SE_SHUTDOWN | SE_DEBUG | SE_AUDIT | SE_SYSTEM_ENVIRONMENT | SE_CHANGE_NOTIFY | SE_REMOTE_SHUTDOWN | SE_CREATE_GLOBAL | SE_UNDOCK | SE_MANAGE_VOLUME | SE_IMPERSONATE | SE_ENABLE_DELEGATION | SE_SYNC_AGENT | SE_TRUSTED_CREDMAN_ACCESS | SE_RELABEL | SE_INCREASE_WORKING_SET | SE_TIME_ZONE | SE_CREATE_SYMBOLIC_LINK let string_of_privilege = function | SE_CREATE_TOKEN -> "SeCreateTokenPrivilege" | SE_ASSIGNPRIMARYTOKEN -> "SeAssignPrimaryTokenPrivilege" | SE_LOCK_MEMORY -> "SeLockMemoryPrivilege" | SE_INCREASE_QUOTA -> "SeIncreaseQuotaPrivilege" | SE_UNSOLICITED_INPUT -> "SeUnsolicitedInputPrivilege" | SE_MACHINE_ACCOUNT -> "SeMachineAccountPrivilege" | SE_TCB -> "SeTcbPrivilege" | SE_SECURITY -> "SeSecurityPrivilege" | SE_TAKE_OWNERSHIP -> "SeTakeOwnershipPrivilege" | SE_LOAD_DRIVER -> "SeLoadDriverPrivilege" | SE_SYSTEM_PROFILE -> "SeSystemProfilePrivilege" | SE_SYSTEMTIME -> "SeSystemtimePrivilege" | SE_PROF_SINGLE_PROCESS -> "SeProfileSingleProcessPrivilege" | SE_INC_BASE_PRIORITY -> "SeIncreaseBasePriorityPrivilege" | SE_CREATE_PAGEFILE -> "SeCreatePagefilePrivilege" | SE_CREATE_PERMANENT -> "SeCreatePermanentPrivilege" | SE_BACKUP -> "SeBackupPrivilege" | SE_RESTORE -> "SeRestorePrivilege" | SE_SHUTDOWN -> "SeShutdownPrivilege" | SE_DEBUG -> "SeDebugPrivilege" | SE_AUDIT -> "SeAuditPrivilege" | SE_SYSTEM_ENVIRONMENT -> "SeSystemEnvironmentPrivilege" | SE_CHANGE_NOTIFY -> "SeChangeNotifyPrivilege" | SE_REMOTE_SHUTDOWN -> "SeRemoteShutdownPrivilege" | SE_CREATE_GLOBAL -> "SeCreateGlobalPrivilege" | SE_UNDOCK -> "SeUndockPrivilege" | SE_MANAGE_VOLUME -> "SeManageVolumePrivilege" | SE_IMPERSONATE -> "SeImpersonatePrivilege" | SE_ENABLE_DELEGATION -> "SeEnableDelegationPrivilege" | SE_SYNC_AGENT -> "SeSyncAgentPrivilege" | SE_TRUSTED_CREDMAN_ACCESS -> "SeTrustedCredManAccessPrivilege" | SE_RELABEL -> "SeRelabelPrivilege" | SE_INCREASE_WORKING_SET -> "SeIncreaseWorkingSetPrivilege" | SE_TIME_ZONE -> "SeTimeZonePrivilege" | SE_CREATE_SYMBOLIC_LINK -> "SeCreateSymbolicLinkPrivilege" type handle exception Win32Error of int * string let _ = Callback.register_exception "win32 exception" (Win32Error (0,"win32 error")) (* 是否为空句柄 *) external is_null_handle : handle:handle -> bool = "is_null_handle" (* 关闭句柄,失败则抛出Win32Error异常 *) external close_handle : handle:handle -> unit = "close_handle" (* 打开进程,打开失败抛出Win32Error异常 *) external open_process : da : process_desired_access list -> inherit_handle : bool -> proc_id : int -> handle = "open_process" (* 结束进程,失败抛出Win32Error异常 *) external terminate_process : handle:handle -> exit_code : int -> unit = "terminate_process" type proc_info = int * string (* 枚举所有进程 *) external enum_processes : unit -> proc_info array = "enum_all_proc" external enable_privilege_s : string -> unit = "enable_privilege" (* 提升当前进程的指定权限,失败抛出Win32Error异常 *) let enable_privilege priv = enable_privilege_s (string_of_privilege priv) (* 杀死指定的进程,失败则抛出Win32Error异常 *) let kill pid = let hproc = open_process [ PROCESS_TERMINATE ] false pid in (* 如果terminate_process抛出异常,则关闭句柄,并重新抛出异常 *) try ( terminate_process hproc 1; close_handle hproc ) with exn -> close_handle hproc; raise exn
kill.ml,主程序,注意这个文件要以cp936编码保存，否则cmd输出乱码:
(* * 进程结束工具 *) let main () = let pname = ref None in let kill_all = ref false in let usage = "进程结束工具\n使用方法: kill [-a] [-n <process name>] [pid ...] \ \n进程名可以用通配符?和*" in let args = Arg.align [ ("-n", Arg.String (fun s -> pname := Some s), " 要结束的进程名"); ("-a", Arg.Set kill_all, " 结束所有进程名匹配的进程") ] in if Array.length Sys.argv = 1 then (Arg.usage args usage; exit 1); (* 添加命令行参数上的pid *) let pids = ref [] in let append_pids s = try let id = int_of_string s in pids := id :: !pids with _ -> failwith "进程id必须为数字" in Arg.parse args append_pids usage; (* 设置调试权限 *) Process.enable_privilege Process.SE_DEBUG; (* 枚举所有进程 *) let all_proc = Array.to_list (Process.enum_processes ()) in (* 结束进程,pids为进程id列表 *) let kill_procs pids = let kill_proc pid = try let name = List.assoc pid all_proc in Printf.printf "结束进程 %-6d: %s\n" pid name; Process.kill pid with | Not_found -> Printf.printf "找不到进程id:%d\n" pid | Process.Win32Error (id, msg) -> Printf.printf "[Win32 Error %d]: %s" id msg in List.iter kill_proc pids in (* 结束所有指定进程id的进程 *) if !pids <> [] then kill_procs !pids ; match !pname with | None -> () | Some s -> ( (* 转换?和*通配符为正则表达式字符串 *) let reg_str = let buf = Buffer.create 100 in for i = 0 to String.length s - 1 do match s.[i] with | '$' | '^' | '+' | '[' | ']' as c -> Buffer.add_char buf '\\'; Buffer.add_char buf c | '?' -> Buffer.add_char buf '.' | '*' -> Buffer.add_string buf ".*" | c -> Buffer.add_char buf c done; Buffer.contents buf in let s_regex = Str.regexp reg_str in let is_proc_name (_, name) = Str.string_match s_regex name 0 && Str.match_end () = String.length name || name = s ^ ".exe" in let pids = List.filter is_proc_name all_proc in if pids = [] then ( Printf.printf "找不到进程: %s\n" s; exit 1 ); (* 把(id, name)的列表变成id的列表 *) let pids = List.map (fun (id, name) -> id) pids in if !kill_all then kill_procs pids else kill_procs [List.hd pids] ) let _ = main ()
编译方式:
以下采用vc编译器,如果用gcc, 库的名字不同, 用-cclib -lpsapi 代替-cclib psapi.lib
字节码:
ocamlc -custom -o kill.exe win32_process_stubs.c process.ml kill.ml -cclib psapi.lib
本地代码:
ocamlopt -o kill.opt.exe win32_process_stubs.c process.ml kill.ml -cclib psapi.lib
带.pdb调试符号文件的本地代码(仅限vc编译器,也可以加上-g选项去掉优化):
ocamlopt -o kill.opt.exe win32_process_stubs.c process.ml kill.ml -ccopt "psapi.lib -link /DEBUG"
生成自定义toplevel:
ocamlmktop -custom -o processtop.exe process.ml win32_process_stubs.c -cclib psapi.lib win32_process_stubs.c
生成库文件:
ocamlmklib -linkall -o process process.cmx win32_process_stubs.obj -ldopt "advapi32.lib psapi.lib"
然后就可以在ocaml toplevel中使用#load "process.cma" 加载Process模块
附带一个ps.ml，列出当前所有进程:
(* 列出系统的所有进程 *) let main () = let all_proc = Process.enum_processes () in Array.iter (fun (id, name) -> Printf.printf "%-30s %8d\n" name id) all_proc let _ = (* main (); (* 没有提升debug权限时，有些进程名字获取不到 *) *) Process.enable_privilege Process.SE_DEBUG; main ()
编译方式与kill相同，只是把kill换成ps。
现在可以用ps列出当前进程，然后用kill进程id或进程名的方式结束 进程
参考文章:
How to wrap C functions to OCaml
997
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
