Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

merge back from master

  • Loading branch information...
commit 40f720a7340a119f13a8bc9b9b5749868a648063 1 parent 026552b
@mor1 mor1 authored
Showing with 11,639 additions and 4,544 deletions.
  1. +17 −6 .gitignore
  2. +21 −139 INSTALL.md
  3. +15 −9 Makefile
  4. +20 −2 NOTES.md
  5. +2 −0  README.md
  6. +24 −11 assemble.sh
  7. +4 −1 docs/Makefile
  8. +1 −0  docs/json.ml
  9. +50 −28 docs/odoc_json.ml
  10. +87 −0 docs/parse.ml
  11. +18 −15 lib/Makefile
  12. +1 −1  lib/_tags
  13. +0 −3  lib/block/direct/_tags
  14. +0 −1  lib/block/direct/block.mlpack
  15. +1 −0  lib/block/direct/block.smlpack
  16. +0 −103 lib/block/direct/rO.ml
  17. +141 −0 lib/block/direct/simpleKV.ml
  18. +1 −9 lib/block/{socket/manager.mli → direct/simpleKV.mli}
  19. +0 −1  lib/block/{socket/block.mlpack → node/block.smlpack}
  20. +1 −0  lib/block/node/manager.ml
  21. +0 −3  lib/block/socket/_tags
  22. +1 −0  lib/block/socket/block.smlpack
  23. +113 −0 lib/block/socket/simpleKV.ml
  24. +17 −0 lib/block/socket/simpleKV.mli
  25. +0 −3  lib/cow/_tags
  26. 0  lib/cow/{cow.mlpack → cow.smlpack}
  27. +0 −2  lib/debugger/lib/_tags
  28. +0 −4 lib/debugger/lib/debugger.mlpack
  29. +0 −123 lib/debugger/lib/event.ml
  30. +0 −62 lib/debugger/lib/server.ml
  31. +0 −20 lib/debugger/lib/style.ml
  32. +0 −126 lib/debugger/myocamlbuild.ml
  33. +0 −13 lib/debugger/static/index.html
  34. +0 −97 lib/debugger/static/index.js
  35. +0 −232 lib/debugger/static/uki.js
  36. +0 −4 lib/dns/_tags
  37. 0  lib/dns/{dns.mlpack → dns.smlpack}
  38. +0 −1  lib/dyntype/_tags
  39. +21 −0 lib/fs/Makefile
  40. +1,332 −0 lib/fs/fat.ml
  41. +104 −0 lib/fs/fat.mli
  42. +234 −0 lib/fs/fat_shell.ml
  43. +1 −0  lib/fs/fs.smlpack
  44. +0 −3  lib/http/_tags
  45. 0  lib/http/{http.mlpack → http.smlpack}
  46. +2 −2 lib/http/parser.ml
  47. +16 −8 lib/http/server.ml
  48. +71 −0 lib/http/server.mli
  49. +87 −142 lib/myocamlbuild.ml
  50. +0 −3  lib/net/direct/_tags
  51. +6 −3 lib/net/direct/channel.ml
  52. +11 −6 lib/net/direct/datagram.ml
  53. +0 −4 lib/net/direct/dhcp/_tags
  54. +25 −8 lib/net/direct/dhcp/client.ml
  55. +37 −0 lib/net/direct/dhcp/client.mli
  56. 0  lib/net/direct/dhcp/{dhcp.mlpack → dhcp.smlpack}
  57. +110 −0 lib/net/direct/dhcp/option.mli
  58. +4 −5 lib/net/direct/ethif.ml
  59. +38 −0 lib/net/direct/ethif.mli
  60. +2 −2 lib/net/direct/flow.ml
  61. +2 −2 lib/net/direct/icmp.ml
  62. +21 −0 lib/net/direct/icmp.mli
  63. +0 −5 lib/net/direct/ip/_tags
  64. 0  lib/net/direct/ip/{iP.mlpack → iP.smlpack}
  65. +2 −2 lib/net/direct/ipv4.ml
  66. +85 −49 lib/net/direct/manager.ml
  67. +13 −3 lib/net/direct/manager.mli
  68. 0  lib/net/direct/{net.mlpack → net.smlpack}
  69. +0 −6 lib/net/direct/tcp/_tags
  70. +6 −3 lib/net/direct/tcp/options.ml
  71. +10 −10 lib/net/direct/tcp/pcb.ml
  72. +5 −0 lib/net/direct/tcp/segment.ml
  73. 0  lib/net/direct/tcp/{tcp.mlpack → tcp.smlpack}
  74. +7 −0 lib/net/direct/tcp/window.ml
  75. +0 −1  lib/net/direct/udp.ml
  76. +225 −0 lib/net/node/channel.ml
  77. +49 −0 lib/net/node/channel.mli
  78. +34 −0 lib/net/node/datagram.ml
  79. +22 −0 lib/net/node/datagram.mli
  80. +89 −0 lib/net/node/flow.ml
  81. +18 −23 lib/{block/socket/rO.ml → net/node/flow.mli}
  82. +3 −0  lib/net/node/manager.ml
  83. +1 −0  lib/net/node/manager.mli
  84. +5 −0 lib/net/node/net.smlpack
  85. +172 −0 lib/net/node/nettypes.ml
  86. +119 −0 lib/net/node/nettypes.mli
  87. +0 −3  lib/net/socket/_tags
  88. +6 −5 lib/net/socket/channel.ml
  89. +4 −5 lib/net/socket/datagram.ml
  90. +5 −5 lib/net/socket/flow.ml
  91. +13 −67 lib/net/socket/manager.ml
  92. +17 −43 lib/net/socket/manager.mli
  93. 0  lib/net/socket/{net.mlpack → net.smlpack}
  94. +559 −0 lib/oUnit/oUnit.ml
  95. +204 −0 lib/oUnit/oUnit.mli
  96. +0 −4 lib/openflow/_tags
  97. +152 −152 lib/openflow/controller.ml
  98. +29 −0 lib/openflow/controller.mli
  99. +1,198 −1,214 lib/openflow/ofpacket.ml
  100. +443 −0 lib/openflow/ofpacket.mli
  101. +1 −1  lib/openflow/{openflow.mlpack → openflow.smlpack}
  102. +0 −3  lib/os/node.itarget
  103. +1 −3 lib/os/node/_tags
  104. +2 −0  lib/os/node/activations.ml
  105. +31 −0 lib/os/node/activations.mli
  106. +5 −24 lib/{block/socket/manager.ml → os/node/blkif.mli}
  107. +37 −0 lib/os/node/clock.mli
  108. +36 −0 lib/os/node/console.mli
  109. +1 −0  lib/os/node/devices.ml
  110. +1 −0  lib/os/node/devices.mli
  111. +18 −0 lib/os/node/env.ml
  112. +17 −0 lib/os/node/env.mli
  113. +22 −16 lib/os/node/main.ml
  114. +1 −0  lib/os/node/main.mli
  115. +3 −1 lib/os/node/{oS.mlpack → oS.smlpack}
  116. +0 −1  lib/os/runtime_node/_tags
  117. +19 −4 lib/os/runtime_node/mirage.js
  118. +660 −89 lib/os/runtime_node/runtime.js
  119. +0 −1  lib/os/runtime_unix/_tags
  120. +1 −2  lib/os/runtime_unix/checksum_stubs.c
  121. +0 −10 lib/os/runtime_unix/evtchn_stubs.c
  122. +1 −2  lib/os/runtime_unix/main.c
  123. +139 −8 lib/os/runtime_unix/socket_stubs.c
  124. +0 −1  lib/os/runtime_xen/dietlibc/lib/_tags
  125. +0 −1  lib/os/runtime_xen/dietlibc/libugly/_tags
  126. +20 −0 lib/os/runtime_xen/include/log.h
  127. +2 −0  lib/os/runtime_xen/kernel/gnttab_stubs.c
  128. +1 −0  lib/os/runtime_xen/kernel/kernel.c
  129. +1 −1  lib/os/runtime_xen/kernel/main.c
  130. +1 −0  lib/os/runtime_xen/kernel/mm.c
  131. +1 −0  lib/os/runtime_xen/kernel/x86_mm.c
  132. +1 −0  lib/os/runtime_xen/kernel/x86_setup.c
  133. +0 −1  lib/os/runtime_xen/ocaml/_tags
  134. +0 −1  lib/os/runtime_xen/ocaml/libocaml.cclib
  135. +0 −532 lib/os/runtime_xen/ocaml/str_stubs.c
  136. +0 −3  lib/os/unix.itarget
  137. +0 −4 lib/os/unix/_tags
  138. +2 −2 lib/os/unix/activations.ml
  139. +2 −5 lib/os/unix/activations.mli
  140. +80 −8 lib/os/unix/blkif.ml
  141. +2 −5 lib/os/unix/blkif.mli
  142. +183 −0 lib/os/unix/devices.ml
  143. +67 −0 lib/os/unix/devices.mli
  144. +19 −0 lib/os/unix/env.ml
  145. +17 −0 lib/os/unix/env.mli
  146. +25 −30 lib/os/unix/main.ml
  147. +1 −1  lib/os/unix/main.mli
  148. +34 −25 lib/os/unix/netif.ml
  149. +2 −4 lib/os/unix/netif.mli
  150. +4 −1 lib/os/unix/{oS.mlpack → oS.smlpack}
  151. +89 −0 lib/os/unix/socket.ml
  152. +61 −0 lib/os/unix/socket.mli
  153. +0 −2  lib/os/xen.itarget
  154. +0 −5 lib/os/xen/_tags
  155. +24 −0 lib/os/xen/activations.mli
  156. +152 −50 lib/os/xen/blkif.ml
  157. +58 −0 lib/os/xen/blkif.mli
  158. +29 −0 lib/os/xen/clock.mli
  159. +1 −0  lib/os/xen/devices.ml
  160. +1 −0  lib/os/xen/devices.mli
  161. +18 −0 lib/os/xen/env.ml
  162. +17 −0 lib/os/xen/env.mli
  163. +55 −64 lib/os/xen/gnttab.ml
  164. +16 −12 lib/os/xen/gnttab.mli
  165. +57 −9 lib/os/xen/io_page.ml
  166. +22 −3 lib/os/xen/io_page.mli
  167. +21 −16 lib/os/xen/main.ml
  168. +18 −0 lib/os/xen/main.mli
  169. +65 −42 lib/os/xen/netif.ml
  170. +30 −4 lib/os/xen/netif.mli
  171. +2 −0  lib/os/xen/{oS.mlpack → oS.smlpack}
  172. +56 −29 lib/os/xen/queueop.ml
  173. +47 −0 lib/os/xen/queueop.mli
  174. +8 −12 lib/os/xen/ring.ml
  175. +35 −0 lib/os/xen/time.mli
  176. +32 −0 lib/os/xen/xb_op.mli
  177. +13 −0 lib/os/xen/xb_partial.mli
  178. +13 −0 lib/os/xen/xb_state.mli
  179. +31 −19 lib/os/xen/xs.ml
  180. +5 −10 lib/os/xen/xs.mli
  181. +13 −0 lib/os/xen/xs_packet.mli
  182. +101 −55 lib/os/xen/xsraw.ml
  183. +6 −11 lib/os/xen/xsraw.mli
  184. +0 −57 lib/pack_in_one.ml
  185. +0 −2  lib/regexp/_tags
  186. +4 −4 lib/regexp/{regexp.mlpack → regexp.smlpack}
  187. +24 −0 lib/std/LICENSE.ounit
  188. +1 −5 lib/std/_tags
  189. +27 −0 lib/std/bitstring.ml
  190. +20 −0 lib/std/bitstring.mli
  191. +4 −4 lib/std/bitstring_persistent.ml
  192. +21 −0 lib/std/bitstring_stream.ml
  193. +2 −6 lib/{block/socket/rO.mli → std/bitstring_stream.mli}
  194. +6 −3 lib/std/stdlib.mllib
  195. +46 −0 lib/std/string.ml
  196. +39 −0 lib/std/string.mli
  197. +1 −1  lib/xen.itarget
  198. +14 −0 regress/Makefile
  199. +8 −0 regress/NOTES.md
  200. +4 −0 regress/basic.suite
  201. +8 −0 regress/basic/console.ml
  202. +1 −0  regress/basic/exception.ml
  203. +2 −0  regress/basic/exception.spec
  204. +2 −0  regress/basic/extern.ml
  205. +3 −0  regress/basic/extern.sh
  206. +1 −0  regress/basic/extern.spec
  207. +1 −0  regress/basic/sleep.mir
  208. +21 −0 regress/basic/sleep.ml
  209. +1 −0  regress/basic/sleep.spec
  210. +4 −0 regress/block.suite
  211. +17 −0 regress/block/basic_vbd.ml
  212. +10 −0 regress/block/basic_vbd.sh
  213. +3 −0  regress/block/basic_vbd.spec
  214. +20 −0 regress/block/basic_vbd_xen.ml
  215. +10 −0 regress/block/basic_vbd_xen.sh
  216. +3 −0  regress/block/basic_vbd_xen.spec
  217. +193 −0 regress/block/crunch_kv_ro.ml
  218. +13 −0 regress/block/gen_crunch.sh
  219. +33 −0 regress/block/kv_ro.ml
  220. +2 −0  regress/block/kv_ro_crunch.mir
  221. +1 −0  regress/block/kv_ro_crunch.spec
  222. +16 −0 regress/block/kv_ro_direct.sh
  223. +4 −0 regress/block/kv_ro_direct.spec
  224. +2 −0  regress/block/kv_ro_simple.mir
  225. +4 −0 regress/block/kv_ro_simple.sh
  226. +11 −0 regress/block/kv_ro_socket.sh
  227. +3 −0  regress/block/kv_ro_socket.spec
  228. +1 −0  regress/fs.suite
  229. +2 −0  regress/fs/readdir.mir
  230. +67 −0 regress/fs/readdir.ml
  231. +35 −0 regress/fs/readdir.sh
  232. +2 −0  regress/fs/readdir.spec
  233. +8 −0 regress/lwt.suite
  234. +18 −0 regress/lwt/echoserver1.ml
  235. +80 −0 regress/lwt/echoserver2.ml
  236. +1 −0  regress/lwt/heads1.mir
  237. +15 −0 regress/lwt/heads1.ml
  238. +1 −0  regress/lwt/heads1.spec
  239. +10 −0 regress/lwt/heads2.ml
  240. +1 −0  regress/lwt/heads2.spec
  241. +16 −0 regress/lwt/heads_syntax.ml
  242. +74 −0 regress/lwt/intserver.ml
  243. +19 −0 regress/lwt/timeout1.ml
  244. +22 −0 regress/lwt/timeout2.ml
  245. +5 −0 regress/net.suite
  246. +57 −0 regress/net/channel_echo.ml
  247. +2 −0  regress/net/channel_echo.spec
  248. +34 −0 regress/net/datagram_echo.ml
  249. +41 −0 regress/net/deens.ml
  250. +14 −0 regress/net/deens.sh
  251. +1 −0  regress/net/deens.spec
  252. +54 −0 regress/net/flow_echo.ml
  253. +2 −0  regress/net/flow_echo.spec
  254. +34 −0 regress/net/ping.ml
  255. +4 −0 regress/net/ping.sh
  256. +1 −0  regress/net/ping.spec
  257. +67 −0 regress/net/tcp_echo.ml
  258. +2 −0  regress/net/tcp_echo.spec
  259. +5 −0 regress/perf.suite
  260. +1 −3 tests/perf/alloc/test.ml → regress/perf/alloc.ml
  261. +5 −3 tests/perf/gc/test.ml → regress/perf/gcperf.ml
  262. +10 −12 {tests/perf/gnt → regress/perf}/gnt.ml
  263. +1 −0  regress/perf/gnt.spec
  264. +26 −23 {tests/perf/mandelbrot → regress/perf}/mandelbrot.ml
  265. +10 −8 {tests/perf/nbody → regress/perf}/nbody.ml
  266. +8 −2 {tests/perf/sieve → regress/perf}/sieve.ml
  267. +34 −0 scripts/caml-mode/Makefile
  268. +771 −0 scripts/caml-mode/caml-types.el
  269. +0 −71 scripts/deploy-linux
  270. +0 −63 scripts/deploy-minios
  271. +1 −1  scripts/ec2.sh
  272. +0 −4 scripts/init.sh
  273. +0 −7 scripts/linux-config.in
  274. +0 −24 scripts/lvs_init
  275. +0 −8 scripts/minios-config.in
  276. +41 −0 scripts/mir-build
  277. +45 −0 scripts/mir-fat-create
  278. +235 −0 scripts/mir-run
  279. +392 −204 scripts/myocamlbuild.ml
  280. +0 −43 scripts/run_minios
  281. +0 −16 scripts/tap_init
  282. +2 −2 syntax/Makefile
  283. +4 −8 syntax/_tags
  284. +3 −10 syntax/all.itarget
  285. +0 −1  syntax/bitstring.ml
  286. +2 −0  syntax/bitstring/_tags
  287. +1 −0  syntax/bitstring/bitstring_config.ml
  288. +1 −0  syntax/bitstring/bitstring_persistent.ml
  289. +1 −0  syntax/bitstring/bitstring_types.ml
  290. +1 −1  syntax/{ → bitstring}/pp_bitstring.ml
  291. +0 −1  syntax/bitstring_config.ml
  292. +0 −1  syntax/bitstring_persistent.ml
  293. +0 −1  syntax/bitstring_types.ml
  294. +2 −1  syntax/css/_tags
  295. +18 −0 syntax/css/options.ml
  296. +5 −2 syntax/css/quotations.ml
  297. +0 −1  syntax/dyntype.ml
  298. +0 −1  syntax/dyntype.mli
  299. +2 −0  syntax/dyntype/_tags
  300. +1 −0  syntax/dyntype/dyntype.ml
