OCamlのSedlex+Menhir+LLVMでLispコンパイラを作ろうとしたが行き詰まった件

言語実装素人ですが、LispのLLVMフロントエンドを作ろうとした記録を残したいと思います。
途中で行き詰まってしまったので、また進展があれば随時更新していきます。

2016/12/10 23:55 追記しました。carで値が取り出せるように。

目標

cons・car・cdrと四則演算+-*/を用いたLispコードをLLVM IRに変換する。

環境

• OCaml 4.03.0
• oasis 0.4.7
• llvm 3.9
• sedlex 1.99.3
• menhir 20160825
• ppx_deriving 4.1

開発の流れ

全体的にここを参考にして進めた。

ビルドツールのセットアップ

開発ディレクトリ直下にsrcディレクトリと_oasisファイルを作成。

_oasis

OASISFormat: 0.4
Name:        Llclimp
Version:     0.1.0
Synopsis:    LLVM Common Lisp Implementation.
Authors:     Tamamu
License:     MIT
Plugins:     META (0.4)

BuildTools: ocamlbuild

Library llclimp
  Path:       src
  InternalModules: Parser
  Modules: Ast, Syntax
  CompiledObject: best
  BuildDepends:
    llvm, llvm.analysis, llvm.bitreader, sedlex, menhirLib, ppx_deriving.show

Executable llclimp
  Path:       src
  MainIs:     main.ml
  CompiledObject: best
  BuildDepends: llclimp

以下のコマンドでビルド用のスクリプトを作成。

$ oasis setup -setup-update dynamic

ビルドする時はこう。

$ ocaml setup.ml -build -use-menhir

構文解析

まずparserとlexerを作った。
構文木のためのデータ型を定義する。
[@@deriving show]で自動的にその型のprinterが作られる。

src/ast.ml

type atom =
  | Nil
  | T
  | Integer of int
  | Float of float
  | String of string
  | Symbol of string
[@@deriving show]

type statement =
  |Sexp of statement list
  |Atom of atom
[@@deriving show]

menhir-exampleを参考にparserを作成。

src/parser.mly

%{ open Ast %}

%token Nil
%token T
%token <string> Symbol
%token <int> Integer
%token <float> Float
%token <string> String
%token LParen RParen Eof

%start main
%type <Ast.statement list> main

%start main_statement
%type <Ast.statement option> main_statement

%%

main:
| statements = list(statement) Eof {statements}

main_statement:
| statement = statement {Some statement}
| Eof {None}

statement:
| sexp=sexp {Sexp sexp}
| atom=atom {Atom atom}

sexp:
| LParen statements=list(statement) RParen {statements}

atom:
| Nil {Nil}
| T {T}
| i=Integer {Integer i}
| f=Float {Float f}
| str=String {String str}
| sym=Symbol {Symbol sym}

数値型以外にもtや文字列型を定義しているが、今回は使わないので無視してもよい。

次に字句解析器を作っていく。
トークン化の部分を変えただけで、ほとんど参考先を写経したに過ぎない。
sedlexの正規表現の書き方はGithubのページに書いてあるものを参考にした。
https://github.com/alainfrisch/sedlex
また識別子名に使える文字は以下のページを参考に、C#のものを真似してみた。
http://ufcpp.net/study/csharp/misc_identifier.html

src/syntax.ml

type lexbuf = {
  stream: Sedlexing.lexbuf;
  mutable pos: Lexing.position;
}

let create_lexbuf ?(file="") stream =
  let pos = {Lexing.
              pos_fname = file;
              pos_lnum = 1;
              pos_bol = 0;
              pos_cnum = 0;
            }
  in {pos; stream}

let new_line ?(n=0) lexbuf =
  let open Lexing in
  let lcp = lexbuf.pos in
  lexbuf.pos <-
    {lcp with
     pos_lnum = lcp.pos_lnum + 1;
     pos_bol = lcp.pos_cnum;
    }

let update lexbuf =
  let new_pos = Sedlexing.lexeme_end lexbuf.stream in
  let p = lexbuf.pos in
  lexbuf.pos <- {p with Lexing.pos_cnum = new_pos}

let lexeme {stream} = Sedlexing.Utf8.lexeme stream

(** [ParseError (file, line, col, token)] *)
exception ParseError of (string * int * int * string)

