mirror of
https://github.com/rust-lang/rust
synced 2024-10-04 15:50:51 +00:00
Remove rustboot from the repository.
This commit is contained in:
Graydon Hoare
parent
ef75860a0a
commit
6997adf763
6
configure
vendored
6
configure
vendored
|
|
@ -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
98
mk/boot.mk
|
|
@ -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 $@ $<
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
11
src/README
|
|
@ -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
405
src/boot/README
|
|
@ -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.
|
||||
|
||||
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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
1784
src/boot/be/elf.ml
File diff suppressed because it is too large
Load diff
|
|
@ -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
1194
src/boot/be/macho.ml
File diff suppressed because it is too large
Load diff
1175
src/boot/be/pe.ml
1175
src/boot/be/pe.ml
File diff suppressed because it is too large
Load diff
|
|
@ -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
2582
src/boot/be/x86.ml
File diff suppressed because it is too large
Load diff
|
|
@ -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:
|
||||
*)
|
||||
|
||||
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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
1795
src/boot/fe/ast.ml
File diff suppressed because it is too large
Load diff
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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
1334
src/boot/fe/item.ml
File diff suppressed because it is too large
Load diff
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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
1441
src/boot/fe/pexp.ml
File diff suppressed because it is too large
Load diff
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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
3213
src/boot/me/dwarf.ml
File diff suppressed because it is too large
Load diff
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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:
|
||||
*)
|
||||
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -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
6367
src/boot/me/trans.ml
File diff suppressed because it is too large
Load diff
|
|
@ -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
1453
src/boot/me/type.ml
File diff suppressed because it is too large
Load diff
File diff suppressed because it is too large
Load diff
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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:
|
||||
*)
|
||||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -984,9 +984,7 @@ fn parse_expr_opt(parser p) -> option::t[@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,
|
||||
|
|
|
|||
Loading…
Reference in a new issue