Sorry, we could not display the entire diff because too many files (386) changed.
View
23 .gitignore
@@ -1,14 +1,25 @@
+*~
+\#*
+.#*
+*.annot
+*.o
+
+_build/
+
+docs/parse.native
+
+tools/*/*.native
+tools/fs/mir-fs-*
+
+regress/myocamlbuild.ml
+regress/*/myocamlbuild.ml
+tests/*/*/myocamlbuild.ml
+
lib/.init
syntax.init
.*.swp
-*~
-*.annot
*.odoc
-_build/
CVS/
doc/html/
-tests/*/*/myocamlbuild.ml
/screenlog.*
-tools/*/*.native
tools/fs/*.o
-tools/fs/mir-fs-*
View
160 INSTALL.md
@@ -1,154 +1,36 @@
+Mirage has been tested on Debian Squeeze, Ubuntu Lucid and MacOS X 10.6. To compile the Xen backend, you *must* have a 64-bit Linux host. 32-bit is not supported at this time.
-Mirage has been tested on:
+# Requirements
-* Debian Squeeze x86_64 and x86_32
-* Ubuntu Lucid 10.04 x86_64
-* MacOS X 10.6 Snow Leopard x86_64
-* MacOS X 10.5 Snow Leopard x86_32
+You need to have the following installed and available on your `PATH`:
-To build it, you must first:
+* [OCaml](http://www.ocaml.org) 3.12.0
+* (optional) [Js_of_ocaml](http://ocsigen.org/js_of_ocaml/install)
-1. Install the basic toolchain
-2. Build the tools
-3. Build the core libraries
+# Installation
-Toolchain
----------
+Pick a location you want to install the binaries and add `$PREFIX/bin` to your `PATH`. The default `PREFIX` is `~/mir-inst` which does not require super-user access.
-You need to have the following installed and available on your PATH:
+Then run
-* OCaml 3.12.0
-* OCamlfind
-* Js_of_ocaml from http://ocsigen.org/js_of_ocaml/install (optional)
+```
+make PREFIX=<location>
+make install
+```
-Debian Squeeze and Ubuntu are still at 3.11, but you can grab the latest
-packages from: http://ocaml.debian.net/debian/ocaml-3.12.0/
+The installation has the UNIX and Xen custom runtimes, if appropriate for the build platform. You require 64-bit Linux to compile up Xen binaries (32-bit will not work).
-Then: apt-get install ocaml-findlib camlp4-extra ocaml-native-compilers
+# IDE integration
-### Ubuntu
+### Emacs
- sudo apt-get remove ocaml-findlib camlp4-extra ocaml-native-compilers
- sudo apt-get autoremove
+Mirage comes with a slightly modified version of the `caml-mode` to dispay type information. In order to install it, you can run
-There are then package conflicts with the following, which must be
-downloaded and installed separately:
+```
+make install-el
+```
- ncurses-bin_5.7+20100626-0ubuntu1_amd64.deb
- libncurses5-dev_5.7+20100626-0ubuntu1_amd64.deb
- libncurses5_5.7+20100626-0ubuntu1_amd64.deb
+### Vim
- sudo dpkg --install ~/libncurses5-dev_5.7+20100626-0ubuntu1_amd64.deb
- sudo dpkg --install ~/ncurses-bin_5.7+20100626-0ubuntu1_amd64.deb
- sudo dpkg --install ~/libncurses5-dev_5.7+20100626-0ubuntu1_amd64.deb
- sudo apt-get install ocaml-findlib camlp4-extra ocaml-native-compilers ocaml-nox
+You will need the latest version [ocaml-annot](https://github.com/avsm/ocaml-annot) (>= 0.9.1), to be able to display type information for your Mirage projects.
-The necessary GPG key must be installed to use the package source for
-the latest OCaml versions:
-
- gpg -a --export 49881AD3 > glondu.gpg
- apt-key add glondu.gpg
-
-Then add the following to `/etc/apt/sources.list`
-
- deb http://ocaml.debian.net/debian/ocaml-3.12.0 sid main
- deb-src http://ocaml.debian.net/debian/ocaml-3.12.0 sid main
-
-And finally execute apt-get update:
-
- sudo apt-get update
- sudo apt-get upgrade
-
-To install tuntap device, required for unix-direct:
-
- sudo modprobe tun
-
-
-All-in-one
-----------
-
- make PREFIX=<location> all install
-
-
-Tools
------
-
-This installs the build tools and syntax extensions into the install PREFIX.
-
- make PREFIX=<location> tools
-
-The tools include the `mir-unix-*` and `mir-xen` build wrappers.
-
-Libraries
----------
-
- make && make install
-
-This will build the OCaml libraries and the Xen custom runtime, if
-appropriate for the build platform. You require 64-bit Linux to
-compile up Xen binaries (32-bit will not work).
-
-Build an application
---------------------
-
-Mirage uses `ocamlbuild` to build applications, with the `mir`
-script providing a thin wrapper to install a custom plugin to deal
-with the various backends.
-
-To try out basic functionality, do `cd tests/basic/sleep`.
-
-Build a UNIX binary:
-
- mir-unix-direct sleep.bin
-
-output will be in `_build/sleep.bin`
-
-Build a Xen kernel:
-
- mir-xen sleep.xen
-
-output will be in `_build/sleep.{bin,xen}`, and you can boot it up
-in Xen with a config file like:
-
- $ cat > sleep.cfg
- name="sleep"
- memory=1024
- kernel="sleep.xen"
- <control-d>
- $ sudo xm create -c sleep.cfg
-
-This runs a simple interlocking sleep test which tries out the
-console and timer support for the various supported platforms.
-
-Note that the `kernel` variable only accepts an absolute path or the
-name of a file in the current directory.
-
-
-Network
--------
-
-Mirage networking is present in the Net module and can compile in two modes:
-
-A 'direct' mode that works from the Ethernet layer (the OS.Ethif
-module). On Xen, this is the virtual Ethernet driver, and on UNIX
-this requires the `tuntap` interface.
-
-A subset of the Net modules (Flow and Manager) are available in
-'socket' mode under UNIX. This maps the Flow interface onto POSIX
-sockets, enabling easy comparison with normal kernels.
-
-There are two echo servers available in:
-
-* `tests/net/flow`
-* `tests/net/flow_udp`
-
-You can compile these with:
-
- $ mir-unix-socket echo.bin
- $ ./_build/echo.bin
-
- $ mir-unix-direct echo.bin
- $ sudo ./_build/echo.bin
-
- $ mir-xen echo.xen
- # boot the kernel in ./_build/echo.xen
View
24 Makefile
@@ -1,4 +1,4 @@
-.PHONY: all clean tools
+.PHONY: all clean
.DEFAULT: all
-include Makefile.config
@@ -14,7 +14,8 @@ export PREFIX
JOBS=-j 6
export JOBS
-all: tools
+all:
+ @cd tools && $(MAKE)
@cd syntax && $(MAKE)
@cd lib && $(MAKE)
@@ -22,12 +23,12 @@ doc:
@cd docs && $(MAKE) all
@cd lib && $(MAKE) doc
-tools:
- @cd tools/crunch && ocamlbuild $(JOBS) crunch.native
- @cd tools/mir && $(MAKE) install
- @cp tools/crunch/_build/crunch.native $(PREFIX)/bin/mlcrunch
- @$(MAKE) -C tools/fs all
- @cp tools/fs/mir-fs-create $(PREFIX)/bin/mir-fs-create
+doc-json:
+ @./docs/_build/parse.native lib/_build/unix-socket > docs/_build/unix-socket.json
+ @./docs/_build/parse.native lib/_build/unix-direct > docs/_build/unix-direct.json
+ @./docs/_build/parse.native lib/_build/node > docs/_build/node.json
+# @./docs/_build/parse.native lib/_build/xen > docs/_build/xen.json
+
install:
@rm -rf _build
@@ -38,5 +39,10 @@ install:
clean:
@cd syntax && $(MAKE) clean
@cd lib && $(MAKE) clean
- @cd tools/crunch && ocamlbuild -clean
+ @cd tools && $(MAKE) clean
+ @cd regress && $(MAKE) clean
+ @cd docs && $(MAKE) clean
@rm -rf _build
+
+install-el:
+ @cd scripts/caml-mode && $(MAKE) install-el
View
22 NOTES.md
@@ -1,8 +1,26 @@
-Useful build targets:
+## Build targets
+
+These must be run from the `lib/` directory only, and will not work in subdirectories.
Given an input foo.ml:
- $ mir-unix-socket foo.pp.ml
+ $ mir-build foo.pp.ml
...will post-process the file with all the syntax extensions, and output the result in `_build/foo.pp.ml`. This is very useful to inspect the actual OCaml code being compiled after syntax extensions such as LWT or COW have been applied.
+ $ mir-build foo.inferred.mli
+
+...will generate the default .mli for a given .ml file (useful as a skeleton). It will be in `_build/foo.inferred.mli` and can be copied into the source directory and edited from there.
+
+## Test suite targets
+
+ $ cd regress
+
+ # run a single test, as listed in a .spec file
+ $ ocamlbuild lwt/heads1.exec
+ $ cat _build/lwt/heads1.exec
+
+ # run a suite of tests, as listed in .suite
+ $ ocamlbuild lwt.run
+ $ cat _build/lwt.run
+
View
2  README.md
@@ -12,6 +12,8 @@ project in the USENIX HotCloud paper available at:
An early self-hosting website (that may be down fairly often!) is
available at <http://www.openmirage.org/>
+Installation instructions: <http://www.openmirage.org/wiki/install>
+
This repository is still in a pre-alpha state and not suitable for use. If
you are interested in working with it, please contact:
View
35 assemble.sh
@@ -18,15 +18,15 @@ ROOT=`pwd`
BUILDDIR=${ROOT}/_build
function assemble_xen {
- if [ -d ${ROOT}/lib/_build/xen-direct ]; then
+ if [ -d ${ROOT}/lib/_build/xen ]; then
echo Assembling: Xen
- OBJ=${BUILDDIR}/xen-direct
+ OBJ=${BUILDDIR}/xen
mkdir -p ${OBJ}/lib ${OBJ}/syntax
for i in dietlibc/libdiet.a libm/libm.a ocaml/libocaml.a kernel/libxen.a kernel/libxencaml.a kernel/x86_64.o; do
- cp ${ROOT}/lib/_build/xen-direct/os/runtime_xen/$i ${OBJ}/lib/
+ cp ${ROOT}/lib/_build/xen/os/runtime_xen/$i ${OBJ}/lib/
done
cp ${ROOT}/lib/os/runtime_xen/kernel/mirage-x86_64.lds ${OBJ}/lib/
- cp ${ROOT}/lib/_build/xen-direct/std/*.{cmi,cmx,a,o,cmxa} ${OBJ}/lib/
+ cp ${ROOT}/lib/_build/xen/std/*.{cmi,cmx,a,o,cmxa} ${OBJ}/lib/
else
echo Skipping: Xen
fi
@@ -49,14 +49,14 @@ function assemble_unix {
function assemble_node {
mode=$1
- echo Assembling: node $1
- OBJ=${BUILDDIR}/node-$1
- if [ -d ${ROOT}/lib/_build/node-$1 ]; then
+ echo Assembling: node
+ OBJ=${BUILDDIR}/node
+ if [ -d ${ROOT}/lib/_build/node ]; then
mkdir -p ${OBJ}/lib
for i in libos.a dllos.so; do
- cp ${ROOT}/lib/_build/node-$1/os/runtime_node/$i ${OBJ}/lib/
+ cp ${ROOT}/lib/_build/node/os/runtime_node/$i ${OBJ}/lib/
done
- cp ${ROOT}/lib/_build/node-$1/std/*.{cmi,cmo,cma} ${OBJ}/lib/
+ cp ${ROOT}/lib/_build/node/std/*.{cmi,cmo,cma} ${OBJ}/lib/
cp ${ROOT}/lib/os/runtime_node/*.js ${OBJ}/lib/
else
echo Skipping: Node
@@ -67,7 +67,7 @@ function assemble_syntax {
echo Assembling: camlp4 extensions
OBJ=${BUILDDIR}/syntax
mkdir -p ${OBJ}
- cp ${ROOT}/syntax/_build/*.{cma,cmi,cmo} ${OBJ}/
+ cp ${ROOT}/syntax/_build/*.{cma,cmi,cmo,cmxs} ${OBJ}/
}
function assemble_scripts {
@@ -77,9 +77,22 @@ function assemble_scripts {
cp ${ROOT}/scripts/myocamlbuild.ml ${OBJ}/
}
+function assemble_bin {
+ echo Assembling: binaries
+ OBJ=${BUILDDIR}/bin
+ mkdir -p ${OBJ}
+ sed -e "s,@MIRAGELIB@,${PREFIX},g" < ${ROOT}/scripts/mir-build > ${OBJ}/mir-build
+ cp ${ROOT}/scripts/mir-run ${OBJ}/mir-run
+ chmod 755 ${OBJ}/mir-build ${OBJ}/mir-run
+ cp ${ROOT}/tools/crunch/_build/crunch.native ${OBJ}/mir-crunch
+ cp ${ROOT}/tools/fs/mir-fs-create ${OBJ}/mir-fs-create
+ cp ${ROOT}/scripts/mir-fat-create ${OBJ}/mir-fat-create
+}
+
assemble_syntax
assemble_xen
assemble_unix "direct"
assemble_unix "socket"
-assemble_node "socket"
+assemble_node
assemble_scripts
+assemble_bin
View
5 docs/Makefile
@@ -1,10 +1,13 @@
.PHONY: all clean
-all: _build/odoc_json.cmo _build/odoc_json.cmxs
+all: _build/odoc_json.cmo _build/odoc_json.cmxs _build/parse.native
@ :
_build/odoc_json.cmo _build/odoc_json.cmxs: odoc_json.ml
ocamlbuild -cflag -I -cflag +ocamldoc odoc_json.cmo odoc_json.cmxs
+_build/parse.native: json.ml parse.ml
+ ocamlbuild parse.native
+
clean:
ocamlbuild -clean
View
1  docs/json.ml
View
78 docs/odoc_json.ml
@@ -245,7 +245,7 @@ class gen () =
method t_of_text = List.map self#t_of_text_element
- method t_of_raw s = Leaf (remove_asterisks s)
+ method t_of_raw s = Leaf s
method t_of_text_element = function
| Odoc_info.Raw s -> self#t_of_raw s
@@ -316,9 +316,9 @@ class gen () =
| None -> Empty
| Some t -> String (Odoc_info.string_of_module_type t) (* self#json_of_module_type_expr t *)
in
- let mk = "kind", match mt.Module.mt_kind with
- | None -> Empty
- | Some t -> Empty (* self#json_of_module_type_kind t *)
+ let mk = match mt.Module.mt_kind with
+ | None -> "kind", Empty
+ | Some t -> self#json_of_module_type_kind t
in
let file = "file", String mt.Module.mt_file in
Object (name :: file :: loc :: info :: mte :: mk :: [])
@@ -378,14 +378,15 @@ class gen () =
in *)
Object (name :: loc :: info :: args @ alias) (* @ code *)
+ method json_of_mnt_option = function
+ | None -> []
+ | Some (Module.Mod _) -> ["kind", String "module"]
+ | Some (Module.Modtype _) -> ["kind", String "module_type"]
+
method json_of_included_module im =
let name = "name", String im.Module.im_name in
let info = "info", self#json_of_info_opt im.Module.im_info in
- let kind = match im.im_module with
- | None -> []
- | Some (Module.Mod _) -> ["kind", String "module"]
- | Some (Module.Modtype _) -> ["kind", String "module_type"]
- in
+ let kind = self#json_of_mnt_option im.im_module in
Object (name :: info :: kind @ [])
method json_of_comment t =
@@ -407,7 +408,7 @@ class gen () =
Object (name :: loc :: info :: params :: kind :: manifest @ []) (* @ code *)
method json_of_type_parameter (texp, covar, contravar) =
- Object ["covariant", String (string_of_bool covar); "contravariant", String (string_of_bool contravar); "type", self#json_of_type_expr_param texp]
+ Object ["covariant", (json_of_bool covar); "contravariant", (json_of_bool contravar); "type", self#json_of_type_expr_param texp]
method json_of_type_expr t =
Odoc_info.reset_type_names ();
@@ -499,31 +500,53 @@ class gen () =
method json_of_module_parameter mparam =
let name = "name", String mparam.Module.mp_name in
- Object (name :: [])
+ let typ = self#json_of_module_type_kind mparam.Module.mp_kind in
+ Object (name :: typ :: [])
+ method json_of_module_alias al =
+ Object (("name" , String al.Module.ma_name) :: self#json_of_mnt_option al.Module.ma_module)
+
+ method json_of_module_type_alias al =
+ (("name" , String al.Module.mta_name) ::
+ match al.Module.mta_module with
+ | None -> []
+ | Some m -> [ "module_type", self#json_of_module_type m ])
+
+ method json_of_module_type_kind = function
+ | Module_type_struct l ->
+ "module_structure", Array (List.map self#json_of_module_element l)
+ | Module_type_functor (mparam, mk) ->
+ "module_functor", Object ["parameter", self#json_of_module_parameter mparam;
+ self#json_of_module_type_kind mk]
+ | Module_type_alias ma ->
+ "module_alias", Object (self#json_of_module_type_alias ma)
+ | Module_type_with (mk, s) ->
+ "module_with", Object [ self#json_of_module_type_kind mk;
+ "with", String s]
+ | Module_type_typeof s ->
+ "module_typeof", String s
+
method json_of_module_kind = function
| Module_struct l ->
- "module_structure", Array (List.map self#json_of_module_element l)
+ "module_structure", Array (List.map self#json_of_module_element l)
| Module_alias ma ->
- "module_alias", String "unavailable" (* self#t_of_module_alias ma *)
+ "module_alias", self#json_of_module_alias ma
| Module_functor (mparam, mk) ->
- "module_functor", Object (["parameter", self#json_of_module_parameter mparam; self#json_of_module_kind mk])
-(* node "module_functor"
- [ self#t_of_module_parameter mparam ; self#t_of_module_kind mk]*)
+ "module_functor", Object ["parameter", self#json_of_module_parameter mparam;
+ self#json_of_module_kind mk]
| Module_apply (mk1, mk2) ->
- "module_apply", String "unavailable"
-(* node "module_apply"
- [ self#t_of_module_kind mk1 ; self#t_of_module_kind mk2]*)
+ "module_apply", Array [ Object [self#json_of_module_kind mk1];
+ Object [self#json_of_module_kind mk2]]
| Module_with (mk, s) ->
- "module_with", String "unavailable"
-(* node "module_with"
- [ self#t_of_module_type_kind mk; node "with" [Leaf s] ]*)
+ "module_with", Object [self#json_of_module_type_kind mk;
+ "with", String s]
| Module_constraint (mk, mtk) ->
- self#json_of_module_kind mk
-(* node "module_constraint"
- [ self#t_of_module_kind mk ;
- self#t_of_module_type_kind mtk ;
- ]*)
+ "module_constraint", Object [self#json_of_module_kind mk;
+ self#json_of_module_type_kind mtk]
+ | Module_typeof s ->
+ "module_typeof", String s
+ | Module_unpack (s, al) ->
+ "module_unpack", Object (("code", String s) :: self#json_of_module_type_alias al)
method json_of_module m =
let name = "name", String m.Module.m_name in
@@ -533,7 +556,6 @@ class gen () =
let mte = "type", String (Odoc_info.string_of_module_type m.Module.m_type) in
let mk = self#json_of_module_kind m.Module.m_kind in
let info = "info", self#json_of_info_opt m.Module.m_info in
-
(* dependencies *)
let p = m.Module.m_name in
let ch = m.Module.m_top_deps in
View
87 docs/parse.ml
@@ -0,0 +1,87 @@
+open Json
+open Printf
+
+let string_of_file name =
+ let ch = open_in name in
+ let len = 1024 in
+ let buf = Buffer.create len in
+ (try while true do
+ let l = input_line ch in
+ Buffer.add_string buf l
+ done with _ -> ());
+ close_in ch;
+ Buffer.contents buf
+
+let string_val k l =
+ try match List.assoc k l with
+ | String x -> x
+ | _ -> ""
+ with Not_found ->
+ Printf.eprintf "string_val %s %s\n%!" k (Json.to_string (Object l)); exit 1
+
+let object_val k l =
+ try match List.assoc k l with
+ | Object x -> x
+ | _ -> []
+ with Not_found ->
+ Printf.eprintf "string_val %s %s\n%!" k (Json.to_string (Object l)); exit 1
+
+let array_val k l =
+ try match List.assoc k l with
+ | Array x -> x
+ | _ -> []
+ with Not_found ->
+ []
+
+let get_object = function
+ | Object x -> x
+ | j -> Printf.eprintf "%s\n!" (Json.to_string j); exit 1
+
+let module_type l =
+ if List.mem_assoc "module_type" l then
+ `Module_type (object_val "module_type" l)
+ else if List.mem_assoc "module" l then
+ `Module (object_val "module" l)
+ else
+ `Other
+
+let parse_module dir name fn =
+ match Json.of_string (string_of_file (Filename.concat dir (name ^ ".json"))) with
+ |Object [ "module", Object x ] -> fn x
+ |x -> failwith ("b" ^ Json.to_string x)
+
+let index_map dir fn =
+ match Json.of_string (string_of_file (Filename.concat dir "index.json")) with
+ |Array js -> List.map (function Object l -> fn l |_ -> assert false) js
+ |x -> failwith ("c" ^ Json.to_string x)
+
+let module_map dir fn =
+ index_map dir (fun l -> parse_module dir (string_val "name" l) fn)
+
+let make_tree dir =
+ let node name children = Object [
+ "data", String name;
+ "attr", Object ["id", String ("tree" ^ name)];
+ "children", Array children;
+ ] in
+ let rec subtree l =
+ let name = string_val "name" l in
+ let children =
+ List.fold_left (fun accu m ->
+ match module_type (get_object m) with
+ | `Module_type m
+ | `Module m -> subtree m :: accu
+ | `Other -> accu
+ ) [] (array_val "module_structure" l) in
+ node name children in
+ Array (module_map dir subtree)
+
+let _ =
+ let dir = Sys.argv.(1) in
+ let module_tree = make_tree dir in
+ let module_info = module_map dir (fun x ->
+ let name = string_val "name" x in
+ name, Object ["module", Object x]
+ ) in
+ let out_json = Object [ "tree", module_tree; "info", Object module_info ] in
+ print_endline (Json.to_string out_json)
View
33 lib/Makefile
@@ -1,44 +1,47 @@
.PHONY: all unix clean
JOBS ?= -j 4
-OFLAGS ?= -classic-display
+OFLAGS ?= # -classic-display
OS = $(shell uname -s | tr '[A-Z]' '[a-z]' | sed -e 's/darwin/macosx/g')
ARCH = $(shell uname -m)
NODE = $(shell ocamlfind query js_of_ocaml 2>/dev/null)
ifeq ($(OS) $(ARCH),linux x86_64)
-XEN_BUILD=xen-direct-xen
-XEN_DOC=xen-direct-doc
+XEN_BUILD=xen
endif
ifeq ($(NODE),)
NODE_BUILD=
else
-NODE_BUILD=node-socket-node
+NODE_BUILD=node
endif
-all: $(XEN_BUILD) $(NODE_BUILD) unix-socket-unix unix-direct-unix
- @ :
+UNIX_BUILD= unix-direct unix-socket
-doc: $(XEN_DOC) unix-socket-doc unix-direct-doc
+all: $(XEN_BUILD) $(NODE_BUILD) $(UNIX_BUILD)
@ :
-unix-direct-%:
+doc:
+ for spec in $(XEN_BUILD) $(NODE_BUILD) $(UNIX_BUILD); do \
+ SPEC=$$spec ocamlbuild $(OFLOAGS) $(JOBS) doc.otarget; \
+ done
+
+unix-direct:
@mkdir -p _build
- @env MIRAGEOS=unix MIRAGEFLOW=direct MIRAGETARGET=$* ocamlbuild $(OFLAGS) $(JOBS) $*.otarget
+ @env SPEC=unix-direct ocamlbuild $(OFLAGS) $(JOBS) unix.otarget
-unix-socket-%:
+unix-socket:
@mkdir -p _build
- @env MIRAGEOS=unix MIRAGEFLOW=socket MIRAGETARGET=$* ocamlbuild $(OFLAGS) $(JOBS) $*.otarget
+ @env SPEC=unix-socket ocamlbuild $(OFLAGS) $(JOBS) unix.otarget
-xen-direct-%:
+xen:
@mkdir -p _build
- @env MIRAGEOS=xen MIRAGEFLOW=direct MIRAGETARGET=$* ocamlbuild $(OFLAGS) $(JOBS) $*.otarget
+ @env SPEC=xen ocamlbuild $(OFLAGS) $(JOBS) xen.otarget
-node-socket-%:
+node:
@mkdir -p _build
- @env MIRAGEOS=node MIRAGEFLOW=socket MIRAGETARGET=$* ocamlbuild $(OFLAGS) $(JOBS) $*.otarget
+ @env SPEC=node ocamlbuild $(OFLAGS) $(JOBS) node.otarget
clean:
@ocamlbuild -clean
View
2  lib/_tags
@@ -1,2 +1,2 @@
-true: mirage
<std>: include
+true: pa_mirage
View
3  lib/block/direct/_tags
@@ -1,3 +0,0 @@
-true: mirage
-<*.ml>: for-pack(Block)
-"rO.ml": pa_lwt
View
1  lib/block/direct/block.mlpack
@@ -1 +0,0 @@
-RO
View
1  lib/block/direct/block.smlpack
@@ -0,0 +1 @@
+SimpleKV
View
103 lib/block/direct/rO.ml
@@ -1,103 +0,0 @@
-(*
- * Copyright (c) 2011 Anil Madhavapeddy <anil@recoil.org>
- *
- * Permission to use, copy, modify, and distribute this software for any
- * purpose with or without fee is hereby granted, provided that the above
- * copyright notice and this permission notice appear in all copies.
- *
- * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
- * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
- * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
- * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
- * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
- * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
- * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
- *)
-
-(* A simple read-only block filesystem *)
-open Lwt
-open Printf
-
-type file = {
- name: string;
- offset: int64;
- len: int64;
-}
-
-type t = {
- vbd: OS.Blkif.t;
- files: (string, file) Hashtbl.t;
-}
-
-let create vbd =
- let files = Hashtbl.create 7 in
- let rec read_page off =
- lwt page = OS.Blkif.read_page vbd off in
- let rec parse_page num =
- let loff = num * 512 in
- let bs = Bitstring.subbitstring page (loff * 8) (512 * 8) in
- bitmatch bs with
- | { 0xDEADBEEFl:32; offset:64; len:64; namelen:32:bind(Int32.to_int namelen * 8); name:namelen:string } ->
- if Int64.rem offset 512L <> 0L then
- fail (Failure (sprintf "unaligned offset file found: offset=%Lu" offset))
- else begin
- Hashtbl.add files name { name; offset; len };
- printf "Read file: %s %Lu[%Lu]\n%!" name offset len;
- if num = 7 then
- read_page (Int64.add off 8L)
- else
- parse_page (num+1)
- end
- | { _ } -> return ()
- in
- parse_page 0 in
- read_page 0L >>
- return { vbd; files }
-
-exception Error of string
-
-(* Read directly from the disk, no caching *)
-let read t filename =
- try
- let file = Hashtbl.find t.files filename in
- let offset = Int64.div file.offset 512L in
- assert(Int64.rem file.offset 512L = 0L);
- let cur_seg = ref None in
- let pos = ref 0L in
- let rec readfn () =
- (* Check if we have an active segment *)
- match !cur_seg with
- |Some (idx, arr) ->
- (* Traversing an existing segment, so get next in element *)
- let r =
- (* If this is the end of the file, might need to be a partial view *)
- if Int64.add !pos 512L > file.len then begin
- let sz = Int64.sub file.len !pos in
- pos := Int64.add !pos sz;
- cur_seg := None;
- Bitstring.subbitstring arr.(idx) 0 (Int64.to_int sz * 8)
- end else begin
- pos := Int64.add !pos 4096L;
- cur_seg := if idx < Array.length arr - 1 then Some (idx+1, arr) else None;
- arr.(idx)
- end
- in
- return (Some r)
- |None ->
- if !pos >= file.len then begin
- return None (* EOF *)
- end else begin
- (* Need to retrieve more data *)
- (* Assuming a sector size of 512, we can read a maximum of
- 11 * 8 512-byte sectors (44KB=45056b) per scatter-gather request *)
- let need_bytes = min 45056L (Int64.sub file.len !pos) in
- (* Get rounded up number of sectors *)
- let need_sectors = Int64.(div (add need_bytes 511L) 512L) in
- lwt arr = OS.Blkif.read_512 t.vbd (Int64.add offset (Int64.div !pos 512L)) need_sectors in
- cur_seg := Some (0, arr);
- readfn ()
- end
- in
- return (Lwt_stream.from readfn)
- with
- | Not_found -> fail (Error "file not found")
View
141 lib/block/direct/simpleKV.ml
@@ -0,0 +1,141 @@
+(*
+ * Copyright (c) 2011 Anil Madhavapeddy <anil@recoil.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+(* A simple read-only block filesystem *)
+open Lwt
+open Printf
+
+type file = {
+ name: string;
+ offset: int64;
+ len: int64;
+}
+
+let create ~(id:string) ~(vbd:OS.Devices.blkif) : OS.Devices.kv_ro Lwt.t =
+(* printf "SimpleKV.create: creating %s from VBD %s\n%!" id vbd#id; *)
+ (* Attach and parse the index file *)
+ let files = Hashtbl.create 7 in
+ let rec read_page off =
+ lwt page = vbd#read_page off in
+ let rec parse_page num =
+ let loff = num * 512 in
+ let bs = Bitstring.subbitstring page (loff * 8) (512 * 8) in
+ bitmatch bs with
+ | { 0xDEADBEEFl:32; offset:64; len:64; namelen:32:bind(Int32.to_int namelen * 8); name:namelen:string } ->
+ if Int64.rem offset 512L <> 0L then
+ fail (Failure (sprintf "unaligned offset file found: offset=%Lu" offset))
+ else begin
+ Hashtbl.add files name { name; offset; len };
+ (* printf "SimpleKV: %s INIT: Read file: %s %Lu[%Lu]\n%!" id name offset len; *)
+ if num = 7 then
+ read_page (Int64.add off 4096L)
+ else
+ parse_page (num+1)
+ end
+ | { _ } ->
+(* printf "SimpleKV: %s init done (%d files)\n%!" id (Hashtbl.length files); *)
+ return ()
+ in
+ parse_page 0 in
+ read_page 0L >>
+ return (object
+ method iter_s fn =
+ let files = Hashtbl.fold (fun k v a -> k :: a) files [] in
+ Lwt_list.iter_s fn files
+
+ method size name =
+ try return (Some (Hashtbl.find files name).len)
+ with Not_found -> return None
+
+ method read filename =
+ try
+ (* Strip out any leading / character *)
+ let filename =
+ if String.length filename > 0 && filename.[0] = '/' then
+ String.sub filename 1 (String.length filename - 1)
+ else
+ filename
+ in
+ (* printf "SimpleKV.read %s\n%!" filename; *)
+ let file = Hashtbl.find files filename in
+ let pos = ref 0L in
+ (* Return a stream for the file *)
+ return (Some (Lwt_stream.from (fun () ->
+ if !pos < file.len then begin
+ (* Still data to read *)
+ (* printf "SimpleKV.read %s offset=%Lu pos=%Lu %!" filename file.offset !pos; *)
+ lwt p = vbd#read_page (Int64.add file.offset !pos) in
+ match (Int64.add !pos 4096L) < file.len with
+ |true -> (* Read full page *)
+ (* printf "full page\n%!"; *)
+ pos := Int64.add !pos 4096L;
+ return (Some p)
+ |false -> (* EOF, short read *)
+ (* printf "short page\n%!"; *)
+ let p' = Bitstring.subbitstring p 0 ((Int64.to_int (Int64.sub file.len !pos)) * 8) in
+ pos := file.len;
+ return (Some p')
+ end else begin
+ (* printf "SimpleKV.read CLOSE: %s\n%!" filename; *)
+ return None
+ end
+ )))
+ with
+ | Not_found ->
+(* printf "SimpleKV: file %s not found\n%!" filename; *)
+ return None
+ end )
+
+let _ =
+ let plug_mvar = Lwt_mvar.create_empty () in
+ let unplug_mvar = Lwt_mvar.create_empty () in
+ (* KV_RO provider *)
+ let provider = object(self)
+ method id = "Direct.SimpleKV"
+ method plug = plug_mvar
+ method unplug = unplug_mvar
+ method create ~deps ~cfg id =
+ let open OS.Devices in
+ (* One dependency: a Blkif entry to mount *)
+ match deps with
+ |[{node=Blkif vbd} as ent] ->
+(* printf "SimpleKV.provider: %s depends on vbd %s\n%!" id ent.id; *)
+ lwt t = create ~id ~vbd in
+ return OS.Devices.({
+ provider=self;
+ id=self#id;
+ depends=deps;
+ node=KV_RO t
+ })
+ |_ -> raise_lwt (Failure "bad deps")
+ end
+ in
+ OS.Devices.new_provider provider;
+ OS.Main.at_enter (fun () ->
+ let fs = ref [] in
+ lwt env = OS.Env.argv () in
+ Array.iteri (fun i -> function
+ |"-simple_kv_ro" -> begin
+ match Regexp.Re.(split_delim (from_string ":") env.(i+1)) with
+ |[p_id;p_dep_id] ->
+ let p_dep_ids=[p_dep_id] in
+ fs := ({OS.Devices.p_dep_ids; p_cfg=[]; p_id}) :: !fs
+ |_ -> failwith "Direct.SimpleKV: bad -simple_kv_ro flag, must be id:dep_id"
+ end
+ |_ -> ()) env;
+ Lwt_list.iter_s (Lwt_mvar.put plug_mvar) !fs
+ )
+
View
10 lib/block/socket/manager.mli → lib/block/direct/simpleKV.mli
@@ -14,12 +14,4 @@
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
-exception Error of string
-module Unix : sig
- type 'a fd
- type 'a resp = OK of 'a | Err of string | Retry
- external file_open_readonly : string -> [ `ro_file ] fd resp = "caml_file_open_readonly"
- external read : [ `ro_file ] fd -> string -> int -> int -> int resp = "caml_socket_read"
- external close : [ `ro_file ] fd -> unit = "caml_socket_close"
- val iobind : ('a -> 'b resp) -> 'a -> 'b Lwt.t
-end
+val create: id:string -> vbd:OS.Devices.blkif -> OS.Devices.kv_ro Lwt.t
View
1  lib/block/socket/block.mlpack → lib/block/node/block.smlpack
@@ -1,2 +1 @@
Manager
-RO
View
1  lib/block/node/manager.ml
@@ -0,0 +1 @@
+type t
View
3  lib/block/socket/_tags
@@ -1,3 +0,0 @@
-true: mirage
-<*.ml>: for-pack(Block)
-"manager.ml" or "rO.ml": pa_lwt
View
1  lib/block/socket/block.smlpack
@@ -0,0 +1 @@
+SimpleKV
View
113 lib/block/socket/simpleKV.ml
@@ -0,0 +1,113 @@
+(*
+ * Copyright (c) 2011 Anil Madhavapeddy <anil@recoil.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+(** A blocking (so not for heavy use) read-only filesystem interface. *)
+
+open Lwt
+open Printf
+open OS.Socket
+
+(* The state is just the root directory which is mapped through *)
+type t = {
+ id: string;
+ root: string;
+}
+
+let create ~id ~root =
+ return (object
+ method read filename =
+ let fullname = sprintf "%s/%s" root filename in
+ (* Open the FD using the manager bindings *)
+ match file_open_readonly fullname with
+ | Err x -> return None
+ | Retry -> assert false
+ | OK fd ->
+ (* Construct a stream that reads pages of istrings *)
+ return (Some (Lwt_stream.from (fun () ->
+ let str = String.create 4096 in
+ lwt len = iobind (fun fd -> OS.Socket.read fd str 0 4096) fd in
+ match len with
+ | 0 -> close fd; return None
+ | len -> return (Some (str, 0, len*8))
+ )))
+
+ method iter_s fn =
+ match opendir root with
+ | Err x -> fail (Failure x)
+ | Retry -> assert false
+ | OK dir -> begin
+ let rec loop () =
+ match readdir dir with
+ |Err x -> return ()
+ |Retry -> loop ()
+ |OK fname -> fn fname >>= loop
+ in
+ try_lwt
+ loop ()
+ finally (match closedir dir with
+ | Err x -> fail (Error x)
+ | OK () -> return ()
+ | Retry -> assert false)
+ end
+
+ method size filename =
+ let fullname = sprintf "%s/%s" root filename in
+ match file_size fullname with
+ | Err x -> return None
+ | Retry -> assert false
+ | OK sz -> return (Some sz)
+ end)
+
+let _ =
+ let plug_mvar = Lwt_mvar.create_empty () in
+ let unplug_mvar = Lwt_mvar.create_empty () in
+ (* KV_RO provider *)
+ let provider = object(self)
+ method id = "RO.Socket"
+ method plug = plug_mvar
+ method unplug = unplug_mvar
+ method create ~deps ~cfg id =
+ (* Configuration key "root" defines where to map the K/V filesystem *)
+ lwt root =
+ try
+ return (List.assoc "root" cfg)
+ with Not_found ->
+ raise_lwt (Failure "RO.socket: 'root' configuration key not found")
+ in
+ lwt t = create ~id ~root in
+ return OS.Devices.({
+ provider=self;
+ id=self#id;
+ depends=[];
+ node=KV_RO t })
+ end
+ in
+ OS.Devices.new_provider provider;
+ OS.Main.at_enter (fun () ->
+ let fs = ref [] in
+ lwt env = OS.Env.argv () in
+ Array.iteri (fun i -> function
+ |"-simple_kv_ro" -> begin
+ match Regexp.Re.(split_delim (from_string ":") env.(i+1)) with
+ |[p_id;root] ->
+ let p_cfg = ["root",root] in
+ fs := ({OS.Devices.p_dep_ids=[]; p_cfg; p_id}) :: !fs
+ |_ -> failwith "Socket.RO: bad -simple_kv_ro flag, must be id:root_dir"
+ end
+ |_ -> ()) env;
+ Lwt_list.iter_s (Lwt_mvar.put plug_mvar) !fs
+ )
+
View
17 lib/block/socket/simpleKV.mli
@@ -0,0 +1,17 @@
+(*
+ * Copyright (c) 2011 Anil Madhavapeddy <anil@recoil.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+val create : id:string -> root:string -> OS.Devices.kv_ro Lwt.t
View
3  lib/cow/_tags
@@ -1,3 +0,0 @@
-true: mirage,pa_cow
-"twitter.ml": pa_lwt
-<*.cmx>: for-pack(Cow)
View
0  lib/cow/cow.mlpack → lib/cow/cow.smlpack
File renamed without changes
View
2  lib/debugger/lib/_tags
@@ -1,2 +0,0 @@
-true: mirage
-<*.cmx>: for-pack(Debugger)
View
4 lib/debugger/lib/debugger.mlpack
@@ -1,4 +0,0 @@
-Static
-Server
-Style
-Event
View
123 lib/debugger/lib/event.ml
@@ -1,123 +0,0 @@
-(*
- * Copyright (C) 2010 Thomas Gazagnaire <thomas@gazagnaire.org>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-open Cow
-
-type level =
- [ `debug
- | `warn
- | `info
- | `error ]
-with json
-
-type t = {
- date : string;
- id : int;
- level : level;
- section : string;
- message : string;
- backtrace : string option;
-} with json
-
-let default = {
- date = "<not set>";
- id = 0;
- level = `error;
- section = "<not set>";
- message = "<not set>";
- backtrace = None;
-}
-
-let css = <:css<
- .date, .section, .message, .id {
- display: inline;
- padding-left: 1em;
- }
- .section {
- color: white;
- font-style: italic;
- }
- .debug {
- background-color: blue;
- }
- .warn {
- background-color: orange;
- }
- .info {
- background-color: green;
- }
- .error {
- background-color: red;
- }
- .message {
- color: white;
- }
- div[class="info"] {
- display: none;
- }
- input:checked + div[class="info"] {
- display: block;
- }
->>
-
-type ring = {
- mutable init : int;
- mutable current : int;
- size : int;
- content : t array;
-}
-
-let make size = {
- init = 0;
- current = 0;
- size = size;
- content = Array.create size default;
-}
-
-let get r i =
- r.content.(i mod r.size)
-
-let push r t =
- if (r.current + 1) mod r.size = r.init then
- (* The ring is full, need to overwrite it *)
- r.init <- (r.init + 1) mod r.size;
- r.content.(r.current) <- t;
- r.current <- (r.current + 1) mod r.size
-
-let state = make 128
-
-let stream last_id =
- let init = match last_id with
- | None -> state.init
- | Some id -> max (id+1) state.init in
- let accu = ref [] in
- for i = init to state.current - 1 do
- let str = Printf.sprintf "id: %d\ndata: %s\n" i (Json.to_string (json_of_t (get state i))) in
- accu := str :: !accu
- done;
- String.concat "\n" (List.rev !accu)
-
-let logger ~date ~id ~level ~section ?backtrace ~message =
- let t = {
- date;
- id;
- level;
- section;
- message;
- backtrace;
- } in
- push state t
-
-let () =
- Log.add_logger "remote JavaScript debugger" logger
View
62 lib/debugger/lib/server.ml
@@ -1,62 +0,0 @@
-(*
- * Copyright (C) 2010 Thomas Gazagnaire <thomas@gazagnaire.org>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-open Lwt
-open Cow
-open Net.Http.Daemon
-open Net.Http.Request
-
-let section = "Debugger.Server"
-
-(* handle exceptions with a 500 *)
-let exn_handler exn =
- let body = Printexc.to_string exn in
- Log.error section "ERROR: %s" body;
- return ()
-
-(* main callback function *)
-let dispatch conn_id req =
- let req_path = path req in
- let req_path = if req_path = "/" || req_path = "" then "index.html" else req_path in
- let path_elem = Str.split (Str.regexp_string "/") req_path in
- let dyn ?(headers=[]) req body =
- let status = `OK in
- respond ~body ~headers ~status () in
- match Static.t req_path with
- | Some body -> respond ~body ()
- | None ->
- match path_elem with
- | ["events"] ->
- let last_id =
- try Some (int_of_string (List.hd (header req ~name:"last-event-id")))
- with _ -> None in
- let headers = ["content-type","text/event-stream"] in
- dyn ~headers req (Event.stream last_id)
- | x -> (respond_not_found ~url:(path req) ())
-
-let spec = {
- address = "0.0.0.0";
- auth = `None;
- callback = dispatch;
- conn_closed = (fun _ -> ());
- port = 8081;
- exn_handler = exn_handler;
- timeout = Some 300.;
-}
-
-let _ =
- OS.Main.set_control_thread (
- Log.info section "listening to HTTP on port %d" spec.port;
- main spec
- )
View
20 lib/debugger/lib/style.ml
@@ -1,20 +0,0 @@
-(*
- * Copyright (C) 2010 Thomas Gazagnaire <thomas@gazagnaire.org>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-open Cow
-
-let main = Css.to_string <:css<
- $Css.reset_padding$;
- $Event.css$;
->>
View
126 lib/debugger/myocamlbuild.ml
@@ -1,126 +0,0 @@
-open Ocamlbuild_plugin
-open Command
-
-let sf = Printf.sprintf
-
-(* Utility functions (e.g. to execute a command and return lines read) *)
-module Util = struct
- let split s ch =
- let x = ref [] in
- let rec go s =
- let pos = String.index s ch in
- x := (String.before s pos)::!x;
- go (String.after s (pos + 1))
- in
- try
- go s
- with Not_found ->
- List.rev !x
-
- let split_nl s = split s '\n'
-
- let run_and_read x = split_nl (Ocamlbuild_pack.My_unix.run_and_read x)
-
- let get_lib lib =
- try
- sf "%s/%s" (Sys.getenv "MIRAGELIB") lib
- with Not_found ->
- sf "../../%s/_build" lib
-end
-
-let std_lib =
- Util.get_lib "std" ^ "/lib"
-
-let std_syntax =
- Util.get_lib "std" ^ "/syntax"
-
-let dyntype_lib =
- Util.get_lib "dyntype" ^ "/lib"
-
-let dyntype_syntax =
- Util.get_lib "dyntype" ^ "/syntax"
-
-let os_lib =
- let os = try Sys.getenv "MIRAGEOS" with Not_found -> "unix" in
- Util.get_lib "os" ^ (sf "/%s" os)
-
-let os_runtime_lib =
- let os = try Sys.getenv "MIRAGEOS" with Not_found -> "unix" in
- Util.get_lib "os" ^ (sf "/runtime_%s" os)
-
-let net_lib =
- let os = try Sys.getenv "MIRAGEOS" with Not_found -> "unix" in
- sf "%s/%s" (Util.get_lib "net") os
-
-let cow_syntax =
- Util.get_lib "cow" ^ "/syntax"
-
-let cow_lib =
- Util.get_lib "cow" ^ "/lib"
-
-let caml_lib =
- List.hd (Util.run_and_read "ocamlc -where")
-
-module Flags = struct
-
- let camlp4_magic =
- "-parser Camlp4QuotationCommon -parser Camlp4OCamlRevisedQuotationExpander"
-
- let pa_dyntype_deps =
- sf "-I +camlp4 %s -I %s pa_type_conv.cmo dyntype.cmo pa_dyntype.cmo" camlp4_magic dyntype_syntax
-
- let pa_ulex_deps =
- sf "-I %s pa_ulex.cma" std_syntax
-
- let pa_lwt_deps =
- sf "-I %s pa_lwt.cma" std_syntax
-
- let pa_cow_deps =
- sf "%s %s %s -I %s str.cma pa_cow.cmo" pa_ulex_deps pa_lwt_deps pa_dyntype_deps cow_syntax
-
- let camlp4 deps = [
- A"-pp"; A (sf "camlp4o %s" deps)
- ]
-
- let pa_cow = [
- A"-I"; A"+camlp4";
- ] @ camlp4 pa_cow_deps
-
- let stdlib = [ A"-nostdlib"; A"-I"; A std_lib; ]
- let dyntype = [ A"-I"; A dyntype_lib ]
- let ulex = [ A"-I"; A std_lib ]
- let cow = [ A"-I"; A cow_lib ]
- let os = [ A"-I"; A os_lib ]
- let net = [ A"-I"; A net_lib ]
-
- let all =
- stdlib @ dyntype @ ulex @ os @ net @ cow
-end
-
-module Expand = struct
- let camlp4o tags arg out =
- Cmd (S [A"camlp4o"; A"-printer"; A"o"; T(tags++"ocaml"++"camlp4"++"pa_exp"); P arg; Sh">"; Px out])
-
- let camlp4o_expand ml exp_ml env build =
- let ml = env ml and exp_ml = env exp_ml in
- let tags = tags_of_pathname ml in
- camlp4o tags ml exp_ml
-
- let () =
- rule "expand: ml -> _exp.ml"
- ~prod:"%_exp.ml"
- ~dep:"%.ml"
- (camlp4o_expand "%.ml" "%_exp.ml");
-end
-
-let _ = dispatch begin function
- | After_rules ->
-
- (* use pa_cow syntax extension if the _tags file specifies it *)
- flag ["ocaml"; "compile" ] & S (Flags.pa_cow @ Flags.all);
- flag ["ocaml"; "ocamldep"] & S Flags.pa_cow;
- flag ["ocaml"; "camlp4" ] & Sh Flags.pa_cow_deps;
-
- | _ -> ()
-end
-
View
13 lib/debugger/static/index.html
@@ -1,13 +0,0 @@
-<html xmlns="http://www.w3.org/1999/xhtml">
-
-<head>
- <meta http-equiv="Content-Type" content="text/html;charset=utf-8"/>
- <title>mirage :: remote debugger</title>
-</head>
-
-<body>
- <script type="text/javascript" src="/uki.js"></script>
- <script type="text/javascript" src="/index.js"></script>
-</body>
-
-</html>
View
97 lib/debugger/static/index.js
@@ -1,97 +0,0 @@
-// index -> connection
-var index = [];
-
-// connection -> log events table
-var events = [];
-
-uki({
- view: 'HSplitPane',
- rect: '0 0 1200 1000',
- anchors: 'left top right bottom',
- handlePosition: 200,
- leftMin: 200,
- rightMin: 300,
-
- leftChildViews: {
- view: 'List',
- id: 'left',
- rect: '0 0 200 1000',
- anchors: 'left top',
- data: [],
- textSelectable: false },
-
- rightChildViews: {
- view: 'Table',
- id : 'right',
- rect: '0 0 1000 1000',
- anchors: 'left top',
- columns: [
- { view: 'table.CustomColumn', label: 'Date', resizable: true, width: 150, sort: 'ASC' },
- { view: 'table.CustomColumn', label: 'Level', resizable: true, width: 50 },
- { view: 'table.CustomColumn', label: 'Section', resizable: true, width: 200 },
- { view: 'table.CustomColumn', label: 'Message', resizable: true, width: 600 } ],
- style: {fontSize: '11px', lineHeight: '11px'},
- textSelectable: false,
- data: [] },
-
-}).attachTo( window, '1000 1000' );
-
-// click on header should order the table
-uki('#right').find('Header').bind('columnClick', function(e) {
- var header = this;
-
- if (e.column.sort() == 'ASC')
- e.column.sort('DESC');
- else
- e.column.sort('ASC');
-
- header.redrawColumn(e.columnIndex);
- uki.each(header.columns(), function(i, col) {
- if (col != e.column && col.sort()) {
- col.sort('');
- header.redrawColumn(i);
- }
- });
- uki('#right').data(e.column.sortData(uki('#right').data()));
-})
-
-
-function update_right(i) {
- uki('#right').data(events[index[i]]);
-}
-
-// click on the left column should update the right panel
-uki('#left').bind('click', function () { update_right(this.lastClickIndex()); });
-
-function update_left() {
- var cons = [];
- for (var c in events)
- cons.push('Connection '+ c);
- uki('#left').data(cons);
-}
-
-function add_event (data) {
- var json = JSON.parse(data);
- raw_data = [ json.date, json.level, json.section, json.message ];
- if (events[json.id] == undefined) {
- index.push(json.id);
- events[json.id] = [raw_data];
- } else {
- events[json.id].push(raw_data);
- };
- update_left();
-}
-
-document.addEventListener('DOMContentLoaded', function () {
- var eventSrc = new EventSource('/events');
-
- eventSrc.addEventListener('open', function (event) {
- console.log(event.type);
- });
-
- eventSrc.addEventListener('message', function (event) {
- console.log(event.type);
- add_event(event.data);
- });
-
-}, false);
View
232 lib/debugger/static/uki.js
0 additions, 232 deletions not shown
View
4 lib/dns/_tags
@@ -1,4 +0,0 @@
-true: mirage
-<**/*.ml> : annot
-<*.ml>: pa_lwt
-<*.cmx> and not "dns.cmx": for-pack(Dns)
View
0  lib/dns/dns.mlpack → lib/dns/dns.smlpack
File renamed without changes
View
1  lib/dyntype/_tags
@@ -1 +0,0 @@
-true: mirage
View
21 lib/fs/Makefile
@@ -0,0 +1,21 @@
+OCAMLC = ocamlfind ocamlc
+OCAMLOPT = ocamlfind ocamlopt
+OCAMLFLAGS = -annot -g
+
+PACKS = bitstring
+
+.PHONY: all clean
+all: fat.opt
+
+fat.opt: fat_utils.cmx fat.cmx fat_shell.cmx
+ $(OCAMLOPT) -linkpkg -package $(PACKS) -o $@ fat_utils.cmx fat.cmx fat_shell.cmx
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLFLAGS) -package $(PACKS),bitstring.syntax -syntax camlp4o -c -o $@ $<
+
+%_gen: %.ml
+ camlp4o $(shell ocamlfind query bitstring.syntax -r -format "-I %d %a" -predicates syntax,preprocessor) $< -printer o > $@.ml
+ $(OCAMLOPT) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $@.ml
+
+clean:
+ rm -f *.cmx *.cmi *.cmo *.cmxa *.o $(EXECS)
View
1,332 lib/fs/fat.ml
@@ -0,0 +1,1332 @@
+(*
+ * Copyright (c) 2011 Citrix Systems
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+(* This contains the FAT-specific library stuff *)
+
+(** Instances of SectorMap will map virtual sectors within a file to physical
+ sector numbers on disk *)
+module SectorMap = struct
+ include Map.Make(struct type t = int let compare = compare end)
+
+ let make sectors =
+ fst (List.fold_left (fun (m, i) o -> add i o m, i + 1) (empty,0) sectors)
+
+ (** [find x sector] returns the physical address on disk corresponding to the
+ virtual sector [sector] according to SectorMap [x] *)
+ let find (x: int t) sector =
+ if not (mem sector x) then failwith "fault";
+ find sector x
+
+ (** [transform_offset x sector_size vaddr] returns the physical address on disk
+ corresponding to virtual address [vaddr] according to SectorMap [x] *)
+ let transform_offset (x: int t) sector_size vaddr =
+ let s = Int64.of_int sector_size in
+ let vsector = Int64.(div vaddr s) in
+ let psector = find x (Int64.to_int vsector) in
+ let voffset = Int64.(sub vaddr (mul vsector s)) in
+ Int64.(add voffset (mul (of_int psector) s))
+end
+
+module Update = struct
+ type t = { offset: int64; data: Bitstring.t }
+
+ let to_string x = Printf.sprintf "Update[offset=%Ld length=%d]" x.offset (Bitstring.bitstring_length x.data / 8)
+
+ let hexdump x = Printf.printf "%s:\n%!" (to_string x); Bitstring.hexdump_bitstring stdout x.data
+
+ let make offset data = { offset = offset; data = data }
+ let move offset x = { x with offset = Int64.add x.offset offset }
+
+ (** [total_length x] returns the minimum size of the buffer needed to apply this update. *)
+ let total_length x = Int64.add x.offset (Int64.of_int (Bitstring.bitstring_length x.data / 8))
+
+ let apply bs x =
+ let result = Bitstring.bitstring_of_string (Bitstring.string_of_bitstring bs) in
+ Bitstring.bitstring_write x.data (Int64.to_int x.offset) result;
+ result
+
+ (** [clip x offset length] returns the fraction of the update between
+ [offset] and [offset+length] in bytes *)
+ let clip x offset length =
+ let new_offset = max x.offset offset in
+ let drop_bytes_from_start = Int64.(to_int(sub new_offset x.offset)) in
+ let original_end = Int64.(add x.offset (of_int (Bitstring.bitstring_length x.data * 8))) in
+ let proposed_end = Int64.(add offset (of_int length)) in
+ let new_end = min original_end proposed_end in
+ let new_length = Int64.(to_int(sub new_end new_offset)) in
+ { offset = new_offset; data = Bitstring.bitstring_clip x.data (8 * drop_bytes_from_start) (8 * new_length) }
+
+ let is_empty x = Bitstring.equals Bitstring.empty_bitstring x.data
+
+ (** [split x sector_size] returns [x] as a sequence of consecutive updates,
+ each of which corresponds to a region of length [sector_size]. Note empty
+ updates are omitted. *)
+ let split x sector_size =
+ let rec inner acc start =
+ if Int64.(add x.offset (mul 8L (of_int (Bitstring.bitstring_length x.data)))) <= start
+ then List.rev acc
+ else
+ let this = clip x start sector_size in
+ let new_start = Int64.(add start (of_int sector_size)) in
+ inner (if is_empty this then acc else this :: acc) new_start in
+ inner [] 0L
+
+ (** [map_updates xs offsets] takes a sequence of virtual sector updates (eg within the
+ virtual address space of a file) and a sequence of physical offsets (eg the
+ location of physical sectors on disk) and returns a sequence of physical
+ sector updates. *)
+ let map_updates xs sectors sector_size =
+ let m = SectorMap.make sectors in
+ List.map (fun x -> { x with offset = SectorMap.transform_offset m sector_size x.offset}) xs
+end
+
+type format = FAT12 | FAT16 | FAT32
+let string_of_format = function
+ | FAT12 -> "FAT12"
+ | FAT16 -> "FAT16"
+ | FAT32 -> "FAT32"
+
+module Boot_sector = struct
+ type t = {
+ oem_name: string;
+ bytes_per_sector: int;
+ sectors_per_cluster: int;
+ reserved_sectors: int;
+ number_of_fats: int;
+ number_of_root_dir_entries: int;
+ total_sectors: int32;
+ sectors_per_fat: int;
+ hidden_preceeding_sectors: int32;
+ }
+ let of_bitstring bits =
+ bitmatch bits with
+ | { _: 24: string; (* JMP instruction *)