let raise_ParseError lexbuf =
  let {pos} = lexbuf in
  let line = pos.pos_lnum in
  let col = pos.pos_cnum - pos.pos_bol in
  let tok = lexeme lexbuf in
  raise @@ ParseError (pos.pos_fname, line, col, tok)

let string_of_ParseError (file, line, cnum, tok) =
  let file_to_string file =
    if file = "" then ""
    else " on file " ^ file
  in
  Printf.sprintf
    "Parse error%s line %i, column %i, token %s"
    (file_to_string file)
    line cnum tok

(** Sedlexの構文に従ってトークン表現を定義 *)
(** 数字1文字にマッチ *)
let exp_digit = [%sedlex.regexp? '0'..'9']
(** 識別子の先頭文字 *)
let exp_initial = [%sedlex.regexp? alphabetic | Chars "!#$%&=-+*<>?/" | lu | ll | lt | lm | lo | nl]
(** 識別子の先頭以降の文字 *)
let exp_rest = [%sedlex.regexp? exp_initial | mn | mc | pc | cf | '.' | exp_digit]
(** Symbolのトークン表現 *)
let exp_symbol = [%sedlex.regexp? exp_initial, Star exp_rest]
(** Integerのトークン表現 *)
let exp_integer = [%sedlex.regexp? (Opt (Chars "+-")), Plus exp_digit]
(** Floatのトークン表現 *)
let exp_float = [%sedlex.regexp? (Opt (Chars "+-")),
                               ((Opt exp_digit, '.', exp_integer)
                               | (Plus exp_digit, '.', Opt exp_integer))]
(** Stringのトークン表現 *)
let exp_string = [%sedlex.regexp? '"', Star any, '"']

(** 字句解析 *)
let rec lex lexbuf =
  let buf = lexbuf.stream in
  match%sedlex buf with

  (** 改行 *)
  | '\n' ->
    update lexbuf; new_line lexbuf;
    lex lexbuf

  (** 空白文字 *)
  | white_space ->
    update lexbuf;
    lex lexbuf

  | 't' ->
    update lexbuf;
    Parser.T

  | "nil" ->
    update lexbuf;
    Parser.Nil

  | exp_integer ->
    update lexbuf;
    Parser.Integer (int_of_string @@ lexeme lexbuf)

  | exp_float ->
    update lexbuf;
    Parser.Float (float_of_string @@ lexeme lexbuf)

  | exp_string ->
    update lexbuf;
    Parser.String (lexeme lexbuf)

  | exp_symbol ->
    update lexbuf;
    Parser.Symbol (lexeme lexbuf)

  (** コメント *)
  | ';', Star (Compl '\n'), '\n' ->
    update lexbuf; new_line lexbuf;
    lex lexbuf

  | eof ->
    update lexbuf;
    Parser.Eof

  | '(' -> update lexbuf; Parser.LParen
  | ')' -> update lexbuf; Parser.RParen

  | _ ->
    update lexbuf;
    raise_ParseError lexbuf


let parse f lexbuf =
  let lexer () =
    let ante_position = lexbuf.pos in
    let token = lex lexbuf in
    let post_position = lexbuf.pos
    in (token, ante_position, post_position) in
  let parser =
    MenhirLib.Convert.Simplified.traditional2revised f
  in
  try
    parser lexer
  with
  | Parser.Error
  | Sedlexing.MalFormed
  | Sedlexing.InvalidCodepoint _
    -> raise_ParseError lexbuf

let parse_program lexbuf =
  parse Parser.main lexbuf


let parse_statement lexbuf =
  parse Parser.main_statement lexbuf

続いて字句解析器のインターフェースを作成。

src/syntax.mli

type lexbuf

val create_lexbuf:
  ?file:string -> Sedlexing.lexbuf -> lexbuf

val parse_program:
  lexbuf -> Ast.statement list

val parse_statement:
  lexbuf -> Ast.statement option


exception ParseError of (string * int * int * string)

val string_of_ParseError: (string * int * int * string) -> string

以上で構文解析器の完成。

構文木を出力

構文解析器が正しく構文木を出力できるか試してみる。
標準入力からLispコードを受け取って、構文木を出力するループを作成する。

src/toplevel.ml

