dnrops
/
rust
mirror of https://github.com/rust-lang/rust.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Remove rustboot from the repository.

This commit is contained in:
Graydon Hoare 2011-05-13 18:38:28 -07:00
parent ef75860a0a
commit 6997adf763
46 changed files with 2 additions and 37556 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
configure vendored
View File

@ -176,7 +176,6 @@ fi
step_msg "making directories"
for i in \
doc \
boot/fe boot/me boot/be boot/driver boot/util \
rt rt/isaac rt/bigint rt/sync rt/test \
rustllvm \
dl stage0 stage1 stage2 stage3 \
@ -203,11 +202,6 @@ probe CFG_CLANG clang++
probe CFG_GCC gcc
probe CFG_LLVM_CONFIG llvm-config
probe CFG_VALGRIND valgrind
probe CFG_OCAMLC ocamlc
probe CFG_OCAMLOPT ocamlopt
probe CFG_OCAMLC_OPT ocamlc.opt
probe CFG_OCAMLOPT_OPT ocamlopt.opt
probe CFG_FLEXLINK flexlink
probe CFG_MAKEINFO makeinfo
probe CFG_TEXI2PDF texi2pdf
probe CFG_TEX tex

98
mk/boot.mk
View File

@ -1,98 +0,0 @@
######################################################################
# Bootstrap compiler variables and rules
######################################################################
ifdef CFG_BOOT_PROFILE
$(info cfg: forcing native bootstrap compiler (CFG_BOOT_PROFILE))
CFG_BOOT_NATIVE := 1
CFG_OCAMLOPT_PROFILE_FLAGS := -p
endif
ifdef CFG_BOOT_DEBUG
$(info cfg: forcing bytecode bootstrap compiler (CFG_BOOT_DEBUG))
CFG_BOOT_NATIVE :=
endif
ifdef CFG_BOOT_NATIVE
$(info cfg: building native bootstrap compiler)
else
$(info cfg: building bytecode bootstrap compiler)
endif
GENERATED := boot/fe/lexer.ml boot/version.ml
# We must list them in link order.
# Nobody calculates the link-order DAG automatically, sadly.
BOOT_MLS := \
$(addsuffix .ml, \
boot/version \
$(addprefix boot/util/, fmt common bits) \
$(addprefix boot/driver/, session) \
$(addprefix boot/fe/, ast token lexer parser \
extfmt pexp item cexp fuzz) \
$(addprefix boot/be/, asm il abi) \
$(addprefix boot/me/, walk semant resolve alias \
simplify type dead layer typestate \
loop layout transutil trans dwarf) \
$(addprefix boot/be/, x86 ra pe elf macho) \
$(addprefix boot/driver/, lib glue main)) \
BOOT_CMOS := $(BOOT_MLS:.ml=.cmo)
BOOT_CMXS := $(BOOT_MLS:.ml=.cmx)
BOOT_OBJS := $(BOOT_MLS:.ml=.o)
BOOT_CMIS := $(BOOT_MLS:.ml=.cmi)
BS := $(S)src/boot
BOOT_ML_DEP_INCS := -I $(BS)/fe -I $(BS)/me \
-I $(BS)/be -I $(BS)/driver \
-I $(BS)/util -I boot
BOOT_ML_INCS := -I boot/fe -I boot/me \
-I boot/be -I boot/driver \
-I boot/util -I boot
BOOT_ML_LIBS := unix.cma nums.cma bigarray.cma
BOOT_ML_NATIVE_LIBS := unix.cmxa nums.cmxa bigarray.cmxa
BOOT_OCAMLC_FLAGS := -g $(BOOT_ML_INCS) -w Ael -warn-error Ael
BOOT_OCAMLOPT_FLAGS := -g $(BOOT_ML_INCS) -w Ael -warn-error Ael
ifdef CFG_FLEXLINK
BOOT_OCAMLOPT_FLAGS += -cclib -L/usr/lib
endif
BOOT := $(Q)OCAMLRUNPARAM="b1" boot/rustboot$(X) $(CFG_BOOT_FLAGS) -L stage0
ifdef CFG_BOOT_NATIVE
boot/rustboot$(X): $(BOOT_CMXS) $(MKFILES)
@$(call E, link: $@)
$(Q)ocamlopt$(OPT) -o $@ $(BOOT_OCAMLOPT_FLAGS) $(BOOT_ML_NATIVE_LIBS) \
$(BOOT_CMXS)
else
boot/rustboot$(X): $(BOOT_CMOS) $(MKFILES)
@$(call E, link: $@)
$(Q)ocamlc$(OPT) -o $@ $(BOOT_OCAMLC_FLAGS) $(BOOT_ML_LIBS) $(BOOT_CMOS)
endif
boot/version.ml: $(MKFILES)
@$(call E, git: $@)
$(Q)(cd $(S) && git log -1 \
--pretty=format:'let version = "prerelease (%h %ci)";;') >$@ || exit 1
%.cmo: %.ml $(MKFILES)
@$(call E, compile: $@)
$(Q)ocamlc$(OPT) -c -o $@ $(BOOT_OCAMLC_FLAGS) $<
%.cmo: %.cmi $(MKFILES)
%.cmx %.o: %.ml $(MKFILES)
@$(call E, compile: $@)
$(Q)ocamlopt$(OPT) -c -o $@ $(BOOT_OCAMLOPT_FLAGS) $<
%.ml: %.mll $(MKFILES)
@$(call E, lex-gen: $@)
$(Q)ocamllex$(OPT) -q -o $@ $<

1
mk/clean.mk
View File

@ -17,7 +17,6 @@ clean:
@$(call E, cleaning)
$(Q)rm -f $(RUNTIME_OBJS) $(RUNTIME_DEF)
$(Q)rm -f $(RUSTLLVM_LIB_OBJS) $(RUSTLLVM_OBJS_OBJS) $(RUSTLLVM_DEF)
$(Q)rm -f $(BOOT_CMOS) $(BOOT_CMIS) $(BOOT_CMXS) $(BOOT_OBJS)
$(Q)rm -f $(ML_DEPFILES) $(C_DEPFILES) $(CRATE_DEPFILES)
$(Q)rm -f $(ML_DEPFILES:%.d=%.d.tmp)
$(Q)rm -f $(C_DEPFILES:%.d=%.d.tmp)

6
mk/platform.mk
View File

@ -87,9 +87,6 @@ ifdef CFG_WINDOWSY
CFG_PATH_MUNGE := $(strip perl -i.bak -p \
-e 's@\\(\S)@/\1@go;' \
-e 's@^/([a-zA-Z])/@\1:/@o;')
ifdef CFG_FLEXLINK
CFG_BOOT_NATIVE := 1
endif
CFG_GCCISH_CFLAGS += -march=i686 -O2
CFG_GCCISH_LINK_FLAGS += -shared -fPIC
CFG_DEF_SUFFIX := .def
@ -106,8 +103,6 @@ ifdef CFG_UNIXY
$(CFG_LDENV)=$(call CFG_TESTLIB,$(1)):$(CFG_LDPATH) \
$(CFG_VALGRIND) $(1)
CFG_BOOT_NATIVE := 1
ifdef MINGW_CROSS
CFG_EXE_SUFFIX := .exe
CFG_LIB_NAME=$(1).dll
@ -118,7 +113,6 @@ ifdef CFG_UNIXY
CFG_INFO := $(info cfg: mingw-cross)
CFG_GCCISH_CROSS := i586-mingw32msvc-
CFG_BOOT_FLAGS += -t win32-x86-pe
ifdef CFG_VALGRIND
CFG_VALGRIND += wine
endif

11
src/README
View File

@ -2,16 +2,7 @@ This is preliminary version of the Rust compiler(s).
Source layout:
boot/ The bootstrap compiler
boot/README - More-detailed guide to it.
boot/fe - Front end (lexer, parser, AST)
boot/me - Middle end (resolve, check, layout, trans)
boot/be - Back end (IL, RA, insns, asm, objfiles)
boot/util - Ubiquitous helpers
boot/driver - Compiler driver
comp/ The self-hosted compiler ("rustc": incomplete)
comp/* - Similar structure as in boot/
comp/ The self-hosted compiler
rt/ The runtime system
rt/rust_*.cpp - The majority of the runtime services

405
src/boot/README
View File

@ -1,405 +0,0 @@
An informal guide to reading and working on the rustboot compiler.
==================================================================
First off, know that our current state of development is "bootstrapping";
this means we've got two compilers on the go and one of them is being used
to develop the other. Rustboot is written in ocaml and rustc in rust. The
one you *probably* ought to be working on at present is rustc. Rustboot is
more for historical comparison and bug-fixing whenever necessary to un-block
development of rustc.
There's a document similar to this next door, then, in comp/README. The
comp directory is where we do work on rustc.
If you wish to expand on this document, or have one of the
slightly-more-familiar authors add anything else to it, please get in touch or
file a bug. Your concerns are probably the same as someone else's.
High-level concepts, invariants, 30,000-ft view
===============================================
Rustboot has 3 main subdirectories: fe, me, and be (front, mid, back
end). Helper modules and ubiquitous types are found in util/.
The entry-point for the compiler is driver/main.ml, and this file sequences
the various parts together.
The 4 central data structures:
------------------------------
#1: fe/ast.ml defines the AST. The AST is treated as immutable after parsing
despite containing some mutable types (hashtbl and such). Many -- though
not all -- nodes within this data structure are wrapped in the type 'a
identified. This is important. An "identified" AST node is one that the
parser has marked with a unique node_id value. This node_id is used both
to denote a source location and, more importantly, to key into a large
number of tables later in the compiler. Most additional calculated
properties of a program that the compiler derives are keyed to the node_id
of an identified node.
The types 'a identified, node_id and such are in util/common.ml
#2: me/semant.ml defines the Semant.ctxt structure. This is a record of
tables, almost all of which are keyed by node_id. See previous comment
regrding node_id. The Semant module is open in most of the modules within
the me/ directory, and they all refer liberally to the ctxt tables, either
directly or via helper functions in semant. Semant also defines the
mid-end pass-management logic, lookup routines, type folds, and a variety
of other miscallaneous semantic-analysis helpers.
#3: be/il.ml defines the IL. This is a small, typed IL based on a type system
that is relatively LLVM-ish, and a control-flow system that is *not*
expression/SSA based like LLVM. It's much dumber than that. The root of
the interesting types in this file is the type 'emitter', which is a
growable buffer along with a few counters. An emitter is essentially a
buffer of quads. A quad, in turn, is a primitive virtual instruction
('quad' because it is in its limit a 3-address machine, plus opcode) which
we then ... tend to turn directly into x86 anyways. Sorry; it wasn't clear
during initial construction that we'd wind up stopping at x86, so the IL
is probably superfluous, but there it is.
The IL types are operand = cell | immediate, and cell = reg | mem. Plus a
certain quantity of special-casing and noise for constant-pointer
propagation and addressing modes and whatnot.
#4: be/asm.ml defines the Asm.frag type, which is a "chunk of binary-ish
stuff" to put in an output file. Words, bytes, lazily-resolved fixups,
constant expressions, 0-terminated strings, alignment boundaries, etc. You
will hopefully not need to produce a lot of this yourself; most of this is
already being emitted.
An important type that gets resolved here is fixup, from util/common.ml.
Fixups are things you can wrap around a frag using an Asm.DEF frag, which
get their size and position (both in-file and in-memory) calculated at
asm-time; but you can refer to them before they're resolved. So any time
the compiler needs to refer to "the place / size this thingy will be, when
it finally gets boiled down to frags and emitted" we generate a fixup and
use that. Functions and static data structures, for example, tend to get
fixups assigned to them early on in the middle-end of the compiler.
Control and information flow within the compiler:
-------------------------------------------------
- driver/main.ml assumes control on startup. Options are parsed, platform is
detected, etc.
- fe/lexer.ml does lexing in any case; fe/parser.ml holds the fundamental
parser-state and parser-combinator functions. Parsing rules are split
between 3 files: fe/cexp.ml, fe/pexp.ml, and fe/item.ml. This split
represents the general structure of the grammar(s):
- The outermost grammar is called "cexp" (crate expression), and is an
expression language that describes the crate directives found in crate
files. It's evaluated inside the compiler.
- The next grammar is "item", which is a statement language that describes
the directives, declarations and statements found in source files. If
you compile a naked source file, you jump straight to item and then
synthesize a simple crate structure around the result.
- The innermost grammar is "pexp" (parsed expression), and is an
expression language used for the shared expression grammar within both
cexp and item. Pexps within cexp are evaluated in the compiler
(non-constant, complex cexps are errors) whereas pexps within items are
desugared to statements and primitive expressions.
- The AST is the output from the item grammar. Pexp and cexp do not escape
the front-end.
- driver/main.ml then builds a Semant.ctxt and threads it through the various
middle-end passes. Each pass defines one or more visitors, which is an FRU
copy of the empty_visitor in me/walk.ml. Each visitor performs a particular
task, encapsulates some local state in local variables, and leaves its
results in a table. If the table it's calculating is pass-local, it will be
a local binding within the pass; if it's to be shared with later passes, it
will be a table in Semant.ctxt. Pass order is therefore somewhat important,
so I'll describe it here:
- me/resolve.ml looks up names and connects them to definitions. This
includes expanding all types (as types can occur within names, as part
of a parametric name) and performing all import/export/visibility
judgments. After resolve, we should not be doing any further name-based
lookups (with one exception: typestate does some more name
lookup. Subtle reason, will return to it).
Resolve populates several of the tables near the top of Semant.ctxt:
ctxt_all_cast_types
ctxt_all_defns
ctxt_all_item_names
ctxt_all_item_types
ctxt_all_lvals
ctxt_all_stmts
ctxt_all_type_items
ctxt_block_items
ctxt_block_slots
ctxt_frame_args
ctxt_lval_to_referent
ctxt_node_referenced
ctxt_required_items
ctxt_slot_is_arg
ctxt_slot_keys
The most obviously critical of these are lval_to_referent and all_defns,
which connect subsequent visitors from a reference node to its referent
node, and catalogue all the possible things a referent may be.
Part of resolving that is perhaps not obvious is the task of resolving
and normalizing recursive types. This is what TY_iso is for. Recursive
types in rust have to pass through a tag type on their recursive edge;
TY_iso is an iso-recursive group of tags that refer only to one another;
within a TY_iso, the type term "TY_idx n" refers to "the nth member of
the current TY_iso". Resolve is responsible for finding such groups and
tying them into such closed-form knots.
TY_name should be completely eliminated in any of the types exiting
resolve.
- me/type.ml is a unification-based typechecker and inference engine. This
is as textbook-y as we could make it. It rewrites "auto" slots in the
ctxt_all_defns table when it completes (these are the slots with None as
their Ast.slot_ty).
This file is organized around tyspecs and tyvars. A tyspec is a
constraint on an unknown type that is implied by its use; tyspecs are
generated during the AST-walk, placed in ref cells (tyvars), and the
cells are and unified with one another. If two tyvars unify, then a new
constraint is created with the tighter of the two and the two previous
tyvars are updated to point to the unified spec. Ideally all constraints
eventually run into a source of a concrete type (or a type otherwise
uniquely-determined by its tyspecs). If not, the type is underdetermined
and we get a type error. Similarly if two tyvars that are supposed to
unify clash in some way (integer unify-with string, say) then there is
also a type error.
- me/typestate.ml is a dataflow-based typestate checker. It is responsible
for ensuring all preconditions are met, including init-before-use. It
also determines slot lifecycle boundaries, and populates the context
tables:
ctxt_constr_ids
ctxt_constrs
ctxt_copy_stmt_is_init
ctxt_post_stmt_slot_drops
ctxt_postconditions
ctxt_poststates
ctxt_preconditions
ctxt_prestates
It is organized around constr_keys, a bunch of bitsets, and a CFG.
A constr_key is a normalized value representing a single constraint that
we wish to be able to refer to within a typestate. Every constr_key gets
a bit number assigned to it. A condition (and a typestate) is a
bit-vector, in which the set bits indicate the constr_keys (indexed by
associatd number) that hold in the condition/typestate.
There are 4 such bitsets generated for each node in the CFG:
precondition/postcondition and prestate/poststate. The visitors here
figure out all the constr_keys we'll need, then assign all the pre/post
conditions, generate the CFG, calculate the typestates from the CFG, and
check that every typestate satisfies its precondition.
(Due to the peculiarity that types are pure terms and are not 'a
identified in our AST, we have to do some name-lookup in here as well
when normalizing the const_keys).
- Effect is relatively simple: it calculates the effect of each type and
item, and checks that they either match their declarations or are
authorized to be lying.
- Loop is even simpler: it calculates loop-depth information for later use
generating foreach loops. It populates the context tables:
ctxt_block_is_loop_body
ctxt_slot_loop_depths
ctxt_stmt_loop_depths
- Alias checks slot-aliasing to ensure none of the rules are broken about
simultaneous aliases and such. It also populates the table
ctxt_slot_is_aliased.
- Layout determines the layout of frames, arguments, objects, closures and
such. This includes deciding which slot should go in a vreg and
generating fixups for all frame-spill regions. It populates the context
tables:
ctxt_block_is_loop_body
ctxt_call_sizes
ctxt_frame_blocks
ctxt_frame_sizes
ctxt_slot_is_obj_state
ctxt_slot_offsets
ctxt_slot_vregs
ctxt_spill_fixups
There is a useful chunk of ASCII-art in the leading comment of layout,
if you want to see how a frame goes together, I recommend reading it.
- Trans is the big one. This is the "translate AST to IL" pass, and it's a
bit of a dumping ground, sadly. Probably 4x the size of any other
pass. Stuff that is common to the x86 and LLVM backends is factored out
into transutil.ml, but it hardly helps. Suggestions welcome for
splitting it further.
Trans works *imperatively*. It maintains a stack of emitters, one per
function (or helper-function) and emits Il.quads into the top-of-stack
emitter into while it walks the statements of each function. If at any
point it needs to pause to emit a helper function ("glue function") it
pushes a new emitter onto the stack and emits into that.
Trans populates the context tables:
ctxt_all_item_code
ctxt_block_fixups
ctxt_data
ctxt_file_code
ctxt_file_fixups
ctxt_fn_fixups
ctxt_glue_code
The entries in the tables ending in _code are of type Semant.code, which
is an abstract type covering both function and glue-function code; each
holds an executable block of quads, plus an aggregate count of vregs and
a reference to the spill fixup for that code.
- Once it completes trans, driver/main.ml does the "finishing touches":
register allocates each emitted code value (be/ra.ml), emits dwarf for the
crate (me/dwarf.ml), selects instructions (be/x86.ml), then selects one of
the object-file backends (be/elf.ml, be/macho.ml or be/pe.ml) and emits the
selected Asm.frag to it. Hopefully little of this will require further work;
the most incomplete module here is probably dwarf.ml but the remainder are
mostly stable and don't tend to change much, aside from picking bugs out of
them.
Details and curiosities to note along the way:
==============================================
- Where you might expect there to be a general recursive expression type for
'expr', you'll find only a very limited non-recursive 3-way switch: binary,
unary, or atom; where atom is either a literal or an lval. This is because
all the "big" expressions (pexps) were boiled off during the desugaring
phase in the frontend.
- There are multiple ways to refer to a path. Names, lvals and cargs all
appear to have similar structure (and do). They're all subsets of the
general path grammar, so all follow the rough shape of being either a base
anchor-path or an ext (extension) path with structural recursion to the
left.
Cargs (constraint arguments) are the sort of paths that can be passed to
constraints in the typestate system, and can contain the special symbol "*"
in the grammar, meaning "thing I am attached to". This is the symbol
BASE_formal in the carg_base type.
Names are the sort of paths that refer to types or other items. Not slots.
Lvals are the sort of paths that *might* refer to slots, but we don't
generally know. So they can contain the dynamic-indexing component
COMP_atom. For example, x.(1 + 2).y is an lval.
- Only one of these forms is 'a identified: an lval. And moreover, only the
lval *base* is identified; the remainder of the path has to be projected
forward through the referent after lookup. This also means that when you
lookup anything else by name, you have to be using the result immediately,
not storing it in a table for later.
- Types are not 'a identified. This means that you (generally) cannot refer to
a *particular* occurrence of a type in the AST and associate information
with it. Instead, we treat types as "pure terms" (not carrying identity) and
calculate properties of them on the fly. For this we use a general fold
defined in me/semant.ml, the family of functions held in a ty_fold
structure, and passed to fold_ty.
- There is a possibly-surprising type called "size" in util/common. This is a
type representing a "size expression" that may depend on runtime
information, such as the type descriptors passed to a frame at runtime. This
exists because our type-parameterization scheme is, at the moment,
implemented by passing type descriptors around at runtime, not
code-expansion a la C++ templates. So any time we have a translated indexing
operation or such that depends on a type parameter, we wind up with a size
expression including SIZE_param_size or SIZE_param_align, and have to do
size arithmetic at runtime. Upstream of trans, we generate sizes willy-nilly
and then decide in trans, x86, and dwarf whether they can be emitted
statically or via runtime calculation at the point of use.
- Trans generates position-independent code (PIC). This means that it never
refers to the exact position of a fixup in memory at load-time, always the
distance-to-a-fixup from some other fixup, and/or current PC. On x86 this
means we wind up copying the "get next pc thunk" trick used on linux
systems, and/or storing "crate relative" addresses. The runtime and compiler
"know" (unfortunately sometimes quite obscurely) that an immediate pointer
should be encoded as relative-to a given displacement base, and work with
those as necessary. Similarly, they emit code to reify pointer immediates
(add the displacements to displacement-bases) before handing them off to
(say) C library functions that expect "real" pointers. This is all somewhat
messy.
- There is one central static data structure, "rust_crate", which is emitted
into the final loadable object and contains pointers to all subsequent
information the runtime may be interested in. It also serves as the
displacement base for a variety of PIC-ish displacements stored
elsewhere. When the runtime loads a crate, it dlsym()s rust_crate, and then
digs around in there. It's the entry-point for crawling the crate's
structure from outside. Importantly: it also contains pointers to the dwarf.
- Currently we drive linking off dwarf. That is: when a crate needs to 'use'
an item from another dwarf crate, we dlopen / LoadLibrary and find the
"rust_crate" value, follow its pointers to dwarf tables, and scan around the
dwarf DIE tree resolving the hierarchical name of the used item. This may
change, we decided to recycle dwarf for this purpose early in the language
evolution and may, given the number of simplifications that have occurred
along the way, be able to fall back to C "mangled name" linkage at some
point. Though that decision carries a number of serious constraints, and
should not be taken lightly.
Probably-bad ideas we will want to do differently in the self-hosted compiler:
==============================================================================
- We desugar too early in rustboot and should preserve the pexp structure
until later. Dherman is likely to argue for movement to a more
expression-focused grammar. This may well happen.
- Multiple kinds of paths enforced by numerous nearly-isomorphic ML type
constructors is pointless once we're in rust; we can just make type
abbreviations that carry constraints like path : is_name(*) or such.
- Storing auxiliary information in semant tables is awkward, and we should
figure out a suitably rusty idiom for decorating AST nodes in-place.
Inter-pass dependencies should be managed by augmenting the AST with
ever-more constraints (is_resolved(ast), is_typechecked(ast), etc.)
- Trans should be organized as pure and value-producing code, not imperatively
emitting quads into emitters. LLVM will enforce this anyways. See what
happened in lltrans.ml if you're curious what it'll look (more) like.
- The PIC scheme will have to change, hopefully get much easier.

253
src/boot/be/abi.ml
View File

@ -1,253 +0,0 @@
(*
* The 'abi' structure is pretty much just a grab-bag of machine
* dependencies and structure-layout information. Part of the latter
* is shared with trans and semant.
*
* Make some attempt to factor it as time goes by.
*)
(* Word offsets for structure fields in rust-internal.h, and elsewhere in
compiler. *)
let rc_base_field_refcnt = 0;;
(* FIXME: this needs updating if you ever want to work on 64 bit. *)
let const_refcount = 0x7badfaceL;;
let task_field_refcnt = rc_base_field_refcnt;;
let task_field_stk = task_field_refcnt + 2;;
let task_field_runtime_sp = task_field_stk + 1;;
let task_field_rust_sp = task_field_runtime_sp + 1;;
let task_field_gc_alloc_chain = task_field_rust_sp + 1;;
let task_field_dom = task_field_gc_alloc_chain + 1;;
let n_visible_task_fields = task_field_dom + 1;;
let dom_field_interrupt_flag = 1;;
let frame_glue_fns_field_mark = 0;;
let frame_glue_fns_field_drop = 1;;
let frame_glue_fns_field_reloc = 2;;
let box_rc_field_refcnt = 0;;
let box_rc_field_body = 1;;
let box_gc_alloc_base = (-3);;
let box_gc_field_prev = (-3);;
let box_gc_field_next = (-2);;
let box_gc_field_ctrl = (-1);;
let box_gc_field_refcnt = 0;;
let box_gc_field_body = 1;;
let box_rc_header_size = 1;;
let box_gc_header_size = 4;;
let box_gc_malloc_return_adjustment = 3;;
let stk_field_valgrind_id = 0;;
let stk_field_limit = stk_field_valgrind_id + 1;;
let stk_field_data = stk_field_limit + 1;;
(* Both obj and fn are two-word "bindings": One word points to some static
* dispatch information (vtbl, thunk, callee), and the other points to some
* box of bound data (object-body or closure).
*)
let binding_field_dispatch = 0;;
let binding_field_bound_data = 1;;
let obj_field_vtbl = binding_field_dispatch;;
let obj_field_box = binding_field_bound_data;;
let obj_body_elt_tydesc = 0;;
let obj_body_elt_fields = 1;;
let fn_field_code = binding_field_dispatch;;
let fn_field_box = binding_field_bound_data;;
(* NB: bound ty params come last to facilitate ignoring them on
* closure-dropping. *)
let closure_body_elt_bound_args_tydesc = 0;;
let closure_body_elt_target = 1;;
let closure_body_elt_bound_args = 2;;
let closure_body_elt_bound_ty_params = 3;;
let tag_elt_discriminant = 0;;
let tag_elt_variant = 1;;
let general_code_alignment = 16;;
let tydesc_field_first_param = 0;;
let tydesc_field_size = 1;;
let tydesc_field_align = 2;;
let tydesc_field_take_glue = 3;;
let tydesc_field_drop_glue = 4;;
let tydesc_field_free_glue = 5;;
let tydesc_field_sever_glue = 6;;
let tydesc_field_mark_glue = 7;;
let tydesc_field_obj_drop_glue = 8;;
let tydesc_field_cmp_glue = 9;; (* FIXME these two aren't in the *)
let tydesc_field_hash_glue = 10;; (* runtime's type_desc struct. *)
let tydesc_field_stateflag = 11;;
let vec_elt_rc = 0;;
let vec_elt_alloc = 1;;
let vec_elt_fill = 2;;
let vec_elt_pad = 3;;
let vec_elt_data = 4;;
let calltup_elt_out_ptr = 0;;
let calltup_elt_task_ptr = 1;;
let calltup_elt_indirect_args = 2;;
let calltup_elt_ty_params = 3;;
let calltup_elt_args = 4;;
let calltup_elt_iterator_args = 5;;
let iterator_args_elt_block_fn = 0;;
let iterator_args_elt_outer_frame_ptr = 1;;
let indirect_args_elt_closure = 0;;
(* Current worst case is by vec grow glue *)
let worst_case_glue_call_args = 8;;
(*
* ABI tags used to inform the runtime which sort of frame to set up for new
* spawned functions. FIXME: There is almost certainly a better abstraction to
* use.
*)
let abi_x86_rustboot_cdecl = 1;;
let abi_x86_rustc_fastcall = 2;;
type abi =
{
abi_word_sz: int64;
abi_word_bits: Il.bits;
abi_word_ty: Common.ty_mach;
abi_tag: int;
abi_has_pcrel_data: bool;
abi_has_pcrel_code: bool;
abi_n_hardregs: int;
abi_str_of_hardreg: (int -> string);
abi_emit_target_specific: (Il.emitter -> Il.quad -> unit);
abi_constrain_vregs: (Il.quad -> (Il.vreg,Bits.t) Hashtbl.t -> unit);
abi_emit_fn_prologue: (Il.emitter
-> Common.size (* framesz *)
-> Common.size (* callsz *)
-> Common.nabi
-> Common.fixup (* grow_task *)
-> bool (* is_obj_fn *)
-> bool (* minimal *)
-> unit);
abi_emit_fn_epilogue: (Il.emitter -> unit);
abi_emit_fn_tail_call: (Il.emitter
-> int64 (* caller_callsz *)
-> int64 (* caller_argsz *)
-> Il.code (* callee_code *)
-> int64 (* callee_argsz *)
-> unit);
abi_clobbers: (Il.quad -> Il.hreg list);
abi_emit_native_call: (Il.emitter
-> Il.cell (* ret *)
-> Common.nabi
-> Common.fixup (* callee *)
-> Il.operand array (* args *)
-> unit);
abi_emit_native_void_call: (Il.emitter
-> Common.nabi
-> Common.fixup (* callee *)
-> Il.operand array (* args *)
-> unit);
abi_emit_native_call_in_thunk: (Il.emitter
-> Il.cell option (* ret *)
-> Common.nabi
-> Il.operand (* callee *)
-> Il.operand array (* args *)
-> unit);
abi_emit_inline_memcpy: (Il.emitter
-> int64 (* n_bytes *)
-> Il.reg (* dst_ptr *)
-> Il.reg (* src_ptr *)
-> Il.reg (* tmp_reg *)
-> bool (* ascending *)
-> unit);
(* Global glue. *)
abi_activate: (Il.emitter -> unit);
abi_yield: (Il.emitter -> unit);
abi_unwind: (Il.emitter -> Common.nabi -> Common.fixup -> unit);
abi_gc: (Il.emitter -> unit);
abi_get_next_pc_thunk:
((Il.reg (* output *)
* Common.fixup (* thunk in objfile *)
* (Il.emitter -> unit)) (* fn to make thunk *)
option);
abi_sp_reg: Il.reg;
abi_fp_reg: Il.reg;
abi_dwarf_fp_reg: int;
abi_tp_cell: Il.cell;
abi_implicit_args_sz: int64;
abi_frame_base_sz: int64;
abi_callee_saves_sz: int64;
abi_frame_info_sz: int64;
abi_spill_slot: (Il.spill -> Il.mem);
}
;;
let load_fixup_addr
(e:Il.emitter)
(out_reg:Il.reg)
(fix:Common.fixup)
(rty:Il.referent_ty)
: unit =
let cell = Il.Reg (out_reg, Il.AddrTy rty) in
let op = Il.ImmPtr (fix, rty) in
Il.emit e (Il.lea cell op);
;;
let load_fixup_codeptr
(e:Il.emitter)
(out_reg:Il.reg)
(fixup:Common.fixup)
(has_pcrel_code:bool)
(indirect:bool)
: Il.code =
if indirect
then
begin
load_fixup_addr e out_reg fixup (Il.ScalarTy (Il.AddrTy Il.CodeTy));
Il.CodePtr (Il.Cell (Il.Mem (Il.RegIn (out_reg, None),
Il.ScalarTy (Il.AddrTy Il.CodeTy))))
end
else
if has_pcrel_code
then (Il.CodePtr (Il.ImmPtr (fixup, Il.CodeTy)))
else
begin
load_fixup_addr e out_reg fixup Il.CodeTy;
Il.CodePtr (Il.Cell (Il.Reg (out_reg, Il.AddrTy Il.CodeTy)))
end
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

831
src/boot/be/asm.ml
View File

@ -1,831 +0,0 @@
(*
Our assembler is an all-at-once, buffer-in-memory job, very simple
minded. I have 1gb of memory on my laptop: I don't expect to ever
emit a program that large with this code.
It is based on the 'frag' type, which has a variant for every major
type of machine-blob we know how to write (bytes, zstrings, BSS
blocks, words of various sorts).
A frag can contain symbolic references between the sub-parts of
it. These are accomplished through ref cells we call fixups, and a
2-pass (resolution and writing) process defined recursively over
the frag structure.
Fixups are defined by wrapping a frag in a DEF pseudo-frag with
a fixup attached. This will record information about the wrapped
frag -- positions and sizes -- in the fixup during resolution.
We say "positions" and "sizes" there, in plural, because both a
file number and a memory number is recorded for each concept.
File numbers refer to positions and sizes in the file we're
generating, and are based on the native int type for the host
platform -- usually 31 or 62 bits -- whereas the expressions that
*use* position fixups tend to promote them up to 32 or 64 bits
somehow. On a 32 bit platform, you can't generate output buffers
with 64-bit positions (ocaml limitation!)
Memory numbers are 64 bit, always, and refer to sizes and positions
of frags when they are loaded into memory in the target. When
you're generating code for a 32-bit target, or using a memory
number in a context that's less than 64 bits, the value is
range-checked and truncated. But in all other respects, we imagine
a 32-bit address space is just the prefix of the continuing 64-bit
address space. If you need to pin an object at a particular place
from the point 2^32-1, say, you will need to do arithmetic and use
the MEMPOS pseudo-frag, that sets the current memory position as
it's being processed.
Fixups can be *used* anywhere else in the frag tree, as many times
as you like. If you try to write an unresolved fixup, the emitter
faults. When you specify the use of a fixup, you need to specify
whether you want to use its file size, file position, memory size,
or memory position.
Positions, addresses, sizes and such, of course, are in bytes.
Expressions are evaluated to an int64 (signed), even if the
expression is an int32 or less. Depending on how you use the result
of the expression, a range check error may fire (for example, if
the expression evaluates to -2^24 and you're emitting a word16).
Word endianness is per-file. At the moment this seems acceptable.
Because we want to be *very specific* about the time and place
arithmetic promotions occur, we define two separate expression-tree
types (with the same polymorphic constructors) and two separate
evaluation functions, with an explicit operator for marking the
promotion-points.
*)
open Common;;
open Fmt;;
let log (sess:Session.sess) =
Session.log "asm"
sess.Session.sess_log_asm
sess.Session.sess_log_out
;;
let iflog (sess:Session.sess) (thunk:(unit -> unit)) : unit =
if sess.Session.sess_log_asm
then thunk ()
else ()
;;
exception Bad_fit of string;;
exception Undef_sym of string;;
type ('a, 'b) expr =
IMM of 'a
| ADD of (('a, 'b) expr) * (('a, 'b) expr)
| SUB of (('a, 'b) expr) * (('a, 'b) expr)
| MUL of (('a, 'b) expr) * (('a, 'b) expr)
| DIV of (('a, 'b) expr) * (('a, 'b) expr)
| REM of (('a, 'b) expr) * (('a, 'b) expr)
| MAX of (('a, 'b) expr) * (('a, 'b) expr)
| ALIGN of (('a, 'b) expr) * (('a, 'b) expr)
| SLL of (('a, 'b) expr) * int
| SLR of (('a, 'b) expr) * int
| SAR of (('a, 'b) expr) * int
| AND of (('a, 'b) expr) * (('a, 'b) expr)
| XOR of (('a, 'b) expr) * (('a, 'b) expr)
| OR of (('a, 'b) expr) * (('a, 'b) expr)
| NOT of (('a, 'b) expr)
| NEG of (('a, 'b) expr)
| F_POS of fixup
| F_SZ of fixup
| M_POS of fixup
| M_SZ of fixup
| EXT of 'b
type expr32 = (int32, int) expr
;;
type expr64 = (int64, expr32) expr
;;
let rec eval32 (e:expr32)
: int32 =
let chop64 kind name v =
let x = Int64.to_int32 v in
if (Int64.compare v (Int64.of_int32 x)) = 0 then
x
else raise (Bad_fit (kind
^ " fixup "
^ name
^ " overflowed 32 bits in eval32: "
^ Int64.to_string v))
in
let expandInt _ _ v = Int32.of_int v in
let checkdef kind name v inj =
match v with
None ->
raise (Undef_sym (kind ^ " fixup " ^ name
^ " undefined in eval32"))
| Some x -> inj kind name x
in
match e with
IMM i -> i
| ADD (a, b) -> Int32.add (eval32 a) (eval32 b)
| SUB (a, b) -> Int32.sub (eval32 a) (eval32 b)
| MUL (a, b) -> Int32.mul (eval32 a) (eval32 b)
| DIV (a, b) -> Int32.div (eval32 a) (eval32 b)
| REM (a, b) -> Int32.rem (eval32 a) (eval32 b)
| MAX (a, b) -> i32_max (eval32 a) (eval32 b)
| ALIGN (a, b) -> i32_align (eval32 a) (eval32 b)
| SLL (a, b) -> Int32.shift_left (eval32 a) b
| SLR (a, b) -> Int32.shift_right_logical (eval32 a) b
| SAR (a, b) -> Int32.shift_right (eval32 a) b
| AND (a, b) -> Int32.logand (eval32 a) (eval32 b)
| XOR (a, b) -> Int32.logxor (eval32 a) (eval32 b)
| OR (a, b) -> Int32.logor (eval32 a) (eval32 b)
| NOT a -> Int32.lognot (eval32 a)
| NEG a -> Int32.neg (eval32 a)
| F_POS f ->
checkdef "file position"
f.fixup_name f.fixup_file_pos expandInt
| F_SZ f ->
checkdef "file size"
f.fixup_name f.fixup_file_sz expandInt
| M_POS f ->
checkdef "mem position"
f.fixup_name f.fixup_mem_pos chop64
| M_SZ f ->
checkdef "mem size" f.fixup_name f.fixup_mem_sz chop64
| EXT i -> Int32.of_int i
;;
let rec eval64 (e:expr64)
: int64 =
let checkdef kind name v inj =
match v with
None ->
raise (Undef_sym (kind ^ " fixup '"
^ name ^ "' undefined in eval64"))
| Some x -> inj x
in
match e with
IMM i -> i
| ADD (a, b) -> Int64.add (eval64 a) (eval64 b)
| SUB (a, b) -> Int64.sub (eval64 a) (eval64 b)
| MUL (a, b) -> Int64.mul (eval64 a) (eval64 b)
| DIV (a, b) -> Int64.div (eval64 a) (eval64 b)
| REM (a, b) -> Int64.rem (eval64 a) (eval64 b)
| MAX (a, b) -> i64_max (eval64 a) (eval64 b)
| ALIGN (a, b) -> i64_align (eval64 a) (eval64 b)
| SLL (a, b) -> Int64.shift_left (eval64 a) b
| SLR (a, b) -> Int64.shift_right_logical (eval64 a) b
| SAR (a, b) -> Int64.shift_right (eval64 a) b
| AND (a, b) -> Int64.logand (eval64 a) (eval64 b)
| XOR (a, b) -> Int64.logxor (eval64 a) (eval64 b)
| OR (a, b) -> Int64.logor (eval64 a) (eval64 b)
| NOT a -> Int64.lognot (eval64 a)
| NEG a -> Int64.neg (eval64 a)
| F_POS f ->
checkdef "file position"
f.fixup_name f.fixup_file_pos Int64.of_int
| F_SZ f ->
checkdef "file size"
f.fixup_name f.fixup_file_sz Int64.of_int
| M_POS f ->
checkdef "mem position"
f.fixup_name f.fixup_mem_pos (fun x -> x)
| M_SZ f ->
checkdef "mem size"
f.fixup_name f.fixup_mem_sz (fun x -> x)
| EXT e -> Int64.of_int32 (eval32 e)
;;
let rec string_of_expr64 (e64:expr64) : string =
let bin op a b =
Printf.sprintf "(%s %s %s)" (string_of_expr64 a) op (string_of_expr64 b)
in
let bini op a b =
Printf.sprintf "(%s %s %d)" (string_of_expr64 a) op b
in
match e64 with
IMM i when (i64_lt i 0L) -> Printf.sprintf "-0x%Lx" (Int64.neg i)
| IMM i -> Printf.sprintf "0x%Lx" i
| ADD (a,b) -> bin "+" a b
| SUB (a,b) -> bin "-" a b
| MUL (a,b) -> bin "*" a b
| DIV (a,b) -> bin "/" a b
| REM (a,b) -> bin "%" a b
| MAX (a,b) ->
Printf.sprintf "(max %s %s)"
(string_of_expr64 a) (string_of_expr64 b)
| ALIGN (a,b) ->
Printf.sprintf "(align %s %s)"
(string_of_expr64 a) (string_of_expr64 b)
| SLL (a,b) -> bini "<<" a b
| SLR (a,b) -> bini ">>" a b
| SAR (a,b) -> bini ">>>" a b
| AND (a,b) -> bin "&" a b
| XOR (a,b) -> bin "xor" a b
| OR (a,b) -> bin "|" a b
| NOT a -> Printf.sprintf "(not %s)" (string_of_expr64 a)
| NEG a -> Printf.sprintf "-%s" (string_of_expr64 a)
| F_POS f -> Printf.sprintf "<%s>.fpos" f.fixup_name
| F_SZ f -> Printf.sprintf "<%s>.fsz" f.fixup_name
| M_POS f -> Printf.sprintf "<%s>.mpos" f.fixup_name
| M_SZ f -> Printf.sprintf "<%s>.msz" f.fixup_name
| EXT _ -> "??ext??"
;;
type frag =
MARK (* MARK == 'PAD (IMM 0L)' *)
| SEQ of frag array
| PAD of int
| BSS of int64
| MEMPOS of int64
| BYTE of int
| BYTES of int array
| CHAR of char
| STRING of string
| ZSTRING of string
| ULEB128 of expr64
| SLEB128 of expr64
| WORD of (ty_mach * expr64)
| ALIGN_FILE of (int * frag)
| ALIGN_MEM of (int * frag)
| DEF of (fixup * frag)
| RELAX of relaxation
and relaxation =
{ relax_options: frag array;
relax_choice: int ref; }
;;
let rec fmt_frag (ff:Format.formatter) (f:frag) : unit =
match f with
MARK -> fmt ff "MARK"
| SEQ fs -> fmt_bracketed_arr_sep "[" "]" ", " fmt_frag ff fs
| PAD i -> fmt ff "PAD(%d)" i
| BSS i -> fmt ff "BSZ(%Ld)" i
| MEMPOS i -> fmt ff "MEMPOS(%Ld)" i
| BYTE i -> fmt ff "0x%x" i
| BYTES iz ->
fmt ff "BYTES";
fmt_bracketed_arr_sep "(" ")" ", "
(fun ff i -> fmt ff "0x%x" i) ff iz
| CHAR c -> fmt ff "CHAR(%s)" (Char.escaped c)
| STRING s -> fmt ff "STRING(%s)" (String.escaped s)
| ZSTRING s -> fmt ff "ZSTRING(%s)" (String.escaped s)
| ULEB128 e -> fmt ff "ULEB128(%s)" (string_of_expr64 e)
| SLEB128 e -> fmt ff "SLEB128(%s)" (string_of_expr64 e)
| WORD (tm, e) ->
fmt ff "%s:%s"
(string_of_ty_mach tm) (string_of_expr64 e)
| ALIGN_FILE (i, f) ->
fmt ff "ALIGN_FILE(%d, " i;
fmt_frag ff f;
fmt ff ")"
| ALIGN_MEM (i, f) ->
fmt ff "ALIGN_MEM(%d, " i;
fmt_frag ff f;
fmt ff ")"
| DEF (fix, f) ->
fmt ff "DEF(%s, " fix.fixup_name;
fmt_frag ff f;
fmt ff ")"
| RELAX r ->
fmt ff "RELAX(";
fmt_arr_sep ", " fmt_frag ff r.relax_options
;;
let sprintf_frag = Fmt.sprintf_fmt fmt_frag;;
exception Relax_more of relaxation;;
let new_relaxation (frags:frag array) =
RELAX { relax_options = frags;
relax_choice = ref ((Array.length frags) - 1); }
;;
let rec write_frag
~(sess:Session.sess)
~(lsb0:bool)
~(buf:Buffer.t)
~(frag:frag)
: unit =
let relax = Queue.create () in
let bump_relax r =
iflog sess (fun _ ->
log sess "bumping relaxation to position %d"
((!(r.relax_choice)) - 1));
r.relax_choice := (!(r.relax_choice)) - 1;
if !(r.relax_choice) < 0
then bug () "relaxation ran out of options"
in
let rec loop _ =
Queue.clear relax;
Buffer.clear buf;
resolve_frag_full relax frag;
lower_frag ~sess ~lsb0 ~buf ~relax ~frag;
if Queue.is_empty relax
then ()
else
begin
iflog sess (fun _ -> log sess "relaxing");
Queue.iter bump_relax relax;
loop ()
end
in
loop ()
and resolve_frag_full (relax:relaxation Queue.t) (frag:frag)
: unit =
let file_pos = ref 0 in
let mem_pos = ref 0L in
let bump i =
mem_pos := Int64.add (!mem_pos) (Int64.of_int i);
file_pos := (!file_pos) + i
in
let uleb (e:expr64) : unit =
let rec loop value =
let value = Int64.shift_right_logical value 7 in
if value = 0L
then bump 1
else
begin
bump 1;
loop value
end
in
loop (eval64 e)
in
let sleb (e:expr64) : unit =
let rec loop value =
let byte = Int64.logand value 0xf7L in
let value = Int64.shift_right value 7 in
let signbit = Int64.logand byte 0x40L in
if (((value = 0L) && (signbit = 0L)) ||
((value = -1L) && (signbit = 0x40L)))
then bump 1
else
begin
bump 1;
loop value
end
in
loop (eval64 e)
in
let rec resolve_frag it =
match it with
| MARK -> ()
| SEQ frags -> Array.iter resolve_frag frags
| PAD i -> bump i
| BSS i -> mem_pos := Int64.add (!mem_pos) i
| MEMPOS i -> mem_pos := i
| BYTE _ -> bump 1
| BYTES ia -> bump (Array.length ia)
| CHAR _ -> bump 1
| STRING s -> bump (String.length s)
| ZSTRING s -> bump ((String.length s) + 1)
| ULEB128 e -> uleb e
| SLEB128 e -> sleb e
| WORD (mach,_) -> bump (bytes_of_ty_mach mach)
| ALIGN_FILE (n, frag) ->
let spill = (!file_pos) mod n in
let pad = (n - spill) mod n in
file_pos := (!file_pos) + pad;
(*
* NB: aligning the file *causes* likewise alignment of
* memory, since we implement "file alignment" by
* padding!
*)
mem_pos := Int64.add (!mem_pos) (Int64.of_int pad);
resolve_frag frag
| ALIGN_MEM (n, frag) ->
let n64 = Int64.of_int n in
let spill = Int64.rem (!mem_pos) n64 in
let pad = Int64.rem (Int64.sub n64 spill) n64 in
mem_pos := Int64.add (!mem_pos) pad;
resolve_frag frag
| DEF (f, i) ->
let fpos1 = !file_pos in
let mpos1 = !mem_pos in
resolve_frag i;
f.fixup_file_pos <- Some fpos1;
f.fixup_mem_pos <- Some mpos1;
f.fixup_file_sz <- Some ((!file_pos) - fpos1);
f.fixup_mem_sz <- Some (Int64.sub (!mem_pos) mpos1)
| RELAX rel ->
begin
try
resolve_frag rel.relax_options.(!(rel.relax_choice))
with
Bad_fit _ -> Queue.add rel relax
end
in
resolve_frag frag
and lower_frag
~(sess:Session.sess)
~(lsb0:bool)
~(buf:Buffer.t)
~(relax:relaxation Queue.t)
~(frag:frag)
: unit =
let byte (i:int) =
if i < 0
then raise (Bad_fit "byte underflow")
else
if i > 255
then raise (Bad_fit "byte overflow")
else Buffer.add_char buf (Char.chr i)
in
let uleb (e:expr64) : unit =
let emit1 k = Buffer.add_char buf (Char.chr (Int64.to_int k)) in
let rec loop value =
let byte = Int64.logand value 0x7fL in
let value = Int64.shift_right_logical value 7 in
if value = 0L
then emit1 byte
else
begin
emit1 (Int64.logor byte 0x80L);
loop value
end
in
loop (eval64 e)
in
let sleb (e:expr64) : unit =
let emit1 k = Buffer.add_char buf (Char.chr (Int64.to_int k)) in
let rec loop value =
let byte = Int64.logand value 0x7fL in
let value = Int64.shift_right value 7 in
let signbit = Int64.logand byte 0x40L in
if (((value = 0L) && (signbit = 0L)) ||
((value = -1L) && (signbit = 0x40L)))
then emit1 byte
else
begin
emit1 (Int64.logor byte 0x80L);
loop value
end
in
loop (eval64 e)
in
let word (nbytes:int) (signed:bool) (e:expr64) =
let i = eval64 e in
(*
FIXME:
We should really base the entire assembler and memory-position
system on Big_int.big_int, but in ocaml the big_int type lacks,
oh, just about every useful function (no format string spec, no
bitwise ops, blah blah) so it's useless; we're stuck on int64
for bootstrapping.
For the time being we're just going to require you to represent
those few unsigned 64 bit terms you have in mind via their
signed bit pattern. Suboptimal but it's the best we can do.
*)
let (top,bot) =
if nbytes >= 8
then
if signed
then (Int64.max_int,Int64.min_int)
else (Int64.max_int,0L)
else
if signed
then
let bound = (Int64.shift_left 1L ((8 * nbytes) - 1)) in
(Int64.sub bound 1L, Int64.neg bound)
else
let bound = (Int64.shift_left 1L (8 * nbytes)) in
(Int64.sub bound 1L, 0L)
in
let mask1 = Int64.logand 0xffL in
let shift = Int64.shift_right_logical in
let emit1 k = Buffer.add_char buf (Char.chr (Int64.to_int k)) in
if Int64.compare i bot = (-1)
then raise (Bad_fit ("word underflow: "
^ (Int64.to_string i)
^ " into "
^ (string_of_int nbytes)
^ (if signed then " signed" else " unsigned")
^ " bytes"))
else
if Int64.compare i top = 1
then raise (Bad_fit ("word overflow: "
^ (Int64.to_string i)
^ " into "
^ (string_of_int nbytes)
^ (if signed then " signed" else " unsigned")
^ " bytes"))
else
if lsb0
then
for n = 0 to (nbytes - 1) do
emit1 (mask1 (shift i (8*n)))
done
else
for n = (nbytes - 1) downto 0 do
emit1 (mask1 (shift i (8*n)))
done
in
match frag with
MARK -> ()
| SEQ frags ->
Array.iter
begin
fun frag ->
lower_frag ~sess ~lsb0 ~buf ~relax ~frag
end frags
| PAD c ->
for i = 1 to c do
Buffer.add_char buf '\x00'
done
| BSS _ -> ()
| MEMPOS _ -> ()
| BYTE i -> byte i
| BYTES bs ->
iflog sess (fun _ -> log sess "lowering %d bytes"
(Array.length bs));
Array.iter byte bs
| CHAR c ->
iflog sess (fun _ -> log sess "lowering char: %c" c);
Buffer.add_char buf c
| STRING s ->
iflog sess (fun _ -> log sess "lowering string: %s" s);
Buffer.add_string buf s
| ZSTRING s ->
iflog sess (fun _ -> log sess "lowering zstring: %s" s);
Buffer.add_string buf s;
byte 0
| ULEB128 e -> uleb e
| SLEB128 e -> sleb e
| WORD (m,e) ->
iflog sess
(fun _ ->
log sess "lowering word %s with val %s"
(string_of_ty_mach m)
(fmt_to_str fmt_frag frag));
word (bytes_of_ty_mach m) (mach_is_signed m) e
| ALIGN_FILE (n, frag) ->
let spill = (Buffer.length buf) mod n in
let pad = (n - spill) mod n in
for i = 1 to pad do
Buffer.add_char buf '\x00'
done;
lower_frag sess lsb0 buf relax frag
| ALIGN_MEM (_, i) -> lower_frag sess lsb0 buf relax i
| DEF (f, i) ->
iflog sess (fun _ -> log sess "lowering fixup: %s" f.fixup_name);
lower_frag sess lsb0 buf relax i;
| RELAX rel ->
begin
try
lower_frag sess lsb0 buf relax
rel.relax_options.(!(rel.relax_choice))
with
Bad_fit _ -> Queue.add rel relax
end
;;
let fold_flags (f:'a -> int64) (flags:'a list) : int64 =
List.fold_left (Int64.logor) 0x0L (List.map f flags)
;;
let write_out_frag sess lsb0 frag =
let buf = Buffer.create 0xffff in
let file = Session.filename_of sess.Session.sess_out in
let out = open_out_bin file in
write_frag ~sess ~lsb0 ~buf ~frag;
Buffer.output_buffer out buf;
flush out;
close_out out;
Unix.chmod file 0o755
;;
(* Asm-reader stuff for loading info back from mapped files. *)
(*
* Unfortunately the ocaml Bigarray interface takes 'int' indices, so
* f.e. can't do 64-bit offsets / files when running on a 32bit platform.
* Despite the fact that we can possibly produce them. Sigh. Yet another
* "bootstrap compiler limitation".
*)
type asm_reader =
{
asm_seek: int -> unit;
asm_get_u32: unit -> int;
asm_get_u16: unit -> int;
asm_get_u8: unit -> int;
asm_get_uleb: unit -> int;
asm_get_zstr: unit -> string;
asm_get_zstr_padded: int -> string;
asm_get_off: unit -> int;
asm_adv: int -> unit;
asm_adv_u32: unit -> unit;
asm_adv_u16: unit -> unit;
asm_adv_u8: unit -> unit;
asm_adv_zstr: unit -> unit;
asm_close: unit -> unit;
}
;;
type mmap_arr =
(int, Bigarray.int8_unsigned_elt, Bigarray.c_layout)
Bigarray.Array1.t
;;
let new_asm_reader (sess:Session.sess) (s:filename) : asm_reader =
iflog sess (fun _ -> log sess "opening file %s" s);
let fd = Unix.openfile s [ Unix.O_RDONLY ] 0 in
let arr = (Bigarray.Array1.map_file
fd ~pos:0L
Bigarray.int8_unsigned
Bigarray.c_layout
false (-1))
in
let tmp = ref Nativeint.zero in
let buf = Buffer.create 16 in
let off = ref 0 in
let is_open = ref true in
let get_word_as_int (nbytes:int) : int =
assert (!is_open);
let lsb0 = true in
tmp := Nativeint.zero;
if lsb0
then
for j = nbytes-1 downto 0 do
tmp := Nativeint.shift_left (!tmp) 8;
tmp := Nativeint.logor (!tmp) (Nativeint.of_int arr.{(!off) + j})
done
else
for j = 0 to nbytes-1 do
tmp := Nativeint.shift_left (!tmp) 8;
tmp := Nativeint.logor (!tmp) (Nativeint.of_int arr.{(!off) + j})
done;
off := (!off) + nbytes;
Nativeint.to_int (!tmp)
in
let get_zstr_padded pad_opt =
assert (!is_open);
let i = ref (!off) in
Buffer.clear buf;
let buflen_ok _ =
match pad_opt with
None -> true
| Some pad -> (Buffer.length buf) < pad
in
while arr.{!i} != 0 && (buflen_ok()) do
Buffer.add_char buf (Char.chr arr.{!i});
incr i
done;
begin
match pad_opt with
None -> off := (!off) + (Buffer.length buf) + 1
| Some pad ->
begin
assert ((Buffer.length buf) <= pad);
off := (!off) + pad
end
end;
Buffer.contents buf
in
let bump i =
assert (!is_open);
off := (!off) + i
in
{
asm_seek = (fun i -> off := i);
asm_get_u32 = (fun _ -> get_word_as_int 4);
asm_get_u16 = (fun _ -> get_word_as_int 2);
asm_get_u8 = (fun _ -> get_word_as_int 1);
asm_get_uleb =
begin
fun _ ->
let rec loop result shift =
let byte = arr.{!off} in
incr off;
let result = result lor ((byte land 0x7f) lsl shift) in
if (byte land 0x80) = 0
then result
else loop result (shift+7)
in
loop 0 0
end;
asm_get_zstr = (fun _ -> get_zstr_padded None);
asm_get_zstr_padded = (fun pad -> get_zstr_padded (Some pad));
asm_get_off = (fun _ -> !off);
asm_adv = bump;
asm_adv_u32 = (fun _ -> bump 4);
asm_adv_u16 = (fun _ -> bump 2);
asm_adv_u8 = (fun _ -> bump 1);
asm_adv_zstr = (fun _ -> while arr.{!off} != 0
do incr off done);
asm_close = (fun _ ->
assert (!is_open);
Unix.close fd;
is_open := false)
}
;;
(*
* Metadata note-section encoding / decoding.
*
* Since the only object format that defines a "note" section at all is
* ELF, we model the contents of the metadata section on ELF's
* notes. But the same blob of data is stuck into PE and Mach-O files
* too.
*
* The format is essentially just the ELF note format:
*
* <un-padded-size-of-name:u32>
* <size-of-desc:u32>
* <type-code=0:u32>
* <name="rust":zstr>
* <0-pad to 4-byte boundary>
* <n=meta-count:u32>
* <k1:zstr> <v1:zstr>
* ...
* <kn:zstr> <vn:zstr>
* <0-pad to 4-byte boundary>
*
*)
let note_rust_frags (meta:(Ast.ident * string) array) : frag =
let desc_fixup = new_fixup ".rust.note metadata" in
let desc =
DEF (desc_fixup,
SEQ [|
WORD (TY_u32, IMM (Int64.of_int (Array.length meta)));
SEQ (Array.map
(fun (k,v) -> SEQ [| ZSTRING k; ZSTRING v; |])
meta);
ALIGN_FILE (4, MARK) |])
in
let name = "rust" in
let ty = 0L in
let padded_name = SEQ [| ZSTRING name;
ALIGN_FILE (4, MARK) |]
in
let name_sz = IMM (Int64.of_int ((String.length name) + 1)) in
SEQ [| WORD (TY_u32, name_sz);
WORD (TY_u32, F_SZ desc_fixup);
WORD (TY_u32, IMM ty);
padded_name;
desc;|]
;;
let read_rust_note (ar:asm_reader) : (Ast.ident * string) array =
ar.asm_adv_u32 ();
ar.asm_adv_u32 ();
assert ((ar.asm_get_u32 ()) = 0);
let rust_name = ar.asm_get_zstr_padded 8 in
assert (rust_name = "rust");
let n = ar.asm_get_u32() in
let meta = Queue.create () in
for i = 1 to n
do
let k = ar.asm_get_zstr() in
let v = ar.asm_get_zstr() in
Queue.add (k,v) meta
done;
queue_to_arr meta
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

1784
src/boot/be/elf.ml
View File

File diff suppressed because it is too large Load Diff

937
src/boot/be/il.ml
View File

@ -1,937 +0,0 @@
open Common;;
(* FIXME (issue #1): thread a session object through this eventually. *)
let log_iltypes = ref false;;
(* IL type system, very rudimentary. *)
type bits =
Bits8
| Bits16
| Bits32
| Bits64
;;
type scalar_ty =
ValTy of bits
| AddrTy of referent_ty
and referent_ty =
ScalarTy of scalar_ty
| StructTy of referent_ty array
| UnionTy of referent_ty array
| ParamTy of ty_param_idx (* Thing of current-frame type-param #n *)
| OpaqueTy (* Unknown memory-resident thing. *)
| CodeTy (* Executable machine code. *)
| NilTy (* 0 bits of space. *)
;;
let (voidptr_t:scalar_ty) = AddrTy OpaqueTy;;
let (codeptr_t:scalar_ty) = AddrTy CodeTy;;
(* Operands. *)
type vreg = int ;;
type hreg = int ;;
type label = int ;;
type spill = int ;;
type reg =
Vreg of vreg
| Hreg of hreg
;;
type mem =
Abs of Asm.expr64
| RegIn of (reg * (Asm.expr64 option))
| Spill of spill
;;
type typed_reg = (reg * scalar_ty);;
type typed_mem = (mem * referent_ty);;
type typed_imm = (Asm.expr64 * ty_mach);;
type typed_imm_ptr = (fixup * referent_ty);;
type cell =
Reg of typed_reg
| Mem of typed_mem
;;
(*
* ImmPtr (a, rty) can be assigned to anything of scalar_ty
* AddrTy rty; the difference is that ImmAddr carries its value
* so can be used in cases where we want to have an immediate
* address constant-propagated through the code to the backend.
*)
type operand =
Cell of cell
| Imm of typed_imm
| ImmPtr of typed_imm_ptr
;;
type code =
CodeLabel of label (* Index into current quad block. *)
| CodePtr of operand
| CodeNone
;;
(* NB: for the most part, we let the register allocator assign spills
* from vregs, and we permanently allocate aliased slots to stack
* locations by static aliasing information early, in layout.
*
* The one awkward case this doesn't handle is when someone tries to
* pass a literal-atom to an alias-slot. This *requires* a memory slot
* but we only realize it rather late, much later than we'd normally
* have thougt to desugar the literal into a temporary.
*
* So in these cases, we let the trans module explicitly demand a
* "Spill n" operand, which the register allocator mops up before it
* gets started on the vregs.
*
* NOTE: if we were more clever we'd integrate vregs and spills like
* this together along with the general notion of a temporary way back
* at the desugaring stage, and use some kind of size-class
* consolidation so that spills with non-overlapping lifetimes could
* share memory. But we're not that clever yet.
*)
(* Helpers. *)
let direct_code_ptr fix =
(CodePtr (ImmPtr (fix, CodeTy)))
;;
let cell_referent_ty c =
match c with
Reg (_, st) -> ScalarTy st
| Mem (_, rt) -> rt
;;
let cell_is_nil c =
match c with
Mem (_, NilTy) -> true
| Reg (_, AddrTy NilTy) -> true
| _ -> false
;;
let operand_is_nil o =
match o with
Cell c -> cell_is_nil c
| _ -> false
;;
let mem_off (mem:mem) (off:Asm.expr64) : mem =
let addto e = Asm.ADD (off, e) in
match mem with
Abs e -> Abs (addto e)
| RegIn (r, None) -> RegIn (r, Some off)
| RegIn (r, Some e) -> RegIn (r, Some (addto e))
| Spill _ ->
bug () "Adding offset %s to spill slot"
(Asm.string_of_expr64 off)
;;
let mem_off_imm (mem:mem) (imm:int64) : mem =
mem_off mem (Asm.IMM imm)
;;
(* Quads. *)
type binop =
ADD | SUB
| IMUL | UMUL
| IDIV | UDIV
| IMOD | UMOD
| AND | OR | XOR
| LSL | LSR | ASR
;;
type unop =
NEG | NOT
| UMOV | IMOV
| ZERO
;;
type jmpop =
JE | JNE
| JZ | JNZ (* FIXME: Synonyms with JE/JNE in x86, others? *)
| JL | JLE | JG | JGE (* Signed. *)
| JB | JBE | JA | JAE (* Unsigned. *)
| JC | JNC | JO | JNO
| JMP
;;
type binary =
{
binary_op: binop;
binary_dst: cell;
binary_lhs: operand;
binary_rhs: operand
}
;;
type unary =
{
unary_op: unop;
unary_dst: cell;
unary_src: operand
}
;;
type cmp =
{
cmp_lhs: operand;
cmp_rhs: operand
}
;;
type lea =
{
lea_dst: cell;
lea_src: operand
}
;;
type jmp =
{
jmp_op: jmpop;
jmp_targ: code;
}
;;
type call =
{
call_dst: cell;
call_targ: code
}
type quad' =
Binary of binary
| Unary of unary
| Lea of lea
| Cmp of cmp
| Jmp of jmp
| Push of operand
| Pop of cell
| Call of call
| Debug (* Debug-break pseudo-instruction. *)
| Enter of fixup (* Enter-fixup-block pseudo-instruction. *)
| Leave (* Leave-fixup-block pseudo-instruction. *)
| Ret (* Return to caller. *)
| Nop (* Keep this quad here, emit CPU nop. *)
| Dead (* Keep this quad but emit nothing. *)
| Regfence (* Clobber all hregs. *)
| End (* Space past the end of quads to emit. *)
;;
type quad =
{ quad_fixup: fixup option;
quad_body: quad'; }
type quads = quad array ;;
(* Query functions. *)
let cell_is_scalar (c:cell) : bool =
match c with
Reg (_, _) -> true
| Mem (_, ScalarTy _) -> true
| _ -> false
;;
let bits_of_ty_mach (tm:ty_mach) : bits =
match tm with
| TY_u8 -> Bits8
| TY_i8 -> Bits8
| TY_u16 -> Bits16
| TY_i16 -> Bits16
| TY_u32 -> Bits32
| TY_i32 -> Bits32
| TY_u64 -> Bits64
| TY_i64 -> Bits64
| TY_f32 -> Bits32
| TY_f64 -> Bits64
;;
let cell_scalar_ty (c:cell) : scalar_ty =
match c with
Reg (_, st) -> st
| Mem (_, ScalarTy st) -> st
| _ -> bug () "mem of non-scalar in Il.cell_scalar_ty"
;;
let operand_scalar_ty (op:operand) : scalar_ty =
match op with
Cell c -> cell_scalar_ty c
| Imm (_, t) -> ValTy (bits_of_ty_mach t)
| ImmPtr (_, t) -> AddrTy t
;;
let scalar_ty_bits (word_bits:bits) (st:scalar_ty) : bits =
match st with
ValTy bits -> bits
| AddrTy _ -> word_bits
;;
let cell_bits (word_bits:bits) (c:cell) : bits =
match c with
Reg (_, st) -> scalar_ty_bits word_bits st
| Mem (_, ScalarTy st) -> scalar_ty_bits word_bits st
| Mem _ -> bug () "mem of non-scalar in Il.cell_bits"
;;
let operand_bits (word_bits:bits) (op:operand) : bits =
match op with
Cell cell -> cell_bits word_bits cell
| Imm (_, tm) -> bits_of_ty_mach tm
| ImmPtr _ -> word_bits
;;
let bits_size (bits:bits) : int64 =
match bits with
Bits8 -> 1L
| Bits16 -> 2L
| Bits32 -> 4L
| Bits64 -> 8L
;;
let bits_align (bits:bits) : int64 =
match bits with
Bits8 -> 1L
| Bits16 -> 2L
| Bits32 -> 4L
| Bits64 -> 8L
;;
let scalar_ty_size (word_bits:bits) (st:scalar_ty) : int64 =
bits_size (scalar_ty_bits word_bits st)
;;
let scalar_ty_align (word_bits:bits) (st:scalar_ty) : int64 =
bits_align (scalar_ty_bits word_bits st)
;;
let rec referent_ty_layout (word_bits:bits) (rt:referent_ty) : (size * size) =
match rt with
ScalarTy st -> (SIZE_fixed (scalar_ty_size word_bits st),
SIZE_fixed (scalar_ty_align word_bits st))
| StructTy rts ->
begin
let accum (off,align) rt : (size * size) =
let (elt_size, elt_align) = referent_ty_layout word_bits rt in
let elt_off = align_sz elt_align off in
(add_sz elt_off elt_size, max_sz elt_align align)
in
Array.fold_left accum (SIZE_fixed 0L, SIZE_fixed 1L) rts
end
| UnionTy rts ->
begin
let accum (sz,align) rt : (size * size) =
let (elt_size, elt_align) = referent_ty_layout word_bits rt in
(max_sz sz elt_size, max_sz elt_align align)
in
Array.fold_left accum (SIZE_fixed 0L, SIZE_fixed 1L) rts
end
| OpaqueTy -> bug () "opaque ty in referent_ty_layout"
| CodeTy -> bug () "code ty in referent_ty_layout"
| ParamTy i -> (SIZE_param_size i, SIZE_param_align i)
| NilTy -> (SIZE_fixed 0L, SIZE_fixed 1L)
and referent_ty_size (word_bits:bits) (rt:referent_ty) : size =
(fst (referent_ty_layout word_bits rt))
and referent_ty_align (word_bits:bits) (rt:referent_ty) : size =
(snd (referent_ty_layout word_bits rt))
;;
let get_element_offset
(word_bits:bits)
(elts:referent_ty array)
(i:int)
: size =
let elts_before = Array.sub elts 0 i in
let elt_rty = elts.(i) in
let elts_before_size = referent_ty_size word_bits (StructTy elts_before) in
let elt_align = referent_ty_align word_bits elt_rty in
let elt_off = align_sz elt_align elts_before_size in
elt_off
;;
(* Processor. *)
type quad_processor =
{ qp_reg: (quad_processor -> reg -> reg);
qp_mem: (quad_processor -> mem -> mem);
qp_cell_read: (quad_processor -> cell -> cell);
qp_cell_write: (quad_processor -> cell -> cell);
qp_code: (quad_processor -> code -> code);
qp_op: (quad_processor -> operand -> operand); }
;;
let identity_processor =
let qp_cell = (fun qp c -> match c with
Reg (r, b) -> Reg (qp.qp_reg qp r, b)
| Mem (a, b) -> Mem (qp.qp_mem qp a, b))
in
{ qp_reg = (fun _ r -> r);
qp_mem = (fun qp a -> match a with
RegIn (r, o) -> RegIn (qp.qp_reg qp r, o)
| Abs _
| Spill _ -> a);
qp_cell_read = qp_cell;
qp_cell_write = qp_cell;
qp_code = (fun qp c -> match c with
CodePtr op -> CodePtr (qp.qp_op qp op)
| CodeLabel _
| CodeNone -> c);
qp_op = (fun qp op -> match op with
Cell c -> Cell (qp.qp_cell_read qp c)
| ImmPtr _ -> op
| Imm _ -> op) }
;;
let process_quad (qp:quad_processor) (q:quad) : quad =
{ q with
quad_body = match q.quad_body with
Binary b ->
Binary { b with
binary_dst = qp.qp_cell_write qp b.binary_dst;
binary_lhs = qp.qp_op qp b.binary_lhs;
binary_rhs = qp.qp_op qp b.binary_rhs }
| Unary u ->
Unary { u with
unary_dst = qp.qp_cell_write qp u.unary_dst;
unary_src = qp.qp_op qp u.unary_src }
| Lea le ->
Lea { lea_dst = qp.qp_cell_write qp le.lea_dst;
lea_src = qp.qp_op qp le.lea_src }
| Cmp c ->
Cmp { cmp_lhs = qp.qp_op qp c.cmp_lhs;
cmp_rhs = qp.qp_op qp c.cmp_rhs }
| Jmp j ->
Jmp { j with
jmp_targ = qp.qp_code qp j.jmp_targ }
| Push op ->
Push (qp.qp_op qp op)
| Pop c ->
Pop (qp.qp_cell_write qp c)
| Call c ->
Call { call_dst = qp.qp_cell_write qp c.call_dst;
call_targ = qp.qp_code qp c.call_targ }
| Ret -> Ret
| Nop -> Nop
| Debug -> Debug
| Regfence -> Regfence
| Enter f -> Enter f
| Leave -> Leave
| Dead -> Dead
| End -> End }
;;
let visit_quads (qp:quad_processor) (qs:quads) : unit =
Array.iter (fun x ->ignore ( process_quad qp x); ()) qs
;;
let process_quads (qp:quad_processor) (qs:quads) : quads =
Array.map (process_quad qp) qs
;;
let rewrite_quads (qp:quad_processor) (qs:quads) : unit =
for i = 0 to ((Array.length qs) - 1) do
qs.(i) <- process_quad qp qs.(i)
done
;;
(* A little partial-evaluator to help lowering sizes. *)
let rec size_to_expr64 (a:size) : Asm.expr64 option =
let binary a b f =
match (size_to_expr64 a, size_to_expr64 b) with
(Some a, Some b) -> Some (f a b)
| _ -> None
in
match a with
SIZE_fixed i -> Some (Asm.IMM i)
| SIZE_fixup_mem_sz f -> Some (Asm.M_SZ f)
| SIZE_fixup_mem_pos f -> Some (Asm.M_POS f)
| SIZE_rt_neg s ->
begin
match (size_to_expr64 s) with
None -> None
| Some s -> Some (Asm.NEG s)
end
| SIZE_rt_add (a, b) -> binary a b (fun a b -> Asm.ADD (a,b))
| SIZE_rt_mul (a, b) -> binary a b (fun a b -> Asm.MUL (a,b))
| SIZE_rt_max (a, b) -> binary a b (fun a b -> Asm.MAX (a,b))
| SIZE_rt_align (a, b) -> binary a b (fun a b -> Asm.ALIGN (a,b))
| _ -> None
;;
(* Formatters. *)
let string_of_bits (b:bits) : string =
match b with
Bits8 -> "b8"
| Bits16 -> "b16"
| Bits32 -> "b32"
| Bits64 -> "b64"
;;
let rec string_of_scalar_ty (s:scalar_ty) : string =
match s with
ValTy b -> (string_of_bits b)
| AddrTy r -> (string_of_referent_ty r) ^ "*"
and string_of_referent_ty (r:referent_ty) : string =
match r with
ScalarTy s -> (string_of_scalar_ty s)
| StructTy rs ->
Printf.sprintf "[%s]"
(String.concat ","
(Array.to_list (Array.map string_of_referent_ty rs)))
| UnionTy rs ->
Printf.sprintf "(%s)"
(String.concat "|"
(Array.to_list (Array.map string_of_referent_ty rs)))
| ParamTy i -> Printf.sprintf "#%d" i
| OpaqueTy -> "?"
| CodeTy -> "!"
| NilTy -> "()"
;;
type hreg_formatter = hreg -> string;;
let string_of_reg (f:hreg_formatter) (r:reg) : string =
match r with
Vreg i -> Printf.sprintf "<v%d>" i
| Hreg i -> f i
;;
let string_of_off (e:Asm.expr64 option) : string =
match e with
None -> ""
| Some (Asm.IMM i) when (i64_lt i 0L) ->
Printf.sprintf " - 0x%Lx" (Int64.neg i)
| Some e' -> " + " ^ (Asm.string_of_expr64 e')
;;
let string_of_mem (f:hreg_formatter) (a:mem) : string =
match a with
Abs e ->
Printf.sprintf "[%s]" (Asm.string_of_expr64 e)
| RegIn (r, off) ->
Printf.sprintf "[%s%s]" (string_of_reg f r) (string_of_off off)
| Spill i ->
Printf.sprintf "[<spill %d>]" i
;;
let string_of_cell (f:hreg_formatter) (c:cell) : string =
match c with
Reg (r,ty) ->
if !log_iltypes
then
Printf.sprintf "%s:%s" (string_of_reg f r) (string_of_scalar_ty ty)
else
Printf.sprintf "%s" (string_of_reg f r)
| Mem (a,ty) ->
if !log_iltypes
then
Printf.sprintf "%s:%s"
(string_of_mem f a) (string_of_referent_ty ty)
else
Printf.sprintf "%s" (string_of_mem f a)
;;
let string_of_operand (f:hreg_formatter) (op:operand) : string =
match op with
Cell c -> string_of_cell f c
| ImmPtr (f, ty) ->
if !log_iltypes
then
Printf.sprintf "$<%s>.mpos:%s*"
f.fixup_name (string_of_referent_ty ty)
else
Printf.sprintf "$<%s>.mpos" f.fixup_name
| Imm (i, ty) ->
if !log_iltypes
then
Printf.sprintf "$%s:%s"
(Asm.string_of_expr64 i) (string_of_ty_mach ty)
else
Printf.sprintf "$%s" (Asm.string_of_expr64 i)
;;
let string_of_code (f:hreg_formatter) (c:code) : string =
match c with
CodeLabel lab -> Printf.sprintf "<label %d>" lab
| CodePtr op -> string_of_operand f op
| CodeNone -> "<none>"
;;
let string_of_binop (op:binop) : string =
match op with
ADD -> "add"
| SUB -> "sub"
| IMUL -> "imul"
| UMUL -> "umul"
| IDIV -> "idiv"
| UDIV -> "udiv"
| IMOD -> "imod"
| UMOD -> "umod"
| AND -> "and"
| OR -> "or"
| XOR -> "xor"
| LSL -> "lsl"
| LSR -> "lsr"
| ASR -> "asr"
;;
let string_of_unop (op:unop) : string =
match op with
NEG -> "neg"
| NOT -> "not"
| UMOV -> "umov"
| IMOV -> "imov"
| ZERO -> "zero"
;;
let string_of_jmpop (op:jmpop) : string =
match op with
JE -> "je"
| JNE -> "jne"
| JL -> "jl"
| JLE -> "jle"
| JG -> "jg"
| JGE -> "jge"
| JB -> "jb"
| JBE -> "jbe"
| JA -> "ja"
| JAE -> "jae"
| JC -> "jc"
| JNC ->"jnc"
| JO -> "jo"
| JNO -> "jno"
| JZ -> "jz"
| JNZ ->"jnz"
| JMP -> "jmp"
;;
let string_of_quad (f:hreg_formatter) (q:quad) : string =
match q.quad_body with
Binary b ->
Printf.sprintf "%s = %s %s %s"
(string_of_cell f b.binary_dst)
(string_of_operand f b.binary_lhs)
(string_of_binop b.binary_op)
(string_of_operand f b.binary_rhs)
| Unary u ->
Printf.sprintf "%s = %s %s"
(string_of_cell f u.unary_dst)
(string_of_unop u.unary_op)
(string_of_operand f u.unary_src)
| Cmp c ->
Printf.sprintf "cmp %s %s"
(string_of_operand f c.cmp_lhs)
(string_of_operand f c.cmp_rhs)
| Lea le ->
Printf.sprintf "lea %s %s"
(string_of_cell f le.lea_dst)
(string_of_operand f le.lea_src)
| Jmp j ->
Printf.sprintf "%s %s"
(string_of_jmpop j.jmp_op)
(string_of_code f j.jmp_targ)
| Push op ->
Printf.sprintf "push %s"
(string_of_operand f op)
| Pop c ->
Printf.sprintf "%s = pop"
(string_of_cell f c)
| Call c ->
Printf.sprintf "%s = call %s"
(string_of_cell f c.call_dst)
(string_of_code f c.call_targ)
| Ret -> "ret"
| Nop -> "nop"
| Dead -> "dead"
| Debug -> "debug"
| Regfence -> "regfence"
| Enter _ -> "enter lexical block"
| Leave -> "leave lexical block"
| End -> "---"
;;
(* Emitters. *)
type emitter = { mutable emit_pc: int;
mutable emit_next_vreg: int option;
mutable emit_next_spill: int;
emit_target_specific: (emitter -> quad -> unit);
mutable emit_quads: quads;
emit_annotations: (int,string) Hashtbl.t;
emit_size_cache: (size,operand) Hashtbl.t;
emit_node: node_id option;
}
let badq = { quad_fixup = None;
quad_body = End }
;;
let deadq = { quad_fixup = None;
quad_body = Dead }
;;
let new_emitter
(emit_target_specific:emitter -> quad -> unit)
(vregs_ok:bool)
(node:node_id option)
: emitter =
{
emit_pc = 0;
emit_next_vreg = (if vregs_ok then Some 0 else None);
emit_next_spill = 0;
emit_target_specific = emit_target_specific;
emit_quads = Array.create 4 badq;
emit_annotations = Hashtbl.create 0;
emit_size_cache = Hashtbl.create 0;
emit_node = node;
}
;;
let num_vregs (e:emitter) : int =
match e.emit_next_vreg with
None -> 0
| Some i -> i
;;
let next_vreg_num (e:emitter) : vreg =
match e.emit_next_vreg with
None -> bug () "Il.next_vreg_num on non-vreg emitter"
| Some i ->
e.emit_next_vreg <- Some (i + 1);
i
;;
let next_vreg (e:emitter) : reg =
Vreg (next_vreg_num e)
;;
let next_vreg_cell (e:emitter) (s:scalar_ty) : cell =
Reg ((next_vreg e), s)
;;
let next_spill (e:emitter) : spill =
let i = e.emit_next_spill in
e.emit_next_spill <- i + 1;
i
;;
let next_spill_slot (e:emitter) (r:referent_ty) : typed_mem =
(Spill (next_spill e), r);
;;
let grow_if_necessary e =
let len = Array.length e.emit_quads in
if e.emit_pc >= len - 1
then
let n = Array.create (2 * len) badq in
Array.blit e.emit_quads 0 n 0 len;
e.emit_quads <- n
;;
let binary (op:binop) (dst:cell) (lhs:operand) (rhs:operand) : quad' =
Binary { binary_op = op;
binary_dst = dst;
binary_lhs = lhs;
binary_rhs = rhs }
;;
let unary (op:unop) (dst:cell) (src:operand) : quad' =
Unary { unary_op = op;
unary_dst = dst;
unary_src = src }
let jmp (op:jmpop) (targ:code) : quad' =
Jmp { jmp_op = op;
jmp_targ = targ; }
;;
let lea (dst:cell) (src:operand) : quad' =
Lea { lea_dst = dst;
lea_src = src; }
;;
let cmp (lhs:operand) (rhs:operand) : quad' =
Cmp { cmp_lhs = lhs;
cmp_rhs = rhs; }
;;
let call (dst:cell) (targ:code) : quad' =
Call { call_dst = dst;
call_targ = targ; }
;;
let umov (dst:cell) (src:operand) : quad' =
if (cell_is_nil dst || operand_is_nil src)
then Dead
else unary UMOV dst src
;;
let imov (dst:cell) (src:operand) : quad' =
if (cell_is_nil dst || operand_is_nil src)
then Dead
else unary IMOV dst src
;;
let zero (dst:cell) (count:operand) : quad' =
unary ZERO dst count
;;
let is_mov uop =
match uop with
UMOV | IMOV -> true
| _ -> false
;;
let mk_quad (q':quad') : quad =
{ quad_body = q';
quad_fixup = None }
;;
let append_quad
(e:emitter)
(q:quad)
: unit =
grow_if_necessary e;
e.emit_quads.(e.emit_pc) <- q;
e.emit_pc <- e.emit_pc + 1
;;
let default_mov q' =
match q' with
Binary b ->
begin
match b.binary_op with
IDIV | IMUL | IMOD -> IMOV
| _ -> UMOV
end
| Unary u ->
begin
match u.unary_op with
IMOV -> IMOV
| _ -> UMOV
end
| _ -> UMOV
;;
let emit_full
(e:emitter)
(fix:fixup option)
(q':quad')
: unit =
e.emit_target_specific e { quad_body = q';
quad_fixup = fix }
;;
let emit (e:emitter) (q':quad') : unit =
emit_full e None q'
;;
let patch_jump (e:emitter) (jmp:int) (targ:int) : unit =
let q = e.emit_quads.(jmp) in
match q.quad_body with
Jmp j ->
assert (j.jmp_targ = CodeNone);
e.emit_quads.(jmp) <-
{ q with quad_body =
Jmp { j with jmp_targ = CodeLabel targ } }
| _ -> ()
;;
(* More query functions. *)
let get_element_ptr
(word_bits:bits)
(fmt:hreg_formatter)
(mem_cell:cell)
(i:int)
: cell =
match mem_cell with
Mem (mem, StructTy elts) when i >= 0 && i < (Array.length elts) ->
assert ((Array.length elts) != 0);
begin
let elt_rty = elts.(i) in
let elt_off = get_element_offset word_bits elts i in
match elt_off with
SIZE_fixed fixed_off ->
Mem (mem_off_imm mem fixed_off, elt_rty)
| _ -> bug ()
"get_element_ptr %d on dynamic-size cell: offset %s"
i (string_of_size elt_off)
end
| _ -> bug () "get_element_ptr %d on cell %s" i
(string_of_cell fmt mem_cell)
;;
let cell_cast (cell:cell) (rty:referent_ty) : cell =
match cell with
Mem (mem, _) -> Mem (mem, rty)
| Reg (reg, _) ->
begin
match rty with
ScalarTy st -> Reg (reg, st)
| _ -> bug () "expected scalar type in Il.cell_cast on register"
end
let ptr_cast (cell:cell) (rty:referent_ty) : cell =
match cell with
Mem (mem, ScalarTy (AddrTy _)) -> Mem (mem, ScalarTy (AddrTy rty))
| Reg (reg, AddrTy _) -> Reg (reg, AddrTy rty)
| _ -> bug () "expected address cell in Il.ptr_cast"
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

1194
src/boot/be/macho.ml
View File

File diff suppressed because it is too large Load Diff

1175
src/boot/be/pe.ml
View File

File diff suppressed because it is too large Load Diff

688
src/boot/be/ra.ml
View File

@ -1,688 +0,0 @@
open Il;;
open Common;;
type ctxt =
{
ctxt_sess: Session.sess;
ctxt_n_vregs: int;
ctxt_abi: Abi.abi;
mutable ctxt_quads: Il.quads;
mutable ctxt_next_spill: int;
mutable ctxt_next_label: int;
(* More state as necessary. *)
}
;;
let new_ctxt
(sess:Session.sess)
(quads:Il.quads)
(vregs:int)
(abi:Abi.abi)
: ctxt =
{
ctxt_sess = sess;
ctxt_quads = quads;
ctxt_n_vregs = vregs;
ctxt_abi = abi;
ctxt_next_spill = 0;
ctxt_next_label = 0;
}
;;
let log (cx:ctxt) =
Session.log "ra"
cx.ctxt_sess.Session.sess_log_ra
cx.ctxt_sess.Session.sess_log_out
;;
let iflog (cx:ctxt) (thunk:(unit -> unit)) : unit =
if cx.ctxt_sess.Session.sess_log_ra
then thunk ()
else ()
;;
let list_to_str list eltstr =
(String.concat "," (List.map eltstr (List.sort compare list)))
;;
let next_spill (cx:ctxt) : int =
let i = cx.ctxt_next_spill in
cx.ctxt_next_spill <- i + 1;
i
;;
let next_label (cx:ctxt) : string =
let i = cx.ctxt_next_label in
cx.ctxt_next_label <- i + 1;
(".L" ^ (string_of_int i))
;;
exception Ra_error of string ;;
let convert_labels (cx:ctxt) : unit =
let quad_fixups = Array.map (fun q -> q.quad_fixup) cx.ctxt_quads in
let qp_code (_:Il.quad_processor) (c:Il.code) : Il.code =
match c with
Il.CodeLabel lab ->
let fix =
match quad_fixups.(lab) with
None ->
let fix = new_fixup (next_label cx) in
begin
quad_fixups.(lab) <- Some fix;
fix
end
| Some f -> f
in
Il.CodePtr (Il.ImmPtr (fix, Il.CodeTy))
| _ -> c
in
let qp = { Il.identity_processor
with Il.qp_code = qp_code }
in
Il.rewrite_quads qp cx.ctxt_quads;
Array.iteri (fun i fix ->
cx.ctxt_quads.(i) <- { cx.ctxt_quads.(i) with
Il.quad_fixup = fix })
quad_fixups;
;;
let convert_pre_spills
(cx:ctxt)
(mkspill:(Il.spill -> Il.mem))
: int =
let n = ref 0 in
let qp_mem (_:Il.quad_processor) (a:Il.mem) : Il.mem =
match a with
Il.Spill i ->
begin
if i+1 > (!n)
then n := i+1;
mkspill i
end
| _ -> a
in
let qp = Il.identity_processor in
let qp = { qp with
Il.qp_mem = qp_mem }
in
begin
Il.rewrite_quads qp cx.ctxt_quads;
!n
end
;;
let kill_quad (i:int) (cx:ctxt) : unit =
cx.ctxt_quads.(i) <-
{ Il.deadq with
Il.quad_fixup = cx.ctxt_quads.(i).Il.quad_fixup }
;;
let kill_redundant_moves (cx:ctxt) : unit =
let process_quad i q =
match q.Il.quad_body with
Il.Unary u when
((Il.is_mov u.Il.unary_op) &&
(Il.Cell u.Il.unary_dst) = u.Il.unary_src) ->
kill_quad i cx
| _ -> ()
in
Array.iteri process_quad cx.ctxt_quads
;;
let quad_jump_target_labels (q:quad) : Il.label list =
match q.Il.quad_body with
Il.Jmp jmp ->
begin
match jmp.Il.jmp_targ with
Il.CodeLabel lab -> [ lab ]
| _ -> []
end
| _ -> []
;;
let quad_used_vregs (q:quad) : Il.vreg list =
let vregs = ref [] in
let qp_reg _ r =
match r with
Il.Vreg v -> (vregs := (v :: (!vregs)); r)
| _ -> r
in
let qp_cell_write qp c =
match c with
Il.Reg _ -> c
| Il.Mem (a, b) -> Il.Mem (qp.qp_mem qp a, b)
in
let qp = { Il.identity_processor with
Il.qp_reg = qp_reg;
Il.qp_cell_write = qp_cell_write }
in
ignore (Il.process_quad qp q);
!vregs
;;
let quad_defined_vregs (q:quad) : Il.vreg list =
let vregs = ref [] in
let qp_cell_write _ c =
match c with
Il.Reg (Il.Vreg v, _) -> (vregs := (v :: (!vregs)); c)
| _ -> c
in
let qp = { Il.identity_processor with
Il.qp_cell_write = qp_cell_write }
in
ignore (Il.process_quad qp q);
!vregs
;;
let quad_is_unconditional_jump (q:quad) : bool =
match q.Il.quad_body with
Il.Jmp { jmp_op = Il.JMP; jmp_targ = _ } -> true
| Il.Ret -> true
| _ -> false
;;
let calculate_live_bitvectors
(cx:ctxt)
: ((Bits.t array) * (Bits.t array)) =
iflog cx (fun _ -> log cx "calculating live bitvectors");
let quads = cx.ctxt_quads in
let n_quads = Array.length quads in
let n_vregs = cx.ctxt_n_vregs in
let new_bitv _ = Bits.create n_vregs false in
let new_true_bitv _ = Bits.create n_vregs true in
let (live_in_vregs:Bits.t array) = Array.init n_quads new_bitv in
let (live_out_vregs:Bits.t array) = Array.init n_quads new_bitv in
let (quad_used_vrs:Bits.t array) = Array.init n_quads new_bitv in
let (quad_not_defined_vrs:Bits.t array) =
Array.init n_quads new_true_bitv
in
let (quad_uncond_jmp:bool array) = Array.make n_quads false in
let (quad_jmp_targs:(Il.label list) array) = Array.make n_quads [] in
(* Working bit-vector. *)
let scratch = new_bitv() in
let changed = ref true in
(* bit-vector helpers. *)
(* Setup pass. *)
for i = 0 to n_quads - 1 do
let q = quads.(i) in
quad_uncond_jmp.(i) <- quad_is_unconditional_jump q;
quad_jmp_targs.(i) <- quad_jump_target_labels q;
List.iter
(fun v -> Bits.set quad_used_vrs.(i) v true)
(quad_used_vregs q);
List.iter
(fun v -> Bits.set quad_not_defined_vrs.(i) v false)
(quad_defined_vregs q);
done;
while !changed do
changed := false;
iflog cx
(fun _ ->
log cx "iterating inner bitvector calculation over %d quads"
n_quads);
for i = n_quads - 1 downto 0 do
let note_change b = if b then changed := true in
let live_in = live_in_vregs.(i) in
let live_out = live_out_vregs.(i) in
let used = quad_used_vrs.(i) in
let not_defined = quad_not_defined_vrs.(i) in
(* Union in the vregs we use. *)
note_change (Bits.union live_in used);
(* Union in all our jump targets. *)
List.iter
(fun i -> note_change (Bits.union live_out live_in_vregs.(i)))
(quad_jmp_targs.(i));
(* Union in our block successor if we have one *)
if i < (n_quads - 1) && (not (quad_uncond_jmp.(i)))
then note_change (Bits.union live_out live_in_vregs.(i+1));
(* Propagate live-out to live-in on anything we don't define. *)
ignore (Bits.copy scratch not_defined);
ignore (Bits.intersect scratch live_out);
note_change (Bits.union live_in scratch);
done;
done;
iflog cx
begin
fun _ ->
log cx "finished calculating live bitvectors";
log cx "=========================";
for q = 0 to n_quads - 1 do
let buf = Buffer.create 128 in
for v = 0 to (n_vregs - 1)
do
if ((Bits.get live_in_vregs.(q) v)
&& (Bits.get live_out_vregs.(q) v))
then Printf.bprintf buf " %-2d" v
else Buffer.add_string buf " "
done;
log cx "[%6d] live vregs: %s" q (Buffer.contents buf)
done;
log cx "========================="
end;
(live_in_vregs, live_out_vregs)
;;
let is_end_of_basic_block (q:quad) : bool =
match q.Il.quad_body with
Il.Jmp _ -> true
| Il.Ret -> true
| _ -> false
;;
let is_beginning_of_basic_block (q:quad) : bool =
match q.Il.quad_fixup with
None -> false
| Some _ -> true
;;
let dump_quads cx =
let f = cx.ctxt_abi.Abi.abi_str_of_hardreg in
let len = (Array.length cx.ctxt_quads) - 1 in
let ndigits_of n = (int_of_float (log10 (float_of_int n))) in
let padded_num n maxnum =
let ndigits = ndigits_of n in
let maxdigits = ndigits_of maxnum in
let pad = String.make (maxdigits - ndigits) ' ' in
Printf.sprintf "%s%d" pad n
in
let padded_str str maxlen =
let pad = String.make (maxlen - (String.length str)) ' ' in
Printf.sprintf "%s%s" pad str
in
let maxlablen = ref 0 in
for i = 0 to len
do
let q = cx.ctxt_quads.(i) in
match q.quad_fixup with
None -> ()
| Some f ->
maxlablen := max (!maxlablen) ((String.length f.fixup_name) + 1)
done;
for i = 0 to len
do
let q = cx.ctxt_quads.(i) in
let qs = (string_of_quad f q) in
let lab = match q.quad_fixup with
None -> ""
| Some f -> f.fixup_name ^ ":"
in
iflog cx
(fun _ ->
log cx "[%s] %s %s"
(padded_num i len) (padded_str lab (!maxlablen)) qs)
done
;;
let calculate_vreg_constraints
(cx:ctxt)
(constraints:(Il.vreg,Bits.t) Hashtbl.t)
(q:quad)
: unit =
let abi = cx.ctxt_abi in
Hashtbl.clear constraints;
abi.Abi.abi_constrain_vregs q constraints;
iflog cx
begin
fun _ ->
let hr_str = cx.ctxt_abi.Abi.abi_str_of_hardreg in
log cx "constraints for quad %s"
(string_of_quad hr_str q);
let qp_reg _ r =
begin
match r with
Il.Hreg _ -> ()
| Il.Vreg v ->
match htab_search constraints v with
None -> log cx "<v%d> unconstrained" v
| Some c ->
let hregs = Bits.to_list c in
log cx "<v%d> constrained to hregs: [%s]"
v (list_to_str hregs hr_str)
end;
r
in
ignore (Il.process_quad { Il.identity_processor with
Il.qp_reg = qp_reg } q)
end
;;
(* Simple local register allocator. Nothing fancy. *)
let reg_alloc
(sess:Session.sess)
(quads:Il.quads)
(vregs:int)
(abi:Abi.abi) =
try
let cx = new_ctxt sess quads vregs abi in
let _ =
iflog cx
begin
fun _ ->
log cx "un-allocated quads:";
dump_quads cx
end
in
(* Work out pre-spilled slots and allocate 'em. *)
let spill_slot (s:Il.spill) = abi.Abi.abi_spill_slot s in
let n_pre_spills = convert_pre_spills cx spill_slot in
let (live_in_vregs, live_out_vregs) =
calculate_live_bitvectors cx
in
(* vreg idx -> hreg bits.t *)
let (vreg_constraints:(Il.vreg,Bits.t) Hashtbl.t) =
Hashtbl.create 0
in
let inactive_hregs = ref [] in (* [hreg] *)
let active_hregs = ref [] in (* [hreg] *)
let dirty_vregs = Hashtbl.create 0 in (* vreg -> () *)
let hreg_to_vreg = Hashtbl.create 0 in (* hreg -> vreg *)
let vreg_to_hreg = Hashtbl.create 0 in (* vreg -> hreg *)
let vreg_to_spill = Hashtbl.create 0 in (* vreg -> spill *)
let (word_ty:Il.scalar_ty) = Il.ValTy abi.Abi.abi_word_bits in
let vreg_spill_cell v =
Il.Mem ((spill_slot (Hashtbl.find vreg_to_spill v)),
Il.ScalarTy word_ty)
in
let newq = ref [] in
let fixup = ref None in
let prepend q =
newq := {q with quad_fixup = !fixup} :: (!newq);
fixup := None
in
let hr h = Il.Reg (Il.Hreg h, Il.voidptr_t) in
let hr_str = cx.ctxt_abi.Abi.abi_str_of_hardreg in
let clean_hreg i hreg =
if (Hashtbl.mem hreg_to_vreg hreg) &&
(hreg < cx.ctxt_abi.Abi.abi_n_hardregs)
then
let vreg = Hashtbl.find hreg_to_vreg hreg in
if Hashtbl.mem dirty_vregs vreg
then
begin
Hashtbl.remove dirty_vregs vreg;
if (Bits.get (live_out_vregs.(i)) vreg) ||
(Bits.get (live_in_vregs.(i)) vreg)
then
let spill_idx =
if Hashtbl.mem vreg_to_spill vreg
then Hashtbl.find vreg_to_spill vreg
else
begin
let s = next_spill cx in
Hashtbl.replace vreg_to_spill vreg s;
s
end
in
let spill_mem = spill_slot spill_idx in
let spill_cell = Il.Mem (spill_mem, Il.ScalarTy word_ty) in
iflog cx
(fun _ ->
log cx "spilling <%d> from %s to %s"
vreg (hr_str hreg) (string_of_mem
hr_str spill_mem));
prepend (Il.mk_quad
(Il.umov spill_cell (Il.Cell (hr hreg))));
else ()
end
else ()
else ()
in
let inactivate_hreg hreg =
if (Hashtbl.mem hreg_to_vreg hreg) &&
(hreg < cx.ctxt_abi.Abi.abi_n_hardregs)
then
let vreg = Hashtbl.find hreg_to_vreg hreg in
Hashtbl.remove vreg_to_hreg vreg;
Hashtbl.remove hreg_to_vreg hreg;
active_hregs := List.filter (fun x -> x != hreg) (!active_hregs);
inactive_hregs := hreg :: (!inactive_hregs);
else ()
in
let spill_specific_hreg i hreg =
clean_hreg i hreg;
inactivate_hreg hreg
in
let rec select_constrained
(constraints:Bits.t)
(hregs:Il.hreg list)
: Il.hreg option =
match hregs with
[] -> None
| h::hs ->
if Bits.get constraints h
then Some h
else select_constrained constraints hs
in
let spill_constrained constrs i =
match select_constrained constrs (!active_hregs) with
None ->
raise (Ra_error ("unable to spill according to constraint"));
| Some h ->
begin
spill_specific_hreg i h;
h
end
in
let all_hregs = Bits.create abi.Abi.abi_n_hardregs true in
let spill_all_regs i =
while (!active_hregs) != []
do
let _ = spill_constrained all_hregs i in
()
done
in
let reload vreg hreg =
if Hashtbl.mem vreg_to_spill vreg
then
prepend (Il.mk_quad
(Il.umov
(hr hreg)
(Il.Cell (vreg_spill_cell vreg))))
else ()
in
let get_vreg_constraints v =
match htab_search vreg_constraints v with
None -> all_hregs
| Some c -> c
in
let use_vreg def i vreg =
if Hashtbl.mem vreg_to_hreg vreg
then
begin
let h = Hashtbl.find vreg_to_hreg vreg in
iflog cx (fun _ -> log cx "found cached assignment %s for <v%d>"
(hr_str h) vreg);
h
end
else
let hreg =
let constrs = get_vreg_constraints vreg in
match select_constrained constrs (!inactive_hregs) with
None ->
let h = spill_constrained constrs i in
iflog cx
(fun _ ->
log cx "selected %s to spill and use for <v%d>"
(hr_str h) vreg);
h
| Some h ->
iflog cx (fun _ -> log cx "selected inactive %s for <v%d>"
(hr_str h) vreg);
h
in
inactive_hregs :=
List.filter (fun x -> x != hreg) (!inactive_hregs);
active_hregs := (!active_hregs) @ [hreg];
Hashtbl.replace hreg_to_vreg hreg vreg;
Hashtbl.replace vreg_to_hreg vreg hreg;
if def
then ()
else
reload vreg hreg;
hreg
in
let qp_reg def i _ r =
match r with
Il.Hreg h -> (spill_specific_hreg i h; r)
| Il.Vreg v -> (Il.Hreg (use_vreg def i v))
in
let qp_cell def i qp c =
match c with
Il.Reg (r, b) -> Il.Reg (qp_reg def i qp r, b)
| Il.Mem (a, b) ->
let qp = { qp with Il.qp_reg = qp_reg false i } in
Il.Mem (qp.qp_mem qp a, b)
in
let qp i = { Il.identity_processor with
Il.qp_cell_read = qp_cell false i;
Il.qp_cell_write = qp_cell true i;
Il.qp_reg = qp_reg false i }
in
cx.ctxt_next_spill <- n_pre_spills;
convert_labels cx;
for i = 0 to cx.ctxt_abi.Abi.abi_n_hardregs - 1
do
inactive_hregs := i :: (!inactive_hregs)
done;
for i = 0 to (Array.length cx.ctxt_quads) - 1
do
let quad = cx.ctxt_quads.(i) in
let _ = calculate_vreg_constraints cx vreg_constraints quad in
let clobbers = cx.ctxt_abi.Abi.abi_clobbers quad in
let used = quad_used_vregs quad in
let defined = quad_defined_vregs quad in
begin
(* If the quad has any nontrivial vreg constraints, regfence.
* This is awful but it saves us from cached/constrained
* interference as was found in issue #152. *)
if List.exists
(fun v -> not (Bits.equal (get_vreg_constraints v) all_hregs))
used
then
begin
(* Regfence. *)
spill_all_regs i;
(* Check for over-constrained-ness after any such regfence. *)
let vreg_constrs v =
(v, Bits.to_list (get_vreg_constraints v))
in
let constrs = List.map vreg_constrs (used @ defined) in
let constrs_collide (v1,c1) =
if List.length c1 <> 1
then false
else
List.exists
(fun (v2,c2) -> if v1 = v2 then false else c1 = c2)
constrs
in
if List.exists constrs_collide constrs
then raise (Ra_error ("over-constrained vregs"));
end;
if List.exists (fun def -> List.mem def clobbers) defined
then raise (Ra_error ("clobber and defined sets overlap"));
iflog cx
begin
fun _ ->
let hr (v:int) : string =
if Hashtbl.mem vreg_to_hreg v
then hr_str (Hashtbl.find vreg_to_hreg v)
else "??"
in
let vr_str (v:int) : string =
Printf.sprintf "v%d=%s" v (hr v)
in
let lstr lab ls fn =
if List.length ls = 0
then ()
else log cx "\t%s: [%s]" lab (list_to_str ls fn)
in
log cx "processing quad %d = %s"
i (string_of_quad hr_str quad);
(lstr "dirt" (htab_keys dirty_vregs) vr_str);
(lstr "clob" clobbers hr_str);
(lstr "in" (Bits.to_list live_in_vregs.(i)) vr_str);
(lstr "out" (Bits.to_list live_out_vregs.(i)) vr_str);
(lstr "use" used vr_str);
(lstr "def" defined vr_str);
end;
List.iter (clean_hreg i) clobbers;
if is_beginning_of_basic_block quad
then
begin
spill_all_regs i;
fixup := quad.quad_fixup;
prepend (Il.process_quad (qp i) quad)
end
else
begin
fixup := quad.quad_fixup;
let newq = (Il.process_quad (qp i) quad) in
begin
if is_end_of_basic_block quad
then spill_all_regs i
else ()
end;
prepend newq
end
end;
List.iter inactivate_hreg clobbers;
List.iter (fun i -> Hashtbl.replace dirty_vregs i ()) defined;
done;
cx.ctxt_quads <- Array.of_list (List.rev (!newq));
kill_redundant_moves cx;
iflog cx
begin
fun _ ->
log cx "spills: %d pre-spilled, %d total"
n_pre_spills cx.ctxt_next_spill;
log cx "register-allocated quads:";
dump_quads cx;
end;
(cx.ctxt_quads, cx.ctxt_next_spill)
with
Ra_error s ->
Session.fail sess "RA error: %s\n" s;
(quads, 0)
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

2582
src/boot/be/x86.ml
View File

File diff suppressed because it is too large Load Diff

16
src/boot/driver/glue.ml
View File

@ -1,16 +0,0 @@
(*
* Glue, or lack thereof, for the standard x86 backend.
*)
let alt_argspecs _ = [];;
let alt_pipeline _ _ _ = ();;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

464
src/boot/driver/lib.ml
View File

@ -1,464 +0,0 @@
open Common;;
open Fmt;;
let log (sess:Session.sess) =
Session.log "lib"
sess.Session.sess_log_lib
sess.Session.sess_log_out
;;
let iflog (sess:Session.sess) (thunk:(unit -> unit)) : unit =
if sess.Session.sess_log_lib
then thunk ()
else ()
;;
(*
* Stuff associated with 'crate interfaces'.
*
* The interface of a crate used to be defined by the accompanying DWARF
* structure in the object file. This was an experiment -- we talked to
* DWARF hackers before hand and they thought it worth trying -- which did
* work, and had the advantage of economy of metadata-emitting, but several
* downsides:
*
* - The reader -- which we want a copy of at runtime in the linker -- has
* to know how to read DWARF. It's not the simplest format.
*
* - The complexity of the encoding meant we didn't always keep pace with
* the AST, and maintaining any degree of inter-change compatibility was
* going ot be a serious challenge.
*
* - Diagnostic tools are atrocious, as is the definition of
* well-formedness. It's largely trial and error when talking to gdb,
* say.
*
* - Because it was doing double-duty as *driving linkage*, we were never
* going to get to the linkage efficiency of native symbols (hash
* lookup) anyway. Runtime linkage -- even when lazy -- really ought to
* be fast.
*
* - LLVM, our "main" backend (in rustc) does not really want to make
* promises about preserving dwarf.
*
* - LLVM also *is* going to emit native symbols; complete with relocs and
* such. We'd actually have to do *extra work* to inhibit that.
*
* - Most tools are set up to think of DWARF as "debug", meaning
* "optional", and may well strip it or otherwise mangle it.
*
* - Many tools want native symbols anyways, and don't know how to look at
* DWARF.
*
* - All the tooling arguments go double on win32. Pretty much only
* objdump and gdb understand DWARF-in-PE. Everything else is just blank
* stares.
*
* For all these reasons we're moving to a self-made format for describing
* our interfaces. This will be stored in the .note.rust section as we
* presently store the meta tags. The encoding is ASCII-compatible (the set
* of "numbers" to encode is small enough, especially compared to dwarf,
* that we can just use a text form) and is very easy to read with a simple
* byte-at-a-time parser.
*
*)
(*
* Encoding goals:
*
* - Simple. Minimal state or read-ambiguity in reader.
*
* - Compact. Shouldn't add a lot to the size of the binary to glue this
* on to it.
*
* - Front-end-y. Doesn't need to contain much beyond parse-level of the
* crate's exported items; it'll be fed into the front-end of the
* pipeline anyway. No need to have all types or names resolved.
*
* - Testable. Human-legible and easy to identify/fix/test errors in.
*
* - Very fast to read the 'identifying' prefix (version, meta tags, hash)
*
* - Tolerably fast to read in its entirety.
*
* - Safe from version-drift (or at least able to notice it and abort).
*
* Anti-goals:
*
* - Random access.
*
* - Generality to other languages.
*
* Structure:
*
* - Line oriented.
*
* - Whitespace-separated and whitespace-agnostic. Indent for legibility.
*
* - Each line is a record. A record is either a full item, an item bracket,
* a comment, or metadata.
*
* - First byte describes type of record, unless first byte is +, in which
* case it's oh-no-we-ran-out-of-tags and it's followed by 2 type-bytes.
* (Continue to +++ if you happen to run out *there* as well. You
* won't.)
*
* - Metadata type is !
*
* - Comment type is #
*
* - Full item types are: y for type, c for const, f for fn, i for iter,
* g for tag constructor.
*
* - Item brackets are those that open/close a scope of
* sub-records. These would be obj (o), mod (m), tag (t) to open. The
* closer is always '.'. So a mod looks like:
*
* m foo
* c bar
* .
*
* - After first byte of openers and full items is whitespace, then an
* ident.
*
* - After that, if it's a ty, fn, iter, obj or tag, there may be [, a
* list of comma-separated ty param names, and ].
*
* - After that, if it's a fn, iter, obj or tag constructor, there is a (,
* a list of comma-separated type-encoded slot/ident pairs, and a ).
*
* - After that, if it's a fn or iter, there's a '->' and a type-encoded
* output.
*
* - After that, a newline '\n'.
*
* - Type encoding is a longer issue! We'll get to that.
*)
let fmt_iface (ff:Format.formatter) (crate:Ast.crate) : unit =
let fmt_ty_param ff (p:Ast.ty_param identified) : unit =
fmt ff "%s" (fst p.node)
in
let rec fmt_ty ff (t:Ast.ty) : unit =
match t with
Ast.TY_any -> fmt ff "a"
| Ast.TY_nil -> fmt ff "n"
| Ast.TY_bool -> fmt ff "b"
| Ast.TY_mach tm -> fmt ff "%s" (string_of_ty_mach tm)
| Ast.TY_int -> fmt ff "i"
| Ast.TY_uint -> fmt ff "u"
| Ast.TY_char -> fmt ff "c"
| Ast.TY_str -> fmt ff "s"
| Ast.TY_tup ttup ->
fmt_bracketed_arr_sep "(" ")" ","
fmt_ty ff ttup
| Ast.TY_vec ty ->
fmt ff "v["; fmt_ty ff ty; fmt ff "]"
| Ast.TY_chan ty ->
fmt ff "C["; fmt_ty ff ty; fmt ff "]"
| Ast.TY_port ty ->
fmt ff "P["; fmt_ty ff ty; fmt ff "]"
| Ast.TY_task ->
fmt ff "T"
| Ast.TY_named n -> fmt ff ":"; fmt_name ff n
| Ast.TY_type -> fmt ff "Y"
| Ast.TY_box t -> fmt ff "@@"; fmt_ty ff t
| Ast.TY_mutable t -> fmt ff "~"; fmt_ty ff t
(* FIXME: finish this. *)
| Ast.TY_rec _
| Ast.TY_tag _
| Ast.TY_fn _
| Ast.TY_obj _
| Ast.TY_native _
| Ast.TY_param _
| Ast.TY_constrained _ -> fmt ff "Z"
and fmt_name ff n =
match n with
Ast.NAME_base (Ast.BASE_ident id) -> fmt ff "%s" id
| Ast.NAME_base (Ast.BASE_temp _) -> failwith "temp in fmt_name"
| Ast.NAME_base (Ast.BASE_app (id, tys)) ->
fmt ff "%s" id;
fmt_bracketed_arr_sep "[" "]" ","
fmt_ty ff tys;
| Ast.NAME_ext (n, Ast.COMP_ident id) ->
fmt_name ff n;
fmt ff ".%s" id
| Ast.NAME_ext (n, Ast.COMP_app (id, tys)) ->
fmt_name ff n;
fmt ff ".%s" id;
fmt_bracketed_arr_sep "[" "]" ","
fmt_ty ff tys;
| Ast.NAME_ext (n, Ast.COMP_idx i) ->
fmt_name ff n;
fmt ff "._%d" i
in
let rec fmt_mod_item (id:Ast.ident) (mi:Ast.mod_item) : unit =
let i c = fmt ff "@\n%c %s" c id in
let o c = fmt ff "@\n"; fmt_obox ff; fmt ff "%c %s" c id in
let p _ =
if (Array.length mi.node.Ast.decl_params) <> 0
then
fmt_bracketed_arr_sep "[" "]" ","
fmt_ty_param ff mi.node.Ast.decl_params
in
let c _ = fmt_cbox ff; fmt ff "@\n." in
match mi.node.Ast.decl_item with
Ast.MOD_ITEM_type _ -> i 'y'; p()
| Ast.MOD_ITEM_tag _ -> i 'g'; p()
| Ast.MOD_ITEM_fn _ -> i 'f'; p();
| Ast.MOD_ITEM_const _ -> i 'c'
| Ast.MOD_ITEM_obj _ ->
o 'o'; p();
c ()
| Ast.MOD_ITEM_mod (_, items) ->
o 'm';
fmt_mod_items items;
c ()
and fmt_mod_items items =
sorted_htab_iter fmt_mod_item items
in
let (_,items) = crate.node.Ast.crate_items in
fmt_mod_items items
;;
(* Mechanisms for scanning libraries. *)
(* FIXME (issue #67): move these to sess. *)
let ar_cache = Hashtbl.create 0 ;;
let sects_cache = Hashtbl.create 0;;
let meta_cache = Hashtbl.create 0;;
let die_cache = Hashtbl.create 0;;
let get_ar
(sess:Session.sess)
(filename:filename)
: Asm.asm_reader option =
htab_search_or_add ar_cache filename
begin
fun _ ->
let sniff =
match sess.Session.sess_targ with
Win32_x86_pe -> Pe.sniff
| MacOS_x86_macho -> Macho.sniff
| Linux_x86_elf -> Elf.sniff
| FreeBSD_x86_elf -> Elf.sniff
in
sniff sess filename
end
;;
let get_sects
(sess:Session.sess)
(filename:filename) :
(Asm.asm_reader * ((string,(int*int)) Hashtbl.t)) option =
htab_search_or_add sects_cache filename
begin
fun _ ->
match get_ar sess filename with
None -> None
| Some ar ->
let get_sections =
match sess.Session.sess_targ with
Win32_x86_pe -> Pe.get_sections
| MacOS_x86_macho -> Macho.get_sections
| Linux_x86_elf -> Elf.get_sections
| FreeBSD_x86_elf -> Elf.get_sections
in
Some (ar, (get_sections sess ar))
end
;;
let get_meta
(sess:Session.sess)
(filename:filename)
: Session.meta option =
htab_search_or_add meta_cache filename
begin
fun _ ->
match get_sects sess filename with
None -> None
| Some (ar, sects) ->
match htab_search sects ".note.rust" with
Some (off, _) ->
ar.Asm.asm_seek off;
Some (Asm.read_rust_note ar)
| None -> None
end
;;
let get_dies_opt
(sess:Session.sess)
(filename:filename)
: (Dwarf.rooted_dies option) =
htab_search_or_add die_cache filename
begin
fun _ ->
match get_sects sess filename with
None -> None
| Some (ar, sects) ->
let debug_abbrev = Hashtbl.find sects ".debug_abbrev" in
let debug_info = Hashtbl.find sects ".debug_info" in
let abbrevs = Dwarf.read_abbrevs sess ar debug_abbrev in
let dies = Dwarf.read_dies sess ar debug_info abbrevs in
ar.Asm.asm_close ();
Hashtbl.remove ar_cache filename;
Some dies
end
;;
let get_dies
(sess:Session.sess)
(filename:filename)
: Dwarf.rooted_dies =
match get_dies_opt sess filename with
None ->
Printf.fprintf stderr "Error: bad crate file: %s\n%!" filename;
exit 1
| Some dies -> dies
;;
let get_file_mod
(sess:Session.sess)
(abi:Abi.abi)
(filename:filename)
: Ast.mod_items =
let dies = get_dies sess filename in
let items = Hashtbl.create 0 in
let nref = sess.Session.sess_node_id_counter in
let oref = sess.Session.sess_opaque_id_counter in
Dwarf.extract_mod_items nref oref abi items dies;
items
;;
let get_mod
(sess:Session.sess)
(abi:Abi.abi)
(meta:Ast.meta_pat)
(use_id:node_id)
(crate_item_cache:(crate_id, Ast.mod_items) Hashtbl.t)
: (filename * Ast.mod_items) =
let found = Queue.create () in
let suffix =
match sess.Session.sess_targ with
Win32_x86_pe -> ".dll"
| MacOS_x86_macho -> ".dylib"
| Linux_x86_elf -> ".so"
| FreeBSD_x86_elf -> ".so"
in
let rec meta_matches i f_meta =
if i >= (Array.length meta)
then true
else
match meta.(i) with
(* FIXME (issue #68): bind the wildcards. *)
(_, None) -> meta_matches (i+1) f_meta
| (k, Some v) ->
match atab_search f_meta k with
None -> false
| Some v' ->
if v = v'
then meta_matches (i+1) f_meta
else false
in
let file_matches file =
log sess "searching for metadata in %s" file;
match get_meta sess file with
None -> false
| Some f_meta ->
log sess "matching metadata in %s" file;
meta_matches 0 f_meta
in
iflog sess
begin
fun _ ->
log sess "searching for library matching:";
Array.iter
begin
fun (k,vo) ->
match vo with
None -> ()
| Some v ->
log sess "%s = %S" k v
end
meta;
end;
Queue.iter
begin
fun dir ->
let dh = Unix.opendir dir in
let rec scan _ =
try
let basename = Unix.readdir dh in
let file = dir ^ "/" ^ basename in
log sess "considering file %s" file;
if (Filename.check_suffix file suffix) &&
(file_matches file)
then
begin
log sess "matched against library %s" file;
let meta = get_meta sess file in
let crate_id =
match meta with
None -> Session.make_crate_id sess
| Some meta ->
iflog sess begin fun _ ->
Array.iter
(fun (k, v) -> log sess "%s = %S" k v)
meta
end;
htab_search_or_default
sess.Session.sess_crate_meta
meta
(fun () -> Session.make_crate_id sess)
in
Queue.add (file, crate_id) found;
end;
scan()
with
End_of_file -> ()
in
scan ()
end
sess.Session.sess_lib_dirs;
match Queue.length found with
0 -> Common.err (Some use_id) "unsatisfied 'use' clause"
| 1 ->
let (filename, crate_id) = Queue.pop found in
let items =
htab_search_or_default crate_item_cache crate_id
(fun () -> get_file_mod sess abi filename)
in
(filename, items)
| _ -> Common.err (Some use_id) "multiple crates match 'use' clause"
;;
let infer_lib_name
(sess:Session.sess)
(ident:filename)
: filename =
match sess.Session.sess_targ with
Win32_x86_pe -> ident ^ ".dll"
| MacOS_x86_macho -> "lib" ^ ident ^ ".dylib"
| Linux_x86_elf -> "lib" ^ ident ^ ".so"
| FreeBSD_x86_elf -> "lib" ^ ident ^ ".so"
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

530
src/boot/driver/main.ml
View File

@ -1,530 +0,0 @@
open Common;;
let (targ:Common.target) =
match Sys.os_type with
| "Win32"
| "Cygwin" -> Win32_x86_pe
| "Unix"
when Unix.system "test `uname -s` = 'Linux'" = Unix.WEXITED 0 ->
Linux_x86_elf
| "Unix"
when Unix.system "test `uname -s` = 'Darwin'" = Unix.WEXITED 0 ->
MacOS_x86_macho
| "Unix"
when Unix.system "test `uname -s` = 'FreeBSD'" = Unix.WEXITED 0 ->
FreeBSD_x86_elf
| _ ->
Linux_x86_elf
;;
let (abi:Abi.abi) = X86.abi;;
let (sess:Session.sess) =
{
Session.sess_in = None;
Session.sess_out = None;
Session.sess_library_mode = false;
Session.sess_alt_backend = false;
Session.sess_minimal = false;
Session.sess_use_pexps = false;
(* FIXME (issue #69): need something fancier here for unix
* sub-flavours.
*)
Session.sess_targ = targ;
Session.sess_log_lex = false;
Session.sess_log_parse = false;
Session.sess_log_ast = false;
Session.sess_log_sig = false;
Session.sess_log_passes = false;
Session.sess_log_resolve = false;
Session.sess_log_type = false;
Session.sess_log_simplify = false;
Session.sess_log_layer = false;
Session.sess_log_typestate = false;
Session.sess_log_loop = false;
Session.sess_log_alias = false;
Session.sess_log_dead = false;
Session.sess_log_layout = false;
Session.sess_log_itype = false;
Session.sess_log_trans = false;
Session.sess_log_dwarf = false;
Session.sess_log_ra = false;
Session.sess_log_insn = false;
Session.sess_log_asm = false;
Session.sess_log_obj = false;
Session.sess_log_lib = false;
Session.sess_log_path = None;
Session.sess_log_out = stdout;
Session.sess_log_err = stderr;
Session.sess_trace_block = false;
Session.sess_trace_drop = false;
Session.sess_trace_tag = false;
Session.sess_trace_gc = false;
Session.sess_failed = false;
Session.sess_spans = Hashtbl.create 0;
Session.sess_report_timing = false;
Session.sess_report_quads = false;
Session.sess_report_gc = false;
Session.sess_report_deps = false;
Session.sess_next_crate_id = 0;
Session.sess_fuzz_item_count = 5;
Session.sess_timings = Hashtbl.create 0;
Session.sess_quad_counts = Hashtbl.create 0;
Session.sess_lib_dirs = Queue.create ();
Session.sess_crate_meta = Hashtbl.create 0;
Session.sess_node_id_counter = ref (Node 0);
Session.sess_opaque_id_counter = ref (Opaque 0);
Session.sess_temp_id_counter = ref (Temp 0);
}
;;
let exit_if_failed _ =
if sess.Session.sess_failed
then exit 1
else ()
;;
let default_output_filename (sess:Session.sess) : filename option =
match sess.Session.sess_in with
None -> None
| Some fname ->
let base = Filename.chop_extension (Filename.basename fname) in
let out =
if sess.Session.sess_library_mode
then
Lib.infer_lib_name sess base
else
base ^ (match sess.Session.sess_targ with
Linux_x86_elf -> ""
| FreeBSD_x86_elf -> ""
| MacOS_x86_macho -> ""
| Win32_x86_pe -> ".exe")
in
Some out
;;
let set_default_output_filename (sess:Session.sess) : unit =
match sess.Session.sess_out with
None -> (sess.Session.sess_out <- default_output_filename sess)
| _ -> ()
;;
let dump_sig (filename:filename) : unit =
let items =
Lib.get_file_mod sess abi filename in
Printf.fprintf stdout "%s\n" (Fmt.fmt_to_str Ast.fmt_mod_items items);
exit_if_failed ();
exit 0
;;
let dump_meta (filename:filename) : unit =
begin
match Lib.get_meta sess filename with
None -> Printf.fprintf stderr "Error: bad crate file: %s\n" filename
| Some meta ->
Array.iter
begin
fun (k,v) ->
Printf.fprintf stdout "%s = %S\n" k v;
end
meta
end;
exit 0
;;
let print_version _ =
Printf.fprintf stdout "rustboot %s\n" Version.version;
exit 0;
;;
let flag f opt desc =
(opt, Arg.Unit f, desc)
;;
let argspecs =
[
("-t", Arg.Symbol (["linux-x86-elf";
"win32-x86-pe";
"macos-x86-macho";
"freebsd-x86-elf"],
fun s -> (sess.Session.sess_targ <-
(match s with
"win32-x86-pe" -> Win32_x86_pe
| "macos-x86-macho" -> MacOS_x86_macho
| "freebsd-x86-elf" -> FreeBSD_x86_elf
| _ -> Linux_x86_elf))),
(" target (default: " ^ (match sess.Session.sess_targ with
Win32_x86_pe -> "win32-x86-pe"
| Linux_x86_elf -> "linux-x86-elf"
| MacOS_x86_macho -> "macos-x86-macho"
| FreeBSD_x86_elf -> "freebsd-x86-elf"
) ^ ")"));
("-o", Arg.String (fun s -> sess.Session.sess_out <- Some s),
"file to output (default: "
^ (Session.filename_of sess.Session.sess_out) ^ ")");
("-shared", Arg.Unit (fun _ -> sess.Session.sess_library_mode <- true),
"compile a shared-library crate");
("-L", Arg.String (fun s -> Queue.add s sess.Session.sess_lib_dirs),
"dir to add to library path");
("-litype", Arg.Unit (fun _ -> sess.Session.sess_log_itype <- true;
Il.log_iltypes := true), "log IL types");
(flag (fun _ -> sess.Session.sess_log_lex <- true)
"-llex" "log lexing");
(flag (fun _ -> sess.Session.sess_log_parse <- true)
"-lparse" "log parsing");
(flag (fun _ -> sess.Session.sess_log_ast <- true)
"-last" "log AST");
(flag (fun _ -> sess.Session.sess_log_sig <- true)
"-lsig" "log signature");
(flag (fun _ -> sess.Session.sess_log_passes <- true)
"-lpasses" "log passes at high-level");
(flag (fun _ -> sess.Session.sess_log_resolve <- true)
"-lresolve" "log resolution");
(flag (fun _ -> sess.Session.sess_log_type <- true)
"-ltype" "log type checking");
(flag (fun _ -> sess.Session.sess_log_simplify <- true)
"-lsimplify" "log simplification");
(flag (fun _ -> sess.Session.sess_log_layer <- true)
"-llayer" "log layer checking");
(flag (fun _ -> sess.Session.sess_log_typestate <- true)
"-ltypestate" "log typestate pass");
(flag (fun _ -> sess.Session.sess_log_loop <- true)
"-lloop" "log loop analysis");
(flag (fun _ -> sess.Session.sess_log_alias <- true)
"-lalias" "log alias analysis");
(flag (fun _ -> sess.Session.sess_log_dead <- true)
"-ldead" "log dead analysis");
(flag (fun _ -> sess.Session.sess_log_layout <- true)
"-llayout" "log frame layout");
(flag (fun _ -> sess.Session.sess_log_trans <- true)
"-ltrans" "log IR translation");
(flag (fun _ -> sess.Session.sess_log_dwarf <- true)
"-ldwarf" "log DWARF generation");
(flag (fun _ -> sess.Session.sess_log_ra <- true)
"-lra" "log register allocation");
(flag (fun _ -> sess.Session.sess_log_insn <- true)
"-linsn" "log instruction selection");
(flag (fun _ -> sess.Session.sess_log_asm <- true)
"-lasm" "log assembly");
(flag (fun _ -> sess.Session.sess_log_obj <- true)
"-lobj" "log object-file generation");
(flag (fun _ -> sess.Session.sess_log_lib <- true)
"-llib" "log library search");
("-lpath", Arg.String
(fun s -> sess.Session.sess_log_path <- Some (split_string '.' s)),
"module path to restrict logging to");
(flag (fun _ -> sess.Session.sess_trace_block <- true)
"-tblock" "emit block-boundary tracing code");
(flag (fun _ -> sess.Session.sess_trace_drop <- true)
"-tdrop" "emit slot-drop tracing code");
(flag (fun _ -> sess.Session.sess_trace_tag <- true)
"-ttag" "emit tag-construction tracing code");
(flag (fun _ -> sess.Session.sess_trace_gc <- true)
"-tgc" "emit GC tracing code");
("-tall", Arg.Unit (fun _ ->
sess.Session.sess_trace_block <- true;
sess.Session.sess_trace_drop <- true;
sess.Session.sess_trace_tag <- true ),
"emit all tracing code");
(flag (fun _ -> sess.Session.sess_report_timing <- true)
"-rtime" "report timing of compiler phases");
(flag (fun _ -> sess.Session.sess_report_quads <- true)
"-rquads" "report categories of quad emitted");
(flag (fun _ -> sess.Session.sess_report_gc <- true)
"-rgc" "report gc behavior of compiler");
("-rsig", Arg.String dump_sig,
"report type-signature from DWARF info in compiled file, then exit");
("-rmeta", Arg.String dump_meta,
"report metadata from DWARF info in compiled file, then exit");
("-rdeps", Arg.Unit (fun _ -> sess.Session.sess_report_deps <- true),
"report dependencies of input, then exit");
("-version", Arg.Unit (fun _ -> print_version()),
"print version information, then exit");
(flag (fun _ -> sess.Session.sess_use_pexps <- true)
"-pexp" "use pexp portion of AST");
(flag (fun _ -> sess.Session.sess_minimal <- true)
"-minimal" ("reduce code size by disabling various features"
^ " (use at own risk)"));
("-zc", Arg.Int (fun i -> sess.Session.sess_fuzz_item_count <- i),
"count of items to generate when fuzzing");
("-zs", Arg.Int (fun i -> Fuzz.fuzz (Some i) sess),
"run fuzzer with given seed");
(flag (fun _ -> Fuzz.fuzz None sess)
"-z" "run fuzzer with random seed")
] @ (Glue.alt_argspecs sess)
;;
Arg.parse
argspecs
(fun arg -> sess.Session.sess_in <- (Some arg))
("usage: " ^ Sys.argv.(0) ^ " [options] (CRATE_FILE.rc|SOURCE_FILE.rs)\n")
;;
let _ = set_default_output_filename sess
;;
let _ =
if sess.Session.sess_out = None
then (Printf.fprintf stderr "Error: no output file specified\n"; exit 1)
else ()
;;
let _ =
if sess.Session.sess_in = None
then (Printf.fprintf stderr "Error: empty input filename\n"; exit 1)
else ()
;;
let parse_input_crate
(crate_cache:(crate_id, Ast.mod_items) Hashtbl.t)
: Ast.crate =
Session.time_inner "parse" sess
begin
fun _ ->
let infile = Session.filename_of sess.Session.sess_in in
let crate =
if Filename.check_suffix infile ".rc"
then
Cexp.parse_crate_file sess
(Lib.get_mod sess abi)
(Lib.infer_lib_name sess)
crate_cache
else
if Filename.check_suffix infile ".rs"
then
Cexp.parse_src_file sess
(Lib.get_mod sess abi)
(Lib.infer_lib_name sess)
crate_cache
else
begin
Printf.fprintf stderr
"Error: unrecognized input file type: %s\n"
infile;
exit 1
end
in
exit_if_failed();
if sess.Session.sess_report_deps
then
let outfile = (Session.filename_of sess.Session.sess_out) in
let depfile =
match sess.Session.sess_targ with
Linux_x86_elf
| FreeBSD_x86_elf
| MacOS_x86_macho -> outfile ^ ".d"
| Win32_x86_pe -> (Filename.chop_extension outfile) ^ ".d"
in
begin
Array.iter
begin
fun out ->
Printf.fprintf stdout "%s: \\\n" out;
Hashtbl.iter
(fun _ file ->
Printf.fprintf stdout " %s \\\n" file)
crate.node.Ast.crate_files;
Printf.fprintf stdout "\n"
end
[| outfile; depfile|];
exit 0
end
else
crate
end
;;
let (crate:Ast.crate) =
try
let crate_cache = Hashtbl.create 1 in
parse_input_crate crate_cache
with
Not_implemented (ido, str) ->
Session.report_err sess ido str;
{ node = Ast.empty_crate'; id = Common.Node 0 }
;;
exit_if_failed ()
;;
if sess.Session.sess_log_ast
then
begin
Printf.fprintf stdout "Post-parse AST:\n";
Format.set_margin 80;
Printf.fprintf stdout "%s\n" (Fmt.fmt_to_str Ast.fmt_crate crate)
end
;;
if sess.Session.sess_log_sig
then
begin
Printf.fprintf stdout "Post-parse signature:\n";
Format.set_margin 80;
Printf.fprintf stdout "%s\n" (Fmt.fmt_to_str Lib.fmt_iface crate);
end
;;
let list_to_seq ls = Asm.SEQ (Array.of_list ls);;
let select_insns (quads:Il.quads) : Asm.frag =
Session.time_inner "insn" sess
(fun _ -> X86.select_insns sess quads)
;;
(* Semantic passes. *)
let sem_cx = Semant.new_ctxt sess abi crate.node
;;
let main_pipeline _ =
let _ =
Array.iter
(fun proc ->
proc sem_cx crate;
exit_if_failed ())
[| Resolve.process_crate;
Simplify.process_crate;
Type.process_crate;
Typestate.process_crate;
Layer.process_crate;
Loop.process_crate;
Alias.process_crate;
Dead.process_crate;
Layout.process_crate;
Trans.process_crate |]
in
(* Tying up various knots, allocating registers and selecting
* instructions.
*)
let process_code _ (code:Semant.code) : Asm.frag =
let frag =
match code.Semant.code_vregs_and_spill with
None ->
X86.log sess "selecting insns for %s"
code.Semant.code_fixup.fixup_name;
select_insns code.Semant.code_quads
| Some (n_vregs, spill_fix) ->
let (quads', n_spills) =
(Session.time_inner "RA" sess
(fun _ ->
Ra.reg_alloc sess
code.Semant.code_quads
n_vregs abi))
in
let _ =
X86.log sess "selecting insns for %s"
code.Semant.code_fixup.fixup_name
in
let insns = select_insns quads' in
begin
spill_fix.fixup_mem_sz <-
Some (Int64.mul
(Int64.of_int n_spills)
abi.Abi.abi_word_sz);
insns
end
in
Asm.ALIGN_FILE (Abi.general_code_alignment,
Asm.DEF (code.Semant.code_fixup, frag))
in
let (file_frags:Asm.frag) =
let process_file file_id frag_code =
let file_fix = Hashtbl.find sem_cx.Semant.ctxt_file_fixups file_id in
Asm.DEF (file_fix,
list_to_seq (reduce_hash_to_list process_code frag_code))
in
list_to_seq (reduce_hash_to_list
process_file sem_cx.Semant.ctxt_file_code)
in
exit_if_failed ();
let (glue_frags:Asm.frag) =
list_to_seq (reduce_hash_to_list
process_code sem_cx.Semant.ctxt_glue_code)
in
exit_if_failed ();
let code = Asm.SEQ [| file_frags; glue_frags |] in
let data = list_to_seq (reduce_hash_to_list
(fun _ (_, i) -> i) sem_cx.Semant.ctxt_data)
in
(* Emitting Dwarf and PE/ELF/Macho. *)
let (dwarf:Dwarf.debug_records) =
Session.time_inner "dwarf" sess
(fun _ -> Dwarf.process_crate sem_cx crate)
in
exit_if_failed ();
let emitter =
match sess.Session.sess_targ with
Win32_x86_pe -> Pe.emit_file
| MacOS_x86_macho -> Macho.emit_file
| Linux_x86_elf -> Elf.emit_file
| FreeBSD_x86_elf -> Elf.emit_file
in
Session.time_inner "emit" sess
(fun _ -> emitter sess crate code data sem_cx dwarf);
exit_if_failed ()
;;
try
if sess.Session.sess_alt_backend
then Glue.alt_pipeline sess sem_cx crate
else main_pipeline ()
with
Not_implemented (ido, str) ->
Session.report_err sess ido str
;;
exit_if_failed ()
;;
if sess.Session.sess_report_timing
then
begin
let cumulative = ref 0.0 in
Printf.fprintf stdout "timing:\n\n";
Array.iter
begin
fun name ->
let t = Hashtbl.find sess.Session.sess_timings name in
Printf.fprintf stdout "%20s: %f\n" name t;
cumulative := (!cumulative) +. t
end
(sorted_htab_keys sess.Session.sess_timings);
Printf.fprintf stdout "\n%20s: %f\n" "cumulative" (!cumulative)
end;
;;
if sess.Session.sess_report_gc
then Gc.print_stat stdout;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

149
src/boot/driver/session.ml
View File

@ -1,149 +0,0 @@
(*
* This module goes near the bottom of the dependency DAG, and holds option,
* and global-state machinery for a single run of the compiler.
*)
open Common;;
type meta = (string * string) array;;
type sess =
{
mutable sess_in: filename option;
mutable sess_out: filename option;
mutable sess_library_mode: bool;
mutable sess_alt_backend: bool;
mutable sess_minimal: bool;
mutable sess_use_pexps: bool;
mutable sess_targ: target;
mutable sess_log_lex: bool;
mutable sess_log_parse: bool;
mutable sess_log_ast: bool;
mutable sess_log_sig: bool;
mutable sess_log_passes: bool;
mutable sess_log_resolve: bool;
mutable sess_log_type: bool;
mutable sess_log_simplify: bool;
mutable sess_log_layer: bool;
mutable sess_log_typestate: bool;
mutable sess_log_dead: bool;
mutable sess_log_loop: bool;
mutable sess_log_alias: bool;
mutable sess_log_layout: bool;
mutable sess_log_trans: bool;
mutable sess_log_itype: bool;
mutable sess_log_dwarf: bool;
mutable sess_log_ra: bool;
mutable sess_log_insn: bool;
mutable sess_log_asm: bool;
mutable sess_log_obj: bool;
mutable sess_log_lib: bool;
mutable sess_log_path: (string list) option;
mutable sess_log_out: out_channel;
mutable sess_log_err: out_channel;
mutable sess_trace_block: bool;
mutable sess_trace_drop: bool;
mutable sess_trace_tag: bool;
mutable sess_trace_gc: bool;
mutable sess_failed: bool;
mutable sess_report_timing: bool;
mutable sess_report_quads: bool;
mutable sess_report_gc: bool;
mutable sess_report_deps: bool;
mutable sess_next_crate_id: int;
mutable sess_fuzz_item_count: int;
sess_timings: (string, float) Hashtbl.t;
sess_quad_counts: (string, int ref) Hashtbl.t;
sess_spans: (node_id,span) Hashtbl.t;
sess_lib_dirs: filename Queue.t;
sess_crate_meta: (meta, crate_id) Hashtbl.t;
sess_node_id_counter: node_id ref;
sess_opaque_id_counter: opaque_id ref;
sess_temp_id_counter: temp_id ref;
}
;;
let add_time sess name amt =
let existing =
if Hashtbl.mem sess.sess_timings name
then Hashtbl.find sess.sess_timings name
else 0.0
in
(Hashtbl.replace sess.sess_timings name (existing +. amt))
;;
let time_inner name sess thunk =
let t0 = Unix.gettimeofday() in
let x = thunk() in
let t1 = Unix.gettimeofday() in
add_time sess name (t1 -. t0);
x
;;
let get_span sess id =
if Hashtbl.mem sess.sess_spans id
then (Some (Hashtbl.find sess.sess_spans id))
else None
;;
let log name flag chan =
let k1 s =
Printf.fprintf chan "%s: %s\n%!" name s
in
let k2 _ = () in
Printf.ksprintf (if flag then k1 else k2)
;;
let fail sess =
sess.sess_failed <- true;
Printf.fprintf sess.sess_log_err
;;
let string_of_pos (p:pos) =
let (filename, line, col) = p in
Printf.sprintf "%s:%d:%d" filename line col
;;
let string_of_span (s:span) =
let (filename, line0, col0) = s.lo in
let (_, line1, col1) = s.hi in
Printf.sprintf "%s:%d:%d:%d:%d" filename line0 col0 line1 col1
;;
let filename_of (fo:filename option) : filename =
match fo with
None -> "<none>"
| Some f -> f
;;
let report_err sess ido str =
let spano = match ido with
None -> None
| Some id -> get_span sess id
in
match spano with
None ->
fail sess "error: %s\n%!" str
| Some span ->
fail sess "%s: error: %s\n%!"
(string_of_span span) str
;;
let make_crate_id (sess:sess) : crate_id =
let crate_id = Crate sess.sess_next_crate_id in
sess.sess_next_crate_id <- sess.sess_next_crate_id + 1;
crate_id
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

1795
src/boot/fe/ast.ml
View File

File diff suppressed because it is too large Load Diff

771
src/boot/fe/cexp.ml
View File

@ -1,771 +0,0 @@
open Common;;
open Token;;
open Parser;;
(* NB: cexps (crate-expressions / constant-expressions) are only used
* transiently during compilation: they are the outermost expression-language
* describing crate configuration and constants. They are completely evaluated
* at compile-time, in a little micro-interpreter defined here, with the
* results of evaluation being the sequence of directives controlling the rest
* of the compiler.
*
* Cexps, like pexps, do not escape the language front-end.
*
* You can think of the AST as a statement-language called "item" sandwiched
* between two expression-languages, "cexp" on the outside and "pexp" on the
* inside. The front-end evaluates cexp on the outside in order to get one big
* directive-list, evaluating those parts of pexp that are directly used by
* cexp in passing, and desugaring those remaining parts of pexp that are
* embedded within the items of the directives.
*
* The rest of the compiler only deals with the directives, which are mostly
* just a set of containers for items. Items are what most of AST describes
* ("most" because the type-grammar spans both items and pexps).
*
*)
type meta = (Ast.ident * Ast.pexp) array;;
type meta_pat = (Ast.ident * (Ast.pexp option)) array;;
type auth = (Ast.name * Ast.auth);;
type cexp =
CEXP_alt of cexp_alt identified
| CEXP_let of cexp_let identified
| CEXP_src_mod of cexp_src identified
| CEXP_dir_mod of cexp_dir identified
| CEXP_use_mod of cexp_use identified
| CEXP_nat_mod of cexp_nat identified
| CEXP_meta of meta identified
| CEXP_auth of auth identified
and cexp_alt =
{ alt_val: Ast.pexp;
alt_arms: (Ast.pexp * cexp array) array;
alt_else: cexp array }
and cexp_let =
{ let_ident: Ast.ident;
let_value: Ast.pexp;
let_body: cexp array; }
and cexp_src =
{ src_ident: Ast.ident;
src_path: Ast.pexp option }
and cexp_dir =
{ dir_ident: Ast.ident;
dir_path: Ast.pexp option;
dir_body: cexp array }
and cexp_use =
{ use_ident: Ast.ident;
use_meta: meta_pat; }
and cexp_nat =
{ nat_abi: string;
nat_ident: Ast.ident;
nat_path: Ast.pexp option;
(*
* FIXME: possibly support embedding optional strings as
* symbol-names, to handle mangling schemes that aren't
* Token.IDENT values
*)
nat_items: Ast.mod_items;
}
;;
(* Cexp grammar. *)
let parse_meta_input (ps:pstate) : (Ast.ident * Ast.pexp option) =
let lab = (ctxt "meta input: label" Pexp.parse_ident ps) in
match peek ps with
EQ ->
bump ps;
let v =
match peek ps with
UNDERSCORE -> bump ps; None
| _ -> Some (Pexp.parse_pexp ps)
in
(lab, v)
| _ -> raise (unexpected ps)
;;
let parse_meta_pat (ps:pstate) : meta_pat =
bracketed_zero_or_more LPAREN RPAREN
(Some COMMA) parse_meta_input ps
;;
let parse_meta (ps:pstate) : meta =
Array.map
begin
fun (id,v) ->
match v with
None ->
raise (err ("wildcard found in meta pattern "
^ "where value expected") ps)
| Some v -> (id,v)
end
(parse_meta_pat ps)
;;
let parse_optional_meta_pat
(ps:pstate)
(ident:Ast.ident)
: meta_pat =
match peek ps with
LPAREN -> parse_meta_pat ps
| _ ->
let apos = lexpos ps in
[| ("name", Some (span ps apos apos (Ast.PEXP_str ident))) |]
;;
let rec parse_cexps (ps:pstate) (term:Token.token) : cexp array =
let cexps = Queue.create () in
while ((peek ps) <> term)
do
Queue.push (parse_cexp ps) cexps
done;
expect ps term;
queue_to_arr cexps
and parse_cexp (ps:pstate) : cexp =
let apos = lexpos ps in
match peek ps with
MOD ->
begin
bump ps;
let name = ctxt "mod: name" Pexp.parse_ident ps in
let path = ctxt "mod: path" parse_eq_pexp_opt ps
in
match peek ps with
SEMI ->
bump ps;
let bpos = lexpos ps in
CEXP_src_mod
(span ps apos bpos { src_ident = name;
src_path = path })
| LBRACE ->
let body =
bracketed_zero_or_more LBRACE RBRACE
None parse_cexp ps
in
let bpos = lexpos ps in
CEXP_dir_mod
(span ps apos bpos { dir_ident = name;
dir_path = path;
dir_body = body })
| _ -> raise (unexpected ps)
end
| NATIVE ->
begin
bump ps;
let abi =
match peek ps with
MOD -> "cdecl"
| LIT_STR s -> bump ps; s
| _ -> raise (unexpected ps)
in
let _ = expect ps MOD in
let name = ctxt "native mod: name" Pexp.parse_ident ps in
let path = ctxt "native mod: path" parse_eq_pexp_opt ps in
let items = Hashtbl.create 0 in
let get_item ps =
Array.map
begin
fun (ident, item) ->
htab_put items ident item
end
(Item.parse_native_mod_item_from_signature ps)
in
ignore (bracketed_zero_or_more
LBRACE RBRACE None get_item ps);
let bpos = lexpos ps in
CEXP_nat_mod
(span ps apos bpos { nat_abi = abi;
nat_ident = name;
nat_path = path;
nat_items = items })
end
| USE ->
begin
bump ps;
let ident = ctxt "use mod: name" Pexp.parse_ident ps in
let meta =
ctxt "use mod: meta" parse_optional_meta_pat ps ident
in
let bpos = lexpos ps in
expect ps SEMI;
CEXP_use_mod
(span ps apos bpos { use_ident = ident;
use_meta = meta })
end
| LET ->
begin
bump ps;
expect ps LPAREN;
let id = Pexp.parse_ident ps in
expect ps EQ;
let v = Pexp.parse_pexp ps in
expect ps RPAREN;
expect ps LBRACE;
let body = parse_cexps ps RBRACE in
let bpos = lexpos ps in
CEXP_let
(span ps apos bpos
{ let_ident = id;
let_value = v;
let_body = body })
end
| ALT ->
begin
bump ps;
expect ps LPAREN;
let v = Pexp.parse_pexp ps in
expect ps RPAREN;
expect ps LBRACE;
let rec consume_arms arms =
match peek ps with
CASE ->
begin
bump ps;
expect ps LPAREN;
let cond = Pexp.parse_pexp ps in
expect ps RPAREN;
expect ps LBRACE;
let consequent = parse_cexps ps RBRACE in
let arm = (cond, consequent) in
consume_arms (arm::arms)
end
| ELSE ->
begin
bump ps;
expect ps LBRACE;
let consequent = parse_cexps ps RBRACE in
expect ps RBRACE;
let bpos = lexpos ps in
span ps apos bpos
{ alt_val = v;
alt_arms = Array.of_list (List.rev arms);
alt_else = consequent }
end
| _ -> raise (unexpected ps)
in
CEXP_alt (consume_arms [])
end
| META ->
bump ps;
let meta = parse_meta ps in
expect ps SEMI;
let bpos = lexpos ps in
CEXP_meta (span ps apos bpos meta)
| AUTH ->
bump ps;
let name = Pexp.parse_name ps in
expect ps EQ;
let au = Pexp.parse_auth ps in
expect ps SEMI;
let bpos = lexpos ps in
CEXP_auth (span ps apos bpos (name, au))
| _ -> raise (unexpected ps)
and parse_eq_pexp_opt (ps:pstate) : Ast.pexp option =
match peek ps with
EQ ->
begin
bump ps;
Some (Pexp.parse_pexp ps)
end
| _ -> None
;;
(*
* Dynamic-typed micro-interpreter for the cexp language.
*
* The product of evaluating a pexp is a pval.
*
* The product of evlauating a cexp is a cdir array.
*)
type pval =
PVAL_str of string
| PVAL_int of int64
| PVAL_bool of bool
;;
type cdir =
CDIR_meta of ((Ast.ident * string) array)
| CDIR_syntax of Ast.name
| CDIR_mod of (Ast.ident * Ast.mod_item)
| CDIR_auth of auth
type env = { env_bindings: ((Ast.ident * pval) list) ref;
env_prefix: filename list;
env_items: (filename, Ast.mod_items) Hashtbl.t;
env_files: (node_id,filename) Hashtbl.t;
env_required: (node_id, (required_lib * nabi_conv)) Hashtbl.t;
env_required_syms: (node_id, string) Hashtbl.t;
env_ps: pstate; }
let unexpected_val (expected:string) (v:pval) =
let got =
match v with
PVAL_str s -> "str \"" ^ (String.escaped s) ^ "\""
| PVAL_int i -> "int " ^ (Int64.to_string i)
| PVAL_bool b -> if b then "bool true" else "bool false"
in
(* FIXME (issue #70): proper error reporting, please. *)
bug () "expected %s, got %s" expected got
;;
let rewrap_items id items =
let item = decl [||] (Ast.MOD_ITEM_mod items) in
{ id = id; node = item }
;;
let rec eval_cexps (env:env) (exps:cexp array) : cdir array =
Parser.arj (Array.map (eval_cexp env) exps)
and eval_cexp (env:env) (exp:cexp) : cdir array =
match exp with
CEXP_alt { node = ca; id = _ } ->
let v = eval_pexp env ca.alt_val in
let rec try_arm i =
if i >= Array.length ca.alt_arms
then ca.alt_else
else
let (arm_head, arm_body) = ca.alt_arms.(i) in
let v' = eval_pexp env arm_head in
if v' = v
then arm_body
else try_arm (i+1)
in
eval_cexps env (try_arm 0)
| CEXP_let { node = cl; id = _ } ->
let ident = cl.let_ident in
let v = eval_pexp env cl.let_value in
let old_bindings = !(env.env_bindings) in
env.env_bindings := (ident,v)::old_bindings;
let res = eval_cexps env cl.let_body in
env.env_bindings := old_bindings;
res
| CEXP_src_mod {node=s; id=id} ->
let name = s.src_ident in
let path =
match s.src_path with
None -> name ^ ".rs"
| Some p -> eval_pexp_to_str env p
in
let full_path =
List.fold_left Filename.concat ""
(List.rev (path :: env.env_prefix))
in
let ps = env.env_ps in
let p =
make_parser
ps.pstate_crate_cache
ps.pstate_sess
ps.pstate_get_mod
ps.pstate_get_cenv_tok
ps.pstate_infer_lib_name
env.env_required
env.env_required_syms
full_path
in
let items = Item.parse_mod_items p EOF in
htab_put env.env_files id full_path;
[| CDIR_mod (name, rewrap_items id items) |]
| CEXP_dir_mod {node=d; id=id} ->
let items = Hashtbl.create 0 in
let name = d.dir_ident in
let path =
match d.dir_path with
None -> name
| Some p -> eval_pexp_to_str env p
in
let env = { env with
env_prefix = path :: env.env_prefix } in
let sub_directives = eval_cexps env d.dir_body in
let add d =
match d with
CDIR_mod (name, item) ->
htab_put items name item
| _ -> raise (err "non-'mod' directive found in 'dir' directive"
env.env_ps)
in
Array.iter add sub_directives;
[| CDIR_mod (name, rewrap_items id (Item.empty_view, items)) |]
| CEXP_use_mod {node=u; id=id} ->
let ps = env.env_ps in
let name = u.use_ident in
let (path, items) =
let meta_pat =
Array.map
begin
fun (k,vo) ->
match vo with
None -> (k, None)
| Some p -> (k, Some (eval_pexp_to_str env p))
end
u.use_meta
in
ps.pstate_get_mod meta_pat id ps.pstate_crate_cache
in
iflog ps
begin
fun _ ->
log ps "extracted mod signature from %s (binding to %s)"
path name;
log ps "%a" Ast.sprintf_mod_items items;
end;
let rlib = REQUIRED_LIB_rust { required_libname = path;
required_prefix = 1 }
in
let item = decl [||] (Ast.MOD_ITEM_mod (Item.empty_view, items)) in
let item = { id = id; node = item } in
let span = Hashtbl.find ps.pstate_sess.Session.sess_spans id in
Item.note_required_mod env.env_ps span CONV_rust rlib item;
[| CDIR_mod (name, item) |]
| CEXP_nat_mod {node=cn;id=id} ->
let conv =
let v = cn.nat_abi in
match string_to_conv v with
None -> unexpected_val "calling convention" (PVAL_str v)
| Some c -> c
in
let name = cn.nat_ident in
let filename =
match cn.nat_path with
None -> env.env_ps.pstate_infer_lib_name name
| Some p -> eval_pexp_to_str env p
in
let item =
decl [||] (Ast.MOD_ITEM_mod (Item.empty_view, cn.nat_items))
in
let item = { id = id; node = item } in
let rlib = REQUIRED_LIB_c { required_libname = filename;
required_prefix = 1 }
in
let ps = env.env_ps in
let span = Hashtbl.find ps.pstate_sess.Session.sess_spans id in
Item.note_required_mod env.env_ps span conv rlib item;
[| CDIR_mod (name, item) |]
| CEXP_meta m ->
[| CDIR_meta
begin
Array.map
begin
fun (id, p) -> (id, eval_pexp_to_str env p)
end
m.node
end |]
| CEXP_auth a -> [| CDIR_auth a.node |]
and eval_pexp (env:env) (exp:Ast.pexp) : pval =
match exp.node with
| Ast.PEXP_binop (bop, a, b) ->
begin
let av = eval_pexp env a in
let bv = eval_pexp env b in
match (bop, av, bv) with
(Ast.BINOP_add, PVAL_str az, PVAL_str bz) ->
PVAL_str (az ^ bz)
| _ ->
let av = (need_int av) in
let bv = (need_int bv) in
PVAL_int
begin
match bop with
Ast.BINOP_add -> Int64.add av bv
| Ast.BINOP_sub -> Int64.sub av bv
| Ast.BINOP_mul -> Int64.mul av bv
| Ast.BINOP_div -> Int64.div av bv
| _ ->
bug ()
"unhandled arithmetic op in Cexp.eval_pexp"
end
end
| Ast.PEXP_unop (uop, a) ->
begin
match uop with
Ast.UNOP_not ->
PVAL_bool (not (eval_pexp_to_bool env a))
| Ast.UNOP_neg ->
PVAL_int (Int64.neg (eval_pexp_to_int env a))
| _ -> bug () "Unexpected unop in Cexp.eval_pexp"
end
| Ast.PEXP_lval (Ast.PLVAL_base (Ast.BASE_ident ident)) ->
begin
match ltab_search !(env.env_bindings) ident with
None -> raise (err (Printf.sprintf "no binding for '%s' found"
ident) env.env_ps)
| Some v -> v
end
| Ast.PEXP_lit (Ast.LIT_bool b) ->
PVAL_bool b
| Ast.PEXP_lit (Ast.LIT_int i) ->
PVAL_int i
| Ast.PEXP_str s ->
PVAL_str s
| _ -> bug () "unexpected Pexp in Cexp.eval_pexp"
and eval_pexp_to_str (env:env) (exp:Ast.pexp) : string =
match eval_pexp env exp with
PVAL_str s -> s
| v -> unexpected_val "str" v
and need_int (cv:pval) : int64 =
match cv with
PVAL_int n -> n
| v -> unexpected_val "int" v
and eval_pexp_to_int (env:env) (exp:Ast.pexp) : int64 =
need_int (eval_pexp env exp)
and eval_pexp_to_bool (env:env) (exp:Ast.pexp) : bool =
match eval_pexp env exp with
PVAL_bool b -> b
| v -> unexpected_val "bool" v
;;
let find_main_fn
(ps:pstate)
(crate_items:Ast.mod_items)
: Ast.name =
let fns = ref [] in
let extend prefix_name ident =
match prefix_name with
None -> Ast.NAME_base (Ast.BASE_ident ident)
| Some n -> Ast.NAME_ext (n, Ast.COMP_ident ident)
in
let rec dig prefix_name items =
Hashtbl.iter (extract_fn prefix_name) items
and extract_fn prefix_name ident item =
if not (Array.length item.node.Ast.decl_params = 0) ||
Hashtbl.mem ps.pstate_required item.id
then ()
else
match item.node.Ast.decl_item with
Ast.MOD_ITEM_mod (_, items) ->
dig (Some (extend prefix_name ident)) items
| Ast.MOD_ITEM_fn _ ->
if ident = "main"
then fns := (extend prefix_name ident) :: (!fns)
else ()
| _ -> ()
in
dig None crate_items;
match !fns with
[] -> raise (err "no 'main' function found" ps)
| [x] -> x
| _ -> raise (err "multiple 'main' functions found" ps)
;;
let with_err_handling sess thunk =
try
thunk ()
with
Parse_err (ps, str) ->
Session.fail sess "%s: error: %s\n%!"
(Session.string_of_pos (lexpos ps)) str;
List.iter
(fun (cx,pos) ->
Session.fail sess "%s: (parse context): %s\n%!"
(Session.string_of_pos pos) cx)
ps.pstate_ctxt;
let apos = lexpos ps in
span ps apos apos Ast.empty_crate'
;;
let parse_crate_file
(sess:Session.sess)
(get_mod:get_mod_fn)
(infer_lib_name:(Ast.ident -> filename))
(crate_cache:(crate_id, Ast.mod_items) Hashtbl.t)
: Ast.crate =
let fname = Session.filename_of sess.Session.sess_in in
let required = Hashtbl.create 4 in
let required_syms = Hashtbl.create 4 in
let files = Hashtbl.create 0 in
let items = Hashtbl.create 4 in
let target_bindings =
let (os, arch, libc) =
match sess.Session.sess_targ with
Linux_x86_elf -> ("linux", "x86", "libc.so.6")
| FreeBSD_x86_elf -> ("freebsd", "x86", "libc.so.7")
| Win32_x86_pe -> ("win32", "x86", "msvcrt.dll")
| MacOS_x86_macho -> ("macos", "x86", "libc.dylib")
in
[
("target_os", PVAL_str os);
("target_arch", PVAL_str arch);
("target_libc", PVAL_str libc)
]
in
let build_bindings =
[
("build_compiler", PVAL_str Sys.executable_name);
("build_input", PVAL_str fname);
]
in
let bindings =
ref (target_bindings
@ build_bindings)
in
let get_cenv_tok ps ident =
match ltab_search (!bindings) ident with
None -> raise (err (Printf.sprintf "no binding for '%s' found"
ident) ps)
| Some (PVAL_bool b) -> LIT_BOOL b
| Some (PVAL_str s) -> LIT_STR s
| Some (PVAL_int n) -> LIT_INT n
in
let ps =
make_parser crate_cache sess get_mod get_cenv_tok
infer_lib_name required required_syms fname
in
let env = { env_bindings = bindings;
env_prefix = [Filename.dirname fname];
env_items = Hashtbl.create 0;
env_files = files;
env_required = required;
env_required_syms = required_syms;
env_ps = ps; }
in
let auth = Hashtbl.create 0 in
with_err_handling sess
begin
fun _ ->
let apos = lexpos ps in
let cexps = parse_cexps ps EOF in
let cdirs = eval_cexps env cexps in
let meta = Queue.create () in
let _ =
Array.iter
begin
fun d ->
match d with
CDIR_mod (name, item) ->
if Hashtbl.mem items name
then raise
(err ("duplicate mod declaration: " ^ name) ps)
else Hashtbl.add items name item
| CDIR_meta metas ->
Array.iter (fun m -> Queue.add m meta) metas
| CDIR_auth (n,e) ->
if Hashtbl.mem auth n
then raise (err "duplicate 'auth' clause" ps)
else Hashtbl.add auth n e
| _ ->
raise
(err "unhandled directive at top level" ps)
end
cdirs
in
let bpos = lexpos ps in
let main =
if ps.pstate_sess.Session.sess_library_mode
then None
else Some (find_main_fn ps items) in
let crate = { Ast.crate_items = (Item.empty_view, items);
Ast.crate_meta = queue_to_arr meta;
Ast.crate_auth = auth;
Ast.crate_required = required;
Ast.crate_required_syms = required_syms;
Ast.crate_main = main;
Ast.crate_files = files }
in
let cratei = span ps apos bpos crate in
htab_put files cratei.id fname;
cratei
end
;;
let parse_src_file
(sess:Session.sess)
(get_mod:get_mod_fn)
(infer_lib_name:(Ast.ident -> filename))
(crate_cache:(crate_id, Ast.mod_items) Hashtbl.t)
: Ast.crate =
let fname = Session.filename_of sess.Session.sess_in in
let required = Hashtbl.create 0 in
let required_syms = Hashtbl.create 0 in
let get_cenv_tok ps ident =
raise (err (Printf.sprintf "no binding for '%s' found"
ident) ps)
in
let ps =
make_parser crate_cache sess get_mod get_cenv_tok
infer_lib_name required required_syms fname
in
with_err_handling sess
begin
fun _ ->
let apos = lexpos ps in
let items = Item.parse_mod_items ps EOF in
let bpos = lexpos ps in
let files = Hashtbl.create 0 in
let main =
if ps.pstate_sess.Session.sess_library_mode
then None
else Some (find_main_fn ps (snd items))
in
let crate = { Ast.crate_items = items;
Ast.crate_required = required;
Ast.crate_required_syms = required_syms;
Ast.crate_auth = Hashtbl.create 0;
Ast.crate_meta = [||];
Ast.crate_main = main;
Ast.crate_files = files }
in
let cratei = span ps apos bpos crate in
htab_put files cratei.id fname;
cratei
end
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

229
src/boot/fe/extfmt.ml
View File

@ -1,229 +0,0 @@
(* The 'fmt' extension is modeled on the posix printf system.
*
* A posix conversion ostensibly looks like this:
*
* %[parameter][flags][width][.precision][length]type
*
* Given the different numeric type bestiary we have, we omit the 'length'
* parameter and support slightly different conversions for 'type':
*
* %[parameter][flags][width][.precision]type
*
* we also only support translating-to-rust a tiny subset of the possible
* combinations at the moment.
*)
exception Malformed of string
;;
type case =
CASE_upper
| CASE_lower
;;
type signedness =
SIGNED
| UNSIGNED
;;
type ty =
TY_bool
| TY_str
| TY_char
| TY_int of signedness
| TY_bits
| TY_hex of case
(* FIXME: Support more later. *)
;;
type flag =
FLAG_left_justify
| FLAG_left_zero_pad
| FLAG_left_space_pad
| FLAG_plus_if_positive
| FLAG_alternate
;;
type count =
COUNT_is of int
| COUNT_is_param of int
| COUNT_is_next_param
| COUNT_implied
type conv =
{ conv_parameter: int option;
conv_flags: flag list;
conv_width: count;
conv_precision: count;
conv_ty: ty }
type piece =
PIECE_string of string
| PIECE_conversion of conv
let rec peek_num (s:string) (i:int) (lim:int)
: (int * int) option =
if i >= lim
then None
else
let c = s.[i] in
if '0' <= c && c <= '9'
then
let n = (Char.code c) - (Char.code '0') in
match peek_num s (i+1) lim with
None -> Some (n, i+1)
| Some (m, i) -> Some (n * 10 + m, i)
else None
;;
let parse_parameter (s:string) (i:int) (lim:int)
: (int option * int) =
if i >= lim
then (None, i)
else
match peek_num s i lim with
None -> (None, i)
| Some (n, j) ->
if j < (String.length s) && s.[j] = '$'
then (Some n, j+1)
else (None, i)
;;
let rec parse_flags (s:string) (i:int) (lim:int)
: (flag list * int) =
if i >= lim
then ([], i)
else
let cont flag =
let (rest, j) = parse_flags s (i+1) lim in
(flag :: rest, j)
in
match s.[i] with
'-' -> cont FLAG_left_justify
| '0' -> cont FLAG_left_zero_pad
| ' ' -> cont FLAG_left_space_pad
| '+' -> cont FLAG_plus_if_positive
| '#' -> cont FLAG_alternate
| _ -> ([], i)
;;
let parse_count (s:string) (i:int) (lim:int)
: (count * int) =
if i >= lim
then (COUNT_implied, i)
else
if s.[i] = '*'
then
begin
match parse_parameter s (i+1) lim with
(None, j) -> (COUNT_is_next_param, j)
| (Some n, j) -> (COUNT_is_param n, j)
end
else
begin
match peek_num s i lim with
None -> (COUNT_implied, i)
| Some (n, j) -> (COUNT_is n, j)
end
;;
let parse_precision (s:string) (i:int) (lim:int)
: (count * int) =
if i >= lim
then (COUNT_implied, i)
else
if s.[i] = '.'
then parse_count s (i+1) lim
else (COUNT_implied, i)
;;
let parse_type (s:string) (i:int) (lim:int)
: (ty * int) =
if i >= lim
then raise (Malformed "missing type in conversion")
else
let t =
match s.[i] with
'b' -> TY_bool
| 's' -> TY_str
| 'c' -> TY_char
| 'd' | 'i' -> TY_int SIGNED
| 'u' -> TY_int UNSIGNED
| 'x' -> TY_hex CASE_lower
| 'X' -> TY_hex CASE_upper
| 't' -> TY_bits
| _ -> raise (Malformed "unknown type in conversion")
in
(t, i+1)
;;
let parse_conversion (s:string) (i:int) (lim:int)
: (piece * int) =
let (parameter, i) = parse_parameter s i lim in
let (flags, i) = parse_flags s i lim in
let (width, i) = parse_count s i lim in
let (precision, i) = parse_precision s i lim in
let (ty, i) = parse_type s i lim in
(PIECE_conversion { conv_parameter = parameter;
conv_flags = flags;
conv_width = width;
conv_precision = precision;
conv_ty = ty }, i)
;;
let parse_fmt_string (s:string) : piece array =
let pieces = Queue.create () in
let i = ref 0 in
let lim = String.length s in
let buf = Buffer.create 10 in
let flush_buf _ =
if (Buffer.length buf) <> 0
then
let piece =
PIECE_string (Buffer.contents buf)
in
Queue.add piece pieces;
Buffer.clear buf;
in
while (!i) < lim
do
if s.[!i] = '%'
then
begin
incr i;
if (!i) >= lim
then raise (Malformed "unterminated conversion at end of string");
if s.[!i] = '%'
then
begin
Buffer.add_char buf '%';
incr i;
end
else
begin
flush_buf();
let (piece, j) = parse_conversion s (!i) lim in
Queue.add piece pieces;
i := j
end
end
else
begin
Buffer.add_char buf s.[!i];
incr i;
end
done;
flush_buf ();
Common.queue_to_arr pieces
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

166
src/boot/fe/fuzz.ml
View File

@ -1,166 +0,0 @@
open Common;;
open Ast;;
let ident_chars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_";;
let digit_chars = "1234567890";;
type scope =
SCOPE_crate of crate
| SCOPE_mod_item of (ident * mod_item)
| SCOPE_block of block
| SCOPE_anon
;;
type ctxt =
{
ctxt_scopes: scope Stack.t;
ctxt_node_counter: int ref;
ctxt_sess: Session.sess;
}
let generate_ident _ : ident =
let char n =
if n = 0
then '_'
else ident_chars.[Random.int (String.length ident_chars)]
in
let i = 3 + (Random.int 10) in
let s = String.create i in
for j = 0 to (i-1)
do
s.[j] <- char j
done;
s
;;
let wrap (n:'a) (cx:ctxt) : 'a identified =
incr cx.ctxt_node_counter;
{ node = n; id = Node (!(cx.ctxt_node_counter)) }
;;
let generate_in (scope:scope) (fn:(ctxt -> 'a)) (cx:ctxt) : 'a =
Stack.push scope cx.ctxt_scopes;
let x = fn cx in
ignore (Stack.pop cx.ctxt_scopes);
x
;;
let generate_some (fn:(ctxt -> 'a)) (cx:ctxt) : 'a array =
let root_count = cx.ctxt_sess.Session.sess_fuzz_item_count in
let depth = Stack.length cx.ctxt_scopes in
if depth >= root_count
then [| |]
else
Array.init (1 + (Random.int (root_count - depth)))
(fun _ -> fn cx)
;;
let rec generate_ty (cx:ctxt) : ty =
let subty _ =
generate_in SCOPE_anon
generate_ty cx
in
match Random.int (if Random.bool() then 10 else 17) with
0 -> TY_nil
| 1 -> TY_bool
| 2 -> TY_mach TY_u8
| 3 -> TY_mach TY_u32
| 4 -> TY_mach TY_i8
| 5 -> TY_mach TY_i32
| 6 -> TY_int
| 7 -> TY_uint
| 8 -> TY_char
| 9 -> TY_str
| 10 -> TY_tup (generate_in SCOPE_anon
(generate_some
generate_ty) cx)
| 11 -> TY_vec (subty())
| 12 ->
let generate_elt cx =
(generate_ident cx, generate_ty cx)
in
TY_rec (generate_in SCOPE_anon
(generate_some generate_elt) cx)
| 13 -> TY_chan (subty())
| 14 -> TY_port (subty())
| 15 -> TY_task
| _ -> TY_box (subty())
;;
let rec generate_mod_item (mis:mod_items) (cx:ctxt) : unit =
let ident = generate_ident () in
let decl i = wrap { decl_item = i;
decl_params = [| |] } cx
in
let item =
match Random.int 2 with
0 ->
let ty = generate_ty cx in
let st = Ast.LAYER_value in
decl (MOD_ITEM_type (st, ty))
| _ ->
let mis' = Hashtbl.create 0 in
let view = { view_imports = Hashtbl.create 0;
view_exports = Hashtbl.create 0; }
in
let item =
decl (MOD_ITEM_mod (view, mis'))
in
let scope =
SCOPE_mod_item (ident, item)
in
ignore
(generate_in scope
(generate_some (generate_mod_item mis'))
cx);
item
in
Hashtbl.add mis ident item
;;
let fuzz (seed:int option) (sess:Session.sess) : unit =
begin
match seed with
None -> Random.self_init ()
| Some s -> Random.init s
end;
let filename =
match sess.Session.sess_out with
Some o -> o
| None ->
match seed with
None -> "fuzz.rs"
| Some seed -> "fuzz-" ^ (string_of_int seed) ^ ".rs"
in
let out = open_out_bin filename in
let ff = Format.formatter_of_out_channel out in
let cx = { ctxt_scopes = Stack.create ();
ctxt_node_counter = ref 0;
ctxt_sess = sess }
in
let mis = Hashtbl.create 0 in
ignore (generate_some
(generate_mod_item mis) cx);
fmt_mod_items ff mis;
Format.pp_print_flush ff ();
close_out out;
exit 0
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

1334
src/boot/fe/item.ml
View File

File diff suppressed because it is too large Load Diff

478
src/boot/fe/lexer.mll
View File

@ -1,478 +0,0 @@
{
open Token;;
open Common;;
exception Lex_err of (string * Common.pos);;
let fail lexbuf s =
let p = lexbuf.Lexing.lex_start_p in
let pos =
(p.Lexing.pos_fname,
p.Lexing.pos_lnum ,
(p.Lexing.pos_cnum) - (p.Lexing.pos_bol))
in
raise (Lex_err (s, pos))
;;
let bump_line p = { p with
Lexing.pos_lnum = p.Lexing.pos_lnum + 1;
Lexing.pos_bol = p.Lexing.pos_cnum }
;;
let newline lexbuf =
lexbuf.Lexing.lex_curr_p
<- (bump_line lexbuf.Lexing.lex_curr_p)
;;
let mach_suf_table = Hashtbl.create 10
;;
let reserved_suf_table = Hashtbl.create 10
;;
let _ =
List.iter (fun (suf, ty) -> Common.htab_put mach_suf_table suf ty)
[ ("u8", Common.TY_u8);
("i8", Common.TY_i8);
("u16", Common.TY_u16);
("i16", Common.TY_i16);
("u32", Common.TY_u32);
("i32", Common.TY_i32);
("u64", Common.TY_u64);
("i64", Common.TY_i64);
("f32", Common.TY_f32);
("f64", Common.TY_f64); ]
;;
let _ =
List.iter (fun suf -> Common.htab_put reserved_suf_table suf ())
[ "f16"; (* IEEE 754-2008 'binary16' interchange format. *)
"f80"; (* IEEE 754-1985 'extended' *)
"f128"; (* IEEE 754-2008 'binary128' *)
"m32"; (* IEEE 754-2008 'decimal32' *)
"m64"; (* IEEE 754-2008 'decimal64' *)
"m128"; (* IEEE 754-2008 'decimal128' *)
"m"; (* One of m32, m64, m128. *)
]
;;
let keyword_table = Hashtbl.create 100
;;
let reserved_table = Hashtbl.create 10
;;
let _ =
List.iter (fun (kwd, tok) -> Common.htab_put keyword_table kwd tok)
[ ("mod", MOD);
("use", USE);
("meta", META);
("auth", AUTH);
("syntax", SYNTAX);
("if", IF);
("else", ELSE);
("while", WHILE);
("do", DO);
("alt", ALT);
("case", CASE);
("for", FOR);
("each", EACH);
("put", PUT);
("ret", RET);
("be", BE);
("fail", FAIL);
("drop", DROP);
("type", TYPE);
("check", CHECK);
("assert", ASSERT);
("claim", CLAIM);
("prove", PROVE);
("state", STATE);
("gc", GC);
("unsafe", UNSAFE);
("native", NATIVE);
("mutable", MUTABLE);
("auto", AUTO);
("fn", FN);
("iter", ITER);
("import", IMPORT);
("export", EXPORT);
("let", LET);
("const", CONST);
("log", LOG);
("log_err", LOG_ERR);
("break", BREAK);
("cont", CONT);
("spawn", SPAWN);
("thread", THREAD);
("yield", YIELD);
("join", JOIN);
("bool", BOOL);
("int", INT);
("uint", UINT);
("float", FLOAT);
("char", CHAR);
("str", STR);
("rec", REC);
("tup", TUP);
("tag", TAG);
("vec", VEC);
("any", ANY);
("obj", OBJ);
("port", PORT);
("chan", CHAN);
("task", TASK);
("true", LIT_BOOL true);
("false", LIT_BOOL false);
("in", IN);
("as", AS);
("with", WITH);
("bind", BIND);
("u8", MACH TY_u8);
("u16", MACH TY_u16);
("u32", MACH TY_u32);
("u64", MACH TY_u64);
("i8", MACH TY_i8);
("i16", MACH TY_i16);
("i32", MACH TY_i32);
("i64", MACH TY_i64);
("f32", MACH TY_f32);
("f64", MACH TY_f64)
]
;;
let _ =
List.iter (fun kwd -> Common.htab_put reserved_table kwd ())
[ "f16"; (* IEEE 754-2008 'binary16' interchange format. *)
"f80"; (* IEEE 754-1985 'extended' *)
"f128"; (* IEEE 754-2008 'binary128' *)
"m32"; (* IEEE 754-2008 'decimal32' *)
"m64"; (* IEEE 754-2008 'decimal64' *)
"m128"; (* IEEE 754-2008 'decimal128' *)
"dec"; (* One of m32, m64, m128. *)
];
;;
}
let hexdig = ['0'-'9' 'a'-'f' 'A'-'F']
let decdig = ['0'-'9']
let bin = '0' 'b' ['0' '1' '_']*
let hex = '0' 'x' ['0'-'9' 'a'-'f' 'A'-'F' '_']*
let dec = decdig ['0'-'9' '_']*
let exp = ['e''E']['-''+']? dec
let flo = (dec '.' dec (exp?)) | (dec exp)
let mach_float_suf = "f32"|"f64"
let mach_int_suf = ['u''i']('8'|"16"|"32"|"64")
let flo_suf = ['m''f']("16"|"32"|"64"|"80"|"128")
let ws = [ ' ' '\t' '\r' ]
let id = ['a'-'z' 'A'-'Z' '_']['a'-'z' 'A'-'Z' '0'-'9' '_']*
rule token = parse
ws+ { token lexbuf }
| '\n' { newline lexbuf;
token lexbuf }
| "//" [^'\n']* { token lexbuf }
| "/*" { comment 1 lexbuf }
| '+' { PLUS }
| '-' { MINUS }
| '*' { STAR }
| '/' { SLASH }
| '%' { PERCENT }
| '=' { EQ }
| '<' { LT }
| "<=" { LE }
| "==" { EQEQ }
| "!=" { NE }
| ">=" { GE }
| '>' { GT }
| '!' { NOT }
| '&' { AND }
| "&&" { ANDAND }
| '|' { OR }
| "||" { OROR }
| "<<" { LSL }
| ">>" { LSR }
| ">>>" { ASR }
| '~' { TILDE }
| '{' { LBRACE }
| '_' (decdig+ as n) { IDX (int_of_string n) }
| '_' { UNDERSCORE }
| '}' { RBRACE }
| "+=" { OPEQ (PLUS) }
| "-=" { OPEQ (MINUS) }
| "*=" { OPEQ (STAR) }
| "/=" { OPEQ (SLASH) }
| "%=" { OPEQ (PERCENT) }
| "&=" { OPEQ (AND) }
| "|=" { OPEQ (OR) }
| "<<=" { OPEQ (LSL) }
| ">>=" { OPEQ (LSR) }
| ">>>=" { OPEQ (ASR) }
| "^=" { OPEQ (CARET) }
| '#' { POUND }
| '@' { AT }
| '^' { CARET }
| '.' { DOT }
| ',' { COMMA }
| ';' { SEMI }
| ':' { COLON }
| '?' { QUES }
| "<-" { LARROW }
| "<|" { SEND }
| "->" { RARROW }
| '(' { LPAREN }
| ')' { RPAREN }
| '[' { LBRACKET }
| ']' { RBRACKET }
| id as i
{
match Common.htab_search keyword_table i with
Some tok -> tok
| None ->
if Hashtbl.mem reserved_table i
then fail lexbuf "reserved keyword"
else IDENT (i)
}
| (bin|hex|dec) as n { LIT_INT (Int64.of_string n) }
| ((bin|hex|dec) as n) 'u' { LIT_UINT (Int64.of_string n) }
| ((bin|hex|dec) as n)
(mach_int_suf as s)
{
match Common.htab_search mach_suf_table s with
Some tm -> LIT_MACH_INT (tm, Int64.of_string n)
| None ->
if Hashtbl.mem reserved_suf_table s
then fail lexbuf "reserved mach-int suffix"
else fail lexbuf "bad mach-int suffix"
}
| flo as n { LIT_FLOAT (float_of_string n) }
| flo 'm' { fail lexbuf "reseved mach-float suffix" }
| (flo as n) (flo_suf as s)
{
match Common.htab_search mach_suf_table s with
Some tm -> LIT_MACH_FLOAT (tm, float_of_string n)
| None ->
if Hashtbl.mem reserved_suf_table s
then fail lexbuf "reserved mach-float suffix"
else fail lexbuf "bad mach-float suffix"
}
| '\'' { char lexbuf }
| '"' { let buf = Buffer.create 32 in
str buf lexbuf }
| _ as c { let s = Char.escaped c in
fail lexbuf ("Bad character: " ^ s) }
| eof { EOF }
and str buf = parse
_ as ch
{
match ch with
'"' -> LIT_STR (Buffer.contents buf)
| '\\' -> str_escape buf lexbuf
| _ ->
Buffer.add_char buf ch;
let c = Char.code ch in
if bounds 0 c 0x7f
then str buf lexbuf
else
if ((c land 0b1110_0000) == 0b1100_0000)
then ext_str 1 buf lexbuf
else
if ((c land 0b1111_0000) == 0b1110_0000)
then ext_str 2 buf lexbuf
else
if ((c land 0b1111_1000) == 0b1111_0000)
then ext_str 3 buf lexbuf
else
if ((c land 0b1111_1100) == 0b1111_1000)
then ext_str 4 buf lexbuf
else
if ((c land 0b1111_1110) == 0b1111_1100)
then ext_str 5 buf lexbuf
else fail lexbuf "bad initial utf-8 byte"
}
and str_escape buf = parse
'x' ((hexdig hexdig) as h)
| 'u' ((hexdig hexdig hexdig hexdig) as h)
| 'U'
((hexdig hexdig hexdig hexdig
hexdig hexdig hexdig hexdig) as h)
{
Buffer.add_string buf (char_as_utf8 (int_of_string ("0x" ^ h)));
str buf lexbuf
}
| 'n' { Buffer.add_char buf '\n'; str buf lexbuf }
| 'r' { Buffer.add_char buf '\r'; str buf lexbuf }
| 't' { Buffer.add_char buf '\t'; str buf lexbuf }
| '\\' { Buffer.add_char buf '\\'; str buf lexbuf }
| '"' { Buffer.add_char buf '"'; str buf lexbuf }
| _ as c { fail lexbuf ("bad escape: \\" ^ (Char.escaped c)) }
and ext_str n buf = parse
_ as ch
{
let c = Char.code ch in
if ((c land 0b1100_0000) == (0b1000_0000))
then
begin
Buffer.add_char buf ch;
if n = 1
then str buf lexbuf
else ext_str (n-1) buf lexbuf
end
else
fail lexbuf "bad trailing utf-8 byte"
}
and char = parse
'\\' { char_escape lexbuf }
| _ as c
{
let c = Char.code c in
if bounds 0 c 0x7f
then end_char c lexbuf
else
if ((c land 0b1110_0000) == 0b1100_0000)
then ext_char 1 (c land 0b0001_1111) lexbuf
else
if ((c land 0b1111_0000) == 0b1110_0000)
then ext_char 2 (c land 0b0000_1111) lexbuf
else
if ((c land 0b1111_1000) == 0b1111_0000)
then ext_char 3 (c land 0b0000_0111) lexbuf
else
if ((c land 0b1111_1100) == 0b1111_1000)
then ext_char 4 (c land 0b0000_0011) lexbuf
else
if ((c land 0b1111_1110) == 0b1111_1100)
then ext_char 5 (c land 0b0000_0001) lexbuf
else fail lexbuf "bad initial utf-8 byte"
}
and char_escape = parse
'x' ((hexdig hexdig) as h)
| 'u' ((hexdig hexdig hexdig hexdig) as h)
| 'U'
((hexdig hexdig hexdig hexdig
hexdig hexdig hexdig hexdig) as h)
{
end_char (int_of_string ("0x" ^ h)) lexbuf
}
| 'n' { end_char (Char.code '\n') lexbuf }
| 'r' { end_char (Char.code '\r') lexbuf }
| 't' { end_char (Char.code '\t') lexbuf }
| '\\' { end_char (Char.code '\\') lexbuf }
| '\'' { end_char (Char.code '\'') lexbuf }
| _ as c { fail lexbuf ("bad escape: \\" ^ (Char.escaped c)) }
and ext_char n accum = parse
_ as c
{
let c = Char.code c in
if ((c land 0b1100_0000) == (0b1000_0000))
then
let accum = (accum lsl 6) lor (c land 0b0011_1111) in
if n = 1
then end_char accum lexbuf
else ext_char (n-1) accum lexbuf
else
fail lexbuf "bad trailing utf-8 byte"
}
and end_char accum = parse
'\'' { LIT_CHAR accum }
and bracequote buf depth = parse
'\\' '{' { Buffer.add_char buf '{';
bracequote buf depth lexbuf }
| '{' { Buffer.add_char buf '{';
bracequote buf (depth+1) lexbuf }
| '\\' '}' { Buffer.add_char buf '}';
bracequote buf depth lexbuf }
| '}' { if depth = 1
then BRACEQUOTE (Buffer.contents buf)
else
begin
Buffer.add_char buf '}';
bracequote buf (depth-1) lexbuf
end }
| '\\' [^'{' '}'] { let s = Lexing.lexeme lexbuf in
Buffer.add_string buf s;
bracequote buf depth lexbuf }
| [^'\\' '{' '}'] as c { Buffer.add_char buf c;
if c = '\n'
then newline lexbuf;
bracequote buf depth lexbuf }
and comment depth = parse
'/' '*' { comment (depth+1) lexbuf }
| '*' '/' { if depth = 1
then token lexbuf
else comment (depth-1) lexbuf }
| '\n' { newline lexbuf;
comment depth lexbuf }
| _ { comment depth lexbuf }
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

372
src/boot/fe/parser.ml
View File

@ -1,372 +0,0 @@
open Common;;
open Token;;
(* Fundamental parser types and actions *)
type get_mod_fn = (Ast.meta_pat
-> node_id
-> (crate_id, Ast.mod_items) Hashtbl.t
-> (filename * Ast.mod_items))
;;
type pstate =
{ mutable pstate_peek : token;
mutable pstate_ctxt : (string * pos) list;
mutable pstate_rstr : bool;
mutable pstate_depth: int;
pstate_lexbuf : Lexing.lexbuf;
pstate_file : filename;
pstate_sess : Session.sess;
pstate_crate_cache : (crate_id, Ast.mod_items) Hashtbl.t;
pstate_get_mod : get_mod_fn;
pstate_get_cenv_tok : pstate -> Ast.ident -> token;
pstate_infer_lib_name : (Ast.ident -> filename);
pstate_required : (node_id, (required_lib * nabi_conv)) Hashtbl.t;
pstate_required_syms : (node_id, string) Hashtbl.t; }
;;
let log (ps:pstate) = Session.log "parse"
ps.pstate_sess.Session.sess_log_parse
ps.pstate_sess.Session.sess_log_out
;;
let iflog ps thunk =
if ps.pstate_sess.Session.sess_log_parse
then thunk ()
else ()
;;
let make_parser
(crate_cache:(crate_id, Ast.mod_items) Hashtbl.t)
(sess:Session.sess)
(get_mod:get_mod_fn)
(get_cenv_tok:pstate -> Ast.ident -> token)
(infer_lib_name:Ast.ident -> filename)
(required:(node_id, (required_lib * nabi_conv)) Hashtbl.t)
(required_syms:(node_id, string) Hashtbl.t)
(fname:string)
: pstate =
let lexbuf = Lexing.from_channel (open_in fname) in
let spos = { lexbuf.Lexing.lex_start_p with Lexing.pos_fname = fname } in
let cpos = { lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = fname } in
lexbuf.Lexing.lex_start_p <- spos;
lexbuf.Lexing.lex_curr_p <- cpos;
let first = Lexer.token lexbuf in
let ps =
{ pstate_peek = first;
pstate_ctxt = [];
pstate_rstr = false;
pstate_depth = 0;
pstate_lexbuf = lexbuf;
pstate_file = fname;
pstate_sess = sess;
pstate_crate_cache = crate_cache;
pstate_get_mod = get_mod;
pstate_get_cenv_tok = get_cenv_tok;
pstate_infer_lib_name = infer_lib_name;
pstate_required = required;
pstate_required_syms = required_syms; }
in
iflog ps (fun _ -> log ps "made parser for: %s\n%!" fname);
ps
;;
exception Parse_err of (pstate * string)
;;
let lexpos (ps:pstate) : pos =
let p = ps.pstate_lexbuf.Lexing.lex_start_p in
(p.Lexing.pos_fname,
p.Lexing.pos_lnum ,
(p.Lexing.pos_cnum) - (p.Lexing.pos_bol))
;;
let next_node_id (ps:pstate) : node_id =
let r = ps.pstate_sess.Session.sess_node_id_counter in
let id = !r in
r := Node ((int_of_node id)+1);
id
;;
let next_opaque_id (ps:pstate) : opaque_id =
let r = ps.pstate_sess.Session.sess_opaque_id_counter in
let id = !r in
r := Opaque ((int_of_opaque id)+1);
id
;;
let span
(ps:pstate)
(apos:pos)
(bpos:pos)
(x:'a)
: 'a identified =
let span = { lo = apos; hi = bpos } in
let id = next_node_id ps in
iflog ps (fun _ -> log ps "span for node #%d: %s"
(int_of_node id) (Session.string_of_span span));
htab_put ps.pstate_sess.Session.sess_spans id span;
{ node = x; id = id }
;;
let decl p i =
{ Ast.decl_params = p;
Ast.decl_item = i }
;;
let spans
(ps:pstate)
(things:('a identified) array)
(apos:pos)
(thing:'a)
: ('a identified) array =
Array.append things [| (span ps apos (lexpos ps) thing) |]
;;
(*
* The point of this is to make a new node_id entry for a node that is a
* "copy" of an lval returned from somewhere else. For example if you create
* a temp, the lval it returns can only be used in *one* place, for the
* node_id denotes the place that lval is first used; subsequent uses of
* 'the same' reference must clone_lval it into a new node_id. Otherwise
* there is trouble.
*)
let clone_span
(ps:pstate)
(oldnode:'a identified)
(newthing:'b)
: 'b identified =
let s = Hashtbl.find ps.pstate_sess.Session.sess_spans oldnode.id in
span ps s.lo s.hi newthing
;;
let rec clone_lval (ps:pstate) (lval:Ast.lval) : Ast.lval =
match lval with
Ast.LVAL_base nb ->
let nnb = clone_span ps nb nb.node in
Ast.LVAL_base nnb
| Ast.LVAL_ext (base, ext) ->
Ast.LVAL_ext ((clone_lval ps base), ext)
;;
let clone_atom (ps:pstate) (atom:Ast.atom) : Ast.atom =
match atom with
Ast.ATOM_literal _ -> atom
| Ast.ATOM_lval lv -> Ast.ATOM_lval (clone_lval ps lv)
| Ast.ATOM_pexp _ -> bug () "Parser.clone_atom on ATOM_pexp"
;;
let ctxt (n:string) (f:pstate -> 'a) (ps:pstate) : 'a =
(ps.pstate_ctxt <- (n, lexpos ps) :: ps.pstate_ctxt;
let res = f ps in
ps.pstate_ctxt <- List.tl ps.pstate_ctxt;
res)
;;
let rstr (r:bool) (f:pstate -> 'a) (ps:pstate) : 'a =
let prev = ps.pstate_rstr in
(ps.pstate_rstr <- r;
let res = f ps in
ps.pstate_rstr <- prev;
res)
;;
let err (str:string) (ps:pstate) =
(Parse_err (ps, (str)))
;;
let (slot_nil:Ast.slot) =
{ Ast.slot_mode = Ast.MODE_local;
Ast.slot_ty = Some Ast.TY_nil }
;;
let (slot_auto:Ast.slot) =
{ Ast.slot_mode = Ast.MODE_local;
Ast.slot_ty = None }
;;
let build_tmp
(ps:pstate)
(slot:Ast.slot)
(apos:pos)
(bpos:pos)
: (temp_id * Ast.lval * Ast.stmt) =
let r = ps.pstate_sess.Session.sess_temp_id_counter in
let id = !r in
r := Temp ((int_of_temp id)+1);
iflog ps
(fun _ -> log ps "building temporary %d" (int_of_temp id));
let decl = Ast.DECL_slot (Ast.KEY_temp id, (span ps apos bpos slot)) in
let declstmt = span ps apos bpos (Ast.STMT_decl decl) in
let tmp = Ast.LVAL_base (span ps apos bpos (Ast.BASE_temp id)) in
(id, tmp, declstmt)
;;
(* Simple helpers *)
(* FIXME (issue #71): please rename these, they make eyes bleed. *)
let arr (ls:'a list) : 'a array = Array.of_list ls ;;
let arl (ls:'a list) : 'a array = Array.of_list (List.rev ls) ;;
let arj (ar:('a array array)) = Array.concat (Array.to_list ar) ;;
let arj1st (pairs:(('a array) * 'b) array) : (('a array) * 'b array) =
let (az, bz) = List.split (Array.to_list pairs) in
(Array.concat az, Array.of_list bz)
(* Bottom-most parser actions. *)
let peek (ps:pstate) : token =
iflog ps
begin
fun _ ->
log ps "peeking at: %s // %s"
(string_of_tok ps.pstate_peek)
(match ps.pstate_ctxt with
(s, _) :: _ -> s
| _ -> "<empty>")
end;
ps.pstate_peek
;;
let bump (ps:pstate) : unit =
begin
iflog ps (fun _ -> log ps "bumping past: %s"
(string_of_tok ps.pstate_peek));
ps.pstate_peek <- Lexer.token ps.pstate_lexbuf
end
;;
let bump_bracequote (ps:pstate) : unit =
begin
assert (ps.pstate_peek = LBRACE);
iflog ps (fun _ -> log ps "bumping past: %s"
(string_of_tok ps.pstate_peek));
let buf = Buffer.create 32 in
ps.pstate_peek <- Lexer.bracequote buf 1 ps.pstate_lexbuf
end
;;
let expect (ps:pstate) (t:token) : unit =
let p = peek ps in
if p == t
then bump ps
else
let msg = ("Expected '" ^ (string_of_tok t) ^
"', found '" ^ (string_of_tok p ) ^ "'") in
raise (Parse_err (ps, msg))
;;
let unexpected (ps:pstate) =
err ("Unexpected token '" ^ (string_of_tok (peek ps)) ^ "'") ps
;;
(* Parser combinators. *)
let one_or_more
(sep:token)
(prule:pstate -> 'a)
(ps:pstate)
: 'a array =
let accum = ref [prule ps] in
while peek ps == sep
do
bump ps;
accum := (prule ps) :: !accum
done;
arl !accum
;;
let bracketed_seq
(mandatory:int)
(bra:token)
(ket:token)
(sepOpt:token option)
(prule:pstate -> 'a)
(ps:pstate)
: 'a array =
expect ps bra;
let accum = ref [] in
let dosep _ =
(match sepOpt with
None -> ()
| Some tok ->
if (!accum = [])
then ()
else expect ps tok)
in
while mandatory > List.length (!accum) do
dosep ();
accum := (prule ps) :: (!accum)
done;
while (not (peek ps = ket))
do
dosep ();
accum := (prule ps) :: !accum
done;
expect ps ket;
arl !accum
;;
let bracketed_zero_or_more
(bra:token)
(ket:token)
(sepOpt:token option)
(prule:pstate -> 'a)
(ps:pstate)
: 'a array =
bracketed_seq 0 bra ket sepOpt (ctxt "bracketed_seq" prule) ps
;;
let paren_comma_list
(prule:pstate -> 'a)
(ps:pstate)
: 'a array =
bracketed_zero_or_more LPAREN RPAREN (Some COMMA) prule ps
;;
let bracketed_one_or_more
(bra:token)
(ket:token)
(sepOpt:token option)
(prule:pstate -> 'a)
(ps:pstate)
: 'a array =
bracketed_seq 1 bra ket sepOpt (ctxt "bracketed_seq" prule) ps
;;
let bracketed_two_or_more
(bra:token)
(ket:token)
(sepOpt:token option)
(prule:pstate -> 'a)
(ps:pstate)
: 'a array =
bracketed_seq 2 bra ket sepOpt (ctxt "bracketed_seq" prule) ps
;;
let bracketed (bra:token) (ket:token) (prule:pstate -> 'a) (ps:pstate) : 'a =
expect ps bra;
let res = ctxt "bracketed" prule ps in
expect ps ket;
res
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

1441
src/boot/fe/pexp.ml
View File

File diff suppressed because it is too large Load Diff

334
src/boot/fe/token.ml
View File

@ -1,334 +0,0 @@
type token =
(* Expression operator symbols *)
PLUS
| MINUS
| STAR
| SLASH
| PERCENT
| EQ
| LT
| LE
| EQEQ
| NE
| GE
| GT
| NOT
| TILDE
| CARET
| AND
| ANDAND
| OR
| OROR
| LSL
| LSR
| ASR
| OPEQ of token
| AS
| WITH
(* Structural symbols *)
| AT
| DOT
| COMMA
| SEMI
| COLON
| QUES
| RARROW
| SEND
| LARROW
| LPAREN
| RPAREN
| LBRACKET
| RBRACKET
| LBRACE
| RBRACE
(* Module and crate keywords *)
| MOD
| USE
| AUTH
| META
(* Metaprogramming keywords *)
| SYNTAX
| POUND
(* Statement keywords *)
| IF
| ELSE
| DO
| WHILE
| ALT
| CASE
| FAIL
| DROP
| IN
| FOR
| EACH
| PUT
| RET
| BE
| BREAK
| CONT
(* Type and type-state keywords *)
| TYPE
| CHECK
| ASSERT
| CLAIM
| PROVE
(* Layer keywords *)
| STATE
| GC
(* Unsafe-block keyword *)
| UNSAFE
(* Type qualifiers *)
| NATIVE
| AUTO
| MUTABLE
(* Name management *)
| IMPORT
| EXPORT
(* Value / stmt declarators *)
| LET
| CONST
(* Magic runtime services *)
| LOG
| LOG_ERR
| SPAWN
| BIND
| THREAD
| YIELD
| JOIN
(* Literals *)
| LIT_INT of int64
| LIT_UINT of int64
| LIT_FLOAT of float
| LIT_MACH_INT of Common.ty_mach * int64
| LIT_MACH_FLOAT of Common.ty_mach * float
| LIT_STR of string
| LIT_CHAR of int
| LIT_BOOL of bool
(* Name components *)
| IDENT of string
| IDX of int
| UNDERSCORE
(* Reserved type names *)
| BOOL
| INT
| UINT
| FLOAT
| CHAR
| STR
| MACH of Common.ty_mach
(* Algebraic type constructors *)
| REC
| TUP
| TAG
| VEC
| ANY
(* Callable type constructors *)
| FN
| ITER
(* Object type *)
| OBJ
(* Comm and task types *)
| CHAN
| PORT
| TASK
| EOF
| BRACEQUOTE of string
;;
let rec string_of_tok t =
match t with
(* Operator symbols (mostly) *)
PLUS -> "+"
| MINUS -> "-"
| STAR -> "*"
| SLASH -> "/"
| PERCENT -> "%"
| EQ -> "="
| LT -> "<"
| LE -> "<="
| EQEQ -> "=="
| NE -> "!="
| GE -> ">="
| GT -> ">"
| TILDE -> "~"
| CARET -> "^"
| NOT -> "!"
| AND -> "&"
| ANDAND -> "&&"
| OR -> "|"
| OROR -> "||"
| LSL -> "<<"
| LSR -> ">>"
| ASR -> ">>>"
| OPEQ op -> string_of_tok op ^ "="
| AS -> "as"
| WITH -> "with"
(* Structural symbols *)
| AT -> "@"
| DOT -> "."
| COMMA -> ","
| SEMI -> ";"
| COLON -> ":"
| QUES -> "?"
| RARROW -> "->"
| SEND -> "<|"
| LARROW -> "<-"
| LPAREN -> "("
| RPAREN -> ")"
| LBRACKET -> "["
| RBRACKET -> "]"
| LBRACE -> "{"
| RBRACE -> "}"
(* Module and crate keywords *)
| MOD -> "mod"
| USE -> "use"
| AUTH -> "auth"
(* Metaprogramming keywords *)
| SYNTAX -> "syntax"
| META -> "meta"
| POUND -> "#"
(* Control-flow keywords *)
| IF -> "if"
| ELSE -> "else"
| DO -> "do"
| WHILE -> "while"
| ALT -> "alt"
| CASE -> "case"
| FAIL -> "fail"
| DROP -> "drop"
| IN -> "in"
| FOR -> "for"
| EACH -> "each"
| PUT -> "put"
| RET -> "ret"
| BE -> "be"
| BREAK -> "break"
| CONT -> "cont"
(* Type and type-state keywords *)
| TYPE -> "type"
| CHECK -> "check"
| ASSERT -> "assert"
| CLAIM -> "claim"
| PROVE -> "prove"
(* Layer keywords *)
| STATE -> "state"
| GC -> "gc"
(* Unsafe-block keyword *)
| UNSAFE -> "unsafe"
(* Type qualifiers *)
| NATIVE -> "native"
| AUTO -> "auto"
| MUTABLE -> "mutable"
(* Name management *)
| IMPORT -> "import"
| EXPORT -> "export"
(* Value / stmt declarators. *)
| LET -> "let"
| CONST -> "const"
(* Magic runtime services *)
| LOG -> "log"
| LOG_ERR -> "log_err"
| SPAWN -> "spawn"
| BIND -> "bind"
| THREAD -> "thread"
| YIELD -> "yield"
| JOIN -> "join"
(* Literals *)
| LIT_INT i -> Int64.to_string i
| LIT_UINT i -> (Int64.to_string i) ^ "u"
| LIT_FLOAT s -> string_of_float s
| LIT_MACH_INT (tm, i) ->
(Int64.to_string i) ^ (Common.string_of_ty_mach tm)
| LIT_MACH_FLOAT (tm, f) ->
(string_of_float f) ^ (Common.string_of_ty_mach tm)
| LIT_STR s -> ("\"" ^ (String.escaped s) ^ "\"")
| LIT_CHAR c -> ("'" ^ (Common.escaped_char c) ^ "'")
| LIT_BOOL b -> if b then "true" else "false"
(* Name components *)
| IDENT s -> s
| IDX i -> ("_" ^ (string_of_int i))
| UNDERSCORE -> "_"
(* Reserved type names *)
| BOOL -> "bool"
| INT -> "int"
| UINT -> "uint"
| FLOAT -> "float"
| CHAR -> "char"
| STR -> "str"
| MACH m -> Common.string_of_ty_mach m
(* Algebraic type constructors *)
| REC -> "rec"
| TUP -> "tup"
| TAG -> "tag"
| VEC -> "vec"
| ANY -> "any"
(* Callable type constructors *)
| FN -> "fn"
| ITER -> "iter"
(* Object type *)
| OBJ -> "obj"
(* Ports and channels *)
| CHAN -> "chan"
| PORT -> "port"
(* Taskess types *)
| TASK -> "task"
| BRACEQUOTE _ -> "{...bracequote...}"
| EOF -> "<EOF>"
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

156
src/boot/me/alias.ml
View File

@ -1,156 +0,0 @@
open Semant;;
open Common;;
let log cx = Session.log "alias"
(should_log cx cx.ctxt_sess.Session.sess_log_alias)
cx.ctxt_sess.Session.sess_log_out
;;
let alias_analysis_visitor
(cx:ctxt)
(inner:Walk.visitor)
: Walk.visitor =
let curr_stmt = Stack.create () in
let alias_slot (slot_id:node_id) : unit =
begin
log cx "noting slot #%d as aliased" (int_of_node slot_id);
Hashtbl.replace cx.ctxt_slot_aliased slot_id ()
end
in
let alias lval =
let defn_id = lval_base_defn_id cx lval in
if (defn_id_is_slot cx defn_id)
then alias_slot defn_id
in
let alias_atom at =
match at with
Ast.ATOM_lval lv -> alias lv
| _ -> () (* Aliasing a literal is harmless, if weird. *)
in
let alias_call_args dst callee args =
alias dst;
let callee_ty = lval_ty cx callee in
match callee_ty with
Ast.TY_fn (tsig,_) ->
Array.iteri
begin
fun i slot ->
match slot.Ast.slot_mode with
Ast.MODE_alias ->
alias_atom args.(i)
| _ -> ()
end
tsig.Ast.sig_input_slots
| _ -> ()
in
let check_no_alias_bindings
(fn:Ast.lval)
(args:(Ast.atom option) array)
: unit =
let fty = match lval_ty cx fn with
Ast.TY_fn tfn -> tfn
| _ -> err (Some (lval_base_id fn)) "binding non-fn"
in
let arg_slots = (fst fty).Ast.sig_input_slots in
Array.iteri
begin
fun i arg ->
match arg with
None -> ()
| Some _ ->
match arg_slots.(i).Ast.slot_mode with
Ast.MODE_local -> ()
| Ast.MODE_alias ->
err (Some (lval_base_id fn)) "binding alias slot"
end
args
in
let visit_stmt_pre s =
Stack.push s.id curr_stmt;
begin
try
match s.node with
(* FIXME (issue #26): actually all these *existing* cases
* can probably go now that we're using Trans.aliasing to
* form short-term spill-based aliases. Only aliases that
* survive 'into' a sub-block (those formed during iteration)
* need to be handled in this module. *)
Ast.STMT_call (dst, callee, args)
| Ast.STMT_spawn (dst, _, _, callee, args)
-> alias_call_args dst callee args
| Ast.STMT_bind (_, fn, args) ->
check_no_alias_bindings fn args
| Ast.STMT_send (_, src) -> alias src
| Ast.STMT_recv (dst, _) -> alias dst
| Ast.STMT_new_port (dst) -> alias dst
| Ast.STMT_new_chan (dst, _) -> alias dst
| Ast.STMT_new_vec (dst, _, _) -> alias dst
| Ast.STMT_new_str (dst, _) -> alias dst
| Ast.STMT_for_each sfe ->
let (slot, _) = sfe.Ast.for_each_slot in
alias_slot slot.id
| _ -> () (* FIXME (issue #29): plenty more to handle here. *)
with
Semant_err (None, msg) ->
raise (Semant_err ((Some s.id), msg))
end;
inner.Walk.visit_stmt_pre s
in
let visit_stmt_post s =
inner.Walk.visit_stmt_post s;
ignore (Stack.pop curr_stmt);
in
let visit_lval_pre lv =
let slot_id = lval_base_defn_id cx lv in
if (not (Stack.is_empty curr_stmt)) && (defn_id_is_slot cx slot_id)
then
begin
let slot_depth = get_slot_depth cx slot_id in
let stmt_depth = get_stmt_depth cx (Stack.top curr_stmt) in
if slot_depth <> stmt_depth
then
begin
let _ = assert (slot_depth < stmt_depth) in
alias_slot slot_id
end
end
in
{ inner with
Walk.visit_stmt_pre = visit_stmt_pre;
Walk.visit_stmt_post = visit_stmt_post;
Walk.visit_lval_pre = visit_lval_pre
}
;;
let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
let passes =
[|
(alias_analysis_visitor cx
Walk.empty_visitor);
|]
in
run_passes cx "alias" passes
cx.ctxt_sess.Session.sess_log_alias log crate
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

134
src/boot/me/dead.ml
View File

@ -1,134 +0,0 @@
(*
* A simple dead-code analysis that rejects code following unconditional
* 'ret' or 'be'.
*)
open Semant;;
open Common;;
let log cx = Session.log "dead"
(should_log cx cx.ctxt_sess.Session.sess_log_dead)
cx.ctxt_sess.Session.sess_log_out
;;
let dead_code_visitor
((*cx*)_:ctxt)
(inner:Walk.visitor)
: Walk.visitor =
(* FIXME: create separate table for each fn body for less garbage *)
let must_exit = Hashtbl.create 100 in
let all_must_exit ids =
arr_for_all (fun _ id -> Hashtbl.mem must_exit id) ids
in
let visit_block_post block =
let stmts = block.node in
let len = Array.length stmts in
if len > 0 then
Array.iteri
begin
fun i s ->
if (i < (len - 1)) && (Hashtbl.mem must_exit s.id) then
err (Some stmts.(i + 1).id) "dead statement"
end
stmts;
inner.Walk.visit_block_post block
in
let exit_stmt_if_exit_body s body =
if (Hashtbl.mem must_exit body.id) then
Hashtbl.add must_exit s.id ()
in
let visit_stmt_post s =
begin
match s.node with
| Ast.STMT_block block ->
if Hashtbl.mem must_exit block.id then
Hashtbl.add must_exit s.id ()
| Ast.STMT_while w
| Ast.STMT_do_while w ->
exit_stmt_if_exit_body s w.Ast.while_body
| Ast.STMT_for_each f ->
exit_stmt_if_exit_body s f.Ast.for_each_body
| Ast.STMT_for f ->
exit_stmt_if_exit_body s f.Ast.for_body
| Ast.STMT_if { Ast.if_then = b1;
Ast.if_else = Some b2;
Ast.if_test = _ } ->
if (Hashtbl.mem must_exit b1.id) && (Hashtbl.mem must_exit b2.id)
then Hashtbl.add must_exit s.id ()
| Ast.STMT_if _ -> ()
| Ast.STMT_ret _
| Ast.STMT_be _ ->
Hashtbl.add must_exit s.id ()
| Ast.STMT_alt_tag { Ast.alt_tag_arms = arms;
Ast.alt_tag_lval = _ } ->
let arm_ids =
Array.map (fun { node = (_, block); id = _ } -> block.id) arms
in
if all_must_exit arm_ids
then Hashtbl.add must_exit s.id ()
| Ast.STMT_alt_type { Ast.alt_type_arms = arms;
Ast.alt_type_else = alt_type_else;
Ast.alt_type_lval = _ } ->
let arm_ids = Array.map (fun { node = ((_, _), block); id = _ } ->
block.id) arms in
let else_ids =
begin
match alt_type_else with
Some stmt -> [| stmt.id |]
| None -> [| |]
end
in
if all_must_exit (Array.append arm_ids else_ids) then
Hashtbl.add must_exit s.id ()
(* FIXME: figure this one out *)
| Ast.STMT_alt_port _ -> ()
| _ -> ()
end;
inner.Walk.visit_stmt_post s
in
{ inner with
Walk.visit_block_post = visit_block_post;
Walk.visit_stmt_post = visit_stmt_post }
;;
let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
let passes =
[|
(dead_code_visitor cx
Walk.empty_visitor)
|]
in
run_passes cx "dead" passes
cx.ctxt_sess.Session.sess_log_dead log crate;
()
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

3213
src/boot/me/dwarf.ml
View File

File diff suppressed because it is too large Load Diff

108
src/boot/me/layer.ml
View File

@ -1,108 +0,0 @@
open Semant;;
open Common;;
let log cx = Session.log "layer"
(should_log cx cx.ctxt_sess.Session.sess_log_layer)
cx.ctxt_sess.Session.sess_log_out
;;
let iflog cx thunk =
if (should_log cx cx.ctxt_sess.Session.sess_log_layer)
then thunk ()
else ()
;;
let state_layer_checking_visitor
(cx:ctxt)
(inner:Walk.visitor)
: Walk.visitor =
(*
* This visitor enforces the following rules:
*
* - A channel type carrying a state type is illegal.
*
* - Writing to an immutable slot is illegal.
*
* - Forming a mutable alias to an immutable slot is illegal.
*
*)
let visit_ty_pre t =
match t with
Ast.TY_chan t' when type_has_state cx t' ->
err None "channel of state type: %a " Ast.sprintf_ty t'
| _ -> ()
in
let check_write s dst =
let is_init = Hashtbl.mem cx.ctxt_stmt_is_init s.id in
let dst_ty = lval_ty cx dst in
let is_mutable =
match dst_ty with
Ast.TY_mutable _ -> true
| _ -> false
in
iflog cx
(fun _ -> log cx "checking %swrite to %slval #%d = %a of type %a"
(if is_init then "initializing " else "")
(if is_mutable then "mutable " else "")
(int_of_node (lval_base_id dst))
Ast.sprintf_lval dst
Ast.sprintf_ty dst_ty);
if (is_mutable or is_init)
then ()
else err (Some s.id)
"writing to immutable type %a in statement %a"
Ast.sprintf_ty dst_ty Ast.sprintf_stmt s
in
(* FIXME (issue #75): enforce the no-write-alias-to-immutable-slot
* rule.
*)
let visit_stmt_pre s =
begin
match s.node with
Ast.STMT_copy (lv_dst, _)
| Ast.STMT_call (lv_dst, _, _)
| Ast.STMT_spawn (lv_dst, _, _, _, _)
| Ast.STMT_recv (lv_dst, _)
| Ast.STMT_bind (lv_dst, _, _)
| Ast.STMT_new_rec (lv_dst, _, _)
| Ast.STMT_new_tup (lv_dst, _)
| Ast.STMT_new_vec (lv_dst, _, _)
| Ast.STMT_new_str (lv_dst, _)
| Ast.STMT_new_port lv_dst
| Ast.STMT_new_chan (lv_dst, _)
| Ast.STMT_new_box (lv_dst, _, _) ->
check_write s lv_dst
| _ -> ()
end;
inner.Walk.visit_stmt_pre s
in
{ inner with
Walk.visit_ty_pre = visit_ty_pre;
Walk.visit_stmt_pre = visit_stmt_pre }
;;
let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
let passes =
[|
(state_layer_checking_visitor cx
Walk.empty_visitor);
|]
in
run_passes cx "layer" passes
cx.ctxt_sess.Session.sess_log_layer log crate
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

480
src/boot/me/layout.ml
View File

@ -1,480 +0,0 @@
open Semant;;
open Common;;
let log cx = Session.log "layout"
(should_log cx cx.ctxt_sess.Session.sess_log_layout)
cx.ctxt_sess.Session.sess_log_out
;;
type slot_stack = Il.referent_ty Stack.t;;
type frame_blocks = slot_stack Stack.t;;
let layout_visitor
(cx:ctxt)
(inner:Walk.visitor)
: Walk.visitor =
(*
* - Frames look, broadly, like this (growing downward):
*
* +----------------------------+ <-- Rewind tail calls to here.
* |caller args |
* |... |
* |... |
* +----------------------------+ <-- fp + abi_frame_base_sz
* |closure/obj ptr (impl. arg) | + abi_implicit_args_sz
* |task ptr (implicit arg) |
* |output ptr (implicit arg) |
* +----------------------------+ <-- fp + abi_frame_base_sz
* |return pc |
* |old fp | <-- fp
* +----------------------------+
* |other callee-save registers |
* |... |
* +----------------------------+ <-- fp - callee_saves
* |crate ptr |
* |crate-rel frame info disp |
* +----------------------------+ <-- fp - (callee_saves
* |spills determined in ra | + abi_frame_info_sz)
* |... |
* |... |
* +----------------------------+ <-- fp - (callee_saves
* |... | + abi_frame_info_sz
* |frame-allocated stuff | + spillsz)
* |determined in resolve |
* |laid out in layout |
* |... |
* |... |
* +----------------------------+ <-- fp - (callee_saves + framesz)
* |call space | == sp + callsz
* |... |
* |... |
* +----------------------------+ <-- fp - (callee_saves
* + framesz + callsz) == sp
*
* - Slot offsets fall into three classes:
*
* #1 frame-locals are negative offsets from fp
* (beneath the frame-info and spills)
*
* #2 incoming arg slots are positive offsets from fp
* (above the frame-base)
*
* #3 outgoing arg slots are positive offsets from sp
*
* - Slots are split into two classes:
*
* #1 those that are never aliased and fit in a word, so are
* vreg-allocated
*
* #2 all others
*
* - Non-aliased, word-fitting slots consume no frame space
* *yet*; they are given a generic value that indicates "try a
* vreg". The register allocator may spill them later, if it
* needs to, but that's not our concern.
*
* - Aliased / too-big slots are frame-allocated, need to be
* laid out in the frame at fixed offsets.
*
* - The frame size is the maximum of all the block sizes contained
* within it. Though at the moment it's the sum of them, due to
* the blood-curdling hack we use to ensure proper unwind/drop
* behavior in absence of CFI or similar precise frame-evolution
* tracking. See visit_block_post below (issue #27).
*
* - Each call is examined and the size of the call tuple required
* for that call is calculated. The call size is the maximum of all
* such call tuples.
*
* - In frames that have a tail call (in fact, currently, all frames
* because we're lazy) we double the call size in order to handle
* the possible need to *execute* a call (to drop glue) while
* destroying the frame, after we've built the outgoing args. This is
* done in the backend though; the logic in this file is ignorant of the
* doubling (some platforms may not require it? Hard to guess)
*
*)
let force_slot_to_mem (slot:Ast.slot) : bool =
(* FIXME (issue #26): For the time being we force any slot that
* points into memory or is of opaque/code type to be stored in the
* frame rather than in a vreg. This can probably be relaxed in the
* future.
*)
let rec st_in_mem st =
match st with
Il.ValTy _ -> false
| Il.AddrTy _ -> true
and rt_in_mem rt =
match rt with
Il.ScalarTy st -> st_in_mem st
| Il.StructTy rts
| Il.UnionTy rts -> List.exists rt_in_mem (Array.to_list rts)
| Il.OpaqueTy
| Il.ParamTy _
| Il.CodeTy -> true
| Il.NilTy -> false
in
rt_in_mem (slot_referent_type cx slot)
in
let rty_sz rty = Il.referent_ty_size cx.ctxt_abi.Abi.abi_word_bits rty in
let rty_layout rty =
Il.referent_ty_layout cx.ctxt_abi.Abi.abi_word_bits rty
in
let is_subword_size sz =
match sz with
SIZE_fixed i -> i64_le i cx.ctxt_abi.Abi.abi_word_sz
| _ -> false
in
let iflog thunk =
if (should_log cx cx.ctxt_sess.Session.sess_log_layout)
then thunk ()
else ()
in
let layout_slot_ids
(slot_accum:slot_stack)
(upwards:bool)
(vregs_ok:bool)
(offset:size)
(slots:node_id array)
: unit =
let accum (off,align) id : (size * size) =
let slot = get_slot cx id in
let rt = slot_referent_type cx slot in
let (elt_size, elt_align) = rty_layout rt in
if vregs_ok
&& (is_subword_size elt_size)
&& (not (type_is_structured cx (slot_ty slot)))
&& (not (force_slot_to_mem slot))
&& (not (Hashtbl.mem cx.ctxt_slot_aliased id))
then
begin
iflog
begin
fun _ ->
let k = Hashtbl.find cx.ctxt_slot_keys id in
log cx "assigning slot #%d = %a to vreg"
(int_of_node id)
Ast.sprintf_slot_key k;
end;
htab_put cx.ctxt_slot_vregs id (ref None);
(off,align)
end
else
begin
let elt_off = align_sz elt_align off in
let frame_off =
if upwards
then elt_off
else neg_sz (add_sz elt_off elt_size)
in
Stack.push
(slot_referent_type cx slot)
slot_accum;
iflog
begin
fun _ ->
let k = Hashtbl.find cx.ctxt_slot_keys id in
log cx "assigning slot #%d = %a frame-offset %s"
(int_of_node id)
Ast.sprintf_slot_key k
(string_of_size frame_off);
end;
if (not (Hashtbl.mem cx.ctxt_slot_offsets id))
then htab_put cx.ctxt_slot_offsets id frame_off;
(add_sz elt_off elt_size, max_sz elt_align align)
end
in
ignore (Array.fold_left accum (offset, SIZE_fixed 0L) slots)
in
let layout_block
(slot_accum:slot_stack)
(offset:size)
(block:Ast.block)
: unit =
log cx "laying out block #%d at fp offset %s"
(int_of_node block.id) (string_of_size offset);
let block_slot_ids =
Array.of_list (htab_vals (Hashtbl.find cx.ctxt_block_slots block.id))
in
layout_slot_ids slot_accum false true offset block_slot_ids
in
let layout_header (id:node_id) (input_slot_ids:node_id array) : unit =
let rty = direct_call_args_referent_type cx id in
let offset =
match rty with
Il.StructTy elts ->
(add_sz
(SIZE_fixed cx.ctxt_abi.Abi.abi_frame_base_sz)
(Il.get_element_offset
cx.ctxt_abi.Abi.abi_word_bits
elts Abi.calltup_elt_args))
| _ -> bug () "call tuple has non-StructTy"
in
log cx "laying out header for node #%d at fp offset %s"
(int_of_node id) (string_of_size offset);
layout_slot_ids (Stack.create()) true false offset input_slot_ids
in
let layout_obj_state (id:node_id) (state_slot_ids:node_id array) : unit =
let offset =
let word_sz = cx.ctxt_abi.Abi.abi_word_sz in
let word_n (n:int) = Int64.mul word_sz (Int64.of_int n) in
SIZE_fixed (word_n (Abi.box_rc_field_body
+ 1 (* the state tydesc. *)))
in
log cx "laying out object-state for node #%d at offset %s"
(int_of_node id) (string_of_size offset);
layout_slot_ids (Stack.create()) true false offset state_slot_ids
in
let (frame_stack:(node_id * frame_blocks) Stack.t) = Stack.create() in
let block_rty (block:slot_stack) : Il.referent_ty =
Il.StructTy (Array.of_list (stk_elts_from_bot block))
in
let frame_rty (frame:frame_blocks) : Il.referent_ty =
Il.StructTy (Array.of_list (List.map block_rty (stk_elts_from_bot frame)))
in
let update_frame_size _ =
let (frame_id, frame_blocks) = Stack.top frame_stack in
let frame_spill = Hashtbl.find cx.ctxt_spill_fixups frame_id in
let sz =
(* NB: the "frame size" does not include the callee-saves. *)
add_sz
(add_sz
(rty_sz (frame_rty frame_blocks))
(SIZE_fixup_mem_sz frame_spill))
(SIZE_fixed
cx.ctxt_abi.Abi.abi_frame_info_sz)
in
let curr = Hashtbl.find cx.ctxt_frame_sizes frame_id in
let sz = max_sz curr sz in
log cx "extending frame #%d frame to size %s"
(int_of_node frame_id) (string_of_size sz);
Hashtbl.replace cx.ctxt_frame_sizes frame_id sz
in
(*
* FIXME: this is a little aggressive for default callsz; it can be
* narrowed in frames with no drop glue and/or no indirect drop glue.
*)
let glue_callsz =
let word = local_slot Ast.TY_int in
let glue_fn =
mk_simple_ty_fn
(Array.init Abi.worst_case_glue_call_args (fun _ -> word))
in
rty_sz (indirect_call_args_referent_type cx 0 glue_fn Il.OpaqueTy)
in
let enter_frame id =
Stack.push (id, (Stack.create())) frame_stack;
htab_put cx.ctxt_frame_sizes id (SIZE_fixed 0L);
htab_put cx.ctxt_call_sizes id glue_callsz;
htab_put cx.ctxt_spill_fixups id (new_fixup "frame spill fixup");
htab_put cx.ctxt_frame_blocks id [];
update_frame_size ();
in
let leave_frame _ =
ignore (Stack.pop frame_stack);
in
let header_slot_ids hdr = Array.map (fun (sid,_) -> sid.id) hdr in
let visit_mod_item_pre n p i =
begin
match i.node.Ast.decl_item with
Ast.MOD_ITEM_fn f ->
enter_frame i.id;
layout_header i.id
(header_slot_ids f.Ast.fn_input_slots)
| Ast.MOD_ITEM_tag (hdr, _, _) when Array.length hdr <> 0 ->
enter_frame i.id;
layout_header i.id
(header_slot_ids hdr)
| Ast.MOD_ITEM_obj obj ->
enter_frame i.id;
let ids = header_slot_ids obj.Ast.obj_state in
layout_obj_state i.id ids;
Array.iter
(fun id -> htab_put cx.ctxt_slot_is_obj_state id ())
ids
| _ -> ()
end;
inner.Walk.visit_mod_item_pre n p i
in
let visit_mod_item_post n p i =
inner.Walk.visit_mod_item_post n p i;
begin
match i.node.Ast.decl_item with
Ast.MOD_ITEM_fn _
| Ast.MOD_ITEM_obj _ -> leave_frame ()
| Ast.MOD_ITEM_tag (hdr, _, _) when Array.length hdr <> 0 ->
leave_frame()
| _ -> ()
end
in
let visit_obj_fn_pre obj ident fn =
enter_frame fn.id;
layout_header fn.id
(header_slot_ids fn.node.Ast.fn_input_slots);
inner.Walk.visit_obj_fn_pre obj ident fn
in
let visit_obj_fn_post obj ident fn =
inner.Walk.visit_obj_fn_post obj ident fn;
leave_frame ()
in
let visit_obj_drop_pre obj b =
enter_frame b.id;
inner.Walk.visit_obj_drop_pre obj b
in
let visit_obj_drop_post obj b =
inner.Walk.visit_obj_drop_post obj b;
leave_frame ()
in
let visit_block_pre b =
if Hashtbl.mem cx.ctxt_block_is_loop_body b.id
then enter_frame b.id;
let (frame_id, frame_blocks) = Stack.top frame_stack in
let frame_spill = Hashtbl.find cx.ctxt_spill_fixups frame_id in
let spill_sz = SIZE_fixup_mem_sz frame_spill in
let callee_saves_sz = SIZE_fixed cx.ctxt_abi.Abi.abi_callee_saves_sz in
let info_sz = SIZE_fixed cx.ctxt_abi.Abi.abi_frame_info_sz in
let locals_off = add_sz spill_sz (add_sz info_sz callee_saves_sz) in
let off =
if Stack.is_empty frame_blocks
then locals_off
else
add_sz locals_off (rty_sz (frame_rty frame_blocks))
in
let block_slots = Stack.create() in
let frame_block_ids = Hashtbl.find cx.ctxt_frame_blocks frame_id in
Hashtbl.replace cx.ctxt_frame_blocks frame_id (b.id :: frame_block_ids);
layout_block block_slots off b;
Stack.push block_slots frame_blocks;
update_frame_size ();
inner.Walk.visit_block_pre b
in
let visit_block_post b =
inner.Walk.visit_block_post b;
if Hashtbl.mem cx.ctxt_block_is_loop_body b.id
then leave_frame();
(* FIXME (issue #27): In earlier versions of this file, multiple
* lexical blocks in the same frame would reuse space from one to
* the next so long as they were not nested; The (commented-out)
* code here supports that logic. Unfortunately since our marking
* and unwinding strategy is very simplistic for now (analogous to
* shadow stacks) we're going to give each lexical block in a frame
* its own space in the frame, even if they seem like they *should*
* be able to reuse space. This makes it possible to arrive at the
* frame and work out which variables are live (and which frame
* memory corresponds to them) w/o paying attention to the current
* pc in the function; a greatly-simplifying assumption.
*
* This is of course not optimal for the long term, but in the
* longer term we'll have time to form proper DWARF CFI
* records. We're in a hurry at the moment. *)
(*
let stk = Stack.top block_stacks in
ignore (Stack.pop stk)
*)
in
let visit_stmt_pre (s:Ast.stmt) : unit =
(* Call-size calculation. *)
begin
let callees =
match s.node with
Ast.STMT_call (_, lv, _)
| Ast.STMT_spawn (_, _, _, lv, _) -> [| lv |]
| Ast.STMT_check (_, calls) -> Array.map (fun (lv, _) -> lv) calls
| _ -> [| |]
in
Array.iter
begin
fun (callee:Ast.lval) ->
let lv_ty = lval_ty cx callee in
let abi = cx.ctxt_abi in
let static = lval_is_static cx callee in
let closure = if static then None else Some Il.OpaqueTy in
let n_ty_params =
if lval_base_is_item cx callee
then Array.length (lval_item cx callee).node.Ast.decl_params
else 0
in
let rty =
call_args_referent_type cx n_ty_params lv_ty closure
in
let sz = Il.referent_ty_size abi.Abi.abi_word_bits rty in
let frame_id = fst (Stack.top frame_stack) in
let curr = Hashtbl.find cx.ctxt_call_sizes frame_id in
log cx "extending frame #%d call size to %s"
(int_of_node frame_id) (string_of_size (max_sz curr sz));
Hashtbl.replace cx.ctxt_call_sizes frame_id (max_sz curr sz)
end
callees
end;
inner.Walk.visit_stmt_pre s
in
{ inner with
Walk.visit_mod_item_pre = visit_mod_item_pre;
Walk.visit_mod_item_post = visit_mod_item_post;
Walk.visit_obj_fn_pre = visit_obj_fn_pre;
Walk.visit_obj_fn_post = visit_obj_fn_post;
Walk.visit_obj_drop_pre = visit_obj_drop_pre;
Walk.visit_obj_drop_post = visit_obj_drop_post;
Walk.visit_stmt_pre = visit_stmt_pre;
Walk.visit_block_pre = visit_block_pre;
Walk.visit_block_post = visit_block_post }
;;
let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
let passes =
[|
(layout_visitor cx
Walk.empty_visitor)
|];
in
run_passes cx "layout" passes
cx.ctxt_sess.Session.sess_log_layout log crate
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

164
src/boot/me/loop.ml
View File

@ -1,164 +0,0 @@
(*
* Computes iterator-loop nesting depths and max depth of each function.
*)
open Semant;;
open Common;;
let log cx = Session.log "loop"
(should_log cx cx.ctxt_sess.Session.sess_log_loop)
cx.ctxt_sess.Session.sess_log_out
;;
type fn_ctxt = { current_depth: int; }
;;
let incr_depth (fcx:fn_ctxt) =
{ current_depth = fcx.current_depth + 1; }
;;
let decr_depth (fcx:fn_ctxt) =
{ current_depth = fcx.current_depth - 1; }
;;
let top_fcx = { current_depth = 0; }
;;
let loop_depth_visitor
(cx:ctxt)
(inner:Walk.visitor)
: Walk.visitor =
let (fcxs : fn_ctxt Stack.t) = Stack.create () in
let push_loop () =
let fcx = Stack.pop fcxs in
Stack.push (incr_depth fcx) fcxs
in
let pop_loop () =
let fcx = Stack.pop fcxs in
Stack.push (decr_depth fcx) fcxs
in
let visit_mod_item_pre
(ident:Ast.ident)
(ty_params:(Ast.ty_param identified) array)
(item:Ast.mod_item)
: unit =
Stack.push top_fcx fcxs;
inner.Walk.visit_mod_item_pre ident ty_params item
in
let visit_mod_item_post
(ident:Ast.ident)
(ty_params:(Ast.ty_param identified) array)
(item:Ast.mod_item)
: unit =
inner.Walk.visit_mod_item_post ident ty_params item;
ignore (Stack.pop fcxs);
in
let visit_obj_fn_pre
(obj:Ast.obj identified)
(ident:Ast.ident)
(fn:Ast.fn identified)
: unit =
Stack.push top_fcx fcxs;
inner.Walk.visit_obj_fn_pre obj ident fn
in
let visit_obj_fn_post
(obj:Ast.obj identified)
(ident:Ast.ident)
(fn:Ast.fn identified)
: unit =
inner.Walk.visit_obj_fn_pre obj ident fn;
ignore (Stack.pop fcxs)
in
let visit_obj_drop_pre
(obj:Ast.obj identified)
(b:Ast.block)
: unit =
Stack.push top_fcx fcxs;
inner.Walk.visit_obj_drop_pre obj b
in
let visit_obj_drop_post
(obj:Ast.obj identified)
(b:Ast.block)
: unit =
inner.Walk.visit_obj_drop_post obj b;
ignore (Stack.pop fcxs)
in
let visit_slot_identified_pre sloti =
let fcx = Stack.top fcxs in
htab_put cx.ctxt_slot_loop_depths sloti.id fcx.current_depth;
inner.Walk.visit_slot_identified_pre sloti
in
let visit_stmt_pre s =
let fcx = Stack.top fcxs in
htab_put cx.ctxt_stmt_loop_depths s.id fcx.current_depth;
begin
match s.node with
| Ast.STMT_for_each fe ->
htab_put cx.ctxt_block_is_loop_body fe.Ast.for_each_body.id ();
| _ -> ()
end;
inner.Walk.visit_stmt_pre s
in
let visit_block_pre b =
if Hashtbl.mem cx.ctxt_block_is_loop_body b.id
then push_loop ();
let fcx = Stack.top fcxs in
htab_put cx.ctxt_block_loop_depths b.id fcx.current_depth;
inner.Walk.visit_block_pre b
in
let visit_block_post b =
inner.Walk.visit_block_post b;
if Hashtbl.mem cx.ctxt_block_is_loop_body b.id
then pop_loop ()
in
{ inner with
Walk.visit_mod_item_pre = visit_mod_item_pre;
Walk.visit_mod_item_post = visit_mod_item_post;
Walk.visit_obj_fn_pre = visit_obj_fn_pre;
Walk.visit_obj_fn_post = visit_obj_fn_post;
Walk.visit_obj_drop_pre = visit_obj_drop_pre;
Walk.visit_obj_drop_post = visit_obj_drop_post;
Walk.visit_slot_identified_pre = visit_slot_identified_pre;
Walk.visit_stmt_pre = visit_stmt_pre;
Walk.visit_block_pre = visit_block_pre;
Walk.visit_block_post = visit_block_post }
;;
let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
let passes =
[|
(loop_depth_visitor cx
Walk.empty_visitor)
|]
in
run_passes cx "loop" passes
cx.ctxt_sess.Session.sess_log_loop log crate
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

935
src/boot/me/resolve.ml
View File

@ -1,935 +0,0 @@
open Semant;;
open Common;;
(*
* Resolution passes:
*
* - build multiple 'scope' hashtables mapping slot_key -> node_id
* - build single 'type inference' hashtable mapping node_id -> slot
*
* (note: not every slot is identified; only those that are declared
* in statements and/or can participate in local type inference.
* Those in function signatures are not, f.e. Also no type values
* are identified, though module items are. )
*
*)
exception Resolution_failure of (Ast.name * Ast.name) list
let log cx = Session.log "resolve"
(should_log cx cx.ctxt_sess.Session.sess_log_resolve)
cx.ctxt_sess.Session.sess_log_out
;;
let iflog cx thunk =
if (should_log cx cx.ctxt_sess.Session.sess_log_resolve)
then thunk ()
else ()
;;
let block_scope_forming_visitor
(cx:ctxt)
(inner:Walk.visitor)
: Walk.visitor =
let visit_block_pre b =
if not (Hashtbl.mem cx.ctxt_block_items b.id)
then htab_put cx.ctxt_block_items b.id (Hashtbl.create 0);
if not (Hashtbl.mem cx.ctxt_block_slots b.id)
then htab_put cx.ctxt_block_slots b.id (Hashtbl.create 0);
inner.Walk.visit_block_pre b
in
{ inner with Walk.visit_block_pre = visit_block_pre }
;;
let stmt_collecting_visitor
(cx:ctxt)
(inner:Walk.visitor)
: Walk.visitor =
let block_ids = Stack.create () in
let visit_block_pre (b:Ast.block) =
htab_put cx.ctxt_all_blocks b.id b.node;
Stack.push b.id block_ids;
inner.Walk.visit_block_pre b
in
let visit_block_post (b:Ast.block) =
inner.Walk.visit_block_post b;
ignore (Stack.pop block_ids)
in
let visit_for_block
((si:Ast.slot identified),(ident:Ast.ident))
(block_id:node_id)
: unit =
let slots = Hashtbl.find cx.ctxt_block_slots block_id in
let key = Ast.KEY_ident ident in
log cx "found decl of '%s' in for-loop block header" ident;
htab_put slots key si.id;
htab_put cx.ctxt_slot_keys si.id key
in
let visit_stmt_pre stmt =
begin
htab_put cx.ctxt_all_stmts stmt.id stmt;
match stmt.node with
Ast.STMT_decl d ->
begin
let bid = Stack.top block_ids in
let items = Hashtbl.find cx.ctxt_block_items bid in
let slots = Hashtbl.find cx.ctxt_block_slots bid in
let check_and_log_ident id ident =
if Hashtbl.mem items ident ||
Hashtbl.mem slots (Ast.KEY_ident ident)
then
err (Some id)
"duplicate declaration '%s' in block" ident
else
log cx "found decl of '%s' in block" ident
in
let check_and_log_tmp id tmp =
if Hashtbl.mem slots (Ast.KEY_temp tmp)
then
err (Some id)
"duplicate declaration of temp #%d in block"
(int_of_temp tmp)
else
log cx "found decl of temp #%d in block" (int_of_temp tmp)
in
let check_and_log_key id key =
match key with
Ast.KEY_ident i -> check_and_log_ident id i
| Ast.KEY_temp t -> check_and_log_tmp id t
in
match d with
Ast.DECL_mod_item (ident, item) ->
check_and_log_ident item.id ident;
htab_put items ident item.id
| Ast.DECL_slot (key, sid) ->
check_and_log_key sid.id key;
htab_put slots key sid.id;
htab_put cx.ctxt_slot_keys sid.id key
end
| Ast.STMT_for f ->
visit_for_block f.Ast.for_slot f.Ast.for_body.id
| Ast.STMT_for_each f ->
visit_for_block f.Ast.for_each_slot f.Ast.for_each_head.id
| Ast.STMT_alt_tag { Ast.alt_tag_arms = arms;
Ast.alt_tag_lval = _ } ->
let rec resolve_pat block pat =
match pat with
Ast.PAT_slot ({ id = slot_id; node = _ }, ident) ->
let slots = Hashtbl.find cx.ctxt_block_slots block.id in
let key = Ast.KEY_ident ident in
htab_put slots key slot_id;
htab_put cx.ctxt_slot_keys slot_id key
| Ast.PAT_tag (_, pats) -> Array.iter (resolve_pat block) pats
| Ast.PAT_lit _
| Ast.PAT_wild -> ()
in
Array.iter (fun { node = (p, b); id = _ } ->
resolve_pat b p) arms
| _ -> ()
end;
inner.Walk.visit_stmt_pre stmt
in
{ inner with
Walk.visit_block_pre = visit_block_pre;
Walk.visit_block_post = visit_block_post;
Walk.visit_stmt_pre = visit_stmt_pre }
;;
let all_item_collecting_visitor
(cx:ctxt)
(inner:Walk.visitor)
: Walk.visitor =
let items = Stack.create () in
let push_on_item_arg_list item_id arg_id =
let existing =
match htab_search cx.ctxt_frame_args item_id with
None -> []
| Some x -> x
in
htab_put cx.ctxt_slot_is_arg arg_id ();
Hashtbl.replace cx.ctxt_frame_args item_id (arg_id :: existing)
in
let note_header item_id header =
Array.iter
(fun (sloti,ident) ->
let key = Ast.KEY_ident ident in
htab_put cx.ctxt_slot_keys sloti.id key;
push_on_item_arg_list item_id sloti.id)
header;
in
let visit_mod_item_pre n p i =
Stack.push i.id items;
Array.iter (fun p -> htab_put cx.ctxt_all_defns p.id
(DEFN_ty_param p.node)) p;
htab_put cx.ctxt_all_defns i.id (DEFN_item i.node);
htab_put cx.ctxt_all_item_names i.id (path_to_name cx.ctxt_curr_path);
log cx "collected item #%d: %s" (int_of_node i.id) n;
begin
match i.node.Ast.decl_item with
Ast.MOD_ITEM_fn f ->
note_header i.id f.Ast.fn_input_slots;
| Ast.MOD_ITEM_obj ob ->
note_header i.id ob.Ast.obj_state;
| Ast.MOD_ITEM_tag (hdr, _, _) ->
note_header i.id hdr
| Ast.MOD_ITEM_type (_, Ast.TY_tag ttag) ->
Hashtbl.replace cx.ctxt_user_tag_names ttag.Ast.tag_id
(path_to_name cx.ctxt_curr_path)
| _ -> ()
end;
inner.Walk.visit_mod_item_pre n p i
in
let visit_mod_item_post n p i =
inner.Walk.visit_mod_item_post n p i;
ignore (Stack.pop items)
in
let visit_obj_fn_pre obj ident fn =
htab_put cx.ctxt_all_defns fn.id (DEFN_obj_fn (obj.id, fn.node));
htab_put cx.ctxt_all_item_names fn.id (path_to_name cx.ctxt_curr_path);
note_header fn.id fn.node.Ast.fn_input_slots;
inner.Walk.visit_obj_fn_pre obj ident fn
in
let visit_obj_drop_pre obj b =
htab_put cx.ctxt_all_defns b.id (DEFN_obj_drop obj.id);
htab_put cx.ctxt_all_item_names b.id (path_to_name cx.ctxt_curr_path);
inner.Walk.visit_obj_drop_pre obj b
in
let visit_stmt_pre s =
begin
match s.node with
Ast.STMT_for_each fe ->
let id = fe.Ast.for_each_body.id in
htab_put cx.ctxt_all_defns id
(DEFN_loop_body (Stack.top items));
htab_put cx.ctxt_all_item_names id
(path_to_name cx.ctxt_curr_path);
| _ -> ()
end;
inner.Walk.visit_stmt_pre s;
in
{ inner with
Walk.visit_mod_item_pre = visit_mod_item_pre;
Walk.visit_mod_item_post = visit_mod_item_post;
Walk.visit_obj_fn_pre = visit_obj_fn_pre;
Walk.visit_obj_drop_pre = visit_obj_drop_pre;
Walk.visit_stmt_pre = visit_stmt_pre; }
;;
let lookup_type_node_by_name
(cx:ctxt)
(scopes:scope list)
(name:Ast.name)
: node_id =
iflog cx (fun _ ->
log cx "lookup_simple_type_by_name %a"
Ast.sprintf_name name);
match lookup_by_name cx [] scopes name with
RES_failed name' -> raise (Resolution_failure [ name', name ])
| RES_ok (_, id) ->
match htab_search cx.ctxt_all_defns id with
Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_type _;
Ast.decl_params = _ })
| Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_obj _;
Ast.decl_params = _ })
| Some (DEFN_ty_param _) -> id
| _ ->
err None "Found non-type binding for %a"
Ast.sprintf_name name
;;
type recur_info =
{ recur_all_nodes: node_id list }
;;
let empty_recur_info =
{ recur_all_nodes = []; }
;;
let push_node r n =
{ recur_all_nodes = n :: r.recur_all_nodes }
let report_resolution_failure type_names =
let rec recur type_names str =
let stringify_pair (part, whole) =
if part = whole then
Printf.sprintf "'%a'" Ast.sprintf_name part
else
Printf.sprintf "'%a' in name '%a'" Ast.sprintf_name part
Ast.sprintf_name whole
in
match type_names with
[] -> bug () "no name in resolution failure"
| [ pair ] -> err None "unbound name %s%s" (stringify_pair pair) str
| pair::pairs ->
recur pairs
(Printf.sprintf " while resolving %s" (stringify_pair pair))
in
recur type_names ""
let rec lookup_type_by_name
?loc:loc
(cx:ctxt)
(scopes:scope list)
(recur:recur_info)
(name:Ast.name)
: ((scope list) * node_id * Ast.ty) =
iflog cx (fun _ ->
log cx "+++ lookup_type_by_name %a"
Ast.sprintf_name name);
match lookup_by_name ?loc:loc cx [] scopes name with
RES_failed name' -> raise (Resolution_failure [ name', name ])
| RES_ok (scopes', id) ->
let ty, params =
match htab_search cx.ctxt_all_defns id with
Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_type (_, t);
Ast.decl_params = params }) ->
(t, Array.map (fun p -> p.node) params)
| Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_obj ob;
Ast.decl_params = params }) ->
(Ast.TY_obj (ty_obj_of_obj ob),
Array.map (fun p -> p.node) params)
| Some (DEFN_ty_param (_, x)) ->
(Ast.TY_param x, [||])
| _ ->
err loc "Found non-type binding for %a"
Ast.sprintf_name name
in
let args =
match name with
Ast.NAME_ext (_, Ast.COMP_app (_, args)) -> args
| Ast.NAME_base (Ast.BASE_app (_, args)) -> args
| _ -> [| |]
in
let args =
iflog cx (fun _ -> log cx
"lookup_type_by_name %a resolving %d type args"
Ast.sprintf_name name
(Array.length args));
Array.mapi
begin
fun i t ->
let t =
resolve_type ?loc:loc cx scopes recur t
in
iflog cx (fun _ -> log cx
"lookup_type_by_name resolved arg %d to %a" i
Ast.sprintf_ty t);
t
end
args
in
iflog cx
begin
fun _ ->
log cx
"lookup_type_by_name %a found ty %a"
Ast.sprintf_name name Ast.sprintf_ty ty;
log cx "applying %d type args to %d params"
(Array.length args) (Array.length params);
log cx "params: %s"
(Fmt.fmt_to_str Ast.fmt_decl_params params);
log cx "args: %s"
(Fmt.fmt_to_str Ast.fmt_app_args args);
end;
let ty =
rebuild_ty_under_params ?node_id:loc cx None ty params args true
in
iflog cx (fun _ -> log cx "--- lookup_type_by_name %a ==> %a"
Ast.sprintf_name name
Ast.sprintf_ty ty);
(scopes', id, ty)
and resolve_type
?loc:loc
(cx:ctxt)
(scopes:(scope list))
(recur:recur_info)
(t:Ast.ty)
: Ast.ty =
let _ = iflog cx (fun _ -> log cx "+++ resolve_type %a" Ast.sprintf_ty t) in
let base = ty_fold_rebuild (fun t -> t) in
let ty_fold_named name =
let (scopes, node, t) =
lookup_type_by_name ?loc:loc cx scopes recur name
in
iflog cx (fun _ ->
log cx "resolved type name '%a' to item %d with ty %a"
Ast.sprintf_name name (int_of_node node)
Ast.sprintf_ty t);
if List.mem node recur.recur_all_nodes
then (err (Some node) "infinite recursive type definition: '%a'"
Ast.sprintf_name name)
else
let recur = push_node recur node in
iflog cx (fun _ -> log cx "recursively resolving type %a"
Ast.sprintf_ty t);
try
resolve_type ?loc:loc cx scopes recur t
with Resolution_failure names ->
raise (Resolution_failure ((name, name)::names))
in
let fold =
{ base with
ty_fold_named = ty_fold_named; }
in
let t' = fold_ty cx fold t in
iflog cx (fun _ ->
log cx "--- resolve_type %a ==> %a"
Ast.sprintf_ty t Ast.sprintf_ty t');
t'
;;
let type_resolving_visitor
(cx:ctxt)
(scopes:(scope list) ref)
(inner:Walk.visitor)
: Walk.visitor =
let tinfos = Hashtbl.create 0 in
let resolve_ty ?(loc=id_of_scope (List.hd (!scopes))) (t:Ast.ty) : Ast.ty =
try
resolve_type ~loc:loc cx (!scopes) empty_recur_info t
with Resolution_failure pairs ->
report_resolution_failure pairs
in
let resolve_slot (s:Ast.slot) : Ast.slot =
match s.Ast.slot_ty with
None -> s
| Some ty -> { s with Ast.slot_ty = Some (resolve_ty ty) }
in
let resolve_slot_identified
(s:Ast.slot identified)
: (Ast.slot identified) =
try
let slot = resolve_slot s.node in
{ s with node = slot }
with
Semant_err (None, e) -> raise (Semant_err ((Some s.id), e))
in
let visit_slot_identified_pre slot =
let slot = resolve_slot_identified slot in
htab_put cx.ctxt_all_defns slot.id (DEFN_slot slot.node);
iflog cx
(fun _ ->
log cx "collected resolved slot #%d with type %s"
(int_of_node slot.id)
(match slot.node.Ast.slot_ty with
None -> "??"
| Some t -> (Fmt.fmt_to_str Ast.fmt_ty t)));
inner.Walk.visit_slot_identified_pre slot
in
let visit_mod_item_pre id params item =
let resolve_and_store_type _ =
let t = ty_of_mod_item item in
let ty = resolve_ty ~loc:item.id t in
iflog cx
(fun _ ->
log cx "resolved item %s, type as %a" id Ast.sprintf_ty ty);
htab_put cx.ctxt_all_item_types item.id ty;
in
begin
try
match item.node.Ast.decl_item with
Ast.MOD_ITEM_type (_, ty) ->
let ty = resolve_ty ~loc:item.id ty in
iflog cx
(fun _ ->
log cx "resolved item %s, defining type %a"
id Ast.sprintf_ty ty);
htab_put cx.ctxt_all_type_items item.id ty;
htab_put cx.ctxt_all_item_types item.id Ast.TY_type;
if Hashtbl.mem cx.ctxt_all_item_names item.id then
Hashtbl.add cx.ctxt_user_type_names ty
(Hashtbl.find cx.ctxt_all_item_names item.id)
(*
* Don't resolve the "type" of a mod item; just resolve its
* members.
*)
| Ast.MOD_ITEM_mod _ -> ()
| Ast.MOD_ITEM_tag (slots, oid, n) ->
resolve_and_store_type ();
let tinfo =
htab_search_or_add
tinfos oid
(fun _ ->
{ tag_idents = Hashtbl.create 0;
tag_nums = Hashtbl.create 0; } )
in
let ttup =
Array.map
(fun (s,_) -> (slot_ty (resolve_slot_identified s).node))
slots
in
if not (Hashtbl.mem tinfo.tag_idents id)
then
begin
htab_put tinfo.tag_idents id (n, item.id, ttup);
htab_put tinfo.tag_nums n (id, item.id, ttup);
end
| _ -> resolve_and_store_type ()
with
Semant_err (None, e) -> raise (Semant_err ((Some item.id), e))
end;
inner.Walk.visit_mod_item_pre id params item
in
let visit_obj_fn_pre obj ident fn =
let fty = resolve_ty ~loc:fn.id (Ast.TY_fn (ty_fn_of_fn fn.node)) in
iflog cx
(fun _ ->
log cx "resolved obj fn %s as %a" ident Ast.sprintf_ty fty);
htab_put cx.ctxt_all_item_types fn.id fty;
inner.Walk.visit_obj_fn_pre obj ident fn
in
let visit_obj_drop_pre obj b =
let fty = mk_simple_ty_fn [| |] in
htab_put cx.ctxt_all_item_types b.id fty;
inner.Walk.visit_obj_drop_pre obj b
in
let visit_stmt_pre stmt =
begin
match stmt.node with
Ast.STMT_for_each fe ->
let id = fe.Ast.for_each_body.id in
let fty = mk_simple_ty_iter [| |] in
htab_put cx.ctxt_all_item_types id fty;
| Ast.STMT_copy (_, Ast.EXPR_unary (Ast.UNOP_cast t, _)) ->
let ty = resolve_ty t.node in
htab_put cx.ctxt_all_cast_types t.id ty
| _ -> ()
end;
inner.Walk.visit_stmt_pre stmt
in
let rebuilt_pexps = Hashtbl.create 0 in
let get_rebuilt_pexp p =
Hashtbl.find rebuilt_pexps p.id
in
let visit_pexp_post p =
inner.Walk.visit_pexp_post p;
let rebuild_plval pl =
match pl with
Ast.PLVAL_base (Ast.BASE_app (id, tys)) ->
Ast.PLVAL_base (Ast.BASE_app (id, Array.map resolve_ty tys))
| Ast.PLVAL_base _ -> pl
| Ast.PLVAL_ext_name (pexp, nc) ->
let pexp = get_rebuilt_pexp pexp in
let nc =
match nc with
Ast.COMP_ident _
| Ast.COMP_idx _ -> nc
| Ast.COMP_app (id, tys) ->
Ast.COMP_app (id, Array.map resolve_ty tys)
in
Ast.PLVAL_ext_name (pexp, nc)
| Ast.PLVAL_ext_pexp (a, b) ->
Ast.PLVAL_ext_pexp (get_rebuilt_pexp a,
get_rebuilt_pexp b)
| Ast.PLVAL_ext_deref p ->
Ast.PLVAL_ext_deref (get_rebuilt_pexp p)
in
let p =
match p.node with
Ast.PEXP_lval pl ->
let pl' = rebuild_plval pl in
iflog cx (fun _ -> log cx "rebuilt plval %a as %a (#%d)"
Ast.sprintf_plval pl Ast.sprintf_plval pl'
(int_of_node p.id));
{ p with node = Ast.PEXP_lval pl' }
| _ -> p
in
htab_put rebuilt_pexps p.id p
in
let visit_lval_pre lv =
let rec rebuild_lval' lv =
match lv with
Ast.LVAL_ext (base, ext) ->
let ext =
match ext with
Ast.COMP_deref
| Ast.COMP_named (Ast.COMP_ident _)
| Ast.COMP_named (Ast.COMP_idx _)
| Ast.COMP_atom (Ast.ATOM_literal _) -> ext
| Ast.COMP_atom (Ast.ATOM_lval lv) ->
Ast.COMP_atom (Ast.ATOM_lval (rebuild_lval lv))
| Ast.COMP_atom (Ast.ATOM_pexp _) ->
bug () "Resolve.rebuild_lval' on ATOM_pexp"
| Ast.COMP_named (Ast.COMP_app (ident, params)) ->
Ast.COMP_named
(Ast.COMP_app (ident, Array.map resolve_ty params))
in
Ast.LVAL_ext (rebuild_lval' base, ext)
| Ast.LVAL_base nb ->
let node =
match nb.node with
Ast.BASE_ident _
| Ast.BASE_temp _ -> nb.node
| Ast.BASE_app (ident, params) ->
Ast.BASE_app (ident, Array.map resolve_ty params)
in
Ast.LVAL_base {nb with node = node}
and rebuild_lval lv =
let id = lval_base_id lv in
let lv' = rebuild_lval' lv in
iflog cx (fun _ -> log cx "rebuilt lval %a as %a (#%d)"
Ast.sprintf_lval lv Ast.sprintf_lval lv'
(int_of_node id));
htab_put cx.ctxt_all_lvals id lv';
lv'
in
ignore (rebuild_lval lv);
inner.Walk.visit_lval_pre lv
in
let visit_crate_post c =
inner.Walk.visit_crate_post c;
Hashtbl.iter (fun k v -> Hashtbl.add cx.ctxt_all_tag_info k v) tinfos
in
{ inner with
Walk.visit_slot_identified_pre = visit_slot_identified_pre;
Walk.visit_mod_item_pre = visit_mod_item_pre;
Walk.visit_obj_fn_pre = visit_obj_fn_pre;
Walk.visit_obj_drop_pre = visit_obj_drop_pre;
Walk.visit_stmt_pre = visit_stmt_pre;
Walk.visit_lval_pre = visit_lval_pre;
Walk.visit_pexp_post = visit_pexp_post;
Walk.visit_crate_post = visit_crate_post }
;;
let lval_base_resolving_visitor
(cx:ctxt)
(scopes:(scope list) ref)
(inner:Walk.visitor)
: Walk.visitor =
let lookup_defn_by_ident id ident =
iflog cx
(fun _ -> log cx "looking up slot or item with ident '%s'" ident);
match lookup cx (!scopes) (Ast.KEY_ident ident) with
RES_failed _ -> err (Some id) "unresolved identifier '%s'" ident
| RES_ok (_, id) ->
((iflog cx (fun _ -> log cx "resolved to node id #%d"
(int_of_node id))); id)
in
let lookup_slot_by_temp id temp =
iflog cx (fun _ -> log cx "looking up temp slot #%d" (int_of_temp temp));
let res = lookup cx (!scopes) (Ast.KEY_temp temp) in
match res with
RES_failed _ -> err
(Some id) "unresolved temp node #%d" (int_of_temp temp)
| RES_ok (_, id) ->
(iflog cx
(fun _ -> log cx "resolved to node id #%d" (int_of_node id));
id)
in
let lookup_defn_by_name_base id nb =
match nb with
Ast.BASE_ident ident
| Ast.BASE_app (ident, _) -> lookup_defn_by_ident id ident
| Ast.BASE_temp temp -> lookup_slot_by_temp id temp
in
let visit_lval_pre lv =
let rec lookup_lval lv =
iflog cx (fun _ ->
log cx "looking up lval #%d"
(int_of_node (lval_base_id lv)));
match lv with
Ast.LVAL_ext (base, ext) ->
begin
lookup_lval base;
match ext with
Ast.COMP_atom (Ast.ATOM_lval lv') -> lookup_lval lv'
| _ -> ()
end
| Ast.LVAL_base nb ->
let defn_id = lookup_defn_by_name_base nb.id nb.node in
iflog cx (fun _ -> log cx "resolved lval #%d to defn #%d"
(int_of_node nb.id) (int_of_node defn_id));
htab_put cx.ctxt_lval_base_id_to_defn_base_id nb.id defn_id
in
(*
* The point here is just to tickle the reference-a-name machinery in
* lookup that makes sure that all and only those items referenced get
* processed by later stages. An lval that happens to be an item will
* mark the item in question here.
*)
let reference_any_name lv =
let rec lval_is_name lv =
match lv with
Ast.LVAL_base {node = Ast.BASE_ident _; id = _}
| Ast.LVAL_base {node = Ast.BASE_app _; id = _} -> true
| Ast.LVAL_ext (lv', Ast.COMP_named (Ast.COMP_ident _))
| Ast.LVAL_ext (lv', Ast.COMP_named (Ast.COMP_app _))
-> lval_is_name lv'
| _ -> false
in
if lval_is_name lv && lval_base_is_item cx lv
then ignore (lookup_by_name cx [] (!scopes) (lval_to_name lv))
in
lookup_lval lv;
reference_any_name lv;
inner.Walk.visit_lval_pre lv
in
let visit_pexp_pre p =
begin
match p.node with
Ast.PEXP_lval pl ->
begin
match pl with
(Ast.PLVAL_base (Ast.BASE_ident ident))
| (Ast.PLVAL_base (Ast.BASE_app (ident, _))) ->
let id = lookup_defn_by_ident p.id ident in
iflog cx
(fun _ ->
log cx "resolved plval %a = #%d to defn #%d"
Ast.sprintf_plval pl
(int_of_node p.id) (int_of_node id));
(* Record the pexp -> defn mapping. *)
htab_put cx.ctxt_lval_base_id_to_defn_base_id p.id id;
(* Tickle the referenced-ness table if it's an item. *)
if defn_id_is_item cx id
then ignore (lookup_by_name cx [] (!scopes)
(plval_to_name pl))
| _ -> ()
end
| _ -> ()
end;
inner.Walk.visit_pexp_pre p
in
{ inner with
Walk.visit_lval_pre = visit_lval_pre;
Walk.visit_pexp_pre = visit_pexp_pre
};
;;
let pattern_resolving_visitor
(cx:ctxt)
(inner:Walk.visitor)
: Walk.visitor =
let not_tag_ctor nm id : unit =
err (Some id) "'%s' is not a tag constructor" (string_of_name nm)
in
let resolve_pat_tag
(name:Ast.name)
(id:node_id)
(pats:Ast.pat array)
(tag_ctor_id:node_id)
: unit =
(* NB this isn't really the proper tag type, since we aren't applying any
* type parameters from the tag constructor in the pattern, but since we
* are only looking at the fact that it's a tag-like type at all, and
* asking for its arity, it doesn't matter that the possibly parametric
* tag type has its parameters unbound here. *)
let tag_ty =
match Hashtbl.find cx.ctxt_all_item_types tag_ctor_id with
Ast.TY_tag t -> Ast.TY_tag t
| ft -> fn_output_ty ft
in
begin
match tag_ty with
Ast.TY_tag ttag ->
let ident =
match name with
Ast.NAME_ext (_, Ast.COMP_ident id)
| Ast.NAME_ext (_, Ast.COMP_app (id, _))
| Ast.NAME_base (Ast.BASE_ident id)
| Ast.NAME_base (Ast.BASE_app (id, _)) -> id
| _ -> err (Some id) "pattern-name ends in non-ident"
in
let tinfo = Hashtbl.find cx.ctxt_all_tag_info ttag.Ast.tag_id in
let (_, _, ttup) = Hashtbl.find tinfo.tag_idents ident in
let arity = Array.length ttup in
if (Array.length pats) != arity
then
err (Some id)
"tag pattern '%s' with wrong number of components"
(string_of_name name)
else ()
| _ -> not_tag_ctor name id
end
in
let resolve_arm { node = arm; id = id } =
match fst arm with
Ast.PAT_tag (lval, pats) ->
let lval_nm = lval_to_name lval in
let lval_id = lval_base_id lval in
let tag_ctor_id = (lval_item ~node_id:id cx lval).id in
if defn_id_is_item cx tag_ctor_id
(* FIXME (issue #76): we should actually check here that the
* function is a tag value-ctor. For now this actually allows
* any function returning a tag type to pass as a tag
* pattern. *)
then resolve_pat_tag lval_nm lval_id pats tag_ctor_id
else not_tag_ctor lval_nm lval_id
| _ -> ()
in
let visit_stmt_pre stmt =
begin
match stmt.node with
Ast.STMT_alt_tag { Ast.alt_tag_lval = _;
Ast.alt_tag_arms = arms } ->
Array.iter resolve_arm arms
| _ -> ()
end;
inner.Walk.visit_stmt_pre stmt
in
{ inner with Walk.visit_stmt_pre = visit_stmt_pre }
;;
let export_referencing_visitor
(cx:ctxt)
(inner:Walk.visitor)
: Walk.visitor =
let visit_mod_item_pre id params item =
begin
match item.node.Ast.decl_item with
Ast.MOD_ITEM_mod (view, items) ->
let is_defining_mod =
(* auto-ref the default-export cases only if
* the containing mod is 'defining', meaning
* not-native / not-use
*)
not (Hashtbl.mem cx.ctxt_required_items item.id)
in
let reference _ item =
Hashtbl.replace cx.ctxt_node_referenced item.id ();
in
let reference_export e _ =
match e with
Ast.EXPORT_ident ident ->
let item = Hashtbl.find items ident in
reference ident item
| Ast.EXPORT_all_decls ->
if is_defining_mod
then Hashtbl.iter reference items
in
Hashtbl.iter reference_export view.Ast.view_exports
| _ -> ()
end;
inner.Walk.visit_mod_item_pre id params item
in
{ inner with Walk.visit_mod_item_pre = visit_mod_item_pre }
;;
let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
let (scopes:(scope list) ref) = ref [] in
let passes_0 =
[|
(block_scope_forming_visitor cx Walk.empty_visitor);
(stmt_collecting_visitor cx
(all_item_collecting_visitor cx
Walk.empty_visitor));
|]
in
let passes_1 =
[|
(scope_stack_managing_visitor scopes
(type_resolving_visitor cx scopes
(lval_base_resolving_visitor cx scopes
Walk.empty_visitor)));
|]
in
let passes_2 =
[|
(scope_stack_managing_visitor scopes
(pattern_resolving_visitor cx
Walk.empty_visitor));
export_referencing_visitor cx Walk.empty_visitor
|]
in
let log_flag = cx.ctxt_sess.Session.sess_log_resolve in
log cx "running primary resolve passes";
run_passes cx "resolve collect" passes_0 log_flag log crate;
log cx "running secondary resolve passes";
run_passes cx "resolve bind" passes_1 log_flag log crate;
log cx "running tertiary resolve passes";
run_passes cx "resolve patterns" passes_2 log_flag log crate;
iflog cx
begin
fun _ ->
Hashtbl.iter
begin
fun n _ ->
if defn_id_is_item cx n
then
log cx "referenced: %a"
Ast.sprintf_name
(Hashtbl.find cx.ctxt_all_item_names n)
end
cx.ctxt_node_referenced;
end;
(* Post-resolve, we can establish a tag cache. *)
cx.ctxt_tag_cache <- Some (Hashtbl.create 0);
cx.ctxt_rebuild_cache <- Some (Hashtbl.create 0)
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

2802
src/boot/me/semant.ml
View File

File diff suppressed because it is too large Load Diff

109
src/boot/me/simplify.ml
View File

@ -1,109 +0,0 @@
open Common;;
open Semant;;
let log cx =
Session.log
"simplify"
(should_log cx cx.Semant.ctxt_sess.Session.sess_log_simplify)
cx.Semant.ctxt_sess.Session.sess_log_out
let iflog cx thunk =
if (should_log cx cx.Semant.ctxt_sess.Session.sess_log_simplify)
then thunk ()
else ()
;;
let plval_const_marking_visitor
(cx:Semant.ctxt)
(inner:Walk.visitor)
: Walk.visitor =
let visit_pexp_pre pexp =
begin
match pexp.node with
Ast.PEXP_lval pl ->
begin
let id = lval_base_id_to_defn_base_id cx pexp.id in
let is_const =
if defn_id_is_item cx id
then match (get_item cx id).Ast.decl_item with
Ast.MOD_ITEM_const _ -> true
| _ -> false
else false
in
iflog cx (fun _ -> log cx "plval %a refers to %s"
Ast.sprintf_plval pl
(if is_const then "const item" else "non-const"));
htab_put cx.ctxt_plval_const pexp.id is_const
end
| _ -> ()
end;
inner.Walk.visit_pexp_pre pexp
in
let visit_pexp_post p =
inner.Walk.visit_pexp_post p;
iflog cx (fun _ -> log cx "pexp %a is %s"
Ast.sprintf_pexp p
(if pexp_is_const cx p
then "constant"
else "non-constant"))
in
{ inner with
Walk.visit_pexp_pre = visit_pexp_pre;
Walk.visit_pexp_post = visit_pexp_post;
}
;;
let pexp_simplifying_visitor
(_:Semant.ctxt)
(inner:Walk.visitor)
: Walk.visitor =
let walk_atom at =
match at with
Ast.ATOM_pexp _ ->
begin
(* FIXME: move desugaring code from frontend to here. *)
()
end
| _ -> ()
in
let visit_stmt_pre s =
begin
match s.node with
Ast.STMT_copy (_, Ast.EXPR_atom a) -> walk_atom a
| _ -> ()
end;
inner.Walk.visit_stmt_pre s;
in
{ inner with
Walk.visit_stmt_pre = visit_stmt_pre;
}
;;
let process_crate (cx:Semant.ctxt) (crate:Ast.crate) : unit =
let passes =
[|
(plval_const_marking_visitor cx Walk.empty_visitor);
(pexp_simplifying_visitor cx Walk.empty_visitor)
|]
in
let log_flag = cx.Semant.ctxt_sess.Session.sess_log_simplify in
Semant.run_passes cx "simplify" passes log_flag log crate
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

6367
src/boot/me/trans.ml
View File

File diff suppressed because it is too large Load Diff

251
src/boot/me/transutil.ml
View File

@ -1,251 +0,0 @@
open Common;;
open Semant;;
(* A note on GC:
*
* We employ -- or "will employ" when the last few pieces of it are done -- a
* "simple" precise, mark-sweep, single-generation, per-task (thereby
* preemptable and relatively quick) GC scheme on mutable memory.
*
* - For the sake of this note, call any box of 'state' effect a gc_val.
*
* - gc_vals come from the same malloc as all other values but undergo
* different storage management.
*
* - Every frame has a frame_glue_fns pointer in its fp[-1] slot, written on
* function-entry.
*
* - gc_vals have *three* extra words at their head, not one.
*
* - A pointer to a gc_val, however, points to the third of these three
* words. So a certain quantity of code can treat gc_vals the same way it
* would treat refcounted box vals.
*
* - The first word at the head of a gc_val is used as a refcount, as in
* non-gc allocations.
*
* - The (-1)st word at the head of a gc_val is a pointer to a tydesc,
* with the low bit of that pointer used as a mark bit.
*
* - The (-2)nd word at the head of a gc_val is a linked-list pointer to the
* gc_val that was allocated (temporally) just before it. Following this
* list traces through all the currently active gc_vals in a task.
*
* - The task has a gc_alloc_chain field that points to the most-recent
* gc_val allocated.
*
* - GC glue has two phases, mark and sweep:
*
* - The mark phase walks down the frame chain, like the unwinder. It calls
* each frame's mark glue as it's passing through. This will mark all the
* reachable parts of the task's gc_vals.
*
* - The sweep phase walks down the task's gc_alloc_chain checking to see
* if each allocation has been marked. If marked, it has its mark-bit
* reset and the sweep passes it by. If unmarked, it has its tydesc
* free_glue called on its body, and is unlinked from the chain. The
* free-glue will cause the allocation to (recursively) drop all of its
* references and/or run dtors.
*
* - Note that there is no "special gc state" at work here; the task looks
* like it's running normal code that happens to not perform any gc_val
* allocation. Mark-bit twiddling is open-coded into all the mark
* functions, which know their contents; we only have to do O(frames)
* indirect calls to mark, the rest are static. Sweeping costs O(gc-heap)
* indirect calls, unfortunately, because the set of sweep functions to
* call is arbitrary based on allocation order.
*)
type deref_ctrl =
DEREF_one_box
| DEREF_all_boxes
| DEREF_none
;;
type mem_ctrl =
MEM_rc_opaque
| MEM_rc_struct
| MEM_gc
| MEM_interior
;;
type clone_ctrl =
CLONE_none
| CLONE_chan of Il.cell
| CLONE_all of Il.cell
;;
type call_ctrl =
CALL_direct
| CALL_vtbl
| CALL_indirect
;;
type for_each_ctrl =
{
for_each_fixup: fixup;
for_each_depth: int;
}
;;
let word_sz (abi:Abi.abi) : int64 =
abi.Abi.abi_word_sz
;;
let word_n (abi:Abi.abi) (n:int) : int64 =
Int64.mul (word_sz abi) (Int64.of_int n)
;;
let word_bits (abi:Abi.abi) : Il.bits =
abi.Abi.abi_word_bits
;;
let word_ty_mach (abi:Abi.abi) : ty_mach =
match word_bits abi with
Il.Bits8 -> TY_u8
| Il.Bits16 -> TY_u16
| Il.Bits32 -> TY_u32
| Il.Bits64 -> TY_u64
;;
let word_ty_signed_mach (abi:Abi.abi) : ty_mach =
match word_bits abi with
Il.Bits8 -> TY_i8
| Il.Bits16 -> TY_i16
| Il.Bits32 -> TY_i32
| Il.Bits64 -> TY_i64
;;
let rec ty_mem_ctrl (cx:ctxt) (ty:Ast.ty) : mem_ctrl =
match ty with
Ast.TY_port _
| Ast.TY_chan _
| Ast.TY_task
| Ast.TY_str -> MEM_rc_opaque
| Ast.TY_vec _ ->
if type_has_state cx ty
then MEM_gc
else MEM_rc_opaque
| Ast.TY_box t ->
if type_has_state cx t
then MEM_gc
else
if type_is_structured cx t
then MEM_rc_struct
else MEM_rc_opaque
| Ast.TY_mutable t
| Ast.TY_constrained (t, _) ->
ty_mem_ctrl cx t
| _ ->
MEM_interior
;;
let slot_mem_ctrl (cx:ctxt) (slot:Ast.slot) : mem_ctrl =
match slot.Ast.slot_mode with
Ast.MODE_alias -> MEM_interior
| Ast.MODE_local ->
ty_mem_ctrl cx (slot_ty slot)
;;
let iter_block_slots
(cx:Semant.ctxt)
(block_id:node_id)
(fn:Ast.slot_key -> node_id -> Ast.slot -> unit)
: unit =
let block_slots = Hashtbl.find cx.ctxt_block_slots block_id in
Hashtbl.iter
begin
fun key slot_id ->
let slot = get_slot cx slot_id in
fn key slot_id slot
end
block_slots
;;
let iter_frame_slots
(cx:Semant.ctxt)
(frame_id:node_id)
(fn:Ast.slot_key -> node_id -> Ast.slot -> unit)
: unit =
let blocks = Hashtbl.find cx.ctxt_frame_blocks frame_id in
List.iter (fun block -> iter_block_slots cx block fn) blocks
;;
let iter_arg_slots
(cx:Semant.ctxt)
(frame_id:node_id)
(fn:Ast.slot_key -> node_id -> Ast.slot -> unit)
: unit =
match htab_search cx.ctxt_frame_args frame_id with
None -> ()
| Some ls ->
List.iter
begin
fun slot_id ->
let key = Hashtbl.find cx.ctxt_slot_keys slot_id in
let slot = get_slot cx slot_id in
fn key slot_id slot
end
ls
;;
let iter_frame_and_arg_slots
(cx:Semant.ctxt)
(frame_id:node_id)
(fn:Ast.slot_key -> node_id -> Ast.slot -> unit)
: unit =
iter_frame_slots cx frame_id fn;
iter_arg_slots cx frame_id fn;
;;
let next_power_of_two (x:int64) : int64 =
let xr = ref (Int64.sub x 1L) in
xr := Int64.logor (!xr) (Int64.shift_right_logical (!xr) 1);
xr := Int64.logor (!xr) (Int64.shift_right_logical (!xr) 2);
xr := Int64.logor (!xr) (Int64.shift_right_logical (!xr) 4);
xr := Int64.logor (!xr) (Int64.shift_right_logical (!xr) 8);
xr := Int64.logor (!xr) (Int64.shift_right_logical (!xr) 16);
xr := Int64.logor (!xr) (Int64.shift_right_logical (!xr) 32);
Int64.add 1L (!xr)
;;
let iter_tup_parts
(get_element_ptr:'a -> int -> 'a)
(dst_ptr:'a)
(src_ptr:'a)
(tys:Ast.ty_tup)
(f:'a -> 'a -> Ast.ty -> unit)
: unit =
Array.iteri
begin
fun i ty ->
f (get_element_ptr dst_ptr i)
(get_element_ptr src_ptr i)
ty
end
tys
;;
let iter_rec_parts
(get_element_ptr:'a -> int -> 'a)
(dst_ptr:'a)
(src_ptr:'a)
(entries:Ast.ty_rec)
(f:'a -> 'a -> Ast.ty -> unit)
: unit =
iter_tup_parts get_element_ptr dst_ptr src_ptr
(Array.map snd entries) f
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

1453
src/boot/me/type.ml
View File

File diff suppressed because it is too large Load Diff

1537
src/boot/me/typestate.ml
View File

File diff suppressed because it is too large Load Diff

729
src/boot/me/walk.ml
View File

@ -1,729 +0,0 @@
open Common;;
(*
* The purpose of this module is just to decouple the AST from the
* various passes that are interested in visiting "parts" of it.
* If the AST shifts, we have better odds of the shift only affecting
* this module rather than all of its clients. Similarly if the
* clients only need to visit part, they only have to define the
* part of the walk they're interested in, making it cheaper to define
* multiple passes.
*)
type visitor =
{
visit_stmt_pre: Ast.stmt -> unit;
visit_stmt_post: Ast.stmt -> unit;
visit_slot_identified_pre: (Ast.slot identified) -> unit;
visit_slot_identified_post: (Ast.slot identified) -> unit;
visit_expr_pre: Ast.expr -> unit;
visit_expr_post: Ast.expr -> unit;
visit_pexp_pre: Ast.pexp -> unit;
visit_pexp_post: Ast.pexp -> unit;
visit_ty_pre: Ast.ty -> unit;
visit_ty_post: Ast.ty -> unit;
visit_constr_pre: node_id option -> Ast.constr -> unit;
visit_constr_post: node_id option -> Ast.constr -> unit;
visit_pat_pre: Ast.pat -> unit;
visit_pat_post: Ast.pat -> unit;
visit_block_pre: Ast.block -> unit;
visit_block_post: Ast.block -> unit;
visit_lit_pre: Ast.lit -> unit;
visit_lit_post: Ast.lit -> unit;
visit_lval_pre: Ast.lval -> unit;
visit_lval_post: Ast.lval -> unit;
visit_plval_pre: Ast.plval -> unit;
visit_plval_post: Ast.plval -> unit;
visit_mod_item_pre:
(Ast.ident
-> ((Ast.ty_param identified) array)
-> Ast.mod_item
-> unit);
visit_mod_item_post:
(Ast.ident
-> ((Ast.ty_param identified) array)
-> Ast.mod_item
-> unit);
visit_obj_fn_pre:
(Ast.obj identified) -> Ast.ident -> (Ast.fn identified) -> unit;
visit_obj_fn_post:
(Ast.obj identified) -> Ast.ident -> (Ast.fn identified) -> unit;
visit_obj_drop_pre:
(Ast.obj identified) -> Ast.block -> unit;
visit_obj_drop_post:
(Ast.obj identified) -> Ast.block -> unit;
visit_crate_pre: Ast.crate -> unit;
visit_crate_post: Ast.crate -> unit;
}
;;
let empty_visitor =
{ visit_stmt_pre = (fun _ -> ());
visit_stmt_post = (fun _ -> ());
visit_slot_identified_pre = (fun _ -> ());
visit_slot_identified_post = (fun _ -> ());
visit_expr_pre = (fun _ -> ());
visit_expr_post = (fun _ -> ());
visit_pexp_pre = (fun _ -> ());
visit_pexp_post = (fun _ -> ());
visit_ty_pre = (fun _ -> ());
visit_ty_post = (fun _ -> ());
visit_constr_pre = (fun _ _ -> ());
visit_constr_post = (fun _ _ -> ());
visit_pat_pre = (fun _ -> ());
visit_pat_post = (fun _ -> ());
visit_block_pre = (fun _ -> ());
visit_block_post = (fun _ -> ());
visit_lit_pre = (fun _ -> ());
visit_lit_post = (fun _ -> ());
visit_lval_pre = (fun _ -> ());
visit_lval_post = (fun _ -> ());
visit_plval_pre = (fun _ -> ());
visit_plval_post = (fun _ -> ());
visit_mod_item_pre = (fun _ _ _ -> ());
visit_mod_item_post = (fun _ _ _ -> ());
visit_obj_fn_pre = (fun _ _ _ -> ());
visit_obj_fn_post = (fun _ _ _ -> ());
visit_obj_drop_pre = (fun _ _ -> ());
visit_obj_drop_post = (fun _ _ -> ());
visit_crate_pre = (fun _ -> ());
visit_crate_post = (fun _ -> ()); }
;;
let path_managing_visitor
(path:Ast.name_component Stack.t)
(inner:visitor)
: visitor =
let visit_mod_item_pre ident params item =
Stack.push (Ast.COMP_ident ident) path;
inner.visit_mod_item_pre ident params item
in
let visit_mod_item_post ident params item =
inner.visit_mod_item_post ident params item;
ignore (Stack.pop path)
in
let visit_obj_fn_pre obj ident fn =
Stack.push (Ast.COMP_ident ident) path;
inner.visit_obj_fn_pre obj ident fn
in
let visit_obj_fn_post obj ident fn =
inner.visit_obj_fn_post obj ident fn;
ignore (Stack.pop path)
in
let visit_obj_drop_pre obj b =
Stack.push (Ast.COMP_ident "drop") path;
inner.visit_obj_drop_pre obj b
in
let visit_obj_drop_post obj b =
inner.visit_obj_drop_post obj b;
ignore (Stack.pop path)
in
{ inner with
visit_mod_item_pre = visit_mod_item_pre;
visit_mod_item_post = visit_mod_item_post;
visit_obj_fn_pre = visit_obj_fn_pre;
visit_obj_fn_post = visit_obj_fn_post;
visit_obj_drop_pre = visit_obj_drop_pre;
visit_obj_drop_post = visit_obj_drop_post;
}
;;
let walk_bracketed
(pre:'a -> unit)
(children:unit -> unit)
(post:'a -> unit)
(x:'a)
: unit =
begin
pre x;
children ();
post x
end
;;
let walk_option
(walker:'a -> unit)
(opt:'a option)
: unit =
match opt with
None -> ()
| Some v -> walker v
;;
let rec walk_crate
(v:visitor)
(crate:Ast.crate)
: unit =
walk_bracketed
v.visit_crate_pre
(fun _ -> walk_mod_items v (snd crate.node.Ast.crate_items))
v.visit_crate_post
crate
and walk_mod_items
(v:visitor)
(items:Ast.mod_items)
: unit =
Hashtbl.iter (walk_mod_item v) items
and walk_mod_item
(v:visitor)
(name:Ast.ident)
(item:Ast.mod_item)
: unit =
let children _ =
match item.node.Ast.decl_item with
Ast.MOD_ITEM_type (_, ty) -> walk_ty v ty
| Ast.MOD_ITEM_const (ty, e) ->
walk_ty v ty;
walk_option (walk_expr v) e
| Ast.MOD_ITEM_fn f -> walk_fn v f item.id
| Ast.MOD_ITEM_tag (hdr, _, _) ->
walk_header_slots v hdr
| Ast.MOD_ITEM_mod (_, items) ->
walk_mod_items v items
| Ast.MOD_ITEM_obj ob ->
walk_header_slots v ob.Ast.obj_state;
walk_constrs v (Some item.id) ob.Ast.obj_constrs;
let oid = { node = ob; id = item.id } in
Hashtbl.iter (walk_obj_fn v oid) ob.Ast.obj_fns;
match ob.Ast.obj_drop with
None -> ()
| Some d ->
v.visit_obj_drop_pre oid d;
walk_block v d;
v.visit_obj_drop_post oid d
in
walk_bracketed
(v.visit_mod_item_pre name item.node.Ast.decl_params)
children
(v.visit_mod_item_post name item.node.Ast.decl_params)
item
and walk_ty_tup v ttup = Array.iter (walk_ty v) ttup
and walk_ty
(v:visitor)
(ty:Ast.ty)
: unit =
let children _ =
match ty with
Ast.TY_tup ttup -> walk_ty_tup v ttup
| Ast.TY_vec s -> walk_ty v s
| Ast.TY_rec trec -> Array.iter (fun (_, s) -> walk_ty v s) trec
| Ast.TY_fn tfn -> walk_ty_fn v tfn
| Ast.TY_obj (_, fns) ->
Hashtbl.iter (fun _ tfn -> walk_ty_fn v tfn) fns
| Ast.TY_chan t -> walk_ty v t
| Ast.TY_port t -> walk_ty v t
| Ast.TY_constrained (t,cs) ->
begin
walk_ty v t;
walk_constrs v None cs
end
| Ast.TY_named _ -> ()
| Ast.TY_param _ -> ()
| Ast.TY_tag _ -> ()
| Ast.TY_native _ -> ()
| Ast.TY_mach _ -> ()
| Ast.TY_type -> ()
| Ast.TY_str -> ()
| Ast.TY_char -> ()
| Ast.TY_int -> ()
| Ast.TY_uint -> ()
| Ast.TY_bool -> ()
| Ast.TY_nil -> ()
| Ast.TY_task -> ()
| Ast.TY_any -> ()
| Ast.TY_box m -> walk_ty v m
| Ast.TY_mutable m -> walk_ty v m
in
walk_bracketed
v.visit_ty_pre
children
v.visit_ty_post
ty
and walk_ty_sig
(v:visitor)
(s:Ast.ty_sig)
: unit =
begin
Array.iter (walk_slot v) s.Ast.sig_input_slots;
walk_constrs v None s.Ast.sig_input_constrs;
walk_slot v s.Ast.sig_output_slot;
end
and walk_ty_fn
(v:visitor)
(tfn:Ast.ty_fn)
: unit =
let (tsig, _) = tfn in
walk_ty_sig v tsig
and walk_constrs
(v:visitor)
(formal_base:node_id option)
(cs:Ast.constrs)
: unit =
Array.iter (walk_constr v formal_base) cs
and walk_check_calls
(v:visitor)
(calls:Ast.check_calls)
: unit =
Array.iter
begin
fun (f, args) ->
walk_lval v f;
Array.iter (walk_atom v) args
end
calls
and walk_constr
(v:visitor)
(formal_base:node_id option)
(c:Ast.constr)
: unit =
walk_bracketed
(v.visit_constr_pre formal_base)
(fun _ -> ())
(v.visit_constr_post formal_base)
c
and walk_header_slots
(v:visitor)
(hslots:Ast.header_slots)
: unit =
Array.iter (fun (s,_) -> walk_slot_identified v s) hslots
and walk_header_tup
(v:visitor)
(htup:Ast.header_tup)
: unit =
Array.iter (walk_slot_identified v) htup
and walk_obj_fn
(v:visitor)
(obj:Ast.obj identified)
(ident:Ast.ident)
(f:Ast.fn identified)
: unit =
v.visit_obj_fn_pre obj ident f;
walk_fn v f.node f.id;
v.visit_obj_fn_post obj ident f
and walk_fn
(v:visitor)
(f:Ast.fn)
(id:node_id)
: unit =
walk_header_slots v f.Ast.fn_input_slots;
walk_constrs v (Some id) f.Ast.fn_input_constrs;
walk_slot_identified v f.Ast.fn_output_slot;
walk_block v f.Ast.fn_body
and walk_slot_identified
(v:visitor)
(s:Ast.slot identified)
: unit =
walk_bracketed
v.visit_slot_identified_pre
(fun _ -> walk_slot v s.node)
v.visit_slot_identified_post
s
and walk_slot
(v:visitor)
(s:Ast.slot)
: unit =
walk_option (walk_ty v) s.Ast.slot_ty
and walk_stmt
(v:visitor)
(s:Ast.stmt)
: unit =
let walk_stmt_for
(s:Ast.stmt_for)
: unit =
let (si,_) = s.Ast.for_slot in
let lv = s.Ast.for_seq in
walk_slot_identified v si;
walk_lval v lv;
walk_block v s.Ast.for_body
in
let walk_stmt_for_each
(s:Ast.stmt_for_each)
: unit =
let (si,_) = s.Ast.for_each_slot in
let (f,az) = s.Ast.for_each_call in
walk_slot_identified v si;
walk_lval v f;
Array.iter (walk_atom v) az;
walk_block v s.Ast.for_each_head
in
let walk_stmt_while
(s:Ast.stmt_while)
: unit =
let (ss,e) = s.Ast.while_lval in
Array.iter (walk_stmt v) ss;
walk_expr v e;
walk_block v s.Ast.while_body
in
let children _ =
match s.node with
Ast.STMT_log a | Ast.STMT_log_err a ->
walk_atom v a
| Ast.STMT_new_rec (lv, atab, base) ->
walk_lval v lv;
Array.iter (fun (_, _, a) -> walk_atom v a) atab;
walk_option (walk_lval v) base;
| Ast.STMT_new_vec (lv, _, atoms) ->
walk_lval v lv;
Array.iter (walk_atom v) atoms
| Ast.STMT_new_tup (lv, mut_atoms) ->
walk_lval v lv;
Array.iter (fun (_, atom) -> walk_atom v atom) mut_atoms
| Ast.STMT_new_str (lv, _) ->
walk_lval v lv
| Ast.STMT_new_port lv ->
walk_lval v lv
| Ast.STMT_new_chan (chan,port) ->
walk_option (walk_lval v) port;
walk_lval v chan;
| Ast.STMT_new_box (dst, _, src) ->
walk_lval v dst;
walk_atom v src
| Ast.STMT_for f ->
walk_stmt_for f
| Ast.STMT_for_each f ->
walk_stmt_for_each f
| Ast.STMT_while w ->
walk_stmt_while w
| Ast.STMT_do_while w ->
walk_stmt_while w
| Ast.STMT_if i ->
begin
walk_expr v i.Ast.if_test;
walk_block v i.Ast.if_then;
walk_option (walk_block v) i.Ast.if_else
end
| Ast.STMT_block b ->
walk_block v b
| Ast.STMT_copy (lv,e) ->
walk_lval v lv;
walk_expr v e
| Ast.STMT_copy_binop (lv,_,a) ->
walk_lval v lv;
walk_atom v a
| Ast.STMT_call (dst,f,az) ->
walk_lval v dst;
walk_lval v f;
Array.iter (walk_atom v) az
| Ast.STMT_bind (dst, f, az) ->
walk_lval v dst;
walk_lval v f;
Array.iter (walk_opt_atom v) az
| Ast.STMT_spawn (dst,_,_,p,az) ->
walk_lval v dst;
walk_lval v p;
Array.iter (walk_atom v) az
| Ast.STMT_ret ao ->
walk_option (walk_atom v) ao
| Ast.STMT_put at ->
walk_option (walk_atom v) at
| Ast.STMT_put_each (lv, ats) ->
walk_lval v lv;
Array.iter (walk_atom v) ats
(* FIXME (issue #86): this should have a param array, and invoke the
* visitors.
*)
| Ast.STMT_decl (Ast.DECL_mod_item (id, mi)) ->
walk_mod_item v id mi
| Ast.STMT_decl (Ast.DECL_slot (_, slot)) ->
walk_slot_identified v slot
| Ast.STMT_break | Ast.STMT_cont | Ast.STMT_yield | Ast.STMT_fail ->
()
| Ast.STMT_join task ->
walk_lval v task
| Ast.STMT_send (dst,src) ->
walk_lval v dst;
walk_lval v src
| Ast.STMT_recv (dst,src) ->
walk_lval v dst;
walk_lval v src
| Ast.STMT_be (lv, ats) ->
walk_lval v lv;
Array.iter (walk_atom v) ats
| Ast.STMT_check_expr e ->
walk_expr v e
| Ast.STMT_check (cs, calls) ->
walk_constrs v None cs;
walk_check_calls v calls
| Ast.STMT_check_if (cs,calls,b) ->
walk_constrs v None cs;
walk_check_calls v calls;
walk_block v b
| Ast.STMT_prove cs ->
walk_constrs v None cs
| Ast.STMT_alt_tag
{ Ast.alt_tag_lval = lval; Ast.alt_tag_arms = arms } ->
walk_lval v lval;
let walk_arm { node = (pat, block); id=_ } =
walk_pat v pat;
walk_block v block
in
Array.iter walk_arm arms
(* FIXME (issue #20): finish this as needed. *)
| Ast.STMT_slice _
| Ast.STMT_note _
| Ast.STMT_alt_type _
| Ast.STMT_alt_port _ ->
unimpl (Some s.id) "statement type in Walk.walk_stmt"
in
walk_bracketed
v.visit_stmt_pre
children
v.visit_stmt_post
s
and walk_unop
(v:visitor)
(unop:Ast.unop)
: unit =
match unop with
Ast.UNOP_cast tyi ->
walk_ty v tyi.node
| _ -> ()
and walk_expr
(v:visitor)
(e:Ast.expr)
: unit =
let children _ =
match e with
Ast.EXPR_binary (_,aa,ab) ->
walk_atom v aa;
walk_atom v ab
| Ast.EXPR_unary (unop,a) ->
walk_atom v a;
walk_unop v unop
| Ast.EXPR_atom a ->
walk_atom v a
in
walk_bracketed
v.visit_expr_pre
children
v.visit_expr_post
e
and walk_pexp
(v:visitor)
(p:Ast.pexp)
: unit =
let children _ =
match p.node with
Ast.PEXP_call (pexp, pexps) ->
walk_pexp v pexp;
Array.iter (walk_pexp v) pexps
| Ast.PEXP_spawn (_, _, pexp)
| Ast.PEXP_box (_, pexp) ->
walk_pexp v pexp;
| Ast.PEXP_unop (unop, pexp) ->
walk_pexp v pexp;
walk_unop v unop
| Ast.PEXP_bind (pexp, pexp_opts) ->
walk_pexp v pexp;
Array.iter (walk_option (walk_pexp v)) pexp_opts
| Ast.PEXP_rec (elts, base) ->
let walk_elt (_, _, pexp) = walk_pexp v pexp in
Array.iter walk_elt elts;
walk_option (walk_pexp v) base
| Ast.PEXP_tup elts ->
let walk_elt (_, pexp) = walk_pexp v pexp in
Array.iter walk_elt elts
| Ast.PEXP_vec (_, pexps)
| Ast.PEXP_custom (_, pexps, _) ->
Array.iter (walk_pexp v) pexps
| Ast.PEXP_chan po ->
walk_option (walk_pexp v) po
| Ast.PEXP_binop (_, a, b)
| Ast.PEXP_lazy_and (a, b)
| Ast.PEXP_lazy_or (a, b) ->
walk_pexp v a;
walk_pexp v b
| Ast.PEXP_lval pl -> walk_plval v pl
| Ast.PEXP_lit lit -> walk_lit v lit
| Ast.PEXP_port
| Ast.PEXP_str _ -> ()
in
walk_bracketed
v.visit_pexp_pre
children
v.visit_pexp_post
p
and walk_plval
(v:visitor)
(p:Ast.plval)
: unit =
let children _ =
match p with
| Ast.PLVAL_base (Ast.BASE_app (_, tys)) ->
Array.iter (walk_ty v) tys
| Ast.PLVAL_base _ -> ()
| Ast.PLVAL_ext_name (pexp, _) ->
walk_pexp v pexp
| Ast.PLVAL_ext_pexp (a, b) ->
walk_pexp v a;
walk_pexp v b;
| Ast.PLVAL_ext_deref pexp ->
walk_pexp v pexp
in
walk_bracketed
v.visit_plval_pre
children
v.visit_plval_post
p
and walk_atom
(v:visitor)
(a:Ast.atom)
: unit =
match a with
Ast.ATOM_literal ls -> walk_lit v ls.node
| Ast.ATOM_lval lv -> walk_lval v lv
| Ast.ATOM_pexp p -> walk_pexp v p
and walk_opt_atom
(v:visitor)
(ao:Ast.atom option)
: unit =
match ao with
None -> ()
| Some a -> walk_atom v a
and walk_lit
(v:visitor)
(li:Ast.lit)
: unit =
walk_bracketed
v.visit_lit_pre
(fun _ -> ())
v.visit_lit_post
li
and walk_lval
(v:visitor)
(lv:Ast.lval)
: unit =
walk_bracketed
v.visit_lval_pre
(fun _ -> ())
v.visit_lval_post
lv
and walk_pat
(v:visitor)
(p:Ast.pat)
: unit =
let walk p =
match p with
Ast.PAT_lit lit -> walk_lit v lit
| Ast.PAT_tag (lv, pats) ->
walk_lval v lv;
Array.iter (walk_pat v) pats
| Ast.PAT_slot (si, _) -> walk_slot_identified v si
| Ast.PAT_wild -> ()
in
walk_bracketed
v.visit_pat_pre
(fun _ -> walk p)
v.visit_pat_post
p
and walk_block
(v:visitor)
(b:Ast.block)
: unit =
walk_bracketed
v.visit_block_pre
(fun _ -> (Array.iter (walk_stmt v) b.node))
v.visit_block_post
b
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

116
src/boot/util/bits.ml
View File

@ -1,116 +0,0 @@
type t = {
storage: int array;
nbits: int;
}
;;
let int_bits =
if max_int = (1 lsl 30) - 1
then 31
else 63
;;
let create nbits flag =
{ storage = Array.make (nbits / int_bits + 1) (if flag then lnot 0 else 0);
nbits = nbits }
;;
(*
* mutate v0 in place: v0.(i) <- v0.(i) op v1.(i), returning bool indicating
* whether any bits in v0 changed in the process.
*)
let process (op:int -> int -> int) (v0:t) (v1:t) : bool =
let changed = ref false in
assert (v0.nbits = v1.nbits);
assert ((Array.length v0.storage) = (Array.length v1.storage));
Array.iteri
begin
fun i w1 ->
let w0 = v0.storage.(i) in
let w0' = op w0 w1 in
if not (w0' = w0)
then changed := true;
v0.storage.(i) <- w0';
end
v1.storage;
!changed
;;
let union = process (lor) ;;
let intersect = process (land) ;;
let copy = process (fun _ w1 -> w1) ;;
let get (v:t) (i:int) : bool =
assert (i >= 0);
assert (i < v.nbits);
let w = i / int_bits in
let b = i mod int_bits in
let x = 1 land (v.storage.(w) lsr b) in
x = 1
;;
let equal (v1:t) (v0:t) : bool =
v0 = v1
;;
let clear (v:t) : unit =
for i = 0 to (Array.length v.storage) - 1
do
v.storage.(i) <- 0
done
;;
let invert (v:t) : unit =
for i = 0 to (Array.length v.storage) - 1
do
v.storage.(i) <- lnot v.storage.(i)
done
;;
(* dst = dst - src *)
let difference (dst:t) (src:t) : bool =
invert src;
let b = intersect dst src in
invert src;
b
;;
let set (v:t) (i:int) (x:bool) : unit =
assert (i >= 0);
assert (i < v.nbits);
let w = i / int_bits in
let b = i mod int_bits in
let w0 = v.storage.(w) in
let flag = 1 lsl b in
v.storage.(w) <-
if x
then w0 lor flag
else w0 land (lnot flag)
;;
let to_list (v:t) : int list =
if v.nbits = 0
then []
else
let accum = ref [] in
let word = ref v.storage.(0) in
for i = 0 to (v.nbits-1) do
if i mod int_bits = 0
then word := v.storage.(i / int_bits);
if (1 land (!word)) = 1
then accum := i :: (!accum);
word := (!word) lsr 1;
done;
!accum
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

823
src/boot/util/common.ml
View File

@ -1,823 +0,0 @@
(*
* This module goes near the *bottom* of the dependency DAG, and holds basic
* types shared across all phases of the compiler.
*)
type ('a, 'b) either = Left of 'a | Right of 'b
type filename = string
type pos = (filename * int * int)
type span = {lo: pos; hi: pos}
type node_id = Node of int
type temp_id = Temp of int
type opaque_id = Opaque of int
type constr_id = Constr of int
type crate_id = Crate of int
let int_of_node (Node i) = i
let int_of_temp (Temp i) = i
let int_of_opaque (Opaque i) = i
let int_of_constr (Constr i) = i
let int_of_common (Crate i) = i
type 'a identified = { node: 'a; id: node_id }
;;
let bug _ =
let k s = failwith s
in Printf.ksprintf k
;;
(* TODO: On some joyous day, remove me. *)
exception Not_implemented of ((node_id option) * string)
;;
exception Semant_err of ((node_id option) * string)
;;
let err (idopt:node_id option) =
let k s =
raise (Semant_err (idopt, s))
in
Printf.ksprintf k
;;
let unimpl (idopt:node_id option) =
let k s =
raise (Not_implemented (idopt, "unimplemented " ^ s))
in
Printf.ksprintf k
;;
(* Some ubiquitous low-level types. *)
type target =
Linux_x86_elf
| Win32_x86_pe
| MacOS_x86_macho
| FreeBSD_x86_elf
;;
type ty_mach =
TY_u8
| TY_u16
| TY_u32
| TY_u64
| TY_i8
| TY_i16
| TY_i32
| TY_i64
| TY_f32
| TY_f64
;;
let mach_is_integral (mach:ty_mach) : bool =
match mach with
TY_i8 | TY_i16 | TY_i32 | TY_i64
| TY_u8 | TY_u16 | TY_u32 | TY_u64 -> true
| TY_f32 | TY_f64 -> false
;;
let mach_is_signed (mach:ty_mach) : bool =
match mach with
TY_i8 | TY_i16 | TY_i32 | TY_i64 -> true
| TY_u8 | TY_u16 | TY_u32 | TY_u64
| TY_f32 | TY_f64 -> false
;;
let string_of_ty_mach (mach:ty_mach) : string =
match mach with
TY_u8 -> "u8"
| TY_u16 -> "u16"
| TY_u32 -> "u32"
| TY_u64 -> "u64"
| TY_i8 -> "i8"
| TY_i16 -> "i16"
| TY_i32 -> "i32"
| TY_i64 -> "i64"
| TY_f32 -> "f32"
| TY_f64 -> "f64"
;;
let bytes_of_ty_mach (mach:ty_mach) : int =
match mach with
TY_u8 -> 1
| TY_u16 -> 2
| TY_u32 -> 4
| TY_u64 -> 8
| TY_i8 -> 1
| TY_i16 -> 2
| TY_i32 -> 4
| TY_i64 -> 8
| TY_f32 -> 4
| TY_f64 -> 8
;;
type ty_param_idx = int
;;
type nabi_conv =
CONV_rust
| CONV_cdecl
;;
type nabi = { nabi_indirect: bool;
nabi_convention: nabi_conv }
;;
let string_to_conv (a:string) : nabi_conv option =
match a with
"cdecl" -> Some CONV_cdecl
| "rust" -> Some CONV_rust
| _ -> None
(* FIXME: remove this when native items go away. *)
let string_to_nabi (s:string) (indirect:bool) : nabi option =
match string_to_conv s with
None -> None
| Some c ->
Some { nabi_indirect = indirect;
nabi_convention = c }
;;
type required_lib_spec =
{
required_libname: string;
required_prefix: int;
}
;;
type required_lib =
REQUIRED_LIB_rustrt
| REQUIRED_LIB_crt
| REQUIRED_LIB_rust of required_lib_spec
| REQUIRED_LIB_c of required_lib_spec
;;
type segment =
SEG_text
| SEG_data
;;
type fixup =
{ fixup_name: string;
mutable fixup_file_pos: int option;
mutable fixup_file_sz: int option;
mutable fixup_mem_pos: int64 option;
mutable fixup_mem_sz: int64 option }
;;
let new_fixup (s:string)
: fixup =
{ fixup_name = s;
fixup_file_pos = None;
fixup_file_sz = None;
fixup_mem_pos = None;
fixup_mem_sz = None }
;;
(*
* Auxiliary string functions.
*)
let split_string (c:char) (s:string) : string list =
let ls = ref [] in
let b = Buffer.create (String.length s) in
let flush _ =
if Buffer.length b <> 0
then
begin
ls := (Buffer.contents b) :: (!ls);
Buffer.clear b
end
in
let f ch =
if c = ch
then flush()
else Buffer.add_char b ch
in
String.iter f s;
flush();
List.rev (!ls)
;;
(*
* Auxiliary hashtable functions.
*)
let htab_keys (htab:('a,'b) Hashtbl.t) : ('a list) =
Hashtbl.fold (fun k _ accum -> k :: accum) htab []
;;
let sorted_htab_keys (tab:('a, 'b) Hashtbl.t) : 'a array =
let keys = Array.of_list (htab_keys tab) in
Array.sort compare keys;
keys
;;
let sorted_htab_iter
(f:'a -> 'b -> unit)
(tab:('a, 'b) Hashtbl.t)
: unit =
Array.iter
(fun k -> f k (Hashtbl.find tab k))
(sorted_htab_keys tab)
;;
let htab_vals (htab:('a,'b) Hashtbl.t) : ('b list) =
Hashtbl.fold (fun _ v accum -> v :: accum) htab []
;;
let htab_pairs (htab:('a,'b) Hashtbl.t) : (('a * 'b) list) =
Hashtbl.fold (fun k v accum -> (k,v) :: accum) htab []
;;
let htab_search (htab:('a,'b) Hashtbl.t) (k:'a) : ('b option) =
if Hashtbl.mem htab k
then Some (Hashtbl.find htab k)
else None
;;
let htab_search_or_default
(htab:('a,'b) Hashtbl.t)
(k:'a)
(def:unit -> 'b)
: 'b =
match htab_search htab k with
Some v -> v
| None -> def()
;;
let htab_search_or_add
(htab:('a,'b) Hashtbl.t)
(k:'a)
(mk:unit -> 'b)
: 'b =
let def () =
let v = mk() in
Hashtbl.add htab k v;
v
in
htab_search_or_default htab k def
;;
let htab_put (htab:('a,'b) Hashtbl.t) (a:'a) (b:'b) : unit =
assert (not (Hashtbl.mem htab a));
Hashtbl.add htab a b
;;
(* This is completely ridiculous, but it turns out that ocaml hashtables are
* order-of-element-addition sensitive when it comes to the built-in
* polymorphic comparison operator. So you have to canonicalize them after
* you've stopped adding things to them if you ever want to use them in a
* term that requires structural comparison to work. Sigh.
*)
let htab_canonicalize (htab:('a,'b) Hashtbl.t) : ('a,'b) Hashtbl.t =
let n = Hashtbl.create (Hashtbl.length htab) in
Array.iter
(fun k -> Hashtbl.add n k (Hashtbl.find htab k))
(sorted_htab_keys htab);
n
;;
let htab_map
(htab:('a,'b) Hashtbl.t)
(f:'a -> 'b -> ('c * 'd))
: (('c,'d) Hashtbl.t) =
let ntab = Hashtbl.create (Hashtbl.length htab) in
let g a b =
let (c,d) = f a b in
htab_put ntab c d
in
Hashtbl.iter g htab;
htab_canonicalize (ntab)
;;
let htab_fold
(fn:'a -> 'b -> 'c -> 'c)
(init:'c)
(h:('a, 'b) Hashtbl.t) : 'c =
let accum = ref init in
let f a b = accum := (fn a b (!accum)) in
Hashtbl.iter f h;
!accum
;;
let reduce_hash_to_list
(fn:'a -> 'b -> 'c)
(h:('a, 'b) Hashtbl.t)
: ('c list) =
htab_fold (fun a b ls -> (fn a b) :: ls) [] h
;;
(*
* Auxiliary association-array and association-list operations.
*)
let atab_search (atab:('a * 'b) array) (a:'a) : ('b option) =
let lim = Array.length atab in
let rec step i =
if i = lim
then None
else
let (k,v) = atab.(i) in
if k = a
then Some v
else step (i+1)
in
step 0
let atab_find (atab:('a * 'b) array) (a:'a) : 'b =
match atab_search atab a with
None -> bug () "atab_find: element not found"
| Some b -> b
let atab_mem (atab:('a * 'b) array) (a:'a) : bool =
match atab_search atab a with
None -> false
| Some _ -> true
let rec ltab_search (ltab:('a * 'b) list) (a:'a) : ('b option) =
match ltab with
[] -> None
| (k,v)::_ when k = a -> Some v
| _::lz -> ltab_search lz a
let ltab_put (ltab:('a * 'b) list) (a:'a) (b:'b) : (('a * 'b) list) =
assert ((ltab_search ltab a) = None);
(a,b)::ltab
(*
* Auxiliary list functions.
*)
let rec list_search (list:'a list) (f:'a -> 'b option) : ('b option) =
match list with
[] -> None
| a::az ->
match f a with
Some b -> Some b
| None -> list_search az f
let rec list_search_ctxt
(list:'a list)
(f:'a -> 'b option)
: ((('a list) * 'b) option) =
match list with
[] -> None
| a::az ->
match f a with
Some b -> Some (list, b)
| None -> list_search_ctxt az f
let rec list_drop n ls =
if n = 0
then ls
else list_drop (n-1) (List.tl ls)
;;
let rec list_count elem lst =
match lst with
[] -> 0
| h::t when h = elem -> 1 + (list_count elem t)
| _::t -> list_count elem t
;;
(*
* Auxiliary pair functions.
*)
let pair_rev (x,y) = (y,x)
(*
* Auxiliary option functions.
*)
let bool_of_option x =
match x with
Some _ -> true
| None -> false
let may f x =
match x with
Some x' -> f x'
| None -> ()
let option_map f x =
match x with
Some x' -> Some (f x')
| None -> None
let option_get x =
match x with
Some x -> x
| None -> raise Not_found
(*
* Auxiliary either functions.
*)
let either_has_left x =
match x with
Left _ -> true
| Right _ -> false
let either_has_right x = not (either_has_left x)
let either_get_left x =
match x with
Left x -> x
| Right _ -> raise Not_found
let either_get_right x =
match x with
Right x -> x
| Left _ -> raise Not_found
(*
* Auxiliary stack functions.
*)
let stk_fold (s:'a Stack.t) (f:'a -> 'b -> 'b) (x:'b) : 'b =
let r = ref x in
Stack.iter (fun e -> r := f e (!r)) s;
!r
let stk_elts_from_bot (s:'a Stack.t) : ('a list) =
stk_fold s (fun x y -> x::y) []
let stk_elts_from_top (s:'a Stack.t) : ('a list) =
List.rev (stk_elts_from_bot s)
let stk_search (s:'a Stack.t) (f:'a -> 'b option) : 'b option =
stk_fold s (fun e accum -> match accum with None -> (f e) | x -> x) None
(*
* Auxiliary array functions.
*)
let arr_search (a:'a array) (f:int -> 'a -> 'b option) : 'b option =
let max = Array.length a in
let rec iter i =
if i < max
then
let v = a.(i) in
let r = f i v in
match r with
Some _ -> r
| None -> iter (i+1)
else
None
in
iter 0
;;
let arr_idx (arr:'a array) (a:'a) : int =
let find i v = if v = a then Some i else None in
match arr_search arr find with
None -> bug () "arr_idx: element not found"
| Some i -> i
;;
let arr_map_partial (a:'a array) (f:'a -> 'b option) : 'b array =
let accum a ls =
match f a with
None -> ls
| Some b -> b :: ls
in
Array.of_list (Array.fold_right accum a [])
;;
let arr_filter_some (a:'a option array) : 'a array =
arr_map_partial a (fun x -> x)
;;
let arr_find_dups (a:'a array) : ('a * 'a) option =
let copy = Array.copy a in
Array.sort compare copy;
let lasti = (Array.length copy) - 1 in
let rec find_dups i =
if i < lasti then
let this = copy.(i) in
let next = copy.(i+1) in
(if (this = next) then
Some (this, next)
else
find_dups (i+1))
else
None
in
find_dups 0
;;
let arr_check_dups (a:'a array) (f:'a -> 'a -> unit) : unit =
match arr_find_dups a with
Some (x, y) -> f x y
| None -> ()
;;
let arr_map2 (f:'a -> 'b -> 'c) (a:'a array) (b:'b array) : 'c array =
assert ((Array.length a) = (Array.length b));
Array.init (Array.length a) (fun i -> f a.(i) b.(i))
;;
let arr_iter2 (f:'a -> 'b -> unit) (a:'a array) (b:'b array) : unit =
assert ((Array.length a) = (Array.length b));
Array.iteri (fun i a_elem -> f a_elem b.(i)) a
;;
let arr_for_all (f:int -> 'a -> bool) (a:'a array) : bool =
let len = Array.length a in
let rec loop i =
(i >= len) || ((f i a.(i)) && (loop (i+1)))
in
loop 0
;;
let arr_exists (f:int -> 'a -> bool) (a:'a array) : bool =
let len = Array.length a in
let rec loop i =
(i < len) && ((f i a.(i)) || (loop (i+1)))
in
loop 0
;;
(*
* Auxiliary queue functions.
*)
let queue_to_list (q:'a Queue.t) : 'a list =
List.rev (Queue.fold (fun ls elt -> elt :: ls) [] q)
;;
let queue_to_arr (q:'a Queue.t) : 'a array =
Array.init (Queue.length q) (fun _ -> Queue.take q)
;;
(*
* Auxiliary int64 functions
*)
let i64_lt (a:int64) (b:int64) : bool = (Int64.compare a b) < 0
let i64_le (a:int64) (b:int64) : bool = (Int64.compare a b) <= 0
let i64_ge (a:int64) (b:int64) : bool = (Int64.compare a b) >= 0
let i64_gt (a:int64) (b:int64) : bool = (Int64.compare a b) > 0
let i64_max (a:int64) (b:int64) : int64 =
(if (Int64.compare a b) > 0 then a else b)
let i64_min (a:int64) (b:int64) : int64 =
(if (Int64.compare a b) < 0 then a else b)
let i64_align (align:int64) (v:int64) : int64 =
(assert (align <> 0L));
let mask = Int64.sub align 1L in
Int64.logand (Int64.lognot mask) (Int64.add v mask)
;;
let rec i64_for (lo:int64) (hi:int64) (thunk:int64 -> unit) : unit =
if i64_lt lo hi then
begin
thunk lo;
i64_for (Int64.add lo 1L) hi thunk;
end
;;
let rec i64_for_rev (hi:int64) (lo:int64) (thunk:int64 -> unit) : unit =
if i64_ge hi lo then
begin
thunk hi;
i64_for_rev (Int64.sub hi 1L) lo thunk;
end
;;
(*
* Auxiliary int32 functions
*)
let i32_lt (a:int32) (b:int32) : bool = (Int32.compare a b) < 0
let i32_le (a:int32) (b:int32) : bool = (Int32.compare a b) <= 0
let i32_ge (a:int32) (b:int32) : bool = (Int32.compare a b) >= 0
let i32_gt (a:int32) (b:int32) : bool = (Int32.compare a b) > 0
let i32_max (a:int32) (b:int32) : int32 =
(if (Int32.compare a b) > 0 then a else b)
let i32_min (a:int32) (b:int32) : int32 =
(if (Int32.compare a b) < 0 then a else b)
let i32_align (align:int32) (v:int32) : int32 =
(assert (align <> 0l));
let mask = Int32.sub align 1l in
Int32.logand (Int32.lognot mask) (Int32.add v mask)
;;
(*
* Int-as-unichar functions.
*)
let bounds lo c hi = (lo <= c) && (c <= hi)
;;
let escaped_char i =
if bounds 0 i 0x7f
then Char.escaped (Char.chr i)
else
if bounds 0 i 0xffff
then Printf.sprintf "\\u%4.4X" i
else Printf.sprintf "\\U%8.8X" i
;;
let char_as_utf8 i =
let buf = Buffer.create 8 in
let addb i =
Buffer.add_char buf (Char.chr (i land 0xff))
in
let fini _ =
Buffer.contents buf
in
let rec add_trailing_bytes n i =
if n = 0
then fini()
else
begin
addb (0b1000_0000 lor ((i lsr ((n-1) * 6)) land 0b11_1111));
add_trailing_bytes (n-1) i
end
in
if bounds 0 i 0x7f
then (addb i; fini())
else
if bounds 0x80 i 0x7ff
then (addb ((0b1100_0000) lor (i lsr 6));
add_trailing_bytes 1 i)
else
if bounds 0x800 i 0xffff
then (addb ((0b1110_0000) lor (i lsr 12));
add_trailing_bytes 2 i)
else
if bounds 0x1000 i 0x1f_ffff
then (addb ((0b1111_0000) lor (i lsr 18));
add_trailing_bytes 3 i)
else
if bounds 0x20_0000 i 0x3ff_ffff
then (addb ((0b1111_1000) lor (i lsr 24));
add_trailing_bytes 4 i)
else
if bounds 0x400_0000 i 0x7fff_ffff
then (addb ((0b1111_1100) lor (i lsr 30));
add_trailing_bytes 5 i)
else bug () "bad unicode character 0x%X" i
;;
(*
* Size-expressions.
*)
type size =
SIZE_fixed of int64
| SIZE_fixup_mem_sz of fixup
| SIZE_fixup_mem_pos of fixup
| SIZE_param_size of ty_param_idx
| SIZE_param_align of ty_param_idx
| SIZE_rt_neg of size
| SIZE_rt_add of size * size
| SIZE_rt_mul of size * size
| SIZE_rt_max of size * size
| SIZE_rt_align of size * size
;;
let rec string_of_size (s:size) : string =
match s with
SIZE_fixed i -> Printf.sprintf "%Ld" i
| SIZE_fixup_mem_sz f -> Printf.sprintf "%s.mem_sz" f.fixup_name
| SIZE_fixup_mem_pos f -> Printf.sprintf "%s.mem_pos" f.fixup_name
| SIZE_param_size i -> Printf.sprintf "ty[%d].size" i
| SIZE_param_align i -> Printf.sprintf "ty[%d].align" i
| SIZE_rt_neg a ->
Printf.sprintf "-(%s)" (string_of_size a)
| SIZE_rt_add (a, b) ->
Printf.sprintf "(%s + %s)" (string_of_size a) (string_of_size b)
| SIZE_rt_mul (a, b) ->
Printf.sprintf "(%s * %s)" (string_of_size a) (string_of_size b)
| SIZE_rt_max (a, b) ->
Printf.sprintf "max(%s,%s)" (string_of_size a) (string_of_size b)
| SIZE_rt_align (align, off) ->
Printf.sprintf "align(%s,%s)"
(string_of_size align) (string_of_size off)
;;
let neg_sz (a:size) : size =
match a with
SIZE_fixed a -> SIZE_fixed (Int64.neg a)
| _ -> SIZE_rt_neg a
;;
let add_sz (a:size) (b:size) : size =
match (a, b) with
(SIZE_fixed a, SIZE_fixed b) -> SIZE_fixed (Int64.add a b)
| ((SIZE_rt_add ((SIZE_fixed a), c)), SIZE_fixed b)
| ((SIZE_rt_add (c, (SIZE_fixed a))), SIZE_fixed b)
| (SIZE_fixed a, (SIZE_rt_add ((SIZE_fixed b), c)))
| (SIZE_fixed a, (SIZE_rt_add (c, (SIZE_fixed b)))) ->
SIZE_rt_add (SIZE_fixed (Int64.add a b), c)
| (SIZE_fixed 0L, b) -> b
| (a, SIZE_fixed 0L) -> a
| (a, SIZE_fixed b) -> SIZE_rt_add (SIZE_fixed b, a)
| (a, b) -> SIZE_rt_add (a, b)
;;
let mul_sz (a:size) (b:size) : size =
match (a, b) with
(SIZE_fixed a, SIZE_fixed b) -> SIZE_fixed (Int64.mul a b)
| (a, SIZE_fixed b) -> SIZE_rt_mul (SIZE_fixed b, a)
| (a, b) -> SIZE_rt_mul (a, b)
;;
let rec max_sz (a:size) (b:size) : size =
let rec no_negs x =
match x with
SIZE_fixed _
| SIZE_fixup_mem_sz _
| SIZE_fixup_mem_pos _
| SIZE_param_size _
| SIZE_param_align _ -> true
| SIZE_rt_neg _ -> false
| SIZE_rt_add (a,b) -> (no_negs a) && (no_negs b)
| SIZE_rt_mul (a,b) -> (no_negs a) && (no_negs b)
| SIZE_rt_max (a,b) -> (no_negs a) && (no_negs b)
| SIZE_rt_align (a,b) -> (no_negs a) && (no_negs b)
in
match (a, b) with
(SIZE_rt_align _, SIZE_fixed 1L) -> a
| (SIZE_fixed 1L, SIZE_rt_align _) -> b
| (SIZE_param_align _, SIZE_fixed 1L) -> a
| (SIZE_fixed 1L, SIZE_param_align _) -> b
| (a, SIZE_rt_max (b, c)) when a = b -> max_sz a c
| (a, SIZE_rt_max (b, c)) when a = c -> max_sz a b
| (SIZE_rt_max (b, c), a) when a = b -> max_sz a c
| (SIZE_rt_max (b, c), a) when a = c -> max_sz a b
| (SIZE_fixed a, SIZE_fixed b) -> SIZE_fixed (i64_max a b)
| (SIZE_fixed 0L, b) when no_negs b -> b
| (a, SIZE_fixed 0L) when no_negs a -> a
| (a, SIZE_fixed b) -> max_sz (SIZE_fixed b) a
| (a, b) when a = b -> a
| (a, b) -> SIZE_rt_max (a, b)
;;
(* FIXME: audit this carefuly; I am not terribly certain of the
* algebraic simplification going on here. Sadly, without it
* the diagnostic output from translation becomes completely
* illegible.
*)
let align_sz (a:size) (b:size) : size =
let rec alignment_of s =
match s with
SIZE_rt_align (SIZE_fixed n, s) ->
let inner_alignment = alignment_of s in
if (Int64.rem n inner_alignment) = 0L
then inner_alignment
else n
| SIZE_rt_add (SIZE_fixed n, s)
| SIZE_rt_add (s, SIZE_fixed n) ->
let inner_alignment = alignment_of s in
if (Int64.rem n inner_alignment) = 0L
then inner_alignment
else 1L (* This could be lcd(...) or such. *)
| SIZE_rt_max (a, SIZE_fixed 1L) -> alignment_of a
| SIZE_rt_max (SIZE_fixed 1L, b) -> alignment_of b
| _ -> 1L
in
match (a, b) with
(SIZE_fixed a, SIZE_fixed b) -> SIZE_fixed (i64_align a b)
| (SIZE_fixed x, _) when i64_lt x 1L -> bug () "alignment less than 1"
| (SIZE_fixed 1L, b) -> b (* everything is 1-aligned. *)
| (_, SIZE_fixed 0L) -> b (* 0 is everything-aligned. *)
| (SIZE_fixed a, b) ->
let inner_alignment = alignment_of b in
if (Int64.rem a inner_alignment) = 0L
then b
else SIZE_rt_align (SIZE_fixed a, b)
| (SIZE_rt_max (a, SIZE_fixed 1L), b) -> SIZE_rt_align (a, b)
| (SIZE_rt_max (SIZE_fixed 1L, a), b) -> SIZE_rt_align (a, b)
| (a, b) -> SIZE_rt_align (a, b)
;;
let force_sz (a:size) : int64 =
match a with
SIZE_fixed i -> i
| _ -> bug () "force_sz: forced non-fixed size expression %s"
(string_of_size a)
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

86
src/boot/util/fmt.ml
View File

@ -1,86 +0,0 @@
(*
* Common formatting helpers.
*)
let fmt = Format.fprintf
;;
let fmt_str ff = fmt ff "%s"
;;
let fmt_obox ff = Format.pp_open_box ff 4;;
let fmt_obox_n ff n = Format.pp_open_box ff n;;
let fmt_cbox ff = Format.pp_close_box ff ();;
let fmt_obr ff = fmt ff "{";;
let fmt_cbr ff = fmt ff "@\n}";;
let fmt_cbb ff = (fmt_cbox ff; fmt_cbr ff);;
let fmt_break ff = Format.pp_print_space ff ();;
let fmt_bracketed
(bra:string)
(ket:string)
(inner:Format.formatter -> 'a -> unit)
(ff:Format.formatter)
(a:'a)
: unit =
fmt_str ff bra;
fmt_obox_n ff 0;
inner ff a;
fmt_cbox ff;
fmt_str ff ket
;;
let fmt_arr_sep
(sep:string)
(inner:Format.formatter -> 'a -> unit)
(ff:Format.formatter)
(az:'a array)
: unit =
Array.iteri
begin
fun i a ->
if i <> 0
then (fmt_str ff sep; fmt_break ff);
inner ff a
end
az
;;
let fmt_bracketed_arr_sep
(bra:string)
(ket:string)
(sep:string)
(inner:Format.formatter -> 'a -> unit)
(ff:Format.formatter)
(az:'a array)
: unit =
fmt_bracketed bra ket
(fmt_arr_sep sep inner)
ff az
;;
let fmt_to_str (f:Format.formatter -> 'a -> unit) (v:'a) : string =
let buf = Buffer.create 16 in
let bf = Format.formatter_of_buffer buf in
begin
f bf v;
Format.pp_print_flush bf ();
Buffer.contents buf
end
;;
let sprintf_fmt
(f:Format.formatter -> 'a -> unit)
: (unit -> 'a -> string) =
(fun _ -> fmt_to_str f)
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)

41
src/comp/README
View File

@ -1,16 +1,6 @@
An informal guide to reading and working on the rustc compiler.
==================================================================
First off, know that our current state of development is "bootstrapping";
this means we've got two compilers on the go and one of them is being used
to develop the other. Rustboot is written in ocaml and rustc in rust. The
one you *probably* ought to be working on at present is rustc. Rustboot is
more for historical comparison and bug-fixing whenever necessary to un-block
development of rustc.
There's a document similar to this next door, then, in boot/README. The boot
directory is where we do work on rustboot.
If you wish to expand on this document, or have one of the
slightly-more-familiar authors add anything else to it, please get in touch or
file a bug. Your concerns are probably the same as someone else's.
@ -85,34 +75,3 @@ Control and information flow within the compiler:
type-directed translation to LLVM-ese. When it's finished synthesizing LLVM
values, rustc asks LLVM to write them out as a bitcode file, on which you
can run the normal LLVM pipeline (opt, llc, as) to get an executable.
Comparison with rustboot
========================
Rustc is written in a more "functional" style than rustboot; each rustc pass
tends to depend only on the AST it's given as input, which it does not mutate.
Calculations flow from one phase to another by repeatedly rebuilding the AST
with additional annotations.
Rustboot normalizes to a statement-centric AST. Rustc uses an
expression-centric AST.
Rustboot generates 3-address IL into imperative buffers of coded IL quads.
Rustc generates LLVM, an SSA-based expression IL.
Rustc, being attached to LLVM, generates much better code. Factor of 5
smaller, usually. Sometimes much more.
Rustc preserves more of the parsed input structure. Rustboot "desugars" most
of the input, rendering round-trip pretty-printing impossible. Error reporting
is also better in rustc, as type names (as denoted by the user) are preserved
throughout typechecking.
Rustc is not concerned with the PIC-ness of the resulting code, nor anything
to do with encoding DWARF or x86 instructions. All this superfluous
machine-level logic that seeped up to the translation layer in rustboot is
pushed past LLVM into later stages of the toolchain in rustc.
Numerous "bad idea" idiosyncracies of the rustboot AST have been eliminated in
rustc. In general the code is much more obvious, minimal and straightforward.

4
src/comp/front/parser.rs
View File

@ -984,9 +984,7 @@ fn parse_bottom_expr(parser p) -> @ast::expr {
* FIXME: This is a crude approximation of the syntax-extension system,
* for purposes of prototyping and/or hard-wiring any extensions we
* wish to use while bootstrapping. The eventual aim is to permit
* loading rust crates to process extensions, but this will likely
* require a rust-based frontend, or an ocaml-FFI-based connection to
* rust crates. At the moment we have neither.
* loading rust crates to process extensions.
*/
fn expand_syntax_ext(parser p, ast::span sp,