llvm.org GIT mirror llvm / 49457b8
Add OCaml tutorial to the examples. git-svn-id: https://llvm.org/svn/llvm-project/llvm/trunk@97966 91177308-0d34-0410-b5e6-96231b3b80d8 Erick Tryzelaar 9 years ago
65 changed file(s) with 3511 addition(s) and 32 deletion(s). Raw diff Collapse all Expand all
6565 Compile.CMX := $(strip $(OCAMLOPT) -c $(OCAMLCFLAGS) $(OCAMLDEBUGFLAG) -o)
6666 Archive.CMXA := $(strip $(OCAMLOPT) -a $(OCAMLAFLAGS) $(OCAMLDEBUGFLAG) -o)
6767
68 ifdef OCAMLOPT
69 Archive.EXE := $(strip $(OCAMLOPT) -cc $(CXX) $(OCAMLCFLAGS) $(UsedOcamLibs:%=%.cmxa) $(OCAMLDEBUGFLAG) -o)
70 else
71 Archive.EXE := $(strip $(OCAMLC) -cc $(CXX) $(OCAMLCFLAGS) $(OCAMLDEBUGFLAG:%=%.cma) -o)
72 endif
73
6874 # Source files
6975 OcamlSources1 := $(sort $(wildcard $(PROJ_SRC_DIR)/*.ml))
70 OcamlHeaders1 := $(OcamlSources1:.ml=.mli)
71
72 OcamlSources := $(OcamlSources1:$(PROJ_SRC_DIR)/%=$(ObjDir)/%)
73 OcamlHeaders := $(OcamlHeaders1:$(PROJ_SRC_DIR)/%=$(ObjDir)/%)
76 OcamlHeaders1 := $(sort $(wildcard $(PROJ_SRC_DIR)/*.mli))
77
78 OcamlSources2 := $(filter-out $(ExcludeSources),$(OcamlSources1))
79 OcamlHeaders2 := $(filter-out $(ExcludeHeaders),$(OcamlHeaders1))
80
81 OcamlSources := $(OcamlSources2:$(PROJ_SRC_DIR)/%=$(ObjDir)/%)
82 OcamlHeaders := $(OcamlHeaders2:$(PROJ_SRC_DIR)/%=$(ObjDir)/%)
7483
7584 # Intermediate files
76 LibraryCMA := $(ObjDir)/$(LIBRARYNAME).cma
77 LibraryCMXA := $(ObjDir)/$(LIBRARYNAME).cmxa
7885 ObjectsCMI := $(OcamlSources:%.ml=%.cmi)
7986 ObjectsCMO := $(OcamlSources:%.ml=%.cmo)
8087 ObjectsCMX := $(OcamlSources:%.ml=%.cmx)
8188
89 ifdef LIBRARYNAME
90 LibraryCMA := $(ObjDir)/$(LIBRARYNAME).cma
91 LibraryCMXA := $(ObjDir)/$(LIBRARYNAME).cmxa
92 endif
93
94 ifdef TOOLNAME
95 ToolEXE := $(ObjDir)/$(TOOLNAME)$(EXEEXT)
96 endif
97
8298 # Output files
8399 # The .cmo files are the only intermediates; all others are to be installed.
100 OutputsCMI := $(ObjectsCMI:$(ObjDir)/%.cmi=$(OcamlDir)/%.cmi)
101 OutputsCMX := $(ObjectsCMX:$(ObjDir)/%.cmx=$(OcamlDir)/%.cmx)
102 OutputLibs := $(UsedLibNames:%=$(OcamlDir)/%)
103
104 ifdef LIBRARYNAME
84105 LibraryA := $(OcamlDir)/lib$(LIBRARYNAME).a
85106 OutputCMA := $(LibraryCMA:$(ObjDir)/%.cma=$(OcamlDir)/%.cma)
86107 OutputCMXA := $(LibraryCMXA:$(ObjDir)/%.cmxa=$(OcamlDir)/%.cmxa)
87 OutputsCMI := $(ObjectsCMI:$(ObjDir)/%.cmi=$(OcamlDir)/%.cmi)
88 OutputsCMX := $(ObjectsCMX:$(ObjDir)/%.cmx=$(OcamlDir)/%.cmx)
89 OutputLibs := $(UsedLibNames:%=$(OcamlDir)/%)
108 endif
109
110 ifdef TOOLNAME
111 ifdef EXAMPLE_TOOL
112 OutputEXE := $(ExmplDir)/$(strip $(TOOLNAME))$(EXEEXT)
113 else
114 OutputEXE := $(ToolDir)/$(strip $(TOOLNAME))$(EXEEXT)
115 endif
116 endif
90117
91118 # Installation targets
119 DestLibs := $(UsedLibNames:%=$(PROJ_libocamldir)/%)
120
121 ifdef LIBRARYNAME
92122 DestA := $(PROJ_libocamldir)/lib$(LIBRARYNAME).a
93123 DestCMA := $(PROJ_libocamldir)/$(LIBRARYNAME).cma
94124 DestCMXA := $(PROJ_libocamldir)/$(LIBRARYNAME).cmxa
95 DestLibs := $(UsedLibNames:%=$(PROJ_libocamldir)/%)
96
125 endif
97126
98127 ##===- Dependencies -------------------------------------------------------===##
99128 # Copy the sources into the intermediate directory because older ocamlc doesn't
105134 $(ObjDir)/%.ml: $(PROJ_SRC_DIR)/%.ml $(ObjDir)/.dir
106135 $(Verb) $(CP) -f $< $@
107136
137 $(ObjectsCMI): $(UsedOcamlInterfaces:%=$(OcamlDir)/%.cmi)
138
139 ifdef LIBRARYNAME
108140 $(ObjDir)/$(LIBRARYNAME).ocamldep: $(OcamlSources) $(OcamlHeaders) \
109141 $(OcamlDir)/.dir $(ObjDir)/.dir
110142 $(Verb) $(OCAMLDEP) $(OCAMLCFLAGS) $(OcamlSources) $(OcamlHeaders) > $@
111143
112 $(ObjectsCMI): $(UsedOcamlInterfaces:%=$(OcamlDir)/%.cmi)
113
114144 -include $(ObjDir)/$(LIBRARYNAME).ocamldep
115
145 endif
146
147 ifdef TOOLNAME
148 $(ObjDir)/$(TOOLNAME).ocamldep: $(OcamlSources) $(OcamlHeaders) \
149 $(OcamlDir)/.dir $(ObjDir)/.dir
150 $(Verb) $(OCAMLDEP) $(OCAMLCFLAGS) $(OcamlSources) $(OcamlHeaders) > $@
151
152 -include $(ObjDir)/$(TOOLNAME).ocamldep
153 endif
116154
117155 ##===- Build static library from C sources --------------------------------===##
118156
119 ifneq ($(ObjectsO),)
157 ifdef LibraryA
120158 all-local:: $(LibraryA)
121159 clean-local:: clean-a
122160 install-local:: install-a
159197 $(Verb) ln -sf $< $@
160198
161199 clean-deplibs:
162 $(Verb) rm -f $(OutputLibs)
200 $(Verb) $(RM) -f $(OutputLibs)
163201
164202 install-deplibs:
165203 $(Verb) $(MKDIR) $(PROJ_libocamldir)
168206 done
169207
170208 uninstall-deplibs:
171 $(Verb) rm -f $(DestLibs)
209 $(Verb) $(RM) -f $(DestLibs)
172210
173211
174212 ##===- Build ocaml interfaces (.mli's -> .cmi's) --------------------------===##
175213
214 ifneq ($(OcamlHeaders),)
176215 all-local:: build-cmis
177216 clean-local:: clean-cmis
178217 install-local:: install-cmis
211250 $(EchoCmd) "Uninstalling $(PROJ_libocamldir)/$$i"; \
212251 $(RM) -f "$(PROJ_libocamldir)/$$i"; \
213252 done
253 endif
214254
215255
216256 ##===- Build ocaml bytecode archive (.ml's -> .cmo's -> .cma) -------------===##
217257
258 $(ObjDir)/%.cmo: $(ObjDir)/%.ml
259 $(Echo) "Compiling $(notdir $<) for $(BuildMode) build"
260 $(Verb) $(Compile.CMO) $@ $<
261
262 ifdef LIBRARYNAME
218263 all-local:: $(OutputCMA)
219264 clean-local:: clean-cma
220265 install-local:: install-cma
227272 $(Echo) "Archiving $(notdir $@) for $(BuildMode) build"
228273 $(Verb) $(Archive.CMA) $@ $(ObjectsCMO)
229274
230 $(ObjDir)/%.cmo: $(ObjDir)/%.ml
231 $(Echo) "Compiling $(notdir $<) for $(BuildMode) build"
232 $(Verb) $(Compile.CMO) $@ $<
233
234275 clean-cma::
235276 $(Verb) $(RM) -f $(OutputCMA) $(UsedLibNames:%=$(OcamlDir)/%)
236277
242283 uninstall-cma::
243284 $(Echo) "Uninstalling $(DestCMA)"
244285 -$(Verb) $(RM) -f $(DestCMA)
245
286 endif
246287
247288 ##===- Build optimized ocaml archive (.ml's -> .cmx's -> .cmxa, .a) -------===##
248289
250291 # If unavailable, 'configure' will not define OCAMLOPT in Makefile.config.
251292 ifdef OCAMLOPT
252293
294 $(OcamlDir)/%.cmx: $(ObjDir)/%.cmx
295 $(Verb) $(CP) -f $< $@
296
297 $(ObjDir)/%.cmx: $(ObjDir)/%.ml
298 $(Echo) "Compiling optimized $(notdir $<) for $(BuildMode) build"
299 $(Verb) $(Compile.CMX) $@ $<
300
301 ifdef LIBRARYNAME
253302 all-local:: $(OutputCMXA) $(OutputsCMX)
254303 clean-local:: clean-cmxa
255304 install-local:: install-cmxa
259308 $(Verb) $(CP) -f $< $@
260309 $(Verb) $(CP) -f $(<:.cmxa=.a) $(@:.cmxa=.a)
261310
262 $(OcamlDir)/%.cmx: $(ObjDir)/%.cmx
263 $(Verb) $(CP) -f $< $@
264
265311 $(LibraryCMXA): $(ObjectsCMX)
266312 $(Echo) "Archiving $(notdir $@) for $(BuildMode) build"
267313 $(Verb) $(Archive.CMXA) $@ $(ObjectsCMX)
268314 $(Verb) $(RM) -f $(@:.cmxa=.o)
269
270 $(ObjDir)/%.cmx: $(ObjDir)/%.ml
271 $(Echo) "Compiling optimized $(notdir $<) for $(BuildMode) build"
272 $(Verb) $(Compile.CMX) $@ $<
273315
274316 clean-cmxa::
275317 $(Verb) $(RM) -f $(OutputCMXA) $(OutputCMXA:.cmxa=.a) $(OutputsCMX)
294336 $(EchoCmd) "Uninstalling $(PROJ_libocamldir)/$$i"; \
295337 $(RM) -f $(PROJ_libocamldir)/$$i; \
296338 done
297
339 endif
340 endif
341
342 ##===- Build executables --------------------------------------------------===##
343
344 ifdef TOOLNAME
345 all-local:: $(OutputEXE)
346 clean-local:: clean-exe
347
348 $(OutputEXE): $(ToolEXE) $(OcamlDir)/.dir
349 $(Verb) $(CP) -f $< $@
350
351 ifndef OCAMLOPT
352 $(ToolEXE): $(ObjectsCMO) $(OcamlDir)/.dir
353 $(Echo) "Archiving $(notdir $@) for $(BuildMode) build"
354 $(Verb) $(Archive.EXE) $@ $<
355 else
356 $(ToolEXE): $(ObjectsCMX) $(OcamlDir)/.dir
357 $(Echo) "Archiving $(notdir $@) for $(BuildMode) build"
358 $(Verb) $(Archive.EXE) $@ $<
359 endif
298360 endif
299361
300362 ##===- Generate documentation ---------------------------------------------===##
324386 $(Echo) "LibraryCMA : " '$(LibraryCMA)'
325387 $(Echo) "LibraryCMXA : " '$(LibraryCMXA)'
326388 $(Echo) "OcamlSources1: " '$(OcamlSources1)'
389 $(Echo) "OcamlSources2: " '$(OcamlSources2)'
327390 $(Echo) "OcamlSources : " '$(OcamlSources)'
391 $(Echo) "OcamlHeaders1: " '$(OcamlHeaders1)'
392 $(Echo) "OcamlHeaders2: " '$(OcamlHeaders2)'
328393 $(Echo) "OcamlHeaders : " '$(OcamlHeaders)'
329394 $(Echo) "ObjectsCMI : " '$(ObjectsCMI)'
330395 $(Echo) "ObjectsCMO : " '$(ObjectsCMO)'
339404 .PHONY: printcamlvars build-cmis \
340405 clean-a clean-cmis clean-cma clean-cmxa \
341406 install-a install-cmis install-cma install-cmxa \
342 uninstall-a uninstall-cmis uninstall-cma uninstall-cmxa
407 install-exe \
408 uninstall-a uninstall-cmis uninstall-cma uninstall-cmxa \
409 uninstall-exe
99
1010 include $(LEVEL)/Makefile.config
1111
12 PARALLEL_DIRS:= BrainF Fibonacci HowToUseJIT Kaleidoscope ModuleMaker
12 PARALLEL_DIRS:= BrainF Fibonacci HowToUseJIT Kaleidoscope ModuleMaker \
13 OCaml-Kaleidoscope
1314
1415 ifeq ($(HAVE_PTHREAD),1)
1516 PARALLEL_DIRS += ParallelJIT
0 ##===- examples/OCaml-Kaleidoscope/Chapter2/Makefile -------*- Makefile -*-===##
1 #
2 # The LLVM Compiler Infrastructure
3 #
4 # This file is distributed under the University of Illinois Open Source
5 # License. See LICENSE.TXT for details.
6 #
7 ##===----------------------------------------------------------------------===##
8 #
9 # This is the makefile for the Objective Caml kaleidoscope tutorial, chapter 2.
10 #
11 ##===----------------------------------------------------------------------===##
12
13 LEVEL := ../../..
14 TOOLNAME := OCaml-Kaleidoscope-Ch2
15 EXAMPLE_TOOL := 1
16 UsedComponents := core
17 UsedOcamLibs := llvm
18
19 OCAMLCFLAGS += -pp camlp4of
20
21 include $(LEVEL)/bindings/ocaml/Makefile.ocaml
0 <{lexer,parser}.ml>: use_camlp4, pp(camlp4of)
0 (*===----------------------------------------------------------------------===
1 * Abstract Syntax Tree (aka Parse Tree)
2 *===----------------------------------------------------------------------===*)
3
4 (* expr - Base type for all expression nodes. *)
5 type expr =
6 (* variant for numeric literals like "1.0". *)
7 | Number of float
8
9 (* variant for referencing a variable, like "a". *)
10 | Variable of string
11
12 (* variant for a binary operator. *)
13 | Binary of char * expr * expr
14
15 (* variant for function calls. *)
16 | Call of string * expr array
17
18 (* proto - This type represents the "prototype" for a function, which captures
19 * its name, and its argument names (thus implicitly the number of arguments the
20 * function takes). *)
21 type proto = Prototype of string * string array
22
23 (* func - This type represents a function definition itself. *)
24 type func = Function of proto * expr
0 (*===----------------------------------------------------------------------===
1 * Lexer
2 *===----------------------------------------------------------------------===*)
3
4 let rec lex = parser
5 (* Skip any whitespace. *)
6 | [< ' (' ' | '\n' | '\r' | '\t'); stream >] -> lex stream
7
8 (* identifier: [a-zA-Z][a-zA-Z0-9] *)
9 | [< ' ('A' .. 'Z' | 'a' .. 'z' as c); stream >] ->
10 let buffer = Buffer.create 1 in
11 Buffer.add_char buffer c;
12 lex_ident buffer stream
13
14 (* number: [0-9.]+ *)
15 | [< ' ('0' .. '9' as c); stream >] ->
16 let buffer = Buffer.create 1 in
17 Buffer.add_char buffer c;
18 lex_number buffer stream
19
20 (* Comment until end of line. *)
21 | [< ' ('#'); stream >] ->
22 lex_comment stream
23
24 (* Otherwise, just return the character as its ascii value. *)
25 | [< 'c; stream >] ->
26 [< 'Token.Kwd c; lex stream >]
27
28 (* end of stream. *)
29 | [< >] -> [< >]
30
31 and lex_number buffer = parser
32 | [< ' ('0' .. '9' | '.' as c); stream >] ->
33 Buffer.add_char buffer c;
34 lex_number buffer stream
35 | [< stream=lex >] ->
36 [< 'Token.Number (float_of_string (Buffer.contents buffer)); stream >]
37
38 and lex_ident buffer = parser
39 | [< ' ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' as c); stream >] ->
40 Buffer.add_char buffer c;
41 lex_ident buffer stream
42 | [< stream=lex >] ->
43 match Buffer.contents buffer with
44 | "def" -> [< 'Token.Def; stream >]
45 | "extern" -> [< 'Token.Extern; stream >]
46 | id -> [< 'Token.Ident id; stream >]
47
48 and lex_comment = parser
49 | [< ' ('\n'); stream=lex >] -> stream
50 | [< 'c; e=lex_comment >] -> e
51 | [< >] -> [< >]
0 (*===---------------------------------------------------------------------===
1 * Parser
2 *===---------------------------------------------------------------------===*)
3
4 (* binop_precedence - This holds the precedence for each binary operator that is
5 * defined *)
6 let binop_precedence:(char, int) Hashtbl.t = Hashtbl.create 10
7
8 (* precedence - Get the precedence of the pending binary operator token. *)
9 let precedence c = try Hashtbl.find binop_precedence c with Not_found -> -1
10
11 (* primary
12 * ::= identifier
13 * ::= numberexpr
14 * ::= parenexpr *)
15 let rec parse_primary = parser
16 (* numberexpr ::= number *)
17 | [< 'Token.Number n >] -> Ast.Number n
18
19 (* parenexpr ::= '(' expression ')' *)
20 | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e
21
22 (* identifierexpr
23 * ::= identifier
24 * ::= identifier '(' argumentexpr ')' *)
25 | [< 'Token.Ident id; stream >] ->
26 let rec parse_args accumulator = parser
27 | [< e=parse_expr; stream >] ->
28 begin parser
29 | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e
30 | [< >] -> e :: accumulator
31 end stream
32 | [< >] -> accumulator
33 in
34 let rec parse_ident id = parser
35 (* Call. *)
36 | [< 'Token.Kwd '(';
37 args=parse_args [];
38 'Token.Kwd ')' ?? "expected ')'">] ->
39 Ast.Call (id, Array.of_list (List.rev args))
40
41 (* Simple variable ref. *)
42 | [< >] -> Ast.Variable id
43 in
44 parse_ident id stream
45
46 | [< >] -> raise (Stream.Error "unknown token when expecting an expression.")
47
48 (* binoprhs
49 * ::= ('+' primary)* *)
50 and parse_bin_rhs expr_prec lhs stream =
51 match Stream.peek stream with
52 (* If this is a binop, find its precedence. *)
53 | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c ->
54 let token_prec = precedence c in
55
56 (* If this is a binop that binds at least as tightly as the current binop,
57 * consume it, otherwise we are done. *)
58 if token_prec < expr_prec then lhs else begin
59 (* Eat the binop. *)
60 Stream.junk stream;
61
62 (* Parse the primary expression after the binary operator. *)
63 let rhs = parse_primary stream in
64
65 (* Okay, we know this is a binop. *)
66 let rhs =
67 match Stream.peek stream with
68 | Some (Token.Kwd c2) ->
69 (* If BinOp binds less tightly with rhs than the operator after
70 * rhs, let the pending operator take rhs as its lhs. *)
71 let next_prec = precedence c2 in
72 if token_prec < next_prec
73 then parse_bin_rhs (token_prec + 1) rhs stream
74 else rhs
75 | _ -> rhs
76 in
77
78 (* Merge lhs/rhs. *)
79 let lhs = Ast.Binary (c, lhs, rhs) in
80 parse_bin_rhs expr_prec lhs stream
81 end
82 | _ -> lhs
83
84 (* expression
85 * ::= primary binoprhs *)
86 and parse_expr = parser
87 | [< lhs=parse_primary; stream >] -> parse_bin_rhs 0 lhs stream
88
89 (* prototype
90 * ::= id '(' id* ')' *)
91 let parse_prototype =
92 let rec parse_args accumulator = parser
93 | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
94 | [< >] -> accumulator
95 in
96
97 parser
98 | [< 'Token.Ident id;
99 'Token.Kwd '(' ?? "expected '(' in prototype";
100 args=parse_args [];
101 'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
102 (* success. *)
103 Ast.Prototype (id, Array.of_list (List.rev args))
104
105 | [< >] ->
106 raise (Stream.Error "expected function name in prototype")
107
108 (* definition ::= 'def' prototype expression *)
109 let parse_definition = parser
110 | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
111 Ast.Function (p, e)
112
113 (* toplevelexpr ::= expression *)
114 let parse_toplevel = parser
115 | [< e=parse_expr >] ->
116 (* Make an anonymous proto. *)
117 Ast.Function (Ast.Prototype ("", [||]), e)
118
119 (* external ::= 'extern' prototype *)
120 let parse_extern = parser
121 | [< 'Token.Extern; e=parse_prototype >] -> e
0 (*===----------------------------------------------------------------------===
1 * Lexer Tokens
2 *===----------------------------------------------------------------------===*)
3
4 (* The lexer returns these 'Kwd' if it is an unknown character, otherwise one of
5 * these others for known things. *)
6 type token =
7 (* commands *)
8 | Def | Extern
9
10 (* primary *)
11 | Ident of string | Number of float
12
13 (* unknown *)
14 | Kwd of char
0 (*===----------------------------------------------------------------------===
1 * Top-Level parsing and JIT Driver
2 *===----------------------------------------------------------------------===*)
3
4 (* top ::= definition | external | expression | ';' *)
5 let rec main_loop stream =
6 match Stream.peek stream with
7 | None -> ()
8
9 (* ignore top-level semicolons. *)
10 | Some (Token.Kwd ';') ->
11 Stream.junk stream;
12 main_loop stream
13
14 | Some token ->
15 begin
16 try match token with
17 | Token.Def ->
18 ignore(Parser.parse_definition stream);
19 print_endline "parsed a function definition.";
20 | Token.Extern ->
21 ignore(Parser.parse_extern stream);
22 print_endline "parsed an extern.";
23 | _ ->
24 (* Evaluate a top-level expression into an anonymous function. *)
25 ignore(Parser.parse_toplevel stream);
26 print_endline "parsed a top-level expr";
27 with Stream.Error s ->
28 (* Skip token for error recovery. *)
29 Stream.junk stream;
30 print_endline s;
31 end;
32 print_string "ready> "; flush stdout;
33 main_loop stream
0 (*===----------------------------------------------------------------------===
1 * Main driver code.
2 *===----------------------------------------------------------------------===*)
3
4 let main () =
5 (* Install standard binary operators.
6 * 1 is the lowest precedence. *)
7 Hashtbl.add Parser.binop_precedence '<' 10;
8 Hashtbl.add Parser.binop_precedence '+' 20;
9 Hashtbl.add Parser.binop_precedence '-' 20;
10 Hashtbl.add Parser.binop_precedence '*' 40; (* highest. *)
11
12 (* Prime the first token. *)
13 print_string "ready> "; flush stdout;
14 let stream = Lexer.lex (Stream.of_channel stdin) in
15
16 (* Run the main "interpreter loop" now. *)
17 Toplevel.main_loop stream;
18 ;;
19
20 main ()
0 ##===- examples/OCaml-Kaleidoscope/Chapter3/Makefile -------*- Makefile -*-===##
1 #
2 # The LLVM Compiler Infrastructure
3 #
4 # This file is distributed under the University of Illinois Open Source
5 # License. See LICENSE.TXT for details.
6 #
7 ##===----------------------------------------------------------------------===##
8 #
9 # This is the makefile for the Objective Caml kaleidoscope tutorial, chapter 3.
10 #
11 ##===----------------------------------------------------------------------===##
12
13 LEVEL := ../../..
14 TOOLNAME := OCaml-Kaleidoscope-Ch3
15 EXAMPLE_TOOL := 1
16 UsedComponents := core
17 UsedOcamLibs := llvm llvm_analysis
18
19 OCAMLCFLAGS += -pp camlp4of
20
21 ExcludeSources = $(PROJ_SRC_DIR)/myocamlbuild.ml
22
23 include $(LEVEL)/bindings/ocaml/Makefile.ocaml
0 <{lexer,parser}.ml>: use_camlp4, pp(camlp4of)
1 <*.{byte,native}>: g++, use_llvm, use_llvm_analysis
0 (*===----------------------------------------------------------------------===
1 * Abstract Syntax Tree (aka Parse Tree)
2 *===----------------------------------------------------------------------===*)
3
4 (* expr - Base type for all expression nodes. *)
5 type expr =
6 (* variant for numeric literals like "1.0". *)
7 | Number of float
8
9 (* variant for referencing a variable, like "a". *)
10 | Variable of string
11
12 (* variant for a binary operator. *)
13 | Binary of char * expr * expr
14
15 (* variant for function calls. *)
16 | Call of string * expr array
17
18 (* proto - This type represents the "prototype" for a function, which captures
19 * its name, and its argument names (thus implicitly the number of arguments the
20 * function takes). *)
21 type proto = Prototype of string * string array
22
23 (* func - This type represents a function definition itself. *)
24 type func = Function of proto * expr
0 (*===----------------------------------------------------------------------===
1 * Code Generation
2 *===----------------------------------------------------------------------===*)
3
4 open Llvm
5
6 exception Error of string
7
8 let context = global_context ()
9 let the_module = create_module context "my cool jit"
10 let builder = builder context
11 let named_values:(string, llvalue) Hashtbl.t = Hashtbl.create 10
12 let double_type = double_type context
13
14 let rec codegen_expr = function
15 | Ast.Number n -> const_float double_type n
16 | Ast.Variable name ->
17 (try Hashtbl.find named_values name with
18 | Not_found -> raise (Error "unknown variable name"))
19 | Ast.Binary (op, lhs, rhs) ->
20 let lhs_val = codegen_expr lhs in
21 let rhs_val = codegen_expr rhs in
22 begin
23 match op with
24 | '+' -> build_add lhs_val rhs_val "addtmp" builder
25 | '-' -> build_sub lhs_val rhs_val "subtmp" builder
26 | '*' -> build_mul lhs_val rhs_val "multmp" builder
27 | '<' ->
28 (* Convert bool 0/1 to double 0.0 or 1.0 *)
29 let i = build_fcmp Fcmp.Ult lhs_val rhs_val "cmptmp" builder in
30 build_uitofp i double_type "booltmp" builder
31 | _ -> raise (Error "invalid binary operator")
32 end
33 | Ast.Call (callee, args) ->
34 (* Look up the name in the module table. *)
35 let callee =
36 match lookup_function callee the_module with
37 | Some callee -> callee
38 | None -> raise (Error "unknown function referenced")
39 in
40 let params = params callee in
41
42 (* If argument mismatch error. *)
43 if Array.length params == Array.length args then () else
44 raise (Error "incorrect # arguments passed");
45 let args = Array.map codegen_expr args in
46 build_call callee args "calltmp" builder
47
48 let codegen_proto = function
49 | Ast.Prototype (name, args) ->
50 (* Make the function type: double(double,double) etc. *)
51 let doubles = Array.make (Array.length args) double_type in
52 let ft = function_type double_type doubles in
53 let f =
54 match lookup_function name the_module with
55 | None -> declare_function name ft the_module
56
57 (* If 'f' conflicted, there was already something named 'name'. If it
58 * has a body, don't allow redefinition or reextern. *)
59 | Some f ->
60 (* If 'f' already has a body, reject this. *)
61 if block_begin f <> At_end f then
62 raise (Error "redefinition of function");
63
64 (* If 'f' took a different number of arguments, reject. *)
65 if element_type (type_of f) <> ft then
66 raise (Error "redefinition of function with different # args");
67 f
68 in
69
70 (* Set names for all arguments. *)
71 Array.iteri (fun i a ->
72 let n = args.(i) in
73 set_value_name n a;
74 Hashtbl.add named_values n a;
75 ) (params f);
76 f
77
78 let codegen_func = function
79 | Ast.Function (proto, body) ->
80 Hashtbl.clear named_values;
81 let the_function = codegen_proto proto in
82
83 (* Create a new basic block to start insertion into. *)
84 let bb = append_block context "entry" the_function in
85 position_at_end bb builder;
86
87 try
88 let ret_val = codegen_expr body in
89
90 (* Finish off the function. *)
91 let _ = build_ret ret_val builder in
92
93 (* Validate the generated code, checking for consistency. *)
94 Llvm_analysis.assert_valid_function the_function;
95
96 the_function
97 with e ->
98 delete_function the_function;
99 raise e
0 (*===----------------------------------------------------------------------===
1 * Lexer
2 *===----------------------------------------------------------------------===*)
3
4 let rec lex = parser
5 (* Skip any whitespace. *)
6 | [< ' (' ' | '\n' | '\r' | '\t'); stream >] -> lex stream
7
8 (* identifier: [a-zA-Z][a-zA-Z0-9] *)
9 | [< ' ('A' .. 'Z' | 'a' .. 'z' as c); stream >] ->
10 let buffer = Buffer.create 1 in
11 Buffer.add_char buffer c;
12 lex_ident buffer stream
13
14 (* number: [0-9.]+ *)
15 | [< ' ('0' .. '9' as c); stream >] ->
16 let buffer = Buffer.create 1 in
17 Buffer.add_char buffer c;
18 lex_number buffer stream
19
20 (* Comment until end of line. *)
21 | [< ' ('#'); stream >] ->
22 lex_comment stream
23
24 (* Otherwise, just return the character as its ascii value. *)
25 | [< 'c; stream >] ->
26 [< 'Token.Kwd c; lex stream >]
27
28 (* end of stream. *)
29 | [< >] -> [< >]
30
31 and lex_number buffer = parser
32 | [< ' ('0' .. '9' | '.' as c); stream >] ->
33 Buffer.add_char buffer c;
34 lex_number buffer stream
35 | [< stream=lex >] ->
36 [< 'Token.Number (float_of_string (Buffer.contents buffer)); stream >]
37
38 and lex_ident buffer = parser
39 | [< ' ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' as c); stream >] ->
40 Buffer.add_char buffer c;
41 lex_ident buffer stream
42 | [< stream=lex >] ->
43 match Buffer.contents buffer with
44 | "def" -> [< 'Token.Def; stream >]
45 | "extern" -> [< 'Token.Extern; stream >]
46 | id -> [< 'Token.Ident id; stream >]
47
48 and lex_comment = parser
49 | [< ' ('\n'); stream=lex >] -> stream
50 | [< 'c; e=lex_comment >] -> e
51 | [< >] -> [< >]
0 open Ocamlbuild_plugin;;
1
2 ocaml_lib ~extern:true "llvm";;
3 ocaml_lib ~extern:true "llvm_analysis";;
4
5 flag ["link"; "ocaml"; "g++"] (S[A"-cc"; A"g++"]);;
0 (*===---------------------------------------------------------------------===
1 * Parser
2 *===---------------------------------------------------------------------===*)
3
4 (* binop_precedence - This holds the precedence for each binary operator that is
5 * defined *)
6 let binop_precedence:(char, int) Hashtbl.t = Hashtbl.create 10
7
8 (* precedence - Get the precedence of the pending binary operator token. *)
9 let precedence c = try Hashtbl.find binop_precedence c with Not_found -> -1
10
11 (* primary
12 * ::= identifier
13 * ::= numberexpr
14 * ::= parenexpr *)
15 let rec parse_primary = parser
16 (* numberexpr ::= number *)
17 | [< 'Token.Number n >] -> Ast.Number n
18
19 (* parenexpr ::= '(' expression ')' *)
20 | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e
21
22 (* identifierexpr
23 * ::= identifier
24 * ::= identifier '(' argumentexpr ')' *)
25 | [< 'Token.Ident id; stream >] ->
26 let rec parse_args accumulator = parser
27 | [< e=parse_expr; stream >] ->
28 begin parser
29 | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e
30 | [< >] -> e :: accumulator
31 end stream
32 | [< >] -> accumulator
33 in
34 let rec parse_ident id = parser
35 (* Call. *)
36 | [< 'Token.Kwd '(';
37 args=parse_args [];
38 'Token.Kwd ')' ?? "expected ')'">] ->
39 Ast.Call (id, Array.of_list (List.rev args))
40
41 (* Simple variable ref. *)
42 | [< >] -> Ast.Variable id
43 in
44 parse_ident id stream
45
46 | [< >] -> raise (Stream.Error "unknown token when expecting an expression.")
47
48 (* binoprhs
49 * ::= ('+' primary)* *)
50 and parse_bin_rhs expr_prec lhs stream =
51 match Stream.peek stream with
52 (* If this is a binop, find its precedence. *)
53 | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c ->
54 let token_prec = precedence c in
55
56 (* If this is a binop that binds at least as tightly as the current binop,
57 * consume it, otherwise we are done. *)
58 if token_prec < expr_prec then lhs else begin
59 (* Eat the binop. *)
60 Stream.junk stream;
61
62 (* Parse the primary expression after the binary operator. *)
63 let rhs = parse_primary stream in
64
65 (* Okay, we know this is a binop. *)
66 let rhs =
67 match Stream.peek stream with
68 | Some (Token.Kwd c2) ->
69 (* If BinOp binds less tightly with rhs than the operator after
70 * rhs, let the pending operator take rhs as its lhs. *)
71 let next_prec = precedence c2 in
72 if token_prec < next_prec
73 then parse_bin_rhs (token_prec + 1) rhs stream
74 else rhs
75 | _ -> rhs
76 in
77
78 (* Merge lhs/rhs. *)
79 let lhs = Ast.Binary (c, lhs, rhs) in
80 parse_bin_rhs expr_prec lhs stream
81 end
82 | _ -> lhs
83
84 (* expression
85 * ::= primary binoprhs *)
86 and parse_expr = parser
87 | [< lhs=parse_primary; stream >] -> parse_bin_rhs 0 lhs stream
88
89 (* prototype
90 * ::= id '(' id* ')' *)
91 let parse_prototype =
92 let rec parse_args accumulator = parser
93 | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
94 | [< >] -> accumulator
95 in
96
97 parser
98 | [< 'Token.Ident id;
99 'Token.Kwd '(' ?? "expected '(' in prototype";
100 args=parse_args [];
101 'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
102 (* success. *)
103 Ast.Prototype (id, Array.of_list (List.rev args))
104
105 | [< >] ->
106 raise (Stream.Error "expected function name in prototype")
107
108 (* definition ::= 'def' prototype expression *)
109 let parse_definition = parser
110 | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
111 Ast.Function (p, e)
112
113 (* toplevelexpr ::= expression *)
114 let parse_toplevel = parser
115 | [< e=parse_expr >] ->
116 (* Make an anonymous proto. *)
117 Ast.Function (Ast.Prototype ("", [||]), e)
118
119 (* external ::= 'extern' prototype *)
120 let parse_extern = parser
121 | [< 'Token.Extern; e=parse_prototype >] -> e
0 (*===----------------------------------------------------------------------===
1 * Lexer Tokens
2 *===----------------------------------------------------------------------===*)
3
4 (* The lexer returns these 'Kwd' if it is an unknown character, otherwise one of
5 * these others for known things. *)
6 type token =
7 (* commands *)
8 | Def | Extern
9
10 (* primary *)
11 | Ident of string | Number of float
12
13 (* unknown *)
14 | Kwd of char
0 (*===----------------------------------------------------------------------===
1 * Top-Level parsing and JIT Driver
2 *===----------------------------------------------------------------------===*)
3
4 open Llvm
5
6 (* top ::= definition | external | expression | ';' *)
7 let rec main_loop stream =
8 match Stream.peek stream with
9 | None -> ()
10
11 (* ignore top-level semicolons. *)
12 | Some (Token.Kwd ';') ->
13 Stream.junk stream;
14 main_loop stream
15
16 | Some token ->
17 begin
18 try match token with
19 | Token.Def ->
20 let e = Parser.parse_definition stream in
21 print_endline "parsed a function definition.";
22 dump_value (Codegen.codegen_func e);
23 | Token.Extern ->
24 let e = Parser.parse_extern stream in
25 print_endline "parsed an extern.";
26 dump_value (Codegen.codegen_proto e);
27 | _ ->
28 (* Evaluate a top-level expression into an anonymous function. *)
29 let e = Parser.parse_toplevel stream in
30 print_endline "parsed a top-level expr";
31 dump_value (Codegen.codegen_func e);
32 with Stream.Error s | Codegen.Error s ->
33 (* Skip token for error recovery. *)
34 Stream.junk stream;
35 print_endline s;
36 end;
37 print_string "ready> "; flush stdout;
38 main_loop stream
0 (*===----------------------------------------------------------------------===
1 * Main driver code.
2 *===----------------------------------------------------------------------===*)
3
4 open Llvm
5
6 let main () =
7 (* Install standard binary operators.
8 * 1 is the lowest precedence. *)
9 Hashtbl.add Parser.binop_precedence '<' 10;
10 Hashtbl.add Parser.binop_precedence '+' 20;
11 Hashtbl.add Parser.binop_precedence '-' 20;
12 Hashtbl.add Parser.binop_precedence '*' 40; (* highest. *)
13
14 (* Prime the first token. *)
15 print_string "ready> "; flush stdout;
16 let stream = Lexer.lex (Stream.of_channel stdin) in
17
18 (* Run the main "interpreter loop" now. *)
19 Toplevel.main_loop stream;
20
21 (* Print out all the generated code. *)
22 dump_module Codegen.the_module
23 ;;
24
25 main ()
0 ##===- examples/OCaml-Kaleidoscope/Chapter4/Makefile -------*- Makefile -*-===##
1 #
2 # The LLVM Compiler Infrastructure
3 #
4 # This file is distributed under the University of Illinois Open Source
5 # License. See LICENSE.TXT for details.
6 #
7 ##===----------------------------------------------------------------------===##
8 #
9 # This is the makefile for the Objective Caml kaleidoscope tutorial, chapter 4.
10 #
11 ##===----------------------------------------------------------------------===##
12
13 LEVEL := ../../..
14 TOOLNAME := OCaml-Kaleidoscope-Ch4
15 EXAMPLE_TOOL := 1
16 UsedComponents := core
17 UsedOcamLibs := llvm llvm_analysis llvm_executionengine llvm_target \
18 llvm_scalar_opts
19
20 OCAMLCFLAGS += -pp camlp4of
21
22 ExcludeSources = $(PROJ_SRC_DIR)/myocamlbuild.ml
23
24 include $(LEVEL)/bindings/ocaml/Makefile.ocaml
0 <{lexer,parser}.ml>: use_camlp4, pp(camlp4of)
1 <*.{byte,native}>: g++, use_llvm, use_llvm_analysis
2 <*.{byte,native}>: use_llvm_executionengine, use_llvm_target
3 <*.{byte,native}>: use_llvm_scalar_opts, use_bindings
0 (*===----------------------------------------------------------------------===
1 * Abstract Syntax Tree (aka Parse Tree)
2 *===----------------------------------------------------------------------===*)
3
4 (* expr - Base type for all expression nodes. *)
5 type expr =
6 (* variant for numeric literals like "1.0". *)
7 | Number of float
8
9 (* variant for referencing a variable, like "a". *)
10 | Variable of string
11
12 (* variant for a binary operator. *)
13 | Binary of char * expr * expr
14
15 (* variant for function calls. *)
16 | Call of string * expr array
17
18 (* proto - This type represents the "prototype" for a function, which captures
19 * its name, and its argument names (thus implicitly the number of arguments the
20 * function takes). *)
21 type proto = Prototype of string * string array
22
23 (* func - This type represents a function definition itself. *)
24 type func = Function of proto * expr
0 #include
1
2 /* putchard - putchar that takes a double and returns 0. */
3 extern double putchard(double X) {
4 putchar((char)X);
5 return 0;
6 }
0 (*===----------------------------------------------------------------------===
1 * Code Generation
2 *===----------------------------------------------------------------------===*)
3
4 open Llvm
5
6 exception Error of string
7
8 let context = global_context ()
9 let the_module = create_module context "my cool jit"
10 let builder = builder context
11 let named_values:(string, llvalue) Hashtbl.t = Hashtbl.create 10
12 let double_type = double_type context
13
14 let rec codegen_expr = function
15 | Ast.Number n -> const_float double_type n
16 | Ast.Variable name ->
17 (try Hashtbl.find named_values name with
18 | Not_found -> raise (Error "unknown variable name"))
19 | Ast.Binary (op, lhs, rhs) ->
20 let lhs_val = codegen_expr lhs in
21 let rhs_val = codegen_expr rhs in
22 begin
23 match op with
24 | '+' -> build_add lhs_val rhs_val "addtmp" builder
25 | '-' -> build_sub lhs_val rhs_val "subtmp" builder
26 | '*' -> build_mul lhs_val rhs_val "multmp" builder
27 | '<' ->
28 (* Convert bool 0/1 to double 0.0 or 1.0 *)
29 let i = build_fcmp Fcmp.Ult lhs_val rhs_val "cmptmp" builder in
30 build_uitofp i double_type "booltmp" builder
31 | _ -> raise (Error "invalid binary operator")
32 end
33 | Ast.Call (callee, args) ->
34 (* Look up the name in the module table. *)
35 let callee =
36 match lookup_function callee the_module with
37 | Some callee -> callee
38 | None -> raise (Error "unknown function referenced")
39 in
40 let params = params callee in
41
42 (* If argument mismatch error. *)
43 if Array.length params == Array.length args then () else
44 raise (Error "incorrect # arguments passed");
45 let args = Array.map codegen_expr args in
46 build_call callee args "calltmp" builder
47
48 let codegen_proto = function
49 | Ast.Prototype (name, args) ->
50 (* Make the function type: double(double,double) etc. *)
51 let doubles = Array.make (Array.length args) double_type in
52 let ft = function_type double_type doubles in
53 let f =
54 match lookup_function name the_module with
55 | None -> declare_function name ft the_module
56
57 (* If 'f' conflicted, there was already something named 'name'. If it
58 * has a body, don't allow redefinition or reextern. *)
59 | Some f ->
60 (* If 'f' already has a body, reject this. *)
61 if block_begin f <> At_end f then
62 raise (Error "redefinition of function");
63
64 (* If 'f' took a different number of arguments, reject. *)
65 if element_type (type_of f) <> ft then
66 raise (Error "redefinition of function with different # args");
67 f
68 in
69
70 (* Set names for all arguments. *)
71 Array.iteri (fun i a ->
72 let n = args.(i) in
73 set_value_name n a;
74 Hashtbl.add named_values n a;
75 ) (params f);
76 f
77
78 let codegen_func the_fpm = function
79 | Ast.Function (proto, body) ->
80 Hashtbl.clear named_values;
81 let the_function = codegen_proto proto in
82
83 (* Create a new basic block to start insertion into. *)
84 let bb = append_block context "entry" the_function in
85 position_at_end bb builder;
86
87 try
88 let ret_val = codegen_expr body in
89
90 (* Finish off the function. *)
91 let _ = build_ret ret_val builder in
92
93 (* Validate the generated code, checking for consistency. *)
94 Llvm_analysis.assert_valid_function the_function;
95
96 (* Optimize the function. *)
97 let _ = PassManager.run_function the_function the_fpm in
98
99 the_function
100 with e ->
101 delete_function the_function;
102 raise e
0 (*===----------------------------------------------------------------------===
1 * Lexer
2 *===----------------------------------------------------------------------===*)
3
4 let rec lex = parser
5 (* Skip any whitespace. *)
6 | [< ' (' ' | '\n' | '\r' | '\t'); stream >] -> lex stream
7
8 (* identifier: [a-zA-Z][a-zA-Z0-9] *)
9 | [< ' ('A' .. 'Z' | 'a' .. 'z' as c); stream >] ->
10 let buffer = Buffer.create 1 in
11 Buffer.add_char buffer c;
12 lex_ident buffer stream
13
14 (* number: [0-9.]+ *)
15 | [< ' ('0' .. '9' as c); stream >] ->
16 let buffer = Buffer.create 1 in
17 Buffer.add_char buffer c;
18 lex_number buffer stream
19
20 (* Comment until end of line. *)
21 | [< ' ('#'); stream >] ->
22 lex_comment stream
23
24 (* Otherwise, just return the character as its ascii value. *)
25 | [< 'c; stream >] ->
26 [< 'Token.Kwd c; lex stream >]
27
28 (* end of stream. *)
29 | [< >] -> [< >]
30
31 and lex_number buffer = parser
32 | [< ' ('0' .. '9' | '.' as c); stream >] ->
33 Buffer.add_char buffer c;
34 lex_number buffer stream
35 | [< stream=lex >] ->
36 [< 'Token.Number (float_of_string (Buffer.contents buffer)); stream >]
37
38 and lex_ident buffer = parser
39 | [< ' ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' as c); stream >] ->
40 Buffer.add_char buffer c;
41 lex_ident buffer stream
42 | [< stream=lex >] ->
43 match Buffer.contents buffer with
44 | "def" -> [< 'Token.Def; stream >]
45 | "extern" -> [< 'Token.Extern; stream >]
46 | id -> [< 'Token.Ident id; stream >]
47
48 and lex_comment = parser
49 | [< ' ('\n'); stream=lex >] -> stream
50 | [< 'c; e=lex_comment >] -> e
51 | [< >] -> [< >]
0 open Ocamlbuild_plugin;;
1
2 ocaml_lib ~extern:true "llvm";;
3 ocaml_lib ~extern:true "llvm_analysis";;
4 ocaml_lib ~extern:true "llvm_executionengine";;
5 ocaml_lib ~extern:true "llvm_target";;
6 ocaml_lib ~extern:true "llvm_scalar_opts";;
7
8 flag ["link"; "ocaml"; "g++"] (S[A"-cc"; A"g++"]);;
9 dep ["link"; "ocaml"; "use_bindings"] ["bindings.o"];;
0 (*===---------------------------------------------------------------------===
1 * Parser
2 *===---------------------------------------------------------------------===*)
3
4 (* binop_precedence - This holds the precedence for each binary operator that is
5 * defined *)
6 let binop_precedence:(char, int) Hashtbl.t = Hashtbl.create 10
7
8 (* precedence - Get the precedence of the pending binary operator token. *)
9 let precedence c = try Hashtbl.find binop_precedence c with Not_found -> -1
10
11 (* primary
12 * ::= identifier
13 * ::= numberexpr
14 * ::= parenexpr *)
15 let rec parse_primary = parser
16 (* numberexpr ::= number *)
17 | [< 'Token.Number n >] -> Ast.Number n
18
19 (* parenexpr ::= '(' expression ')' *)
20 | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e
21
22 (* identifierexpr
23 * ::= identifier
24 * ::= identifier '(' argumentexpr ')' *)
25 | [< 'Token.Ident id; stream >] ->
26 let rec parse_args accumulator = parser
27 | [< e=parse_expr; stream >] ->
28 begin parser
29 | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e
30 | [< >] -> e :: accumulator
31 end stream
32 | [< >] -> accumulator
33 in
34 let rec parse_ident id = parser
35 (* Call. *)
36 | [< 'Token.Kwd '(';
37 args=parse_args [];
38 'Token.Kwd ')' ?? "expected ')'">] ->
39 Ast.Call (id, Array.of_list (List.rev args))
40
41 (* Simple variable ref. *)
42 | [< >] -> Ast.Variable id
43 in
44 parse_ident id stream
45
46 | [< >] -> raise (Stream.Error "unknown token when expecting an expression.")
47
48 (* binoprhs
49 * ::= ('+' primary)* *)
50 and parse_bin_rhs expr_prec lhs stream =
51 match Stream.peek stream with
52 (* If this is a binop, find its precedence. *)
53 | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c ->
54 let token_prec = precedence c in
55
56 (* If this is a binop that binds at least as tightly as the current binop,
57 * consume it, otherwise we are done. *)
58 if token_prec < expr_prec then lhs else begin
59 (* Eat the binop. *)
60 Stream.junk stream;
61
62 (* Parse the primary expression after the binary operator. *)
63 let rhs = parse_primary stream in
64
65 (* Okay, we know this is a binop. *)
66 let rhs =
67 match Stream.peek stream with
68 | Some (Token.Kwd c2) ->
69 (* If BinOp binds less tightly with rhs than the operator after
70 * rhs, let the pending operator take rhs as its lhs. *)
71 let next_prec = precedence c2 in
72 if token_prec < next_prec
73 then parse_bin_rhs (token_prec + 1) rhs stream
74 else rhs
75 | _ -> rhs
76 in
77
78 (* Merge lhs/rhs. *)
79 let lhs = Ast.Binary (c, lhs, rhs) in
80 parse_bin_rhs expr_prec lhs stream
81 end
82 | _ -> lhs
83
84 (* expression
85 * ::= primary binoprhs *)
86 and parse_expr = parser
87 | [< lhs=parse_primary; stream >] -> parse_bin_rhs 0 lhs stream
88
89 (* prototype
90 * ::= id '(' id* ')' *)
91 let parse_prototype =
92 let rec parse_args accumulator = parser
93 | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
94 | [< >] -> accumulator
95 in
96
97 parser
98 | [< 'Token.Ident id;
99 'Token.Kwd '(' ?? "expected '(' in prototype";
100 args=parse_args [];
101 'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
102 (* success. *)
103 Ast.Prototype (id, Array.of_list (List.rev args))
104
105 | [< >] ->
106 raise (Stream.Error "expected function name in prototype")
107
108 (* definition ::= 'def' prototype expression *)
109 let parse_definition = parser
110 | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
111 Ast.Function (p, e)
112
113 (* toplevelexpr ::= expression *)
114 let parse_toplevel = parser
115 | [< e=parse_expr >] ->
116 (* Make an anonymous proto. *)
117 Ast.Function (Ast.Prototype ("", [||]), e)
118
119 (* external ::= 'extern' prototype *)
120 let parse_extern = parser
121 | [< 'Token.Extern; e=parse_prototype >] -> e
0 (*===----------------------------------------------------------------------===
1 * Lexer Tokens
2 *===----------------------------------------------------------------------===*)
3
4 (* The lexer returns these 'Kwd' if it is an unknown character, otherwise one of
5 * these others for known things. *)
6 type token =
7 (* commands *)
8 | Def | Extern
9
10 (* primary *)
11 | Ident of string | Number of float
12
13 (* unknown *)
14 | Kwd of char
0 (*===----------------------------------------------------------------------===
1 * Top-Level parsing and JIT Driver
2 *===----------------------------------------------------------------------===*)
3
4 open Llvm
5 open Llvm_executionengine
6
7 (* top ::= definition | external | expression | ';' *)
8 let rec main_loop the_fpm the_execution_engine stream =
9 match Stream.peek stream with
10 | None -> ()
11
12 (* ignore top-level semicolons. *)
13 | Some (Token.Kwd ';') ->
14 Stream.junk stream;
15 main_loop the_fpm the_execution_engine stream
16
17 | Some token ->
18 begin
19 try match token with
20 | Token.Def ->
21 let e = Parser.parse_definition stream in
22 print_endline "parsed a function definition.";
23 dump_value (Codegen.codegen_func the_fpm e);
24 | Token.Extern ->
25 let e = Parser.parse_extern stream in
26 print_endline "parsed an extern.";
27 dump_value (Codegen.codegen_proto e);
28 | _ ->
29 (* Evaluate a top-level expression into an anonymous function. *)
30 let e = Parser.parse_toplevel stream in
31 print_endline "parsed a top-level expr";
32 let the_function = Codegen.codegen_func the_fpm e in
33 dump_value the_function;
34
35 (* JIT the function, returning a function pointer. *)
36 let result = ExecutionEngine.run_function the_function [||]
37 the_execution_engine in
38
39 print_string "Evaluated to ";
40 print_float (GenericValue.as_float Codegen.double_type result);
41 print_newline ();
42 with Stream.Error s | Codegen.Error s ->
43 (* Skip token for error recovery. *)
44 Stream.junk stream;
45 print_endline s;
46 end;
47 print_string "ready> "; flush stdout;
48 main_loop the_fpm the_execution_engine stream
0 (*===----------------------------------------------------------------------===
1 * Main driver code.
2 *===----------------------------------------------------------------------===*)
3
4 open Llvm
5 open Llvm_executionengine
6 open Llvm_target
7 open Llvm_scalar_opts
8
9 let main () =
10 ignore (initialize_native_target ());
11
12 (* Install standard binary operators.
13 * 1 is the lowest precedence. *)
14 Hashtbl.add Parser.binop_precedence '<' 10;
15 Hashtbl.add Parser.binop_precedence '+' 20;
16 Hashtbl.add Parser.binop_precedence '-' 20;
17 Hashtbl.add Parser.binop_precedence '*' 40; (* highest. *)
18
19 (* Prime the first token. *)
20 print_string "ready> "; flush stdout;
21 let stream = Lexer.lex (Stream.of_channel stdin) in
22
23 (* Create the JIT. *)
24 let the_execution_engine = ExecutionEngine.create Codegen.the_module in
25 let the_fpm = PassManager.create_function Codegen.the_module in
26
27 (* Set up the optimizer pipeline. Start with registering info about how the
28 * target lays out data structures. *)
29 TargetData.add (ExecutionEngine.target_data the_execution_engine) the_fpm;
30
31 (* Do simple "peephole" optimizations and bit-twiddling optzn. *)
32 add_instruction_combination the_fpm;
33
34 (* reassociate expressions. *)
35 add_reassociation the_fpm;
36
37 (* Eliminate Common SubExpressions. *)
38 add_gvn the_fpm;
39
40 (* Simplify the control flow graph (deleting unreachable blocks, etc). *)
41 add_cfg_simplification the_fpm;
42
43 ignore (PassManager.initialize the_fpm);
44
45 (* Run the main "interpreter loop" now. *)
46 Toplevel.main_loop the_fpm the_execution_engine stream;
47
48 (* Print out all the generated code. *)
49 dump_module Codegen.the_module
50 ;;
51
52 main ()
0 ##===- examples/OCaml-Kaleidoscope/Chapter5/Makefile -------*- Makefile -*-===##
1 #
2 # The LLVM Compiler Infrastructure
3 #
4 # This file is distributed under the University of Illinois Open Source
5 # License. See LICENSE.TXT for details.
6 #
7 ##===----------------------------------------------------------------------===##
8 #
9 # This is the makefile for the Objective Caml kaleidoscope tutorial, chapter 5.
10 #
11 ##===----------------------------------------------------------------------===##
12
13 LEVEL := ../../..
14 TOOLNAME := OCaml-Kaleidoscope-Ch5
15 EXAMPLE_TOOL := 1
16 UsedComponents := core
17 UsedOcamLibs := llvm llvm_analysis llvm_executionengine llvm_target \
18 llvm_scalar_opts
19
20 OCAMLCFLAGS += -pp camlp4of
21
22 ExcludeSources = $(PROJ_SRC_DIR)/myocamlbuild.ml
23
24 include $(LEVEL)/bindings/ocaml/Makefile.ocaml
0 <{lexer,parser}.ml>: use_camlp4, pp(camlp4of)
1 <*.{byte,native}>: g++, use_llvm, use_llvm_analysis
2 <*.{byte,native}>: use_llvm_executionengine, use_llvm_target
3 <*.{byte,native}>: use_llvm_scalar_opts, use_bindings
0 (*===----------------------------------------------------------------------===
1 * Abstract Syntax Tree (aka Parse Tree)
2 *===----------------------------------------------------------------------===*)
3
4 (* expr - Base type for all expression nodes. *)
5 type expr =
6 (* variant for numeric literals like "1.0". *)
7 | Number of float
8
9 (* variant for referencing a variable, like "a". *)
10 | Variable of string
11
12 (* variant for a binary operator. *)
13 | Binary of char * expr * expr
14
15 (* variant for function calls. *)
16 | Call of string * expr array
17
18 (* variant for if/then/else. *)
19 | If of expr * expr * expr
20
21 (* variant for for/in. *)
22 | For of string * expr * expr * expr option * expr
23
24 (* proto - This type represents the "prototype" for a function, which captures
25 * its name, and its argument names (thus implicitly the number of arguments the
26 * function takes). *)
27 type proto = Prototype of string * string array
28
29 (* func - This type represents a function definition itself. *)
30 type func = Function of proto * expr
0 #include
1
2 /* putchard - putchar that takes a double and returns 0. */
3 extern double putchard(double X) {
4 putchar((char)X);
5 return 0;
6 }
0 (*===----------------------------------------------------------------------===
1 * Code Generation
2 *===----------------------------------------------------------------------===*)
3
4 open Llvm
5
6 exception Error of string
7
8 let context = global_context ()
9 let the_module = create_module context "my cool jit"
10 let builder = builder context
11 let named_values:(string, llvalue) Hashtbl.t = Hashtbl.create 10
12 let double_type = double_type context
13
14 let rec codegen_expr = function
15 | Ast.Number n -> const_float double_type n
16 | Ast.Variable name ->
17 (try Hashtbl.find named_values name with
18 | Not_found -> raise (Error "unknown variable name"))
19 | Ast.Binary (op, lhs, rhs) ->
20 let lhs_val = codegen_expr lhs in
21 let rhs_val = codegen_expr rhs in
22 begin
23 match op with
24 | '+' -> build_add lhs_val rhs_val "addtmp" builder
25 | '-' -> build_sub lhs_val rhs_val "subtmp" builder
26 | '*' -> build_mul lhs_val rhs_val "multmp" builder
27 | '<' ->
28 (* Convert bool 0/1 to double 0.0 or 1.0 *)
29 let i = build_fcmp Fcmp.Ult lhs_val rhs_val "cmptmp" builder in
30 build_uitofp i double_type "booltmp" builder
31 | _ -> raise (Error "invalid binary operator")
32 end
33 | Ast.Call (callee, args) ->
34 (* Look up the name in the module table. *)
35 let callee =
36 match lookup_function callee the_module with
37 | Some callee -> callee
38 | None -> raise (Error "unknown function referenced")
39 in
40 let params = params callee in
41
42 (* If argument mismatch error. *)
43 if Array.length params == Array.length args then () else
44 raise (Error "incorrect # arguments passed");
45 let args = Array.map codegen_expr args in
46 build_call callee args "calltmp" builder
47 | Ast.If (cond, then_, else_) ->
48 let cond = codegen_expr cond in
49
50 (* Convert condition to a bool by comparing equal to 0.0 *)
51 let zero = const_float double_type 0.0 in
52 let cond_val = build_fcmp Fcmp.One cond zero "ifcond" builder in
53
54 (* Grab the first block so that we might later add the conditional branch
55 * to it at the end of the function. *)
56 let start_bb = insertion_block builder in
57 let the_function = block_parent start_bb in
58
59 let then_bb = append_block context "then" the_function in
60
61 (* Emit 'then' value. *)
62 position_at_end then_bb builder;
63 let then_val = codegen_expr then_ in
64
65 (* Codegen of 'then' can change the current block, update then_bb for the
66 * phi. We create a new name because one is used for the phi node, and the
67 * other is used for the conditional branch. *)
68 let new_then_bb = insertion_block builder in
69
70 (* Emit 'else' value. *)
71 let else_bb = append_block context "else" the_function in
72 position_at_end else_bb builder;
73 let else_val = codegen_expr else_ in
74
75 (* Codegen of 'else' can change the current block, update else_bb for the
76 * phi. *)
77 let new_else_bb = insertion_block builder in
78
79 (* Emit merge block. *)
80 let merge_bb = append_block context "ifcont" the_function in
81 position_at_end merge_bb builder;
82 let incoming = [(then_val, new_then_bb); (else_val, new_else_bb)] in
83 let phi = build_phi incoming "iftmp" builder in
84
85 (* Return to the start block to add the conditional branch. *)
86 position_at_end start_bb builder;
87 ignore (build_cond_br cond_val then_bb else_bb builder);
88
89 (* Set a unconditional branch at the end of the 'then' block and the
90 * 'else' block to the 'merge' block. *)
91 position_at_end new_then_bb builder; ignore (build_br merge_bb builder);
92 position_at_end new_else_bb builder; ignore (build_br merge_bb builder);
93
94 (* Finally, set the builder to the end of the merge block. *)
95 position_at_end merge_bb builder;
96
97 phi
98 | Ast.For (var_name, start, end_, step, body) ->
99 (* Emit the start code first, without 'variable' in scope. *)
100 let start_val = codegen_expr start in
101
102 (* Make the new basic block for the loop header, inserting after current
103 * block. *)
104 let preheader_bb = insertion_block builder in
105 let the_function = block_parent preheader_bb in
106 let loop_bb = append_block context "loop" the_function in
107
108 (* Insert an explicit fall through from the current block to the
109 * loop_bb. *)
110 ignore (build_br loop_bb builder);
111
112 (* Start insertion in loop_bb. *)
113 position_at_end loop_bb builder;
114
115 (* Start the PHI node with an entry for start. *)
116 let variable = build_phi [(start_val, preheader_bb)] var_name builder in
117
118 (* Within the loop, the variable is defined equal to the PHI node. If it
119 * shadows an existing variable, we have to restore it, so save it
120 * now. *)
121 let old_val =
122 try Some (Hashtbl.find named_values var_name) with Not_found -> None
123 in
124 Hashtbl.add named_values var_name variable;
125
126 (* Emit the body of the loop. This, like any other expr, can change the
127 * current BB. Note that we ignore the value computed by the body, but
128 * don't allow an error *)
129 ignore (codegen_expr body);
130
131 (* Emit the step value. *)
132 let step_val =
133 match step with
134 | Some step -> codegen_expr step
135 (* If not specified, use 1.0. *)
136 | None -> const_float double_type 1.0
137 in
138
139 let next_var = build_add variable step_val "nextvar" builder in
140
141 (* Compute the end condition. *)
142 let end_cond = codegen_expr end_ in
143
144 (* Convert condition to a bool by comparing equal to 0.0. *)
145 let zero = const_float double_type 0.0 in
146 let end_cond = build_fcmp Fcmp.One end_cond zero "loopcond" builder in
147
148 (* Create the "after loop" block and insert it. *)
149 let loop_end_bb = insertion_block builder in
150 let after_bb = append_block context "afterloop" the_function in
151
152 (* Insert the conditional branch into the end of loop_end_bb. *)
153 ignore (build_cond_br end_cond loop_bb after_bb builder);
154
155 (* Any new code will be inserted in after_bb. *)
156 position_at_end after_bb builder;
157
158 (* Add a new entry to the PHI node for the backedge. *)
159 add_incoming (next_var, loop_end_bb) variable;
160
161 (* Restore the unshadowed variable. *)
162 begin match old_val with
163 | Some old_val -> Hashtbl.add named_values var_name old_val
164 | None -> ()
165 end;
166
167 (* for expr always returns 0.0. *)
168 const_null double_type
169
170 let codegen_proto = function
171 | Ast.Prototype (name, args) ->
172 (* Make the function type: double(double,double) etc. *)
173 let doubles = Array.make (Array.length args) double_type in
174 let ft = function_type double_type doubles in
175 let f =
176 match lookup_function name the_module with
177 | None -> declare_function name ft the_module
178
179 (* If 'f' conflicted, there was already something named 'name'. If it
180 * has a body, don't allow redefinition or reextern. *)
181 | Some f ->
182 (* If 'f' already has a body, reject this. *)
183 if block_begin f <> At_end f then
184 raise (Error "redefinition of function");
185
186 (* If 'f' took a different number of arguments, reject. *)
187 if element_type (type_of f) <> ft then
188 raise (Error "redefinition of function with different # args");
189 f
190 in
191
192 (* Set names for all arguments. *)
193 Array.iteri (fun i a ->
194 let n = args.(i) in
195 set_value_name n a;
196 Hashtbl.add named_values n a;
197 ) (params f);
198 f
199
200 let codegen_func the_fpm = function
201 | Ast.Function (proto, body) ->
202 Hashtbl.clear named_values;
203 let the_function = codegen_proto proto in
204
205 (* Create a new basic block to start insertion into. *)
206 let bb = append_block context "entry" the_function in
207 position_at_end bb builder;
208
209 try
210 let ret_val = codegen_expr body in
211
212 (* Finish off the function. *)
213 let _ = build_ret ret_val builder in
214
215 (* Validate the generated code, checking for consistency. *)
216 Llvm_analysis.assert_valid_function the_function;
217
218 (* Optimize the function. *)
219 let _ = PassManager.run_function the_function the_fpm in
220
221 the_function
222 with e ->
223 delete_function the_function;
224 raise e
0 (*===----------------------------------------------------------------------===
1 * Lexer
2 *===----------------------------------------------------------------------===*)
3
4 let rec lex = parser
5 (* Skip any whitespace. *)
6 | [< ' (' ' | '\n' | '\r' | '\t'); stream >] -> lex stream
7
8 (* identifier: [a-zA-Z][a-zA-Z0-9] *)
9 | [< ' ('A' .. 'Z' | 'a' .. 'z' as c); stream >] ->
10 let buffer = Buffer.create 1 in
11 Buffer.add_char buffer c;
12 lex_ident buffer stream
13
14 (* number: [0-9.]+ *)
15 | [< ' ('0' .. '9' as c); stream >] ->
16 let buffer = Buffer.create 1 in
17 Buffer.add_char buffer c;
18 lex_number buffer stream
19
20 (* Comment until end of line. *)
21 | [< ' ('#'); stream >] ->
22 lex_comment stream
23
24 (* Otherwise, just return the character as its ascii value. *)
25 | [< 'c; stream >] ->
26 [< 'Token.Kwd c; lex stream >]
27
28 (* end of stream. *)
29 | [< >] -> [< >]
30
31 and lex_number buffer = parser
32 | [< ' ('0' .. '9' | '.' as c); stream >] ->
33 Buffer.add_char buffer c;
34 lex_number buffer stream
35 | [< stream=lex >] ->
36 [< 'Token.Number (float_of_string (Buffer.contents buffer)); stream >]
37
38 and lex_ident buffer = parser
39 | [< ' ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' as c); stream >] ->
40 Buffer.add_char buffer c;
41 lex_ident buffer stream
42 | [< stream=lex >] ->
43 match Buffer.contents buffer with
44 | "def" -> [< 'Token.Def; stream >]
45 | "extern" -> [< 'Token.Extern; stream >]
46 | "if" -> [< 'Token.If; stream >]
47 | "then" -> [< 'Token.Then; stream >]
48 | "else" -> [< 'Token.Else; stream >]
49 | "for" -> [< 'Token.For; stream >]
50 | "in" -> [< 'Token.In; stream >]
51 | id -> [< 'Token.Ident id; stream >]
52
53 and lex_comment = parser
54 | [< ' ('\n'); stream=lex >] -> stream
55 | [< 'c; e=lex_comment >] -> e
56 | [< >] -> [< >]
0 open Ocamlbuild_plugin;;
1
2 ocaml_lib ~extern:true "llvm";;
3 ocaml_lib ~extern:true "llvm_analysis";;
4 ocaml_lib ~extern:true "llvm_executionengine";;
5 ocaml_lib ~extern:true "llvm_target";;
6 ocaml_lib ~extern:true "llvm_scalar_opts";;
7
8 flag ["link"; "ocaml"; "g++"] (S[A"-cc"; A"g++"]);;
9 dep ["link"; "ocaml"; "use_bindings"] ["bindings.o"];;
0 (*===---------------------------------------------------------------------===
1 * Parser
2 *===---------------------------------------------------------------------===*)
3
4 (* binop_precedence - This holds the precedence for each binary operator that is
5 * defined *)
6 let binop_precedence:(char, int) Hashtbl.t = Hashtbl.create 10
7
8 (* precedence - Get the precedence of the pending binary operator token. *)
9 let precedence c = try Hashtbl.find binop_precedence c with Not_found -> -1
10
11 (* primary
12 * ::= identifier
13 * ::= numberexpr
14 * ::= parenexpr
15 * ::= ifexpr
16 * ::= forexpr *)
17 let rec parse_primary = parser
18 (* numberexpr ::= number *)
19 | [< 'Token.Number n >] -> Ast.Number n
20
21 (* parenexpr ::= '(' expression ')' *)
22 | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e
23
24 (* identifierexpr
25 * ::= identifier
26 * ::= identifier '(' argumentexpr ')' *)
27 | [< 'Token.Ident id; stream >] ->
28 let rec parse_args accumulator = parser
29 | [< e=parse_expr; stream >] ->
30 begin parser
31 | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e
32 | [< >] -> e :: accumulator
33 end stream
34 | [< >] -> accumulator
35 in
36 let rec parse_ident id = parser
37 (* Call. *)
38 | [< 'Token.Kwd '(';
39 args=parse_args [];
40 'Token.Kwd ')' ?? "expected ')'">] ->
41 Ast.Call (id, Array.of_list (List.rev args))
42
43 (* Simple variable ref. *)
44 | [< >] -> Ast.Variable id
45 in
46 parse_ident id stream
47
48 (* ifexpr ::= 'if' expr 'then' expr 'else' expr *)
49 | [< 'Token.If; c=parse_expr;
50 'Token.Then ?? "expected 'then'"; t=parse_expr;
51 'Token.Else ?? "expected 'else'"; e=parse_expr >] ->
52 Ast.If (c, t, e)
53
54 (* forexpr
55 ::= 'for' identifier '=' expr ',' expr (',' expr)? 'in' expression *)
56 | [< 'Token.For;
57 'Token.Ident id ?? "expected identifier after for";
58 'Token.Kwd '=' ?? "expected '=' after for";
59 stream >] ->
60 begin parser
61 | [<
62 start=parse_expr;
63 'Token.Kwd ',' ?? "expected ',' after for";
64 end_=parse_expr;
65 stream >] ->
66 let step =
67 begin parser
68 | [< 'Token.Kwd ','; step=parse_expr >] -> Some step
69 | [< >] -> None
70 end stream
71 in
72 begin parser
73 | [< 'Token.In; body=parse_expr >] ->
74 Ast.For (id, start, end_, step, body)
75 | [< >] ->
76 raise (Stream.Error "expected 'in' after for")
77 end stream
78 | [< >] ->
79 raise (Stream.Error "expected '=' after for")
80 end stream
81
82 | [< >] -> raise (Stream.Error "unknown token when expecting an expression.")
83
84 (* binoprhs
85 * ::= ('+' primary)* *)
86 and parse_bin_rhs expr_prec lhs stream =
87 match Stream.peek stream with
88 (* If this is a binop, find its precedence. *)
89 | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c ->
90 let token_prec = precedence c in
91
92 (* If this is a binop that binds at least as tightly as the current binop,
93 * consume it, otherwise we are done. *)
94 if token_prec < expr_prec then lhs else begin
95 (* Eat the binop. *)
96 Stream.junk stream;
97
98 (* Parse the primary expression after the binary operator. *)
99 let rhs = parse_primary stream in
100
101 (* Okay, we know this is a binop. *)
102 let rhs =
103 match Stream.peek stream with
104 | Some (Token.Kwd c2) ->
105 (* If BinOp binds less tightly with rhs than the operator after
106 * rhs, let the pending operator take rhs as its lhs. *)
107 let next_prec = precedence c2 in
108 if token_prec < next_prec
109 then parse_bin_rhs (token_prec + 1) rhs stream
110 else rhs
111 | _ -> rhs
112 in
113
114 (* Merge lhs/rhs. *)
115 let lhs = Ast.Binary (c, lhs, rhs) in
116 parse_bin_rhs expr_prec lhs stream
117 end
118 | _ -> lhs
119
120 (* expression
121 * ::= primary binoprhs *)
122 and parse_expr = parser
123 | [< lhs=parse_primary; stream >] -> parse_bin_rhs 0 lhs stream
124
125 (* prototype
126 * ::= id '(' id* ')' *)
127 let parse_prototype =
128 let rec parse_args accumulator = parser
129 | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
130 | [< >] -> accumulator
131 in
132
133 parser
134 | [< 'Token.Ident id;
135 'Token.Kwd '(' ?? "expected '(' in prototype";
136 args=parse_args [];
137 'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
138 (* success. *)
139 Ast.Prototype (id, Array.of_list (List.rev args))
140
141 | [< >] ->
142 raise (Stream.Error "expected function name in prototype")
143
144 (* definition ::= 'def' prototype expression *)
145 let parse_definition = parser
146 | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
147 Ast.Function (p, e)
148
149 (* toplevelexpr ::= expression *)
150 let parse_toplevel = parser
151 | [< e=parse_expr >] ->
152 (* Make an anonymous proto. *)
153 Ast.Function (Ast.Prototype ("", [||]), e)
154
155 (* external ::= 'extern' prototype *)
156 let parse_extern = parser
157 | [< 'Token.Extern; e=parse_prototype >] -> e
0 (*===----------------------------------------------------------------------===
1 * Lexer Tokens
2 *===----------------------------------------------------------------------===*)
3
4 (* The lexer returns these 'Kwd' if it is an unknown character, otherwise one of
5 * these others for known things. *)
6 type token =
7 (* commands *)
8 | Def | Extern
9
10 (* primary *)
11 | Ident of string | Number of float
12
13 (* unknown *)
14 | Kwd of char
15
16 (* control *)
17 | If | Then | Else
18 | For | In
0 (*===----------------------------------------------------------------------===
1 * Top-Level parsing and JIT Driver
2 *===----------------------------------------------------------------------===*)
3
4 open Llvm
5 open Llvm_executionengine
6
7 (* top ::= definition | external | expression | ';' *)
8 let rec main_loop the_fpm the_execution_engine stream =
9 match Stream.peek stream with
10 | None -> ()
11
12 (* ignore top-level semicolons. *)
13 | Some (Token.Kwd ';') ->
14 Stream.junk stream;
15 main_loop the_fpm the_execution_engine stream
16
17 | Some token ->
18 begin
19 try match token with
20 | Token.Def ->
21 let e = Parser.parse_definition stream in
22 print_endline "parsed a function definition.";
23 dump_value (Codegen.codegen_func the_fpm e);
24 | Token.Extern ->
25 let e = Parser.parse_extern stream in
26 print_endline "parsed an extern.";
27 dump_value (Codegen.codegen_proto e);
28 | _ ->
29 (* Evaluate a top-level expression into an anonymous function. *)
30 let e = Parser.parse_toplevel stream in
31 print_endline "parsed a top-level expr";
32 let the_function = Codegen.codegen_func the_fpm e in
33 dump_value the_function;
34
35 (* JIT the function, returning a function pointer. *)
36 let result = ExecutionEngine.run_function the_function [||]
37 the_execution_engine in
38
39 print_string "Evaluated to ";
40 print_float (GenericValue.as_float Codegen.double_type result);
41 print_newline ();
42 with Stream.Error s | Codegen.Error s ->
43 (* Skip token for error recovery. *)
44 Stream.junk stream;
45 print_endline s;
46 end;
47 print_string "ready> "; flush stdout;
48 main_loop the_fpm the_execution_engine stream
0 (*===----------------------------------------------------------------------===
1 * Main driver code.
2 *===----------------------------------------------------------------------===*)
3
4 open Llvm
5 open Llvm_executionengine
6 open Llvm_target
7 open Llvm_scalar_opts
8
9 let main () =
10 ignore (initialize_native_target ());
11
12 (* Install standard binary operators.
13 * 1 is the lowest precedence. *)
14 Hashtbl.add Parser.binop_precedence '<' 10;
15 Hashtbl.add Parser.binop_precedence '+' 20;
16 Hashtbl.add Parser.binop_precedence '-' 20;
17 Hashtbl.add Parser.binop_precedence '*' 40; (* highest. *)
18
19 (* Prime the first token. *)
20 print_string "ready> "; flush stdout;
21 let stream = Lexer.lex (Stream.of_channel stdin) in
22
23 (* Create the JIT. *)
24 let the_execution_engine = ExecutionEngine.create Codegen.the_module in
25 let the_fpm = PassManager.create_function Codegen.the_module in
26
27 (* Set up the optimizer pipeline. Start with registering info about how the
28 * target lays out data structures. *)
29 TargetData.add (ExecutionEngine.target_data the_execution_engine) the_fpm;
30
31 (* Do simple "peephole" optimizations and bit-twiddling optzn. *)
32 add_instruction_combination the_fpm;
33
34 (* reassociate expressions. *)
35 add_reassociation the_fpm;
36
37 (* Eliminate Common SubExpressions. *)
38 add_gvn the_fpm;
39
40 (* Simplify the control flow graph (deleting unreachable blocks, etc). *)
41 add_cfg_simplification the_fpm;
42
43 ignore (PassManager.initialize the_fpm);
44
45 (* Run the main "interpreter loop" now. *)
46 Toplevel.main_loop the_fpm the_execution_engine stream;
47
48 (* Print out all the generated code. *)
49 dump_module Codegen.the_module
50 ;;
51
52 main ()
0 ##===- examples/OCaml-Kaleidoscope/Chapter6/Makefile -------*- Makefile -*-===##
1 #
2 # The LLVM Compiler Infrastructure
3 #
4 # This file is distributed under the University of Illinois Open Source
5 # License. See LICENSE.TXT for details.
6 #
7 ##===----------------------------------------------------------------------===##
8 #
9 # This is the makefile for the Objective Caml kaleidoscope tutorial, chapter 6.
10 #
11 ##===----------------------------------------------------------------------===##
12
13 LEVEL := ../../..
14 TOOLNAME := OCaml-Kaleidoscope-Ch6
15 EXAMPLE_TOOL := 1
16 UsedComponents := core
17 UsedOcamLibs := llvm llvm_analysis llvm_executionengine llvm_target \
18 llvm_scalar_opts
19
20 OCAMLCFLAGS += -pp camlp4of
21
22 ExcludeSources = $(PROJ_SRC_DIR)/myocamlbuild.ml
23
24 include $(LEVEL)/bindings/ocaml/Makefile.ocaml
0 <{lexer,parser}.ml>: use_camlp4, pp(camlp4of)
1 <*.{byte,native}>: g++, use_llvm, use_llvm_analysis
2 <*.{byte,native}>: use_llvm_executionengine, use_llvm_target
3 <*.{byte,native}>: use_llvm_scalar_opts, use_bindings
0 (*===----------------------------------------------------------------------===
1 * Abstract Syntax Tree (aka Parse Tree)
2 *===----------------------------------------------------------------------===*)
3
4 (* expr - Base type for all expression nodes. *)
5 type expr =
6 (* variant for numeric literals like "1.0". *)
7 | Number of float
8
9 (* variant for referencing a variable, like "a". *)
10 | Variable of string
11
12 (* variant for a unary operator. *)
13 | Unary of char * expr
14
15 (* variant for a binary operator. *)
16 | Binary of char * expr * expr
17
18 (* variant for function calls. *)
19 | Call of string * expr array
20
21 (* variant for if/then/else. *)
22 | If of expr * expr * expr
23
24 (* variant for for/in. *)
25 | For of string * expr * expr * expr option * expr
26
27 (* proto - This type represents the "prototype" for a function, which captures
28 * its name, and its argument names (thus implicitly the number of arguments the
29 * function takes). *)
30 type proto =
31 | Prototype of string * string array
32 | BinOpPrototype of string * string array * int
33
34 (* func - This type represents a function definition itself. *)
35 type func = Function of proto * expr
0 #include
1
2 /* putchard - putchar that takes a double and returns 0. */
3 extern double putchard(double X) {
4 putchar((char)X);
5 return 0;
6 }
7
8 /* printd - printf that takes a double prints it as "%f\n", returning 0. */
9 extern double printd(double X) {
10 printf("%f\n", X);
11 return 0;
12 }
0 (*===----------------------------------------------------------------------===
1 * Code Generation
2 *===----------------------------------------------------------------------===*)
3
4 open Llvm
5
6 exception Error of string
7
8 let context = global_context ()
9 let the_module = create_module context "my cool jit"
10 let builder = builder context
11 let named_values:(string, llvalue) Hashtbl.t = Hashtbl.create 10
12 let double_type = double_type context
13
14 let rec codegen_expr = function
15 | Ast.Number n -> const_float double_type n
16 | Ast.Variable name ->
17 (try Hashtbl.find named_values name with
18 | Not_found -> raise (Error "unknown variable name"))
19 | Ast.Unary (op, operand) ->
20 let operand = codegen_expr operand in
21 let callee = "unary" ^ (String.make 1 op) in
22 let callee =
23 match lookup_function callee the_module with
24 | Some callee -> callee
25 | None -> raise (Error "unknown unary operator")
26 in
27 build_call callee [|operand|] "unop" builder
28 | Ast.Binary (op, lhs, rhs) ->
29 let lhs_val = codegen_expr lhs in
30 let rhs_val = codegen_expr rhs in
31 begin
32 match op with
33 | '+' -> build_add lhs_val rhs_val "addtmp" builder
34 | '-' -> build_sub lhs_val rhs_val "subtmp" builder
35 | '*' -> build_mul lhs_val rhs_val "multmp" builder
36 | '<' ->
37 (* Convert bool 0/1 to double 0.0 or 1.0 *)
38 let i = build_fcmp Fcmp.Ult lhs_val rhs_val "cmptmp" builder in
39 build_uitofp i double_type "booltmp" builder
40 | _ ->
41 (* If it wasn't a builtin binary operator, it must be a user defined
42 * one. Emit a call to it. *)
43 let callee = "binary" ^ (String.make 1 op) in
44 let callee =
45 match lookup_function callee the_module with
46 | Some callee -> callee
47 | None -> raise (Error "binary operator not found!")
48 in
49 build_call callee [|lhs_val; rhs_val|] "binop" builder
50 end
51 | Ast.Call (callee, args) ->
52 (* Look up the name in the module table. *)
53 let callee =
54 match lookup_function callee the_module with
55 | Some callee -> callee
56 | None -> raise (Error "unknown function referenced")
57 in
58 let params = params callee in
59
60 (* If argument mismatch error. *)
61 if Array.length params == Array.length args then () else
62 raise (Error "incorrect # arguments passed");
63 let args = Array.map codegen_expr args in
64 build_call callee args "calltmp" builder
65 | Ast.If (cond, then_, else_) ->
66 let cond = codegen_expr cond in
67
68 (* Convert condition to a bool by comparing equal to 0.0 *)
69 let zero = const_float double_type 0.0 in
70 let cond_val = build_fcmp Fcmp.One cond zero "ifcond" builder in
71
72 (* Grab the first block so that we might later add the conditional branch
73 * to it at the end of the function. *)
74 let start_bb = insertion_block builder in
75 let the_function = block_parent start_bb in
76
77 let then_bb = append_block context "then" the_function in
78
79 (* Emit 'then' value. *)
80 position_at_end then_bb builder;
81 let then_val = codegen_expr then_ in
82
83 (* Codegen of 'then' can change the current block, update then_bb for the
84 * phi. We create a new name because one is used for the phi node, and the
85 * other is used for the conditional branch. *)
86 let new_then_bb = insertion_block builder in
87
88 (* Emit 'else' value. *)
89 let else_bb = append_block context "else" the_function in
90 position_at_end else_bb builder;
91 let else_val = codegen_expr else_ in
92
93 (* Codegen of 'else' can change the current block, update else_bb for the
94 * phi. *)
95 let new_else_bb = insertion_block builder in
96
97 (* Emit merge block. *)
98 let merge_bb = append_block context "ifcont" the_function in
99 position_at_end merge_bb builder;
100 let incoming = [(then_val, new_then_bb); (else_val, new_else_bb)] in
101 let phi = build_phi incoming "iftmp" builder in
102
103 (* Return to the start block to add the conditional branch. *)
104 position_at_end start_bb builder;
105 ignore (build_cond_br cond_val then_bb else_bb builder);
106
107 (* Set a unconditional branch at the end of the 'then' block and the
108 * 'else' block to the 'merge' block. *)
109 position_at_end new_then_bb builder; ignore (build_br merge_bb builder);
110 position_at_end new_else_bb builder; ignore (build_br merge_bb builder);
111
112 (* Finally, set the builder to the end of the merge block. *)
113 position_at_end merge_bb builder;
114
115 phi
116 | Ast.For (var_name, start, end_, step, body) ->
117 (* Emit the start code first, without 'variable' in scope. *)
118 let start_val = codegen_expr start in
119
120 (* Make the new basic block for the loop header, inserting after current
121 * block. *)
122 let preheader_bb = insertion_block builder in
123 let the_function = block_parent preheader_bb in
124 let loop_bb = append_block context "loop" the_function in
125
126 (* Insert an explicit fall through from the current block to the
127 * loop_bb. *)
128 ignore (build_br loop_bb builder);
129
130 (* Start insertion in loop_bb. *)
131 position_at_end loop_bb builder;
132
133 (* Start the PHI node with an entry for start. *)
134 let variable = build_phi [(start_val, preheader_bb)] var_name builder in
135
136 (* Within the loop, the variable is defined equal to the PHI node. If it
137 * shadows an existing variable, we have to restore it, so save it
138 * now. *)
139 let old_val =
140 try Some (Hashtbl.find named_values var_name) with Not_found -> None
141 in
142 Hashtbl.add named_values var_name variable;
143
144 (* Emit the body of the loop. This, like any other expr, can change the
145 * current BB. Note that we ignore the value computed by the body, but
146 * don't allow an error *)
147 ignore (codegen_expr body);
148
149 (* Emit the step value. *)
150 let step_val =
151 match step with
152 | Some step -> codegen_expr step
153 (* If not specified, use 1.0. *)
154 | None -> const_float double_type 1.0
155 in
156
157 let next_var = build_add variable step_val "nextvar" builder in
158
159 (* Compute the end condition. *)
160 let end_cond = codegen_expr end_ in
161
162 (* Convert condition to a bool by comparing equal to 0.0. *)
163 let zero = const_float double_type 0.0 in
164 let end_cond = build_fcmp Fcmp.One end_cond zero "loopcond" builder in
165
166 (* Create the "after loop" block and insert it. *)
167 let loop_end_bb = insertion_block builder in
168 let after_bb = append_block context "afterloop" the_function in
169
170 (* Insert the conditional branch into the end of loop_end_bb. *)
171 ignore (build_cond_br end_cond loop_bb after_bb builder);
172
173 (* Any new code will be inserted in after_bb. *)
174 position_at_end after_bb builder;
175
176 (* Add a new entry to the PHI node for the backedge. *)
177 add_incoming (next_var, loop_end_bb) variable;
178
179 (* Restore the unshadowed variable. *)
180 begin match old_val with
181 | Some old_val -> Hashtbl.add named_values var_name old_val
182 | None -> ()
183 end;
184
185 (* for expr always returns 0.0. *)
186 const_null double_type
187
188 let codegen_proto = function
189 | Ast.Prototype (name, args) | Ast.BinOpPrototype (name, args, _) ->
190 (* Make the function type: double(double,double) etc. *)
191 let doubles = Array.make (Array.length args) double_type in
192 let ft = function_type double_type doubles in
193 let f =
194 match lookup_function name the_module with
195 | None -> declare_function name ft the_module
196
197 (* If 'f' conflicted, there was already something named 'name'. If it
198 * has a body, don't allow redefinition or reextern. *)
199 | Some f ->
200 (* If 'f' already has a body, reject this. *)
201 if block_begin f <> At_end f then
202 raise (Error "redefinition of function");
203
204 (* If 'f' took a different number of arguments, reject. *)
205 if element_type (type_of f) <> ft then
206 raise (Error "redefinition of function with different # args");
207 f
208 in
209
210 (* Set names for all arguments. *)
211 Array.iteri (fun i a ->
212 let n = args.(i) in
213 set_value_name n a;
214 Hashtbl.add named_values n a;
215 ) (params f);
216 f
217
218 let codegen_func the_fpm = function
219 | Ast.Function (proto, body) ->
220 Hashtbl.clear named_values;
221 let the_function = codegen_proto proto in
222
223 (* If this is an operator, install it. *)
224 begin match proto with
225 | Ast.BinOpPrototype (name, args, prec) ->
226 let op = name.[String.length name - 1] in
227 Hashtbl.add Parser.binop_precedence op prec;
228 | _ -> ()
229 end;
230
231 (* Create a new basic block to start insertion into. *)
232 let bb = append_block context "entry" the_function in
233 position_at_end bb builder;
234
235 try
236 let ret_val = codegen_expr body in
237
238 (* Finish off the function. *)
239 let _ = build_ret ret_val builder in
240
241 (* Validate the generated code, checking for consistency. *)
242 Llvm_analysis.assert_valid_function the_function;
243
244 (* Optimize the function. *)
245 let _ = PassManager.run_function the_function the_fpm in
246
247 the_function
248 with e ->
249 delete_function the_function;
250 raise e
0 (*===----------------------------------------------------------------------===
1 * Lexer
2 *===----------------------------------------------------------------------===*)
3
4 let rec lex = parser
5 (* Skip any whitespace. *)
6 | [< ' (' ' | '\n' | '\r' | '\t'); stream >] -> lex stream
7
8 (* identifier: [a-zA-Z][a-zA-Z0-9] *)
9 | [< ' ('A' .. 'Z' | 'a' .. 'z' as c); stream >] ->
10 let buffer = Buffer.create 1 in
11 Buffer.add_char buffer c;
12 lex_ident buffer stream
13
14 (* number: [0-9.]+ *)
15 | [< ' ('0' .. '9' as c); stream >] ->
16 let buffer = Buffer.create 1 in
17 Buffer.add_char buffer c;
18 lex_number buffer stream
19
20 (* Comment until end of line. *)
21 | [< ' ('#'); stream >] ->
22 lex_comment stream
23
24 (* Otherwise, just return the character as its ascii value. *)
25 | [< 'c; stream >] ->
26 [< 'Token.Kwd c; lex stream >]
27
28 (* end of stream. *)
29 | [< >] -> [< >]
30
31 and lex_number buffer = parser
32 | [< ' ('0' .. '9' | '.' as c); stream >] ->
33 Buffer.add_char buffer c;
34 lex_number buffer stream
35 | [< stream=lex >] ->
36 [< 'Token.Number (float_of_string (Buffer.contents buffer)); stream >]
37
38 and lex_ident buffer = parser
39 | [< ' ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' as c); stream >] ->
40 Buffer.add_char buffer c;
41 lex_ident buffer stream
42 | [< stream=lex >] ->
43 match Buffer.contents buffer with
44 | "def" -> [< 'Token.Def; stream >]
45 | "extern" -> [< 'Token.Extern; stream >]
46 | "if" -> [< 'Token.If; stream >]
47 | "then" -> [< 'Token.Then; stream >]
48 | "else" -> [< 'Token.Else; stream >]
49 | "for" -> [< 'Token.For; stream >]
50 | "in" -> [< 'Token.In; stream >]
51 | "binary" -> [< 'Token.Binary; stream >]
52 | "unary" -> [< 'Token.Unary; stream >]
53 | id -> [< 'Token.Ident id; stream >]
54
55 and lex_comment = parser
56 | [< ' ('\n'); stream=lex >] -> stream
57 | [< 'c; e=lex_comment >] -> e
58 | [< >] -> [< >]
0 open Ocamlbuild_plugin;;
1
2 ocaml_lib ~extern:true "llvm";;
3 ocaml_lib ~extern:true "llvm_analysis";;
4 ocaml_lib ~extern:true "llvm_executionengine";;
5 ocaml_lib ~extern:true "llvm_target";;
6 ocaml_lib ~extern:true "llvm_scalar_opts";;
7
8 flag ["link"; "ocaml"; "g++"] (S[A"-cc"; A"g++"]);;
9 dep ["link"; "ocaml"; "use_bindings"] ["bindings.o"];;
0 (*===---------------------------------------------------------------------===
1 * Parser
2 *===---------------------------------------------------------------------===*)
3
4 (* binop_precedence - This holds the precedence for each binary operator that is
5 * defined *)
6 let binop_precedence:(char, int) Hashtbl.t = Hashtbl.create 10
7
8 (* precedence - Get the precedence of the pending binary operator token. *)
9 let precedence c = try Hashtbl.find binop_precedence c with Not_found -> -1
10
11 (* primary
12 * ::= identifier
13 * ::= numberexpr
14 * ::= parenexpr
15 * ::= ifexpr
16 * ::= forexpr *)
17 let rec parse_primary = parser
18 (* numberexpr ::= number *)
19 | [< 'Token.Number n >] -> Ast.Number n
20
21 (* parenexpr ::= '(' expression ')' *)
22 | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e
23
24 (* identifierexpr
25 * ::= identifier
26 * ::= identifier '(' argumentexpr ')' *)
27 | [< 'Token.Ident id; stream >] ->
28 let rec parse_args accumulator = parser
29 | [< e=parse_expr; stream >] ->
30 begin parser
31 | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e
32 | [< >] -> e :: accumulator
33 end stream
34 | [< >] -> accumulator
35 in
36 let rec parse_ident id = parser
37 (* Call. *)
38 | [< 'Token.Kwd '(';
39 args=parse_args [];
40 'Token.Kwd ')' ?? "expected ')'">] ->
41 Ast.Call (id, Array.of_list (List.rev args))
42
43 (* Simple variable ref. *)
44 | [< >] -> Ast.Variable id
45 in
46 parse_ident id stream
47
48 (* ifexpr ::= 'if' expr 'then' expr 'else' expr *)
49 | [< 'Token.If; c=parse_expr;
50 'Token.Then ?? "expected 'then'"; t=parse_expr;
51 'Token.Else ?? "expected 'else'"; e=parse_expr >] ->
52 Ast.If (c, t, e)
53
54 (* forexpr
55 ::= 'for' identifier '=' expr ',' expr (',' expr)? 'in' expression *)
56 | [< 'Token.For;
57 'Token.Ident id ?? "expected identifier after for";
58 'Token.Kwd '=' ?? "expected '=' after for";
59 stream >] ->
60 begin parser
61 | [<
62 start=parse_expr;
63 'Token.Kwd ',' ?? "expected ',' after for";
64 end_=parse_expr;
65 stream >] ->
66 let step =
67 begin parser
68 | [< 'Token.Kwd ','; step=parse_expr >] -> Some step
69 | [< >] -> None
70 end stream
71 in
72 begin parser
73 | [< 'Token.In; body=parse_expr >] ->
74 Ast.For (id, start, end_, step, body)
75 | [< >] ->
76 raise (Stream.Error "expected 'in' after for")
77 end stream
78 | [< >] ->
79 raise (Stream.Error "expected '=' after for")
80 end stream
81
82 | [< >] -> raise (Stream.Error "unknown token when expecting an expression.")
83
84 (* unary
85 * ::= primary
86 * ::= '!' unary *)
87 and parse_unary = parser
88 (* If this is a unary operator, read it. *)
89 | [< 'Token.Kwd op when op != '(' && op != ')'; operand=parse_expr >] ->
90 Ast.Unary (op, operand)
91
92 (* If the current token is not an operator, it must be a primary expr. *)
93 | [< stream >] -> parse_primary stream
94
95 (* binoprhs
96 * ::= ('+' primary)* *)
97 and parse_bin_rhs expr_prec lhs stream =
98 match Stream.peek stream with
99 (* If this is a binop, find its precedence. *)
100 | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c ->
101 let token_prec = precedence c in
102
103 (* If this is a binop that binds at least as tightly as the current binop,
104 * consume it, otherwise we are done. *)
105 if token_prec < expr_prec then lhs else begin
106 (* Eat the binop. *)
107 Stream.junk stream;
108
109 (* Parse the unary expression after the binary operator. *)
110 let rhs = parse_unary stream in
111
112 (* Okay, we know this is a binop. *)
113 let rhs =
114 match Stream.peek stream with
115 | Some (Token.Kwd c2) ->
116 (* If BinOp binds less tightly with rhs than the operator after
117 * rhs, let the pending operator take rhs as its lhs. *)
118 let next_prec = precedence c2 in
119 if token_prec < next_prec
120 then parse_bin_rhs (token_prec + 1) rhs stream
121 else rhs
122 | _ -> rhs
123 in
124
125 (* Merge lhs/rhs. *)
126 let lhs = Ast.Binary (c, lhs, rhs) in
127 parse_bin_rhs expr_prec lhs stream
128 end
129 | _ -> lhs
130
131 (* expression
132 * ::= primary binoprhs *)
133 and parse_expr = parser
134 | [< lhs=parse_unary; stream >] -> parse_bin_rhs 0 lhs stream
135
136 (* prototype
137 * ::= id '(' id* ')'
138 * ::= binary LETTER number? (id, id)
139 * ::= unary LETTER number? (id) *)
140 let parse_prototype =
141 let rec parse_args accumulator = parser
142 | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
143 | [< >] -> accumulator
144 in
145 let parse_operator = parser
146 | [< 'Token.Unary >] -> "unary", 1
147 | [< 'Token.Binary >] -> "binary", 2
148 in
149 let parse_binary_precedence = parser
150 | [< 'Token.Number n >] -> int_of_float n
151 | [< >] -> 30
152 in
153 parser
154 | [< 'Token.Ident id;
155 'Token.Kwd '(' ?? "expected '(' in prototype";
156 args=parse_args [];
157 'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
158 (* success. *)
159 Ast.Prototype (id, Array.of_list (List.rev args))
160 | [< (prefix, kind)=parse_operator;
161 'Token.Kwd op ?? "expected an operator";
162 (* Read the precedence if present. *)
163 binary_precedence=parse_binary_precedence;
164 'Token.Kwd '(' ?? "expected '(' in prototype";
165 args=parse_args [];
166 'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
167 let name = prefix ^ (String.make 1 op) in
168 let args = Array.of_list (List.rev args) in
169
170 (* Verify right number of arguments for operator. *)
171 if Array.length args != kind
172 then raise (Stream.Error "invalid number of operands for operator")
173 else
174 if kind == 1 then
175 Ast.Prototype (name, args)
176 else
177 Ast.BinOpPrototype (name, args, binary_precedence)
178 | [< >] ->
179 raise (Stream.Error "expected function name in prototype")
180
181 (* definition ::= 'def' prototype expression *)
182 let parse_definition = parser
183 | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
184 Ast.Function (p, e)
185
186 (* toplevelexpr ::= expression *)
187 let parse_toplevel = parser
188 | [< e=parse_expr >] ->
189 (* Make an anonymous proto. *)
190 Ast.Function (Ast.Prototype ("", [||]), e)
191
192 (* external ::= 'extern' prototype *)
193 let parse_extern = parser
194 | [< 'Token.Extern; e=parse_prototype >] -> e
0 (*===----------------------------------------------------------------------===
1 * Lexer Tokens
2 *===----------------------------------------------------------------------===*)
3
4 (* The lexer returns these 'Kwd' if it is an unknown character, otherwise one of
5 * these others for known things. *)
6 type token =
7 (* commands *)
8 | Def | Extern
9
10 (* primary *)
11 | Ident of string | Number of float
12
13 (* unknown *)
14 | Kwd of char
15
16 (* control *)
17 | If | Then | Else
18 | For | In
19
20 (* operators *)
21 | Binary | Unary
0 (*===----------------------------------------------------------------------===
1 * Top-Level parsing and JIT Driver
2 *===----------------------------------------------------------------------===*)
3
4 open Llvm
5 open Llvm_executionengine
6
7 (* top ::= definition | external | expression | ';' *)
8 let rec main_loop the_fpm the_execution_engine stream =
9 match Stream.peek stream with
10 | None -> ()
11
12 (* ignore top-level semicolons. *)
13 | Some (Token.Kwd ';') ->
14 Stream.junk stream;
15 main_loop the_fpm the_execution_engine stream
16
17 | Some token ->
18 begin
19 try match token with
20 | Token.Def ->
21 let e = Parser.parse_definition stream in
22 print_endline "parsed a function definition.";
23 dump_value (Codegen.codegen_func the_fpm e);
24 | Token.Extern ->
25 let e = Parser.parse_extern stream in
26 print_endline "parsed an extern.";
27 dump_value (Codegen.codegen_proto e);
28 | _ ->
29 (* Evaluate a top-level expression into an anonymous function. *)
30 let e = Parser.parse_toplevel stream in
31 print_endline "parsed a top-level expr";
32 let the_function = Codegen.codegen_func the_fpm e in
33 dump_value the_function;
34
35 (* JIT the function, returning a function pointer. *)
36 let result = ExecutionEngine.run_function the_function [||]
37 the_execution_engine in
38
39 print_string "Evaluated to ";
40 print_float (GenericValue.as_float Codegen.double_type result);
41 print_newline ();
42 with Stream.Error s | Codegen.Error s ->
43 (* Skip token for error recovery. *)
44 Stream.junk stream;
45 print_endline s;
46 end;
47 print_string "ready> "; flush stdout;
48 main_loop the_fpm the_execution_engine stream
0 (*===----------------------------------------------------------------------===
1 * Main driver code.
2 *===----------------------------------------------------------------------===*)
3
4 open Llvm
5 open Llvm_executionengine
6 open Llvm_target
7 open Llvm_scalar_opts
8
9 let main () =
10 ignore (initialize_native_target ());
11
12 (* Install standard binary operators.
13 * 1 is the lowest precedence. *)
14 Hashtbl.add Parser.binop_precedence '<' 10;
15 Hashtbl.add Parser.binop_precedence '+' 20;
16 Hashtbl.add Parser.binop_precedence '-' 20;
17 Hashtbl.add Parser.binop_precedence '*' 40; (* highest. *)
18
19 (* Prime the first token. *)
20 print_string "ready> "; flush stdout;
21 let stream = Lexer.lex (Stream.of_channel stdin) in
22
23 (* Create the JIT. *)
24 let the_execution_engine = ExecutionEngine.create Codegen.the_module in
25 let the_fpm = PassManager.create_function Codegen.the_module in
26
27 (* Set up the optimizer pipeline. Start with registering info about how the
28 * target lays out data structures. *)
29 TargetData.add (ExecutionEngine.target_data the_execution_engine) the_fpm;
30
31 (* Do simple "peephole" optimizations and bit-twiddling optzn. *)
32 add_instruction_combination the_fpm;
33
34 (* reassociate expressions. *)
35 add_reassociation the_fpm;
36
37 (* Eliminate Common SubExpressions. *)
38 add_gvn the_fpm;
39
40 (* Simplify the control flow graph (deleting unreachable blocks, etc). *)
41 add_cfg_simplification the_fpm;
42
43 ignore (PassManager.initialize the_fpm);
44
45 (* Run the main "interpreter loop" now. *)
46 Toplevel.main_loop the_fpm the_execution_engine stream;
47
48 (* Print out all the generated code. *)
49 dump_module Codegen.the_module
50 ;;
51
52 main ()
0 ##===- examples/OCaml-Kaleidoscope/Chapter7/Makefile -------*- Makefile -*-===##
1 #
2 # The LLVM Compiler Infrastructure
3 #
4 # This file is distributed under the University of Illinois Open Source
5 # License. See LICENSE.TXT for details.
6 #
7 ##===----------------------------------------------------------------------===##
8 #
9 # This is the makefile for the Objective Caml kaleidoscope tutorial, chapter 7.
10 #
11 ##===----------------------------------------------------------------------===##
12
13 LEVEL := ../../..
14 TOOLNAME := OCaml-Kaleidoscope-Ch7
15 EXAMPLE_TOOL := 1
16 UsedComponents := core
17 UsedOcamLibs := llvm llvm_analysis llvm_executionengine llvm_target \
18 llvm_scalar_opts
19
20 OCAMLCFLAGS += -pp camlp4of
21
22 ExcludeSources = $(PROJ_SRC_DIR)/myocamlbuild.ml
23
24 include $(LEVEL)/bindings/ocaml/Makefile.ocaml
0 <{lexer,parser}.ml>: use_camlp4, pp(camlp4of)
1 <*.{byte,native}>: g++, use_llvm, use_llvm_analysis
2 <*.{byte,native}>: use_llvm_executionengine, use_llvm_target
3 <*.{byte,native}>: use_llvm_scalar_opts, use_bindings
0 (*===----------------------------------------------------------------------===
1 * Abstract Syntax Tree (aka Parse Tree)
2 *===----------------------------------------------------------------------===*)
3
4 (* expr - Base type for all expression nodes. *)
5 type expr =
6 (* variant for numeric literals like "1.0". *)
7 | Number of float
8
9 (* variant for referencing a variable, like "a". *)
10 | Variable of string
11
12 (* variant for a unary operator. *)
13 | Unary of char * expr
14
15 (* variant for a binary operator. *)
16 | Binary of char * expr * expr
17
18 (* variant for function calls. *)
19 | Call of string * expr array
20
21 (* variant for if/then/else. *)
22 | If of expr * expr * expr
23
24 (* variant for for/in. *)
25 | For of string * expr * expr * expr option * expr
26
27 (* variant for var/in. *)
28 | Var of (string * expr option) array * expr
29
30 (* proto - This type represents the "prototype" for a function, which captures
31 * its name, and its argument names (thus implicitly the number of arguments the
32 * function takes). *)
33 type proto =
34 | Prototype of string * string array
35 | BinOpPrototype of string * string array * int
36
37 (* func - This type represents a function definition itself. *)
38 type func = Function of proto * expr
0 #include
1
2 /* putchard - putchar that takes a double and returns 0. */
3 extern double putchard(double X) {
4 putchar((char)X);
5 return 0;
6 }
7
8 /* printd - printf that takes a double prints it as "%f\n", returning 0. */
9 extern double printd(double X) {
10 printf("%f\n", X);
11 return 0;
12 }
0 (*===----------------------------------------------------------------------===
1 * Code Generation
2 *===----------------------------------------------------------------------===*)
3
4 open Llvm
5
6 exception Error of string
7
8 let context = global_context ()
9 let the_module = create_module context "my cool jit"
10 let builder = builder context
11 let named_values:(string, llvalue) Hashtbl.t = Hashtbl.create 10
12 let double_type = double_type context
13
14 (* Create an alloca instruction in the entry block of the function. This
15 * is used for mutable variables etc. *)
16 let create_entry_block_alloca the_function var_name =
17 let builder = builder_at context (instr_begin (entry_block the_function)) in
18 build_alloca double_type var_name builder
19
20 let rec codegen_expr = function
21 | Ast.Number n -> const_float double_type n
22 | Ast.Variable name ->
23 let v = try Hashtbl.find named_values name with
24 | Not_found -> raise (Error "unknown variable name")
25 in
26 (* Load the value. *)
27 build_load v name builder
28 | Ast.Unary (op, operand) ->
29 let operand = codegen_expr operand in
30 let callee = "unary" ^ (String.make 1 op) in
31 let callee =
32 match lookup_function callee the_module with
33 | Some callee -> callee
34 | None -> raise (Error "unknown unary operator")
35 in
36 build_call callee [|operand|] "unop" builder
37 | Ast.Binary (op, lhs, rhs) ->
38 begin match op with
39 | '=' ->
40 (* Special case '=' because we don't want to emit the LHS as an
41 * expression. *)
42 let name =
43 match lhs with
44 | Ast.Variable name -> name
45 | _ -> raise (Error "destination of '=' must be a variable")
46 in
47
48 (* Codegen the rhs. *)
49 let val_ = codegen_expr rhs in
50
51 (* Lookup the name. *)
52 let variable = try Hashtbl.find named_values name with
53 | Not_found -> raise (Error "unknown variable name")
54 in
55 ignore(build_store val_ variable builder);
56 val_
57 | _ ->
58 let lhs_val = codegen_expr lhs in
59 let rhs_val = codegen_expr rhs in
60 begin
61 match op with
62 | '+' -> build_add lhs_val rhs_val "addtmp" builder
63 | '-' -> build_sub lhs_val rhs_val "subtmp" builder
64 | '*' -> build_mul lhs_val rhs_val "multmp" builder
65 | '<' ->
66 (* Convert bool 0/1 to double 0.0 or 1.0 *)
67 let i = build_fcmp Fcmp.Ult lhs_val rhs_val "cmptmp" builder in
68 build_uitofp i double_type "booltmp" builder
69 | _ ->
70 (* If it wasn't a builtin binary operator, it must be a user defined
71 * one. Emit a call to it. *)
72 let callee = "binary" ^ (String.make 1 op) in
73 let callee =
74 match lookup_function callee the_module with
75 | Some callee -> callee
76 | None -> raise (Error "binary operator not found!")
77 in
78 build_call callee [|lhs_val; rhs_val|] "binop" builder
79 end
80 end
81 | Ast.Call (callee, args) ->
82 (* Look up the name in the module table. *)
83 let callee =
84 match lookup_function callee the_module with
85 | Some callee -> callee
86 | None -> raise (Error "unknown function referenced")
87 in
88 let params = params callee in
89
90 (* If argument mismatch error. *)
91 if Array.length params == Array.length args then () else
92 raise (Error "incorrect # arguments passed");
93 let args = Array.map codegen_expr args in
94 build_call callee args "calltmp" builder
95 | Ast.If (cond, then_, else_) ->
96 let cond = codegen_expr cond in
97
98 (* Convert condition to a bool by comparing equal to 0.0 *)
99 let zero = const_float double_type 0.0 in
100 let cond_val = build_fcmp Fcmp.One cond zero "ifcond" builder in
101
102 (* Grab the first block so that we might later add the conditional branch
103 * to it at the end of the function. *)
104 let start_bb = insertion_block builder in
105 let the_function = block_parent start_bb in
106
107 let then_bb = append_block context "then" the_function in
108
109 (* Emit 'then' value. *)
110 position_at_end then_bb builder;
111 let then_val = codegen_expr then_ in
112
113 (* Codegen of 'then' can change the current block, update then_bb for the
114 * phi. We create a new name because one is used for the phi node, and the
115 * other is used for the conditional branch. *)
116 let new_then_bb = insertion_block builder in
117
118 (* Emit 'else' value. *)
119 let else_bb = append_block context "else" the_function in
120 position_at_end else_bb builder;
121 let else_val = codegen_expr else_ in
122
123 (* Codegen of 'else' can change the current block, update else_bb for the
124 * phi. *)
125 let new_else_bb = insertion_block builder in
126
127 (* Emit merge block. *)
128 let merge_bb = append_block context "ifcont" the_function in
129 position_at_end merge_bb builder;
130 let incoming = [(then_val, new_then_bb); (else_val, new_else_bb)] in
131 let phi = build_phi incoming "iftmp" builder in
132
133 (* Return to the start block to add the conditional branch. *)
134 position_at_end start_bb builder;
135 ignore (build_cond_br cond_val then_bb else_bb builder);
136
137 (* Set a unconditional branch at the end of the 'then' block and the
138 * 'else' block to the 'merge' block. *)
139 position_at_end new_then_bb builder; ignore (build_br merge_bb builder);
140 position_at_end new_else_bb builder; ignore (build_br merge_bb builder);
141
142 (* Finally, set the builder to the end of the merge block. *)
143 position_at_end merge_bb builder;
144
145 phi
146 | Ast.For (var_name, start, end_, step, body) ->
147 (* Output this as:
148 * var = alloca double
149 * ...
150 * start = startexpr
151 * store start -> var
152 * goto loop
153 * loop:
154 * ...
155 * bodyexpr
156 * ...
157 * loopend:
158 * step = stepexpr
159 * endcond = endexpr
160 *
161 * curvar = load var
162 * nextvar = curvar + step
163 * store nextvar -> var
164 * br endcond, loop, endloop
165 * outloop: *)
166
167 let the_function = block_parent (insertion_block builder) in
168
169 (* Create an alloca for the variable in the entry block. *)
170 let alloca = create_entry_block_alloca the_function var_name in
171
172 (* Emit the start code first, without 'variable' in scope. *)
173 let start_val = codegen_expr start in
174
175 (* Store the value into the alloca. *)
176 ignore(build_store start_val alloca builder);
177
178 (* Make the new basic block for the loop header, inserting after current
179 * block. *)
180 let loop_bb = append_block context "loop" the_function in
181
182 (* Insert an explicit fall through from the current block to the
183 * loop_bb. *)
184 ignore (build_br loop_bb builder);
185
186 (* Start insertion in loop_bb. *)
187 position_at_end loop_bb builder;
188
189 (* Within the loop, the variable is defined equal to the PHI node. If it
190 * shadows an existing variable, we have to restore it, so save it
191 * now. *)
192 let old_val =
193 try Some (Hashtbl.find named_values var_name) with Not_found -> None
194 in
195 Hashtbl.add named_values var_name alloca;
196
197 (* Emit the body of the loop. This, like any other expr, can change the
198 * current BB. Note that we ignore the value computed by the body, but
199 * don't allow an error *)
200 ignore (codegen_expr body);
201
202 (* Emit the step value. *)
203 let step_val =
204 match step with
205 | Some step -> codegen_expr step
206 (* If not specified, use 1.0. *)
207 | None -> const_float double_type 1.0
208 in
209
210 (* Compute the end condition. *)
211 let end_cond = codegen_expr end_ in
212
213 (* Reload, increment, and restore the alloca. This handles the case where
214 * the body of the loop mutates the variable. *)
215 let cur_var = build_load alloca var_name builder in
216 let next_var = build_add cur_var step_val "nextvar" builder in
217 ignore(build_store next_var alloca builder);
218
219 (* Convert condition to a bool by comparing equal to 0.0. *)
220 let zero = const_float double_type 0.0 in
221 let end_cond = build_fcmp Fcmp.One end_cond zero "loopcond" builder in
222
223 (* Create the "after loop" block and insert it. *)
224 let after_bb = append_block context "afterloop" the_function in
225
226 (* Insert the conditional branch into the end of loop_end_bb. *)
227 ignore (build_cond_br end_cond loop_bb after_bb builder);
228
229 (* Any new code will be inserted in after_bb. *)
230 position_at_end after_bb builder;
231
232 (* Restore the unshadowed variable. *)
233 begin match old_val with
234 | Some old_val -> Hashtbl.add named_values var_name old_val
235 | None -> ()
236 end;
237
238 (* for expr always returns 0.0. *)
239 const_null double_type
240 | Ast.Var (var_names, body) ->
241 let old_bindings = ref [] in
242
243 let the_function = block_parent (insertion_block builder) in
244
245 (* Register all variables and emit their initializer. *)
246 Array.iter (fun (var_name, init) ->
247 (* Emit the initializer before adding the variable to scope, this
248 * prevents the initializer from referencing the variable itself, and
249 * permits stuff like this:
250 * var a = 1 in
251 * var a = a in ... # refers to outer 'a'. *)
252 let init_val =
253 match init with
254 | Some init -> codegen_expr init
255 (* If not specified, use 0.0. *)
256 | None -> const_float double_type 0.0
257 in
258
259 let alloca = create_entry_block_alloca the_function var_name in
260 ignore(build_store init_val alloca builder);
261
262 (* Remember the old variable binding so that we can restore the binding
263 * when we unrecurse. *)
264 begin
265 try
266 let old_value = Hashtbl.find named_values var_name in
267 old_bindings := (var_name, old_value) :: !old_bindings;
268 with Not_found -> ()
269 end;
270
271 (* Remember this binding. *)
272 Hashtbl.add named_values var_name alloca;
273 ) var_names;
274
275 (* Codegen the body, now that all vars are in scope. *)
276 let body_val = codegen_expr body in
277
278 (* Pop all our variables from scope. *)
279 List.iter (fun (var_name, old_value) ->
280 Hashtbl.add named_values var_name old_value
281 ) !old_bindings;
282
283 (* Return the body computation. *)
284 body_val
285
286 let codegen_proto = function
287 | Ast.Prototype (name, args) | Ast.BinOpPrototype (name, args, _) ->
288 (* Make the function type: double(double,double) etc. *)
289 let doubles = Array.make (Array.length args) double_type in
290 let ft = function_type double_type doubles in
291 let f =
292 match lookup_function name the_module with
293 | None -> declare_function name ft the_module
294
295 (* If 'f' conflicted, there was already something named 'name'. If it
296 * has a body, don't allow redefinition or reextern. *)
297 | Some f ->
298 (* If 'f' already has a body, reject this. *)
299 if block_begin f <> At_end f then
300 raise (Error "redefinition of function");
301
302 (* If 'f' took a different number of arguments, reject. *)
303 if element_type (type_of f) <> ft then
304 raise (Error "redefinition of function with different # args");
305 f
306 in
307
308 (* Set names for all arguments. *)
309 Array.iteri (fun i a ->
310 let n = args.(i) in
311 set_value_name n a;
312 Hashtbl.add named_values n a;
313 ) (params f);
314 f
315
316 (* Create an alloca for each argument and register the argument in the symbol
317 * table so that references to it will succeed. *)
318 let create_argument_allocas the_function proto =
319 let args = match proto with
320 | Ast.Prototype (_, args) | Ast.BinOpPrototype (_, args, _) -> args
321 in
322 Array.iteri (fun i ai ->
323 let var_name = args.(i) in
324 (* Create an alloca for this variable. *)
325 let alloca = create_entry_block_alloca the_function var_name in
326
327 (* Store the initial value into the alloca. *)
328 ignore(build_store ai alloca builder);
329
330 (* Add arguments to variable symbol table. *)
331 Hashtbl.add named_values var_name alloca;
332 ) (params the_function)
333
334 let codegen_func the_fpm = function
335 | Ast.Function (proto, body) ->
336 Hashtbl.clear named_values;
337 let the_function = codegen_proto proto in
338
339 (* If this is an operator, install it. *)
340 begin match proto with
341 | Ast.BinOpPrototype (name, args, prec) ->
342 let op = name.[String.length name - 1] in
343 Hashtbl.add Parser.binop_precedence op prec;
344 | _ -> ()
345 end;
346
347 (* Create a new basic block to start insertion into. *)
348 let bb = append_block context "entry" the_function in
349 position_at_end bb builder;
350
351 try
352 (* Add all arguments to the symbol table and create their allocas. *)
353 create_argument_allocas the_function proto;
354
355 let ret_val = codegen_expr body in
356
357 (* Finish off the function. *)
358 let _ = build_ret ret_val builder in
359
360 (* Validate the generated code, checking for consistency. *)
361 Llvm_analysis.assert_valid_function the_function;
362
363 (* Optimize the function. *)
364 let _ = PassManager.run_function the_function the_fpm in
365
366 the_function
367 with e ->
368 delete_function the_function;
369 raise e
0 (*===----------------------------------------------------------------------===
1 * Lexer
2 *===----------------------------------------------------------------------===*)
3
4 let rec lex = parser
5 (* Skip any whitespace. *)
6 | [< ' (' ' | '\n' | '\r' | '\t'); stream >] -> lex stream
7
8 (* identifier: [a-zA-Z][a-zA-Z0-9] *)
9 | [< ' ('A' .. 'Z' | 'a' .. 'z' as c); stream >] ->
10 let buffer = Buffer.create 1 in
11 Buffer.add_char buffer c;
12 lex_ident buffer stream
13
14 (* number: [0-9.]+ *)
15 | [< ' ('0' .. '9' as c); stream >] ->
16 let buffer = Buffer.create 1 in
17 Buffer.add_char buffer c;
18 lex_number buffer stream
19
20 (* Comment until end of line. *)
21 | [< ' ('#'); stream >] ->
22 lex_comment stream
23
24 (* Otherwise, just return the character as its ascii value. *)
25 | [< 'c; stream >] ->
26 [< 'Token.Kwd c; lex stream >]
27
28 (* end of stream. *)
29 | [< >] -> [< >]
30
31 and lex_number buffer = parser
32 | [< ' ('0' .. '9' | '.' as c); stream >] ->
33 Buffer.add_char buffer c;
34 lex_number buffer stream
35 | [< stream=lex >] ->
36 [< 'Token.Number (float_of_string (Buffer.contents buffer)); stream >]
37
38 and lex_ident buffer = parser
39 | [< ' ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' as c); stream >] ->
40 Buffer.add_char buffer c;
41 lex_ident buffer stream
42 | [< stream=lex >] ->
43 match Buffer.contents buffer with
44 | "def" -> [< 'Token.Def; stream >]
45 | "extern" -> [< 'Token.Extern; stream >]
46 | "if" -> [< 'Token.If; stream >]
47 | "then" -> [< 'Token.Then; stream >]
48 | "else" -> [< 'Token.Else; stream >]
49 | "for" -> [< 'Token.For; stream >]
50 | "in" -> [< 'Token.In; stream >]
51 | "binary" -> [< 'Token.Binary; stream >]
52 | "unary" -> [< 'Token.Unary; stream >]
53 | "var" -> [< 'Token.Var; stream >]
54 | id -> [< 'Token.Ident id; stream >]
55
56 and lex_comment = parser
57 | [< ' ('\n'); stream=lex >] -> stream
58 | [< 'c; e=lex_comment >] -> e
59 | [< >] -> [< >]
0 open Ocamlbuild_plugin;;
1
2 ocaml_lib ~extern:true "llvm";;
3 ocaml_lib ~extern:true "llvm_analysis";;
4 ocaml_lib ~extern:true "llvm_executionengine";;
5 ocaml_lib ~extern:true "llvm_target";;
6 ocaml_lib ~extern:true "llvm_scalar_opts";;
7
8 flag ["link"; "ocaml"; "g++"] (S[A"-cc"; A"g++"]);;
9 dep ["link"; "ocaml"; "use_bindings"] ["bindings.o"];;
0 (*===---------------------------------------------------------------------===
1 * Parser
2 *===---------------------------------------------------------------------===*)
3
4 (* binop_precedence - This holds the precedence for each binary operator that is
5 * defined *)
6 let binop_precedence:(char, int) Hashtbl.t = Hashtbl.create 10
7
8 (* precedence - Get the precedence of the pending binary operator token. *)
9 let precedence c = try Hashtbl.find binop_precedence c with Not_found -> -1
10
11 (* primary
12 * ::= identifier
13 * ::= numberexpr
14 * ::= parenexpr
15 * ::= ifexpr
16 * ::= forexpr
17 * ::= varexpr *)
18 let rec parse_primary = parser
19 (* numberexpr ::= number *)
20 | [< 'Token.Number n >] -> Ast.Number n
21
22 (* parenexpr ::= '(' expression ')' *)
23 | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e
24
25 (* identifierexpr
26 * ::= identifier
27 * ::= identifier '(' argumentexpr ')' *)
28 | [< 'Token.Ident id; stream >] ->
29 let rec parse_args accumulator = parser
30 | [< e=parse_expr; stream >] ->
31 begin parser
32 | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e
33 | [< >] -> e :: accumulator
34 end stream
35 | [< >] -> accumulator
36 in
37 let rec parse_ident id = parser
38 (* Call. *)
39 | [< 'Token.Kwd '(';
40 args=parse_args [];
41 'Token.Kwd ')' ?? "expected ')'">] ->
42 Ast.Call (id, Array.of_list (List.rev args))
43
44 (* Simple variable ref. *)
45 | [< >] -> Ast.Variable id
46 in
47 parse_ident id stream
48
49 (* ifexpr ::= 'if' expr 'then' expr 'else' expr *)
50 | [< 'Token.If; c=parse_expr;
51 'Token.Then ?? "expected 'then'"; t=parse_expr;