let rec main_loop () : unit =
  Printf.printf "ready> %!";
  match
    let lexbuf = Syntax.create_lexbuf @@
      Sedlexing.Utf8.from_channel stdin in
    Syntax.parse_statement lexbuf
  with
  | Some statement -> begin
      print_endline @@ Ast.show_statement statement;
      main_loop ()
    end

  | exception Syntax.ParseError e -> begin
      print_endline @@ Syntax.string_of_ParseError e;
      main_loop ()
    end

  | None -> print_newline ()

メインファイルからこのループを呼び出す。

src/main.ml

let main () =
  Toplevel.main_loop ();;

main ()

ここまでで一旦ビルドして実行してみた。

$ ./main.native
ready> (cons "Hello" (cons 14 9))  
(Ast.Sexp
   [(Ast.Atom (Ast.Symbol "cons")); (Ast.Atom (Ast.String "\"Hello\""));
     (Ast.Sexp
        [(Ast.Atom (Ast.Symbol "cons")); (Ast.Atom (Ast.Integer 14));
          (Ast.Atom (Ast.Integer 9))])
     ])
ready>

ちゃんとパース出来ているっぽい。

LLVMコード生成

ここから実際にLLVM IRを吐けるようにしていく。
まずコード生成部分の本体を作成。

src/codegen.ml

open Llvm

exception Error of string

let context = global_context ()
let the_module = create_module context "llclimp"
let builder = builder context
let symbol_tbl:(string, llvalue) Hashtbl.t = Hashtbl.create 10
let bit_type = i1_type context
let integer_type = i32_type context
let address_type = i8_type context
let float_type = float_type context
let cell_type = named_struct_type context "cell";;
struct_set_body cell_type [|address_type; address_type|] false;

let rec codegen = function
    Ast.Sexp vals ->
    (try
       let head = match (List.hd vals) with
           Ast.Sexp sexp -> raise (Error "Not implemented: Call the S-expression")
         | Ast.Atom atom -> atom
       in
       match head with
         Ast.Symbol name ->
         let args = Array.of_list (try List.tl vals with Failure "tl" -> []) in
         let callee = match lookup_function name the_module with
           | Some func -> func
           | None -> raise (Error "unknown function")
         in let params = params callee in
         if Array.length params == Array.length args then () else
           raise (Error "incorrect # arguments passed");
         let args = Array.map codegen args in
         build_call callee args "calltmp" builder
       | _ -> raise (Error "Expect any function")
     with
       Failure "hd" -> const_int bit_type 0)
  | Ast.Atom atom -> codegen_expr atom

and codegen_expr = function
  | Ast.Integer n -> const_int integer_type n
  | Ast.Float n -> const_float float_type n
  | Ast.String s -> const_string context s
  | Ast.Nil -> const_int bit_type 0
  | Ast.T -> const_int bit_type 1
  | Ast.Symbol name ->
    (try Hashtbl.find symbol_tbl name with
     | Not_found -> raise (Error "unknown symbol"))
  | _ -> raise (Error "unknown symbol")

次に、構文木と共にIRコードを出力するようにメインループを修正。

src/toplevel.ml

open Llvm

(** 中略 *)
  | Some statement -> begin
      print_endline @@ Ast.show_statement statement;
      dump_value (Codegen.codegen statement);
      main_loop ()
    end

(** 略 *)

終了時にコード全体をダンプするようにメインファイルを修正。

src/main.ml

open Llvm

let main () =
  Toplevel.main_loop ();
  dump_module Codegen.the_module;;

main ()

ここまででビルド・実行すると、データ型に対応したコードが出力される。
ただしシンボルは何も定義していないため、シンボルやS式では例外処理されて強制終了する。

cons関数の定義

consを定義してみる。
セル構造体型は先ほど定義したので、引数を2つ受け取ってそれを構造体に格納して返すようにする。
引数はポインタアドレス(i8)を想定している。

ビルトイン関数はメインループよりも前に定義されていて欲しいので、codegenの上に書く。

src/codegen.ml

let arg_type = Array.make 2 address_type in
let ft = function_type cell_type arg_type in
let the_function = declare_function "cons" ft the_module in
let car = param the_function 0 in
let cdr = param the_function 1 in
let bb = append_block context "entry" the_function in
position_at_end bb builder;
try
  let ret_val = const_named_struct cell_type [|car; cdr|] in
  let _ = build_ret ret_val builder in
  Llvm_analysis.assert_valid_function the_function;
with e->
  delete_function the_function;
  raise e;;

