1. camlspotter
  2. ocaml-llvm-phantom

Commits

camlspotter  committed 7416f05

preparation for oasis

  • Participants
  • Parent commits 0ff8931
  • Branches default

Comments (0)

Files changed (62)

File OMakefile

View file
  • Ignore whitespace
+# How-to-build using OMake
+#
+# yes no | omake --install # to create OMakeroot for the first time
+
 # If OMakeroot is here, include OMyMakefile
 if $(file-exists OMakeroot)
    include OMyMakefile
    export
 
-.PHONY: all install clean
-
 OCAMLINCLUDES +=
 
 OCAMLFLAGS    += -annot -w Ae
 OCAML_BYTE_LINK_FLAGS +=
 OCAML_NATIVE_LINK_FLAGS +=
 
-CAMLP4PACKS[]=
-    monad
-
-OCAMLPACKS[]= 
-    spotlib
-    llvm
-
-OCAML_PREINSTALLED_PACKS += llvm
-
-OCAMLDEPFLAGS= -syntax camlp4o -package monad
-OCAMLPPFLAGS= -syntax camlp4o -package monad
-
-FILES[] =
-   extension
-   context
-   type_intf
-   type
-   type_ctxt
-   value_intf
-   value
-   gep
-   value_ctxt
-   module_intf
-   module
-   build_intf
-   build
-   wrap_intf
-   wrap
-   genvalue
-   std
-
-OCAML_LIBS +=
-OCAML_CLIBS +=
-OCAML_OTHER_LIBS +=
-OCAML_LIB_FLAGS +=
-
-MyOCamlPackage(llvm_phantom, $(FILES), $(EMPTY), $(EMPTY))
-
-printer: printer.ml
-    ocamlfind ocamlc -linkpkg -package spotlib -o printer printer.ml
-
 Subdirs()

File OMyMakefile

View file
  • Ignore whitespace
+# ==========================
+# OMyMakefile
+# ==========================
+# Useful functions to build OCaml projects
+
+#| A flag to tell that we can use OMyMakefile functions
+WithOMy=true
+
+.PHONY: all install uninstall clean
+
+# Directories
+# =====================================================================
+
+#| The build root directory  
+BIG_ROOT=$(dir .)
+
+# Installation mark files
+# =======================================================================
+
+#| To enable the installation mark files, you must define INSTALLED path variable
+# for the mark file directory like INSTALLED=$(BIG_ROOT)/installed and make sure
+# the directory $(INSTALLED) exists. This preparation must be done outside of 
+# this OMyMakefile.
+
+#|Returns the installation mark files of $(packs)
+Installed(packs) = 
+  if $(defined INSTALLED)
+      return $(addprefix $(INSTALLED)/, $(packs))
+  else
+      return $(array)
+
+#|Create md5 sum file of $(targets)
+CreateCheckSum(pack, targets)=
+    chan=$(fopen $(pack), w)
+    fprintln($(chan), $(string $(targets)))
+    fprintln($(chan), $(string $(digest $(targets))))
+    close($(chan))
+
+#|Create $(Installed $(pack)) file from the digests of $(targets)
+CreateInstalled(pack, targets)=
+    if $(defined INSTALLED)
+        println(dump md5 $(INSTALLED)/$(pack))
+        CreateCheckSum($(INSTALLED)/$(pack), $(targets))
+
+# Misc tools
+# ======================================================================
+
+#|ditto.
+mkdir_if_not_exists(dir) =
+  if $(not $(test -e $(dir))):
+    mkdir $(dir) 
+  return
+
+# OCamlFind
+# ========================================================================
+
+#|OMy requires OCamlFind! Do not ask me how to use OMy without OCamlFind. Please.
+USE_OCAMLFIND = true
+OCAMLFIND_DESTDIR= $(shell ocamlfind printconf destdir)
+
+# OCaml -where
+# ========================================================================
+
+#|Path to the OCaml library directory
+OCAML_WHERE = $(shell ocamlc -where)
+
+#|Preinstalled libraries which are always available for normal ocaml.
+#
+# You may want to add the required packages which are built and installed out of OMy framework:
+#
+#::
+#
+#   include OMyMakefile
+#   
+#   OCAML_PREINSTALLED_PACKS += llvm # llvm has been installed already, independently
+#   
+#   Subdirs()
+#
+# It includes "findlib" by default. If you want to build findlib in OMy framework, you have to remove it from the list.
+OCAML_PREINSTALLED_PACKS[]= bigarray camlp4 dbm dynlink graphics num num-top stdlib str threads unix findlib
+
+# byte/nat
+NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
+#|If set false in a project directory, byte compilation is disabled there.
+BYTE_ENABLED = true
+
+######################### Compiler
+OCAMLPACKAGEFLAGS=
+
+# Why we need "public." ?
+public.OCamlC() =
+    value $(OCAMLFIND) $(OCAMLC) $(OCAMLPACKAGEFLAGS) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS)\
+              $(OCAMLCFLAGS) $(OCAMLPPFLAGS) $(PREFIXED_OCAMLINCLUDES)
+
+public.OCamlOpt() =
+    value $(OCAMLFIND) $(OCAMLOPT) $(OCAMLPACKAGEFLAGS) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS)\
+              $(OCAMLOPTFLAGS) $(OCAMLPPFLAGS) $(PREFIXED_OCAMLINCLUDES)
+
+# Spot files (OCamlSpotter)
+# ==================================================================
+
+#| OCAML_SPOT is true if the compiler supports ocamlspot
+OCAML_SPOT = false
+match $(string $(shell ocamlc -version)) # We cannot use OCamlC since there may not be ocamlfind
+case $"ocamlspot"
+  OCAML_SPOT = true 
+  export
+
+#| Define OCAML_ANNOT so that custom ocamlc/ocamlopt automatically create spot/spit/annot files, even without -annot option.
+setenv(OCAML_ANNOT, 1)
+
+# Additional implicit rules by file extensions
+
+# annot, spot, spit files
+%.annot %.spot: %.ml %.cmi
+	$(OCamlC) -c $<
+
+%.spit: %.mli 
+	$(OCamlC) -c $<
+
+# Packages
+# =========================================================
+
+#| OCaml packages required for compilation. MyCaml* functions automatically add necessary dependencies over packages in $(OCAMLPACKS).
+# 
+# .. note:: They are also required for dependency analysis.
+public.OCAMLPACKS[]=
+
+#| CamlP4 syntax extension packages required for parsing. MyCaml* functions automatically add necessary dependencies over packages in $(CAMLP4PACKS).
+public.CAMLP4PACKS[]=
+
+# Dependencies
+# =========================================================================
+
+#|Returns packages managed by OMy framework
+OMyManagedPackages(packages) =
+   return $(set-diff $(packages), $(OCAML_PREINSTALLED_PACKS))
+
+#|Add dependencies of any build activity of this directory over $(files).
+#
+# .. note:: These functions introduce implicit rules: *you may need to export it, if you use this function in a local context.*
+RequireFiles(files) =
+    .SCANNER: scan-%: $(files)
+    % : $(files)
+    export
+
+#|Add dependencies of any build activity over $(packages).
+#
+# .. note:: These functions introduce implicit rules: *you may need to export it, if you use this function in a local context.*
+RequirePackages(packages) =
+    RequireFiles($(OMyManagedPackages $(packages)))
+    export
+
+#|Add dependencies of any build activity of this directory over $(targets) and their dependencies
+# Creates an intermidiate md5 memo dependencies.md5
+#
+# .. note:: These functions introduce implicit rules: *you may need to export it, if you use this function in a local context.*
+RequireBuild(targets) =
+    dependencies.md5: $(targets)
+        CreateCheckSum($@, $(sequence-sort $(compare), $(dependencies-all $(targets))))
+    RequireFiles(dependencies.md5)
+    export
+
+#|Add dependencies of OCaml compiled files (cmx, cmo, etc.) over $(packages).
+# $(packages) listed in OCAML_PREINSTALLED_PACKS are ignored.
+#
+# .. note:: These functions introduce implicit rules: *you may need to export it, if you use this function in a local context.*
+#
+# .. note:: Usually you do not need to call this function. Use OCAMLPACKS variable instead. 
+OCamlRequirePackages(packages) =
+    packages += findlib # Yes we use findlib
+    required_packs = $(OMyManagedPackages $(packages))
+    if $(defined INSTALLED)
+      %.cmx %.cmo %.cmi %.cma %.cmxa %.annot %.spot %.spit : $(Installed $(required_packs))
+      export
+    export
+
+#|Add dependencies of OCaml dependency analysis and build over $(packages).
+# Use this for adding dependencies for CamlP4 extensions.
+# $(packages) listed in OCAML_PREINSTALLED_PACKS are ignored.
+#
+# .. note:: These functions introduce implicit rules: *you may need to export it, if you use this function in a local context.*
+#
+# .. note:: Usually you do not need to call this function. Use CAML4PACKS variable instead. 
+OCamlRequireCamlP4Packages(packages) =
+    packages += findlib # Yes we use findlib
+    required_packs = $(OMyManagedPackages $(packages))
+    if $(defined INSTALLED)
+      .SCANNER: scan-ocaml-%: $(Installed $(required_packs))
+      %.cmx %.cmo %.cmi %.cma %.cmxa %.annot %.spot %.spit : $(Installed $(required_packs))
+      export 
+    export
+
+#|``omake xxx.auto.mli`` generates .mli file from xxx.ml 
+%.auto.mli: %.ml
+	$(OCamlC) -i -c $< > $@
+
+# Build rules
+# ==========================================================
+
+# Extend the bundled OCamlPackage with .spot creation
+public.OCamlPackage(name, files) =
+   # XXX: JYH: these variables should be marked private in 0.9.9
+   protected.OFILES   = $(addsuffix $(EXT_OBJ), $(files))
+   protected.CMOFILES = $(addsuffix .cmo, $(files))
+   protected.CMXFILES = $(addsuffix .cmx, $(files))
+
+   protected.OBJ       = $(file $(name)$(EXT_OBJ))
+   protected.CMO       = $(file $(name).cmo)
+   protected.CMX       = $(file $(name).cmx)
+   protected.CMI       = $(file $(name).cmi)
+   protected.MLI       = $(file $(name).mli)
+
+   protected.BYTE_TARGETS   = $(CMO)
+   protected.NATIVE_TARGETS = $(CMX) $(OBJ)
+
+   if $(OCAML_SPOT)
+       if $(BYTE_ENABLED)
+          BYTE_TARGETS += $(file $(name).spot)
+          export
+       else
+          NATIVE_TARGETS += $(file $(name).spot)
+          export
+       export
+
+   protected.TARGETS = $(CMI)
+   if $(NATIVE_ENABLED)
+       TARGETS += $(NATIVE_TARGETS)
+       export
+
+   if $(BYTE_ENABLED)
+       TARGETS += $(BYTE_TARGETS)
+       export
+
+   #
+   # Link commands
+   #
+   protected.BYTE_DEPS = $(CMOFILES)
+   $(BYTE_TARGETS): $(CMOFILES)
+      section rule
+         if $(or $(NATIVE_ENABLED), $(target-exists $(MLI)))
+             BYTE_DEPS += $(CMI)
+             export
+         else
+             BYTE_TARGETS += $(CMI)
+             export
+         $(BYTE_TARGETS): $(BYTE_DEPS)
+            $(OCAMLFIND) $(OCAMLC) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) \
+                $(OCAMLCFLAGS) $(OCAML_LIB_FLAGS) -pack -o $(CMO) $(OCamlLinkSort $(CMOFILES))
+
+   protected.NATIVE_DEPS = $(CMXFILES) $(OFILES)
+   $(NATIVE_TARGETS): $(NATIVE_DEPS)
+      section rule
+         if $(target-exists $(MLI))
+            NATIVE_DEPS += $(CMI)
+            export
+         else
+            NATIVE_TARGETS += $(CMI)
+            export
+         $(NATIVE_TARGETS): $(NATIVE_DEPS)
+            $(OCAMLFIND) $(OCAMLOPTLINK) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) \
+                $(OCAMLOPTFLAGS) $(OCAML_LIB_FLAGS) -pack -o $(CMX) $(OCamlLinkSort $(CMXFILES))
+
+   $(CMI):
+      section rule
+         if $(target-exists $(MLI))
+            $(CMI): $(MLI) :scanner: scan-ocaml-$(name).mli
+                $(OCamlC) -c $<
+         elseif $(NATIVE_ENABLED)
+            $(NATIVE_TARGETS) $(CMI): $(NATIVE_DEPS)
+               $(OCAMLFIND) $(OCAMLOPTLINK) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) \
+                   $(OCAMLOPTFLAGS) $(OCAML_LIB_FLAGS) -pack -o $(CMX) $(OCamlLinkSort $(CMXFILES))
+         else
+            $(BYTE_TARGETS) $(CMI): $(BYTE_DEPS)
+               $(OCAMLFIND) $(OCAMLC) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) \
+                   $(OCAMLCFLAGS) $(OCAML_LIB_FLAGS) -pack -o $(CMO) $(OCamlLinkSort $(CMOFILES))
+
+   return $(TARGETS)
+
+# Add implicit dependencies over the packages declared in OCAMLPACKS and CAMLP4PACKS
+# If this function is used in a local scope, you may want to export. 
+AddLocalOCamlPackageDependencies() =
+  # We make sure the required libraries are installed
+  OCamlRequirePackages($(OCAMLPACKS)) # must be exported!
+  OCamlRequireCamlP4Packages($(OCAMLPACKS) $(CAMLP4PACKS))
+  export
+
+#| Add a rule for OCaml package $(library_name).cmo, $(library_name).cmx and etc.
+#     library_name
+#         target package name
+#     files
+#         ML module names (without .ml)
+#     cmodules
+#         C source files (without .c)
+#     linkopts
+#         C library link option (without OCaml -cclib options)    
+#
+#  Example::
+#
+#      MyOCamlPackage(foo, alpha beta, $(EMPTY), $(EMPTY))
+#
+#  Todo: external C library
+MyOCamlPackage(library_name, files, cmodules, linkopts) =
+  AddLocalOCamlPackageDependencies()
+  export # The above thing is local: need to be exported
+
+  CSTUBS=$(addsuffix .o,$(cmodules))
+  CMOS=$(addsuffix .cmo,$(library_name))
+  CMXS=$(addsuffix .cmx,$(library_name))
+  CMA=$(library_name).cma
+  CMXA=$(library_name).cmxa
+
+  CSTUBLIBRARIES=
+  if $(not $(equal $(cmodules), $(EMPTY)))
+      CSTUBLIBRARIES= dll$(library_name).so lib$(library_name).a 
+      export
+
+  # CR jfuruse: I guess we do not need the following
+  # export # export the implicit rule above
+
+  .DEFAULT: $(library_name).cmo $(library_name).cmx $(library_name).cma $(library_name).cmxa
+
+  $(CMA) $(CMXA) $(library_name).a $(CSTUBLIBRARIES) : $(CSTUBS) $(CMOS) $(CMXS)
+      ocamlmklib -verbose -o $(library_name) $(CSTUBS) $(linkopts) $(CMOS) $(CMXS)
+
+  ## the followings are necessary for packing
+
+  OCAMLPACKAGEFLAGS += -for-pack $(capitalize $(library_name))
+  export OCAMLPACKAGEFLAGS
+
+  ## build rule
+
+  OCamlPackage($(library_name), $(files))
+
+  ## clean
+  AutoClean()
+  clean:
+	rm -f $(library_name).spot
+
+  ## install
+
+  # CR jfuruse: x.cmi is required if x.mli does not exist!
+  targets[]=META $(glob i, *.mli) $(library_name).cmi $(library_name).cmo $(library_name).cmx $(library_name).cma $(library_name).cmxa $(library_name).o $(library_name).a $(CSTUBLIBRARIES)
+
+  if $(OCAML_SPOT)
+    targets[]+= $(library_name).spot
+
+  if $(defined INSTALLED)
+    $(Installed $(library_name)): $(targets)
+	$(OCAMLFIND) remove $(library_name)
+	section:
+            $(OCAMLFIND) install $(library_name) $(targets)
+            CreateInstalled($(library_name), $(targets))
+
+    install: $(Installed $(library_name))
+
+    uninstall:
+	rm -f $(Installed $(library_name))
+	$(OCAMLFIND) remove $(library_name)
+
+    export
+  else
+    install:
+	$(OCAMLFIND) remove $(library_name)
+        $(OCAMLFIND) install $(library_name) $(targets)
+
+    uninstall:
+	$(OCAMLFIND) remove $(library_name)
+
+    export
+
+############################################################## build ocaml exec
+
+#| Add a rule to build a program $(name)
+#      name
+#          Name of the program
+#      files
+#          OCaml module names (without .ml)
+MyOCamlProgram(name, files) =
+  AddLocalOCamlPackageDependencies()
+  export # The above thing is local: need to be exported
+
+  $(name).run $(name).opt: $(Installed $(OMyManagedPackages $(OCAMLPACKS)))
+
+  # CR jfuruse: forgot to add the deps over the packages!
+  .DEFAULT: $(OCamlProgram $(name), $(files))
+
+  # The following clean the files twice if MyOCamlPackge coexists,
+  # but who cases ?
+  AutoClean()
+
+#|  Add rules to build OCaml library $(name)
+#        name
+#            Name of the library
+#        files
+#            OCaml module name (without .ml)
+#
+#   .. note :: Probably you should use MyOCamlPackage
+MyOCamlLibrary(name, files) =
+  AddLocalOCamlPackageDependencies()
+  export # The above thing is local: need to be exported
+
+  # CR jfuruse: forgot to add the deps over the packages!
+  .DEFAULT: $(OCamlLibrary $(name), $(files))
+
+  # The following clean the files twice if MyOCamlPacakge coexists,
+  # but who cases ?
+  AutoClean()
+
+# Auto clean
+# ====================================================================
+
+#| Install clean command which cleans all the target files exists under the directory. Use with care.
+AutoClean()=
+    .PHONY: clean
+    clean:
+        rm -f $(filter-proper-targets $(ls R, .))
+
+# Subdir traversal
+# =====================================================================
+
+#| Recursively traverse the subdirs except $(dirs)
+Subdirs_except(dirs) =
+  # println(PWD: $(shell pwd))
+
+  # need to export since .SUBDIRS is evaluated in the global scope
+  export VISIT_SUBDIRS
+
+  sub_omakefiles = $(glob i, */OMakefile)
+  subdirs = $(sub_omakefiles.map $(dirname))
+
+  VISIT_SUBDIRS=$(set-diff $(subdirs), $(dirs))
+
+  # printing requires $(string ...) to convert arrays to strings
+  # println(SUBDIRS: $(string $(VISIT_SUBDIRS)))
+
+  # The rule
+  .SUBDIRS: $(VISIT_SUBDIRS)
+
+#| Recursively traverse all the subdirs
+Subdirs() =
+  Subdirs_except($(array))
+
+#| Recursively traverse the given subdirs $(dirs)
+Subdirs_only(dirs) =
+ .SUBDIRS: $(dirs)
+
+# Dependency dot files for Graphviz
+# ======================================================================
+
+#| Add a rule for ``depend.dot`` for a dependency graph of OCaml files in the current directory
+Dot() =
+	depend.dot: $(ls *.ml *.mli)
+	    $(OCAMLFIND) ocamldoc -I +threads $(OCAMLPACKAGEFLAGS) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLPPFLAGS) $(PREFIXED_OCAMLINCLUDES) -dot -dot-include-all -dot-reduce $+ -o $@
+
+