これで実行してみる。

ready> (cons 1 2)
(Ast.Sexp
   [(Ast.Atom (Ast.Symbol "cons")); (Ast.Atom (Ast.Integer 1));
     (Ast.Atom (Ast.Integer 2))])
  %calltmp = call %cell @cons(i32 1, i32 2)
ready> 
; ModuleID = 'llclimp'
source_filename = "llclimp"

%cell = type { i8*, i8* }

define %cell @cons(i8*, i8*) {
entry:
  ret %cell { i8* %0, i8* %1 }
  %calltmp = call %cell @cons(i32 1, i32 2)
}

それらしい関数は出力された。
しかしユーザ入力による関数呼び出しが変なところに入ってしまっている。
また関数呼び出し時に型のチェックを行っていないため、実際には動かないであろうコードが出力されている。

これらの問題はひとまず置いて、次に進んだ。

car関数の定義

consで作ったセルの先頭要素を取り出せるようにしたい。
実際にconsを実行するためには、引数に渡す値は全て定数として保持し、その参照を渡せるようにしないといけない。
これについてはcarを定義してから対処するつもりだった。

consの定義の後に続いて書く。

src/codegen.ml

let arg_type = Array.make 1 cell_type in
let ft = function_type address_type arg_type in
let the_function = declare_function "car" ft the_module in
let cell = param the_function 0 in
let gep = build_struct_gep cell 0 "gep" builder in
let elm = build_load gep "ret" builder in
let bb = append_block context "entry" the_function in
position_at_end bb builder;
try
  let ret_val = elm in
  let _ = build_ret ret_val builder in
  Llvm_analysis.assert_valid_function the_function;
with e->
  delete_function the_function;
  raise e

実行してみる。

[1]    12214 segmentation fault (core dumped)  ./main.native

ここでまさかのセグメンテーションフォルト。
どうやらbuild_struct_gepを呼び出してる部分で起きているようだ。
いろいろ試行錯誤してみたが、どうやっても消せなかった。

問題の整理

• ユーザ入力による関数呼び出しが変なところに入る
  ユーザ入力に移る前にbuilderの指している位置を変えてやれば良さそう。ただそのやり方が分からない。
  => ユーザ入力用のブロックを作成しposition_at_endでその位置に合わせてやればOK。
• 関数呼び出し時に型のチェックを行っていない
  引数は全てポインタになるはずなので、おそらくチェックしなくても大丈夫？
  => 引数にポインタアドレス(i64)を渡すようにしたため、各関数の中で元のポインタ型に戻してやる。
• 値は全て定数として保持する
  codegen_exprで定数として保持するようにし、ポインタとして返す。LLVMにdata segmentに相当するものはあるのか？
  => codegen_exprの時にグローバル定数を作り、その値をそのまま渡せば良い(勝手にポインタとして扱われる)。
• build_struct_gepでセグメンテーションフォルト
  そもそも原因が分からない。
  => 直接構造体を渡すのではなく、ポインタでラップしてから渡すようにすればよい。

2016/12/10 追記

開発の続き

car関数の定義リベンジ

コメントより、

gdbでスタックトレースを見たところ、llvalueにポインタを期待しているところにポインタではない生のcell_typeを渡しているのでエラーになってました。ポインタ型を受け取るようにすれば解決します。

頂いたコードを参考に、スコープを切りつつ該当箇所を書き換えてみたらセグメンテーションフォルトが消えた！
とりあえず、そのまま貼らせていただきます。

src/codegen.ml

(* スコープを切る *)
let gen_cons a_module context =
  let arg_type = Array.make 2 address_type in
  let ft = function_type cell_type arg_type in
  let the_function = declare_function "cons" ft a_module in
  let car = param the_function 0 in
  let cdr = param the_function 1 in
  let bb = append_block context "entry" the_function in
  position_at_end bb builder;
  try
    let ret_val = const_named_struct cell_type [|car; cdr|] in
    let _ = build_ret ret_val builder in
    Llvm_analysis.assert_valid_function the_function;
  with e->
    delete_function the_function;
    raise e;;

let gen_car a_module context =
  (* cell_typeではなくpointer_type cell_typeにする *)
  let arg_type = Array.make 1 (pointer_type cell_type) in
  let ft = function_type address_type arg_type in
  let the_function = declare_function "car" ft a_module in
  let cell = param the_function 0 in
  let bb = append_block context "entry" the_function in
  position_at_end bb builder;
  try
    (* それっぽい名前があった方が分かりやすい *)
    let gep = build_struct_gep cell 0 "cons" builder in
    let elm = build_load gep "car" builder in
    let ret_val = elm in
    let _ = build_ret ret_val builder in
    Llvm_analysis.assert_valid_function the_function;
  with e->
    delete_function the_function;
    raise e;;

(* ユーザ入力用にmain関数も用意 *)
let gen_main a_module context =
  let arg_type = [||] in
  let ft = function_type (void_type context) arg_type in
  let main_function = declare_function "main" ft the_module in
  let bb = append_block context "entry" main_function in
  bb;;

gen_cons the_module context;;
gen_car the_module context;;
let main_bb = gen_main the_module context in
    (* builderのポジションをmainに合わせておく *)
    position_at_end main_bb builder;;

ここで初めて、出力されたLLVM IRを動かしてみようと思い立った。

$ ./main.native
ready> (car (cons 23 56))
(Ast.Sexp
   [(Ast.Atom (Ast.Symbol "car"));
     (Ast.Sexp
        [(Ast.Atom (Ast.Symbol "cons")); (Ast.Atom (Ast.Integer 23));
          (Ast.Atom (Ast.Integer 56))])
     ])
  %calltmp1 = call void* @car(%cell %calltmp)

最終的にダンプされたコードが以下。

test0.ll

; ModuleID = 'llclimp'
source_filename = "llclimp"

%cell = type { void*, void* }

define %cell @cons(void*, void*) {
entry:
  ret %cell { void* %0, void* %1 }
}

define void* @car(%cell*) {
entry:
  %cons = getelementptr inbounds %cell, %cell* %0, i32 0, i32 0
  %car = load void*, void** %cons
  ret void* %car
}

define void @main() {
entry:
  %calltmp = call %cell @cons(i32 23, i32 56)
  %calltmp1 = call void* @car(%cell %calltmp)
}

これをまずLLVMビットコードに変換する。

$ llvm-as test0.ll
llvm-as: test0.ll:4:20: error: pointers to void are invalid - use i8* instead
%cell = type { void*, void* }
                               ^

と、ここでエラー。void型へのポインタは使えないらしい。
となると、型を区別しないで値を入れるためにはポインタアドレスを格納しなければならない。
ここでポインタアドレスのサイズを調べてみたところ、32bit環境では4bytes、64bit環境では8bytesとなるらしい。
自分は64bit環境なので、address_typeの定義を以下のように変えた。

src/codegen.ml

let address_type = i64_type context

これで先ほどと同じように、出力されたLLVM IRをビットコードに変換する。

$ llvm-as test1.ll
llvm-as: test1.ll:8:20: error: invalid use of function-local name
  ret %cell { i64* %0, i64* %1 }
                                ^

今度はcons関数の定義場所でエラーが起きた。
引数をそのまま構造体のメンバとしているのが駄目そう。
こういう時は実際にC言語のコードをLLVM IRに変換して動きを見てみれば良い。

test.c

# include <stdio.h>

struct cell{
  int* car;
  int* cdr;
};

int main() {
  int a = 30;
  int b = 50;
  struct cell cons = {&a, &b};
  return 0;
}

上のようなC言語コードを書いて、clangを利用してLLVM IRを吐かせる。

$ clang -c -S -emit-llvm test.c

すると以下のようなコードが出力された。

test.ll(一部略)

%struct.cell = type { i32*, i32* }

; Function Attrs: nounwind uwtable
define i32 @main() #0 {
  %1 = alloca i32, align 4
  %2 = alloca i32, align 4
  %3 = alloca i32, align 4
  %4 = alloca %struct.cell, align 8
  store i32 0, i32* %1, align 4
  store i32 30, i32* %2, align 4
  store i32 50, i32* %3, align 4
  %5 = getelementptr inbounds %struct.cell, %struct.cell* %4, i32 0, i32 0
  store i32* %2, i32** %5, align 8
  %6 = getelementptr inbounds %struct.cell, %struct.cell* %4, i32 0, i32 1
  store i32* %3, i32** %6, align 8
  ret i32 0
}