File _oasis

View file
  • Ignore whitespace
+OASISFormat: 0.2
+Name:        ocaml-llvm-phantom
+Version:     2.8.0
+Synopsis:    OCaml LLVM API enhanced with some static phantom typing
+Authors:     Jun FURUSE
+License:     LGPL-2.0 with OCaml linking exception
+Plugins:      StdFiles (0.2)
+BuildType:    Custom (0.2)
+InstallType:    Custom (0.2)
+XCustomBuild: yes no | omake --install; omake
+XCustomInstall: omake install
+XCustomUninstall: omake uninstall
+BuildTools: omake
+
+Library planck
+  Path:          lib
+  FindlibName:   ocaml-llvm-phantom
+  BuildDepends:  spotlib (>= 1.0.0), monad-custom (>= 6.0.0), ocaml-llvm (>= 2.8)
+  Modules:       
+   Extension,
+   Context,
+   Type_intf,
+   Type,
+   Type_ctxt,
+   Value_intf,
+   Value,
+   Gep,
+   Value_ctxt,
+   Module_intf,
+   Module,
+   Build_intf,
+   Build,
+   Wrap_intf,
+   Wrap,
+   Genvalue,
+   Std

File build.ml

  • Ignore whitespace
-open Spotlib.Spot
-module P = Spotlib.Spot.Phantom
-open P.Open
-
-module Builder = struct
-  include Monad.Make(struct
-    type 'a t = Llvm.llbuilder -> 'a
-    let bind a f = fun builder ->
-      let a = a builder in
-      f a builder
-    let return a = fun _builder -> a
-  end)
-end
-open Builder.Open
-
-module Make(Module : Module_intf.S) = struct
-  module Type = Type_ctxt.Make(Module)
-  module Value = Value_ctxt.Make(Module)
-  open Type
-  open Value
-
-  module Module = Module
-
-  (** Builder monad *)
-
-  (* CR jfuruse: Builder is independent from Module. It can be somewhere else. *)
-  module Monad = struct
-    include Builder
-    let run v = v (Llvm.builder Module.context)
-  end
-  type 'a m = 'a Monad.t
-  let build = Monad.run
-  let unknownM (v : 'a v m) : unknown v m = v >>= fun v -> return (!?v)
-  let magicM (v : 'a v m) : 'b v m = perform v <-- v; return (P.magic v)
-  let unsafeM v = perform v <-- v; return (P.unsafe v)
-
-  (** Function calls *)
-
-  let call 
-      ?(name="called") (* CR jfuruse: called + f's name *)
-      (f : ('args -> 'ret) pointer v)
-      (args : 'args vs)
-      : 'ret v m = 
-    (* If its return type is void, we erase the name *)
-    let name = 
-      match classify (function_return (element (type_of f))) with
-      | Llvm.TypeKind.Void -> ""
-      | _ -> name
-    in
-    unsafeM (Llvm.build_call !<f (P.List.to_array args) name)
-
-  let call_va_args
-      ?(name="called")
-      (f : ('args -> dots -> 'ret) pointer v)
-      (args : 'args vs)
-      (va_args : unknown v list)
-      : 'ret v m = 
-    let name = 
-      match classify (function_return (element (type_of f))) with
-      | Llvm.TypeKind.Void -> ""
-      | _ -> name
-    in
-    unsafeM (Llvm.build_call !<f (Array.of_list (P.List.to_list args 
-                                            @ List.map (!<) va_args)) name)
-
-
-  (** String *)
-
-  let global_stringptr ?(name="stringptr") str : i8 pointer v m = 
-    unsafeM (Llvm.build_global_stringptr str name)
-
-  (** Pointers *)
-
-  let is_null ?(name="is_null") (lv : 'a pointer v) : i1 v m = 
-    unsafeM (Llvm.build_is_null !<lv name)
-
-  (** Casts *)
-
-  let cast_name ?name v lty = match name with
-    | Some n -> n
-    | None ->
-        let name = Value.name v in
-        let name = try String.sub name 0 (String.rindex name '=') with Not_found -> name in
-        name ^ "=" ^ Type.string_of lty
-
-  let bitcast ?name v lty = 
-    let name = cast_name ?name v lty in
-    unsafeM (Llvm.build_bitcast !<v !<lty name)
-
-  let pointercast ?name v lty = 
-    let name = cast_name ?name v lty in
-    unsafeM (Llvm.build_pointercast !<v !<lty name)
-
-  let intcast ?name v lty = 
-    let name = cast_name ?name v lty in
-    unsafeM (Llvm.build_intcast !<v !<lty name)
-
-  (** Load/Store. Unsafe and type-safe versions *)
-
-  let load 
-      ?(name="loaded")
-      (v : 'ty pointer v)
-      : 'ty v m = 
-    unsafeM (Llvm.build_load !<v name)
-
-  let store 
-      (x : 'a v)
-      ~dst:(dst : 'a pointer v)
-      : unit m = 
-    Monad.ignore (Llvm.build_store !<x !<dst)
-
-  (* unsafe *)
-  let unsafe_gep 
-      ?(name = "gepped")
-      (v : 'a pointer v)
-      (xs : i32 v list)
-      : 'unsafe pointer v m = 
-    unsafeM (Llvm.build_gep !<v (Array.of_list (List.map (!<) xs)) name)
-
-  let gep_gen ?name cont v = Gep.gen (fun lst ->
-    let lst = List.map (function
-      | `int n -> Const.i32_of_int n
-      | `llvalue i -> P.unsafe i) lst in
-    perform
-      ptr <-- unsafe_gep ?name v lst;
-    cont ptr)
-
-  let gep ?name v = gep_gen ?name return v
-  let gep_load ?name v = gep_gen (load ?name) v
-  let gep_store x ~dst:v = gep_gen (fun ptr -> store x ~dst:ptr) v
-
-  let unsafe_const_load ?name ptr indices = perform
-    gepped <-- unsafe_gep ~name:"for_load" ptr (List.map Const.i32_of_int indices);
-    load ?name gepped
-
-  (* opposite order! *)
-  let unsafe_const_store ptr indices lv = perform
-      gepped <-- unsafe_gep ~name:"for_store" ptr (List.map Const.i32_of_int indices);
-      Monad.ignore (store lv ~dst:gepped)
-
-  (** Arithmetic operations *)
-
-  (* CR jfuruse: unfortunately no arith type check is done yet *)      
-  let arith (defname : string) f = 
-    fun ?(name=defname) (x : 'a v) (y : 'a v) ->
-      (unsafeM (f !<x !<y name) : 'a v m)
-  let cmp (defname : string) f = 
-    fun ?(name=defname) (x : 'a v) (y : 'a v) ->
-      (unsafeM (f !<x !<y name) : i1 v m)
-
-  let add  ?name = arith "added" Llvm.build_add ?name
-  let sub  ?name = arith "subed" Llvm.build_sub ?name
-  let mul  ?name = arith "muled" Llvm.build_mul ?name
-  let sdiv ?name = arith "sdived" Llvm.build_sdiv ?name
-  let fadd ?name = arith "fadded" Llvm.build_fadd ?name
-  let fsub ?name = arith "fsubed" Llvm.build_fsub ?name
-  let fmul ?name = arith "fmuled" Llvm.build_fmul ?name
-  let fdiv ?name = arith "fdived" Llvm.build_fdiv ?name
-  let icmp c = cmp "icmped" (Llvm.build_icmp c)
-  let fcmp c = cmp "fcmped" (Llvm.build_fcmp c)
-
-  (** Arithmetic type conversion *)
-
-  let sitofp ?(name="sitofped") i ty = 
-    unsafeM ^$ Llvm.build_sitofp !<i !<ty name
-
-  (** Memory *)
-
-  let alloca ?(name="inStack") ty =
-    unsafeM ^$ Llvm.build_alloca !<ty name
-
-  (** Useful libc functions *)
-
-  let printf : string -> unknown v list -> unit m = 
-    fun fmt args -> perform
-      fmt <-- global_stringptr ~name:"fmt" fmt;
-      Monad.ignore (call_va_args (Module.External.printf) (P.c1 fmt) args ~name:"res")
-  ;;
-
-  let memcpy ~dst ~src ~size = call ~name:"copied" Module.External.memcpy (P.c3 dst src size)
-
-  let bzero dst ~size = Monad.ignore (call Module.External.bzero (P.c2 dst size))
-
-  let malloc : ?name:string -> ?bzero:bool -> i32 v -> void_pointer v m =
-    fun ?(name="alloced") ?bzero:(zero=false) size -> perform
-      ptr <-- call ~name Module.External.malloc (P.c1 size);
-      if zero then bzero ptr ~size else return ();
-      return ptr
-  ;;
-
-  let malloc_by_ty ?name ?bzero (lty : 'ty typ) = perform
-    ptr <-- malloc ?name ?bzero (size_of lty);
-    bitcast ptr (pointer lty)
-
-  let free ptr = perform
-    ptr <-- bitcast ptr pointer_void;
-    Monad.ignore (call Module.External.free (P.c1 ptr))
-  ;;
-
-  (** Control flow codegens *)
-
-  let ret x : unit m = Monad.ignore (Llvm.build_ret !<x)
-  let ret_void : unit m = Monad.ignore Llvm.build_ret_void
-
-  let phi 
-      ?(name="phi")
-      (lst : ('a v * Llvm.llbasicblock) list)
-      : 'a v m =
-    unsafeM (Llvm.build_phi (List.map (fun (v, b) -> !<v, b) lst) name)
-
-  let cond_br 
-      (b : i1 v)
-      bthen belse
-      : unit m
-      = Monad.ignore (Llvm.build_cond_br !<b bthen belse)
-
-  let br b = Monad.ignore (Llvm.build_br b)
-
-  (** Basic blocks *)
-
-  module Block = struct
-    let position_at_end = Llvm.position_at_end
-    let insertion = Llvm.insertion_block
-
-    (* They are independent from the builder *) 	
-    let append ?(name="block") (v : ('a -> 'b) pointer v) = Llvm.append_block Module.context name !<v  
-    let parent bb : ('a -> 'b) pointer v = P.unsafe (Llvm.block_parent bb)
-  end
-
-  let func name (ty_ret : 'ret typ) (args : ('args, (string * Llvm.lltype)) P.ts) 
-      ?(dump=false)
-      (f : ('args -> 'ret) pointer v -> 'args vs -> 'ret v m) : ('args -> 'ret) pointer v m =
-    (* Format.eprintf "Creating function %s@." name; *)
-    let lty = function_ ty_ret (P.List.map snd args) in
-    let lv_f = match Module.Function.lookup name with
-      | Some _ -> failwithf "LLib.create_fun: function %s is defined more than once" name
-      | None -> Module.Function.declare name lty
-    in
-    (* name args *)
-    List.iter2 (fun lv_param name ->
-      Value.set_name name lv_param) 
-      (P.List.to_unknown_list (function_params lv_f))
-      (P.List.to_list (P.List.map fst args));
-    let bb = Block.append ~name:"entry" lv_f in
-    perform 
-      Block.position_at_end bb;
-      lv_body <-- f lv_f (function_params lv_f);
-      (* Finish off the function. *)
-      if classify ty_ret = Llvm.TypeKind.Void then ret_void else ret lv_body;
-      (* Validate the generated code, checking for consistency. *)
-      \ if dump then Value.dump lv_f;
-      \ Analysis.assert_valid_function lv_f;
-      (* Optimize the function *)
-      \ Module.PassManager.run_function_if_opt lv_f;
-      (* \ Format.eprintf "Created function %s@." name; *)
-      return lv_f
-
-  let func0 name ?dump ret () f = func name ?dump ret P.c0 (fun self -> P.uncurry0 (f self))
-  let func1 name ?dump ret (arg0,t0) f = func name ?dump ret (P.c1 (P.combine arg0 t0)) (fun self -> P.uncurry1 (f self))
-  let func2 name ?dump ret (arg0,t0) (arg1,t1) f = func name ?dump ret (P.c2 (P.combine arg0 t0) (P.combine arg1 t1)) (fun self -> P.uncurry2 (f self))
-  let func3 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) f = func name ?dump ret (P.c3 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2)) (fun self -> P.uncurry3 (f self))
-  let func4 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) f = func name ?dump ret (P.c4 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3)) (fun self -> P.uncurry4 (f self))
-  let func5 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) f = func name ?dump ret (P.c5 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4)) (fun self -> P.uncurry5 (f self))
-  let func6 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) f = func name ?dump ret (P.c6 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5)) (fun self -> P.uncurry6 (f self))
-  let func7 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) (arg6,t6) f = func name ?dump ret (P.c7 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5) (P.combine arg6 t6)) (fun self -> P.uncurry7 (f self))
-  let func8 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) (arg6,t6) (arg7,t7) f = func name ?dump ret (P.c8 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5) (P.combine arg6 t6) (P.combine arg7 t7)) (fun self -> P.uncurry8 (f self))
-  let func9 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) (arg6,t6) (arg7,t7) (arg8,t8) f = func name ?dump ret (P.c9 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5) (P.combine arg6 t6) (P.combine arg7 t7) (P.combine arg8 t8)) (fun self -> P.uncurry9 (f self))
-  let func10 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) (arg6,t6) (arg7,t7) (arg8,t8) (arg9,t9) f = func name ?dump ret (P.c10 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5) (P.combine arg6 t6) (P.combine arg7 t7) (P.combine arg8 t8) (P.combine arg9 t9)) (fun self -> P.uncurry10 (f self))
-
-  (* stupid lambda abstraction is required for polymorphism *)    
-  let current_function : unit -> ('a -> 'b) pointer v m = fun () -> perform
-    current_bb <-- Block.insertion;
-    return (Block.parent current_bb)
-
-  let append_code_block name (codegen : 'a m) : (Llvm.llbasicblock * 'a * Llvm.llbasicblock) m = perform
-    the_function <-- current_function ();
-    let bb = Block.append ~name the_function in
-    (* Emit value. *)
-    Block.position_at_end bb;
-    res <-- codegen;
-    (* Codegen of [res] can change the current block, update bb for the phi. *)
-    new_bb <-- Block.insertion;
-    return (bb, res, new_bb)
-
-  (** Connecting basic blocks *)
-
-  let return_void : void v m = (fun _builder -> P.magic Const.i32_0)
-    (* The return value looks strange but probably ok. Probably. *)
-
-  let uncond_br from to_ = perform
-    Block.position_at_end from;
-    Monad.ignore (br to_)
-
-  let if_then_else (lv_cond : i1 v m) (lv_then : 'a v m) (lv_else : 'a v m) : 'a v m = perform
-    (* get the current bb *)
-    start_bb <-- Block.insertion;
-
-    lv_cond <-- lv_cond; (* created in [start_bb] *)
-    (* before adding branching, we must create the destinations *)
-
-    (then_bb, lv_then, new_then_bb) <-- append_code_block "then" lv_then;
-    (else_bb, lv_else, new_else_bb) <-- append_code_block "else" lv_else;
-
-    (* merge_bb and new_merge_bb should be the same *)
-    (merge_bb, phi, new_merge_bb) <-- append_code_block "ifcont" begin
-      let incoming = [(lv_then, new_then_bb); (lv_else, new_else_bb)] in
-      (* Llvm.build_phi returns the merged value, which can be used the
-         return of the entire (if ...) *)
-      phi incoming ~name:"iftmp"
-    end;
-
-    (* Return to the start block to add the conditional branch. *)
-    Block.position_at_end start_bb;
-    cond_br lv_cond then_bb else_bb;
-
-    (* Set a unconditional branch at the end of the 'then' block and the
-     * 'else' block to the 'merge' block. *)
-    uncond_br new_then_bb merge_bb;
-    uncond_br new_else_bb merge_bb;
-
-    (* Finally, set the G.builder to the end of the merge block. *)
-    Block.position_at_end new_merge_bb;
-
-    return phi
-
-  let imp_if_then_else (lv_cond : i1 v m) (lv_then : unit m) (lv_else : unit m) : unit m = perform
-    (* get the current bb *)
-    start_bb <-- Block.insertion;
-
-    lv_cond <-- lv_cond; (* created in [start_bb] *)
-    (* before adding branching, we must create the destinations *)
-
-    (then_bb, (), new_then_bb) <-- append_code_block "then" lv_then;
-    (else_bb, (), new_else_bb) <-- append_code_block "else" lv_else;
-
-    (* merge_bb and new_merge_bb should be the same *)
-    (merge_bb, (), new_merge_bb) <-- append_code_block "ifcont" (return ());
-
-    (* Return to the start block to add the conditional branch. *)
-    Block.position_at_end start_bb;
-    cond_br lv_cond then_bb else_bb;
-
-    (* Set a unconditional branch at the end of the 'then' block and the
-     * 'else' block to the 'merge' block. *)
-    uncond_br new_then_bb merge_bb;
-    uncond_br new_else_bb merge_bb;
-
-    (* Finally, set the G.builder to the end of the merge block. *)
-    Block.position_at_end new_merge_bb;
-
-    return ()
-
-  let for_loop 
-      (init : 'a v) (* initialization of the loop variable of type 'a v *)
-      (cond : 'a v -> i1 v m) (* test on the loop variable *)
-      (do_ : 'a v -> 'a v m) (* do the job and update the loop variable *) = perform
-    start_bb <-- Block.insertion;
-    current_function <-- current_function ();
-
-    (phi_enter, phi, phi_exit) <-- append_code_block "phi" (
-      perform
-        let incoming = [(init, start_bb)] in (* do is not prepared. Added later. *)
-        phi incoming ~name:"fortmp");
-
-    (do_enter,   do_,  do_exit)   <-- append_code_block "do" (do_ phi);
-    \ Llvm.add_incoming (!<do_, do_exit) !<phi; (* now we can add the other incoming *)
-
-    let exit_bb = Block.append ~name:"exit" current_function in
-
-    (cond_enter, _cond, _cond_exit) <-- append_code_block "cond" (perform
-      cond <-- cond phi;
-      cond_br cond do_enter exit_bb;
-      return cond);
-
-    uncond_br start_bb phi_enter;
-    uncond_br do_exit phi_enter;
-    uncond_br phi_exit cond_enter;
-
-    Block.position_at_end exit_bb;
-
-    return ()
-
-  (** Execution *)
-
-  let exec =
-    let cntr = ref 0 in
-    fun (v : unit m) ->
-      incr cntr;
-      let name = Printf.sprintf "lbuilder.exec%d" !cntr in
-      Format.eprintf "Executing %s...@." name;
-      let f : (unit -> void) pointer v =
-        let proto = function_ void P.c0 in
-        match Module.Function.lookup name with
-        | Some _ -> failwithf "function %s is defined more than once" name
-        | None -> Module.Function.declare name proto
-      in
-      prerr_endline "proto done";
-      (* Create a new basic block to start insertion into. *)
-      Monad.run (perform
-        let bb = Block.append ~name:"entry" f in
-        Block.position_at_end bb;
-        v; (* create the code *)
-        ret_void);
-      (* Optimize the function *)
-      Value.dump f;
-      Module.PassManager.run_function_if_opt f;
-      Analysis.assert_valid_function f;
-      Format.eprintf "Now running %s@." name;
-      ignore (Module.ExecutionEngine.run_function f P.c0);
-      Format.eprintf "Done running %s@." name;
-end

File build.mli

  • Ignore whitespace
-module Make(Module : Module_intf.S) : Build_intf.S

File build_intf.ml

  • Ignore whitespace
-open Spotlib.Spot
-open Spotlib.Spot.Phantom
-open Type
-open Value
-
-module type S = sig
-
-  (** Builder monad *)
-
-  module Monad : sig
-    include Monad_intf.T with type 'a t = Llvm.llbuilder -> 'a
-    val run : 'a t -> 'a
-  end
-  type 'a m = 'a Monad.t
-
-  val build : 'a m -> 'a
-    (** [build m] runs the code gen store in the monad [m] *)
-
-  (** Lifted value coercions *)      
-  val unknownM : 'a v m -> unknown v m
-  val magicM : 'a v m -> 'b v m
-
-
-
-  (** Function calls *)
-
-  val call : ?name:string -> ('a -> 'b) pointer v -> 'a vs -> 'b v m
-  val call_va_args : ?name: string -> ('a -> dots -> 'b) pointer v -> 'a vs -> unknown v list -> 'b v m
-
-
-
-  (** String *)
-  val global_stringptr : ?name:string -> string -> i8 pointer v m
-
-
-
-  (** Pointers *)
-
-  val is_null : ?name:string -> 'a pointer v -> i1 v m
-
-
-
-  (** Casts *)
-
-  val bitcast : ?name:string -> 'a v -> 'b typ -> 'b v m
-  val pointercast : ?name:string -> 'a pointer v -> ([>`int] as 'b) typ -> 'b v m
-  val intcast : ?name:string -> [>`int] v -> ([>`int] as 'a) typ -> 'a v m
-
-
-
-  (** Load/Store. Unsafe and type-safe versions *)
-
-  val unsafe_gep : ?name:string -> 'a pointer v -> i32 v list -> 'unsafe pointer v m
-    
-  (** Type-safe GEP
-      
-      Do not be fooled by those complex types. They are pretty easy to use:
-
-      [gep v acc1 acc2 ... accn Gep.end_] provides a type safe version of 
-      [unsafe_gep v [<acc1>; <acc2>; .. ; <accn>]].
-
-      Here acci is an accessor, one of the followings:
-       - [Gep.pos n] : Accessing n-th pointer/array/vector elements
-       - [Gep.pos_i32 n] : Accessing n-th pointer/array/vector elements by llvalue
-       - [Gep.mem<i>] : Accessing n-th element of struct
-
-      You must give appropriate accessors: 
-      for example, you cannot use [pos n] for n-th element of struct.
-
-      Do not forget to put Gep.end_ at the end of the accessor list.
-
-      Examples:
-
-        - Obtain i32* from i32[20]* p, which points to p[0][n]
-            gep pointer (Gep.pos_const 0) (Gep.pos n) Gep.end_ : i32 pointer v m
-        - Obtain i32* from {i1, i16, i32, i64}* p, which points to the i32 element of the struct *p.
-            gep pointer (Gep.pos_const 0) Gep.mem2 Gep.end_ : i32 pointer v m
-
-      Type-safe GEP + load/store
-
-      GEP and load/store are often used in conjunctions, gep_load and gep_store are available for such cases:
-
-        - Load i32 p[0][n] of i32[20]* p
-            gep_load pointer (Gep.pos_const 0) (Gep.pos n) Gep.end_ : i32 v m 
-        - Store the i32 element [v] to the 2nd element of {i1, i16, i32, i64}* p
-            gep_store v ~dst:pointer (Gep.pos_const 0) Gep.mem2 Gep.end_ : i32 v m 
-  *)
-  val gep : ?name:string 
-            -> 'a pointer v
-            -> (('a pointer, 'x, 'x pointer v m) Gep.t -> 'b)
-            -> 'b
-  val gep_load : ?name:string 
-            -> 'a pointer v
-            -> (('a pointer, 'x, 'x v m) Gep.t -> 'b)
-            -> 'b
-  val gep_store : 'x v
-            -> dst:'a pointer v
-            -> (('a pointer, 'x, unit m) Gep.t -> 'b)
-            -> 'b
-
-  val load : ?name:string -> 'a pointer v -> 'a v m
-  val store : 'a v -> dst:'a pointer v -> unit m
-
-  val unsafe_const_load : ?name:string -> 'a pointer v -> int list -> 'unsafe v m
-  val unsafe_const_store : 'a pointer v -> int list -> 'unsafe v -> unit m
-
-
-
-  (** Arithmetic operations *)
-
-  val add :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
-  val sub :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
-  val mul :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
-  val sdiv : ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
-  val fadd : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
-  val fsub : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
-  val fmul : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
-  val fdiv : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
-  val icmp : Llvm.Icmp.t -> ?name:string -> ([>`int] as 'a) v -> 'a v -> i1 v m
-  val fcmp : Llvm.Fcmp.t -> ?name:string -> ([>`floating] as 'a) v -> 'a v -> i1 v m
-
-
-  (** Arithmetic type conversion *)
-
-  val sitofp : ?name:string -> [>`int] v -> ([>`floating] as 'a) typ -> 'a v m
-
-
-  (** Memory *)
-
-  val alloca : ?name:string -> 'a typ -> 'a pointer v m
-
-
-  (** Useful libc functions *)
-
-  val printf : string -> unknown v list -> unit m
-    (* CR jfuruse: probably (quite unlikely though), we can have a type safer version *)
-
-  val malloc : ?name:string -> ?bzero:bool -> i32 v -> void_pointer v m
-    (** malloc by size. *)
-
-  val malloc_by_ty : ?name:string -> ?bzero:bool -> 'a typ -> 'a pointer v m
-    (** malloc by type.
-        CR: no nelems available. 
-    *)
-
-  val memcpy : dst:void_pointer v -> src:void_pointer v -> size:i32 v -> void_pointer v m
-  val bzero : void_pointer v -> size:i32 v -> unit m
-  val free : 'a pointer v -> unit m
-
-
-  (** Control flow codegens *)
-
-  val ret : 'a v -> unit m
-  val ret_void : unit m
-    
-  val phi : ?name:string -> ('a v * Llvm.llbasicblock) list -> 'a v m
-
-  val cond_br : i1 v -> Llvm.llbasicblock -> Llvm.llbasicblock -> unit m
-
-  val br : Llvm.llbasicblock -> unit m
-
-
-
-  (** Basic blocks *)
-
-  module Block : sig
-    val position_at_end : Llvm.llbasicblock -> unit m
-    val insertion : Llvm.llbasicblock m
-    val append : ?name:string -> ('a -> 'b) pointer v -> Llvm.llbasicblock
-    val parent : Llvm.llbasicblock -> ('a -> 'b) pointer v
-  end
-
-
-
-  (** Function definition *)
-
-  val func : string -> 'a typ -> ('b, (string * Llvm.lltype)) Phantom.ts
-    -> ?dump: bool
-    -> (('b -> 'a) pointer v (* self *) -> 'b vs -> 'a v m) 
-    -> ('b -> 'a) pointer v m
-  (** [func name return_type arg_types ?dump f] defines a function of a name [name] whose type is
-      [arg_types] -> [return_type]. Its function body is defined by [f].
-      Self is for recursion.
-  *)
-
-  val func0 : string -> ?dump:bool -> 'res typ
-    -> unit
-    -> ((tpl0 -> 'res) pointer v -> unit -> 'res v m)
-    -> (tpl0 -> 'res) pointer v m
-  val func1 : string -> ?dump:bool -> 'res typ
-    -> (string * 'a0 typ)
-    -> ((('a0) tpl1 -> 'res) pointer v -> 'a0 v -> 'res v m)
-    -> (('a0) tpl1 -> 'res) pointer v m
-  val func2 : string -> ?dump:bool -> 'res typ
-    -> (string * 'a0 typ) -> (string * 'a1 typ)
-    -> ((('a0,'a1) tpl2 -> 'res) pointer v -> 'a0 v -> 'a1 v -> 'res v m)
-    -> (('a0,'a1) tpl2 -> 'res) pointer v m
-  val func3 : string -> ?dump:bool -> 'res typ
-    -> (string * 'a0 typ) -> (string * 'a1 typ) -> (string * 'a2 typ)
-    -> ((('a0,'a1,'a2) tpl3 -> 'res) pointer v -> 'a0 v -> 'a1 v -> 'a2 v -> 'res v m)
-    -> (('a0,'a1,'a2) tpl3 -> 'res) pointer v m
-  val func4 : string -> ?dump:bool -> 'res typ
-    -> (string * 'a0 typ) -> (string * 'a1 typ) -> (string * 'a2 typ) -> (string * 'a3 typ)
-    -> ((('a0,'a1,'a2,'a3) tpl4 -> 'res) pointer v -> 'a0 v -> 'a1 v -> 'a2 v -> 'a3 v -> 'res v m)
-    -> (('a0,'a1,'a2,'a3) tpl4 -> 'res) pointer v m
-  val func5 : string -> ?dump:bool -> 'res typ
-    -> (string * 'a0 typ) -> (string * 'a1 typ) -> (string * 'a2 typ) -> (string * 'a3 typ) -> (string * 'a4 typ)
-    -> ((('a0,'a1,'a2,'a3,'a4) tpl5 -> 'res) pointer v -> 'a0 v -> 'a1 v -> 'a2 v -> 'a3 v -> 'a4 v -> 'res v m)
-    -> (('a0,'a1,'a2,'a3,'a4) tpl5 -> 'res) pointer v m
-  val func6 : string -> ?dump:bool -> 'res typ
-    -> (string * 'a0 typ) -> (string * 'a1 typ) -> (string * 'a2 typ) -> (string * 'a3 typ) -> (string * 'a4 typ) -> (string * 'a5 typ)
-    -> ((('a0,'a1,'a2,'a3,'a4,'a5) tpl6 -> 'res) pointer v -> 'a0 v -> 'a1 v -> 'a2 v -> 'a3 v -> 'a4 v -> 'a5 v -> 'res v m)
-    -> (('a0,'a1,'a2,'a3,'a4,'a5) tpl6 -> 'res) pointer v m
-  val func7 : string -> ?dump:bool -> 'res typ
-    -> (string * 'a0 typ) -> (string * 'a1 typ) -> (string * 'a2 typ) -> (string * 'a3 typ) -> (string * 'a4 typ) -> (string * 'a5 typ) -> (string * 'a6 typ)
-    -> ((('a0,'a1,'a2,'a3,'a4,'a5,'a6) tpl7 -> 'res) pointer v -> 'a0 v -> 'a1 v -> 'a2 v -> 'a3 v -> 'a4 v -> 'a5 v -> 'a6 v -> 'res v m)
-    -> (('a0,'a1,'a2,'a3,'a4,'a5,'a6) tpl7 -> 'res) pointer v m
-  val func8 : string -> ?dump:bool -> 'res typ
-    -> (string * 'a0 typ) -> (string * 'a1 typ) -> (string * 'a2 typ) -> (string * 'a3 typ) -> (string * 'a4 typ) -> (string * 'a5 typ) -> (string * 'a6 typ) -> (string * 'a7 typ)
-    -> ((('a0,'a1,'a2,'a3,'a4,'a5,'a6,'a7) tpl8 -> 'res) pointer v -> 'a0 v -> 'a1 v -> 'a2 v -> 'a3 v -> 'a4 v -> 'a5 v -> 'a6 v -> 'a7 v -> 'res v m)
-    -> (('a0,'a1,'a2,'a3,'a4,'a5,'a6,'a7) tpl8 -> 'res) pointer v m
-  val func9 : string -> ?dump:bool -> 'res typ
-    -> (string * 'a0 typ) -> (string * 'a1 typ) -> (string * 'a2 typ) -> (string * 'a3 typ) -> (string * 'a4 typ) -> (string * 'a5 typ) -> (string * 'a6 typ) -> (string * 'a7 typ) -> (string * 'a8 typ)
-    -> ((('a0,'a1,'a2,'a3,'a4,'a5,'a6,'a7,'a8) tpl9 -> 'res) pointer v -> 'a0 v -> 'a1 v -> 'a2 v -> 'a3 v -> 'a4 v -> 'a5 v -> 'a6 v -> 'a7 v -> 'a8 v -> 'res v m)
-    -> (('a0,'a1,'a2,'a3,'a4,'a5,'a6,'a7,'a8) tpl9 -> 'res) pointer v m
-  val func10 : string -> ?dump:bool -> 'res typ
-    -> (string * 'a0 typ) -> (string * 'a1 typ) -> (string * 'a2 typ) -> (string * 'a3 typ) -> (string * 'a4 typ) -> (string * 'a5 typ) -> (string * 'a6 typ) -> (string * 'a7 typ) -> (string * 'a8 typ) -> (string * 'a9 typ)
-    -> ((('a0,'a1,'a2,'a3,'a4,'a5,'a6,'a7,'a8,'a9) tpl10 -> 'res) pointer v -> 'a0 v -> 'a1 v -> 'a2 v -> 'a3 v -> 'a4 v -> 'a5 v -> 'a6 v -> 'a7 v -> 'a8 v -> 'a9 v -> 'res v m)
-    -> (('a0,'a1,'a2,'a3,'a4,'a5,'a6,'a7,'a8,'a9) tpl10 -> 'res) pointer v m
-
-  (** Connecting basic blocks *)
-
-  val return_void : void v m 
-  (** for functions returning void *)
-
-  val current_function : unit -> ('a -> 'b) pointer v m
-  (** Returns the current function. If not in a function, raises Not_found *) 
-
-  val append_code_block : 
-    string (* name *)
-    -> 'a v m (* codegen *)
-    -> (Llvm.llbasicblock * 'a v * Llvm.llbasicblock) m
-  (** [append_code_block name vm] appends a basicblock of name [name]
-      using the codegen [vm] in the function being defined currently. 
-      It returns the entering block, the codegen result llvalue, and  
-      the exiting block. *)
-
-  val if_then_else : i1 v m -> 'a v m -> 'a v m -> 'a v m
-  (** Functional condition: Not_found is raised if not defined in a function. *)
-
-  val imp_if_then_else : i1 v m -> unit m -> unit m -> unit m
-  (** Imperative condition: Not_found is raised if not defined in a function. *)
-
-  val for_loop : 
-    'a v (* the init loop value *) 
-    -> ('a v -> i1 v m) (* test on the loop value *)
-    -> ('a v -> 'a v m) (* the loop job + loop value update *)
-    -> unit m
-  (** Not_found is raised if not defined in a function *)
-
-
-
-  (** Execution *)
-
-  val exec : unit m -> unit
-  (** [exec u] creates an anonymous function from [u] and runs it. *)
-end

File context.ml

  • Ignore whitespace
-open Llvm
-
-(** Contexts *)
-
-type t = llcontext
-
-let create = create_context 
-let dispose = dispose_context
-let global = global_context
-let mdkind_id = mdkind_id

File context.mli

  • Ignore whitespace
-open Llvm
-
-(** {6 Contexts} *)
-
-type t = llcontext
-
-(** [create ()] creates a context for storing the "global" state in
-    LLVM. See the constructor [llvm::LLVMContext]. *)
-val create : unit -> t
-
-(** [destroy ()] destroys a context. See the destructor
-    [llvm::LLVMContext::~LLVMContext]. *)
-val dispose : t -> unit
-
-(** See the function [llvm::getGlobalContext]. *)
-val global : unit -> t
-
-(** [mdkind_id context name] returns the MDKind ID that corresponds to the
-    name [name] in the context [context].  See the function
-    [llvm::LLVMContext::getMDKindID]. *)
-val mdkind_id : t -> string -> int

File extension.ml

  • Ignore whitespace
-(* Some functions which could be additions or bug-fixes to the original LLVM OCaml binding *)
-
-module Llvm = struct
-  open Llvm
-
-  (** [string_of_lltype] of LLVM 2.8 has a bug: if it tries to print a recursive type, 
-      Kabooom! *)        
-  (* Here is a fix *)        
-  let string_of_lltype defined_names ty =
-    let create_name =
-      let cntr = ref 0 in
-      fun () ->
-        let x = !cntr in
-        incr cntr;
-        x
-    in
-    let rec string_of_lltype visited ty =
-      try 
-        let modname, name = List.assq ty defined_names in
-        modname ^ "." ^ name, []
-      with Not_found ->
-        if List.memq ty visited then 
-          let name = "'" ^ string_of_int (create_name ()) in
-          name, [ty, name]
-        else 
-          let visited = ty :: visited in
-          let s, recs =  
-            match classify_type ty with
-            | TypeKind.Integer -> 
-                "i" ^ string_of_int (integer_bitwidth ty), []
-            | TypeKind.Pointer -> 
-                let s, recs = string_of_lltype visited (element_type ty) in
-                s ^ "*", recs
-            | TypeKind.Struct ->
-                let name_recs = List.map (string_of_lltype visited) (Array.to_list (struct_element_types ty)) in
-                let s = "{ " ^ String.concat ", " (List.map fst name_recs) ^ " }" in
-                let recs = List.concat (List.map snd name_recs) in
-                if is_packed ty
-                then "<" ^ s ^ ">", recs
-                else s, recs
-            | TypeKind.Array -> 
-                let s, recs = string_of_lltype visited (element_type ty) in
-                "[" ^ (string_of_int (array_length ty)) ^ " x " ^ s ^ "]", recs
-            | TypeKind.Vector -> 
-                let s, recs = string_of_lltype visited (element_type ty) in
-                "<" ^ (string_of_int (vector_size ty)) ^ " x " ^ s ^ ">", recs
-            | TypeKind.Opaque -> "opaque", []
-            | TypeKind.Function -> 
-                let name_recs = List.map (string_of_lltype visited) (Array.to_list (param_types ty)) in
-                let s = String.concat ", " (List.map fst name_recs) in
-                let recs = List.concat (List.map snd name_recs) in
-                let ret, recs_ret = string_of_lltype visited (return_type ty) in
-                ret ^ " (" ^ s ^ ")", recs_ret @ recs
-            | TypeKind.Label -> "label", []
-            | TypeKind.Ppc_fp128 -> "ppc_fp128", []
-            | TypeKind.Fp128 -> "fp128", []
-            | TypeKind.X86fp80 -> "x86_fp80", []
-            | TypeKind.Double -> "double", []
-            | TypeKind.Float -> "float", []
-            | TypeKind.Void -> "void", []
-            | TypeKind.Metadata -> "metadata", []
-          in
-          try 
-            let name = List.assq ty recs in
-            "u" ^ name ^ "." ^ s, recs
-          with
-          | Not_found -> s, recs
-    in
-    fst (string_of_lltype [] ty)
-end

File extension.mli

  • Ignore whitespace
-(* Some functions which could be additions or bug-fixes to the original LLVM OCaml binding *)
-open Llvm
-
-module Llvm : sig
-  val string_of_lltype : (Llvm.lltype * (string * string)) list -> lltype -> string
-  (** It can print named types and recursive types with mu notation *)
-end 

File genvalue.ml

  • Ignore whitespace
-(* CR jfuruse: This should be Value.Generic *)
-
-open Llvm
-open Llvm_executionengine
-
-open Spotlib.Spot
-module P = Spotlib.Spot.Phantom
-open P.Open
-
-open Type
-
-
-module GV = GenericValue
-
-(** phantom *)
-type 'a v = ('a, GV.t) Phantom.t
-type 'a vs = ('a, GV.t) Phantom.ts
-
-let unsafe_annotate v _t = v
-
-let of_float : ([>`floating] as 'a) typ -> float -> 'a v = 
-  fun ty v -> P.unsafe ^$ GV.of_float !<ty v
-
-let unsafe_of_pointer : 'a (* unsafe *) -> 'b pointer v = 
-  fun v -> P.unsafe ^$ GV.of_pointer v
-
-let of_int32 : ([>`int] as 'a) typ -> int32 -> 'a v =
-  fun ty v -> P.unsafe ^$ GV.of_int32 !<ty v
-
-let of_int : ([>`int] as 'a) typ -> int -> 'a v =
-  fun ty v -> P.unsafe ^$ GV.of_int !<ty v
-
-let of_nativeint : ([>`int] as 'a) typ -> nativeint -> 'a v =
-  fun ty v -> P.unsafe ^$ GV.of_nativeint !<ty v
-
-let of_int64 : ([>`int] as 'a) typ -> int64 -> 'a v =
-  fun ty v -> P.unsafe ^$ GV.of_int64 !<ty v
-
-let as_float : ([>`floating] as 'a) typ -> 'a v -> float = 
-  fun ty v -> GV.as_float !<ty !<v
-let as_unsafe_pointer : 'a pointer v -> 'b (* unsafe *) = fun v -> GV.as_pointer !<v
-let as_int32 : ([>`int] as 'a) v -> int32  = fun v -> GV.as_int32 !<v
-let as_int : ([>`int] as 'a) v -> int = fun v -> GV.as_int !<v
-let as_nativeint : ([>`int] as 'a) v -> nativeint = fun v -> GV.as_nativeint !<v
-let as_int64 : ([>`int] as 'a) v -> int64 = fun v -> GV.as_int64 !<v
-

File genvalue.mli

  • Ignore whitespace
-open Type
-open Llvm_executionengine
-
-open Spotlib.Spot
-open Spotlib.Spot.Phantom.Open
-
-type 'a v = ('a, GenericValue.t) Phantom.t
-type 'a vs = ('a, GenericValue.t) Phantom.ts
-
-(** phantom *)
-(* val unsafe_annotate : GenericValue.t -> 'a v _t = v *)
-
-val of_float : ([>`floating] as 'a) typ -> float -> 'a v
-val unsafe_of_pointer : 'a (* unsafe *) -> 'b pointer v
-val of_int32 : ([>`int] as 'a) typ -> int32 -> 'a v
-val of_int : ([>`int] as 'a) typ -> int -> 'a v
-val of_nativeint : ([>`int] as 'a) typ -> nativeint -> 'a v
-val of_int64 : ([>`int] as 'a) typ -> int64 -> 'a v
-
-val as_float : ([>`floating] as 'a) typ -> 'a v -> float
-val as_unsafe_pointer : 'a pointer v -> 'b (* unsafe *)
-val as_int32 : ([>`int] as 'a) v -> int32
-val as_int : ([>`int] as 'a) v -> int
-val as_nativeint : ([>`int] as 'a) v -> nativeint
-val as_int64 : ([>`int] as 'a) v -> int64
-

File gep.ml

  • Ignore whitespace
-open Spotlib.Spot.Phantom.Open
-open Value
-
-type ('a, 'final, 'res) t = 
-    { k : [`int of int | `llvalue of Llvm.llvalue] list -> 'res; 
-      rev : [`int of int | `llvalue of Llvm.llvalue] list; 
-                            }
-let gen k f = f { rev = []; k = k; }
-let end_ st = st.k (List.rev st.rev)
-  
-let pos (n : int) st k = k { st with rev = `int n::st.rev }
-let pos_i32 n st k = k { st with rev = `llvalue !<n::st.rev }
-let mem0 st k = k { st with rev = `int 0  :: st.rev }
-let mem1 st k = k { st with rev = `int 1  :: st.rev }
-let mem2 st k = k { st with rev = `int 2  :: st.rev }
-let mem3 st k = k { st with rev = `int 3  :: st.rev }
-let mem4 st k = k { st with rev = `int 4  :: st.rev }
-let mem5 st k = k { st with rev = `int 5  :: st.rev }
-let mem6 st k = k { st with rev = `int 6  :: st.rev }
-let mem7 st k = k { st with rev = `int 7  :: st.rev }
-let mem8 st k = k { st with rev = `int 8  :: st.rev }
-let mem9 st k = k { st with rev = `int 9  :: st.rev }
-

File gep.mli

  • Ignore whitespace
-(** Type-safe GEP tools *)
-
-open Type
-open Value
-
-type ('a, 'final, 'res) t
-  (** GEP phantom *)
-
-val gen : ([ `int of int | `llvalue of Llvm.llvalue ] list -> 'res) -> (('a, 'final, 'res) t -> 'b) -> 'b
-  (** GEP generator *)
-
-val end_ : ('final, 'final, 'res) t -> 'res
-  (** GEP finisher *)
-
-(** pointer/array/vector accessors *)
-
-val pos : int -> ([> `container of 'a], 'final, 'res) t -> (('a, 'final, 'res) t -> 'b) -> 'b
-val pos_i32 : i32 v -> ([> `container of 'a], 'final, 'res) t -> (('a, 'final, 'res) t -> 'b) -> 'b
-
-(** struct member accessors *)
-
-val mem0 : (('a0 * _) struct_, 'final, 'res) t -> (('a0, 'final, 'res) t -> 'b) -> 'b
-val mem1 : ((_ * ('a1 * _)) struct_, 'final, 'res) t -> (('a1, 'final, 'res) t -> 'b) -> 'b
-val mem2 : ((_ * (_ * ('a2 * _))) struct_, 'final, 'res) t -> (('a2, 'final, 'res) t -> 'b) -> 'b
-val mem3 : ((_ * (_ * (_ * ('a3 * _)))) struct_, 'final, 'res) t -> (('a3, 'final, 'res) t -> 'b) -> 'b
-val mem4 : ((_ * (_ * (_ * (_ * ('a4 * _))))) struct_, 'final, 'res) t -> (('a4, 'final, 'res) t -> 'b) -> 'b
-val mem5 : ((_ * (_ * (_ * (_ * (_ * ('a5 * _)))))) struct_, 'final, 'res) t -> (('a5, 'final, 'res) t -> 'b) -> 'b
-val mem6 : ((_ * (_ * (_ * (_ * (_ * (_ * ('a6 * _))))))) struct_, 'final, 'res) t -> (('a6, 'final, 'res) t -> 'b) -> 'b
-val mem7 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a7 * _)))))))) struct_, 'final, 'res) t -> (('a7, 'final, 'res) t -> 'b) -> 'b
-val mem8 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a8 * _))))))))) struct_, 'final, 'res) t -> (('a8, 'final, 'res) t -> 'b) -> 'b
-val mem9 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a9 * _)))))))))) struct_, 'final, 'res) t -> (('a9, 'final, 'res) t -> 'b) -> 'b

File lib/OMakefile

View file
  • Ignore whitespace
+.PHONY: all install clean
+
+OCAMLINCLUDES +=
+
+OCAMLFLAGS    += -annot -w Ae
+OCAMLCFLAGS   +=
+OCAMLOPTFLAGS +=
+OCAML_LINK_FLAGS +=
+OCAML_BYTE_LINK_FLAGS +=
+OCAML_NATIVE_LINK_FLAGS +=
+
+CAMLP4PACKS[]=
+    monad-custom
+
+OCAMLPACKS[]= 
+    spotlib
+    llvm
+
+OCAML_PREINSTALLED_PACKS += llvm
+
+OCAMLDEPFLAGS= -syntax camlp4o -package monad-custom
+OCAMLPPFLAGS= -syntax camlp4o -package monad-custom
+
+FILES[] =
+   extension
+   context
+   type_intf
+   type
+   type_ctxt
+   value_intf
+   value
+   gep
+   value_ctxt
+   module_intf
+   module
+   build_intf
+   build
+   wrap_intf
+   wrap
+   genvalue
+   std
+
+OCAML_LIBS +=
+OCAML_CLIBS +=
+OCAML_OTHER_LIBS +=
+OCAML_LIB_FLAGS +=
+
+MyOCamlPackage(llvm_phantom, $(FILES), $(EMPTY), $(EMPTY))
+
+printer: printer.ml
+    ocamlfind ocamlc -linkpkg -package spotlib -o printer printer.ml
+
+Subdirs()

File lib/build.ml

View file
  • Ignore whitespace
+open Spotlib.Spot
+module P = Spotlib.Spot.Phantom
+open P.Open
+
+module Builder = struct
+  include Monad.Make(struct
+    type 'a t = Llvm.llbuilder -> 'a
+    let bind a f = fun builder ->
+      let a = a builder in
+      f a builder
+    let return a = fun _builder -> a
+  end)
+end
+open Builder.Open
+
+module Make(Module : Module_intf.S) = struct
+  module Type = Type_ctxt.Make(Module)
+  module Value = Value_ctxt.Make(Module)
+  open Type
+  open Value
+
+  module Module = Module
+
+  (** Builder monad *)
+
+  (* CR jfuruse: Builder is independent from Module. It can be somewhere else. *)
+  module Monad = struct
+    include Builder
+    let run v = v (Llvm.builder Module.context)
+  end
+  type 'a m = 'a Monad.t
+  let build = Monad.run
+  let unknownM (v : 'a v m) : unknown v m = v >>= fun v -> return (!?v)
+  let magicM (v : 'a v m) : 'b v m = perform v <-- v; return (P.magic v)
+  let unsafeM v = perform v <-- v; return (P.unsafe v)
+
+  (** Function calls *)
+
+  let call 
+      ?(name="called") (* CR jfuruse: called + f's name *)
+      (f : ('args -> 'ret) pointer v)
+      (args : 'args vs)
+      : 'ret v m = 
+    (* If its return type is void, we erase the name *)
+    let name = 
+      match classify (function_return (element (type_of f))) with
+      | Llvm.TypeKind.Void -> ""
+      | _ -> name
+    in
+    unsafeM (Llvm.build_call !<f (P.List.to_array args) name)
+
+  let call_va_args
+      ?(name="called")
+      (f : ('args -> dots -> 'ret) pointer v)
+      (args : 'args vs)
+      (va_args : unknown v list)
+      : 'ret v m = 
+    let name = 
+      match classify (function_return (element (type_of f))) with
+      | Llvm.TypeKind.Void -> ""
+      | _ -> name
+    in
+    unsafeM (Llvm.build_call !<f (Array.of_list (P.List.to_list args 
+                                            @ List.map (!<) va_args)) name)
+
+
+  (** String *)
+
+  let global_stringptr ?(name="stringptr") str : i8 pointer v m = 
+    unsafeM (Llvm.build_global_stringptr str name)
+
+  (** Pointers *)
+
+  let is_null ?(name="is_null") (lv : 'a pointer v) : i1 v m = 
+    unsafeM (Llvm.build_is_null !<lv name)
+
+  (** Casts *)
+
+  let cast_name ?name v lty = match name with
+    | Some n -> n
+    | None ->
+        let name = Value.name v in
+        let name = try String.sub name 0 (String.rindex name '=') with Not_found -> name in
+        name ^ "=" ^ Type.string_of lty
+
+  let bitcast ?name v lty = 
+    let name = cast_name ?name v lty in
+    unsafeM (Llvm.build_bitcast !<v !<lty name)
+
+  let pointercast ?name v lty = 
+    let name = cast_name ?name v lty in
+    unsafeM (Llvm.build_pointercast !<v !<lty name)
+
+  let intcast ?name v lty = 
+    let name = cast_name ?name v lty in
+    unsafeM (Llvm.build_intcast !<v !<lty name)
+
+  (** Load/Store. Unsafe and type-safe versions *)
+
+  let load 
+      ?(name="loaded")
+      (v : 'ty pointer v)
+      : 'ty v m = 
+    unsafeM (Llvm.build_load !<v name)
+
+  let store 
+      (x : 'a v)
+      ~dst:(dst : 'a pointer v)
+      : unit m = 
+    Monad.ignore (Llvm.build_store !<x !<dst)
+
+  (* unsafe *)
+  let unsafe_gep 
+      ?(name = "gepped")
+      (v : 'a pointer v)
+      (xs : i32 v list)
+      : 'unsafe pointer v m = 
+    unsafeM (Llvm.build_gep !<v (Array.of_list (List.map (!<) xs)) name)
+
+  let gep_gen ?name cont v = Gep.gen (fun lst ->
+    let lst = List.map (function
+      | `int n -> Const.i32_of_int n
+      | `llvalue i -> P.unsafe i) lst in
+    perform
+      ptr <-- unsafe_gep ?name v lst;
+    cont ptr)
+
+  let gep ?name v = gep_gen ?name return v
+  let gep_load ?name v = gep_gen (load ?name) v
+  let gep_store x ~dst:v = gep_gen (fun ptr -> store x ~dst:ptr) v
+
+  let unsafe_const_load ?name ptr indices = perform
+    gepped <-- unsafe_gep ~name:"for_load" ptr (List.map Const.i32_of_int indices);
+    load ?name gepped
+
+  (* opposite order! *)
+  let unsafe_const_store ptr indices lv = perform
+      gepped <-- unsafe_gep ~name:"for_store" ptr (List.map Const.i32_of_int indices);
+      Monad.ignore (store lv ~dst:gepped)
+
+  (** Arithmetic operations *)
+
+  (* CR jfuruse: unfortunately no arith type check is done yet *)      
+  let arith (defname : string) f = 
+    fun ?(name=defname) (x : 'a v) (y : 'a v) ->
+      (unsafeM (f !<x !<y name) : 'a v m)
+  let cmp (defname : string) f = 
+    fun ?(name=defname) (x : 'a v) (y : 'a v) ->
+      (unsafeM (f !<x !<y name) : i1 v m)
+
+  let add  ?name = arith "added" Llvm.build_add ?name
+  let sub  ?name = arith "subed" Llvm.build_sub ?name
+  let mul  ?name = arith "muled" Llvm.build_mul ?name
+  let sdiv ?name = arith "sdived" Llvm.build_sdiv ?name
+  let fadd ?name = arith "fadded" Llvm.build_fadd ?name
+  let fsub ?name = arith "fsubed" Llvm.build_fsub ?name
+  let fmul ?name = arith "fmuled" Llvm.build_fmul ?name
+  let fdiv ?name = arith "fdived" Llvm.build_fdiv ?name
+  let icmp c = cmp "icmped" (Llvm.build_icmp c)
+  let fcmp c = cmp "fcmped" (Llvm.build_fcmp c)
+
+  (** Arithmetic type conversion *)
+
+  let sitofp ?(name="sitofped") i ty = 
+    unsafeM ^$ Llvm.build_sitofp !<i !<ty name
+
+  (** Memory *)
+
+  let alloca ?(name="inStack") ty =
+    unsafeM ^$ Llvm.build_alloca !<ty name
+
+  (** Useful libc functions *)
+
+  let printf : string -> unknown v list -> unit m = 
+    fun fmt args -> perform
+      fmt <-- global_stringptr ~name:"fmt" fmt;
+      Monad.ignore (call_va_args (Module.External.printf) (P.c1 fmt) args ~name:"res")
+  ;;
+
+  let memcpy ~dst ~src ~size = call ~name:"copied" Module.External.memcpy (P.c3 dst src size)
+
+  let bzero dst ~size = Monad.ignore (call Module.External.bzero (P.c2 dst size))
+
+  let malloc : ?name:string -> ?bzero:bool -> i32 v -> void_pointer v m =
+    fun ?(name="alloced") ?bzero:(zero=false) size -> perform
+      ptr <-- call ~name Module.External.malloc (P.c1 size);
+      if zero then bzero ptr ~size else return ();
+      return ptr
+  ;;
+
+  let malloc_by_ty ?name ?bzero (lty : 'ty typ) = perform
+    ptr <-- malloc ?name ?bzero (size_of lty);
+    bitcast ptr (pointer lty)
+
+  let free ptr = perform
+    ptr <-- bitcast ptr pointer_void;
+    Monad.ignore (call Module.External.free (P.c1 ptr))
+  ;;
+
+  (** Control flow codegens *)
+
+  let ret x : unit m = Monad.ignore (Llvm.build_ret !<x)
+  let ret_void : unit m = Monad.ignore Llvm.build_ret_void
+
+  let phi 
+      ?(name="phi")
+      (lst : ('a v * Llvm.llbasicblock) list)
+      : 'a v m =
+    unsafeM (Llvm.build_phi (List.map (fun (v, b) -> !<v, b) lst) name)
+
+  let cond_br 
+      (b : i1 v)
+      bthen belse
+      : unit m
+      = Monad.ignore (Llvm.build_cond_br !<b bthen belse)
+
+  let br b = Monad.ignore (Llvm.build_br b)
+
+  (** Basic blocks *)
+
+  module Block = struct
+    let position_at_end = Llvm.position_at_end
+    let insertion = Llvm.insertion_block
+
+    (* They are independent from the builder *) 	
+    let append ?(name="block") (v : ('a -> 'b) pointer v) = Llvm.append_block Module.context name !<v  
+    let parent bb : ('a -> 'b) pointer v = P.unsafe (Llvm.block_parent bb)
+  end
+
+  let func name (ty_ret : 'ret typ) (args : ('args, (string * Llvm.lltype)) P.ts) 
+      ?(dump=false)
+      (f : ('args -> 'ret) pointer v -> 'args vs -> 'ret v m) : ('args -> 'ret) pointer v m =
+    (* Format.eprintf "Creating function %s@." name; *)
+    let lty = function_ ty_ret (P.List.map snd args) in
+    let lv_f = match Module.Function.lookup name with
+      | Some _ -> failwithf "LLib.create_fun: function %s is defined more than once" name
+      | None -> Module.Function.declare name lty
+    in
+    (* name args *)
+    List.iter2 (fun lv_param name ->
+      Value.set_name name lv_param) 
+      (P.List.to_unknown_list (function_params lv_f))
+      (P.List.to_list (P.List.map fst args));
+    let bb = Block.append ~name:"entry" lv_f in
+    perform 
+      Block.position_at_end bb;
+      lv_body <-- f lv_f (function_params lv_f);
+      (* Finish off the function. *)
+      if classify ty_ret = Llvm.TypeKind.Void then ret_void else ret lv_body;
+      (* Validate the generated code, checking for consistency. *)
+      \ if dump then Value.dump lv_f;
+      \ Analysis.assert_valid_function lv_f;
+      (* Optimize the function *)
+      \ Module.PassManager.run_function_if_opt lv_f;
+      (* \ Format.eprintf "Created function %s@." name; *)
+      return lv_f
+
+  let func0 name ?dump ret () f = func name ?dump ret P.c0 (fun self -> P.uncurry0 (f self))
+  let func1 name ?dump ret (arg0,t0) f = func name ?dump ret (P.c1 (P.combine arg0 t0)) (fun self -> P.uncurry1 (f self))
+  let func2 name ?dump ret (arg0,t0) (arg1,t1) f = func name ?dump ret (P.c2 (P.combine arg0 t0) (P.combine arg1 t1)) (fun self -> P.uncurry2 (f self))
+  let func3 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) f = func name ?dump ret (P.c3 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2)) (fun self -> P.uncurry3 (f self))
+  let func4 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) f = func name ?dump ret (P.c4 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3)) (fun self -> P.uncurry4 (f self))
+  let func5 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) f = func name ?dump ret (P.c5 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4)) (fun self -> P.uncurry5 (f self))
+  let func6 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) f = func name ?dump ret (P.c6 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5)) (fun self -> P.uncurry6 (f self))
+  let func7 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) (arg6,t6) f = func name ?dump ret (P.c7 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5) (P.combine arg6 t6)) (fun self -> P.uncurry7 (f self))
+  let func8 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) (arg6,t6) (arg7,t7) f = func name ?dump ret (P.c8 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5) (P.combine arg6 t6) (P.combine arg7 t7)) (fun self -> P.uncurry8 (f self))
+  let func9 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) (arg6,t6) (arg7,t7) (arg8,t8) f = func name ?dump ret (P.c9 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5) (P.combine arg6 t6) (P.combine arg7 t7) (P.combine arg8 t8)) (fun self -> P.uncurry9 (f self))
+  let func10 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) (arg6,t6) (arg7,t7) (arg8,t8) (arg9,t9) f = func name ?dump ret (P.c10 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5) (P.combine arg6 t6) (P.combine arg7 t7) (P.combine arg8 t8) (P.combine arg9 t9)) (fun self -> P.uncurry10 (f self))
+
+  (* stupid lambda abstraction is required for polymorphism *)    
+  let current_function : unit -> ('a -> 'b) pointer v m = fun () -> perform
+    current_bb <-- Block.insertion;
+    return (Block.parent current_bb)
+
+  let append_code_block name (codegen : 'a m) : (Llvm.llbasicblock * 'a * Llvm.llbasicblock) m = perform
+    the_function <-- current_function ();
+    let bb = Block.append ~name the_function in
+    (* Emit value. *)
+    Block.position_at_end bb;
+    res <-- codegen;
+    (* Codegen of [res] can change the current block, update bb for the phi. *)
+    new_bb <-- Block.insertion;
+    return (bb, res, new_bb)
+
+  (** Connecting basic blocks *)
+
+  let return_void : void v m = (fun _builder -> P.magic Const.i32_0)
+    (* The return value looks strange but probably ok. Probably. *)
+
+  let uncond_br from to_ = perform
+    Block.position_at_end from;
+    Monad.ignore (br to_)
+
+  let if_then_else (lv_cond : i1 v m) (lv_then : 'a v m) (lv_else : 'a v m) : 'a v m = perform
+    (* get the current bb *)
+    start_bb <-- Block.insertion;
+
+    lv_cond <-- lv_cond; (* created in [start_bb] *)
+    (* before adding branching, we must create the destinations *)
+
+    (then_bb, lv_then, new_then_bb) <-- append_code_block "then" lv_then;
+    (else_bb, lv_else, new_else_bb) <-- append_code_block "else" lv_else;
+
+    (* merge_bb and new_merge_bb should be the same *)
+    (merge_bb, phi, new_merge_bb) <-- append_code_block "ifcont" begin
+      let incoming = [(lv_then, new_then_bb); (lv_else, new_else_bb)] in
+      (* Llvm.build_phi returns the merged value, which can be used the
+         return of the entire (if ...) *)
+      phi incoming ~name:"iftmp"
+    end;
+
+    (* Return to the start block to add the conditional branch. *)
+    Block.position_at_end start_bb;
+    cond_br lv_cond then_bb else_bb;
+
+    (* Set a unconditional branch at the end of the 'then' block and the
+     * 'else' block to the 'merge' block. *)
+    uncond_br new_then_bb merge_bb;
+    uncond_br new_else_bb merge_bb;
+
+    (* Finally, set the G.builder to the end of the merge block. *)
+    Block.position_at_end new_merge_bb;
+
+    return phi
+
+  let imp_if_then_else (lv_cond : i1 v m) (lv_then : unit m) (lv_else : unit m) : unit m = perform
+    (* get the current bb *)
+    start_bb <-- Block.insertion;
+
+    lv_cond <-- lv_cond; (* created in [start_bb] *)
+    (* before adding branching, we must create the destinations *)
+
+    (then_bb, (), new_then_bb) <-- append_code_block "then" lv_then;
+    (else_bb, (), new_else_bb) <-- append_code_block "else" lv_else;
+
+    (* merge_bb and new_merge_bb should be the same *)
+    (merge_bb, (), new_merge_bb) <-- append_code_block "ifcont" (return ());
+
+    (* Return to the start block to add the conditional branch. *)
+    Block.position_at_end start_bb;
+    cond_br lv_cond then_bb else_bb;
+
+    (* Set a unconditional branch at the end of the 'then' block and the
+     * 'else' block to the 'merge' block. *)
+    uncond_br new_then_bb merge_bb;
+    uncond_br new_else_bb merge_bb;
+
+    (* Finally, set the G.builder to the end of the merge block. *)
+    Block.position_at_end new_merge_bb;
+
+    return ()
+
+  let for_loop 
+      (init : 'a v) (* initialization of the loop variable of type 'a v *)
+      (cond : 'a v -> i1 v m) (* test on the loop variable *)
+      (do_ : 'a v -> 'a v m) (* do the job and update the loop variable *) = perform
+    start_bb <-- Block.insertion;
+    current_function <-- current_function ();
+
+    (phi_enter, phi, phi_exit) <-- append_code_block "phi" (
+      perform
+        let incoming = [(init, start_bb)] in (* do is not prepared. Added later. *)
+        phi incoming ~name:"fortmp");
+
+    (do_enter,   do_,  do_exit)   <-- append_code_block "do" (do_ phi);
+    \ Llvm.add_incoming (!<do_, do_exit) !<phi; (* now we can add the other incoming *)
+
+    let exit_bb = Block.append ~name:"exit" current_function in
+
+    (cond_enter, _cond, _cond_exit) <-- append_code_block "cond" (perform
+      cond <-- cond phi;
+      cond_br cond do_enter exit_bb;
+      return cond);
+
+    uncond_br start_bb phi_enter;
+    uncond_br do_exit phi_enter;
+    uncond_br phi_exit cond_enter;
+
+    Block.position_at_end exit_bb;
+
+    return ()
+
+  (** Execution *)
+
+  let exec =
+    let cntr = ref 0 in
+    fun (v : unit m) ->
+      incr cntr;
+      let name = Printf.sprintf "lbuilder.exec%d" !cntr in
+      Format.eprintf "Executing %s...@." name;
+      let f : (unit -> void) pointer v =
+        let proto = function_ void P.c0 in
+        match Module.Function.lookup name with
+        | Some _ -> failwithf "function %s is defined more than once" name
+        | None -> Module.Function.declare name proto
+      in
+      prerr_endline "proto done";
+      (* Create a new basic block to start insertion into. *)
+      Monad.run (perform
+        let bb = Block.append ~name:"entry" f in
+        Block.position_at_end bb;
+        v; (* create the code *)
+        ret_void);
+      (* Optimize the function *)
+      Value.dump f;
+      Module.PassManager.run_function_if_opt f;
+      Analysis.assert_valid_function f;
+      Format.eprintf "Now running %s@." name;
+      ignore (Module.ExecutionEngine.run_function f P.c0);
+      Format.eprintf "Done running %s@." name;
+end

File lib/build.mli

View file
  • Ignore whitespace
+module Make(Module : Module_intf.S) : Build_intf.S

File lib/build_intf.ml

View file
  • Ignore whitespace
+open Spotlib.Spot
+open Spotlib.Spot.Phantom
+open Type
+open Value
+
+module type S = sig
+
+  (** Builder monad *)
+
+  module Monad : sig
+    include Monad_intf.T with type 'a t = Llvm.llbuilder -> 'a
+    val run : 'a t -> 'a
+  end
+  type 'a m = 'a Monad.t
+
+  val build : 'a m -> 'a
+    (** [build m] runs the code gen store in the monad [m] *)
+
+  (** Lifted value coercions *)      
+  val unknownM : 'a v m -> unknown v m
+  val magicM : 'a v m -> 'b v m
+
+
+
+  (** Function calls *)
+
+  val call : ?name:string -> ('a -> 'b) pointer v -> 'a vs -> 'b v m
+  val call_va_args : ?name: string -> ('a -> dots -> 'b) pointer v -> 'a vs -> unknown v list -> 'b v m
+
+
+
+  (** String *)
+  val global_stringptr : ?name:string -> string -> i8 pointer v m
+
+
+
+  (** Pointers *)
+
+  val is_null : ?name:string -> 'a pointer v -> i1 v m
+
+
+
+  (** Casts *)
+
+  val bitcast : ?name:string -> 'a v -> 'b typ -> 'b v m
+  val pointercast : ?name:string -> 'a pointer v -> ([>`int] as 'b) typ -> 'b v m
+  val intcast : ?name:string -> [>`int] v -> ([>`int] as 'a) typ -> 'a v m
+
+
+
+  (** Load/Store. Unsafe and type-safe versions *)
+
+  val unsafe_gep : ?name:string -> 'a pointer v -> i32 v list -> 'unsafe pointer v m
+    
+  (** Type-safe GEP
+      
+      Do not be fooled by those complex types. They are pretty easy to use:
+
+      [gep v acc1 acc2 ... accn Gep.end_] provides a type safe version of 
+      [unsafe_gep v [<acc1>; <acc2>; .. ; <accn>]].
+
+      Here acci is an accessor, one of the followings:
+       - [Gep.pos n] : Accessing n-th pointer/array/vector elements
+       - [Gep.pos_i32 n] : Accessing n-th pointer/array/vector elements by llvalue
+       - [Gep.mem<i>] : Accessing n-th element of struct
+
+      You must give appropriate accessors: 
+      for example, you cannot use [pos n] for n-th element of struct.
+
+      Do not forget to put Gep.end_ at the end of the accessor list.
+
+      Examples:
+
+        - Obtain i32* from i32[20]* p, which points to p[0][n]
+            gep pointer (Gep.pos_const 0) (Gep.pos n) Gep.end_ : i32 pointer v m
+        - Obtain i32* from {i1, i16, i32, i64}* p, which points to the i32 element of the struct *p.
+            gep pointer (Gep.pos_const 0) Gep.mem2 Gep.end_ : i32 pointer v m
+
+      Type-safe GEP + load/store
+
+      GEP and load/store are often used in conjunctions, gep_load and gep_store are available for such cases:
+
+        - Load i32 p[0][n] of i32[20]* p
+            gep_load pointer (Gep.pos_const 0) (Gep.pos n) Gep.end_ : i32 v m 
+        - Store the i32 element [v] to the 2nd element of {i1, i16, i32, i64}* p
+            gep_store v ~dst:pointer (Gep.pos_const 0) Gep.mem2 Gep.end_ : i32 v m 
+  *)
+  val gep : ?name:string 
+            -> 'a pointer v
+            -> (('a pointer, 'x, 'x pointer v m) Gep.t -> 'b)
+            -> 'b
+  val gep_load : ?name:string 
+            -> 'a pointer v
+            -> (('a pointer, 'x, 'x v m) Gep.t -> 'b)
+            -> 'b
+  val gep_store : 'x v
+            -> dst:'a pointer v
+            -> (('a pointer, 'x, unit m) Gep.t -> 'b)
+            -> 'b
+
+  val load : ?name:string -> 'a pointer v -> 'a v m
+  val store : 'a v -> dst:'a pointer v -> unit m
+
+  val unsafe_const_load : ?name:string -> 'a pointer v -> int list -> 'unsafe v m
+  val unsafe_const_store : 'a pointer v -> int list -> 'unsafe v -> unit m
+
+
+
+  (** Arithmetic operations *)
+
+  val add :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
+  val sub :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
+  val mul :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
+  val sdiv : ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
+  val fadd : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
+  val fsub : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
+  val fmul : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
+  val fdiv : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
+  val icmp : Llvm.Icmp.t -> ?name:string -> ([>`int] as 'a) v -> 'a v -> i1 v m
+  val fcmp : Llvm.Fcmp.t -> ?name:string -> ([>`floating] as 'a) v -> 'a v -> i1 v m
+
+
+  (** Arithmetic type conversion *)
+
+  val sitofp : ?name:string -> [>`int] v -> ([>`floating] as 'a) typ -> 'a v m
+
+
+  (** Memory *)
+
+  val alloca : ?name:string -> 'a typ -> 'a pointer v m
+
+