これを見ると、まずallocaで構造体のメモリを確保し、各要素へのポインタ経由で値をstoreしている。
この時知ったのだが、constantな値は動的には作れないようだ。当然といえば当然である。
const_*関数はグローバル変数(定数)を作成する時にのみ用いるらしい。

ということで、これを参考にcons関数の定義を書き換えた。
同時に返り値も、セルのアドレスを返すように変更した。

src/codegen.ml

let gen_cons a_module context =
  let arg_type = Array.make 2 address_type in
  let ft = function_type address_type arg_type in
  let the_function = declare_function "cons" ft a_module in
  (** p0 = &a *)
  let p0 = param the_function 0 in
  (** p1 = &b *)
  let p1 = param the_function 1 in
  let bb = append_block context "entry" the_function in
  position_at_end bb builder;
  try
    (** struct cell *cell; *)
    let cell = build_alloca cell_type "cell" builder in
    (** cell->car = p0 *)
    let car = build_struct_gep cell 0 "car" builder in
    let _ = build_store p0 car builder in
    (** cell->cdr = p1 *)
    let cdr = build_struct_gep cell 1 "cdr" builder in
    let _ = build_store p1 cdr builder in
    (** return (i64_t)cell *)
    let addr = build_ptrtoint cell address_type "addr" builder in
    let ret_val = addr in
    let _ = build_ret ret_val builder in
    Llvm_analysis.assert_valid_function the_function;
  with e->
    delete_function the_function;
    raise e;;

さらに、これに対応する形でcar関数の定義も書き換えた。

src/codegen.ml

let gen_car a_module context =
  (** consセルへのポインタアドレスを受け取る *)
  let arg_type = Array.make 1 address_type in
  let ft = function_type address_type arg_type in
  let the_function = declare_function "car" ft a_module in
  let p0 = param the_function 0 in
  let bb = append_block context "entry" the_function in
  position_at_end bb builder;
  try
    (** ポインタアドレスをconsセルのポインタに変換 *)
    let ptr = build_inttoptr p0 (pointer_type cell_type) "consptr" builder in
    let cons = build_struct_gep ptr 0 "cons" builder in
    let car = build_load cons "car" builder in
    let ret_val = car in
    let _ = build_ret ret_val builder in
    Llvm_analysis.assert_valid_function the_function;
  with e->
    delete_function the_function;
    raise e

そしてコードを出力して変換…の前に、codegen_exprでグローバル定数を作成するようにするのを忘れていた。
以下のように、ひとまずintとfloatだけ定数を作成するようにし、ポインタをアドレスに変換させる。

src/codegen.ml

and codegen_expr = function
  | Ast.Integer n -> build_ptrtoint (define_global ".int" (const_int integer_type n) the_module) address_type ".intp" builder
  | Ast.Float n -> build_ptrtoint (define_global ".float" (const_float float_type n) the_module) address_type ".floatp" builder
  | Ast.String s -> const_string context s
  | Ast.Nil -> const_int bit_type 0
  | Ast.T -> const_int bit_type 1
  | Ast.Symbol name ->
    (try Hashtbl.find symbol_tbl name with
     | Not_found -> raise (Error "unknown symbol"))
  | _ -> raise (Error "unknown symbol")

ここまででビルドして、コードを出力させてみる。

$ ./main.native
ready> (car (cons 30 50))

test2.ll

; ModuleID = 'llclimp'
source_filename = "llclimp"

%cell = type { i64, i64 }

@.int = global i32 30
@.int.1 = global i32 50

define i64 @cons(i64, i64) {
entry:
  %cell = alloca %cell
  %car = getelementptr inbounds %cell, %cell* %cell, i32 0, i32 0
  store i64 %0, i64* %car
  %cdr = getelementptr inbounds %cell, %cell* %cell, i32 0, i32 1
  store i64 %1, i64* %cdr
  %addr = ptrtoint %cell* %cell to i64
  ret i64 %addr
}

define i64 @car(i64) {
entry:
  %consptr = inttoptr i64 %0 to %cell*
  %cons = getelementptr inbounds %cell, %cell* %consptr, i32 0, i32 0
  %car = load i64, i64* %cons
  ret i64 %car
}

define void @main() {
entry:
  %calltmp = call i64 @cons(i64 ptrtoint (i32* @.int to i64), i64 ptrtoint (i32* @.int.1 to i64))
  %calltmp1 = call i64 @car(i64 %calltmp)
}

そしてビットコードに変換。

$ llvm-as test2.ll
llvm-as: test2.ll:32:1: error: expected instruction opcode
}
^

ああ、main関数の中でreturnするのを忘れていた。
場当たり的に、そのまま直接付け足した。

test2.ll(main関数のみ抜粋)

define void @main() {
entry:
  %calltmp = call i64 @cons(i64 ptrtoint (i32* @.int to i64), i64 ptrtoint (i32* @.int.1 to i64))
  %calltmp1 = call i64 @car(i64 %calltmp)
  ret void
}

これを変換するとtest2.bcが出力される。
付属のJITインタープリタで実行してみる。

$ lli test2.bc  # 何も出力されない！

何も出力されないのが正常な動作だ。
しかしこれでは本当にconsやらcarが動作しているのか分からないので、carの返り値だけでも知りたい。
しかしcarで返ってくるのはポインタアドレスだ。このままでは出力出来ない。

retint関数の定義

ポインタの中身を表示するのにCのputs関数やprintf関数を利用しても良いのだが、少し大袈裟だ。
なので、ポインタアドレスを渡すとその先の値を返してくれる関数を作り、その結果をmain関数の返り値にする。
そうすればシェル上から終了コードとして値を知ることが出来る。

以下のように定義した。

src/codegen.ml

let gen_retint a_module context =
  let arg_type = Array.make 1 address_type in
  let ft = function_type integer_type arg_type in
  let the_function = declare_function "retint" ft a_module in
  let p0 = param the_function 0 in
  let bb = append_block context "entry" the_function in
  position_at_end bb builder;
  try
    let ptr = build_inttoptr p0 (pointer_type integer_type) "vptr" builder in
    let v = build_load ptr "v" builder in
    let ret_val = v in
    let _ = build_ret ret_val builder in
    Llvm_analysis.assert_valid_function the_function;
  with e->
    delete_function the_function;
    raise e

;;

(** 関数の登録も忘れずに行う *)
gen_retint the_module context;;

これを使って以下のようなコードを書いた。

$ ./main.native
ready> (retint (car (cons 30 50)))

test3.ll

; ModuleID = 'llclimp'
source_filename = "llclimp"

%cell = type { i64, i64 }

@.int = global i32 30
@.int.1 = global i32 50

define i64 @cons(i64, i64) {
entry:
  %cell = alloca %cell
  %car = getelementptr inbounds %cell, %cell* %cell, i32 0, i32 0
  store i64 %0, i64* %car
  %cdr = getelementptr inbounds %cell, %cell* %cell, i32 0, i32 1
  store i64 %1, i64* %cdr
  %addr = ptrtoint %cell* %cell to i64
  ret i64 %addr
}

define i64 @car(i64) {
entry:
  %consptr = inttoptr i64 %0 to %cell*
  %cons = getelementptr inbounds %cell, %cell* %consptr, i32 0, i32 0
  %car = load i64, i64* %cons
  ret i64 %car
}

define i32 @retint(i64) {
entry:
  %vptr = inttoptr i64 %0 to i32*
  %v = load i32, i32* %vptr
  ret i32 %v
}

define void @main() {
entry:
  %calltmp = call i64 @cons(i64 ptrtoint (i32* @.int to i64), i64 ptrtoint (i32* @.int.1 to i64))
  %calltmp1 = call i64 @car(i64 %calltmp)
  %calltmp2 = call i32 @retint(i64 %calltmp1)
}

そしてmain関数の型と末尾を書き換える。

test3.ll(main関数のみ抜粋)

define i32 @main() {
entry:
  %calltmp = call i64 @cons(i64 ptrtoint (i32* @.int to i64), i64 ptrtoint (i32* @.int.1 to i64))
  %calltmp1 = call i64 @car(i64 %calltmp)
  %calltmp2 = call i32 @retint(i64 %calltmp1)
  ret i32 %calltmp2
}

続けて変換、実行までしてみる。

$ llvm-as test3.ll
$ lli test3.bc
$ echo $?
30

consで作ったセルからcarで値が取り出せた！！
長い道のりだったが、だいぶ目標まで近付けた気がする。

@blackenedgoldさん、ありがとうございました！

課題

• cdr関数の定義
• 四則演算+-*/関数の定義
• 可変長引数への対応
• 標準出力を出来るようにすること