*~
+*.x86
+*.llvm
*.out
*.exe
*.orig
-Rust authors:
+Initial author, project lead, target of blame:
Graydon Hoare <graydon@mozilla.com>
+
+Other authors:
+
Andreas Gal <gal@mozilla.com>
+Brendan Eich <brendan@mozilla.org>
Dave Herman <dherman@mozilla.com>
+Michael Bebenita <mbebenita@mozilla.com>
Patrick Walton <pwalton@mozilla.com>
-Brendan Eich <brendan@mozilla.com>
+Roy Frostig <rfrostig@mozilla.com>
All rights reserved.
Redistribution and use in source and binary forms, with or without
- modification, are permitted provided that the following conditions are met:
+ modification, are permitted provided that the following conditions are
+ met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-* Two header files that are part of the Valgrind package. These files are found
- at src/rt/valgrind.h and src/rt/memcheck.h, within this distribution. These
- files are redistributed under the following terms, as noted in them:
+* Two header files that are part of the Valgrind package. These files are
+ found at src/rt/valgrind.h and src/rt/memcheck.h, within this
+ distribution. These files are redistributed under the following terms, as
+ noted in them:
for src/rt/valgrind.h:
Copyright (c) 2006-2010 Graydon Hoare
Copyright (c) 2009-2010 Mozilla Foundation
- Permission is hereby granted, free of charge, to any person obtaining a copy
- of this software and associated documentation files (the "Software"), to deal
- in the Software without restriction, including without limitation the rights
- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
- copies of the Software, and to permit persons to whom the Software is
- furnished to do so, subject to the following conditions:
+ Permission is hereby granted, free of charge, to any person obtaining a
+ copy of this software and associated documentation files (the "Software"),
+ to deal in the Software without restriction, including without limitation
+ the rights to use, copy, modify, merge, publish, distribute, sublicense,
+ and/or sell copies of the Software, and to permit persons to whom the
+ Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
- THE SOFTWARE.
+ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+ THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ DEALINGS IN THE SOFTWARE.
texi2pdf $<
%.html: %.texi
- makeinfo --html --force --no-split --output=$@ $<
+ makeinfo --html --ifhtml --force --no-split --output=$@ $<
clean:
- rm -f rust.aux rust.cp rust.fn rust.ky rust.log rust.pdf rust.html rust.pg rust.toc rust.tp rust.vr
\ No newline at end of file
+ rm -f rust.aux rust.cp rust.fn rust.ky rust.log rust.pdf \
+ rust.html rust.pg rust.toc rust.tp rust.vr
\ No newline at end of file
--- /dev/null
+\input texinfo @c -*-texinfo-*-
+@c %**start of header
+@setfilename rust.info
+@settitle Rust Documentation
+@setchapternewpage odd
+@c %**end of header
+
+@syncodeindex fn cp
+
+@ifinfo
+This manual is for the ``Rust'' programming language.
+
+Copyright 2006-2010 Graydon Hoare
+
+Copyright 2009-2010 Mozilla Foundation
+
+All rights reserved (for the time being).
+@end ifinfo
+
+@dircategory Programming
+@direntry
+* rust: (rust). Rust programming language
+@end direntry
+
+@titlepage
+@title Rust
+@subtitle A safe, concurrent, practical language.
+@author Graydon Hoare
+@author Mozilla Foundation
+
+@page
+@vskip 0pt plus 1filll
+Copyright @copyright{} 2006-2010 Graydon Hoare
+
+Copyright @copyright{} 2009-2010 Mozilla Foundation
+
+See accompanying LICENSE.txt for terms.
+@end titlepage
+
+@ifnottex
+@node Top
+@top Top
+
+Rust Documentation
+
+@end ifnottex
+
+@menu
+* Disclaimer:: Notes on a work in progress.
+* Introduction:: Background, intentions, lineage.
+* Tutorial:: Gentle introduction to reading Rust code.
+* Reference:: Systematic reference of language elements.
+* Index:: Index
+@end menu
+
+@ifnottex
+Complete table of contents
+@end ifnottex
+
+@contents
+
+@c ############################################################
+@c Disclaimer
+@c ############################################################
+
+@node Disclaimer
+@chapter Disclaimer
+
+To the reader,
+
+Rust is a work in progress. The language continues to evolve as the design
+shifts and is fleshed out in working code. Certain parts work, certain parts
+do not, certain parts will be removed or changed.
+
+This manual is a snapshot written in the present tense. Some features
+described do not yet exist in working code. Some may be temporary. It
+is a @emph{draft}, and we ask that you not take anything you read here
+as either definitive or final. The manual is to help you get a sense
+of the language and its organization, not to serve as a complete
+specification. At least not yet.
+
+If you have suggestions to make, please try to focus them on @emph{reductions}
+to the language: possible features that can be combined or omitted. At this
+point, every ``additive'' feature we're likely to support is already on the
+table. The task ahead involves combining, trimming, and implementing.
+
+
+@c ############################################################
+@c Introduction
+@c ############################################################
+
+@node Introduction
+@chapter Introduction
+
+@quotation
+ We have to fight chaos, and the most effective way of doing that is
+ to prevent its emergence.
+@flushright
+ - Edsger Dijkstra
+@end flushright
+@end quotation
+@sp 2
+
+Rust is a curly-brace, block-structured statement language. It visually
+resembles the C language family, but differs significantly in syntactic and
+semantic details. Its design is oriented toward concerns of ``programming in
+the large'', that is, of creating and maintaining @emph{boundaries} -- both
+abstract and operational -- that preserve large-system @emph{integrity},
+@emph{availability} and @emph{concurrency}.
+
+It supports a mixture of imperative procedural, concurrent actor, object
+oriented and pure functional styles. Rust also supports generic programming
+and metaprogramming, in both static and dynamic styles.
+
+@menu
+* Goals:: Intentions, motivations.
+* Sales Pitch:: A summary for the impatient.
+* Influences:: Relationship to past languages.
+@end menu
+
+
+@node Goals
+@section Goals
+
+The language design pursues the following goals:
+
+@sp 1
+@itemize
+@item Compile-time error detection and prevention.
+@item Run-time fault tolerance and containment.
+@item System building, analysis and maintenance affordances.
+@item Clarity and precision of expression.
+@item Implementation simplicity.
+@item Run-time efficiency.
+@item High concurrency.
+@end itemize
+@sp 1
+
+Note that most of these goals are @emph{engineering} goals, not showcases for
+sophisticated language technology. Most of the technology in Rust is
+@emph{old} and has been seen decades earlier in other languages.
+
+All new languages are developed in a technological context. Rust's goals arise
+from the context of writing large programs that interact with the internet --
+both servers and clients -- and are thus much more concerned with
+@emph{safety} and @emph{concurrency} than older generations of program. Our
+experience is that these two forces do not conflict; rather they drive system
+design decisions toward extensive use of @emph{partitioning} and
+@emph{statelessness}. Rust aims to make these a more natural part of writing
+programs, within the niche of lower-level, practical, resource-conscious
+languages.
+
+
+@page
+@node Sales Pitch
+@section Sales Pitch
+
+The following comprises a brief ``sales pitch'' overview of the salient
+features of Rust, relative to other languages.
+
+@itemize
+
+@sp 1
+@item No @code{null} pointers
+
+The initialization state of every slot is statically computed as part of the
+typestate system (see below), and requires that all slots are initialized
+before use. There is no @code{null} value; uninitialized slots are
+uninitialized, and can only be written to, not read.
+
+The common use for @code{null} in other languages -- as a sentinel value -- is
+subsumed into the more general facility of disjoint union types. A program
+must explicitly model its use of such types.
+
+@sp 1
+@item Lightweight tasks with no shared mutable state
+
+Like many @emph{actor} languages, Rust provides an isolation (and concurrency)
+model based on lightweight tasks scheduled by the language runtime. These
+tasks are very inexpensive and statically unable to mutate one another's local
+memory. Breaking the rule of task isolation is only possible by calling
+external (C/C++) code.
+
+Inter-task communication is typed, asynchronous and simplex, based on passing
+messages over channels to ports. Transmission can be rate-limited or
+rate-unlimited. Selection between multiple senders is pseudo-randomized on the
+receiver side.
+
+@sp 1
+@item Predictable native code, simple runtime
+
+The meaning and cost of every operation within a Rust program is intended to
+be easy to model for the reader. The code should not ``surprise'' the
+programmer once it has been compiled.
+
+Rust compiles to native code. Rust compilation units are large and the
+compilation model is designed around multi-file, whole-library or
+whole-program optimization. The compiled units are standard loadable objects
+(ELF, PE, Mach-O) containing standard metadata (DWARF) and are compatible with
+existing, standard low-level tools (disassemblers, debuggers, profilers,
+dynamic loaders).
+
+The Rust runtime library is a small collection of support code for scheduling,
+memory management, inter-task communication, reflection and runtime
+linkage. This library is written in standard C++ and is quite
+straightforward. It presents a simple interface to embeddings. No
+research-level virtual machine, JIT or garbage collection technology is
+required. It should be relatively easy to adapt a Rust front-end on to many
+existing native toolchains.
+
+@sp 1
+@item Integrated system-construction facility
+
+The units of compilation of Rust are multi-file amalgamations called
+@emph{crates}. A crate is described by a separate, declarative type of source
+file that guides the compilation of the crate, its packaging, its versioning,
+and its external dependencies. Crates are also the units of distribution and
+loading. Significantly: the dependency graph of crates is @emph{acyclic} and
+@emph{anonymous}: there is no global namespace for crates, and module-level
+recursion cannot cross crate barriers.
+
+Unlike many languages, individual modules do @emph{not} carry all the
+mechanisms or restrictions of crates. Modules and crates serve different
+roles.
+
+@sp 1
+@item Stack-based iterators
+
+Rust provides a type of function-like multiple-invocation iterator that is
+very efficient: the iterator state lives only on the stack and is tightly
+coupled to the loop that invoked it.
+
+@sp 1
+@item Direct interface to C code
+
+Rust can load and call many C library functions simply by declaring
+them. Calling a C function statically marks a function as ``unsafe'', unless
+the task calling the unsafe function is further isolated within an external
+``heavyweight'' operating-system subprocess. Every ``unsafe'' function or
+module in a Rust compilation unit must be explicitly authorized in the crate
+file.
+
+@sp 1
+@item Structural algebraic data types
+
+The Rust type system is structural rather than nominal, and contains the
+standard assortment of useful ``algebraic'' type constructors from functional
+languages, such as function types, tuples, record types, vectors, and tagged
+disjoint unions. Structural types may be @emph{pattern-matched} in an
+@code{alt} statement.
+
+@sp 1
+@item Generic code
+
+Rust supports a simple form of parametric polymorphism: functions, iterators,
+types and objects can be parametrized by other types.
+
+@sp 1
+@item Argument binding
+
+Rust provides a mechanism of partially binding arguments to functions,
+producing new functions that accept the remaining un-bound arguments. This
+mechanism combines some of the features of lexical closures with some of the
+features of currying, in a smaller and simpler package.
+
+@sp 1
+@item Local type inference
+
+To save some quantity of programmer key-pressing, Rust supports local type
+inference: signatures of functions, objects and iterators always require type
+annotation, but within the body of a function or iterator many slots can be
+declared @code{auto} and Rust will infer the slot's type from its uses.
+
+@sp 1
+@item Structural object system
+
+Rust has a lightweight object system based on structural object types: there
+is no ``class hierarchy'' nor any concept of inheritance. Method overriding
+and object restriction are performed explicitly on object values, which are
+little more than order-insensitive records of methods sharing a common private
+value. Objects can be mutable or immutable, and immutable objects can have
+destructors.
+
+@sp 1
+@item Dynamic type
+
+Rust includes support for slots of a top type, @code{any}, that can hold any
+type of value whatsoever. An @code{any} slot is a pair of a type code and an
+exterior value of that type. Injection into an @code{any} and projection by
+type-case-selection is integrated into the language.
+
+@sp 1
+@item Dynamic metaprogramming (reflection)
+
+Rust supports run-time reflection on the structure of a crate, using a
+combination of custom descriptor structures and the DWARF metadata tables used
+to support crate linkage and other runtime services.
+
+@sp 1
+@item Static metaprogramming (syntactic extension)
+
+Rust supports a system for syntactic extensions that can be loaded into the
+compiler, to implement user-defined notations, macros, program-generators and
+the like. These notations are @emph{marked} using a special form of
+bracketing, such that a reader unfamiliar with the extension can still parse
+the surrounding text by skipping over the bracketed ``extension text''.
+
+@sp 1
+@item Idempotent failure
+
+If a task fails due to a signal, or if it executes the special @code{fail}
+statement, it enters the @emph{failing} state. A failing task unwinds its
+control stack, frees all of its owned resources (executing destructors) and
+enters the @emph{dead} state. Failure is idempotent and non-recoverable.
+
+@sp 1
+@item Signal handling
+
+Rust has a system for propagating task-failures and other spontaneous
+events between tasks. Some signals can be trapped and redirected to
+channels; other signals are fatal and result in task-failure. Tasks
+can designate other tasks to handle signals for them. This permits
+organizing tasks into mutually-supervising or mutually-failing groups.
+
+@sp 1
+@item Deterministic destruction
+
+Immutable objects can have destructor functions, which are executed
+deterministically in top-down ownership order, as control frames are exited
+and/or objects are otherwise freed from data structures holding them. The same
+destructors are run in the same order whether the object is deleted by
+unwinding during failure or normal execution.
+
+Similarly, the rules for freeing immutable memory are deterministic and
+predictable: on scope-exit or structure-release, interior slots are released
+immediately, exterior slots have their reference count decreased and are
+released if the count drops to zero. Alias slots are not affected by scope
+exit.
+
+Mutable memory is local to a task, and is subject to per-task garbage
+collection. As a result, unreferenced mutable memory is not necessarily freed
+immediately; if it is acyclic it is freed when the last reference to it drops,
+but if it is part of a reference cycle it will be freed when the GC collects
+it (or when the owning task terminates, at the latest).
+
+Mutable memory can point to immutable memory but not vice-versa. Doing so
+merely delays (to an undefined future time) the moment when the deterministic,
+top-down destruction sequence for the referenced immutable memory
+@emph{starts}. In other words, the immutable ``leaves'' of a mutable structure
+are released in a locally-predictable order, even if the ``interior'' of the
+mutable structure is released in an unpredictable order.
+
+@sp 1
+@item Typestate system
+
+Every storage slot in Rust participates in not only a conventional structural
+static type system, describing the interpretation of memory in the slot, but
+also a @emph{typestate} system. The static typestates of a program describe
+the set of @emph{pure, dynamic predicates} that provably hold over some set of
+slots, at each point in the program's control flow graph. The static
+calculation of the typestates of a program is a dataflow problem, and handles
+user-defined predicates in a similar fashion to the way the type system
+permits user-defined types.
+
+A short way of thinking of this is: types statically model the kinds of values
+held in slots, typestates statically model @emph{assertions that hold} before
+and after statements.
+
+@sp 1
+@item Static control over memory allocation, packing and aliasing.
+
+Every variable or field in Rust is a combination of a type, a mutability flag
+and a @emph{mode}; this combination is called a @emph{slot}. There are 3 kinds
+of @dfn{slot mode}, denoting 3 ways of referring to a value:
+
+@itemize
+@item ``interior'' (slot contains value)
+@item ``exterior'', (slot points to to managed heap allocation)
+@item ``alias'', (slot points directly to provably-live address)
+@end itemize
+
+Interior slots declared as variables in a function are allocated very quickly
+on the stack, as part of a local activation frame, as in C or C++. Alias slots
+permit efficient by-reference parameter passing without adjusting heap
+reference counts or interacting with garbage collection, as alias lifetimes
+are statically guaranteed to outlive callee lifetimes.
+
+Copying data between slots of different modes may cause either a simple
+address assignment or reference-count adjustment, or may cause a value to be
+``transplanted'': copied by value from the interior of one memory structure to
+another, or between stack and heap. Transplanting, when necessary, is
+predictable and automatic, as part of the definition of the copy operator
+(@code{=}).
+
+In addition, slots have a static initialization state that is calculated by
+the typestate system. This permits late initialization of variables in
+functions with complex control-flow, while still guaranteeing that every use
+of a slot occurs after it has been initialized.
+
+@sp 1
+@item Static control over mutability.
+
+Slots in Rust are classified as either immutable or mutable. By default,
+all slots are immutable.
+
+If a slot within a type is declared as @code{mutable}, the type is a
+@code{state} type and must be declared as such.
+
+This classification of data types in Rust interacts with the memory allocation
+and transmission rules. In particular:
+
+@itemize
+@item Only immutable (non-state) values can be sent over channels.
+@item Only immutable (non-state) objects can have destructor functions.
+@end itemize
+
+State values are subject to local (per-task) garbage-collection. Garbage
+collection costs are therefore also task-local and do not interrupt or suspend
+other tasks.
+
+Immutable values are reference-counted and have a deterministic destruction
+order: top-down, immediately upon release of the last live reference.
+
+State values can refer to immutable values, but not vice-versa. Rust therefore
+encourages the programmer to write in a style that consists primarily of
+immutable types, but also permits limited, local (per-task) mutability.
+
+@end itemize
+
+
+@page
+@node Influences
+@section Influences
+@sp 2
+
+@quotation
+ The essential problem that must be solved in making a fault-tolerant
+ software system is therefore that of fault-isolation. Different programmers
+ will write different modules, some modules will be correct, others will have
+ errors. We do not want the errors in one module to adversely affect the
+ behaviour of a module which does not have any errors.
+
+@flushright
+ - Joe Armstrong
+@end flushright
+@end quotation
+@sp 2
+
+@quotation
+ In our approach, all data is private to some process, and processes can
+ only communicate through communications channels. @emph{Security}, as used
+ in this paper, is the property which guarantees that processes in a system
+ cannot affect each other except by explicit communication.
+
+ When security is absent, nothing which can be proven about a single module
+ in isolation can be guaranteed to hold when that module is embedded in a
+ system [...]
+@flushright
+ - Robert Strom and Shaula Yemini
+@end flushright
+@end quotation
+@sp 2
+
+@quotation
+ Concurrent and applicative programming complement each other. The
+ ability to send messages on channels provides I/O without side effects,
+ while the avoidance of shared data helps keep concurrent processes from
+ colliding.
+@flushright
+ - Rob Pike
+@end flushright
+@end quotation
+@sp 2
+
+@page
+Rust is not a particularly original language. It may however appear unusual by
+contemporary standards, as its design elements are drawn from a number of
+``historical'' languages that have, with a few exceptions, fallen out of
+favour. Five prominent lineages contribute the most:
+
+@itemize
+@sp 1
+@item
+The NIL (1981) and Hermes (1990) family. These languages were developed by
+Robert Strom, Shaula Yemini, David Bacon and others in their group at IBM
+Watson Research Center (Yorktown Heights, NY, USA).
+
+@sp 1
+@item
+The Erlang (1987) language, developed by Joe Armstrong, Robert Virding, Claes
+Wikstr@"om, Mike Williams and others in their group at the Ericsson Computer
+Science Laboratory (@"Alvsj@"o, Stockholm, Sweden) .
+
+@sp 1
+@item
+The Sather (1990) language, developed by Stephen Omohundro, Chu-Cheow Lim,
+Heinz Schmidt and others in their group at The International Computer Science
+Institute of the University of California, Berkeley (Berkeley, CA, USA).
+
+@sp 1
+@item
+The Newsqueak (1988), Alef (1995), and Limbo (1996) family. These languages
+were developed by Rob Pike, Phil Winterbottom, Sean Dorward and others in
+their group at Bell labs Computing Sciences Reserch Center (Murray Hill, NJ,
+USA).
+
+@sp 1
+@item
+The Napier (1985) and Napier88 (1988) family. These languages were developed
+by Malcolm Atkinson, Ron Morrison and others in their group at the University
+of St. Andrews (St. Andrews, Fife, UK).
+@end itemize
+
+@sp 1
+Additional specific influences can be seen from the following languages:
+@itemize
+@item The structural algebraic types and compilation manager of SML.
+@item The syntax-extension systems of Camlp4 and the Common Lisp readtable.
+@item The deterministic destructor system of C++.
+@end itemize
+
+@c ############################################################
+@c Tutorial
+@c ############################################################
+
+@node Tutorial
+@chapter Tutorial
+
+@emph{TODO}.
+
+@c ############################################################
+@c Reference
+@c ############################################################
+
+@node Reference
+@chapter Reference
+
+@menu
+* Ref.Lex:: Lexical structure.
+* Ref.Path:: References to slots and items.
+* Ref.Gram:: Grammar.
+* Ref.Comp:: Compilation and component model.
+* Ref.Mem:: Semantic model of memory.
+* Ref.Task:: Semantic model of tasks.
+* Ref.Item:: The components of a module.
+* Ref.Type:: The types of values held in memory.
+* Ref.Expr:: Parsed and primitive expressions.
+* Ref.Stmt:: Executable statements.
+* Ref.Run:: Organization of runtime services.
+@end menu
+
+@page
+@node Ref.Lex
+@section Ref.Lex
+@c * Ref.Lex:: Lexical structure.
+
+The lexical structure of a Rust source file or crate file is defined in terms
+of Unicode character codes and character properties.
+
+Groups of Unicode character codes and characters are organized into
+@emph{tokens}. Tokens are defined as the longest contiguous sequence of
+characters within the same token type (identifier, keyword, literal, symbol),
+or interrupted by ignored characters.
+
+Most tokens in Rust follow rules similar to the C family.
+
+Most tokens (including identifiers, whitespace, keywords, operators and
+structural symbols) are drawn from the ASCII-compatible range of
+Unicode. String and character literals, however, may include the full range of
+Unicode characters.
+
+@emph{TODO: formalize this section much more}.
+
+@menu
+* Ref.Lex.Ignore:: Ignored characters.
+* Ref.Lex.Ident:: Identifier tokens.
+* Ref.Lex.Key:: Keyword tokens.
+* Ref.Lex.Num:: Numeric tokens.
+* Ref.Lex.Text:: String and character tokens.
+* Ref.Lex.Syntax:: Syntactic extension tokens.
+* Ref.Lex.Sym:: Special symbol tokens.
+@end menu
+
+@page
+@node Ref.Lex.Ignore
+@subsection Ref.Lex.Ignore
+@c * Ref.Lex.Ignore:: Ignored tokens.
+
+The classes of @emph{whitespace} and @emph{comment} is ignored, and are not
+considered as tokens.
+
+@dfn{Whitespace} is any of the following Unicode characters: U+0020 (space),
+U+0009 (tab, @code{'\t'}), U+000A (LF, @code{'\n'}), U+000D (CR, @code{'\r'}).
+
+@dfn{Comments} are any sequence of Unicode characters beginning with U+002F
+U+002F (@code{//}) and extending to the next U+000a character,
+@emph{excluding} cases in which such a sequence occurs within a string literal
+token or a syntactic extension token.
+
+
+@page
+@node Ref.Lex.Ident
+@subsection Ref.Lex.Ident
+@c * Ref.Lex.Ident:: Identifier tokens.
+
+Identifiers follow the pattern of C identifiers: they begin with a
+@emph{letter} or underscore character @code{_} (Unicode character U+005f), and
+continue with any combination of @emph{letters}, @emph{digits} and
+underscores, and must not be equal to any keyword. @xref{Ref.Lex.Key}.
+
+A @emph{letter} is a Unicode character in the ranges U+0061-U+007A and
+U+0041-U+005A (@code{a-z} and @code{A-Z}).
+
+A @emph{digit} is a Unicode character in the range U+0030-U0039 (@code{0-9}).
+
+@page
+@node Ref.Lex.Key
+@subsection Ref.Lex.Key
+@c * Ref.Lex.Key:: Keyword tokens.
+
+The keywords are:
+
+@sp 2
+
+@multitable @columnfractions .15 .15 .15 .15 .15
+@item @code{use}
+@tab @code{meta}
+@tab @code{syntax}
+@tab @code{mutable}
+@tab @code{native}
+@item @code{mod}
+@tab @code{import}
+@tab @code{export}
+@tab @code{let}
+@tab @code{auto}
+@item @code{io}
+@tab @code{state}
+@tab @code{unsafe}
+@tab @code{auth}
+@tab @code{with}
+@item @code{bind}
+@tab @code{type}
+@tab @code{true}
+@tab @code{false}
+@item @code{any}
+@tab @code{int}
+@tab @code{uint}
+@tab @code{char}
+@tab @code{bool}
+@item @code{u8}
+@tab @code{u16}
+@tab @code{u32}
+@tab @code{u64}
+@tab @code{f32}
+@item @code{i8}
+@tab @code{i16}
+@tab @code{i32}
+@tab @code{i64}
+@tab @code{f64}
+@item @code{rec}
+@tab @code{tup}
+@tab @code{tag}
+@tab @code{vec}
+@tab @code{str}
+@item @code{fn}
+@tab @code{iter}
+@tab @code{obj}
+@tab @code{as}
+@tab @code{drop}
+@item @code{task}
+@tab @code{port}
+@tab @code{chan}
+@tab @code{flush}
+@tab @code{spawn}
+@item @code{if}
+@tab @code{else}
+@tab @code{alt}
+@tab @code{case}
+@tab @code{in}
+@item @code{do}
+@tab @code{while}
+@tab @code{break}
+@tab @code{cont}
+@tab @code{fail}
+@item @code{log}
+@tab @code{note}
+@tab @code{claim}
+@tab @code{check}
+@tab @code{prove}
+@item @code{for}
+@tab @code{each}
+@tab @code{ret}
+@tab @code{put}
+@tab @code{be}
+@end multitable
+
+@page
+@node Ref.Lex.Num
+@subsection Ref.Lex.Num
+@c * Ref.Lex.Num:: Numeric tokens.
+
+@emph{TODO: describe numeric literals}.
+
+@page
+@node Ref.Lex.Text
+@subsection Ref.Lex.Text
+@c * Ref.Lex.Key:: String and character tokens.
+
+@emph{TODO: describe string and character literals}.
+
+@page
+@node Ref.Lex.Syntax
+@subsection Ref.Lex.Syntax
+@c * Ref.Lex.Syntax:: Syntactic extension tokens.
+
+Syntactic extensions are marked with the @emph{pound} sigil @code{#} (U+0023),
+followed by a qualified name of a compile-time imported module item, an
+optional parenthesized list of @emph{tokens}, and an optional brace-enclosed
+region of free-form text (with brace-matching and brace-escaping used to
+determine the limit of the region). @xref{Ref.Comp.Syntax}.
+
+@emph{TODO: formalize those terms more}.
+
+@page
+@node Ref.Lex.Sym
+@subsection Ref.Lex.Sym
+@c * Ref.Lex.Sym:: Special symbol tokens.
+
+The special symbols are:
+
+@sp 2
+
+@multitable @columnfractions .1 .1 .1 .1 .1 .1
+
+@item @code{@@}
+@tab @code{_}
+@item @code{#}
+@tab @code{:}
+@tab @code{.}
+@tab @code{;}
+@tab @code{,}
+@item @code{[}
+@tab @code{]}
+@tab @code{@{}
+@tab @code{@}}
+@tab @code{(}
+@tab @code{)}
+@item @code{=}
+@tab @code{<-}
+@tab @code{<|}
+@tab @code{<+}
+@tab @code{->}
+@item @code{+}
+@tab @code{++}
+@tab @code{+=}
+@tab @code{-}
+@tab @code{--}
+@tab @code{-=}
+@item @code{*}
+@tab @code{/}
+@tab @code{%}
+@tab @code{*=}
+@tab @code{/=}
+@tab @code{%=}
+@item @code{&}
+@tab @code{|}
+@tab @code{!}
+@tab @code{~}
+@tab @code{^}
+@item @code{&=}
+@tab @code{|=}
+@tab @code{^=}
+@tab @code{!=}
+@item @code{>>}
+@tab @code{>>>}
+@tab @code{<<}
+@tab @code{<<=}
+@tab @code{>>=}
+@tab @code{>>>=}
+@item @code{<}
+@tab @code{<=}
+@tab @code{==}
+@tab @code{>=}
+@tab @code{>}
+@item @code{&&}
+@tab @code{||}
+@end multitable
+
+@page
+@page
+@node Ref.Path
+@section Ref.Path
+@c * Ref.Path:: References to slots and items.
+
+A @dfn{path} is a ubiquitous syntactic form in Rust that deserves special
+attention. A path denotes a slot or an
+item. @xref{Ref.Mem.Slot}. @xref{Ref.Item}. Every slot and item in a Rust
+crate has a @emph{canonical path} that refers to it from the crate top-level,
+as well as a number of shorter @emph{relative paths} that may also denote it
+in inner scopes of the crate. There is no way to define a slot or item without
+a canonical path within its crate (with the exception of the crate's implicit
+top-level module). Paths have meaning only within a specific
+crate. @xref{Ref.Comp.Crate}.
+
+Paths consist of period-separated components. In the simplest form, path
+components are identifiers. @xref{Ref.Lex.Ident}.
+
+Two examples of simple paths consisting of only identifier components:
+@example
+x;
+x.y.z;
+@end example
+
+Paths fall into two important categories: @emph{names} and
+@emph{lvals}.
+
+A @dfn{name} denotes an item, and is statically resolved to its
+referent at compile time.
+
+An @dfn{lval} denotes a slot, and is statically resolved to a sequence of
+memory operations and primitive (arithmetic) expressions required to load or
+store to the slot at compile time.
+
+In some contexts, the Rust grammar accepts a general @emph{path}, but a
+subsequent syntactic restriction requires the path to be an lval or a name. In
+other words: in some contexts an lval is required (for example, on the left
+hand side of the copy operator, @pxref{Ref.Stmt.Copy}) and in other contexts a
+name is required (for example, as a type parameter, @pxref{Ref.Item}). In no
+case is the grammar made ambiguous by accepting a general path and restricting
+allowed paths to names or lvals after parsing. These restrictions are noted in
+the grammar. @xref{Ref.Gram}.
+
+A name component may include type parameters. Type parameters are denoted by
+square brackets. Square brackets are used @emph{only} to denote type
+parameters in Rust. If a name component includes a type parameter, the type
+parameter must also resolve statically to a type in the environment of the
+name. Type parameters are only part of the names of items. @xref{Ref.Item}.
+
+An example of a name with type parameters:
+@example
+m.map[int,str];
+@end example
+
+An lval component may include an indexing operator. Index operators are
+enclosed in parentheses and can include any integral expression. Indexing
+operators can only be applied to vectors or strings, and imply a run-time
+bounds-check. @xref{Ref.Type.Vec}.
+
+An example of an lval with a dynamic indexing operator:
+@example
+x.y.(1 + v).z;
+@end example
+
+@page
+@node Ref.Gram
+@section Ref.Gram
+@c * Ref.Gram:: Grammar.
+
+@emph{TODO: LL(1), it reads like C, Alef and bits of Napier; formalize here}.
+
+@page
+@node Ref.Comp
+@section Ref.Comp
+@c * Ref.Comp:: Compilation and component model.
+
+Rust is a @emph{compiled} language. Its semantics are divided along a
+@emph{phase distinction} between compile-time and run-time. Those semantic
+rules that have a @emph{static interpretation} govern the success or failure
+of compilation. A program that fails to compile due to violation of a
+compile-time rule has no defined semantics at run-time; the compiler should
+halt with an error report, and produce no executable artifact.
+
+The compilation model centres on artifacts called @emph{crates}. Each
+compilation is directed towards a single crate in source form, and if
+successful produces a single crate in executable form.
+
+@menu
+* Ref.Comp.Crate:: Units of compilation and linking.
+* Ref.Comp.Meta:: Metadata about a crate.
+* Ref.Comp.Syntax:: Syntax extensions.
+@end menu
+
+@page
+@node Ref.Comp.Crate
+@subsection Ref.Comp.Crate
+@c * Ref.Comp.Crate:: Units of compilation and linking.
+
+A @dfn{crate} is a unit of compilation and linking, as well as versioning,
+distribution and runtime loading. Crates are defined by @emph{crate source
+files}, which are a type of source file written in a special declarative
+language: @emph{crate language}.@footnote{A crate is somewhat analogous to an
+@emph{assembly} in the ECMA-335 CLI model, a @emph{library} in the SML/NJ
+Compilation Manager, a @emph{unit} in the Owens and Flatt module system, or a
+@emph{configuration} in Mesa.} A crate source file describes:
+
+@itemize
+@item Metadata about the crate, such as author, name, version, and copyright.
+@item The source-file and directory modules that make up the crate.
+@item The set of syntax extensions to enable for the crate.
+@item Any external crates or native modules that the crate imports to its top level.
+@item The organization of the crate's internal namespace.
+@item The set of names exported from the crate.
+@end itemize
+
+A single crate source file may describe the compilation of a large number of
+Rust source files; it is compiled in its entirety, as a single indivisible
+unit. The compilation phase attempts to transform a single crate source file,
+and its referenced contents, into a single compiled crate. Crate source files
+and compiled crates have a 1:1 relationship.
+
+The syntactic form of a crate is a sequence of @emph{directives}, some of
+which have nested sub-directives.
+
+A crate defines an implicit top-level anonymous module: within this module,
+all members of the crate have canonical path names. @xref{Ref.Path}. The
+@code{mod} directives within a crate file specify sub-modules to include in
+the crate: these are either directory modules, corresponding to directories in
+the filesystem of the compilation environment, or file modules, corresponding
+to Rust source files. The names given to such modules in @code{mod} directives
+become prefixes of the paths of items and slots defined within any included
+Rust source files.
+
+The @code{use} directives within the crate specify @emph{other crates} to scan
+for, locate, import into the crate's module namespace during compilation, and
+link against at runtime. Use directives may also occur independently in rust
+source files. These directives may specify loose or tight ``matching
+criteria'' for imported crates, depending on the preferences of the crate
+developer. In the simplest case, a @code{use} directive may only specify a
+symbolic name and leave the task of locating and binding an appropriate crate
+to a compile-time heuristic. In a more controlled case, a @code{use} directive
+may specify any metadata as matching criteria, such as a URI, an author name
+or version number, a checksum or even a cryptographic signature, in order to
+select an an appropriate imported crate. @xref{Ref.Comp.Meta}.
+
+The compiled form of a crate is a loadable and executable object file full of
+machine code, in a standard loadable operating-system format such as ELF, PE
+or Mach-O. The loadable object contains extensive DWARF metadata, describing:
+@itemize
+@item Metadata required for type reflection.
+@item The publicly exported module structure of the crate.
+@item Any metadata about the crate, defined by @code{meta} directives.
+@item The crates to dynamically link with at run-time, with matching criteria
+derived from the same @code{use} directives that guided compile-time imports.
+@end itemize
+
+The @code{syntax} directives of a crate are similar to the @code{use}
+directives, except they govern the syntax extension namespace (accessed
+through the syntax-extension sigil @code{#}, @pxref{Ref.Comp.Syntax})
+available only at compile time. A @code{syntax} directive also makes its
+extension available to all subsequent directives in the crate file.
+
+An example of a crate:
+
+@example
+// Metadata about this crate
+meta (author = "Jane Doe",
+ name = "projx"
+ desc = "Project X",
+ ver = "2.5");
+
+// Import a module.
+use std (ver = "1.0");
+
+// Activate a syntax-extension.
+syntax re;
+
+// Define some modules.
+mod foo = "foo.rs";
+mod bar @{
+ mod quux = "quux.rs";
+@}
+@end example
+
+@page
+@node Ref.Comp.Meta
+@subsection Ref.Comp.Meta
+
+In a crate, a @code{meta} directive associates free form key-value metadata
+with the crate. This metadata can, in turn, be used in providing partial
+matching parameters to syntax-extension loading and crate importing
+directives, denoted by @code{syntax} and @code{use} keywords respectively.
+
+Alternatively, metadata can serve as a simple form of documentation.
+
+@page
+@node Ref.Comp.Syntax
+@subsection Ref.Comp.Syntax
+@c * Ref.Comp.Syntax:: Syntax extension.
+
+Rust provides a notation for @dfn{syntax extension}. The notation is a marked
+syntactic form that can appear as an expression, statement or item in the body
+of a Rust program, or as a directive in a Rust crate, and which causes the
+text enclosed within the marked form to be translated through a named
+extension function loaded into the compiler at compile-time.
+
+The compile-time extension function must return a value of the corresponding
+Rust AST type, either an expression node, a statement node or an item
+node. @footnote{The syntax-extension system is analogous to the extensible
+reader system provided by Lisp @emph{readtables}, or the Camlp4 system of
+Objective Caml.} @xref{Ref.Lex.Syntax}.
+
+A syntax extension is enabled by a @code{syntax} directive, which must occur
+in a crate file. When the Rust compiler encounters a @code{syntax} directive
+in a crate file, it immediately loads the named syntax extension, and makes it
+available for all subsequent crate directives within the enclosing block scope
+of the crate file, and all Rust source files referenced as modules from the
+enclosing block scope of the crate file.
+
+For example, this extension might provide a syntax for regular
+expression literals:
+
+@example
+// In a crate file:
+
+// Requests the 're' syntax extension from the compilation environment.
+syntax re;
+
+// Also declares an import dependency on the module 're'.
+use re;
+
+// Reference to a Rust source file as a module in the crate.
+mod foo = "foo.rs";
+
+@dots{}
+
+// In the source file "foo.rs", use the #re syntax extension and
+// the re module at run-time.
+let str s = get_string();
+let regex pattern = #re.pat@{ aa+b? @};
+let bool matched = re.match(pattern, s);
+@end example
+
+@page
+@node Ref.Mem
+@section Ref.Mem
+@c * Ref.Mem:: Semantic model of memory.
+
+A Rust task's memory consists of a static set of @emph{items}, a set of tasks
+each with its own @emph{stack}, and a @emph{heap}. Immutable portions of the
+heap may be shared between tasks, mutable portions may not.
+
+Allocations in the stack and the heap consist of @emph{slots}.
+
+@menu
+* Ref.Mem.Alloc:: Memory allocation model.
+* Ref.Mem.Own:: Memory ownership model.
+* Ref.Mem.Slot:: Memory containment and reference model.
+* Ref.Mem.Init:: Initialization state of memory.
+* Ref.Mem.Acct:: Memory accounting model.
+@end menu
+
+@page
+@node Ref.Mem.Alloc
+@subsection Ref.Mem.Alloc
+@c * Ref.Mem.Alloc:: Memory allocation model.
+
+The @dfn{items} of a program are those functions, iterators, objects, modules
+and types that have their value calculated at compile-time and stored uniquely
+in the memory image of the rust process. Items are neither dynamically
+allocated nor freed.
+
+A task's @dfn{stack} consists of activation frames automatically allocated on
+entry to each function as the task executes. A stack allocation is reclaimed
+when control leaves the frame containing it.
+
+The @dfn{heap} is a general term that describes two separate sets of exterior
+allocations: @emph{local heap} allocations and the @emph{shared heap}
+allocations.
+
+Exterior allocations of mutable types are @dfn{local heap} allocations,
+owned by the task. Such @dfn{local allocations} cannot pass over channels and
+do not outlive the task that owns them. When unreferenced, they are collected
+using a general (cycle-aware) garbage-collector local to each task. Garbage
+collection within a local heap does not interrupt execution of other tasks.
+
+Exterior allocations of immutable types are @dfn{shared heap} allocations,
+and can be multiply-referenced by many different tasks. Such @dfn{shared
+allocations} can pass over channels, and live as long as the last task
+referencing them. When unreferenced, they are collected immediately using
+reference-counting.
+
+
+
+@page
+@node Ref.Mem.Own
+@subsection Ref.Mem.Own
+@c * Ref.Mem.Own:: Memory ownership model.
+
+A task @emph{owns} all the interior allocations in its stack and @emph{local}
+exterior allocations. A task @emph{shares} ownership of @emph{shared} exterior
+allocations. A task does not own any items.
+
+@dfn{Ownership} of an allocation means that the owning task is the only task
+that can access the allocation.
+
+@dfn{Sharing} of an allocation means that the same allocation may be
+concurrently referenced by multiple tasks. The only shared allocations are
+those that are immutable.
+
+When a stack frame is exited, its interior allocations are all released, and
+its references to heap allocations (both shared and owned) are dropped.
+
+When a task finishes, its stack is necessarily empty. The task's interior
+slots are released as the task itself is released, and its references to heap
+allocations are dropped.
+
+@page
+@node Ref.Mem.Slot
+@subsection Ref.Mem.Slot
+@c * Ref.Mem.Slot:: Memory containment and reference model.
+
+A @dfn{slot} is a component of an allocation. A slot either holds a value or
+the address of another allocation. Every slot has one of three possible
+@emph{modes}.
+
+The possible @dfn{modes} of a slot are:
+
+@itemize
+@sp 1
+@item @dfn{Interior mode}
+
+The slot holds the value of the slot.
+
+@sp 1
+@item @dfn{Exterior mode}
+
+The slot holds the address of a heap allocation that holds the value of the
+slot.
+
+Exterior slots are indicated by the @emph{at} sigil @code{@@}.
+
+For example, the following code allocates an exterior record, copies it by
+counted-reference to a second exterior slot, then modifies the record through
+the second exterior slot that points to the same exterior allocation.
+@example
+type point3d = rec(int x, int y, int z);
+let @@point3d pt1 = rec(x=1, y=2, z=3);
+let @@point3d pt2 = pt1;
+pt2.z = 4;
+@end example
+
+@sp 1
+@item @dfn{Alias mode}
+
+The slot holds the address of a value. The referenced value may reside within
+a stack allocation @emph{or} a heap allocation.
+
+Alias slots can @emph{only} be declared as members of a function or iterator
+signature, bound to the lifetime of a stack frame. Alias slots cannot be
+declared as members of general data types.
+
+Alias slots are indicated by the @emph{ampersand} sigil @code{&}.
+
+The following example function accepts a single read-only alias parameter:
+@example
+type point3d = rec(int x, int y, int z);
+
+fn extract_z(&point3d p) -> int @{
+ ret p.z;
+@}
+@end example
+
+The following example function accepts a single mutable alias
+parameter:
+@example
+fn incr(mutable &int i) @{
+ i = i + 1;
+@}
+@end example
+
+@end itemize
+
+@page
+@node Ref.Mem.Init
+@subsection Ref.Mem.Init
+@c * Ref.Mem.Init:: Initialization state of memory.
+
+A slot is either initialized or uninitialized at every point in a program. An
+@dfn{initialized} slot is one that holds a value. An @dfn{uninitialized} slot
+is one that has not yet had a value written into it, or has had its value
+deleted, and so holds undefined memory. The typestate system ensures that an
+uninitialized slot cannot be read, but can be written to. A slot becomes
+initialized in any statement that writes to it, and remains initialized until
+explicitly destroyed or until its enclosing allocation is destroyed.
+
+@page
+@node Ref.Mem.Acct
+@subsection Ref.Mem.Acct
+@c * Ref.Mem.Acct:: Memory accounting model.
+
+Every task belongs to a domain, and that domain tracks the amount of memory
+allocated and not yet released by tasks within it. @xref{Ref.Task.Dom}. Each
+domain has a memory budget. The @dfn{budget} of a domain is the maximum amount
+of memory that can be simultaneously allocated in the domain. If a task tries
+to allocate memory within a domain with an exceeded budget, the task will
+receive a signal.
+
+Within a task, accounting is strictly enforced: all memory allocated through
+the runtime library, both user data, sub-domains and runtime-support
+structures such as channel and signal queues, are charged to a task's domain.
+
+When a communication channel crosses from one domain to another, any value
+sent over the channel is guaranteed to have been @emph{detached} from the
+domain's memory graph (singly referenced, and/or deep-copied), so its memory
+cost is transferred to the receiving domain.
+
+
+@page
+@node Ref.Task
+@section Ref.Task
+@c * Ref.Task:: Semantic model of tasks.
+
+A executing Rust program consists of a tree of tasks. A Rust @dfn{task}
+consists of an entry function, a stack, a set of outgoing communication
+channels and incoming communication ports, and ownership of some portion of
+the heap of a single operating-system process.
+
+Multiple Rust tasks may coexist in a single operating-system
+process. Execution of multiple Rust tasks in a single operating-system process
+may be either truly concurrent or interleaved by the runtime scheduler. Rust
+tasks are lightweight: each consumes less memory than an operating-system
+process, and switching between Rust tasks is faster than switching between
+operating-system processes.
+
+@menu
+* Ref.Task.Comm:: Inter-task communication.
+* Ref.Task.Life:: Task lifecycle and state transitions.
+* Ref.Task.Dom:: Task domains.
+* Ref.Task.Sched:: Task scheduling model.
+@end menu
+
+@page
+@node Ref.Task.Comm
+@subsection Ref.Task.Comm
+@c * Ref.Task.Comm:: Inter-task communication.
+
+With the exception of @emph{unsafe} constructs, Rust tasks are isolated from
+interfering with one another's memory directly. Instead of manipulating shared
+storage, Rust tasks communicate with one another using a typed, asynchronous,
+simplex message-passing system.
+
+A @dfn{port} is a communication endpoint that can @emph{receive}
+messages. Ports receive messages from channels.
+
+A @dfn{channel} is a communication endpoint that can @emph{send}
+messages. Channels send messages to ports.
+
+Each port has a unique identity and cannot be replicated. If a port value is
+copied from one slot to another, both slots refer to the @emph{same} port,
+even if the slots are declared as interior-mode. New ports can be constructed
+dynamically and stored in data structures.
+
+Each channel is bound to a port when the channel is constructed, so the
+destination port for a channel must exist before the channel itself. A channel
+cannot be rebound to a different port from the one it was constructed with.
+
+Many channels can be bound to the same port, but each channel is bound to a
+single port. In other words, channels and ports exist in an N:1 relationship,
+N channels to 1 port. @footnote{It may help to remember nautical terminology
+when differentiating channels from ports. Many different waterways --
+channels -- may lead to the same port.}
+
+Each port and channel can carry only one type of message. The message type is
+encoded as a parameter of the channel or port type. The message type of a
+channel is equal to the message type of the port it is bound to.
+
+Messages are sent asynchronously or semi-synchronously. A channel contains a
+message queue and asynchronously sending a message merely inserts it into the
+channel's queue; message receipt is the responsibility of the receiving task.
+
+Queued messages in channels are charged to the domain of the @emph{sending}
+task. If too many messages are queued for transmission from a single sending
+task, without being received by a receiving task, the sending task may exceed
+its memory budget, which causes a run-time signal. To help control this
+possibility, a semi-synchronous send operation is possible, which blocks until
+there is room in the existing queue and then executes an asynchronous send. A
+full @code{flush} operation is also available, which blocks until a channel's
+queue is @emph{empty}. A @code{flush} does @emph{not} guarantee that a message
+has been @emph{received} by any particular recipient when the sending task is
+unblocked. @xref{Ref.Stmt.Flush}.
+
+The asynchronous message-send operator is @code{<+}. The semi-synchronous
+message-send operator is @code{<|}. @xref{Ref.Stmt.Send}. The message-receive
+operator is @code{<-}. @xref{Ref.Stmt.Recv}.
+
+@page
+@node Ref.Task.Life
+@subsection Ref.Task.Life
+@c * Ref.Task.Life:: Task lifecycle and state transitions.
+
+The @dfn{lifecycle} of a task consists of a finite set of states and events
+that cause transitions between the states. The lifecycle states of a task are:
+
+@itemize
+@item running
+@item blocked
+@item failing
+@item dead
+@end itemize
+
+A task begins its lifecycle -- once it has been spawned -- in the
+@emph{running} state. In this state it executes the statements of its entry
+function, and any functions called by the entry function.
+
+A task may transition from the @emph{running} state to the @emph{blocked}
+state any time it executes a communication statement on a port or channel that
+cannot be immediately completed. When the communication statement can be
+completed -- when a message arrives at a sender, or a queue drains
+sufficiently to complete a semi-synchronous send -- then the blocked task will
+unblock and transition back to @emph{running}.
+
+A task may transition to the @emph{failing} state at any time, due to an
+un-trapped signal or the execution of a @code{fail} statement. Once
+@emph{failing}, a task unwinds its stack and transitions to the @emph{dead}
+state. Unwinding the stack of a task is done by the task itself, on its own
+control stack. If a value with a destructor is freed during unwinding, the
+code for the destructor is run, also on the task's control stack. If the
+destructor code causes any subsequent state transitions, the task of unwinding
+and failing may suspend temporarily, and may involve (recursive) unwinding of
+the stack of a failed destructor. Nonetheless, the outermost unwinding
+activity will continue until the stack is unwound and the task transitions to
+the @emph{dead} state. There is no way to ``recover'' from task failure.
+
+A task in the @emph{dead} state cannot transition to other states; it exists
+only to have its termination status inspected by other tasks, and/or to await
+reclamation when the last reference to it drops.
+
+@page
+@node Ref.Task.Dom
+@subsection Ref.Task.Dom
+@c * Ref.Task.Dom:: Task domains
+
+Every task belongs to a domain. A @dfn{domain} is a structure that owns tasks,
+schedules tasks, tracks memory allocation within tasks and manages access to
+runtime services on behalf of tasks.
+
+Typically each domain runs on a separate operating-system @emph{thread}, or
+within an isolated operating-system @emph{process}. An easy way to think of a
+domain is as an abstraction over either an operating-system thread @emph{or} a
+process.
+
+The key feature of a domain is that it isolates memory references created by
+the Rust tasks within it. No Rust task can refer directly to memory outside
+its domain.
+
+Tasks can own sub-domains, which in turn own their own tasks. Every domain
+owns one @emph{root task}, which is the root of the tree of tasks owned by the
+domain.
+
+@page
+@node Ref.Task.Sched
+@subsection Ref.Task.Sched
+@c * Ref.Task.Sched:: Task scheduling model.
+
+Every task is @emph{scheduled} within its domain. @xref{Ref.Task.Dom}. The
+currently scheduled task is given a finite @emph{time slice} in which to
+execute, after which it is @emph{descheduled} at a loop-edge or similar
+preemption point, and another task within the domain is scheduled,
+pseudo-randomly.
+
+An executing task can @code{yield} control at any time, which deschedules it
+immediately. Entering any other non-executing state (blocked, dead) similarly
+deschedules the task.
+
+@page
+@node Ref.Item
+@section Ref.Item
+@c * Ref.Item:: The components of a module.
+
+An @dfn{item} is a component of a module. Items are entirely determined at
+compile-time, remain constant during execution, and may reside in read-only
+memory.
+
+There are 5 primary kinds of item: modules, functions, iterators, objects and
+types.
+
+All items form an implicit scope for the declaration of sub-items. In other
+words, within a function, object or iterator, declarations of items can (in
+many cases) be mixed with the statements, control blocks, and similar
+artifacts that otherwise compose the item body. The meaning of these scoped
+items is the same as if the item was declared outside the scope, except that
+the item's @emph{path name} within the module namespace is qualified by the
+name of the enclosing item. The exact locations in which sub-items may be
+declared is given by the grammar. @xref{Ref.Gram}.
+
+Functions, iterators, objects and types may be @emph{parametrized} by
+type. Type parameters are given as a comma-separated list of identifiers
+enclosed in square brackets (@code{[]}), after the name of the item and before
+its definition. The type parameters of an item are part of the name, not the
+type of the item; in order to refer to the type-parametrized item, a
+referencing name must in general provide type arguments as a list of
+comma-separated types enclosed within square brackets (though the
+type-inference system can often infer such argument types from context). There
+are no general parametric types.
+
+@menu
+* Ref.Item.Mod:: Items defining modules.
+* Ref.Item.Fn:: Items defining functions.
+* Ref.Item.Iter:: Items defining iterators.
+* Ref.Item.Obj:: Items defining objects.
+* Ref.Item.Type:: Items defining the types of values and slots.
+@end menu
+
+@page
+@node Ref.Item.Mod
+@subsection Ref.Item.Mod
+@c * Ref.Item.Mod:: Items defining sub-modules.
+
+A @dfn{module item} contains declarations of other @emph{items}. The items
+within a module may be functions, modules, objects or types. These
+declarations have both static and dynamic interpretation. The purpose of a
+module is to organize @emph{names} and control @emph{visibility}. Modules are
+declared with the keyword @code{mod}.
+
+An example of a module:
+@example
+mod math @{
+ type complex = (f64,f64);
+ fn sin(f64) -> f64 @{
+ @dots{}
+ @}
+ fn cos(f64) -> f64 @{
+ @dots{}
+ @}
+ fn tan(f64) -> f64 @{
+ @dots{}
+ @}
+ @dots{}
+@}
+@end example
+
+Modules may also include any number of @dfn{import and export
+declarations}. These declarations must precede any module item declarations
+within the module, and control the visibility of names both within the module
+and outside of it.
+
+@menu
+* Ref.Item.Mod.Import:: Declarations for module-local synonyms.
+* Ref.Item.Mod.Export:: Declarations for restricting visibility.
+@end menu
+
+@page
+@node Ref.Item.Mod.Import
+@subsubsection Ref.Item.Mod.Import
+@c * Ref.Item.Mod.Import:: Declarations for module-local synonyms.
+
+An @dfn{import declaration} creates one or more local name bindings synonymous
+with some other name. Usually an import declaration is used to shorten the
+path required to refer to a module item.
+
+@emph{Note}: unlike many languages, Rust's @code{import} declarations do
+@emph{not} declare linkage-dependency with external crates. Linkage
+dependencies are independently declared with @code{use}
+declarations. @xref{Ref.Comp.Crate}.
+
+An example of an import:
+@example
+import std.math.sin;
+fn main() @{
+ // Equivalent to 'log std.math.sin(1.0);'
+ log sin(1.0);
+@}
+@end example
+
+@page
+@node Ref.Item.Mod.Export
+@subsubsection Ref.Item.Mod.Export
+@c * Ref.Item.Mod.Import:: Declarations for restricting visibility.
+
+An @dfn{export declaration} restricts the set of local declarations within a
+module that can be accessed from code outside the module. By default, all
+local declarations in a module are exported. If a module contains an export
+declaration, this declaration replaces the default export with the export
+specified.
+
+An example of an export:
+@example
+mod foo @{
+ export primary;
+
+ fn primary() @{
+ helper(1, 2);
+ helper(3, 4);
+ @}
+
+ fn helper(int x, int y) @{
+ @dots{}
+ @}
+@}
+
+fn main() @{
+ foo.primary(); // Will compile.
+ foo.helper(2,3) // ERROR: will not compile.
+@}
+@end example
+
+
+
+@page
+@node Ref.Item.Fn
+@subsection Ref.Item.Fn
+@c * Ref.Item.Fn:: Items defining functions.
+
+A @dfn{function item} defines a sequence of statements associated with a name
+and a set of parameters. Functions are declared with the keyword
+@code{fn}. Functions declare a set of @emph{input slots} as parameters,
+through which the caller passes arguments into the function, and an
+@emph{output slot} through which the function passes results back to the
+caller.
+
+A function may also be copied into a first class @emph{value}, in which case
+the value has the corresponding @emph{function type}, and can be used
+otherwise exactly as a function item (with a minor additional cost of calling
+the function, as such a call is indirect). @xref{Ref.Type.Fn}.
+
+Every control path in a function ends with either a @code{ret} or @code{be}
+statement. If a control path lacks a @code{ret} statement in source code, an
+implicit @code{ret} statement is appended to the end of the control path
+during compilation, returning the implicit @code{()} value.
+
+A function may have an @emph{effect}, which may be either @code{io},
+@code{state}, @code{unsafe}. If no effect is specified, the function is said
+to be @dfn{pure}.
+
+Any pure boolean function is also called a @emph{predicate}, and may be used
+as part of the static typestate system. @xref{Ref.Stmt.Stat.Constr}.
+
+An example of a function:
+@example
+fn add(int x, int y) -> int @{
+ ret x + y;
+@}
+@end example
+
+@page
+@node Ref.Item.Iter
+@subsection Ref.Item.Iter
+@c * Ref.Item.Iter:: Items defining iterators.
+
+Iterators are function-like items that can @code{put} multiple values during
+their execution before returning or tail-calling.
+
+Putting a value is similar to returning a value -- the argument to @code{put}
+is copied into the caller's frame and control transfers back to the caller --
+but the iterator frame is only @emph{suspended} during the put, and will be
+@emph{resumed} at the statement after the @code{put}, on the next iteration of
+the caller's loop.
+
+The output type of an iterator is the type of value that the function will
+@code{put}, before it eventually executes a @code{ret} or @code{be} statement
+of type @code{()} and completes its execution.
+
+An iterator can only be called in the loop header of a matching @code{for
+each} loop or as the argument in a @code{put each} statement.
+@xref{Ref.Stmt.Foreach}.
+
+An example of an iterator:
+@example
+iter range(int lo, int hi) -> int @{
+ let int i = lo;
+ while (i < hi) @{
+ put i;
+ i = i + 1;
+ @}
+@}
+
+let int sum = 0;
+for each (int x = range(0,100)) @{
+ sum += x;
+@}
+@end example
+
+
+@page
+@node Ref.Item.Obj
+@subsection Ref.Item.Obj
+@c * Ref.Item.Obj:: Items defining objects.
+
+An @dfn{object item} defines the @emph{state} and @emph{methods} of a set of
+@emph{object values}. Object values have object types. @xref{Ref.Type.Obj}.
+
+An @emph{object item} declaration -- in addition to providing a scope for
+state and method declarations -- implicitly declares a static function called
+the @emph{object constructor}, as well as a named @emph{object type}. The name
+given to the object item is resolved to a type when used in type context, or a
+constructor function when used in value context (such as a call).
+
+Example of an object item:
+@example
+obj counter(int state) @{
+ fn incr() @{
+ state += 1;
+ @}
+ fn get() -> int @{
+ ret state;
+ @}
+@}
+
+let counter c = counter(1);
+
+c.incr();
+c.incr();
+check (c.get() == 3);
+@end example
+
+@page
+@node Ref.Item.Type
+@subsection Ref.Item.Type
+@c * Ref.Item.Type:: Items defining the types of values and slots.
+
+A @dfn{type} defines an @emph{interpretation} of a value in
+memory. @xref{Ref.Type}. Types are declared with the keyword @code{type}. A
+type's interpretation is used for the values held in any slot with that
+type. @xref{Ref.Mem.Slot}. The interpretation of a value includes:
+
+@itemize
+@item Whether the value is composed of sub-values or is indivisible.
+@item Whether the value represents textual or numerical information.
+@item Whether the value represents integral or floating-point information.
+@item The sequence of memory operations required to access the value.
+@item Whether the value is mutable or immutable.
+@end itemize
+
+For example, the type @code{rec(u8 x, u8 y)} defines the
+interpretation of values that are composite records, each containing
+two unsigned two's complement 8-bit integers accessed through the
+components @code{x} and @code{y}, and laid out in memory with the
+@code{x} component preceding the @code{y} component.
+
+Some types are @emph{recursive}. A recursive type is one that includes
+its own definition as a component, by named reference. Recursive types
+are restricted to occur only within a single crate, and only through a
+restricted form of @code{tag} type. @xref{Ref.Type.Tag}.
+
+@page
+@node Ref.Type
+@section Ref.Type
+
+Every slot and value in a Rust program has a type. The @dfn{type} of a
+@emph{value} defines the interpretation of the memory holding it. The type of
+a @emph{slot} may also include constraints. @xref{Ref.Type.Constr}.
+
+Built-in types and type-constructors are tightly integrated into the language,
+in nontrivial ways that are not possible to emulate in user-defined
+types. User-defined types have limited capabilities. In addition, every
+built-in type or type-constructor name is reserved as a @emph{keyword} in
+Rust; they cannot be used as user-defined identifiers in any context.
+
+@menu
+* Ref.Type.Any:: An open sum of every possible type.
+* Ref.Type.Mach:: Machine-level types.
+* Ref.Type.Int:: The machine-dependent integer types.
+* Ref.Type.Prim:: Primitive types.
+* Ref.Type.Big:: The arbitrary-precision integer type.
+* Ref.Type.Text:: Strings and characters.
+* Ref.Type.Rec:: Labeled products of heterogeneous types.
+* Ref.Type.Tup:: Unlabeled products of homogeneous types.
+* Ref.Type.Vec:: Open products of homogeneous types.
+* Ref.Type.Tag:: Disjoint sums of heterogeneous types.
+* Ref.Type.Fn:: Subroutine types.
+* Ref.Type.Iter:: Scoped coroutine types.
+* Ref.Type.Port:: Unique inter-task message-receipt endpoints.
+* Ref.Type.Chan:: Copyable inter-task message-send capabilities.
+* Ref.Type.Task:: General coroutine-instance types.
+* Ref.Type.Obj:: Abstract types.
+* Ref.Type.Constr:: Constrained types.
+* Ref.Type.Type:: Types describing types.
+@end menu
+
+@page
+@node Ref.Type.Any
+@subsection Ref.Type.Any
+
+The type @code{any} is the union of all possible Rust types. A value of type
+@code{any} is represented in memory as a pair consisting of an exterior value
+of some non-@code{any} type @var{T} and a reflection of the type @var{T}.
+
+Values of type @code{any} can be used in an @code{alt type} statement, in
+which the reflection is used to select a block corresponding to a particular
+type extraction. @xref{Ref.Stmt.Alt}.
+
+@page
+@node Ref.Type.Mach
+@subsection Ref.Type.Mach
+
+The machine types are the following:
+
+@itemize
+@item
+The unsigned two's complement word types @code{u8}, @code{u16}, @code{u32} and
+@code{u64}, with values drawn from the integer intervals
+@iftex
+@math{[0, 2^8 - 1]},
+@math{[0, 2^{16} - 1]},
+@math{[0, 2^{32} - 1]} and
+@math{[0, 2^{64} - 1]}
+@end iftex
+@ifhtml
+@html
+[0, 2<sup>8</sup>-1],
+[0, 2<sup>16</sup>-1],
+[0, 2<sup>32</sup>-1] and
+[0, 2<sup>64</sup>-1]
+@end html
+@end ifhtml
+ respectively.
+@item
+The signed two's complement word types @code{i8}, @code{i16}, @code{i32} and
+@code{i64}, with values drawn from the integer intervals
+@iftex
+@math{[-(2^7),(2^7)-1)]},
+@math{[-(2^{15}),2^{15}-1)]},
+@math{[-(2^{31}),2^{31}-1)]} and
+@math{[-(2^{63}),2^{63}-1)]}
+@end iftex
+@ifhtml
+@html
+[-(2<sup>7</sup>), 2<sup>7</sup>-1],
+[-(2<sup>15</sup>), 2<sup>15</sup>-1],
+[-(2<sup>31</sup>), 2<sup>31</sup>-1] and
+[-(2<sup>63</sup>), 2<sup>63</sup>-1]
+@end html
+@end ifhtml
+ respectively.
+@item
+The IEEE 754 single-precision and double-precision floating point types:
+@code{f32} and @code{f64}, respectively.
+@end itemize
+
+@page
+@node Ref.Type.Int
+@subsection Ref.Type.Int
+
+
+The Rust type @code{uint}@footnote{A Rust @code{uint} is analogous to a C99
+@code{uintptr_t}.} is a two's complement unsigned integer type with with
+target-machine-dependent size. Its size, in bits, is equal to the number of
+bits required to hold any memory address on the target machine.
+
+The Rust type @code{int}@footnote{A Rust @code{int} is analogous to a C99
+@code{intptr_t}.} is a two's complement signed integer type with
+target-machine-dependent size. Its size, in bits, is equal to the size of the
+rust type @code{uint} on the same target machine.
+
+
+
+@page
+@node Ref.Type.Prim
+@subsection Ref.Type.Prim
+
+The primitive types are the following:
+
+@itemize
+@item
+The ``nil'' type @code{()}, having the single ``nil'' value
+@code{()}.@footnote{The ``nil'' value @code{()} is @emph{not} a sentinel
+``null pointer'' value for alias or exterior slots; the ``nil'' type is the
+implicit return type from functions otherwise lacking a return type, and can
+be used in other contexts (such as message-sending or type-parametric code) as
+a zero-byte type.}
+@item
+The boolean type @code{bool} with values @code{true} and @code{false}.
+@item
+The machine types.
+@item
+The machine-dependent integer types.
+@end itemize
+
+
+@page
+@node Ref.Type.Big
+@subsection Ref.Type.Big
+
+The Rust type @code{big}@footnote{A Rust @code{big} is analogous to a Lisp
+bignum or a Python long integer.} is an arbitrary precision integer type that
+fits in a machine word @emph{when possible} and transparently expands to a
+boxed ``big integer'' allocated in the run-time heap when it overflows or
+underflows outside of the range of a machine word.
+
+A Rust @code{big} grows to accommodate extra binary digits as they are needed,
+by taking extra memory from the memory budget available to each Rust task, and
+should only exhaust its range due to memory exhaustion.
+
+@page
+@node Ref.Type.Text
+@subsection Ref.Type.Text
+
+The types @code{char} and @code{str} hold textual data.
+
+A value of type @code{char} is a Unicode character, represented as a 32-bit
+unsigned word holding a UCS-4 codepoint.
+
+A value of type @code{str} is a Unicode string, represented as a vector of
+8-bit unsigned bytes holding a sequence of UTF-8 codepoints.
+
+@page
+@node Ref.Type.Rec
+@subsection Ref.Type.Rec
+
+The record type-constructor @code{rec} forms a new heterogeneous product of
+slots.@footnote{The @code{rec} type-constructor is analogous to the
+@code{struct} type-constructor in the Algol/C family, the @emph{record} types
+of the ML family, or the @emph{structure} types of the Lisp family.} Fields of
+a @code{rec} type are accessed by name and are arranged in memory in the order
+specified by the @code{rec} type.
+
+An example of a @code{rec} type and its use:
+@example
+type point = rec(int x, int y);
+let point p = rec(x=10, y=11);
+let int px = p.x;
+@end example
+
+@page
+@node Ref.Type.Tup
+@subsection Ref.Type.Tup
+
+The tuple type-constructor @code{tup} forms a new heterogeneous product of
+slots exactly as the @code{rec} type-constructor does, with the difference
+that tuple slots are automatically assigned implicit field names, given by
+ascending integers prefixed by the underscore character: @code{_0}, @code{_1},
+@code{_2}, etc. The fields of a tuple are laid out in memory contiguously,
+like a record, in order specified by the tuple type.
+
+An example of a tuple type and its use:
+@example
+type pair = tup(int,str);
+let pair p = tup(10,"hello");
+check (p._0 == 10);
+p._1 = "world";
+check (p._1 == "world");
+@end example
+
+
+@page
+@node Ref.Type.Vec
+@subsection Ref.Type.Vec
+
+The vector type-constructor @code{vec} represents a homogeneous array of
+slots. A vector has a fixed size, and may or may not have mutable member
+slots. If the slots of a vector are mutable, the vector is a @emph{state}
+type.
+
+Vectors can be sliced. A slice expression builds a new vector by copying a
+contiguous range -- given by a pair of indices representing a half-open
+interval -- out of the sliced vector.
+
+And example of a @code{vec} type and its use:
+@example
+let vec[int] v = vec(7, 5, 3);
+let int i = v.(2);
+let vec[int] v2 = v.(0,1); // Form a slice.
+@end example
+
+Vectors always @emph{allocate} a storage region sufficient to store the first
+power of two worth of elements greater than or equal to the size of the
+largest slice sharing the storage. This behaviour supports idiomatic in-place
+``growth'' of a mutable slot holding a vector:
+
+@example
+let mutable vec[int] v = vec(1, 2, 3);
+v += vec(4, 5, 6);
+@end example
+
+Normal vector concatenation causes the allocation of a fresh vector to hold
+the result; in this case, however, the slot holding the vector recycles the
+underlying storage in-place (since the reference-count of the underlying
+storage is equal to 1).
+
+All accessible elements of a vector are always initialized, and access to a
+vector is always bounds-checked.
+
+
+@page
+@node Ref.Type.Tag
+@subsection Ref.Type.Tag
+
+The @code{tag} type-constructor forms new heterogeneous disjoint sum
+types.@footnote{The @code{tag} type is analogous to a @code{data} constructor
+declaration in ML or a @emph{pick ADT} in Limbo.} A @code{tag} type consists
+of a number of @emph{variants}, each of which is independently named and takes
+an optional tuple of arguments.
+
+The variants of a @code{tag} type may be recursive: that is, the definition of
+a @code{tag} type may refer to type definitions that include the defined
+@code{tag} type itself. Such recursion has restrictions:
+@itemize
+@item Recursive types can only be introduced through @code{tag} types.
+@item A recursive @code{tag} type must have at least one non-recursive
+variant (in order to give the recursion a basis case).
+@item The recursive slots of recursive variants must be @emph{exterior}
+slots (in order to bound the in-memory size of the variant).
+@item Recursive type definitions can cross module boundaries, but not module
+@emph{visibility} boundaries, nor crate boundaries (in order to simplify the
+module system).
+@end itemize
+
+An example of a @code{tag} type and its use:
+@example
+type animal = tag(dog, cat);
+let animal a = dog;
+a = cat;
+@end example
+
+An example of a @emph{recursive} @code{tag} type and its use:
+@example
+type list[T] = tag(nil,
+ cons(T, @@list[T]));
+let list[int] a = cons(7, cons(13, nil));
+@end example
+
+
+@page
+@node Ref.Type.Fn
+@subsection Ref.Type.Fn
+
+The function type-constructor @code{fn} forms new function types. A function
+type consists of a sequence of input slots, an optional set of input
+constraints (@pxref{Ref.Stmt.Stat.Constr}), an output slot, and an
+@emph{effect}. @xref{Ref.Item.Fn}.
+
+An example of a @code{fn} type:
+@example
+fn add(int x, int y) -> int @{
+ ret x + y;
+@}
+
+let int x = add(5,7);
+
+type binop = fn(int,int) -> int;
+let binop bo = add;
+x = bo(5,7);
+@end example
+
+@page
+@node Ref.Type.Iter
+@subsection Ref.Type.Iter
+
+The iterator type-constructor @code{iter} forms new iterator types. An
+iterator type consists a sequence of input slots, an optional set of input
+constraints, an output slot, and an @emph{effect}. @xref{Ref.Item.Iter}.
+
+An example of an @code{iter} type:
+@example
+iter range(int x, int y) -> int @{
+ while (x < y) @{
+ put x;
+ x += 1;
+ @}
+@}
+
+for each (int i = range(5,7)) @{
+ @dots{};
+@}
+@end example
+
+
+@page
+@node Ref.Type.Port
+@subsection Ref.Type.Port
+
+The port type-constructor @code{port} forms types that describe ports. A port
+is the @emph{receiving end} of a typed, asynchronous, simplex inter-task
+communication facility. @xref{Ref.Task.Comm}. A @code{port} type takes a
+single type parameter, denoting the type of value that can be received from a
+@code{port} value of that type.
+
+Ports are modeled as mutable native types with built-in meaning to the
+language. They cannot be transmitted over channels or otherwise replicated,
+and are always local to the task that creates them.
+
+An example of a @code{port} type:
+@example
+type port[vec[str]] svp;
+let svp p = get_port();
+let vec[str] v;
+v <- p;
+@end example
+
+@page
+@node Ref.Type.Chan
+@subsection Ref.Type.Chan
+
+The channel type-constructor @code{chan} forms types that describe channels. A
+channel is the @emph{sending end} of a typed, asynchronous, simplex inter-task
+communication facility. @xref{Ref.Task.Comm}. A @code{chan} type takes a
+single type parameter, denoting the type of value that can be sent to a
+channel of that type.
+
+Channels are immutable, and can be transmitted over channels to other
+tasks. They are modeled as immutable native types with built-in meaning to the
+language.
+
+When a task sends a message into a channel, the task forms an outgoing queue
+associated with that channel. The per-task queue @emph{associated} with a
+channel can be indirectly manipulated by the task, but is @emph{not} otherwise
+considered ``part of'' to the channel: the queue is ``part of'' the
+@emph{sending task}. Sending a channel to another task does not copy the queue
+associated with the channel.
+
+Channels are also @emph{weak}: a channel is directly coupled to a particular
+destination port on a particular task, but does not keep that port or task
+@emph{alive}. A channel may therefore fail to operate at any moment. If a task
+sends to a channel that is connected to a nonexistent port, it receives a
+signal.
+
+An example of a @code{chan} type:
+@example
+type chan[vec[str]] svc;
+let svc c = get_chan();
+let vec[str] v = vec("hello", "world");
+c <| v;
+@end example
+
+@page
+@node Ref.Type.Task
+@subsection Ref.Type.Task
+
+The task type @code{task} describes values that are @emph{live
+tasks}.
+
+Tasks form an @emph{ownership tree} in which each task (except the root task)
+is directly owned by exactly one parent task. The purpose of a variable of
+@code{task} type is to manage the lifecycle of the associated
+task. Communication is carried out solely using channels and ports.
+
+Like ports, tasks are modeled as mutable native types with built-in meaning to
+the language. They cannot be transmitted over channels or otherwise
+replicated, and are always local to the task that spawns them.
+
+If all references to a task are dropped (due to the release of any slots
+holding those references), the released task immediately fails.
+@xref{Ref.Task.Life}.
+
+
+@page
+@node Ref.Type.Obj
+@subsection Ref.Type.Obj
+@c * Ref.Type.Obj:: Object types.
+
+A @dfn{object type} describes values of abstract type, that carry some hidden
+@emph{fields} and are accessed through a set of un-ordered
+@emph{methods}. Every object item (@pxref{Ref.Item.Obj}) implicitly declares
+an object type carrying methods with types derived from all the methods of the
+object item.
+
+Object types can also be declared in isolation, independent of any object item
+declaration. Such a ``plain'' object type can be used to describe an interface
+that a variety of particular objects may conform to, by supporting a superset
+of the methods.
+
+An object type that can contain a state must be declared as a @code{state obj}
+like any other state type. And similarly a method type that performs I/O or
+makes native calls must be declared @code{io} or @code{unsafe}, like any other
+function.
+
+Moreover, @emph{all} methods of a state object are implicitly state functions -- as
+they all bind the same mutable state field(s) -- so implicitly have an effect
+lower than @code{io}. It is therefore unnecessary to declare methods within a
+state object type (or state object item) as @code{io}.
+
+An example of an object type with two separate object items supporting it, and
+a client function using both items via the object type:
+
+@example
+
+state type taker =
+ state obj @{
+ fn take(int);
+ @};
+
+state obj adder(mutable int x) @{
+ fn take(int y) @{
+ x += y;
+ @}
+@}
+
+obj sender(chan[int] c) @{
+ io fn take(int z) @{
+ c <| z;
+ @}
+@}
+
+fn give_ints(taker t) @{
+ t.take(1);
+ t.take(2);
+ t.take(3);
+@}
+
+let port[int] p = port();
+
+let taker t1 = adder(0);
+let taker t2 = sender(chan(p));
+
+give_ints(t1);
+give_ints(t2);
+
+@end example
+
+
+
+@page
+@node Ref.Type.Constr
+@subsection Ref.Type.Constr
+@c * Ref.Type.Constr:: Constrained types.
+
+A @dfn{constrained type} is a type that carries a @emph{formal constraint}
+(@pxref{Ref.Stmt.Stat.Constr}), which is similar to a normal constraint except
+that the @emph{base name} of any slots mentioned in the constraint must be the
+special @emph{formal symbol} @emph{*}.
+
+When a constrained type is instantiated in a particular slot declaration, the
+formal symbol in the constraint is replaced with the name of the declared slot
+and the resulting constraint is checked immediately after the slot is
+declared. @xref{Ref.Stmt.Check}.
+
+An example of a constrained type with two separate instantiations:
+@example
+type ordered_range = rec(int low, int high) : less_than(*.low, *.high);
+
+let ordered_range rng1 = rec(low=5, high=7);
+// implicit: 'check less_than(rng1.low, rng1.high);'
+
+let ordered_range rng2 = rec(low=15, high=17);
+// implicit: 'check less_than(rng2.low, rng2.high);'
+@end example
+
+@page
+@node Ref.Type.Type
+@subsection Ref.Type.Type
+@c * Ref.Type.Type:: Types describing types.
+
+@emph{TODO}.
+
+@page
+@node Ref.Expr
+@section Ref.Expr
+@c * Ref.Expr:: Parsed and primitive expressions.
+
+Rust has two kinds of expressions: @emph{parsed expressions} and
+@emph{primitive expressions}. The former are syntactic sugar and are
+eliminated during parsing. The latter are very minimal, consisting only of
+paths and primitive literals, possibly combined via a single level
+(non-recursive) unary or binary machine-level operation (ALU or
+FPU). @xref{Ref.Path}.
+
+For the most part, Rust semantics are defined in terms of @emph{statements},
+which parsed expressions are desugared to. The desugaring is defined in the
+grammar. @xref{Ref.Gram}. The residual primitive statements appear only in the
+right hand side of copy statements, @xref{Ref.Stmt.Copy}.
+
+@page
+@node Ref.Stmt
+@section Ref.Stmt
+@c * Ref.Stmt:: Executable statements.
+
+A @dfn{statement} is a component of a block, which is in turn a components of
+an outer block, a function or an iterator. When a function is spawned into a
+task, the task @emph{executes} statements in an order determined by the body
+of the enclosing structure. Each statement causes the task to perform certain
+actions.
+
+@menu
+* Ref.Stmt.Stat:: The static typestate system of statement analysis.
+* Ref.Stmt.Decl:: Statement declaring an item or slot.
+* Ref.Stmt.Copy:: Statement for copying a value between two slots.
+* Ref.Stmt.Spawn:: Statements for creating new tasks.
+* Ref.Stmt.Send:: Statements for sending a value into a channel.
+* Ref.Stmt.Flush:: Statement for flushing a channel queue.
+* Ref.Stmt.Recv:: Statement for receiving a value from a channel.
+* Ref.Stmt.Call:: Statement for calling a function.
+* Ref.Stmt.Bind:: Statement for binding arguments to functions.
+* Ref.Stmt.Ret:: Statement for stopping and producing a value.
+* Ref.Stmt.Be:: Statement for stopping and executing a tail call.
+* Ref.Stmt.Put:: Statement for pausing and producing a value.
+* Ref.Stmt.Fail:: Statement for causing task failure.
+* Ref.Stmt.Log:: Statement for logging values to diagnostic buffers.
+* Ref.Stmt.Note:: Statement for logging values during failure.
+* Ref.Stmt.While:: Statement for simple conditional looping.
+* Ref.Stmt.Break:: Statement for terminating a loop.
+* Ref.Stmt.Cont:: Statement for terminating a single loop iteration.
+* Ref.Stmt.For:: Statement for looping over strings and vectors.
+* Ref.Stmt.Foreach:: Statement for looping via an iterator.
+* Ref.Stmt.If:: Statement for simple conditional branching.
+* Ref.Stmt.Alt:: Statement for complex conditional branching.
+* Ref.Stmt.Prove:: Statement for static assertion of typestate.
+* Ref.Stmt.Check:: Statement for dynamic assertion of typestate.
+* Ref.Stmt.IfCheck:: Statement for dynamic testing of typestate.
+@end menu
+
+@page
+@node Ref.Stmt.Stat
+@subsection Ref.Stmt.Stat
+@c * Ref.Stmt.Stat:: The static typestate system of statement analysis.
+
+Statements have a detailed static semantics. The static semantics determine,
+on a statement-by-statement basis, the @emph{effects} the statement has on its
+environment, as well the @emph{legality} of the statement in its environment.
+
+The legality of a statement is partly governed by syntactic rules, partly by
+its conformance to the types of slots it affects, and partly by a
+statement-oriented static dataflow analysis. This section describes the
+statement-oriented static dataflow analysis, also called the @emph{typestate}
+system.
+
+@menu
+* Ref.Stmt.Stat.Point:: Inter-statement positions of logical judgements.
+* Ref.Stmt.Stat.CFG:: The control flow graph formed by statements.
+* Ref.Stmt.Stat.Constr:: Predicates applied to slots.
+* Ref.Stmt.Stat.Cond:: Constraints required and implied by a statement.
+* Ref.Stmt.Stat.Typestate:: Constraints that hold at points.
+* Ref.Stmt.Stat.Check:: Relating dynamic state to static typestate.
+@end menu
+
+@page
+@node Ref.Stmt.Stat.Point
+@subsubsection Ref.Stmt.Stat.Point
+@c * Ref.Stmt.Stat.Point:: Inter-statement positions of logical judgements.
+
+A @dfn{point} exists before and after any statement in a Rust program.
+For example, this code:
+
+@example
+ s = "hello, world";
+ print(s);
+@end example
+
+Consists of two statements and four points:
+
+@itemize
+@item the point before the first statement
+@item the point after the first statement
+@item the point before the second statement
+@item the point after the second statement
+@end itemize
+
+The typestate system reasons over points, rather than statements. This may
+seem counter-intuitive, but points are the more primitive concept. Another way
+of thinking about a point is as a set of @emph{instants in time} at which the
+state of a task is fixed. By contrast, a statement represents a @emph{duration
+in time}, during which the state of the task changes. The typestate system is
+concerned with constraining the possible states of a task's memory at
+@emph{instants}; it is meaningless to speak of the state of a task's memory
+``at'' a statement, as each statement is likely to change the contents of
+memory.
+
+@page
+@node Ref.Stmt.Stat.CFG
+@subsubsection Ref.Stmt.Stat.CFG
+@c * Ref.Stmt.Stat.CFG:: The control flow graph formed by statements.
+
+Each @emph{point} can be considered a vertex in a directed @emph{graph}. Each
+kind of statement implies a single edge in this graph between the point before
+the statement and the point after it, as well as a set of zero or more edges
+from the points of the statement to points before other statements. The edges
+between points represent @emph{possible} indivisible control transfers that
+might occur during execution.
+
+This implicit graph is called the @dfn{control flow graph}, or @dfn{CFG}.
+
+@page
+@node Ref.Stmt.Stat.Constr
+@subsubsection Ref.Stmt.Stat.Constr
+@c * Ref.Stmt.Stat.Constr:: Predicates applied to slots.
+
+A @dfn{predicate} is any pure boolean function. @xref{Ref.Item.Fn}.
+
+A @dfn{constraint} is a predicate applied to specific slots.
+
+For example, consider the following code:
+
+@example
+fn is_less_than(int a, int b) -> bool @{
+ ret a < b;
+@}
+
+fn test() @{
+ let int x = 10;
+ let int y = 20;
+ check is_less_than(x,y);
+@}
+@end example
+
+This example defines the predicate @code{is_less_than}, and applies it to the
+slots @code{x} and @code{y}. The constraint being checked on the third line of
+the function is @code{is_less_than(x,y)}.
+
+Predicates can only apply to slots holding immutable values. The slots a
+predicate applies to can themselves be mutable, but the types of values held
+in those slots must be immutable.
+
+@page
+@node Ref.Stmt.Stat.Cond
+@subsubsection Ref.Stmt.Stat.Cond
+@c * Ref.Stmt.Stat.Cond:: Constraints required and implied by a statement.
+
+A @dfn{condition} is a set of zero or more constraints.
+
+Each @emph{point} has an associated @emph{condition}:
+
+@itemize
+@item The @dfn{precondition} of a statement is the condition the statement
+requires in the point before the condition.
+@item The @dfn{postcondition} of a statement is the condition the statement
+enforces in the point after the statement.
+@end itemize
+
+Any constraint present in the precondition and @emph{absent} in the
+postcondition is considered to be @emph{dropped} by the statement.
+
+@page
+@node Ref.Stmt.Stat.Typestate
+@subsubsection Ref.Stmt.Stat.Typestate
+@c * Ref.Stmt.Stat.Typestate:: Constraints that hold at points.
+
+The typestate checking system @emph{calculates} an additional
+condition for each point called its typestate. For a given statement,
+we call the two typestates associated with its two points the prestate
+and a poststate.
+
+@itemize
+@item The @dfn{prestate} of a statement is the typestate of the point
+before the statement.
+@item The @dfn{poststate} of a statement is the typestate of the point
+after the statement.
+@end itemize
+
+A @dfn{typestate} is a condition that has @emph{been determined by the
+typestate algorithm} to hold at a point. This is a subtle but important point
+to understand: preconditions and postconditions are @emph{inputs} to the
+typestate algorithm; prestates and poststates are @emph{outputs} from the
+typestate algorithm.
+
+The typestate algorithm analyses the preconditions and postconditions of every
+statement in a block, and computes a condition for each
+typestate. Specifically:
+
+@itemize
+@item Initially, every typestate is empty.
+@item Each statement's poststate is given the union of the statement's
+prestate, precondition, and postcondition.
+@item Each statement's poststate has the difference between the statement's
+precondition and postcondition removed.
+@item Each statement's prestate is given the intersection of the poststates
+of every parent statement in the CFG.
+@item The previous three steps are repeated until no typestates in the
+block change.
+@end itemize
+
+The typestate algorithm is a very conventional dataflow calculation, and can
+be performed using bit-set operations, with one bit per predicate and one
+bit-set per condition.
+
+After the typestates of a block are computed, the typestate algorithm checks
+that every constraint in the precondition of a statement is satisfied by its
+prestate. If any preconditions are not satisfied, the mismatch is considered a
+static (compile-time) error.
+
+
+@page
+@node Ref.Stmt.Stat.Check
+@subsubsection Ref.Stmt.Stat.Check
+@c * Ref.Stmt.Stat.Check:: Relating dynamic state to static typestate.
+
+The key mechanism that connects run-time semantics and compile-time analysis
+of typestates is the use of @code{check} statements. @xref{Ref.Stmt.Check}. A
+@code{check} statement guarantees that @emph{if} control were to proceed past
+it, the predicate associated with the @code{check} would have succeeded, so
+the constraint being checked @emph{statically} holds in subsequent
+statements.@footnote{A @code{check} statement is similar to an @code{assert}
+call in a C program, with the significant difference that the Rust compiler
+@emph{tracks} the constraint that each @code{check} statement
+enforces. Naturally, @code{check} statements cannot be omitted from a
+``production build'' of a Rust program the same way @code{asserts} are
+frequently disabled in deployed C programs.}
+
+It is important to understand that the typestate system has @emph{no insight}
+into the meaning of a particular predicate. Predicates and constraints are not
+evaluated in any way at compile time. Predicates are treated as specific (but
+unknown) functions applied to specific (also unknown) slots. All the typestate
+system does is track which of those predicates -- whatever they calculate --
+@emph{must have been checked already} in order for program control to reach a
+particular point in the CFG. The fundamental building block, therefore, is the
+@code{check} statement, which tells the typestate system ``if control passes
+this statement, the checked predicate holds''.
+
+From this building block, constraints can be propagated to function signatures
+and constrained types, and the responsibility to @code{check} a constraint
+pushed further and further away from the site at which the program requires it
+to hold in order to execute properly.
+
+@page
+@node Ref.Stmt.Decl
+@subsection Ref.Stmt.Decl
+@c * Ref.Stmt.Decl:: Statement declaring an item or slot.
+
+A @dfn{declaration statement} is one that introduces a @emph{name} into the
+enclosing statement block. The declared name may denote a new slot or a new
+item. The scope of the name extends to the entire containing block, both
+before and after the declaration.
+
+@menu
+* Ref.Stmt.Decl.Item:: Statement declaring an item.
+* Ref.Stmt.Decl.Slot:: Statement declaring a slot.
+@end menu
+
+@page
+@node Ref.Stmt.Decl.Item
+@subsubsection Ref.Stmt.Decl.Item
+@c * Ref.Stmt.Decl.Item:: Statement declaring an item.
+
+An @dfn{item declaration statement} has a syntactic form identical to an item
+declaration within a module. Declaring an item -- a function, iterator,
+object, type or module -- locally within a statement block is simply a way of
+restricting its scope to a narrow region containing all of its uses; it is
+otherwise identical in meaning to declaring the item outside the statement
+block.
+
+Note: there is no implicit capture of the function's dynamic environment when
+declaring a function-local item.
+
+@page
+@node Ref.Stmt.Decl.Slot
+@subsubsection Ref.Stmt.Decl.Slot
+@c * Ref.Stmt.Decl.Slot:: Statement declaring an slot.
+
+A @code{slot declaration statement} has one one of two forms:
+
+@itemize
+@item @code{let} @var{mode-and-type} @var{slot} @var{optional-init};
+@item @code{auto} @var{slot} @var{optional-init};
+@end itemize
+
+Where @var{mode-and-type} is a slot mode and type expression, @var{slot} is
+the name of the slot being declared, and @var{optional-init} is either the
+empty string or an equals sign (@code{=}) followed by a primitive expression.
+
+Both forms introduce a new slot into the containing block scope. The new slot
+is visible across the entire scope, but is initialized only at the point
+following the declaration statement.
+
+The latter (@code{auto}) form of slot declaration causes the compiler to infer
+the static type of the slot through unification with the types of values
+assigned to the slot in the the remaining code in the block scope. Inferred
+slots always have @emph{interior} mode. @xref{Ref.Mem.Slot}.
+
+
+
+@page
+@node Ref.Stmt.Copy
+@subsection Ref.Stmt.Copy
+@c * Ref.Stmt.Copy:: Statement for copying a value between two slots.
+
+A @dfn{copy statement} consists of an @emph{lval} -- a name denoting a slot --
+followed by an equals-sign (@code{=}) and a primitive
+expression. @xref{Ref.Expr}.
+
+Executing a copy statement causes the value denoted by the expression --
+either a value in a slot or a primitive combination of values held in slots --
+to be copied into the slot denoted by the @emph{lval}.
+
+A copy may entail the formation of references, the adjustment of reference
+counts, execution of destructors, or similar adjustments in order to respect
+the @code{lval} slot mode and any existing value held in it. All such
+adjustment is automatic and implied by the @code{=} operator.
+
+An example of three different copy statements:
+@example
+x = y;
+x.y = z;
+x.y = z + 2;
+@end example
+
+@page
+@node Ref.Stmt.Spawn
+@subsection Ref.Stmt.Spawn
+@c * Ref.Stmt.Spawn:: Statements creating new tasks.
+
+A @code{spawn} statement consists of keyword @code{spawn}, followed by a
+normal @emph{call} statement (@pxref{Ref.Stmt.Call}). A @code{spawn}
+statement causes the runtime to construct a new task executing the called
+function. The called function is referred to as the @dfn{entry function} for
+the spawned task, and its arguments are copied form the spawning task to the
+spawned task before the spawned task begins execution.
+
+Only arguments of interior or exterior mode are permitted in the function
+called by a spawn statement, not arguments with alias mode.
+
+The result of a @code{spawn} statement is a @code{task} value.
+
+An example of a @code{spawn} statement:
+@example
+fn helper(chan[u8] out) @{
+ // do some work.
+ out <| result;
+@}
+
+let port[u8] out;
+let task p = spawn helper(chan(out));
+// let task run, do other things.
+auto result <- out;
+
+@end example
+
+@page
+@node Ref.Stmt.Send
+@subsection Ref.Stmt.Send
+@c * Ref.Stmt.Send:: Statements for sending a value into a channel.
+
+Sending a value through a channel can be done via two different statements.
+Both statements take an @emph{lval}, denoting a channel, and a value to send
+into the channel. The action of @emph{sending} varies depending on the
+@dfn{send operator} employed.
+
+The @emph{asynchronous send} operator @code{<+} adds a value to the channel's
+queue, without blocking. If the queue is full, it is extended, taking memory
+from the task's domain. If the task memory budget is exhausted, a signal is
+sent to the task.
+
+The @emph{semi-synchronous send} operator @code{<|} adds a value to the
+channel's queue @emph{only if} the queue has room; if the queue is full, the
+operation @emph{blocks} the sender until the queue has room.
+
+An example of an asynchronous send:
+@example
+chan[str] c = @dots{};
+c <+ "hello, world";
+@end example
+
+An example of a semi-synchronous send:
+@example
+chan[str] c = @dots{};
+c <| "hello, world";
+@end example
+
+@page
+@node Ref.Stmt.Flush
+@subsection Ref.Stmt.Flush
+@c * Ref.Stmt.Flush:: Statement for flushing a channel queue.
+
+A @code{flush} statement takes a channel and blocks the flushing task until
+the channel's queue has emptied. It can be used to implement a more precise
+form of flow-control than with the send operators alone.
+
+An example of the @code{flush} statement:
+@example
+chan[str] c = @dots{};
+c <| "hello, world";
+flush c;
+@end example
+
+
+@page
+@node Ref.Stmt.Recv
+@subsection Ref.Stmt.Recv
+@c * Ref.Stmt.Recv:: Statement for receiving a value from a channel.
+
+The @dfn{receive statement} takes an @var{lval} to receive into and an
+expression denoting a port, and applies the @emph{receive operator}
+(@code{<-}) to the pair, copying a value out of the port and into the
+@var{lval}. The statement causes the receiving task to enter the @emph{blocked
+reading} state until a task is sending a value to the port, at which point the
+runtime pseudo-randomly selects a sending task and copies a value from the
+head of one of the task queues to the receiving slot, and un-blocks the
+receiving task. @xref{Ref.Run.Comm}.
+
+An example of a @emph{receive}:
+@example
+port[str] p = @dots{};
+let str s <- p;
+@end example
+
+@page
+@node Ref.Stmt.Call
+@subsection Ref.Stmt.Call
+@c * Ref.Stmt.Call:: Statement for calling a function.
+
+A @dfn{call statement} invokes a function, providing a tuple of input slots
+and a reference to an output slot. If the function eventually returns, then
+the statement completes.
+
+A call statement statically requires that the precondition declared in the
+callee's signature is satisfied by the statement prestate. In this way,
+typestates propagate through function boundaries. @xref{Ref.Stmt.Stat}.
+
+An example of a call statement:
+@example
+let int x = add(1, 2);
+@end example
+
+@page
+@node Ref.Stmt.Bind
+@subsection Ref.Stmt.Bind
+@c * Ref.Stmt.Bind:: Statement for binding arguments to functions.
+
+A @dfn{bind statement} constructs a new function from an existing
+function.@footnote{The @code{bind} statement is analogous to the @code{bind}
+expression in the Sather language.} The new function has zero or more of its
+arguments @emph{bound} into a new, hidden exterior tuple that holds the
+bindings. For each concrete argument passed in the @code{bind} statement, the
+corresponding parameter in the existing function is @emph{omitted} as a
+parameter of the new function. For each argument passed the placeholder symbol
+@code{_} in the @code{bind} statement, the corresponding parameter of the
+existing function is @emph{retained} as a parameter of the new function.
+
+Any subsequent invocation of the new function with residual arguments causes
+invocation of the existing function with the combination of bound arguments
+and residual arguments that was specified during the binding.
+
+An example of a @code{bind} statement:
+@example
+fn add(int x, int y) -> int @{
+ ret x + y;
+@}
+type single_param_fn = fn(int) -> int;
+
+let single_param_fn add4 = bind add(4, _);
+
+let single_param_fn add5 = bind add(_, 5);
+
+check (add(4,5) == add4(5));
+check (add(4,5) == add5(4));
+
+@end example
+
+A @code{bind} statement generally stores a copy of the bound arguments in the
+hidden exterior tuple. For bound interior slots and alias slots in the bound
+function signature, an interior slot is allocated in the hidden tuple and
+populated with a copy of the bound value. For bound exterior slots in the
+bound function signature, an exterior slot is allocated in the hidden tuple
+and populated with a copy of the bound value, an exterior (pointer) value.
+
+The @code{bind} statement is a lightweight mechanism for simulating the more
+elaborate construct of @emph{lexical closures} that exist in other
+languages. Rust has no support for lexical closures, but many realistic uses
+of them can be achieved with @code{bind} statements.
+
+
+@page
+@node Ref.Stmt.Ret
+@subsection Ref.Stmt.Ret
+@c * Ref.Stmt.Ret:: Statement for stopping and producing a value.
+
+Executing a @code{ret} statement@footnote{A @code{ret} statement is
+analogous to a @code{return} statement in the C family.} copies a
+value into the return slot of the current function, destroys the
+current function activation frame, and transfers control to the caller
+frame.
+
+An example of a @code{ret} statement:
+@example
+fn max(int a, int b) -> int @{
+ if (a > b) @{
+ ret a;
+ @}
+ ret b;
+@}
+@end example
+
+@page
+@node Ref.Stmt.Be
+@subsection Ref.Stmt.Be
+@c * Ref.Stmt.Be:: Statement for stopping and executing a tail call.
+
+Executing a @code{be} statement @footnote{A @code{be} statement in is
+analogous to a @code{become} statement in Newsqueak or Alef.} destroys the
+current function activation frame and replaces it with an activation frame for
+the called function. In other words, @code{be} executes a tail-call. The
+syntactic form of a @code{be} statement is therefore limited to @emph{tail
+position}: its argument must be a @emph{call expression}, and it must be the
+last statement in a block.
+
+An example of a @code{be} statement:
+@example
+fn print_loop(int n) @{
+ if (n <= 0) @{
+ ret;
+ @} else @{
+ print_int(n);
+ be print_loop(n-1);
+ @}
+@}
+@end example
+
+The above example executes in constant space, replacing each frame with a new
+copy of itself.
+
+
+
+@page
+@node Ref.Stmt.Put
+@subsection Ref.Stmt.Put
+@c * Ref.Stmt.Put:: Statement for pausing and producing a value.
+
+Executing a @code{put} statement copies a value into the put slot of the
+current iterator, suspends execution of the current iterator, and transfers
+control to the current put-recipient frame.
+
+A @code{put} statement is only valid within an iterator. @footnote{A
+@code{put} statement is analogous to a @code{yield} statement in the CLU,
+Sather and Objective C 2.0 languages, or in more recent languages providing a
+``generator'' facility, such as Python, Javascript or C#. Like the generators
+of CLU, Sather and Objective C 2.0, but @emph{unlike} these later languages,
+Rust's iterators reside on the stack and obey a strict stack discipline.} The
+current put-recipient will eventually resume the suspended iterator containing
+the @code{put} statement, either continuing execution after the @code{put}
+statement, or terminating its execution and destroying the iterator frame.
+
+
+@page
+@node Ref.Stmt.Fail
+@subsection Ref.Stmt.Fail
+@c * Ref.Stmt.Fail:: Statement for causing task failure.
+
+Executing a @code{fail} statement causes a task to enter the @emph{failing}
+state. In the @emph{failing} state, a task unwinds its stack, destroying all
+frames and freeing all resources until it reaches its entry frame, at which
+point it halts execution in the @emph{dead} state.
+
+@page
+@node Ref.Stmt.Log
+@subsection Ref.Stmt.Log
+@c * Ref.Stmt.Log:: Statement for logging values to diagnostic buffers.
+
+Executing a @code{log} statement may, depending on runtime configuration,
+cause a value to be appended to an internal diagnostic logging buffer provided
+by the runtime or emitted to a system console. Log statements are enabled or
+disabled dynamically at run-time on a per-task and per-item
+basis. @xref{Ref.Run.Log}.
+
+Executing a @code{log} statement not considered an @code{io} effect in the
+effect system. In other words, a pure function remains pure even if it
+contains a log statement.
+
+@example
+@end example
+
+@page
+@node Ref.Stmt.Note
+@subsection Ref.Stmt.Note
+@c * Ref.Stmt.Note:: Statement for logging values during failure.
+
+A @code{note} statement has no effect during normal execution. The purpose of
+a @code{note} statement is to provide additional diagnostic information to the
+logging subsystem during task failure. @xref{Ref.Stmt.Log}. Using @code{note}
+statements, normal diagnostic logging can be kept relatively sparse, while
+still providing verbose diagnostic ``back-traces'' when a task fails.
+
+When a task is failing, control frames @emph{unwind} from the innermost frame
+to the outermost, and from the innermost lexical block within an unwinding
+frame to the outermost. When unwinding a lexical block, the runtime processes
+all the @code{note} statements in the block sequentially, from the first
+statement of the block to the last. During processing, a @code{note}
+statement has equivalent meaning to a @code{log} statement: it causes the
+runtime to append the argument of the @code{note} to the internal logging
+diagnostic buffer.
+
+An example of a @code{note} statement:
+@example
+fn read_file_lines(&str path) -> vec[str] @{
+ note path;
+ vec[str] r;
+ file f = open_read(path);
+ for* (str &s = lines(f)) @{
+ vec.append(r,s);
+ @}
+ ret r;
+@}
+@end example
+
+In this example, if the task fails while attempting to open or read a file,
+the runtime will log the path name that was being read. If the function
+completes normally, the runtime will not log the path.
+
+A slot that is marked by a @code{note} statement does @emph{not} have its
+value copied aside when control passes through the @code{note}. In other
+words, if a @code{note} statement notes a particular slot, and code after the
+@code{note} that slot, and then a subsequent failure occurs, the
+@emph{mutated} value will be logged during unwinding, @emph{not} the original
+value that was held in the slot at the moment control passed through the
+@code{note} statement.
+
+@page
+@node Ref.Stmt.While
+@subsection Ref.Stmt.While
+@c * Ref.Stmt.While:: Statement for simple conditional looping.
+
+A @code{while} statement is a loop construct. A @code{while} loop may be
+either a simple @code{while} or a @code{do}-@code{while} loop.
+
+In the case of a simple @code{while}, the loop begins by evaluating the
+boolean loop conditional expression. If the loop conditional expression
+evaluates to @code{true}, the loop body block executes and control returns to
+the loop conditional expression. If the loop conditional expression evaluates
+to @code{false}, the @code{while} statement completes.
+
+In the case of a @code{do}-@code{while}, the loop begins with an execution of
+the loop body. After the loop body executes, it evaluates the loop conditional
+expression. If it evaluates to @code{true}, control returns to the beginning
+of the loop body. If it evaluates to @code{false}, control exits the loop.
+
+An example of a simple @code{while} statement:
+@example
+while (i < 10) @{
+ print("hello\n");
+ i = i + 1;
+@}
+@end example
+
+An example of a @code{do}-@code{while} statement:
+@example
+do @{
+ print("hello\n");
+ i = i + 1;
+@} while (i < 10);
+@end example
+
+@page
+@node Ref.Stmt.Break
+@subsection Ref.Stmt.Break
+@c * Ref.Stmt.Break:: Statement for terminating a loop.
+
+Executing a @code{break} statement immediately terminates the innermost loop
+enclosing it. It is only permitted in the body of a loop.
+
+@page
+@node Ref.Stmt.Cont
+@subsection Ref.Stmt.Cont
+@c * Ref.Stmt.Cont:: Statement for terminating a single loop iteration.
+
+Executing a @code{cont} statement immediately terminates the current iteration
+of the innermost loop enclosing it, returning control to the loop
+@emph{head}. In the case of a @code{while} loop, the head is the conditional
+expression controlling the loop. In the case of a @code{for} or @code{for
+each} loop, the head is the iterator or vector-slice increment controlling the
+loop.
+
+A @code{cont} statement is only permitted in the body of a loop.
+
+
+@page
+@node Ref.Stmt.For
+@subsection Ref.Stmt.For
+@c * Ref.Stmt.For:: Statement for looping over strings and vectors.
+
+A @dfn{for loop} is controlled by a vector or string. The for loop
+bounds-checks the underlying sequence @emph{once} when initiating the loop,
+then repeatedly copies each value of the underlying sequence into the element
+variable, executing the loop body once per copy. To perform a for loop on a
+sub-range of a vector or string, form a temporary slice over the sub-range and
+run the loop over the slice.
+
+Example of a 4 for loops, all identical:
+@example
+let vec[foo] v = vec(a, b, c);
+
+for (&foo e in v.(0, _vec.len(v))) @{
+ bar(e);
+@}
+
+for (&foo e in v.(0,)) @{
+ bar(e);
+@}
+
+for (&foo e in v.(,)) @{
+ bar(e);
+@}
+
+for (&foo e in v) @{
+ bar(e);
+@}
+@end example
+
+@page
+@node Ref.Stmt.Foreach
+@subsection Ref.Stmt.Foreach
+@c * Ref.Stmt.Foreach:: Statement for general conditional looping.
+
+An @dfn{foreach loop} is denoted by the @code{for each} keywords, and is
+controlled by an iterator. The loop executes once for each value @code{put} by
+the iterator. When the iterator returns or fails, the loop terminates.
+
+Example of a foreach loop:
+@example
+let str txt;
+let vec[str] lines;
+for each (&str s = _str.split(txt, "\n")) @{
+ vec.push(lines, s);
+@}
+@end example
+
+
+@page
+@node Ref.Stmt.If
+@subsection Ref.Stmt.If
+@c * Ref.Stmt.If:: Statement for simple conditional branching.
+
+An @code{if} statement is a conditional branch in program control. The form of
+an @code{if} statement is a parenthesized condition expression, followed by a
+consequent block, and an optional trailing @code{else} block. The condition
+expression must have type @code{bool}. If the condition expression evaluates
+to @code{true}, the consequent block is executed and any @code{else} block is
+skipped. If the condition expression evaluates to @code{false}, the consequent
+block is skipped and any @code{else} block is executed.
+
+@page
+@node Ref.Stmt.Alt
+@subsection Ref.Stmt.Alt
+@c * Ref.Stmt.Alt:: Statement for complex conditional branching.
+
+An @code{alt} statement is a multi-directional branch in program control.
+There are three kinds of @code{alt} statement: communication @code{alt}
+statements, pattern @code{alt} statements, and @code{alt type} statements.
+
+The form of each kind of @code{alt} is similar: an initial @emph{head} that
+describes the criteria for branching, followed by a sequence of zero or more
+@emph{arms}, each of which describes a @emph{case} and provides a @emph{block}
+of statements associated with the case. When an @code{alt} is executed,
+control enters the head, determines which of the cases to branch to, branches
+to the block associated with the chosen case, and then proceeds to the
+statement following the @code{alt} when the case block completes.
+
+@menu
+* Ref.Stmt.Alt.Comm:: Statement for branching on communication events.
+* Ref.Stmt.Alt.Pat:: Statement for branching on pattern matches.
+* Ref.Stmt.Alt.Type:: Statement for branching on types.
+@end menu
+
+@page
+@node Ref.Stmt.Alt.Comm
+@subsubsection Ref.Stmt.Alt.Comm
+@c * Ref.Stmt.Alt.Comm:: Statement for branching on communication events.
+
+The simplest form of @code{alt} statement is the a @emph{communication}
+@code{alt}. The cases of a communication @code{alt}'s arms are send, receive
+and flush statements. @xref{Ref.Task.Comm}.
+
+To execute a communication @code{alt}, the runtime checks all of the ports and
+channels involved in the arms of the statement to see if any @code{case} can
+execute without blocking. If no @code{case} can execute, the task blocks, and
+the runtime unblocks the task when a @code{case} @emph{can} execute. The
+runtime then makes a pseudo-random choice from among the set of @code{case}
+statements that can execute, executes the statement of the @code{case} and
+branches to the block of that arm.
+
+An example of a communication @code{alt} statement:
+@example
+let chan c[int] = foo();
+let port p[str] = bar();
+let int x = 0;
+let vec[str] strs;
+
+alt @{
+ case (str s <- p) @{
+ vec.append(strs, s);
+ @}
+ case (c <| x) @{
+ x++;
+ @}
+@}
+@end example
+
+@page
+@node Ref.Stmt.Alt.Pat
+@subsubsection Ref.Stmt.Alt.Pat
+@c * Ref.Stmt.Alt.Pat:: Statement for branching on pattern matches.
+
+A pattern @code{alt} statement branches on a @emph{pattern}. The exact form of
+matching that occurs depends on the pattern. Patterns consist of some
+combination of literals, tag constructors, variable binding specifications and
+placeholders (@code{_}). A pattern @code{alt} has a parenthesized @emph{head
+expression}, which is the value to compare to the patterns. The type of the
+patterns must equal the type of the head expression.
+
+To execute a pattern @code{alt} statement, first the head expression is
+evaluated, then its value is sequentially compared to the patterns in the arms
+until a match is found. The first arm with a matching @code{case} pattern is
+chosen as the branch target of the @code{alt}, any variables bound by the
+pattern are assigned to local @emph{auto} slots in the arm's block, and
+control enters the block.
+
+An example of a pattern @code{alt} statement:
+
+@example
+type list[X] = tag(nil, cons(X, @@list[X]));
+
+let list[int] x = cons(10, cons(11, nil));
+
+alt (x) @{
+ case (cons(a, cons(b, _))) @{
+ process_pair(a,b);
+ @}
+ case (cons(v=10, _)) @{
+ process_ten(v);
+ @}
+ case (_) @{
+ fail;
+ @}
+@}
+@end example
+
+
+@page
+@node Ref.Stmt.Alt.Type
+@subsubsection Ref.Stmt.Alt.Type
+@c * Ref.Stmt.Alt.Type:: Statement for branching on type.
+
+An @code{alt type} statement is similar to a pattern @code{alt}, but branches
+on the @emph{type} of its head expression, rather than the value. The head
+expression of an @code{alt type} statement must be of type @code{any}, and the
+arms of the statement are slot patterns rather than value patterns. Control
+branches to the arm with a @code{case} that matches the @emph{actual type} of
+the value in the @code{any}.
+
+An example of an @code{alt type} statement:
+
+@example
+let any x = foo();
+
+alt type (x) @{
+ case (int i) @{
+ ret i;
+ @}
+ case (list[int] li) @{
+ ret int_list_sum(li);
+ @}
+ case (list[X] lx) @{
+ ret list_len(lx);
+ @}
+ case (_) @{
+ ret 0;
+ @}
+@}
+@end example
+
+
+@page
+@node Ref.Stmt.Prove
+@subsection Ref.Stmt.Prove
+@c * Ref.Stmt.Prove:: Statement for static assertion of typestate.
+
+A @code{prove} statement has no run-time effect. Its purpose is to statically
+check (and document) that its argument constraint holds at its statement entry
+point. If its argument typestate does not hold, under the typestate algorithm,
+the program containing it will fail to compile.
+
+@page
+@node Ref.Stmt.Check
+@subsection Ref.Stmt.Check
+@c * Ref.Stmt.Check:: Statement for dynamic assertion of typestate.
+
+A @code{check} statement connects dynamic assertions made at run-time to the
+static typestate system. A @code{check} statement takes a constraint to check
+at run-time. If the constraint holds at run-time, control passes through the
+@code{check} and on to the next statement in the enclosing block. If the
+condition fails to hold at run-time, the @code{check} statement behaves as a
+@code{fail} statement.
+
+The typestate algorithm is built around @code{check} statements, and in
+particular the fact that control @emph{will not pass} a check statement with a
+condition that fails to hold. The typestate algorithm can therefore assume
+that the (static) postcondition of a @code{check} statement includes the
+checked constraint itself. From there, the typestate algorithm can perform
+dataflow calculations on subsequent statements, propagating conditions forward
+and statically comparing implied states and their
+specifications. @xref{Ref.Stmt.Stat}.
+
+@example
+fn even(&int x) -> bool @{
+ ret x & 1 == 0;
+@}
+
+fn print_even(int x) : even(x) @{
+ print(x);
+@}
+
+fn test() @{
+ let int y = 8;
+
+ // Cannot call print_even(y) here.
+
+ check even(y);
+
+ // Can call print_even(y) here, since even(y) now holds.
+ print_even(y);
+@}
+@end example
+
+@page
+@node Ref.Stmt.IfCheck
+@subsection Ref.Stmt.IfCheck
+@c * Ref.Stmt.IfCheck:: Statement for dynamic testing of typestate.
+
+An @code{if check} statement combines a @code{if} statement and a @code{check}
+statement in an indivisible unit that can be used to build more complex
+conditional control flow than the @code{check} statement affords.
+
+In fact, @code{if check} is a ``more primitive'' statement @code{check};
+instances of the latter can be rewritten as instances of the former. The
+following two examples are equivalent:
+
+@sp 1
+Example using @code{check}:
+@example
+check even(x);
+print_even(x);
+@end example
+
+@sp 1
+Equivalent example using @code{if check}:
+@example
+if check even(x) @{
+ print_even(x);
+@} else @{
+ fail;
+@}
+@end example
+
+@page
+@node Ref.Run
+@section Ref.Run
+@c * Ref.Run:: Organization of runtime services.
+
+The Rust @dfn{runtime} is a relatively compact collection of C and Rust code
+that provides fundamental services and datatypes to all Rust tasks at
+run-time. It is smaller and simpler than many modern language runtimes. It is
+tightly integrated into the language's execution model of slots, tasks,
+communication, reflection, logging and signal handling.
+
+@menu
+* Ref.Run.Mem:: Runtime memory management service.
+* Ref.Run.Type:: Runtime built-in type services.
+* Ref.Run.Comm:: Runtime communication service.
+* Ref.Run.Refl:: Runtime reflection system.
+* Ref.Run.Log:: Runtime logging system.
+* Ref.Run.Sig:: Runtime signal handler.
+@end menu
+
+@page
+@node Ref.Run.Mem
+@subsection Ref.Run.Mem
+@c * Ref.Run.Mem:: Runtime memory management service.
+
+The runtime memory-management system is based on a @emph{service-provider
+interface}, through which the runtime requests blocks of memory from its
+environment and releases them back to its environment when they are no longer
+in use. The default implementation of the service-provider interface consists
+of the C runtime functions @code{malloc} and @code{free}.
+
+The runtime memory-management system in turn supplies Rust tasks with
+facilities for allocating, extending and releasing stacks, as well as
+allocating and freeing exterior values.
+
+@page
+@node Ref.Run.Type
+@subsection Ref.Run.Type
+@c * Ref.Run.Mem:: Runtime built-in type services.
+
+The runtime provides C and Rust code to manage several built-in types:
+@itemize
+@item @code{vec}, the type of vectors.
+@item @code{str}, the type of UTF-8 strings.
+@item @code{big}, the type of arbitrary-precision integers.
+@item @code{chan}, the type of communication channels.
+@item @code{port}, the type of communication ports.
+@item @code{task}, the type of tasks.
+@end itemize
+Support for other built-in types such as simple types, tuples,
+records, and tags is open-coded by the Rust compiler.
+
+@page
+@node Ref.Run.Comm
+@subsection Ref.Run.Comm
+@c * Ref.Run.Comm:: Runtime communication service.
+
+The runtime provides code to manage inter-task communication. This includes
+the system of task-lifecycle state transitions depending on the contents of
+queues, as well as code to copy values between queues and their recipients and
+to serialize values for transmission over operating-system inter-process
+communication facilities.
+
+@page
+@node Ref.Run.Refl
+@subsection Ref.Run.Refl
+@c * Ref.Run.Refl:: Runtime reflection system.
+
+The runtime reflection system is driven by the DWARF tables emitted into a
+crate at compile-time. Reflecting on a slot or item allocates a Rust data
+structure corresponding to the DWARF DIE for that slot or item.
+
+@page
+@node Ref.Run.Log
+@subsection Ref.Run.Log
+@c * Ref.Run.Log:: Runtime logging system.
+
+The runtime contains a system for directing logging statements to a logging
+console and/or internal logging buffers. @xref{Ref.Stmt.Log}. Logging
+statements can be enabled or disabled via a two-dimensional filtering process:
+
+@itemize
+
+@sp 1
+@item
+By Item
+
+Each @emph{item} (module, function, iterator, object, type) in Rust has a
+static name-path within its crate module, and can have logging enabled or
+disabled on a name-path-prefix basis.
+
+@sp 1
+@item
+By Task
+
+Each @emph{task} in a running Rust program has a unique ownership-path through
+the task ownership tree, and can have logging enabled or disabled on an
+ownership-path-prefix basis.
+@end itemize
+
+Logging is integrated into the language for efficiency reasons, as well as the
+need to filter logs based on these two built-in dimensions.
+
+@page
+@node Ref.Run.Sig
+@subsection Ref.Run.Sig
+@c * Ref.Run.Sig:: Runtime signal handler.
+
+The runtime signal-handling system is driven by a signal-dispatch table and a
+signal queue associated with each task. Sending a signal to a task inserts the
+signal into the task's signal queue and marks the task as having a pending
+signal. At the next scheduling opportunity, the runtime processes signals in
+the task's queue using its dispatch table. The signal queue memory is charged
+to the task's domain; if the queue grows too big, the task will fail.
+
+@c ############################################################
+@c end main body of nodes
+@c ############################################################
+
+@page
+@node Index
+@chapter Index
+
+@printindex cp
+
+@bye
CFG_INFO := $(info cfg: building on $(CFG_OSTYPE) $(CFG_CPUTYPE))
-CFG_GCC_COMPILE_FLAGS :=
+CFG_GCC_CFLAGS :=
CFG_GCC_LINK_FLAGS :=
CFG_VALGRIND :=
CFG_LLVM_CONFIG := llvm-config
-CFG_BOOT_FLAGS :=
+CFG_BOOT_FLAGS := $(FLAGS)
ifeq ($(CFG_OSTYPE), Linux)
CFG_RUNTIME := librustrt.so
CFG_STDLIB := libstd.so
- CFG_GCC_COMPILE_FLAGS += -fPIC
+ CFG_GCC_CFLAGS += -fPIC
CFG_GCC_LINK_FLAGS += -shared -fPIC -ldl -lpthread
ifeq ($(CFG_CPUTYPE), x86_64)
- CFG_GCC_COMPILE_FLAGS += -m32
+ CFG_GCC_CFLAGS += -m32
CFG_GCC_LINK_FLAGS += -m32
endif
CFG_NATIVE := 1
CFG_UNIXY := 1
CFG_VALGRIND := $(shell which valgrind)
ifdef CFG_VALGRIND
- CFG_VALGRIND += --run-libc-freeres=no --leak-check=full --quiet --vex-iropt-level=0
+ CFG_VALGRIND += --leak-check=full \
+ --quiet --vex-iropt-level=0 \
+ --suppressions=etc/x86.supp
endif
endif
# "on an i386" when the whole userspace is 64-bit and the compiler
# emits 64-bit binaries by default. So we just force -m32 here. Smarter
# approaches welcome!
- CFG_GCC_COMPILE_FLAGS += -m32
+ CFG_GCC_CFLAGS += -m32
CFG_GCC_LINK_FLAGS += -m32
endif
CFG_EXE_SUFFIX := .exe
CFG_BOOT := ./rustboot.exe
CFG_COMPILER := ./rustc.exe
- CFG_GCC_COMPILE_FLAGS += -march=i686
+ CFG_GCC_CFLAGS += -march=i686
CFG_GCC_LINK_FLAGS += -shared -fPIC
CFG_RUN_TARG = $(1)
# FIXME: support msvc at some point
endif
CFG_OBJ_SUFFIX := .o
CFG_EXE_SUFFIX := .exe
- CFG_GCC_COMPILE_FLAGS :=
+ CFG_GCC_CFLAGS :=
CFG_GCC_LINK_FLAGS := -shared
ifeq ($(CFG_CPUTYPE), x86_64)
- CFG_GCC_COMPILE_FLAGS += -m32
+ CFG_GCC_CFLAGS += -m32
CFG_GCC_LINK_FLAGS += -m32
endif
endif
ifdef CFG_GCC
CFG_INFO := $(info cfg: using gcc)
- CFG_GCC_COMPILE_FLAGS += -Wall -Werror -fno-rtti -fno-exceptions -g
+ CFG_GCC_CFLAGS += -Wall -Werror -fno-rtti -fno-exceptions -g
CFG_GCC_LINK_FLAGS += -g
- CFG_COMPILE_C = $(CFG_GCC_CROSS)g++ $(CFG_GCC_COMPILE_FLAGS) -c -o $(1) $(2)
+ CFG_COMPILE_C = $(CFG_GCC_CROSS)g++ $(CFG_GCC_CFLAGS) -c -o $(1) $(2)
CFG_LINK_C = $(CFG_GCC_CROSS)g++ $(CFG_GCC_LINK_FLAGS) -o $(1)
- CFG_DEPEND_C = $(CFG_GCC_CROSS)g++ $(CFG_GCC_COMPILE_FLAGS) -MT "$(1)" -MM $(2)
+ CFG_DEPEND_C = $(CFG_GCC_CROSS)g++ $(CFG_GCC_CFLAGS) -MT "$(1)" -MM $(2)
else
CFG_ERR := $(error please try on a system with gcc)
endif
$(info cfg: using LLVM version 2.8svn)
else
CFG_LLVM_CONFIG :=
- $(info cfg: incompatible LLVM version $(CFG_LLVM_VERSION), expected 2.8svn)
+ $(info cfg: incompatible LLVM version $(CFG_LLVM_VERSION), \
+ expected 2.8svn)
endif
endif
ifdef CFG_LLVM_CONFIG
WHERE := $(shell ocamlc -where)
LLVM_LIBS := llvm.cma llvm_bitwriter.cma
LLVM_NATIVE_LIBS := llvm.cmxa llvm_bitwiter.cmxa
- LLVM_CLIBS := $(shell for c in `$(CFG_LLVM_CONFIG) --ldflags --libs` -lllvm -lllvm_bitwriter; do echo -cclib && echo $$c; done | xargs echo)
+ LLVM_CLIBS := $(shell for c in `$(CFG_LLVM_CONFIG) --ldflags --libs` \
+ -lllvm -lllvm_bitwriter; do echo -cclib && echo $$c; done | xargs echo)
LLVM_INCS := -I boot/llvm -I $(WHERE)
- LLVM_MLS := $(addprefix boot/llvm/, llabi.ml llasm.ml llfinal.ml lltrans.ml \
- llemit.ml)
- CFG_LLC_COMPILE_FLAGS := -march=x86
+ LLVM_MLS := $(addprefix boot/llvm/, llabi.ml llasm.ml llfinal.ml \
+ lltrans.ml llemit.ml)
+ CFG_LLC_CFLAGS := -march=x86
$(info cfg: found llvm-config at $(CFG_LLVM_CONFIG))
else
VARIANT=x86
ML_LIBS := unix.cma nums.cma bigarray.cma
ML_NATIVE_LIBS := unix.cmxa nums.cmxa bigarray.cmxa
OCAMLC_FLAGS := -g $(ML_INCS) -w Ael -warn-error Ael
-OCAMLOPT_FLAGS := $(ML_INCS) -w Ael -warn-error Ael $(CFG_OCAMLOPT_PROFILE_FLAGS)
+OCAMLOPT_FLAGS := $(ML_INCS) -w Ael -warn-error Ael \
+ $(CFG_OCAMLOPT_PROFILE_FLAGS)
ifdef CFG_LLVM_CONFIG
ML_LIBS += $(LLVM_LIBS) -custom -cclib -lstdc++ $(LLVM_CLIBS)
BE_MLS := $(addprefix boot/be/, x86.ml ra.ml pe.ml elf.ml \
macho.ml)
IL_MLS := $(addprefix boot/be/, asm.ml il.ml abi.ml)
-ME_MLS := $(addprefix boot/me/, walk.ml semant.ml resolve.ml alias.ml type.ml dead.ml \
- typestate.ml mode.ml mutable.ml gctype.ml loop.ml layout.ml transutil.ml \
- trans.ml dwarf.ml)
-FE_MLS := $(addprefix boot/fe/, ast.ml token.ml lexer.ml parser.ml pexp.ml item.ml cexp.ml)
-DRIVER_TOP_MLS := $(addprefix boot/driver/, $(VARIANT)/glue.ml lib.ml main.ml)
+ME_MLS := $(addprefix boot/me/, walk.ml semant.ml resolve.ml alias.ml \
+ type.ml dead.ml effect.ml typestate.ml loop.ml layout.ml \
+ transutil.ml trans.ml dwarf.ml)
+FE_MLS := $(addprefix boot/fe/, ast.ml token.ml lexer.ml parser.ml pexp.ml \
+ item.ml cexp.ml)
+DRIVER_TOP_MLS := $(addprefix boot/driver/, lib.ml $(VARIANT)/glue.ml main.ml)
BOOT_MLS := $(UTIL_BOT_MLS) $(DRIVER_BOT_MLS) $(FE_MLS) $(IL_MLS) $(ME_MLS) \
$(BE_MLS) $(LLVM_MLS) $(DRIVER_TOP_MLS)
rt/rust_comm.cpp \
rt/rust_dom.cpp \
rt/rust_task.cpp \
+ rt/rust_chan.cpp \
rt/rust_upcall.cpp \
+ rt/rust_log.cpp \
+ rt/rust_timer.cpp \
rt/isaac/randport.cpp
+
RUNTIME_HDR := rt/rust.h \
rt/rust_dwarf.h \
rt/rust_internal.h \
$(CFG_STDLIB): $(STDLIB_CRATE) $(CFG_BOOT) $(MKFILES)
@$(call CFG_ECHO, compile: $<)
- $(CFG_QUIET)OCAMLRUNPARAM="b1" $(CFG_BOOT) $(CFG_BOOT_FLAGS) -shared -o $@ $(STDLIB_CRATE)
+ $(CFG_QUIET)OCAMLRUNPARAM="b1" $(CFG_BOOT) $(CFG_BOOT_FLAGS) \
+ -shared -o $@ $(STDLIB_CRATE)
%$(CFG_OBJ_SUFFIX): %.cpp $(MKFILES)
@$(call CFG_ECHO, compile: $<)
ifdef CFG_NATIVE
$(CFG_BOOT): $(BOOT_CMXS) $(MKFILES)
@$(call CFG_ECHO, compile: $<)
- $(CFG_QUIET)ocamlopt$(OPT) -o $@ $(OCAMLOPT_FLAGS) $(ML_NATIVE_LIBS) $(BOOT_CMXS)
+ $(CFG_QUIET)ocamlopt$(OPT) -o $@ $(OCAMLOPT_FLAGS) $(ML_NATIVE_LIBS) \
+ $(BOOT_CMXS)
else
$(CFG_BOOT): $(BOOT_CMOS) $(MKFILES)
@$(call CFG_ECHO, compile: $<)
# Main compiler targets and rules
######################################################################
-$(CFG_COMPILER): $(COMPILER_CRATE) $(CFG_BOOT) $(CFG_RUNTIME) $(CFG_STDLIB)
+$(CFG_COMPILER): $(COMPILER_INPUTS) $(CFG_BOOT) $(CFG_RUNTIME) $(CFG_STDLIB)
@$(call CFG_ECHO, compile: $<)
$(CFG_QUIET)OCAMLRUNPARAM="b1" $(CFG_BOOT) $(CFG_BOOT_FLAGS) -o $@ $<
$(CFG_QUIET)chmod 0755 $@
# Testing
######################################################################
-TEST_XFAILS_X86 := test/run-pass/mlist_cycle.rs \
+TEST_XFAILS_X86 := test/run-pass/mlist-cycle.rs \
test/run-pass/clone-with-exterior.rs \
+ test/run-pass/obj-as.rs \
test/run-pass/rec-auto.rs \
test/run-pass/vec-slice.rs \
test/run-pass/generic-fn-infer.rs \
+ test/run-pass/generic-recursive-tag.rs \
test/run-pass/generic-tag.rs \
+ test/run-pass/generic-tag-alt.rs \
test/run-pass/bind-obj-ctor.rs \
+ test/run-pass/task-comm.rs \
test/compile-fail/rec-missing-fields.rs \
test/compile-fail/infinite-tag-type-recursion.rs \
test/compile-fail/infinite-vec-type-recursion.rs
TEST_XFAILS_LLVM := $(addprefix test/run-pass/, \
acyclic-unwind.rs \
alt-tag.rs \
+ argv.rs \
basic.rs \
bind-obj-ctor.rs \
bind-thunk.rs \
bind-trivial.rs \
+ bitwise.rs \
+ box-unbox.rs \
cast.rs \
char.rs \
clone-with-exterior.rs \
comm.rs \
+ command-line-args.rs \
complex.rs \
dead-code-one-arm-if.rs \
deep.rs \
div-mod.rs \
drop-on-ret.rs \
+ else-if.rs \
+ export-non-interference.rs \
exterior.rs \
- foreach-simple.rs \
- foreach-simple-outer-slot.rs \
foreach-put-structured.rs \
- vec-slice.rs \
- simple-obj.rs \
- import.rs \
+ foreach-simple-outer-slot.rs \
+ foreach-simple.rs \
fun-call-variants.rs \
fun-indirect-call.rs \
generic-derived-type.rs \
generic-drop-glue.rs \
+ generic-exterior-box.rs \
+ generic-fn-infer.rs \
generic-fn.rs \
- generic-obj.rs \
generic-obj-with-derived-type.rs \
+ generic-obj.rs \
+ generic-recursive-tag.rs \
+ generic-tag-alt.rs \
generic-tag.rs \
+ generic-type-synonym.rs \
generic-type.rs \
- generic-fn-infer.rs \
- vec-append.rs \
- vec-concat.rs \
- vec-drop.rs \
- mutable-vec-drop.rs \
+ i32-sub.rs \
+ i8-incr.rs \
+ import.rs \
inner-module.rs \
large-records.rs \
+ lazy-and-or.rs \
lazychan.rs \
linear-for-loop.rs \
+ list.rs \
many.rs \
+ mlist-cycle.rs \
mlist.rs \
- mlist_cycle.rs \
+ mutable-vec-drop.rs \
mutual-recursion-group.rs \
+ native-mod.rc \
+ native-opaque-type.rs \
native.rc \
- command-line-args.rs \
- native_mod.rc \
+ obj-as.rs \
+ obj-drop.rs \
+ obj-dtor.rs \
+ obj-with-vec.rs \
opeq.rs \
+ preempt.rs \
pred.rs \
readalias.rs \
rec-auto.rs \
rec-extend.rs \
+ rec-tup.rs \
rec.rs \
- rec_tup.rs \
return-nil.rs \
- i32-sub.rs \
- i8-incr.rs \
+ simple-obj.rs \
spawn-fn.rs \
spawn.rs \
stateful-obj.rs \
tail-direct.rs \
threads.rs \
tup.rs \
+ type-sizes.rs \
u32-decr.rs \
u8-incr-decr.rs \
u8-incr.rs \
unit.rs \
user.rs \
+ utf8.rs \
+ vec-append.rs \
+ vec-concat.rs \
+ vec-drop.rs \
+ vec-slice.rs \
vec.rs \
writealias.rs \
yield.rs \
yield2.rs \
- native-opaque-type.rs \
- type-sizes.rs \
- obj-drop.rs \
- obj-dtor.rs \
- obj-with-vec.rs \
- else-if.rs \
- lazy-and-or.rs \
+ task-comm.rs \
) \
$(addprefix test/run-fail/, \
explicit-fail.rs \
fail.rs \
linked-failure.rs \
pred.rs \
- vec_overrun.rs \
- str_overrun.rs \
- vec_underrun.rs \
+ vec-overrun.rs \
+ str-overrun.rs \
+ vec-underrun.rs \
) \
$(addprefix test/compile-fail/, \
rec-missing-fields.rs \
)
ifdef CFG_WINDOWSY
-TEST_XFAILS_X86 += test/run-pass/native_mod.rc
-TEST_XFAILS_LLVM += test/run-pass/native_mod.rc
+TEST_XFAILS_X86 += test/run-pass/native-mod.rc
+TEST_XFAILS_LLVM += test/run-pass/native-mod.rc
+else
+TEST_XFAILS_X86 += test/run-pass/preempt.rs
+TEST_XFAILS_LLVM += test/run-pass/preempt.rs
endif
-TEST_RUN_PASS_CRATES_X86 := $(filter-out $(TEST_XFAILS_X86), $(wildcard test/run-pass/*.rc))
-TEST_RUN_PASS_CRATES_LLVM := $(filter-out $(TEST_XFAILS_LLVM), $(wildcard test/run-pass/*.rc))
-TEST_RUN_PASS_SOURCES_X86 := $(filter-out $(TEST_XFAILS_X86), $(wildcard test/run-pass/*.rs))
-TEST_RUN_PASS_SOURCES_LLVM := $(filter-out $(TEST_XFAILS_LLVM), $(wildcard test/run-pass/*.rs))
-TEST_RUN_PASS_EXTRAS := $(wildcard test/run-pass/*/*.rs)
-TEST_RUN_PASS_EXES_X86 := \
- $(TEST_RUN_PASS_CRATES_X86:.rc=.x86$(CFG_EXE_SUFFIX)) \
- $(TEST_RUN_PASS_SOURCES_X86:.rs=.x86$(CFG_EXE_SUFFIX))
-TEST_RUN_PASS_EXES_LLVM := \
- $(TEST_RUN_PASS_CRATES_LLVM:.rc=.llvm$(CFG_EXE_SUFFIX)) \
- $(TEST_RUN_PASS_SOURCES_LLVM:.rs=.llvm$(CFG_EXE_SUFFIX))
-TEST_RUN_PASS_OUTS_X86 := \
- $(TEST_RUN_PASS_EXES_X86:.x86$(CFG_EXE_SUFFIX)=.x86.out)
-TEST_RUN_PASS_OUTS_LLVM := \
- $(TEST_RUN_PASS_EXES_LLVM:.llvm$(CFG_EXE_SUFFIX)=.llvm.out)
-
-
-TEST_RUN_FAIL_CRATES_X86 := $(filter-out $(TEST_XFAILS_X86), $(wildcard test/run-fail/*.rc))
-TEST_RUN_FAIL_CRATES_LLVM := $(filter-out $(TEST_XFAILS_LLVM), $(wildcard test/run-fail/*.rc))
-TEST_RUN_FAIL_SOURCES_X86 := $(filter-out $(TEST_XFAILS_X86), $(wildcard test/run-fail/*.rs))
-TEST_RUN_FAIL_SOURCES_LLVM := $(filter-out $(TEST_XFAILS_LLVM), $(wildcard test/run-fail/*.rs))
-TEST_RUN_FAIL_EXTRAS := $(wildcard test/run-fail/*/*.rs)
-TEST_RUN_FAIL_EXES_X86 := \
- $(TEST_RUN_FAIL_CRATES_X86:.rc=.x86$(CFG_EXE_SUFFIX)) \
- $(TEST_RUN_FAIL_SOURCES_X86:.rs=.x86$(CFG_EXE_SUFFIX))
-TEST_RUN_FAIL_EXES_LLVM := \
- $(TEST_RUN_FAIL_CRATES_LLVM:.rc=.llvm$(CFG_EXE_SUFFIX)) \
- $(TEST_RUN_FAIL_SOURCES_LLVM:.rs=.llvm$(CFG_EXE_SUFFIX))
-TEST_RUN_FAIL_OUTS_X86 := \
- $(TEST_RUN_FAIL_EXES_X86:.x86$(CFG_EXE_SUFFIX)=.x86.out)
-TEST_RUN_FAIL_OUTS_LLVM := \
- $(TEST_RUN_FAIL_EXES_LLVM:.llvm$(CFG_EXE_SUFFIX)=.llvm.out)
-
-
-TEST_COMPILE_FAIL_CRATES_X86 := $(filter-out $(TEST_XFAILS_X86), $(wildcard test/compile-fail/*.rc))
-TEST_COMPILE_FAIL_CRATES_LLVM := $(filter-out $(TEST_XFAILS_LLVM), $(wildcard test/compile-fail/*.rc))
-TEST_COMPILE_FAIL_SOURCES_X86 := $(filter-out $(TEST_XFAILS_X86), $(wildcard test/compile-fail/*.rs))
-TEST_COMPILE_FAIL_SOURCES_LLVM := $(filter-out $(TEST_XFAILS_LLVM), $(wildcard test/compile-fail/*.rs))
-TEST_COMPILE_FAIL_EXTRAS := $(wildcard test/compile-fail/*/*.rs)
-TEST_COMPILE_FAIL_EXES_X86 := \
- $(TEST_COMPILE_FAIL_CRATES_X86:.rc=.x86$(CFG_EXE_SUFFIX)) \
- $(TEST_COMPILE_FAIL_SOURCES_X86:.rs=.x86$(CFG_EXE_SUFFIX))
-TEST_COMPILE_FAIL_EXES_LLVM := \
- $(TEST_COMPILE_FAIL_CRATES_LLVM:.rc=.llvm$(CFG_EXE_SUFFIX)) \
- $(TEST_COMPILE_FAIL_SOURCES_LLVM:.rs=.llvm$(CFG_EXE_SUFFIX))
-TEST_COMPILE_FAIL_OUTS_X86 := \
- $(TEST_COMPILE_FAIL_EXES_X86:.x86$(CFG_EXE_SUFFIX)=.x86.out)
-TEST_COMPILE_FAIL_OUTS_LLVM := \
- $(TEST_COMPILE_FAIL_EXES_LLVM:.llvm$(CFG_EXE_SUFFIX)=.llvm.out)
-
-ALL_TEST_CRATES := $(TEST_COMPILE_FAIL_CRATES_X86) \
- $(TEST_RUN_FAIL_CRATES_X86) \
- $(TEST_RUN_PASS_CRATES_X86)
-
-ALL_TEST_SOURCES := $(TEST_COMPILE_FAIL_SOURCES_X86) \
- $(TEST_RUN_FAIL_SOURCES_X86) \
- $(TEST_RUN_PASS_SOURCES_X86)
+RPASS_RC := $(wildcard test/run-pass/*.rc)
+RPASS_RS := $(wildcard test/run-pass/*.rs)
+RFAIL_RC := $(wildcard test/run-fail/*.rc)
+RFAIL_RS := $(wildcard test/run-fail/*.rs)
+CFAIL_RC := $(wildcard test/compile-fail/*.rc)
+CFAIL_RS := $(wildcard test/compile-fail/*.rs)
+
+TEST_RPASS_CRATES_X86 := $(filter-out $(TEST_XFAILS_X86), $(RPASS_RC))
+TEST_RPASS_CRATES_LLVM := $(filter-out $(TEST_XFAILS_LLVM), $(RPASS_RC))
+TEST_RPASS_SOURCES_X86 := $(filter-out $(TEST_XFAILS_X86), $(RPASS_RS))
+TEST_RPASS_SOURCES_LLVM := $(filter-out $(TEST_XFAILS_LLVM), $(RPASS_RS))
+TEST_RPASS_EXTRAS := $(wildcard test/run-pass/*/*.rs)
+TEST_RPASS_EXES_X86 := \
+ $(TEST_RPASS_CRATES_X86:.rc=.x86$(CFG_EXE_SUFFIX)) \
+ $(TEST_RPASS_SOURCES_X86:.rs=.x86$(CFG_EXE_SUFFIX))
+TEST_RPASS_EXES_LLVM := \
+ $(TEST_RPASS_CRATES_LLVM:.rc=.llvm$(CFG_EXE_SUFFIX)) \
+ $(TEST_RPASS_SOURCES_LLVM:.rs=.llvm$(CFG_EXE_SUFFIX))
+TEST_RPASS_OUTS_X86 := \
+ $(TEST_RPASS_EXES_X86:.x86$(CFG_EXE_SUFFIX)=.x86.out)
+TEST_RPASS_OUTS_LLVM := \
+ $(TEST_RPASS_EXES_LLVM:.llvm$(CFG_EXE_SUFFIX)=.llvm.out)
+
+
+TEST_RFAIL_CRATES_X86 := $(filter-out $(TEST_XFAILS_X86), $(RFAIL_RC))
+TEST_RFAIL_CRATES_LLVM := $(filter-out $(TEST_XFAILS_LLVM), $(RFAIL_RC))
+TEST_RFAIL_SOURCES_X86 := $(filter-out $(TEST_XFAILS_X86), $(RFAIL_RS))
+TEST_RFAIL_SOURCES_LLVM := $(filter-out $(TEST_XFAILS_LLVM), $(RFAIL_RS))
+TEST_RFAIL_EXTRAS := $(wildcard test/run-fail/*/*.rs)
+TEST_RFAIL_EXES_X86 := \
+ $(TEST_RFAIL_CRATES_X86:.rc=.x86$(CFG_EXE_SUFFIX)) \
+ $(TEST_RFAIL_SOURCES_X86:.rs=.x86$(CFG_EXE_SUFFIX))
+TEST_RFAIL_EXES_LLVM := \
+ $(TEST_RFAIL_CRATES_LLVM:.rc=.llvm$(CFG_EXE_SUFFIX)) \
+ $(TEST_RFAIL_SOURCES_LLVM:.rs=.llvm$(CFG_EXE_SUFFIX))
+TEST_RFAIL_OUTS_X86 := \
+ $(TEST_RFAIL_EXES_X86:.x86$(CFG_EXE_SUFFIX)=.x86.out)
+TEST_RFAIL_OUTS_LLVM := \
+ $(TEST_RFAIL_EXES_LLVM:.llvm$(CFG_EXE_SUFFIX)=.llvm.out)
+
+
+TEST_CFAIL_CRATES_X86 := $(filter-out $(TEST_XFAILS_X86), $(CFAIL_RC))
+TEST_CFAIL_CRATES_LLVM := $(filter-out $(TEST_XFAILS_LLVM), $(CFAIL_RC))
+TEST_CFAIL_SOURCES_X86 := $(filter-out $(TEST_XFAILS_X86), $(CFAIL_RS))
+TEST_CFAIL_SOURCES_LLVM := $(filter-out $(TEST_XFAILS_LLVM), $(CFAIL_RS))
+TEST_CFAIL_EXTRAS := $(wildcard test/compile-fail/*/*.rs)
+TEST_CFAIL_EXES_X86 := \
+ $(TEST_CFAIL_CRATES_X86:.rc=.x86$(CFG_EXE_SUFFIX)) \
+ $(TEST_CFAIL_SOURCES_X86:.rs=.x86$(CFG_EXE_SUFFIX))
+TEST_CFAIL_EXES_LLVM := \
+ $(TEST_CFAIL_CRATES_LLVM:.rc=.llvm$(CFG_EXE_SUFFIX)) \
+ $(TEST_CFAIL_SOURCES_LLVM:.rs=.llvm$(CFG_EXE_SUFFIX))
+TEST_CFAIL_OUTS_X86 := \
+ $(TEST_CFAIL_EXES_X86:.x86$(CFG_EXE_SUFFIX)=.x86.out)
+TEST_CFAIL_OUTS_LLVM := \
+ $(TEST_CFAIL_EXES_LLVM:.llvm$(CFG_EXE_SUFFIX)=.llvm.out)
+
+ALL_TEST_CRATES := $(TEST_CFAIL_CRATES_X86) \
+ $(TEST_RFAIL_CRATES_X86) \
+ $(TEST_RPASS_CRATES_X86)
+
+ALL_TEST_SOURCES := $(TEST_CFAIL_SOURCES_X86) \
+ $(TEST_RFAIL_SOURCES_X86) \
+ $(TEST_RPASS_SOURCES_X86)
ALL_TEST_INPUTS := $(wildcard test/*/*.rs test/*/*/*.rs test/*/*.rc)
-check_nocompile: $(TEST_COMPILE_FAIL_OUTS_X86)
+check_nocompile: $(TEST_CFAIL_OUTS_X86)
+
+check: tidy \
+ $(TEST_RPASS_EXES_X86) $(TEST_RFAIL_EXES_X86) \
+ $(TEST_RPASS_OUTS_X86) $(TEST_RFAIL_OUTS_X86) \
+ $(TEST_CFAIL_OUTS_X86)
-check: $(TEST_RUN_PASS_EXES_X86) $(TEST_RUN_FAIL_EXES_X86) \
- $(TEST_RUN_PASS_OUTS_X86) $(TEST_RUN_FAIL_OUTS_X86) \
- $(TEST_COMPILE_FAIL_OUTS_X86)
ifeq ($(VARIANT),llvm)
-ALL_TEST_CRATES += $(TEST_COMPILE_FAIL_CRATES_LLVM) \
- $(TEST_RUN_FAIL_CRATES_LLVM) \
- $(TEST_RUN_PASS_CRATES_LLVM)
+ALL_TEST_CRATES += $(TEST_CFAIL_CRATES_LLVM) \
+ $(TEST_RFAIL_CRATES_LLVM) \
+ $(TEST_RPASS_CRATES_LLVM)
-ALL_TEST_SOURCES += $(TEST_COMPILE_FAIL_SOURCES_LLVM) \
- $(TEST_RUN_FAIL_SOURCES_LLVM) \
- $(TEST_RUN_PASS_SOURCES_LLVM)
+ALL_TEST_SOURCES += $(TEST_CFAIL_SOURCES_LLVM) \
+ $(TEST_RFAIL_SOURCES_LLVM) \
+ $(TEST_RPASS_SOURCES_LLVM)
-check_nocompile: $(TEST_COMPILE_FAIL_OUTS_LLVM)
+check_nocompile: $(TEST_CFAIL_OUTS_LLVM)
-check: $(TEST_RUN_PASS_EXES_LLVM) $(TEST_RUN_FAIL_EXES_LLVM) \
- $(TEST_RUN_PASS_OUTS_LLVM) $(TEST_RUN_FAIL_OUTS_LLVM) \
- $(TEST_COMPILE_FAIL_OUTS_LLVM)
+check: tidy \
+ $(TEST_RPASS_EXES_LLVM) $(TEST_RFAIL_EXES_LLVM) \
+ $(TEST_RPASS_OUTS_LLVM) $(TEST_RFAIL_OUTS_LLVM) \
+ $(TEST_CFAIL_OUTS_LLVM)
endif
+REQ := $(CFG_BOOT) $(CFG_RUNTIME) $(CFG_STDLIB)
+BOOT := $(CFG_QUIET)OCAMLRUNPARAM="b1" $(CFG_BOOT) $(CFG_BOOT_FLAGS)
+
test/run-pass/%.out: test/run-pass/%$(CFG_EXE_SUFFIX) $(CFG_RUNTIME)
@$(call CFG_ECHO, run: $<)
$(CFG_QUIET)$(call CFG_RUN_TARG, $<) > $@
test/run-fail/%.out: test/run-fail/%$(CFG_EXE_SUFFIX) $(CFG_RUNTIME)
@$(call CFG_ECHO, run: $<)
$(CFG_QUIET)rm -f $@
- $(CFG_QUIET)$(call CFG_RUN_TARG, $<) >$@ 2>&1 ; X=$$? ; if [ $$X -eq 0 ] ; then exit 1 ; else exit 0 ; fi
- $(CFG_QUIET)grep --text --quiet "`awk -F: '/error-pattern/ { print $$2 }' $(basename $(basename $@)).rs | tr -d '\n\r'`" $@
+ $(CFG_QUIET)$(call CFG_RUN_TARG, $<) >$@ 2>&1 ; X=$$? ; \
+ if [ $$X -eq 0 ] ; then exit 1 ; else exit 0 ; fi
+ $(CFG_QUIET)grep --text --quiet \
+ "`awk -F: '/error-pattern/ { print $$2 }' \
+ $(basename $(basename $@)).rs | tr -d '\n\r'`" $@
-test/compile-fail/%.x86.out: test/compile-fail/%.rs $(CFG_BOOT) $(CFG_RUNTIME)
+test/compile-fail/%.x86.out: test/compile-fail/%.rs $(REQ)
@$(call CFG_ECHO, compile [x86]: $<)
$(CFG_QUIET)rm -f $@
- $(CFG_QUIET)OCAMLRUNPARAM="b1" $(CFG_BOOT) -o $(@:.out=$(CFG_EXE_SUFFIX)) $< >$@ 2>&1 || true
- $(CFG_QUIET)grep --text --quiet "`awk -F: '/error-pattern/ { print $$2 }' $< | tr -d '\n\r'`" $@
+ $(BOOT) -o $(@:.out=$(CFG_EXE_SUFFIX)) $< >$@ 2>&1 || true
+ $(CFG_QUIET)grep --text --quiet \
+ "`awk -F: '/error-pattern/ { print $$2 }' $< | tr -d '\n\r'`" $@
-test/compile-fail/%.llvm.out: test/compile-fail/%.rs $(CFG_BOOT) $(CFG_RUNTIME)
+test/compile-fail/%.llvm.out: test/compile-fail/%.rs $(REQ)
@$(call CFG_ECHO, compile [llvm]: $<)
$(CFG_QUIET)rm -f $@
- $(CFG_QUIET)OCAMLRUNPARAM="b1" $(CFG_BOOT) $(CFG_BOOT_FLAGS) -o $(@:.out=$(CFG_EXE_SUFFIX)) $< >$@ 2>&1 || true
- $(CFG_QUIET)grep --text --quiet "`awk -F: '/error-pattern/ { print $$2 }' $< | tr -d '\n\r'`" $@
+ $(BOOT) -o $(@:.out=$(CFG_EXE_SUFFIX)) $< >$@ 2>&1 || true
+ $(CFG_QUIET)grep --text --quiet \
+ "`awk -F: '/error-pattern/ { print $$2 }' $< | tr -d '\n\r'`" $@
-test/run-pass/%.x86$(CFG_EXE_SUFFIX): test/run-pass/%.rc $(CFG_BOOT) $(CFG_RUNTIME) $(CFG_STDLIB)
+test/run-pass/%.x86$(CFG_EXE_SUFFIX): test/run-pass/%.rc $(REQ)
@$(call CFG_ECHO, compile [x86]: $<)
- $(CFG_QUIET)OCAMLRUNPARAM="b1" $(CFG_BOOT) $(CFG_BOOT_FLAGS) -o $@ $<
- $(CFG_QUIET)chmod 0755 $@
+ $(BOOT) -o $@ $<
%.s: %.bc
@$(call CFG_ECHO, compile [llvm]: $<)
- $(CFG_QUIET)llc $(CFG_LLC_COMPILE_FLAGS) -o $@ $<
+ $(CFG_QUIET)llc $(CFG_LLC_CFLAGS) -o $@ $<
%.llvm$(CFG_EXE_SUFFIX): %.s $(CFG_RUNTIME)
@$(call CFG_ECHO, compile [llvm]: $<)
- $(CFG_QUIET)gcc $(CFG_GCC_COMPILE_FLAGS) -o $@ $< -L. -lrustrt
+ $(CFG_QUIET)gcc $(CFG_GCC_CFLAGS) -o $@ $< -L. -lrustrt
-test/run-pass/%.bc: test/run-pass/%.rc $(CFG_BOOT) $(CFG_STDLIB)
+test/run-pass/%.bc: test/run-pass/%.rc $(REQ)
@$(call CFG_ECHO, compile [llvm]: $<)
- $(CFG_QUIET)OCAMLRUNPARAM="b1" $(CFG_BOOT) $(CFG_BOOT_FLAGS) -o $@ -llvm $<
+ $(BOOT) -o $@ -llvm $<
-test/run-pass/%.x86$(CFG_EXE_SUFFIX): test/run-pass/%.rs $(CFG_BOOT) $(CFG_RUNTIME) $(CFG_STDLIB)
+test/run-pass/%.x86$(CFG_EXE_SUFFIX): test/run-pass/%.rs $(REQ)
@$(call CFG_ECHO, compile [x86]: $<)
- $(CFG_QUIET)OCAMLRUNPARAM="b1" $(CFG_BOOT) $(CFG_BOOT_FLAGS) -o $@ $<
- $(CFG_QUIET)chmod 0755 $@
+ $(BOOT) -o $@ $<
-test/run-pass/%.bc: test/run-pass/%.rs $(CFG_BOOT) $(CFG_STDLIB)
+test/run-pass/%.bc: test/run-pass/%.rs $(REQ)
@$(call CFG_ECHO, compile [llvm]: $<)
- $(CFG_QUIET)OCAMLRUNPARAM="b1" $(CFG_BOOT) $(CFG_BOOT_FLAGS) -o $@ -llvm $<
+ $(BOOT) -o $@ -llvm $<
-test/run-fail/%.x86$(CFG_EXE_SUFFIX): test/run-fail/%.rs $(CFG_BOOT) $(CFG_RUNTIME) $(CFG_STDLIB)
+test/run-fail/%.x86$(CFG_EXE_SUFFIX): test/run-fail/%.rs $(REQ)
@$(call CFG_ECHO, compile [x86]: $<)
- $(CFG_QUIET)OCAMLRUNPARAM="b1" $(CFG_BOOT) $(CFG_BOOT_FLAGS) -o $@ $<
- $(CFG_QUIET)chmod 0755 $@
+ $(BOOT) -o $@ $<
-test/run-fail/%.bc: test/run-fail/%.rs $(CFG_BOOT) $(CFG_STDLIB)
+test/run-fail/%.bc: test/run-fail/%.rs $(REQ)
@$(call CFG_ECHO, compile [llvm]: $<)
- $(CFG_QUIET)OCAMLRUNPARAM="b1" $(CFG_BOOT) $(CFG_BOOT_FLAGS) -o $@ -llvm $<
+ $(BOOT) -o $@ -llvm $<
######################################################################
%.d: %.cpp $(MKFILES)
@$(call CFG_ECHO, dep: $<)
- $(CFG_QUIET)$(call CFG_DEPEND_C, $@ $(patsubst %.cpp, %$(CFG_OBJ_SUFFIX), $<), $(RUNTIME_INCS)) $< $(CFG_PATH_MUNGE) >$@
+ $(CFG_QUIET)$(call CFG_DEPEND_C, $@ \
+ $(patsubst %.cpp, %$(CFG_OBJ_SUFFIX), $<), \
+ $(RUNTIME_INCS)) $< $(CFG_PATH_MUNGE) >$@
%.d: %.ml $(MKFILES)
@$(call CFG_ECHO, dep: $<)
$(STDLIB_DEPFILE): $(STDLIB_CRATE) $(MKFILES) $(CFG_BOOT)
@$(call CFG_ECHO, dep: $<)
- $(CFG_QUIET)$(CFG_BOOT) $(CFG_BOOT_FLAGS) -shared -rdeps $< $(CFG_PATH_MUNGE) >$@
+ $(BOOT) -shared -rdeps $< $(CFG_PATH_MUNGE) >$@
%.d: %.rc $(MKFILES) $(CFG_BOOT)
@$(call CFG_ECHO, dep: $<)
- $(CFG_QUIET)$(CFG_BOOT) $(CFG_BOOT_FLAGS) -rdeps $< $(CFG_PATH_MUNGE) >$@
+ $(BOOT) -rdeps $< $(CFG_PATH_MUNGE) >$@
%.d: %.rs $(MKFILES) $(CFG_BOOT)
@$(call CFG_ECHO, dep: $<)
- $(CFG_QUIET)$(CFG_BOOT) $(CFG_BOOT_FLAGS) -rdeps $< $(CFG_PATH_MUNGE) >$@
+ $(BOOT) -rdeps $< $(CFG_PATH_MUNGE) >$@
ifneq ($(MAKECMDGOALS),clean)
-include $(CRATE_DEPFILES)
rt/bigint/bigint.h rt/bigint/bigint_int.cpp \
rt/bigint/bigint_ext.cpp rt/bigint/low_primes.h
PKG_FILES := README \
+ $(wildcard etc/*.*) \
$(MKFILES) $(BOOT_MLS) boot/fe/lexer.mll \
- $(COMPILER_CRATE) $(COMPILER_INPUTS) \
+ $(COMPILER_INPUTS) \
$(STDLIB_CRATE) $(STDLIB_INPUTS) \
$(RUNTIME_CS) $(RUNTIME_HDR) $(PKG_3RDPARTY) \
$(ALL_TEST_INPUTS)
# Cleanup
######################################################################
-.PHONY: clean
+.PHONY: clean tidy
+
+tidy:
+ @$(call CFG_ECHO, check: formatting)
+ $(CFG_QUIET) python etc/tidy.py \
+ $(wildcard ../*.txt) \
+ ../README \
+ $(filter-out boot/fe/lexer.ml $(PKG_3RDPARTY), $(PKG_FILES))
clean:
@$(call CFG_ECHO, cleaning)
- $(CFG_QUIET)rm -f $(RUNTIME_OBJS) $(BOOT_CMOS) $(BOOT_CMIS) $(BOOT_CMXS) $(BOOT_OBJS)
+ $(CFG_QUIET)rm -f $(RUNTIME_OBJS)
+ $(CFG_QUIET)rm -f $(BOOT_CMOS) $(BOOT_CMIS) $(BOOT_CMXS) $(BOOT_OBJS)
$(CFG_QUIET)rm -f $(CFG_COMPILER)
$(CFG_QUIET)rm -f $(ML_DEPFILES) $(C_DEPFILES) $(CRATE_DEPFILES)
$(CFG_QUIET)rm -f boot/fe/lexer.ml
$(CFG_QUIET)rm -f $(CFG_BOOT) $(CFG_RUNTIME) $(CFG_STDLIB)
- $(CFG_QUIET)rm -f $(TEST_RUN_PASS_EXES_X86) $(TEST_RUN_PASS_OUTS_X86)
- $(CFG_QUIET)rm -f $(TEST_RUN_PASS_EXES_LLVM) $(TEST_RUN_PASS_OUTS_LLVM)
- $(CFG_QUIET)rm -f $(TEST_RUN_FAIL_EXES_X86) $(TEST_RUN_FAIL_OUTS_X86)
- $(CFG_QUIET)rm -f $(TEST_RUN_FAIL_EXES_LLVM) $(TEST_RUN_FAIL_OUTS_LLVM)
- $(CFG_QUIET)rm -f $(TEST_COMPILE_FAIL_EXES_X86) $(TEST_COMPILE_FAIL_OUTS_X86)
- $(CFG_QUIET)rm -f $(TEST_COMPILE_FAIL_EXES_LLVM) $(TEST_COMPILE_FAIL_OUTS_LLVM)
+ $(CFG_QUIET)rm -f $(TEST_RPASS_EXES_X86) $(TEST_RPASS_OUTS_X86)
+ $(CFG_QUIET)rm -f $(TEST_RPASS_EXES_LLVM) $(TEST_RPASS_OUTS_LLVM)
+ $(CFG_QUIET)rm -f $(TEST_RFAIL_EXES_X86) $(TEST_RFAIL_OUTS_X86)
+ $(CFG_QUIET)rm -f $(TEST_RFAIL_EXES_LLVM) $(TEST_RFAIL_OUTS_LLVM)
+ $(CFG_QUIET)rm -f $(TEST_CFAIL_EXES_X86) $(TEST_CFAIL_OUTS_X86)
+ $(CFG_QUIET)rm -f $(TEST_CFAIL_EXES_LLVM) $(TEST_CFAIL_OUTS_LLVM)
$(CFG_QUIET)rm -Rf $(PKG_NAME)-*.tar.gz dist
- $(CFG_QUIET)rm -f $(foreach ext,cmx cmi cmo cma o a d exe,$(wildcard boot/*/*.$(ext) boot/*/*/*.$(ext)))
+ $(CFG_QUIET)rm -f $(foreach ext,cmx cmi cmo cma o a d exe,\
+ $(wildcard boot/*/*.$(ext) boot/*/*/*.$(ext)))
--- /dev/null
+This is preliminary version of the Rust compiler.
+
+Source layout:
+
+boot/ The bootstrap compiler
+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/llvm - LLVM-based alternative back end
+boot/driver - Compiler driver
+
+comp/ The self-hosted compiler (doesn't exist yet)
+comp/* - Same structure as in boot/
+
+rt/ The runtime system
+rt/rust_*.cpp - The majority of the runtime services
+rt/isaac - The PRNG used for pseudo-random choices in the runtime
+rt/bigint - The bigint library used for the 'big' type
+rt/uthash - Small hashtable-and-list library for C, used in runtime
+rt/{sync,util} - Small utility classes for the runtime.
+
+test/ Testsuite (for both bootstrap and self-hosted)
+test/compile-fail - Tests that should fail to compile
+test/run-fail - Tests that should compile, run and fail
+test/run-pass - Tests that should compile, run and succeed
+
+Please be gentle, it's a work in progress.
--- /dev/null
+
+(*
+ * 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;;
+
+let task_field_refcnt = rc_base_field_refcnt;;
+let task_field_stk = task_field_refcnt + 1;;
+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 = 0;;
+
+let frame_glue_fns_field_mark = 0;;
+let frame_glue_fns_field_drop = 1;;
+let frame_glue_fns_field_reloc = 2;;
+
+let exterior_rc_slot_field_refcnt = 0;;
+let exterior_rc_slot_field_body = 1;;
+
+let exterior_gc_slot_field_next = (-2);;
+let exterior_gc_slot_field_ctrl = (-1);;
+let exterior_gc_slot_field_refcnt = 0;;
+let exterior_gc_slot_field_body = 1;;
+
+let exterior_rc_header_size = 1;;
+let exterior_gc_header_size = 3;;
+
+let exterior_gc_malloc_return_adjustment = 2;;
+
+let stk_field_valgrind_id = 0 + 1;;
+let stk_field_limit = stk_field_valgrind_id + 1;;
+let stk_field_data = stk_field_limit + 1;;
+
+let binding_size = 2;;
+let binding_field_item = 0;;
+let binding_field_binding = 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_copy_glue = 3;;
+let tydesc_field_drop_glue = 4;;
+let tydesc_field_free_glue = 5;;
+let tydesc_field_mark_glue = 6;;
+let tydesc_field_obj_drop_glue = 7;;
+
+let vec_elt_rc = 0;;
+let vec_elt_alloc = 1;;
+let vec_elt_fill = 2;;
+let vec_elt_data = 3;;
+
+let calltup_elt_out_ptr = 0;;
+let calltup_elt_task_ptr = 1;;
+let calltup_elt_ty_params = 2;;
+let calltup_elt_args = 3;;
+let calltup_elt_iterator_args = 4;;
+let calltup_elt_indirect_args = 5;;
+
+let iterator_args_elt_block_fn = 0;;
+let iterator_args_elt_outer_frame_ptr = 1;;
+
+let indirect_args_elt_closure = 0;;
+
+(* ty_params, src, dst, tydesc, taskptr. *)
+let worst_case_glue_call_args = 5;;
+
+type abi =
+ {
+ abi_word_sz: int64;
+ abi_word_bits: Il.bits;
+ abi_word_ty: Common.ty_mach;
+
+ abi_is_2addr_machine: bool;
+ abi_has_pcrel_data: bool;
+ abi_has_pcrel_code: bool;
+
+ abi_n_hardregs: int;
+ abi_str_of_hardreg: (int -> string);
+
+ abi_prealloc_quad: (Il.quad' -> Il.quad');
+ abi_constrain_vregs: (Il.quad -> Bits.t array -> unit);
+
+ abi_emit_fn_prologue: (Il.emitter
+ -> Common.size (* framesz *)
+ -> Common.size (* callsz *)
+ -> Common.nabi
+ -> Common.fixup (* grow_task *)
+ -> 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 (* 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_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_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 ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(*
+
+ 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;;
+
+
+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)
+;;
+
+
+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; }
+;;
+
+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"
+ (string_of_ty_mach m));
+ 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 ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(*
+ * Module for writing System V ELF files.
+ *
+ * FIXME: Presently heavily infected with x86 and elf32 specificities,
+ * though they are reasonably well marked. Needs to be refactored to
+ * depend on abi fields if it's to be usable for other elf
+ * configurations.
+ *)
+
+open Asm;;
+open Common;;
+
+let log (sess:Session.sess) =
+ Session.log "obj (elf)"
+ sess.Session.sess_log_obj
+ sess.Session.sess_log_out
+;;
+
+let iflog (sess:Session.sess) (thunk:(unit -> unit)) : unit =
+ if sess.Session.sess_log_obj
+ then thunk ()
+ else ()
+;;
+
+
+(* Fixed sizes of structs involved in elf32 spec. *)
+let elf32_ehsize = 52L;;
+let elf32_phentsize = 32L;;
+let elf32_shentsize = 40L;;
+let elf32_symsize = 16L;;
+let elf32_rela_entsz = 0xcL;;
+
+type ei_class =
+ ELFCLASSNONE
+ | ELFCLASS32
+ | ELFCLASS64
+;;
+
+
+type ei_data =
+ ELFDATANONE
+ | ELFDATA2LSB
+ | ELFDATA2MSB
+;;
+
+
+let elf_identification ei_class ei_data =
+ SEQ
+ [|
+ STRING "\x7fELF";
+ BYTES
+ [|
+ (match ei_class with (* EI_CLASS *)
+ ELFCLASSNONE -> 0
+ | ELFCLASS32 -> 1
+ | ELFCLASS64 -> 2);
+ (match ei_data with (* EI_DATA *)
+ ELFDATANONE -> 0
+ | ELFDATA2LSB -> 1
+ | ELFDATA2MSB -> 2);
+ 1; (* EI_VERSION = EV_CURRENT *)
+ 0; (* EI_PAD #7 *)
+ 0; (* EI_PAD #8 *)
+ 0; (* EI_PAD #9 *)
+ 0; (* EI_PAD #A *)
+ 0; (* EI_PAD #B *)
+ 0; (* EI_PAD #C *)
+ 0; (* EI_PAD #D *)
+ 0; (* EI_PAD #E *)
+ 0; (* EI_PAD #F *)
+ |]
+ |]
+;;
+
+
+type e_type =
+ ET_NONE
+ | ET_REL
+ | ET_EXEC
+ | ET_DYN
+ | ET_CORE
+;;
+
+
+type e_machine =
+ (* Maybe support more later. *)
+ EM_NONE
+ | EM_386
+ | EM_X86_64
+;;
+
+
+type e_version =
+ EV_NONE
+ | EV_CURRENT
+;;
+
+
+let elf32_header
+ ~(sess:Session.sess)
+ ~(ei_data:ei_data)
+ ~(e_type:e_type)
+ ~(e_machine:e_machine)
+ ~(e_version:e_version)
+ ~(e_entry_fixup:fixup)
+ ~(e_phoff_fixup:fixup)
+ ~(e_shoff_fixup:fixup)
+ ~(e_phnum:int64)
+ ~(e_shnum:int64)
+ ~(e_shstrndx:int64)
+ : frag =
+ let elf_header_fixup = new_fixup "elf header" in
+ let entry_pos =
+ if sess.Session.sess_library_mode
+ then (IMM 0L)
+ else (M_POS e_entry_fixup)
+ in
+ DEF
+ (elf_header_fixup,
+ SEQ [| elf_identification ELFCLASS32 ei_data;
+ WORD (TY_u16, (IMM (match e_type with
+ ET_NONE -> 0L
+ | ET_REL -> 1L
+ | ET_EXEC -> 2L
+ | ET_DYN -> 3L
+ | ET_CORE -> 4L)));
+ WORD (TY_u16, (IMM (match e_machine with
+ EM_NONE -> 0L
+ | EM_386 -> 3L
+ | EM_X86_64 -> 62L)));
+ WORD (TY_u32, (IMM (match e_version with
+ EV_NONE -> 0L
+ | EV_CURRENT -> 1L)));
+ WORD (TY_u32, entry_pos);
+ WORD (TY_u32, (F_POS e_phoff_fixup));
+ WORD (TY_u32, (F_POS e_shoff_fixup));
+ WORD (TY_u32, (IMM 0L)); (* e_flags *)
+ WORD (TY_u16, (IMM elf32_ehsize));
+ WORD (TY_u16, (IMM elf32_phentsize));
+ WORD (TY_u16, (IMM e_phnum));
+ WORD (TY_u16, (IMM elf32_shentsize));
+ WORD (TY_u16, (IMM e_shnum));
+ WORD (TY_u16, (IMM e_shstrndx));
+ |])
+;;
+
+
+type sh_type =
+ SHT_NULL
+ | SHT_PROGBITS
+ | SHT_SYMTAB
+ | SHT_STRTAB
+ | SHT_RELA
+ | SHT_HASH
+ | SHT_DYNAMIC
+ | SHT_NOTE
+ | SHT_NOBITS
+ | SHT_REL
+ | SHT_SHLIB
+ | SHT_DYNSYM
+;;
+
+
+type sh_flags =
+ SHF_WRITE
+ | SHF_ALLOC
+ | SHF_EXECINSTR
+;;
+
+
+let section_header
+ ~(shstring_table_fixup:fixup)
+ ~(shname_string_fixup:fixup)
+ ~(sh_type:sh_type)
+ ~(sh_flags:sh_flags list)
+ ~(section_fixup:fixup option)
+ ~(sh_addralign:int64)
+ ~(sh_entsize:int64)
+ ~(sh_link:int64 option)
+ : frag =
+ SEQ
+ [|
+ WORD (TY_i32, (SUB
+ ((F_POS shname_string_fixup),
+ (F_POS shstring_table_fixup))));
+ WORD (TY_u32, (IMM (match sh_type with
+ SHT_NULL -> 0L
+ | SHT_PROGBITS -> 1L
+ | SHT_SYMTAB -> 2L
+ | SHT_STRTAB -> 3L
+ | SHT_RELA -> 4L
+ | SHT_HASH -> 5L
+ | SHT_DYNAMIC -> 6L
+ | SHT_NOTE -> 7L
+ | SHT_NOBITS -> 8L
+ | SHT_REL -> 9L
+ | SHT_SHLIB -> 10L
+ | SHT_DYNSYM -> 11L)));
+ WORD (TY_u32, (IMM (fold_flags
+ (fun f -> match f with
+ SHF_WRITE -> 0x1L
+ | SHF_ALLOC -> 0x2L
+ | SHF_EXECINSTR -> 0x4L) sh_flags)));
+ WORD (TY_u32, (match section_fixup with
+ None -> (IMM 0L)
+ | Some s -> (M_POS s)));
+ WORD (TY_u32, (match section_fixup with
+ None -> (IMM 0L)
+ | Some s -> (F_POS s)));
+ WORD (TY_u32, (match section_fixup with
+ None -> (IMM 0L)
+ | Some s -> (F_SZ s)));
+ WORD (TY_u32, (IMM (match sh_link with
+ None -> 0L
+ | Some i -> i)));
+ WORD (TY_u32, (IMM 0L)); (* sh_info *)
+ WORD (TY_u32, (IMM sh_addralign));
+ WORD (TY_u32, (IMM sh_entsize));
+ |]
+;;
+
+
+type p_type =
+ PT_NULL
+ | PT_LOAD
+ | PT_DYNAMIC
+ | PT_INTERP
+ | PT_NOTE
+ | PT_SHLIB
+ | PT_PHDR
+;;
+
+
+type p_flag =
+ PF_X
+ | PF_W
+ | PF_R
+;;
+
+
+let program_header
+ ~(p_type:p_type)
+ ~(segment_fixup:fixup)
+ ~(p_flags:p_flag list)
+ ~(p_align:int64)
+ : frag =
+ SEQ
+ [|
+ WORD (TY_u32, (IMM (match p_type with
+ PT_NULL -> 0L
+ | PT_LOAD -> 1L
+ | PT_DYNAMIC -> 2L
+ | PT_INTERP -> 3L
+ | PT_NOTE -> 4L
+ | PT_SHLIB -> 5L
+ | PT_PHDR -> 6L)));
+ WORD (TY_u32, (F_POS segment_fixup));
+ WORD (TY_u32, (M_POS segment_fixup));
+ WORD (TY_u32, (M_POS segment_fixup));
+ WORD (TY_u32, (F_SZ segment_fixup));
+ WORD (TY_u32, (M_SZ segment_fixup));
+ WORD (TY_u32, (IMM (fold_flags
+ (fun f ->
+ match f with
+ PF_X -> 0x1L
+ | PF_W -> 0x2L
+ | PF_R -> 0x4L)
+ p_flags)));
+ WORD (TY_u32, (IMM p_align));
+ |]
+;;
+
+
+type st_bind =
+ STB_LOCAL
+ | STB_GLOBAL
+ | STB_WEAK
+;;
+
+
+type st_type =
+ STT_NOTYPE
+ | STT_OBJECT
+ | STT_FUNC
+ | STT_SECTION
+ | STT_FILE
+;;
+
+
+(* Special symbol-section indices *)
+let shn_UNDEF = 0L;;
+let shn_ABS = 0xfff1L;;
+let shn_ABS = 0xfff2L;;
+
+
+let symbol
+ ~(string_table_fixup:fixup)
+ ~(name_string_fixup:fixup)
+ ~(sym_target_fixup:fixup option)
+ ~(st_bind:st_bind)
+ ~(st_type:st_type)
+ ~(st_shndx:int64)
+ : frag =
+ let st_bind_num =
+ match st_bind with
+ STB_LOCAL -> 0L
+ | STB_GLOBAL -> 1L
+ | STB_WEAK -> 2L
+ in
+ let st_type_num =
+ match st_type with
+ STT_NOTYPE -> 0L
+ | STT_OBJECT -> 1L
+ | STT_FUNC -> 2L
+ | STT_SECTION -> 3L
+ | STT_FILE -> 4L
+ in
+ SEQ
+ [|
+ WORD (TY_u32, (SUB
+ ((F_POS name_string_fixup),
+ (F_POS string_table_fixup))));
+ WORD (TY_u32, (match sym_target_fixup with
+ None -> (IMM 0L)
+ | Some f -> (M_POS f)));
+ WORD (TY_u32, (match sym_target_fixup with
+ None -> (IMM 0L)
+ | Some f -> (M_SZ f)));
+ WORD (TY_u8, (* st_info *)
+ (OR
+ ((SLL ((IMM st_bind_num), 4)),
+ (AND ((IMM st_type_num), (IMM 0xfL))))));
+ WORD (TY_u8, (IMM 0L)); (* st_other *)
+ WORD (TY_u16, (IMM st_shndx));
+ |]
+;;
+
+type d_tag =
+ DT_NULL
+ | DT_NEEDED
+ | DT_PLTRELSZ
+ | DT_PLTGOT
+ | DT_HASH
+ | DT_STRTAB
+ | DT_SYMTAB
+ | DT_RELA
+ | DT_RELASZ
+ | DT_RELAENT
+ | DT_STRSZ
+ | DT_SYMENT
+ | DT_INIT
+ | DT_FINI
+ | DT_SONAME
+ | DT_RPATH
+ | DT_SYMBOLIC
+ | DT_REL
+ | DT_RELSZ
+ | DT_RELENT
+ | DT_PLTREL
+ | DT_DEBUG
+ | DT_TEXTREL
+ | DT_JMPREL
+ | DT_BIND_NOW
+ | DT_INIT_ARRAY
+ | DT_FINI_ARRAY
+ | DT_INIT_ARRAYSZ
+ | DT_FINI_ARRAYSZ
+ | DT_RUNPATH
+ | DT_FLAGS
+ | DT_ENCODING
+ | DT_PREINIT_ARRAY
+ | DT_PREINIT_ARRAYSZ
+;;
+
+type elf32_dyn = (d_tag * expr64);;
+
+let elf32_num_of_dyn_tag tag =
+ match tag with
+ DT_NULL -> 0L
+ | DT_NEEDED -> 1L
+ | DT_PLTRELSZ -> 2L
+ | DT_PLTGOT -> 3L
+ | DT_HASH -> 4L
+ | DT_STRTAB -> 5L
+ | DT_SYMTAB -> 6L
+ | DT_RELA -> 7L
+ | DT_RELASZ -> 8L
+ | DT_RELAENT -> 9L
+ | DT_STRSZ -> 10L
+ | DT_SYMENT -> 11L
+ | DT_INIT -> 12L
+ | DT_FINI -> 13L
+ | DT_SONAME -> 14L
+ | DT_RPATH -> 15L
+ | DT_SYMBOLIC -> 16L
+ | DT_REL -> 17L
+ | DT_RELSZ -> 18L
+ | DT_RELENT -> 19L
+ | DT_PLTREL -> 20L
+ | DT_DEBUG -> 21L
+ | DT_TEXTREL -> 22L
+ | DT_JMPREL -> 23L
+ | DT_BIND_NOW -> 24L
+ | DT_INIT_ARRAY -> 25L
+ | DT_FINI_ARRAY -> 26L
+ | DT_INIT_ARRAYSZ -> 27L
+ | DT_FINI_ARRAYSZ -> 28L
+ | DT_RUNPATH -> 29L
+ | DT_FLAGS -> 30L
+ | DT_ENCODING -> 31L
+ | DT_PREINIT_ARRAY -> 32L
+ | DT_PREINIT_ARRAYSZ -> 33L
+;;
+
+let elf32_dyn_frag d =
+ let (tag, expr) = d in
+ let tagval = elf32_num_of_dyn_tag tag in
+ SEQ [| WORD (TY_u32, (IMM tagval)); WORD (TY_u32, expr) |]
+;;
+
+type elf32_386_reloc_type =
+ R_386_NONE
+ | R_386_32
+ | R_386_PC32
+ | R_386_GOT32
+ | R_386_PLT32
+ | R_386_COPY
+ | R_386_GLOB_DAT
+ | R_386_JMP_SLOT
+ | R_386_RELATIVE
+ | R_386_GOTOFF
+ | R_386_GOTPC
+;;
+
+
+type elf32_386_rela =
+ { elf32_386_rela_type: elf32_386_reloc_type;
+ elf32_386_rela_offset: expr64;
+ elf32_386_rela_sym: expr64;
+ elf32_386_rela_addend: expr64 }
+;;
+
+let elf32_386_rela_frag r =
+ let type_val =
+ match r.elf32_386_rela_type with
+ R_386_NONE -> 0L
+ | R_386_32 -> 1L
+ | R_386_PC32 -> 2L
+ | R_386_GOT32 -> 3L
+ | R_386_PLT32 -> 4L
+ | R_386_COPY -> 5L
+ | R_386_GLOB_DAT -> 6L
+ | R_386_JMP_SLOT -> 7L
+ | R_386_RELATIVE -> 8L
+ | R_386_GOTOFF -> 9L
+ | R_386_GOTPC -> 10L
+ in
+ let info_expr =
+ WORD (TY_u32,
+ (OR
+ (SLL ((r.elf32_386_rela_sym), 8),
+ AND ((IMM 0xffL), (IMM type_val)))))
+ in
+ SEQ [| WORD (TY_u32, r.elf32_386_rela_offset);
+ info_expr;
+ WORD (TY_u32, r.elf32_386_rela_addend) |]
+;;
+
+
+let elf32_linux_x86_file
+ ~(sess:Session.sess)
+ ~(crate:Ast.crate)
+ ~(entry_name:string)
+ ~(text_frags:(string option, frag) Hashtbl.t)
+ ~(data_frags:(string option, frag) Hashtbl.t)
+ ~(rodata_frags:(string option, frag) Hashtbl.t)
+ ~(required_fixups:(string, fixup) Hashtbl.t)
+ ~(dwarf:Dwarf.debug_records)
+ ~(sem:Semant.ctxt)
+ ~(needed_libs:string array)
+ : frag =
+
+ (* Procedure Linkage Tables (PLTs), Global Offset Tables
+ * (GOTs), and the relocations that set them up:
+ *
+ * The PLT goes in a section called .plt and GOT in a section called
+ * .got. The portion of the GOT that holds PLT jump slots goes in a
+ * section called .got.plt. Dynamic relocations for these jump slots go in
+ * section .rela.plt.
+ *
+ * The easiest way to understand the PLT/GOT system is to draw it:
+ *
+ * PLT GOT
+ * +----------------------+ +----------------------+
+ * 0| push &<GOT[1]> 0| <reserved>
+ * | jmp *GOT[2] 1| <libcookie>
+ * | 2| & <ld.so:resolve-a-sym>
+ * 1| jmp *GOT[3] 3| & <'push 0' in PLT[1]>
+ * | push 0 4| & <'push 1' in PLT[2]>
+ * | jmp *PLT[0] 5| & <'push 2' in PLT[3]>
+ * |
+ * 2| jmp *GOT[4]
+ * | push 1
+ * | jmp *PLT[0]
+ * |
+ * 2| jmp *GOT[5]
+ * | push 2
+ * | jmp *PLT[0]
+ *
+ *
+ * In normal user code, we call PLT entries with a call to a
+ * PC-relative address, the PLT entry, which itself does an indirect
+ * jump through a slot in the GOT that it also addresses
+ * PC-relative. This makes the whole scheme PIC.
+ *
+ * The linker fills in the GOT on startup. For the first 3, it uses
+ * its own thinking. For the remainder it needs to be instructed to
+ * fill them in with "jump slot relocs", type R_386_JUMP_SLOT, each
+ * of which says in effect which PLT entry it's to point back to and
+ * which symbol it's to be resolved to later. These relocs go in the
+ * section .rela.plt.
+ *)
+
+ let plt0_fixup = new_fixup "PLT[0]" in
+ let got_prefix = SEQ [| WORD (TY_u32, (IMM 0L));
+ WORD (TY_u32, (IMM 0L));
+ WORD (TY_u32, (IMM 0L)); |]
+ in
+
+ let got_cell reg i =
+ let got_entry_off = Int64.of_int (i*4) in
+ let got_entry_mem = Il.RegIn (reg, (Some (Asm.IMM got_entry_off))) in
+ Il.Mem (got_entry_mem, Il.ScalarTy (Il.AddrTy Il.CodeTy))
+ in
+
+ let got_code_cell reg i =
+ Il.CodePtr (Il.Cell (got_cell reg i))
+ in
+
+ let plt0_frag =
+ let reg = Il.Hreg X86.eax in
+ let e = X86.new_emitter_without_vregs () in
+ Il.emit e (Il.Push (Il.Cell (got_cell reg 1)));
+ Il.emit e (Il.jmp Il.JMP (got_code_cell reg 2));
+ Il.emit e Il.Nop;
+ Il.emit e Il.Nop;
+ Il.emit e Il.Nop;
+ Il.emit e Il.Nop;
+ DEF (plt0_fixup, (X86.frags_of_emitted_quads sess e))
+ in
+
+ (*
+ * The existence of the GOT/PLT mish-mash causes, therefore, the
+ * following new sections:
+ *
+ * .plt - the PLT itself, in the r/x text segment
+ * .got.plt - the PLT-used portion of the GOT, in the r/w segment
+ * .rela.plt - the dynamic relocs for the GOT-PLT, in the r/x segment
+ *
+ * In addition, because we're starting up a dynamically linked executable,
+ * we have to have several more sections!
+ *
+ * .interp - the read-only section that names ld.so
+ * .dynsym - symbols named by the PLT/GOT entries, r/x segment
+ * .dynstr - string-names used in those symbols, r/x segment
+ * .hash - hashtable in which to look these up, r/x segment
+ * .dynamic - the machine-readable description of the dynamic
+ * linkage requirements of this elf file, in the
+ * r/w _DYNAMIC segment
+ *
+ * The Dynamic section contains a sequence of 2-word records of type
+ * d_tag.
+ *
+ *)
+
+ (* There are 17 official section headers in the file we're making: *)
+ (* *)
+ (* section 0: <null section> *)
+ (* *)
+ (* section 1: .interp (segment 1: R+X, INTERP) *)
+ (* *)
+ (* section 2: .text (segment 2: R+X, LOAD) *)
+ (* section 3: .rodata ... *)
+ (* section 4: .dynsym ... *)
+ (* section 5: .dynstr ... *)
+ (* section 6: .hash ... *)
+ (* section 7: .plt ... *)
+ (* section 8: .got ... *)
+ (* section 9: .rela.plt ... *)
+ (* *)
+ (* section 10: .data (segment 3: R+W, LOAD) *)
+ (* section 11: .bss ... *)
+ (* *)
+ (* section 12: .dynamic (segment 4: R+W, DYNAMIC) *)
+ (* *)
+ (* section 13: .shstrtab (not in a segment) *)
+ (* section 14: .debug_aranges (segment 2: cont'd) *)
+ (* section 15: .debug_pubnames ... *)
+ (* section 14: .debug_info ... *)
+ (* section 15: .debug_abbrev ... *)
+ (* section 14: .debug_line ... *)
+ (* section 15: .debug_frame ... *)
+ (* section 16: .note..rust (segment 5: NOTE) *)
+
+ let sname s =
+ new_fixup (Printf.sprintf "string name of '%s' section" s)
+ in
+ let null_section_name_fixup = sname "<null>" in
+ let interp_section_name_fixup = sname ".interp"in
+ let text_section_name_fixup = sname ".text" in
+ let rodata_section_name_fixup = sname ".rodata" in
+ let dynsym_section_name_fixup = sname ".dynsym" in
+ let dynstr_section_name_fixup = sname ".dynstr" in
+ let hash_section_name_fixup = sname ".hash" in
+ let plt_section_name_fixup = sname ".plt" in
+ let got_plt_section_name_fixup = sname ".got.plt" in
+ let rela_plt_section_name_fixup = sname ".rela.plt" in
+ let data_section_name_fixup = sname ".data" in
+ let bss_section_name_fixup = sname ".bss" in
+ let dynamic_section_name_fixup = sname ".dynamic" in
+ let shstrtab_section_name_fixup = sname ".shstrtab" in
+ let debug_aranges_section_name_fixup = sname ".debug_aranges" in
+ let debug_pubnames_section_name_fixup = sname ".debug_pubnames" in
+ let debug_info_section_name_fixup = sname ".debug_info" in
+ let debug_abbrev_section_name_fixup = sname ".debug_abbrev" in
+ let debug_line_section_name_fixup = sname ".debug_line" in
+ let debug_frame_section_name_fixup = sname ".debug_frame" in
+ let note_rust_section_name_fixup = sname ".note.rust" in
+
+ (* let interpndx = 1L in *) (* Section index of .interp *)
+ let textndx = 2L in (* Section index of .text *)
+ let rodatandx = 3L in (* Section index of .rodata *)
+ let dynsymndx = 4L in (* Section index of .dynsym *)
+ let dynstrndx = 5L in (* Section index of .dynstr *)
+ (* let hashndx = 6L in *) (* Section index of .hash *)
+ (* let pltndx = 7L in *) (* Section index of .plt *)
+ (* let gotpltndx = 8L in *) (* Section index of .got.plt *)
+ (* let relapltndx = 9L in *) (* Section index of .rela.plt *)
+ let datandx = 10L in (* Section index of .data *)
+ (* let bssndx = 11L in *) (* Section index of .bss *)
+ (* let dynamicndx = 12L in *) (* Section index of .dynamic *)
+ let shstrtabndx = 13L in (* Section index of .shstrtab *)
+
+ let section_header_table_fixup = new_fixup ".section header table" in
+ let interp_section_fixup = new_fixup ".interp section" in
+ let text_section_fixup = new_fixup ".text section" in
+ let rodata_section_fixup = new_fixup ".rodata section" in
+ let dynsym_section_fixup = new_fixup ".dynsym section" in
+ let dynstr_section_fixup = new_fixup ".dynstr section" in
+ let hash_section_fixup = new_fixup ".hash section" in
+ let plt_section_fixup = new_fixup ".plt section" in
+ let got_plt_section_fixup = new_fixup ".got.plt section" in
+ let rela_plt_section_fixup = new_fixup ".rela.plt section" in
+ let data_section_fixup = new_fixup ".data section" in
+ let bss_section_fixup = new_fixup ".bss section" in
+ let dynamic_section_fixup = new_fixup ".dynamic section" in
+ let shstrtab_section_fixup = new_fixup ".shstrtab section" in
+ let note_rust_section_fixup = new_fixup ".shstrtab section" in
+
+ let shstrtab_section =
+ SEQ
+ [|
+ DEF (null_section_name_fixup, ZSTRING "");
+ DEF (interp_section_name_fixup, ZSTRING ".interp");
+ DEF (text_section_name_fixup, ZSTRING ".text");
+ DEF (rodata_section_name_fixup, ZSTRING ".rodata");
+ DEF (dynsym_section_name_fixup, ZSTRING ".dynsym");
+ DEF (dynstr_section_name_fixup, ZSTRING ".dynstr");
+ DEF (hash_section_name_fixup, ZSTRING ".hash");
+ DEF (plt_section_name_fixup, ZSTRING ".plt");
+ DEF (got_plt_section_name_fixup, ZSTRING ".got.plt");
+ DEF (rela_plt_section_name_fixup, ZSTRING ".rela.plt");
+ DEF (data_section_name_fixup, ZSTRING ".data");
+ DEF (bss_section_name_fixup, ZSTRING ".bss");
+ DEF (dynamic_section_name_fixup, ZSTRING ".dynamic");
+ DEF (shstrtab_section_name_fixup, ZSTRING ".shstrtab");
+ DEF (debug_aranges_section_name_fixup, ZSTRING ".debug_aranges");
+ DEF (debug_pubnames_section_name_fixup, ZSTRING ".debug_pubnames");
+ DEF (debug_info_section_name_fixup, ZSTRING ".debug_info");
+ DEF (debug_abbrev_section_name_fixup, ZSTRING ".debug_abbrev");
+ DEF (debug_line_section_name_fixup, ZSTRING ".debug_line");
+ DEF (debug_frame_section_name_fixup, ZSTRING ".debug_frame");
+ DEF (note_rust_section_name_fixup, ZSTRING ".note.rust");
+ |]
+ in
+
+ let section_headers =
+ [|
+ (* <null> *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: null_section_name_fixup
+ ~sh_type: SHT_NULL
+ ~sh_flags: []
+ ~section_fixup: None
+ ~sh_addralign: 0L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+
+ (* .interp *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: interp_section_name_fixup
+ ~sh_type: SHT_PROGBITS
+ ~sh_flags: [ SHF_ALLOC ]
+ ~section_fixup: (Some interp_section_fixup)
+ ~sh_addralign: 1L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+
+ (* .text *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: text_section_name_fixup
+ ~sh_type: SHT_PROGBITS
+ ~sh_flags: [ SHF_ALLOC; SHF_EXECINSTR ]
+ ~section_fixup: (Some text_section_fixup)
+ ~sh_addralign: 32L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+
+ (* .rodata *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: rodata_section_name_fixup
+ ~sh_type: SHT_PROGBITS
+ ~sh_flags: [ SHF_ALLOC ]
+ ~section_fixup: (Some rodata_section_fixup)
+ ~sh_addralign: 32L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+
+ (* .dynsym *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: dynsym_section_name_fixup
+ ~sh_type: SHT_DYNSYM
+ ~sh_flags: [ SHF_ALLOC ]
+ ~section_fixup: (Some dynsym_section_fixup)
+ ~sh_addralign: 8L
+ ~sh_entsize: elf32_symsize
+ ~sh_link: (Some dynstrndx) );
+
+ (* .dynstr *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: dynstr_section_name_fixup
+ ~sh_type: SHT_STRTAB
+ ~sh_flags: [ SHF_ALLOC ]
+ ~section_fixup: (Some dynstr_section_fixup)
+ ~sh_addralign: 1L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+
+ (* .hash *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: hash_section_name_fixup
+ ~sh_type: SHT_PROGBITS
+ ~sh_flags: [ SHF_ALLOC ]
+ ~section_fixup: (Some hash_section_fixup)
+ ~sh_addralign: 4L
+ ~sh_entsize: 4L
+ ~sh_link: (Some dynsymndx));
+
+ (* .plt *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: plt_section_name_fixup
+ ~sh_type: SHT_PROGBITS
+ ~sh_flags: [ SHF_ALLOC; SHF_EXECINSTR ]
+ ~section_fixup: (Some plt_section_fixup)
+ ~sh_addralign: 4L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+
+ (* .got.plt *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: got_plt_section_name_fixup
+ ~sh_type: SHT_PROGBITS
+ ~sh_flags: [ SHF_ALLOC; SHF_WRITE ]
+ ~section_fixup: (Some got_plt_section_fixup)
+ ~sh_addralign: 4L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+
+ (* .rela.plt *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: rela_plt_section_name_fixup
+ ~sh_type: SHT_RELA
+ ~sh_flags: [ SHF_ALLOC ]
+ ~section_fixup: (Some rela_plt_section_fixup)
+ ~sh_addralign: 4L
+ ~sh_entsize: elf32_rela_entsz
+ ~sh_link: (Some dynsymndx));
+
+ (* .data *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: data_section_name_fixup
+ ~sh_type: SHT_PROGBITS
+ ~sh_flags: [ SHF_ALLOC; SHF_WRITE ]
+ ~section_fixup: (Some data_section_fixup)
+ ~sh_addralign: 32L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+
+ (* .bss *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: bss_section_name_fixup
+ ~sh_type: SHT_NOBITS
+ ~sh_flags: [ SHF_ALLOC; SHF_WRITE ]
+ ~section_fixup: (Some bss_section_fixup)
+ ~sh_addralign: 32L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+
+ (* .dynamic *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: dynamic_section_name_fixup
+ ~sh_type: SHT_DYNAMIC
+ ~sh_flags: [ SHF_ALLOC; SHF_WRITE ]
+ ~section_fixup: (Some dynamic_section_fixup)
+ ~sh_addralign: 8L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+
+ (* .shstrtab *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: shstrtab_section_name_fixup
+ ~sh_type: SHT_STRTAB
+ ~sh_flags: []
+ ~section_fixup: (Some shstrtab_section_fixup)
+ ~sh_addralign: 1L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+
+(*
+ FIXME: uncomment the dwarf section headers as you make use of them;
+ recent gdb versions have got fussier about parsing dwarf and don't
+ like seeing junk there.
+*)
+
+ (* .debug_aranges *)
+(*
+
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: debug_aranges_section_name_fixup
+ ~sh_type: SHT_PROGBITS
+ ~sh_flags: []
+ ~section_fixup: (Some sem.Semant.ctxt_debug_aranges_fixup)
+ ~sh_addralign: 8L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+*)
+ (* .debug_pubnames *)
+(*
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: debug_pubnames_section_name_fixup
+ ~sh_type: SHT_PROGBITS
+ ~sh_flags: []
+ ~section_fixup: (Some sem.Semant.ctxt_debug_pubnames_fixup)
+ ~sh_addralign: 1L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+*)
+
+ (* .debug_info *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: debug_info_section_name_fixup
+ ~sh_type: SHT_PROGBITS
+ ~sh_flags: []
+ ~section_fixup: (Some sem.Semant.ctxt_debug_info_fixup)
+ ~sh_addralign: 1L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+
+ (* .debug_abbrev *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: debug_abbrev_section_name_fixup
+ ~sh_type: SHT_PROGBITS
+ ~sh_flags: []
+ ~section_fixup: (Some sem.Semant.ctxt_debug_abbrev_fixup)
+ ~sh_addralign: 1L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+ (* .debug_line *)
+(*
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: debug_line_section_name_fixup
+ ~sh_type: SHT_PROGBITS
+ ~sh_flags: []
+ ~section_fixup: (Some sem.Semant.ctxt_debug_line_fixup)
+ ~sh_addralign: 1L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+*)
+
+ (* .debug_frame *)
+(*
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: debug_frame_section_name_fixup
+ ~sh_type: SHT_PROGBITS
+ ~sh_flags: []
+ ~section_fixup: (Some sem.Semant.ctxt_debug_frame_fixup)
+ ~sh_addralign: 4L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+*)
+
+ (* .note.rust *)
+ (section_header
+ ~shstring_table_fixup: shstrtab_section_fixup
+ ~shname_string_fixup: note_rust_section_name_fixup
+ ~sh_type: SHT_NOTE
+ ~sh_flags: []
+ ~section_fixup: (Some note_rust_section_fixup)
+ ~sh_addralign: 1L
+ ~sh_entsize: 0L
+ ~sh_link: None);
+
+ |]
+ in
+ let section_header_table = SEQ section_headers in
+
+
+ (* There are 6 official program headers in the file we're making: *)
+ (* segment 0: RX / PHDR *)
+ (* segment 1: R / INTERP *)
+ (* segment 2: RX / LOAD *)
+ (* segment 3: RW / LOAD *)
+ (* segment 4: RW / DYNAMIC *)
+ (* segment 5: R *)
+
+ let program_header_table_fixup = new_fixup "program header table" in
+ let segment_0_fixup = new_fixup "segment 0" in
+ let segment_1_fixup = new_fixup "segment 1" in
+ let segment_2_fixup = new_fixup "segment 2" in
+ let segment_3_fixup = new_fixup "segment 3" in
+ let segment_4_fixup = new_fixup "segment 4" in
+ let segment_5_fixup = new_fixup "segment 5" in
+
+ let segment_0_align = 4 in
+ let segment_1_align = 1 in
+ let segment_2_align = 0x1000 in
+ let segment_3_align = 0x1000 in
+ let segment_4_align = 0x1000 in
+ let segment_5_align = 1 in
+
+ let program_headers = [|
+ (program_header
+ ~p_type: PT_PHDR
+ ~segment_fixup: segment_0_fixup
+ ~p_flags: [ PF_R; PF_X ]
+ ~p_align: (Int64.of_int segment_0_align));
+ (program_header
+ ~p_type: PT_INTERP
+ ~segment_fixup: segment_1_fixup
+ ~p_flags: [ PF_R ]
+ ~p_align: (Int64.of_int segment_1_align));
+ (program_header
+ ~p_type: PT_LOAD
+ ~segment_fixup: segment_2_fixup
+ ~p_flags: [ PF_R; PF_X ]
+ ~p_align: (Int64.of_int segment_2_align));
+ (program_header
+ ~p_type: PT_LOAD
+ ~segment_fixup: segment_3_fixup
+ ~p_flags: [ PF_R; PF_W ]
+ ~p_align: (Int64.of_int segment_3_align));
+ (program_header
+ ~p_type: PT_DYNAMIC
+ ~segment_fixup: segment_4_fixup
+ ~p_flags: [ PF_R; PF_W ]
+ ~p_align: (Int64.of_int segment_4_align));
+ (program_header
+ ~p_type: PT_NOTE
+ ~segment_fixup: segment_5_fixup
+ ~p_flags: [ PF_R;]
+ ~p_align: (Int64.of_int segment_5_align));
+ |]
+ in
+ let program_header_table = SEQ program_headers in
+
+ let e_entry_fixup = new_fixup "entry symbol" in
+
+ let elf_header =
+ elf32_header
+ ~sess
+ ~ei_data: ELFDATA2LSB
+ ~e_type: ET_DYN
+ ~e_machine: EM_386
+ ~e_version: EV_CURRENT
+
+ ~e_entry_fixup: e_entry_fixup
+ ~e_phoff_fixup: program_header_table_fixup
+ ~e_shoff_fixup: section_header_table_fixup
+ ~e_phnum: (Int64.of_int (Array.length program_headers))
+ ~e_shnum: (Int64.of_int (Array.length section_headers))
+ ~e_shstrndx: shstrtabndx
+ in
+
+ let n_syms = ref 1 in (* The empty symbol, implicit. *)
+
+ let data_sym name st_bind fixup =
+ let name_fixup = new_fixup ("data symbol name fixup: '" ^ name ^ "'") in
+ let strtab_entry = DEF (name_fixup, ZSTRING name) in
+ let symtab_entry =
+ symbol
+ ~string_table_fixup: dynstr_section_fixup
+ ~name_string_fixup: name_fixup
+ ~sym_target_fixup: (Some fixup)
+ ~st_bind
+ ~st_type: STT_OBJECT
+ ~st_shndx: datandx
+ in
+ incr n_syms;
+ (strtab_entry, symtab_entry)
+ in
+
+ let rodata_sym name st_bind fixup =
+ let name_fixup = new_fixup ("rodata symbol name fixup: '" ^ name ^ "'") in
+ let strtab_entry = DEF (name_fixup, ZSTRING name) in
+ let symtab_entry =
+ symbol
+ ~string_table_fixup: dynstr_section_fixup
+ ~name_string_fixup: name_fixup
+ ~sym_target_fixup: (Some fixup)
+ ~st_bind
+ ~st_type: STT_OBJECT
+ ~st_shndx: rodatandx
+ in
+ incr n_syms;
+ (strtab_entry, symtab_entry)
+ in
+
+ let text_sym name st_bind fixup =
+ let name_fixup = new_fixup ("text symbol name fixup: '" ^ name ^ "'") in
+ let strtab_frag = DEF (name_fixup, ZSTRING name) in
+ let symtab_frag =
+ symbol
+ ~string_table_fixup: dynstr_section_fixup
+ ~name_string_fixup: name_fixup
+ ~sym_target_fixup: (Some fixup)
+ ~st_bind: st_bind
+ ~st_type: STT_FUNC
+ ~st_shndx: textndx
+ in
+ incr n_syms;
+ (strtab_frag, symtab_frag)
+ in
+
+ let require_sym name st_bind _(*fixup*) =
+ let name_fixup =
+ new_fixup ("require symbol name fixup: '" ^ name ^ "'")
+ in
+ let strtab_frag = DEF (name_fixup, ZSTRING name) in
+ let symtab_frag =
+ symbol
+ ~string_table_fixup: dynstr_section_fixup
+ ~name_string_fixup: name_fixup
+ ~sym_target_fixup: None
+ ~st_bind
+ ~st_type: STT_FUNC
+ ~st_shndx: shn_UNDEF
+ in
+ incr n_syms;
+ (strtab_frag, symtab_frag)
+ in
+
+ let frags_of_symbol sym_emitter st_bind symname_opt symbody x =
+ let (strtab_frags, symtab_frags, body_frags) = x in
+ let (strtab_frag, symtab_frag, body_frag) =
+ match symname_opt with
+ None -> (MARK, MARK, symbody)
+ | Some symname ->
+ let body_fixup =
+ new_fixup ("symbol body fixup: '" ^ symname ^ "'")
+ in
+ let body =
+ if symname = entry_name
+ then DEF (e_entry_fixup, DEF (body_fixup, symbody))
+ else DEF (body_fixup, symbody)
+ in
+ let (str, sym) = sym_emitter symname st_bind body_fixup in
+ (str, sym, body)
+ in
+ ((strtab_frag :: strtab_frags),
+ (symtab_frag :: symtab_frags),
+ (body_frag :: body_frags))
+ in
+
+ let frags_of_require_symbol sym_emitter st_bind symname plt_entry_fixup x =
+ let (i, strtab_frags, symtab_frags,
+ plt_frags, got_plt_frags, rela_plt_frags) = x in
+ let (strtab_frag, symtab_frag) = sym_emitter symname st_bind None in
+ let e = X86.new_emitter_without_vregs () in
+ let jump_slot_fixup = new_fixup ("jump slot #" ^ string_of_int i) in
+ let jump_slot_initial_target_fixup =
+ new_fixup ("jump slot #" ^ string_of_int i ^ " initial target") in
+
+ (* You may notice this PLT entry doesn't look like either of the
+ * types of "normal" PLT entries outlined in the ELF manual. It is,
+ * however, just what you get when you combine a PIC PLT entry with
+ * inline calls to the horrible __i686.get_pc_thunk.ax kludge used
+ * on x86 to support entering PIC PLTs. We're just doing it *in*
+ * the PLT entries rather than infecting all the callers with the
+ * obligation of having the GOT address in a register on
+ * PLT-entry.
+ *)
+
+ let plt_frag =
+ let (reg, _, _) = X86.get_next_pc_thunk in
+
+ Il.emit_full e (Some plt_entry_fixup) [] Il.Dead;
+
+ Abi.load_fixup_addr e reg got_plt_section_fixup Il.CodeTy;
+
+ Il.emit e (Il.jmp Il.JMP (got_code_cell reg (2+i)));
+
+ Il.emit_full e (Some jump_slot_initial_target_fixup)
+ [] (Il.Push (X86.immi (Int64.of_int i)));
+
+ Il.emit e (Il.jmp Il.JMP (Il.direct_code_ptr plt0_fixup));
+ X86.frags_of_emitted_quads sess e
+ in
+ let got_plt_frag =
+ DEF (jump_slot_fixup,
+ WORD (TY_u32, (M_POS jump_slot_initial_target_fixup)))
+ in
+ let rela_plt =
+ { elf32_386_rela_type = R_386_JMP_SLOT;
+ elf32_386_rela_offset = (M_POS jump_slot_fixup);
+ elf32_386_rela_sym = (IMM (Int64.of_int i));
+ elf32_386_rela_addend = (IMM 0L) }
+ in
+ let rela_plt_frag = elf32_386_rela_frag rela_plt in
+ (i+1,
+ (strtab_frag :: strtab_frags),
+ (symtab_frag :: symtab_frags),
+ (plt_frag :: plt_frags),
+ (got_plt_frag :: got_plt_frags),
+ (rela_plt_frag :: rela_plt_frags))
+ in
+
+ (* Emit text export symbols. *)
+ let (global_text_strtab_frags, global_text_symtab_frags) =
+ match htab_search sem.Semant.ctxt_native_provided SEG_text with
+ None -> ([], [])
+ | Some etab ->
+ Hashtbl.fold
+ begin
+ fun name fix x ->
+ let (strtab_frags, symtab_frags) = x in
+ let (str, sym) = text_sym name STB_GLOBAL fix in
+ (str :: strtab_frags,
+ sym :: symtab_frags)
+ end
+ etab
+ ([],[])
+ in
+
+ (* Emit text fragments (possibly named). *)
+ let (global_text_strtab_frags,
+ global_text_symtab_frags,
+ text_body_frags) =
+ Hashtbl.fold
+ (frags_of_symbol text_sym STB_GLOBAL)
+ text_frags
+ (global_text_strtab_frags, global_text_symtab_frags, [])
+ in
+
+ let (local_text_strtab_frags,
+ local_text_symtab_frags) =
+
+ let symbol_frags_of_code _ code accum =
+ let (strtab_frags, symtab_frags) = accum in
+ let fix = code.Semant.code_fixup in
+ let (strtab_frag, symtab_frag) =
+ text_sym fix.fixup_name STB_LOCAL fix
+ in
+ (strtab_frag :: strtab_frags,
+ symtab_frag :: symtab_frags)
+ in
+
+ let symbol_frags_of_glue_code g code accum =
+ let (strtab_frags, symtab_frags) = accum in
+ let fix = code.Semant.code_fixup in
+ let (strtab_frag, symtab_frag) =
+ text_sym (Semant.glue_str sem g) STB_LOCAL fix
+ in
+ (strtab_frag :: strtab_frags,
+ symtab_frag :: symtab_frags)
+ in
+
+ let item_str_frags, item_sym_frags =
+ Hashtbl.fold symbol_frags_of_code
+ sem.Semant.ctxt_all_item_code ([], [])
+ in
+ let glue_str_frags, glue_sym_frags =
+ Hashtbl.fold symbol_frags_of_glue_code
+ sem.Semant.ctxt_glue_code ([], [])
+ in
+ (item_str_frags @ glue_str_frags,
+ item_sym_frags @ glue_sym_frags)
+ in
+
+ (* Emit rodata export symbols. *)
+ let (rodata_strtab_frags, rodata_symtab_frags) =
+ match htab_search sem.Semant.ctxt_native_provided SEG_data with
+ None -> ([], [])
+ | Some etab ->
+ Hashtbl.fold
+ begin
+ fun name fix x ->
+ let (strtab_frags, symtab_frags) = x in
+ let (str, sym) = rodata_sym name STB_GLOBAL fix in
+ (str :: strtab_frags,
+ sym :: symtab_frags)
+ end
+ etab
+ ([],[])
+ in
+
+ (* Emit rodata fragments (possibly named). *)
+ let (rodata_strtab_frags,
+ rodata_symtab_frags,
+ rodata_body_frags) =
+ Hashtbl.fold
+ (frags_of_symbol rodata_sym STB_GLOBAL)
+ rodata_frags
+ (rodata_strtab_frags, rodata_symtab_frags, [])
+ in
+
+
+ let (data_strtab_frags,
+ data_symtab_frags,
+ data_body_frags) =
+ Hashtbl.fold (frags_of_symbol data_sym STB_GLOBAL) data_frags ([],[],[])
+ in
+
+ let (_,
+ require_strtab_frags,
+ require_symtab_frags,
+ plt_frags,
+ got_plt_frags,
+ rela_plt_frags) =
+ Hashtbl.fold (frags_of_require_symbol require_sym STB_GLOBAL)
+ required_fixups
+ (1,[],[],[plt0_frag],[got_prefix],[])
+ in
+ let require_symtab_frags = List.rev require_symtab_frags in
+ let plt_frags = List.rev plt_frags in
+ let got_plt_frags = List.rev got_plt_frags in
+ let rela_plt_frags = List.rev rela_plt_frags in
+
+ let dynamic_needed_strtab_frags =
+ Array.make (Array.length needed_libs) MARK
+ in
+
+ let dynamic_frags =
+ let dynamic_needed_frags = Array.make (Array.length needed_libs) MARK in
+ for i = 0 to (Array.length needed_libs) - 1 do
+ let fixup =
+ new_fixup ("needed library name fixup: " ^ needed_libs.(i))
+ in
+ dynamic_needed_frags.(i) <-
+ elf32_dyn_frag (DT_NEEDED, SUB (M_POS fixup,
+ M_POS dynstr_section_fixup));
+ dynamic_needed_strtab_frags.(i) <-
+ DEF (fixup, ZSTRING needed_libs.(i))
+ done;
+ (SEQ [|
+ SEQ dynamic_needed_frags;
+ elf32_dyn_frag (DT_STRTAB, M_POS dynstr_section_fixup);
+ elf32_dyn_frag (DT_STRSZ, M_SZ dynstr_section_fixup);
+
+ elf32_dyn_frag (DT_SYMTAB, M_POS dynsym_section_fixup);
+ elf32_dyn_frag (DT_SYMENT, IMM elf32_symsize);
+
+ elf32_dyn_frag (DT_HASH, M_POS hash_section_fixup);
+ elf32_dyn_frag (DT_PLTGOT, M_POS got_plt_section_fixup);
+
+ elf32_dyn_frag (DT_PLTREL, IMM (elf32_num_of_dyn_tag DT_RELA));
+ elf32_dyn_frag (DT_PLTRELSZ, M_SZ rela_plt_section_fixup);
+ elf32_dyn_frag (DT_JMPREL, M_POS rela_plt_section_fixup);
+
+ elf32_dyn_frag (DT_NULL, IMM 0L)
+ |])
+ in
+
+ let null_strtab_fixup = new_fixup "null dynstrtab entry" in
+ let null_strtab_frag = DEF (null_strtab_fixup, ZSTRING "") in
+ let null_symtab_frag = (symbol
+ ~string_table_fixup: dynstr_section_fixup
+ ~name_string_fixup: null_strtab_fixup
+ ~sym_target_fixup: None
+ ~st_bind: STB_LOCAL
+ ~st_type: STT_NOTYPE
+ ~st_shndx: 0L) in
+
+ let dynsym_frags = (null_symtab_frag ::
+ (require_symtab_frags @
+ global_text_symtab_frags @
+ local_text_symtab_frags @
+ rodata_symtab_frags @
+ data_symtab_frags))
+ in
+
+ let dynstr_frags = (null_strtab_frag ::
+ (require_strtab_frags @
+ global_text_strtab_frags @
+ local_text_strtab_frags @
+ rodata_strtab_frags @
+ data_strtab_frags @
+ (Array.to_list dynamic_needed_strtab_frags)))
+ in
+
+ let interp_section =
+ DEF (interp_section_fixup, ZSTRING "/lib/ld-linux.so.2")
+ in
+
+ let text_section =
+ DEF (text_section_fixup,
+ SEQ (Array.of_list text_body_frags))
+ in
+ let rodata_section =
+ DEF (rodata_section_fixup,
+ SEQ (Array.of_list rodata_body_frags))
+ in
+ let data_section =
+ DEF (data_section_fixup,
+ SEQ (Array.of_list data_body_frags))
+ in
+ let bss_section =
+ DEF (bss_section_fixup,
+ SEQ [| |])
+ in
+ let dynsym_section =
+ DEF (dynsym_section_fixup,
+ SEQ (Array.of_list dynsym_frags))
+ in
+ let dynstr_section =
+ DEF (dynstr_section_fixup,
+ SEQ (Array.of_list dynstr_frags))
+ in
+
+ let hash_section =
+ let n_syms = !n_syms in
+
+ DEF (hash_section_fixup,
+ (* Worst hashtable ever: one chain. *)
+ SEQ [|
+ WORD (TY_u32, IMM 1L); (* nbucket *)
+ WORD (TY_u32, (* nchain *)
+ IMM (Int64.of_int n_syms));
+ WORD (TY_u32, IMM 1L); (* bucket 0 => symbol 1. *)
+ SEQ
+ begin
+ Array.init
+ n_syms
+ (fun i ->
+ let next = (* chain[i] => if last then 0 else i+1 *)
+ if i > 0 && i < (n_syms-1)
+ then Int64.of_int (i+1)
+ else 0L
+ in
+ WORD (TY_u32, IMM next))
+ end;
+ |])
+ in
+
+ let plt_section =
+ DEF (plt_section_fixup,
+ SEQ (Array.of_list plt_frags))
+ in
+
+ let got_plt_section =
+ DEF (got_plt_section_fixup,
+ SEQ (Array.of_list got_plt_frags))
+ in
+
+ let rela_plt_section =
+ DEF (rela_plt_section_fixup,
+ SEQ (Array.of_list rela_plt_frags))
+ in
+
+ let dynamic_section =
+ DEF (dynamic_section_fixup, dynamic_frags)
+ in
+
+ let note_rust_section =
+ DEF (note_rust_section_fixup,
+ (Asm.note_rust_frags crate.node.Ast.crate_meta))
+ in
+
+
+ let page_alignment = 0x1000 in
+
+ let align_both i =
+ ALIGN_FILE (page_alignment,
+ (ALIGN_MEM (page_alignment, i)))
+ in
+
+ let def_aligned f i =
+ align_both
+ (SEQ [| DEF(f,i);
+ (align_both MARK)|])
+ in
+
+ let debug_aranges_section =
+ def_aligned
+ sem.Semant.ctxt_debug_aranges_fixup
+ dwarf.Dwarf.debug_aranges
+ in
+ let debug_pubnames_section =
+ def_aligned
+ sem.Semant.ctxt_debug_pubnames_fixup
+ dwarf.Dwarf.debug_pubnames
+ in
+ let debug_info_section =
+ def_aligned
+ sem.Semant.ctxt_debug_info_fixup
+ dwarf.Dwarf.debug_info
+ in
+ let debug_abbrev_section =
+ def_aligned
+ sem.Semant.ctxt_debug_abbrev_fixup
+ dwarf.Dwarf.debug_abbrev
+ in
+ let debug_line_section =
+ def_aligned
+ sem.Semant.ctxt_debug_line_fixup
+ dwarf.Dwarf.debug_line
+ in
+ let debug_frame_section =
+ def_aligned sem.Semant.ctxt_debug_frame_fixup dwarf.Dwarf.debug_frame
+ in
+
+ let load_address = 0x0804_8000L in
+
+ SEQ
+ [|
+ MEMPOS load_address;
+ ALIGN_FILE
+ (segment_2_align,
+ DEF
+ (segment_2_fixup,
+ SEQ
+ [|
+ DEF (sem.Semant.ctxt_image_base_fixup, MARK);
+ elf_header;
+ ALIGN_FILE
+ (segment_0_align,
+ DEF
+ (segment_0_fixup,
+ SEQ
+ [|
+ DEF (program_header_table_fixup,
+ program_header_table);
+ |]));
+ ALIGN_FILE
+ (segment_1_align,
+ DEF (segment_1_fixup, interp_section));
+ text_section;
+ rodata_section;
+ dynsym_section;
+ dynstr_section;
+ hash_section;
+ plt_section;
+ rela_plt_section;
+ debug_aranges_section;
+ debug_pubnames_section;
+ debug_info_section;
+ debug_abbrev_section;
+ debug_line_section;
+ debug_frame_section;
+ |]));
+ ALIGN_FILE
+ (segment_3_align,
+ DEF
+ (segment_3_fixup,
+ SEQ
+ [|
+ data_section;
+ got_plt_section;
+ bss_section;
+ ALIGN_FILE
+ (segment_4_align,
+ DEF (segment_4_fixup,
+ dynamic_section));
+ ALIGN_FILE
+ (segment_5_align,
+ DEF (segment_5_fixup,
+ note_rust_section));
+ |]));
+ DEF (shstrtab_section_fixup,
+ shstrtab_section);
+ DEF (section_header_table_fixup,
+ section_header_table);
+ |]
+;;
+
+let emit_file
+ (sess:Session.sess)
+ (crate:Ast.crate)
+ (code:Asm.frag)
+ (data:Asm.frag)
+ (sem:Semant.ctxt)
+ (dwarf:Dwarf.debug_records)
+ : unit =
+
+ let text_frags = Hashtbl.create 4 in
+ let rodata_frags = Hashtbl.create 4 in
+ let data_frags = Hashtbl.create 4 in
+ let required_fixups = Hashtbl.create 4 in
+
+ (*
+ * Startup on elf-linux is more complex than in win32. It's
+ * thankfully documented in some detail around the net.
+ *
+ * - The elf entry address is for _start.
+ *
+ * - _start pushes:
+ *
+ * eax (should be zero)
+ * esp (holding the kernel-provided stack end)
+ * edx (address of _rtld_fini)
+ * address of _fini
+ * address of _init
+ * ecx (argv)
+ * esi (argc)
+ * address of main
+ *
+ * and then calls __libc_start_main@plt.
+ *
+ * - This means any sensible binary has a PLT. Fun. So
+ * We call into the PLT, which itself is just a bunch
+ * of indirect jumps through slots in the GOT, and wind
+ * up in __libc_start_main. Which calls _init, then
+ * essentially exit(main(argc,argv)).
+ *)
+
+
+ let init_fixup = new_fixup "_init function entry" in
+ let fini_fixup = new_fixup "_fini function entry" in
+ let (start_fixup, rust_start_fixup) =
+ if sess.Session.sess_library_mode
+ then (None, None)
+ else (Some (new_fixup "start function entry"),
+ Some (Semant.require_native sem REQUIRED_LIB_rustrt "rust_start"))
+ in
+ let libc_start_main_fixup = new_fixup "__libc_start_main@plt stub" in
+
+ let start_fn _ =
+ let start_fixup =
+ match start_fixup with
+ None -> bug () "missing start fixup in non-library mode"
+ | Some s -> s
+ in
+ let e = X86.new_emitter_without_vregs () in
+ let push_r32 r = Il.emit e
+ (Il.Push (Il.Cell (Il.Reg (Il.Hreg r, Il.ValTy Il.Bits32))))
+ in
+ let push_pos32 = X86.push_pos32 e in
+
+ Il.emit e (Il.unary Il.UMOV (X86.rc X86.ebp) (X86.immi 0L));
+ Il.emit e (Il.Pop (X86.rc X86.esi));
+ Il.emit e (Il.unary Il.UMOV (X86.rc X86.ecx) (X86.ro X86.esp));
+ Il.emit e (Il.binary Il.AND
+ (X86.rc X86.esp) (X86.ro X86.esp)
+ (X86.immi 0xfffffffffffffff0L));
+
+ push_r32 X86.eax;
+ push_r32 X86.esp;
+ push_r32 X86.edx;
+ push_pos32 fini_fixup;
+ push_pos32 init_fixup;
+ push_r32 X86.ecx;
+ push_r32 X86.esi;
+ push_pos32 start_fixup;
+ Il.emit e (Il.call
+ (Il.Reg (Il.Hreg X86.eax, Il.ValTy Il.Bits32))
+ (Il.direct_code_ptr libc_start_main_fixup));
+ X86.frags_of_emitted_quads sess e
+ in
+
+ let do_nothing_fn _ =
+ let e = X86.new_emitter_without_vregs () in
+ Il.emit e Il.Ret;
+ X86.frags_of_emitted_quads sess e
+ in
+
+ let main_fn _ =
+ match (start_fixup, rust_start_fixup, sem.Semant.ctxt_main_fn_fixup) with
+ (None, _, _)
+ | (_, None, _)
+ | (_, _, None) -> MARK
+ | (Some start_fixup,
+ Some rust_start_fixup,
+ Some main_fn_fixup) ->
+ let e = X86.new_emitter_without_vregs () in
+ X86.objfile_start e
+ ~start_fixup
+ ~rust_start_fixup
+ ~main_fn_fixup
+ ~crate_fixup: sem.Semant.ctxt_crate_fixup
+ ~indirect_start: false;
+ X86.frags_of_emitted_quads sess e
+ in
+
+ let needed_libs =
+ [|
+ "libc.so.6";
+ "librustrt.so"
+ |]
+ in
+
+ let _ =
+ if not sess.Session.sess_library_mode
+ then
+ begin
+ htab_put text_frags (Some "_start") (start_fn());
+ htab_put text_frags (Some "_init")
+ (DEF (init_fixup, do_nothing_fn()));
+ htab_put text_frags (Some "_fini")
+ (DEF (fini_fixup, do_nothing_fn()));
+ htab_put text_frags (Some "main") (main_fn ());
+ htab_put required_fixups "__libc_start_main" libc_start_main_fixup;
+ end;
+ htab_put text_frags None code;
+ htab_put rodata_frags None data;
+
+ Hashtbl.iter
+ begin
+ fun _ tab ->
+ Hashtbl.iter
+ begin
+ fun name fixup ->
+ htab_put required_fixups name fixup
+ end
+ tab
+ end
+ sem.Semant.ctxt_native_required
+ in
+ let all_frags =
+ elf32_linux_x86_file
+ ~sess
+ ~crate
+ ~entry_name: "_start"
+ ~text_frags
+ ~data_frags
+ ~dwarf
+ ~sem
+ ~rodata_frags
+ ~required_fixups
+ ~needed_libs
+ in
+ write_out_frag sess true all_frags
+;;
+
+let elf_magic = "\x7fELF";;
+
+let sniff
+ (sess:Session.sess)
+ (filename:filename)
+ : asm_reader option =
+ try
+ let stat = Unix.stat filename in
+ if (stat.Unix.st_kind = Unix.S_REG) &&
+ (stat.Unix.st_size > 4)
+ then
+ let ar = new_asm_reader sess filename in
+ let _ = log sess "sniffing ELF file" in
+ if (ar.asm_get_zstr_padded 4) = elf_magic
+ then (ar.asm_seek 0; Some ar)
+ else None
+ else
+ None
+ with
+ _ -> None
+;;
+
+let get_sections
+ (sess:Session.sess)
+ (ar:asm_reader)
+ : (string,(int*int)) Hashtbl.t =
+ let sects = Hashtbl.create 0 in
+ let _ = log sess "reading sections" in
+ let elf_id = ar.asm_get_zstr_padded 4 in
+ let _ = assert (elf_id = elf_magic) in
+
+ let _ = ar.asm_seek 0x10 in
+ let _ = ar.asm_adv_u16 () in (* e_type *)
+ let _ = ar.asm_adv_u16 () in (* e_machine *)
+ let _ = ar.asm_adv_u32 () in (* e_version *)
+ let _ = ar.asm_adv_u32 () in (* e_entry *)
+ let _ = ar.asm_adv_u32 () in (* e_phoff *)
+ let e_shoff = ar.asm_get_u32 () in (* e_shoff *)
+ let _ = ar.asm_adv_u32 () in (* e_flags *)
+ let _ = ar.asm_adv_u16 () in (* e_ehsize *)
+ let _ = ar.asm_adv_u16 () in (* e_phentsize *)
+ let _ = ar.asm_adv_u16 () in (* e_phnum *)
+ let e_shentsize = ar.asm_get_u16 () in
+ let e_shnum = ar.asm_get_u16 () in
+ let e_shstrndx = ar.asm_get_u16 () in
+ let _ = log sess
+ "%d ELF section headers, %d bytes each, starting at 0x%x"
+ e_shnum e_shentsize e_shoff
+ in
+ let _ = log sess "section %d is .shstrtab" e_shstrndx in
+
+ let read_section_hdr n =
+ let _ = ar.asm_seek (e_shoff + n * e_shentsize) in
+ let str_off = ar.asm_get_u32() in
+ let _ = ar.asm_adv_u32() in (* sh_type *)
+ let _ = ar.asm_adv_u32() in (* sh_flags *)
+ let _ = ar.asm_adv_u32() in (* sh_addr *)
+ let off = ar.asm_get_u32() in (* sh_off *)
+ let size = ar.asm_get_u32() in (* sh_size *)
+ let _ = ar.asm_adv_u32() in (* sh_link *)
+ let _ = ar.asm_adv_u32() in (* sh_info *)
+ let _ = ar.asm_adv_u32() in (* sh_addralign *)
+ let _ = ar.asm_adv_u32() in (* sh_entsize *)
+ (str_off, off, size)
+ in
+
+ let (_, str_base, _) = read_section_hdr e_shstrndx in
+
+ let _ = ar.asm_seek e_shoff in
+ for i = 0 to (e_shnum - 1) do
+ let (str_off, off, size) = read_section_hdr i in
+ let _ = ar.asm_seek (str_base + str_off) in
+ let name = ar.asm_get_zstr() in
+ log sess "section %d: %s, size %d, offset 0x%x" i name size off;
+ Hashtbl.add sects name (off, size);
+ done;
+ sects
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+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 to spill slot"
+;;
+
+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_implicits: label list;
+ 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 rec string_of_expr64 (e64:Asm.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
+ Asm.IMM i when (i64_lt i 0L) -> Printf.sprintf "-0x%Lx" (Int64.neg i)
+ | Asm.IMM i -> Printf.sprintf "0x%Lx" i
+ | Asm.ADD (a,b) -> bin "+" a b
+ | Asm.SUB (a,b) -> bin "-" a b
+ | Asm.MUL (a,b) -> bin "*" a b
+ | Asm.DIV (a,b) -> bin "/" a b
+ | Asm.REM (a,b) -> bin "%" a b
+ | Asm.MAX (a,b) ->
+ Printf.sprintf "(max %s %s)"
+ (string_of_expr64 a) (string_of_expr64 b)
+ | Asm.ALIGN (a,b) ->
+ Printf.sprintf "(align %s %s)"
+ (string_of_expr64 a) (string_of_expr64 b)
+ | Asm.SLL (a,b) -> bini "<<" a b
+ | Asm.SLR (a,b) -> bini ">>" a b
+ | Asm.SAR (a,b) -> bini ">>>" a b
+ | Asm.AND (a,b) -> bin "&" a b
+ | Asm.XOR (a,b) -> bin "xor" a b
+ | Asm.OR (a,b) -> bin "|" a b
+ | Asm.NOT a -> Printf.sprintf "(not %s)" (string_of_expr64 a)
+ | Asm.NEG a -> Printf.sprintf "-%s" (string_of_expr64 a)
+ | Asm.F_POS f -> Printf.sprintf "<%s>.fpos" f.fixup_name
+ | Asm.F_SZ f -> Printf.sprintf "<%s>.fsz" f.fixup_name
+ | Asm.M_POS f -> Printf.sprintf "<%s>.mpos" f.fixup_name
+ | Asm.M_SZ f -> Printf.sprintf "<%s>.msz" f.fixup_name
+ | Asm.EXT _ -> "??ext??"
+;;
+
+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' -> " + " ^ (string_of_expr64 e')
+;;
+
+let string_of_mem (f:hreg_formatter) (a:mem) : string =
+ match a with
+ Abs e ->
+ Printf.sprintf "[%s]" (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" (string_of_expr64 i) (string_of_ty_mach ty)
+ else
+ Printf.sprintf "$%s" (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_preallocator: (quad' -> quad');
+ emit_is_2addr: bool;
+ mutable emit_quads: quads;
+ emit_annotations: (int,string) Hashtbl.t;
+ emit_size_cache: ((size,operand) Hashtbl.t) Stack.t;
+ emit_node: node_id option;
+ }
+
+
+let badq = { quad_fixup = None;
+ quad_implicits = [];
+ quad_body = End }
+;;
+
+
+let deadq = { quad_fixup = None;
+ quad_implicits = [];
+ quad_body = Dead }
+;;
+
+
+let new_emitter
+ (preallocator:quad' -> quad')
+ (is_2addr:bool)
+ (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_preallocator = preallocator;
+ emit_is_2addr = is_2addr;
+ emit_quads = Array.create 4 badq;
+ emit_annotations = Hashtbl.create 0;
+ emit_size_cache = Stack.create ();
+ 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 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_implicits = [];
+ quad_fixup = None }
+;;
+
+let emit_full
+ (e:emitter)
+ (fix:fixup option)
+ (implicits:label list)
+ (q':quad')
+ : unit =
+ let fixup = ref fix in
+ let emit_quad_bottom q' =
+ grow_if_necessary e;
+ e.emit_quads.(e.emit_pc) <- { quad_body = q';
+ quad_implicits = implicits;
+ quad_fixup = (!fixup) };
+ fixup := None;
+ e.emit_pc <- e.emit_pc + 1
+ in
+
+ let emit_quad (q':quad') : unit =
+ (* re-decay any freshly generated mem-mem movs. *)
+ match q' with
+ Unary { unary_dst = Mem (dst_mem, ScalarTy src_st);
+ unary_src = Cell (Mem (src_mem, ScalarTy dst_st));
+ unary_op = op }
+ when is_mov op ->
+ let v = next_vreg_cell e dst_st in
+ emit_quad_bottom
+ (unary op v (Cell (Mem (src_mem, ScalarTy src_st))));
+ emit_quad_bottom
+ (unary op (Mem (dst_mem, ScalarTy dst_st)) (Cell v))
+ | _ -> emit_quad_bottom q'
+ in
+
+ let default_mov =
+ 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
+ in
+
+ let emit_mov (dst:cell) (src:operand) : unit =
+ emit_quad (unary default_mov dst src)
+ in
+
+ let mov_if_operands_differ
+ (old_op:operand) (new_op:operand)
+ : unit =
+ if (new_op <> old_op)
+ then
+ match new_op with
+ (Cell new_cell) ->
+ emit_mov new_cell old_op
+ | _ -> ()
+ in
+
+ let mov_if_two_operands_differ
+ (old_lhs_op:operand) (new_lhs_op:operand)
+ (old_rhs_op:operand) (new_rhs_op:operand)
+ : unit =
+ (*
+ * This is sufficiently obscure that it deserves an explanation.
+ *
+ * The main idea here is to do two "mov_if_operands_differ" calls,
+ * such as one might have when setting up a binary quad.
+ *
+ * The problem comes when you happen to hit a case like X86 div,
+ * which preallocates *both* operands. Preallocating both means we
+ * have to potentially issue two movs into the preallocated regs,
+ * and the second of those movs might be a problem. Specifically:
+ * the second mov-to-prealloc might make be moving from a
+ * register-indirect mem cell based on a vreg, and that vreg may
+ * wind up being assigned to an hreg that we just loaded with the
+ * first mov. In other words, the second mov may retask the
+ * preallocated hreg we set up in the first mov.
+ *
+ * You laugh, but of course this actually happens.
+ *
+ * So here we do a conservative thing and check to see if either
+ * operand is memory-indirect at all. If either is, then for either
+ * of the 'old' operands we're *about* to mov into a prealloc reg,
+ * we first bounce them off a spill slot. Spill slots, thankfully,
+ * we can always count on being able to address irrespective of the
+ * opinions of the RA, as they are all just fp-relative.
+ *
+ * A slightly more aggressive version of this would only bounce
+ * cases that are not fp-relative already, though doing so would
+ * require threading the notion of what fp *is* through to
+ * here. Possibly tighten this up in the future (or just
+ * ... destroy this backend ASAP).
+ *
+ *)
+ let has_reg_indirect op =
+ match op with
+ Cell (Mem _) -> true
+ | _ -> false
+ in
+ let either_old_op_has_reg_indirect =
+ (has_reg_indirect old_lhs_op) || (has_reg_indirect old_rhs_op)
+ in
+ let old_lhs_op =
+ if either_old_op_has_reg_indirect && (new_lhs_op <> old_lhs_op)
+ then
+ let tmp =
+ Mem (next_spill_slot e
+ (ScalarTy (operand_scalar_ty old_lhs_op)))
+ in
+ emit_mov tmp old_lhs_op;
+ Cell tmp
+ else
+ old_lhs_op
+ in
+ let old_rhs_op =
+ if either_old_op_has_reg_indirect && (new_rhs_op <> old_rhs_op)
+ then
+ let tmp =
+ Mem (next_spill_slot e
+ (ScalarTy (operand_scalar_ty old_rhs_op)))
+ in
+ emit_mov tmp old_rhs_op;
+ Cell tmp
+ else
+ old_rhs_op
+ in
+ mov_if_operands_differ old_lhs_op new_lhs_op;
+ mov_if_operands_differ old_rhs_op new_rhs_op;
+ in
+
+ let mov_if_cells_differ (old_cell:cell) (new_cell:cell) : unit =
+ if not (new_cell = old_cell)
+ then
+ emit_mov old_cell (Cell new_cell)
+ in
+
+ let emit_decayed_quad q' =
+ match (q', e.emit_preallocator q') with
+ (Binary b, Binary b') ->
+ begin
+ mov_if_two_operands_differ
+ b.binary_lhs b'.binary_lhs
+ b.binary_rhs b'.binary_rhs;
+ if e.emit_is_2addr &&
+ (not (b'.binary_lhs = (Cell b'.binary_dst)))
+ then
+ begin
+ emit_mov b'.binary_dst b'.binary_lhs;
+ emit_quad (Binary { b' with
+ binary_lhs = (Cell b'.binary_dst) })
+ end
+ else
+ emit_quad (Binary b');
+ mov_if_cells_differ b.binary_dst b'.binary_dst
+ end
+
+ | (Unary u, Unary u') ->
+ mov_if_operands_differ u.unary_src u'.unary_src;
+ (* Assume '2addr' means '1addr' for unary ops. *)
+ if e.emit_is_2addr &&
+ (u'.unary_op = NEG || u'.unary_op = NOT) &&
+ (not (u'.unary_src = (Cell u'.unary_dst)))
+ then
+ begin
+ emit_mov u'.unary_dst u'.unary_src;
+ emit_quad (Unary { u' with unary_src = (Cell u'.unary_dst) })
+ end
+ else
+ emit_quad (Unary u');
+ mov_if_cells_differ u.unary_dst u'.unary_dst
+
+ | (Cmp c, Cmp c') ->
+ mov_if_two_operands_differ
+ c.cmp_lhs c'.cmp_lhs
+ c.cmp_rhs c'.cmp_rhs;
+ emit_quad (Cmp c');
+
+ | (Push op, Push op') ->
+ mov_if_operands_differ op op';
+ emit_quad (Push op');
+
+ | (Pop c, Pop c') ->
+ emit_quad (Pop c');
+ mov_if_cells_differ c c'
+
+ | (Call c, Call c') ->
+ emit_quad (Call c');
+ mov_if_cells_differ c.call_dst c'.call_dst
+
+ | (Lea lea, Lea lea') ->
+ emit_quad (Lea lea');
+ mov_if_cells_differ lea.lea_dst lea'.lea_dst
+
+ | (x, y) ->
+ assert (x = y);
+ emit_quad x
+ in
+
+ (* pre-decay mem-mem movs. *)
+ match q' with
+ Unary { unary_dst = Mem (dst_mem, ScalarTy src_st);
+ unary_src = Cell (Mem (src_mem, ScalarTy dst_st));
+ unary_op = op }
+ when is_mov op ->
+ let v = next_vreg_cell e dst_st in
+ emit_decayed_quad
+ (unary op v (Cell (Mem (src_mem, ScalarTy src_st))));
+ emit_decayed_quad
+ (unary op (Mem (dst_mem, ScalarTy dst_st)) (Cell v))
+ | _ -> emit_decayed_quad q'
+;;
+
+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)
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+open Asm;;
+open Common;;
+
+(* Mach-O writer. *)
+
+let log (sess:Session.sess) =
+ Session.log "obj (mach-o)"
+ sess.Session.sess_log_obj
+ sess.Session.sess_log_out
+;;
+
+let iflog (sess:Session.sess) (thunk:(unit -> unit)) : unit =
+ if sess.Session.sess_log_obj
+ then thunk ()
+ else ()
+;;
+
+let (cpu_arch_abi64:int64) = 0x01000000L
+;;
+
+let (mh_magic:int64) = 0xfeedfaceL
+;;
+
+let cpu_subtype_intel (f:int64) (m:int64) : int64 =
+ Int64.add f (Int64.shift_left m 4)
+;;
+
+type cpu_type =
+ (* Maybe support more later. *)
+ CPU_TYPE_X86
+ | CPU_TYPE_X86_64
+ | CPU_TYPE_ARM
+ | CPU_TYPE_POWERPC
+;;
+
+type cpu_subtype =
+ (* Maybe support more later. *)
+ CPU_SUBTYPE_X86_ALL
+ | CPU_SUBTYPE_X86_64_ALL
+ | CPU_SUBTYPE_ARM_ALL
+ | CPU_SUBTYPE_POWERPC_ALL
+;;
+
+type file_type =
+ MH_OBJECT
+ | MH_EXECUTE
+ | MH_FVMLIB
+ | MH_CORE
+ | MH_PRELOAD
+ | MH_DYLIB
+ | MH_DYLINKER
+ | MH_BUNDLE
+ | MH_DYLIB_STUB
+ | MH_DSYM
+;;
+
+let file_type_code (ft:file_type) : int64 =
+ match ft with
+ MH_OBJECT ->0x1L (* object *)
+ | MH_EXECUTE -> 0x2L (* executable *)
+ | MH_FVMLIB -> 0x3L (* fixed-VM shared lib *)
+ | MH_CORE -> 0x4L (* core *)
+ | MH_PRELOAD -> 0x5L (* preloaded executable *)
+ | MH_DYLIB -> 0x6L (* dynamic lib *)
+ | MH_DYLINKER -> 0x7L (* dynamic linker *)
+ | MH_BUNDLE -> 0x8L (* bundle *)
+ | MH_DYLIB_STUB -> 0x9L (* shared lib stub *)
+ | MH_DSYM -> 0xaL (* debuginfo only *)
+;;
+
+type file_flag =
+ MH_NOUNDEFS
+ | MH_INCRLINK
+ | MH_DYLDLINK
+ | MH_BINDATLOAD
+ | MH_PREBOUND
+ | MH_SPLIT_SEGS
+ | MH_LAZY_INIT
+ | MH_TWOLEVEL
+ | MH_FORCE_FLAT
+ | MH_NOMULTIDEFS
+ | MH_NOFIXPREBINDING
+ | MH_PREBINDABLE
+ | MH_ALLMODSBOUND
+ | MH_SUBSECTIONS_VIA_SYMBOLS
+ | MH_CANONICAL
+ | MH_WEAK_DEFINES
+ | MH_BINDS_TO_WEAK
+ | MH_ALLOW_STACK_EXECUTION
+ | MH_ROOT_SAFE
+ | MH_SETUID_SAFE
+ | MH_NO_REEXPORTED_DYLIBS
+ | MH_PIE
+;;
+
+let file_flag_code (ff:file_flag) : int64 =
+ match ff with
+ MH_NOUNDEFS -> 0x1L
+ | MH_INCRLINK -> 0x2L
+ | MH_DYLDLINK -> 0x4L
+ | MH_BINDATLOAD -> 0x8L
+ | MH_PREBOUND -> 0x10L
+ | MH_SPLIT_SEGS -> 0x20L
+ | MH_LAZY_INIT -> 0x40L
+ | MH_TWOLEVEL -> 0x80L
+ | MH_FORCE_FLAT -> 0x100L
+ | MH_NOMULTIDEFS -> 0x200L
+ | MH_NOFIXPREBINDING -> 0x400L
+ | MH_PREBINDABLE -> 0x800L
+ | MH_ALLMODSBOUND -> 0x1000L
+ | MH_SUBSECTIONS_VIA_SYMBOLS -> 0x2000L
+ | MH_CANONICAL -> 0x4000L
+ | MH_WEAK_DEFINES -> 0x8000L
+ | MH_BINDS_TO_WEAK -> 0x10000L
+ | MH_ALLOW_STACK_EXECUTION -> 0x20000L
+ | MH_ROOT_SAFE -> 0x40000L
+ | MH_SETUID_SAFE -> 0x80000L
+ | MH_NO_REEXPORTED_DYLIBS -> 0x100000L
+ | MH_PIE -> 0x200000L
+;;
+
+
+type vm_prot =
+ VM_PROT_NONE
+ | VM_PROT_READ
+ | VM_PROT_WRITE
+ | VM_PROT_EXECUTE
+;;
+
+
+type load_command =
+ LC_SEGMENT
+ | LC_SYMTAB
+ | LC_SYMSEG
+ | LC_THREAD
+ | LC_UNIXTHREAD
+ | LC_LOADFVMLIB
+ | LC_IDFVMLIB
+ | LC_IDENT
+ | LC_FVMFILE
+ | LC_PREPAGE
+ | LC_DYSYMTAB
+ | LC_LOAD_DYLIB
+ | LC_ID_DYLIB
+ | LC_LOAD_DYLINKER
+ | LC_ID_DYLINKER
+ | LC_PREBOUND_DYLIB
+ | LC_ROUTINES
+ | LC_SUB_FRAMEWORK
+ | LC_SUB_UMBRELLA
+ | LC_SUB_CLIENT
+ | LC_SUB_LIBRARY
+ | LC_TWOLEVEL_HINTS
+ | LC_PREBIND_CKSUM
+ | LC_LOAD_WEAK_DYLIB
+ | LC_SEGMENT_64
+ | LC_ROUTINES_64
+ | LC_UUID
+ | LC_RPATH
+ | LC_CODE_SIGNATURE
+ | LC_SEGMENT_SPLIT_INFO
+ | LC_REEXPORT_DYLIB
+ | LC_LAZY_LOAD_DYLIB
+ | LC_ENCRYPTION_INFO
+;;
+
+
+let cpu_type_code (cpu:cpu_type) : int64 =
+ match cpu with
+ CPU_TYPE_X86 -> 7L
+ | CPU_TYPE_X86_64 -> Int64.logor 7L cpu_arch_abi64
+ | CPU_TYPE_ARM -> 12L
+ | CPU_TYPE_POWERPC -> 18L
+;;
+
+let cpu_subtype_code (cpu:cpu_subtype) : int64 =
+ match cpu with
+ CPU_SUBTYPE_X86_ALL -> 3L
+ | CPU_SUBTYPE_X86_64_ALL -> 3L
+ | CPU_SUBTYPE_ARM_ALL -> 0L
+ | CPU_SUBTYPE_POWERPC_ALL -> 0L
+;;
+
+
+let vm_prot_code (vmp:vm_prot) : int64 =
+ match vmp with
+ VM_PROT_NONE -> 0L
+ | VM_PROT_READ -> 1L
+ | VM_PROT_WRITE -> 2L
+ | VM_PROT_EXECUTE -> 4L
+;;
+
+
+let lc_req_dyld = 0x80000000L;;
+
+let load_command_code (lc:load_command) =
+ match lc with
+ | LC_SEGMENT -> 0x1L
+ | LC_SYMTAB -> 0x2L
+ | LC_SYMSEG -> 0x3L
+ | LC_THREAD -> 0x4L
+ | LC_UNIXTHREAD -> 0x5L
+ | LC_LOADFVMLIB -> 0x6L
+ | LC_IDFVMLIB -> 0x7L
+ | LC_IDENT -> 0x8L
+ | LC_FVMFILE -> 0x9L
+ | LC_PREPAGE -> 0xaL
+ | LC_DYSYMTAB -> 0xbL
+ | LC_LOAD_DYLIB -> 0xcL
+ | LC_ID_DYLIB -> 0xdL
+ | LC_LOAD_DYLINKER -> 0xeL
+ | LC_ID_DYLINKER -> 0xfL
+ | LC_PREBOUND_DYLIB -> 0x10L
+ | LC_ROUTINES -> 0x11L
+ | LC_SUB_FRAMEWORK -> 0x12L
+ | LC_SUB_UMBRELLA -> 0x13L
+ | LC_SUB_CLIENT -> 0x14L
+ | LC_SUB_LIBRARY -> 0x15L
+ | LC_TWOLEVEL_HINTS -> 0x16L
+ | LC_PREBIND_CKSUM -> 0x17L
+ | LC_LOAD_WEAK_DYLIB -> Int64.logor lc_req_dyld 0x18L
+ | LC_SEGMENT_64 -> 0x19L
+ | LC_ROUTINES_64 -> 0x1aL
+ | LC_UUID -> 0x1bL
+ | LC_RPATH -> Int64.logor lc_req_dyld 0x1cL
+ | LC_CODE_SIGNATURE -> 0x1dL
+ | LC_SEGMENT_SPLIT_INFO -> 0x1eL
+ | LC_REEXPORT_DYLIB -> Int64.logor lc_req_dyld 0x1fL
+ | LC_LAZY_LOAD_DYLIB -> 0x20L
+ | LC_ENCRYPTION_INFO -> 0x21L
+;;
+
+
+let fixed_sz_string (sz:int) (str:string) : frag =
+ if String.length str > sz
+ then STRING (String.sub str 0 sz)
+ else SEQ [| STRING str; PAD (sz - (String.length str)) |]
+;;
+
+type sect_type =
+ S_REGULAR
+ | S_ZEROFILL
+ | S_CSTRING_LITERALS
+ | S_4BYTE_LITERALS
+ | S_8BYTE_LITERALS
+ | S_LITERAL_POINTERS
+ | S_NON_LAZY_SYMBOL_POINTERS
+ | S_LAZY_SYMBOL_POINTERS
+ | S_SYMBOL_STUBS
+ | S_MOD_INIT_FUNC_POINTERS
+ | S_MOD_TERM_FUNC_POINTERS
+ | S_COALESCED
+ | S_GB_ZEROFILL
+ | S_INTERPOSING
+ | S_16BYTE_LITERALS
+ | S_DTRACE_DOF
+ | S_LAZY_DYLIB_SYMBOL_POINTERS
+;;
+
+let sect_type_code (s:sect_type) : int64 =
+ match s with
+ S_REGULAR -> 0x0L
+ | S_ZEROFILL -> 0x1L
+ | S_CSTRING_LITERALS -> 0x2L
+ | S_4BYTE_LITERALS -> 0x3L
+ | S_8BYTE_LITERALS -> 0x4L
+ | S_LITERAL_POINTERS -> 0x5L
+ | S_NON_LAZY_SYMBOL_POINTERS -> 0x6L
+ | S_LAZY_SYMBOL_POINTERS -> 0x7L
+ | S_SYMBOL_STUBS -> 0x8L
+ | S_MOD_INIT_FUNC_POINTERS -> 0x9L
+ | S_MOD_TERM_FUNC_POINTERS -> 0xaL
+ | S_COALESCED -> 0xbL
+ | S_GB_ZEROFILL -> 0xcL
+ | S_INTERPOSING -> 0xdL
+ | S_16BYTE_LITERALS -> 0xeL
+ | S_DTRACE_DOF -> 0xfL
+ | S_LAZY_DYLIB_SYMBOL_POINTERS -> 0x10L
+;;
+
+type sect_attr =
+ S_ATTR_PURE_INSTRUCTIONS
+ | S_ATTR_NO_TOC
+ | S_ATTR_STRIP_STATIC_SYMS
+ | S_ATTR_NO_DEAD_STRIP
+ | S_ATTR_LIVE_SUPPORT
+ | S_ATTR_SELF_MODIFYING_CODE
+ | S_ATTR_DEBUG
+ | S_ATTR_SOME_INSTRUCTIONS
+ | S_ATTR_EXT_RELOC
+ | S_ATTR_LOC_RELOC
+;;
+
+let sect_attr_code (s:sect_attr) : int64 =
+ match s with
+ S_ATTR_PURE_INSTRUCTIONS -> 0x80000000L
+ | S_ATTR_NO_TOC -> 0x40000000L
+ | S_ATTR_STRIP_STATIC_SYMS -> 0x20000000L
+ | S_ATTR_NO_DEAD_STRIP -> 0x10000000L
+ | S_ATTR_LIVE_SUPPORT -> 0x08000000L
+ | S_ATTR_SELF_MODIFYING_CODE -> 0x04000000L
+ | S_ATTR_DEBUG -> 0x02000000L
+ | S_ATTR_SOME_INSTRUCTIONS -> 0x00000400L
+ | S_ATTR_EXT_RELOC -> 0x00000200L
+ | S_ATTR_LOC_RELOC -> 0x00000100L
+;;
+
+type n_type =
+ | N_EXT
+ | N_UNDF
+ | N_ABS
+ | N_SECT
+ | N_PBUD
+ | N_INDIR
+;;
+
+let n_type_code (n:n_type) : int64 =
+ match n with
+ N_EXT -> 0x1L
+ | N_UNDF -> 0x0L
+ | N_ABS -> 0x2L
+ | N_SECT -> 0xeL
+ | N_PBUD -> 0xcL
+ | N_INDIR -> 0xaL
+;;
+
+
+type n_desc_reference_type =
+ REFERENCE_FLAG_UNDEFINED_NON_LAZY
+ | REFERENCE_FLAG_UNDEFINED_LAZY
+ | REFERENCE_FLAG_DEFINED
+ | REFERENCE_FLAG_PRIVATE_DEFINED
+ | REFERENCE_FLAG_PRIVATE_UNDEFINED_NON_LAZY
+ | REFERENCE_FLAG_PRIVATE_UNDEFINED_LAZY
+;;
+
+let n_desc_reference_type_code (n:n_desc_reference_type) : int64 =
+ match n with
+ REFERENCE_FLAG_UNDEFINED_NON_LAZY -> 0x0L
+ | REFERENCE_FLAG_UNDEFINED_LAZY -> 0x1L
+ | REFERENCE_FLAG_DEFINED -> 0x2L
+ | REFERENCE_FLAG_PRIVATE_DEFINED -> 0x3L
+ | REFERENCE_FLAG_PRIVATE_UNDEFINED_NON_LAZY -> 0x4L
+ | REFERENCE_FLAG_PRIVATE_UNDEFINED_LAZY -> 0x5L
+;;
+
+type n_desc_flags =
+ REFERENCED_DYNAMICALLY
+ | N_DESC_DISCARDED
+ | N_NO_DEAD_STRIP
+ | N_WEAK_REF
+ | N_WEAK_DEF
+;;
+
+let n_desc_flags_code (n:n_desc_flags) : int64 =
+ match n with
+ REFERENCED_DYNAMICALLY -> 0x10L
+ | N_DESC_DISCARDED -> 0x20L
+ | N_NO_DEAD_STRIP -> 0x20L (* Yes, they reuse 0x20. *)
+ | N_WEAK_REF -> 0x40L
+ | N_WEAK_DEF -> 0x80L
+;;
+
+type n_desc_dylib_ordinal = int;;
+
+type n_desc = (n_desc_dylib_ordinal *
+ (n_desc_flags list) *
+ n_desc_reference_type)
+;;
+
+let n_desc_code (n:n_desc) : int64 =
+ let (dylib_ordinal, flags, ty) = n in
+ Int64.logor
+ (Int64.of_int (dylib_ordinal lsl 8))
+ (Int64.logor
+ (fold_flags n_desc_flags_code flags)
+ (n_desc_reference_type_code ty))
+;;
+
+
+let macho_section_command
+ (seg_name:string)
+ (sect:(string * int * (sect_attr list) * sect_type * fixup))
+ : frag =
+ let (sect_name, sect_align, sect_attrs, sect_type, sect_fixup) = sect in
+ SEQ [|
+ fixed_sz_string 16 sect_name;
+ fixed_sz_string 16 seg_name;
+ WORD (TY_u32, M_POS sect_fixup);
+ WORD (TY_u32, M_SZ sect_fixup);
+ WORD (TY_u32, F_POS sect_fixup);
+ WORD (TY_u32, IMM (Int64.of_int sect_align));
+ WORD (TY_u32, IMM 0L); (* reloff *)
+ WORD (TY_u32, IMM 0L); (* nreloc *)
+ WORD (TY_u32, (IMM (Int64.logor (* flags (and attrs) *)
+ (fold_flags sect_attr_code sect_attrs)
+ (sect_type_code sect_type))));
+ WORD (TY_u32, IMM 0L); (* reserved1 *)
+ WORD (TY_u32, IMM 0L); (* reserved2 *)
+ |]
+;;
+
+let macho_segment_command
+ (seg_name:string)
+ (seg_fixup:fixup)
+ (maxprot:vm_prot list)
+ (initprot:vm_prot list)
+ (sects:(string * int * (sect_attr list) * sect_type * fixup) array)
+ : frag =
+
+ let cmd_fixup = new_fixup "segment command" in
+ let cmd =
+ SEQ [|
+ WORD (TY_u32, IMM (load_command_code LC_SEGMENT));
+ WORD (TY_u32, F_SZ cmd_fixup);
+ fixed_sz_string 16 seg_name;
+ WORD (TY_u32, M_POS seg_fixup);
+ WORD (TY_u32, M_SZ seg_fixup);
+ WORD (TY_u32, F_POS seg_fixup);
+ WORD (TY_u32, F_SZ seg_fixup);
+ WORD (TY_u32, IMM (fold_flags vm_prot_code maxprot));
+ WORD (TY_u32, IMM (fold_flags vm_prot_code initprot));
+ WORD (TY_u32, IMM (Int64.of_int (Array.length sects)));
+ WORD (TY_u32, IMM 0L); (* Flags? *)
+ |]
+ in
+ DEF (cmd_fixup,
+ SEQ [|
+ cmd;
+ SEQ (Array.map (macho_section_command seg_name) sects);
+ |])
+;;
+
+let macho_thread_command
+ (entry:fixup)
+ : frag =
+ let cmd_fixup = new_fixup "thread command" in
+ let x86_THREAD_STATE32 = 1L in
+ let regs =
+ [|
+ WORD (TY_u32, IMM 0x0L); (* eax *)
+ WORD (TY_u32, IMM 0x0L); (* ebx *)
+ WORD (TY_u32, IMM 0x0L); (* ecx *)
+ WORD (TY_u32, IMM 0x0L); (* edx *)
+
+ WORD (TY_u32, IMM 0x0L); (* edi *)
+ WORD (TY_u32, IMM 0x0L); (* esi *)
+ WORD (TY_u32, IMM 0x0L); (* ebp *)
+ WORD (TY_u32, IMM 0x0L); (* esp *)
+
+ WORD (TY_u32, IMM 0x0L); (* ss *)
+ WORD (TY_u32, IMM 0x0L); (* eflags *)
+ WORD (TY_u32, M_POS entry); (* eip *)
+ WORD (TY_u32, IMM 0x0L); (* cs *)
+
+ WORD (TY_u32, IMM 0x0L); (* ds *)
+ WORD (TY_u32, IMM 0x0L); (* es *)
+ WORD (TY_u32, IMM 0x0L); (* fs *)
+ WORD (TY_u32, IMM 0x0L); (* gs *)
+ |]
+ in
+ let cmd =
+ SEQ [|
+ WORD (TY_u32, IMM (load_command_code LC_UNIXTHREAD));
+ WORD (TY_u32, F_SZ cmd_fixup);
+ WORD (TY_u32, IMM x86_THREAD_STATE32); (* "flavour" *)
+ WORD (TY_u32, IMM (Int64.of_int (Array.length regs)));
+ SEQ regs
+ |]
+ in
+ DEF (cmd_fixup, cmd)
+;;
+
+let macho_dylinker_command : frag =
+ let cmd_fixup = new_fixup "dylinker command" in
+ let str_fixup = new_fixup "dylinker lc_str fixup" in
+ let cmd =
+ SEQ
+ [|
+ WORD (TY_u32, IMM (load_command_code LC_LOAD_DYLINKER));
+ WORD (TY_u32, F_SZ cmd_fixup);
+
+ (* see definition of lc_str; these things are weird. *)
+ WORD (TY_u32, SUB (F_POS (str_fixup), F_POS (cmd_fixup)));
+ DEF (str_fixup, ZSTRING "/usr/lib/dyld");
+ ALIGN_FILE (4, MARK);
+ |]
+ in
+ DEF (cmd_fixup, cmd);
+;;
+
+let macho_dylib_command (dylib:string) : frag =
+
+ let cmd_fixup = new_fixup "dylib command" in
+ let str_fixup = new_fixup "dylib lc_str fixup" in
+ let cmd =
+ SEQ
+ [|
+ WORD (TY_u32, IMM (load_command_code LC_LOAD_DYLIB));
+ WORD (TY_u32, F_SZ cmd_fixup);
+
+ (* see definition of lc_str; these things are weird. *)
+ WORD (TY_u32, SUB (F_POS (str_fixup), F_POS (cmd_fixup)));
+
+ WORD (TY_u32, IMM 0L); (* timestamp *)
+ WORD (TY_u32, IMM 0L); (* current_version *)
+ WORD (TY_u32, IMM 0L); (* compatibility_version *)
+
+ (* Payload-and-alignment of an lc_str goes at end of command. *)
+ DEF (str_fixup, ZSTRING dylib);
+ ALIGN_FILE (4, MARK);
+
+ |]
+ in
+ DEF (cmd_fixup, cmd)
+;;
+
+
+let macho_symtab_command
+ (symtab_fixup:fixup)
+ (nsyms:int64)
+ (strtab_fixup:fixup)
+ : frag =
+ let cmd_fixup = new_fixup "symtab command" in
+ let cmd =
+ SEQ
+ [|
+ WORD (TY_u32, IMM (load_command_code LC_SYMTAB));
+ WORD (TY_u32, F_SZ cmd_fixup);
+
+ WORD (TY_u32, F_POS symtab_fixup); (* symoff *)
+ WORD (TY_u32, IMM nsyms); (* nsyms *)
+
+ WORD (TY_u32, F_POS strtab_fixup); (* stroff *)
+ WORD (TY_u32, F_SZ strtab_fixup); (* strsz *)
+ |]
+ in
+ DEF (cmd_fixup, cmd)
+;;
+
+let macho_dysymtab_command
+ (local_defined_syms_index:int64)
+ (local_defined_syms_count:int64)
+ (external_defined_syms_index:int64)
+ (external_defined_syms_count:int64)
+ (undefined_syms_index:int64)
+ (undefined_syms_count:int64)
+ (indirect_symtab_fixup:fixup) : frag =
+ let cmd_fixup = new_fixup "dysymtab command" in
+ let cmd =
+ SEQ
+ [|
+ WORD (TY_u32, IMM (load_command_code LC_DYSYMTAB));
+ WORD (TY_u32, F_SZ cmd_fixup);
+
+ WORD (TY_u32, IMM local_defined_syms_index); (* ilocalsym *)
+ WORD (TY_u32, IMM local_defined_syms_count); (* nlocalsym *)
+
+ WORD (TY_u32, IMM external_defined_syms_index); (* iextdefsym *)
+ WORD (TY_u32, IMM external_defined_syms_count); (* nextdefsym *)
+
+ WORD (TY_u32, IMM undefined_syms_index); (* iundefsym *)
+ WORD (TY_u32, IMM undefined_syms_count); (* nundefsym *)
+
+ WORD (TY_u32, IMM 0L); (* tocoff *)
+ WORD (TY_u32, IMM 0L); (* ntoc *)
+
+ WORD (TY_u32, IMM 0L); (* modtaboff *)
+ WORD (TY_u32, IMM 0L); (* nmodtab *)
+
+ WORD (TY_u32, IMM 0L); (* extrefsymoff *)
+ WORD (TY_u32, IMM 0L); (* nextrefsyms *)
+
+ WORD (TY_u32, F_POS indirect_symtab_fixup); (* indirectsymoff *)
+ WORD (TY_u32, IMM undefined_syms_count); (* nindirectsyms *)
+
+ WORD (TY_u32, IMM 0L); (* extreloff *)
+ WORD (TY_u32, IMM 0L); (* nextrel *)
+
+ WORD (TY_u32, IMM 0L); (* locreloff *)
+ WORD (TY_u32, IMM 0L); (* nlocrel *)
+ |]
+ in
+ DEF (cmd_fixup, cmd)
+;;
+
+let macho_header_32
+ (cpu:cpu_type)
+ (sub:cpu_subtype)
+ (ftype:file_type)
+ (flags:file_flag list)
+ (loadcmds:frag array) : frag =
+ let load_commands_fixup = new_fixup "load commands" in
+ let cmds = DEF (load_commands_fixup, SEQ loadcmds) in
+ SEQ
+ [|
+ WORD (TY_u32, IMM mh_magic);
+ WORD (TY_u32, IMM (cpu_type_code cpu));
+ WORD (TY_u32, IMM (cpu_subtype_code sub));
+ WORD (TY_u32, IMM (file_type_code ftype));
+ WORD (TY_u32, IMM (Int64.of_int (Array.length loadcmds)));
+ WORD (TY_u32, F_SZ load_commands_fixup);
+ WORD (TY_u32, IMM (fold_flags file_flag_code flags));
+ cmds
+ |]
+;;
+
+let emit_file
+ (sess:Session.sess)
+ (crate:Ast.crate)
+ (code:Asm.frag)
+ (data:Asm.frag)
+ (sem:Semant.ctxt)
+ (dwarf:Dwarf.debug_records)
+ : unit =
+
+ (* FIXME: alignment? *)
+
+ let mh_execute_header_fixup = new_fixup "__mh_execute header" in
+
+ let nxargc_fixup = (Semant.provide_native sem SEG_data "NXArgc") in
+ let nxargv_fixup = (Semant.provide_native sem SEG_data "NXArgv") in
+ let progname_fixup = (Semant.provide_native sem SEG_data "__progname") in
+ let environ_fixup = (Semant.provide_native sem SEG_data "environ") in
+ let exit_fixup = (Semant.require_native sem REQUIRED_LIB_crt "exit") in
+ let (start_fixup, rust_start_fixup) =
+ if sess.Session.sess_library_mode
+ then (None, None)
+ else (Some (new_fixup "start function entry"),
+ Some (Semant.require_native sem REQUIRED_LIB_rustrt "rust_start"))
+ in
+
+ let text_sect_align_log2 = 2 in
+ let data_sect_align_log2 = 2 in
+
+ let seg_align = 0x1000 in
+ let text_sect_align = 2 lsl text_sect_align_log2 in
+ let data_sect_align = 2 lsl data_sect_align_log2 in
+
+ let align_both align i =
+ ALIGN_FILE (align,
+ (ALIGN_MEM (align, i)))
+ in
+
+ let def_aligned a f i =
+ align_both a
+ (SEQ [| DEF(f, i);
+ (align_both a MARK)|])
+ in
+
+ (* Segments. *)
+ let zero_segment_fixup = new_fixup "__PAGEZERO segment" in
+ let text_segment_fixup = new_fixup "__TEXT segment" in
+ let data_segment_fixup = new_fixup "__DATA segment" in
+ let dwarf_segment_fixup = new_fixup "__DWARF segment" in
+ let linkedit_segment_fixup = new_fixup "__LINKEDIT segment" in
+
+ (* Sections in the text segment. *)
+ let text_section_fixup = new_fixup "__text section" in
+
+ (* Sections in the data segment. *)
+ let data_section_fixup = new_fixup "__data section" in
+ let const_section_fixup = new_fixup "__const section" in
+ let bss_section_fixup = new_fixup "__bss section" in
+ let note_rust_section_fixup = new_fixup "__note.rust section" in
+ let nl_symbol_ptr_section_fixup = new_fixup "__nl_symbol_ptr section" in
+
+ let data_section = def_aligned data_sect_align data_section_fixup data in
+ let const_section =
+ def_aligned data_sect_align const_section_fixup (SEQ [| |])
+ in
+ let bss_section =
+ def_aligned data_sect_align bss_section_fixup (SEQ [| |])
+ in
+ let note_rust_section =
+ def_aligned
+ data_sect_align note_rust_section_fixup
+ (Asm.note_rust_frags crate.node.Ast.crate_meta)
+ in
+
+ (* Officially Apple doesn't claim to support DWARF sections like this, but
+ they work. *)
+ let debug_info_section =
+ def_aligned data_sect_align
+ sem.Semant.ctxt_debug_info_fixup
+ dwarf.Dwarf.debug_info
+ in
+ let debug_abbrev_section =
+ def_aligned data_sect_align
+ sem.Semant.ctxt_debug_abbrev_fixup
+ dwarf.Dwarf.debug_abbrev
+ in
+
+
+ (* String, symbol and parallel "nonlazy-pointer" tables. *)
+ let symtab_fixup = new_fixup "symtab" in
+ let strtab_fixup = new_fixup "strtab" in
+
+ let symbol_nlist_entry
+ (sect_index:int)
+ (nty:n_type list)
+ (nd:n_desc)
+ (nv:Asm.expr64)
+ : (frag * fixup) =
+ let strtab_entry_fixup = new_fixup "strtab entry" in
+ (SEQ
+ [|
+ WORD (TY_u32, SUB ((F_POS strtab_entry_fixup),
+ (F_POS strtab_fixup)));
+ BYTE (Int64.to_int (fold_flags n_type_code nty));
+ BYTE sect_index;
+ WORD (TY_u16, IMM (n_desc_code nd));
+ WORD (TY_u32, nv);
+ |], strtab_entry_fixup)
+ in
+
+ let sect_symbol_nlist_entry
+ (seg:segment)
+ (fixup_to_use:fixup)
+ : (frag * fixup) =
+ let nty = [ N_SECT; N_EXT ] in
+ let nd = (0, [], REFERENCE_FLAG_UNDEFINED_NON_LAZY) in
+ let (sect_index, _(*seg_fix*)) =
+ match seg with
+ SEG_text -> (1, text_segment_fixup)
+ | SEG_data -> (2, data_segment_fixup)
+ in
+ symbol_nlist_entry sect_index nty nd (M_POS fixup_to_use)
+ in
+
+ let sect_private_symbol_nlist_entry
+ (seg:segment)
+ (fixup_to_use:fixup)
+ : (frag * fixup) =
+ let nty = [ N_SECT; ] in
+ let nd = (0, [], REFERENCE_FLAG_UNDEFINED_NON_LAZY) in
+ let (sect_index, _(*seg_fix*)) =
+ match seg with
+ SEG_text -> (1, text_segment_fixup)
+ | SEG_data -> (2, data_segment_fixup)
+ in
+ symbol_nlist_entry sect_index nty nd (M_POS fixup_to_use)
+ in
+
+ let indirect_symbol_nlist_entry (dylib_index:int) : (frag * fixup) =
+ let nty = [ N_UNDF; N_EXT ] in
+ let nd = (dylib_index, [], REFERENCE_FLAG_UNDEFINED_NON_LAZY) in
+ symbol_nlist_entry 0 nty nd (IMM 0L)
+ in
+
+ let indirect_symbols =
+ Array.of_list
+ (List.concat
+ (List.map
+ (fun (lib, tab) ->
+ (List.map
+ (fun (name,fix) -> (lib,name,fix))
+ (htab_pairs tab)))
+ (htab_pairs sem.Semant.ctxt_native_required)))
+ in
+
+ let dylib_index (lib:required_lib) : int =
+ match lib with
+ REQUIRED_LIB_rustrt -> 1
+ | REQUIRED_LIB_crt -> 2
+ | _ -> bug () "Macho.dylib_index on nonstandard required lib."
+ in
+
+ (* Make undef symbols for native imports. *)
+ let (undefined_symbols:(string * (frag * fixup)) array) =
+ Array.map (fun (lib,name,_) ->
+ ("_" ^ name,
+ indirect_symbol_nlist_entry (dylib_index lib)))
+ indirect_symbols
+ in
+
+ (* Make symbols for exports. *)
+ let (export_symbols:(string * (frag * fixup)) array) =
+ let export_symbols_of_seg (seg, tab) =
+ List.map
+ begin
+ fun (name, fix) ->
+ let name = "_" ^ name in
+ let sym = sect_symbol_nlist_entry seg fix in
+ (name, sym)
+ end
+ (htab_pairs tab)
+ in
+ Array.of_list
+ (List.concat
+ (List.map export_symbols_of_seg
+ (htab_pairs sem.Semant.ctxt_native_provided)))
+ in
+
+ (* Make private symbols for items. *)
+ let (local_item_symbols:(string * (frag * fixup)) array) =
+ Array.map (fun code ->
+ let fix = code.Semant.code_fixup in
+ ("_" ^ fix.fixup_name,
+ sect_private_symbol_nlist_entry SEG_text fix))
+ (Array.of_list (htab_vals sem.Semant.ctxt_all_item_code))
+ in
+
+ (* Make private symbols for glue. *)
+ let (local_glue_symbols:(string * (frag * fixup)) array) =
+ Array.map (fun (g, code) ->
+ let fix = code.Semant.code_fixup in
+ ("_" ^ (Semant.glue_str sem g),
+ sect_private_symbol_nlist_entry SEG_text fix))
+ (Array.of_list (htab_pairs sem.Semant.ctxt_glue_code))
+ in
+
+ let (export_header_symbols:(string * (frag * fixup)) array) =
+ let name =
+ if sess.Session.sess_library_mode
+ then "__mh_dylib_header"
+ else "__mh_execute_header"
+ in
+ [|
+ (name, sect_symbol_nlist_entry SEG_text mh_execute_header_fixup);
+ |]
+ in
+
+ let export_symbols = Array.concat [ export_symbols;
+ export_header_symbols ]
+ in
+
+ let local_symbols = Array.concat [ local_item_symbols;
+ local_glue_symbols ]
+ in
+
+ let symbols = Array.concat [ local_symbols;
+ export_symbols;
+ undefined_symbols ]
+ in
+ let n_local_syms = Array.length local_symbols in
+ let n_export_syms = Array.length export_symbols in
+ let n_undef_syms = Array.length undefined_symbols in
+
+ let indirect_symbols_off = n_local_syms + n_export_syms in
+ let indirect_symtab_fixup = new_fixup "indirect symbol table" in
+ let indirect_symtab =
+ DEF (indirect_symtab_fixup,
+ SEQ (Array.mapi
+ (fun i _ -> WORD (TY_u32,
+ IMM (Int64.of_int
+ (i + indirect_symbols_off))))
+ indirect_symbols))
+ in
+
+ let nl_symbol_ptr_section =
+ def_aligned data_sect_align nl_symbol_ptr_section_fixup
+ (SEQ (Array.map
+ (fun (_, _, fix) ->
+ DEF(fix, WORD(TY_u32, IMM 0L)))
+ indirect_symbols))
+ in
+ let strtab = DEF (strtab_fixup,
+ SEQ (Array.map
+ (fun (name, (_, fix)) -> DEF(fix, ZSTRING name))
+ symbols))
+ in
+ let symtab = DEF (symtab_fixup,
+ SEQ (Array.map (fun (_, (frag, _)) -> frag) symbols))
+ in
+
+
+ let load_commands =
+ [|
+ macho_segment_command "__PAGEZERO" zero_segment_fixup
+ [] [] [||];
+
+ macho_segment_command "__TEXT" text_segment_fixup
+ [VM_PROT_READ; VM_PROT_EXECUTE]
+ [VM_PROT_READ; VM_PROT_EXECUTE]
+ [|
+ ("__text", text_sect_align_log2, [], S_REGULAR, text_section_fixup)
+ |];
+
+ macho_segment_command "__DATA" data_segment_fixup
+ [VM_PROT_READ; VM_PROT_WRITE]
+ [VM_PROT_READ; VM_PROT_WRITE]
+ [|
+ ("__data", data_sect_align_log2, [],
+ S_REGULAR, data_section_fixup);
+ ("__const", data_sect_align_log2, [],
+ S_REGULAR, const_section_fixup);
+ ("__bss", data_sect_align_log2, [],
+ S_REGULAR, bss_section_fixup);
+ ("__note.rust", data_sect_align_log2, [],
+ S_REGULAR, note_rust_section_fixup);
+ ("__nl_symbol_ptr", data_sect_align_log2, [],
+ S_NON_LAZY_SYMBOL_POINTERS, nl_symbol_ptr_section_fixup)
+ |];
+
+ macho_segment_command "__DWARF" dwarf_segment_fixup
+ [VM_PROT_READ]
+ [VM_PROT_READ]
+ [|
+ ("__debug_info", data_sect_align_log2, [],
+ S_REGULAR, sem.Semant.ctxt_debug_info_fixup);
+ ("__debug_abbrev", data_sect_align_log2, [],
+ S_REGULAR, sem.Semant.ctxt_debug_abbrev_fixup);
+ |];
+
+ macho_segment_command "__LINKEDIT" linkedit_segment_fixup
+ [VM_PROT_READ]
+ [VM_PROT_READ]
+ [|
+ |];
+
+ macho_symtab_command
+ symtab_fixup (Int64.of_int (Array.length symbols)) strtab_fixup;
+
+
+ macho_dysymtab_command
+ 0L
+ (Int64.of_int n_local_syms)
+ (Int64.of_int n_local_syms)
+ (Int64.of_int n_export_syms)
+ (Int64.of_int (n_local_syms + n_export_syms))
+ (Int64.of_int n_undef_syms)
+ indirect_symtab_fixup;
+
+ macho_dylinker_command;
+
+ macho_dylib_command "librustrt.dylib";
+
+ macho_dylib_command "/usr/lib/libSystem.B.dylib";
+
+ begin
+ match start_fixup with
+ None -> MARK
+ | Some start_fixup ->
+ macho_thread_command start_fixup
+ end;
+ |]
+ in
+
+ let header_and_commands =
+ macho_header_32
+ CPU_TYPE_X86
+ CPU_SUBTYPE_X86_ALL
+ (if sess.Session.sess_library_mode then MH_DYLIB else MH_EXECUTE)
+ [ MH_BINDATLOAD; MH_DYLDLINK; MH_TWOLEVEL ]
+ load_commands
+ in
+
+ let objfile_start e start_fixup rust_start_fixup main_fn_fixup =
+ let edx = X86.h X86.edx in
+ let edx_pointee =
+ Il.Mem ((Il.RegIn (edx, None)), Il.ScalarTy (Il.AddrTy Il.OpaqueTy))
+ in
+ Il.emit_full e (Some start_fixup) [] Il.Dead;
+
+ (* zero marks the bottom of the frame chain. *)
+ Il.emit e (Il.Push (X86.imm (Asm.IMM 0L)));
+ Il.emit e (Il.umov (X86.rc X86.ebp) (X86.ro X86.esp));
+
+ (* 16-byte align stack for SSE. *)
+ Il.emit e (Il.binary Il.AND (X86.rc X86.esp) (X86.ro X86.esp)
+ (X86.imm (Asm.IMM 0xfffffffffffffff0L)));
+
+ (* Store argv. *)
+ Abi.load_fixup_addr e edx nxargv_fixup Il.OpaqueTy;
+ Il.emit e (Il.lea (X86.rc X86.ecx)
+ (Il.Cell (Il.Mem ((Il.RegIn (Il.Hreg X86.ebp,
+ Some (X86.word_off_n 2))),
+ Il.OpaqueTy))));
+ Il.emit e (Il.umov edx_pointee (X86.ro X86.ecx));
+ Il.emit e (Il.Push (X86.ro X86.ecx));
+
+ (* Store argc. *)
+ Abi.load_fixup_addr e edx nxargc_fixup Il.OpaqueTy;
+ Il.emit e (Il.umov (X86.rc X86.eax)
+ (X86.c (X86.word_n (Il.Hreg X86.ebp) 1)));
+ Il.emit e (Il.umov edx_pointee (X86.ro X86.eax));
+ Il.emit e (Il.Push (X86.ro X86.eax));
+
+ (* Calculte and store envp. *)
+ Il.emit e (Il.binary Il.ADD
+ (X86.rc X86.eax) (X86.ro X86.eax)
+ (X86.imm (Asm.IMM 1L)));
+ Il.emit e (Il.binary Il.UMUL
+ (X86.rc X86.eax) (X86.ro X86.eax)
+ (X86.imm (Asm.IMM X86.word_sz)));
+ Il.emit e (Il.binary Il.ADD (X86.rc X86.eax)
+ (X86.ro X86.eax) (X86.ro X86.ecx));
+ Abi.load_fixup_addr e edx environ_fixup Il.OpaqueTy;
+ Il.emit e (Il.umov edx_pointee (X86.ro X86.eax));
+
+ (* Push 16 bytes to preserve SSE alignment. *)
+ Abi.load_fixup_addr e edx sem.Semant.ctxt_crate_fixup Il.OpaqueTy;
+ Il.emit e (Il.Push (X86.ro X86.edx));
+ Abi.load_fixup_addr e edx main_fn_fixup Il.OpaqueTy;
+ Il.emit e (Il.Push (X86.ro X86.edx));
+ let fptr = Abi.load_fixup_codeptr e edx rust_start_fixup true true in
+ Il.emit e (Il.call (X86.rc X86.eax) fptr);
+ Il.emit e (Il.Pop (X86.rc X86.ecx));
+ Il.emit e (Il.Push (X86.ro X86.eax));
+ let fptr = Abi.load_fixup_codeptr e edx exit_fixup true true in
+ Il.emit e (Il.call (X86.rc X86.eax) fptr);
+ Il.emit e (Il.Pop (X86.rc X86.ecx));
+ Il.emit e (Il.Pop (X86.rc X86.ecx));
+ Il.emit e (Il.Pop (X86.rc X86.ecx));
+ Il.emit e (Il.Pop (X86.rc X86.ecx));
+
+ Il.emit e Il.Ret;
+ in
+
+ let text_section =
+ let start_code =
+ match (start_fixup, rust_start_fixup,
+ sem.Semant.ctxt_main_fn_fixup) with
+ (None, _, _)
+ | (_, None, _)
+ | (_, _, None) -> MARK
+ | (Some start_fixup,
+ Some rust_start_fixup,
+ Some main_fn_fixup) ->
+ let e = X86.new_emitter_without_vregs () in
+ objfile_start e start_fixup rust_start_fixup main_fn_fixup;
+ X86.frags_of_emitted_quads sess e
+ in
+ def_aligned text_sect_align text_section_fixup
+ (SEQ [|
+ start_code;
+ code
+ |])
+ in
+
+ let text_segment =
+ def_aligned seg_align text_segment_fixup
+ (SEQ [|
+ DEF (mh_execute_header_fixup, header_and_commands);
+ text_section;
+ align_both seg_align MARK;
+ |]);
+ in
+
+ let zero_segment = align_both seg_align
+ (SEQ [| MEMPOS 0L; DEF (zero_segment_fixup,
+ SEQ [| MEMPOS 0x1000L; MARK |] ) |])
+ in
+
+ let data_segment = def_aligned seg_align data_segment_fixup
+ (SEQ [|
+ DEF(nxargc_fixup, WORD (TY_u32, IMM 0L));
+ DEF(nxargv_fixup, WORD (TY_u32, IMM 0L));
+ DEF(environ_fixup, WORD (TY_u32, IMM 0L));
+ DEF(progname_fixup, WORD (TY_u32, IMM 0L));
+ data_section;
+ const_section;
+ bss_section;
+ note_rust_section;
+ nl_symbol_ptr_section
+ |])
+ in
+
+ let dwarf_segment = def_aligned seg_align dwarf_segment_fixup
+ (SEQ [|
+ debug_info_section;
+ debug_abbrev_section;
+ |])
+ in
+
+ let linkedit_segment = def_aligned seg_align linkedit_segment_fixup
+ (SEQ [|
+ symtab;
+ strtab;
+ indirect_symtab;
+ |])
+ in
+
+ let segments =
+ SEQ [|
+ DEF (sem.Semant.ctxt_image_base_fixup, MARK);
+ zero_segment;
+ text_segment;
+ data_segment;
+ dwarf_segment;
+ linkedit_segment;
+ |]
+ in
+ write_out_frag sess true segments
+;;
+
+
+let sniff
+ (sess:Session.sess)
+ (filename:filename)
+ : asm_reader option =
+ try
+ let stat = Unix.stat filename in
+ if (stat.Unix.st_kind = Unix.S_REG) &&
+ (stat.Unix.st_size > 4)
+ then
+ let ar = new_asm_reader sess filename in
+ let _ = log sess "sniffing Mach-O file" in
+ if (ar.asm_get_u32()) = (Int64.to_int mh_magic)
+ then (ar.asm_seek 0; Some ar)
+ else None
+ else
+ None
+ with
+ _ -> None
+;;
+
+let get_sections
+ (sess:Session.sess)
+ (ar:asm_reader)
+ : (string,(int*int)) Hashtbl.t =
+ let sects = Hashtbl.create 0 in
+ let _ = log sess "reading sections" in
+ let magic = ar.asm_get_u32() in
+ let _ = assert (magic = (Int64.to_int mh_magic)) in
+ let _ = ar.asm_adv_u32() in (* cpu type *)
+ let _ = ar.asm_adv_u32() in (* cpu subtype *)
+ let _ = ar.asm_adv_u32() in (* file type *)
+ let n_load_cmds = ar.asm_get_u32() in
+ let _ = ar.asm_adv_u32() in
+ let _ = log sess "Mach-o file with %d load commands" n_load_cmds in
+ let _ = ar.asm_adv_u32() in (* flags *)
+ let lc_seg = Int64.to_int (load_command_code LC_SEGMENT) in
+ for i = 0 to n_load_cmds - 1 do
+ let load_cmd_code = ar.asm_get_u32() in
+ let load_cmd_size = ar.asm_get_u32() in
+ let _ = log sess "load command %d:" i in
+ if load_cmd_code != lc_seg
+ then ar.asm_adv (load_cmd_size - 8)
+ else
+ begin
+ let seg_name = ar.asm_get_zstr_padded 16 in
+ let _ = log sess "LC_SEGMENT %s" seg_name in
+ let _ = ar.asm_adv_u32() in (* seg mem pos *)
+ let _ = ar.asm_adv_u32() in (* seg mem sz *)
+ let _ = ar.asm_adv_u32() in (* seg file pos *)
+ let _ = ar.asm_adv_u32() in (* seg file sz *)
+ let _ = ar.asm_adv_u32() in (* maxprot *)
+ let _ = ar.asm_adv_u32() in (* initprot *)
+ let n_sects = ar.asm_get_u32() in
+ let _ = ar.asm_get_u32() in (* flags *)
+ let _ = log sess "%d sections" in
+ for j = 0 to n_sects - 1 do
+ let sect_name = ar.asm_get_zstr_padded 16 in
+ let _ = ar.asm_adv 16 in (* seg name *)
+ let _ = ar.asm_adv_u32() in (* sect mem pos *)
+ let m_sz = ar.asm_get_u32() in
+ let f_pos = ar.asm_get_u32() in
+ let _ = ar.asm_adv_u32() in (* sect align *)
+ let _ = ar.asm_adv_u32() in (* reloff *)
+ let _ = ar.asm_adv_u32() in (* nreloc *)
+ let _ = ar.asm_adv_u32() in (* flags *)
+ let _ = ar.asm_adv_u32() in (* reserved1 *)
+ let _ = ar.asm_adv_u32() in (* reserved2 *)
+ let _ =
+ log sess
+ " section %d: 0x%x - 0x%x %s "
+ j f_pos (f_pos + m_sz) sect_name
+ in
+ let len = String.length sect_name in
+ let sect_name =
+ if (len > 2
+ && sect_name.[0] = '_'
+ && sect_name.[1] = '_')
+ then "." ^ (String.sub sect_name 2 (len-2))
+ else sect_name
+ in
+ Hashtbl.add sects sect_name (f_pos, m_sz)
+ done
+ end
+ done;
+ sects
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(*
+
+ Module for writing Microsoft PE files
+
+ Every image has a base address it's to be loaded at.
+
+ "file pointer" = offset in file
+
+ "VA" = address at runtime
+
+ "RVA" = VA - base address
+
+ If you write a non-RVA absolute address at any point you must put it
+ in a rebasing list so the loader can adjust it when/if it has to load
+ you at a different address.
+
+ Almost all addresses in the file are RVAs. Worry about the VAs.
+
+*)
+
+open Asm;;
+open Common;;
+
+let log (sess:Session.sess) =
+ Session.log "obj (pe)"
+ sess.Session.sess_log_obj
+ sess.Session.sess_log_out
+;;
+
+let iflog (sess:Session.sess) (thunk:(unit -> unit)) : unit =
+ if sess.Session.sess_log_obj
+ then thunk ()
+ else ()
+;;
+
+(*
+
+ The default image base (VA) for an executable on Win32 is 0x400000.
+
+ We use this too. RVAs are relative to this. RVA 0 = VA 0x400000.
+
+ Alignments are also relatively standard and fixed for Win32/PE32:
+ 4k memory pages, 512 byte disk sectors.
+
+ Since this is a stupid emitter, and we're not generating an awful
+ lot of sections, we are not going to differentiate between these
+ two kinds of alignment: we just align our sections to memory pages
+ and sometimes waste most of them. Shucks.
+
+*)
+
+let pe_image_base = 0x400000L;;
+let pe_file_alignment = 0x200;;
+let pe_mem_alignment = 0x1000;;
+
+let rva (f:fixup) = (SUB ((M_POS f), (IMM pe_image_base)));;
+
+let def_file_aligned f i =
+ ALIGN_FILE
+ (pe_file_alignment,
+ SEQ [|
+ DEF(f,
+ SEQ [| i;
+ ALIGN_FILE
+ (pe_file_alignment, MARK) |]) |] )
+;;
+
+let def_mem_aligned f i =
+ ALIGN_MEM
+ (pe_mem_alignment,
+ SEQ [|
+ DEF(f,
+ SEQ [| i;
+ ALIGN_MEM
+ (pe_mem_alignment, MARK) |]) |] )
+;;
+
+let align_both i =
+ ALIGN_FILE (pe_file_alignment,
+ (ALIGN_MEM (pe_mem_alignment, i)))
+;;
+
+let def_aligned f i =
+ align_both
+ (SEQ [| DEF(f,i);
+ (align_both MARK)|])
+;;
+
+
+(*
+
+ At the beginning of a PE file there is an MS-DOS stub, 0x00 - 0x7F,
+ that we just insert literally. It prints "This program must be run
+ under Win32" and exits. Woo!
+
+ Within it, at offset 0x3C, there is an encoded offset of the PE
+ header we actually care about. So 0x3C - 0x3F are 0x00000100 (LE)
+ which say "the PE header is actually at 0x100", a nice sensible spot
+ for it. We pad the next 128 bytes out to 0x100 and start there for
+ real.
+
+ From then on in it's a sensible object file. Here's the MS-DOS bit.
+*)
+
+let pe_msdos_header_and_padding
+ : frag =
+ SEQ [|
+ BYTES
+ [|
+ (* 00000000 *)
+ 0x4d; 0x5a; 0x50; 0x00; 0x02; 0x00; 0x00; 0x00;
+ 0x04; 0x00; 0x0f; 0x00; 0xff; 0xff; 0x00; 0x00;
+
+ (* 00000010 *)
+ 0xb8; 0x00; 0x00; 0x00; 0x00; 0x00; 0x00; 0x00;
+ 0x40; 0x00; 0x1a; 0x00; 0x00; 0x00; 0x00; 0x00;
+
+ (* 00000020 *)
+ 0x00; 0x00; 0x00; 0x00; 0x00; 0x00; 0x00; 0x00;
+ 0x00; 0x00; 0x00; 0x00; 0x00; 0x00; 0x00; 0x00;
+
+ (* 00000030 *)
+ 0x00; 0x00; 0x00; 0x00; 0x00; 0x00; 0x00; 0x00;
+ 0x00; 0x00; 0x00; 0x00; 0x00; 0x01; 0x00; 0x00;
+ (* ^^^^PE HDR offset^^^^^ *)
+
+ (* 00000040 *)
+ 0xba; 0x10; 0x00; 0x0e; 0x1f; 0xb4; 0x09; 0xcd;
+ 0x21; 0xb8; 0x01; 0x4c; 0xcd; 0x21; 0x90; 0x90;
+
+ (* 00000050 *)
+ 0x54; 0x68; 0x69; 0x73; 0x20; 0x70; 0x72; 0x6f; (* "This pro" *)
+ 0x67; 0x72; 0x61; 0x6d; 0x20; 0x6d; 0x75; 0x73; (* "gram mus" *)
+
+ (* 00000060 *)
+ 0x74; 0x20; 0x62; 0x65; 0x20; 0x72; 0x75; 0x6e; (* "t be run" *)
+ 0x20; 0x75; 0x6e; 0x64; 0x65; 0x72; 0x20; 0x57; (* " under W" *)
+
+ (* 00000070 *)
+ 0x69; 0x6e; 0x33; 0x32; 0x0d; 0x0a; 0x24; 0x37; (* "in32\r\n" *)
+ 0x00; 0x00; 0x00; 0x00; 0x00; 0x00; 0x00; 0x00;
+ |];
+ PAD 0x80
+ |]
+;;
+
+(*
+ A work of art, is it not? Take a moment to appreciate the madness.
+
+ All done? Ok, now on to the PE header proper.
+
+ PE headers are just COFF headers with a little preamble.
+*)
+
+type pe_machine =
+ (* Maybe support more later. *)
+ IMAGE_FILE_MACHINE_AMD64
+ | IMAGE_FILE_MACHINE_I386
+;;
+
+
+let pe_timestamp _ =
+ Int64.of_float (Unix.gettimeofday())
+;;
+
+
+type pe_characteristics =
+ (* Maybe support more later. *)
+ IMAGE_FILE_RELOCS_STRIPPED
+ | IMAGE_FILE_EXECUTABLE_IMAGE
+ | IMAGE_FILE_LINE_NUMS_STRIPPED
+ | IMAGE_FILE_LOCAL_SYMS_STRIPPED
+ | IMAGE_FILE_32BIT_MACHINE
+ | IMAGE_FILE_DEBUG_STRIPPED
+ | IMAGE_FILE_DLL
+;;
+
+
+let pe_header
+ ~(machine:pe_machine)
+ ~(symbol_table_fixup:fixup)
+ ~(number_of_sections:int64)
+ ~(number_of_symbols:int64)
+ ~(loader_hdr_fixup:fixup)
+ ~(characteristics:pe_characteristics list)
+ : frag =
+ ALIGN_FILE
+ (8,
+ SEQ [|
+ STRING "PE\x00\x00";
+ WORD (TY_u16, (IMM (match machine with
+ IMAGE_FILE_MACHINE_AMD64 -> 0x8664L
+ | IMAGE_FILE_MACHINE_I386 -> 0x014cL)));
+ WORD (TY_u16, (IMM number_of_sections));
+ WORD (TY_u32, (IMM (pe_timestamp())));
+ WORD (TY_u32, (F_POS symbol_table_fixup));
+ WORD (TY_u32, (IMM number_of_symbols));
+ WORD (TY_u16, (F_SZ loader_hdr_fixup));
+ WORD (TY_u16, (IMM (fold_flags
+ (fun c -> match c with
+ IMAGE_FILE_RELOCS_STRIPPED -> 0x1L
+ | IMAGE_FILE_EXECUTABLE_IMAGE -> 0x2L
+ | IMAGE_FILE_LINE_NUMS_STRIPPED -> 0x4L
+ | IMAGE_FILE_LOCAL_SYMS_STRIPPED -> 0x8L
+ | IMAGE_FILE_32BIT_MACHINE -> 0x100L
+ | IMAGE_FILE_DEBUG_STRIPPED -> 0x200L
+ | IMAGE_FILE_DLL -> 0x2000L)
+ characteristics)))
+ |])
+;;
+
+(*
+
+ After the PE header comes an "optional" header for the loader. In
+ our case this is hardly optional since we are producing a file for
+ the loader.
+
+*)
+
+type pe_subsystem =
+ (* Maybe support more later. *)
+ IMAGE_SUBSYSTEM_WINDOWS_GUI
+ | IMAGE_SUBSYSTEM_WINDOWS_CUI
+;;
+
+let zero32 = WORD (TY_u32, (IMM 0L))
+;;
+
+let pe_loader_header
+ ~(text_fixup:fixup)
+ ~(init_data_fixup:fixup)
+ ~(size_of_uninit_data:int64)
+ ~(entry_point_fixup:fixup option)
+ ~(image_fixup:fixup)
+ ~(all_hdrs_fixup:fixup)
+ ~(subsys:pe_subsystem)
+ ~(loader_hdr_fixup:fixup)
+ ~(import_dir_fixup:fixup)
+ ~(export_dir_fixup:fixup)
+ : frag =
+ DEF
+ (loader_hdr_fixup,
+ SEQ [|
+ WORD (TY_u16, (IMM 0x10bL)); (* COFF magic tag for PE32. *)
+ (* Snagged *)
+ WORD (TY_u8, (IMM 0x2L)); (* Linker major version. *)
+ WORD (TY_u8, (IMM 0x38L)); (* Linker minor version. *)
+
+ WORD (TY_u32, (F_SZ text_fixup)); (* "size of code" *)
+ WORD (TY_u32, (* "size of all init data" *)
+ (F_SZ init_data_fixup));
+ WORD (TY_u32,
+ (IMM size_of_uninit_data));
+
+ begin
+ match entry_point_fixup with
+ None -> zero32 (* Library mode: DLLMain *)
+ | Some entry_point_fixup ->
+ WORD (TY_u32,
+ (rva
+ entry_point_fixup)) (* "address of entry point" *)
+ end;
+
+ WORD (TY_u32, (rva text_fixup)); (* "base of code" *)
+ WORD (TY_u32, (rva init_data_fixup)); (* "base of data" *)
+ WORD (TY_u32, (IMM pe_image_base));
+ WORD (TY_u32, (IMM (Int64.of_int
+ pe_mem_alignment)));
+ WORD (TY_u32, (IMM (Int64.of_int
+ pe_file_alignment)));
+
+ WORD (TY_u16, (IMM 4L)); (* Major OS version: NT4. *)
+ WORD (TY_u16, (IMM 0L)); (* Minor OS version. *)
+ WORD (TY_u16, (IMM 1L)); (* Major image version. *)
+ WORD (TY_u16, (IMM 0L)); (* Minor image version. *)
+ WORD (TY_u16, (IMM 4L)); (* Major subsystem version. *)
+ WORD (TY_u16, (IMM 0L)); (* Minor subsystem version. *)
+
+ zero32; (* Reserved. *)
+
+ WORD (TY_u32, (M_SZ image_fixup));
+ WORD (TY_u32, (M_SZ all_hdrs_fixup));
+
+ zero32; (* Checksum, but OK if zero. *)
+ WORD (TY_u16, (IMM (match subsys with
+ IMAGE_SUBSYSTEM_WINDOWS_GUI -> 2L
+ | IMAGE_SUBSYSTEM_WINDOWS_CUI -> 3L)));
+
+ WORD (TY_u16, (IMM 0L)); (* DLL characteristics. *)
+
+ WORD (TY_u32, (IMM 0x100000L)); (* Size of stack reserve. *)
+ WORD (TY_u32, (IMM 0x4000L)); (* Size of stack commit. *)
+
+ WORD (TY_u32, (IMM 0x100000L)); (* Size of heap reserve. *)
+ WORD (TY_u32, (IMM 0x1000L)); (* Size of heap commit. *)
+
+ zero32; (* Reserved. *)
+ WORD (TY_u32, (IMM 16L)); (* Number of dir references. *)
+
+ (* Begin directories, variable part of hdr. *)
+
+ (*
+
+ Standard PE files have ~10 directories referenced from
+ here. We only fill in two of them -- the export/import
+ directories -- because we don't care about the others. We
+ leave the rest as zero in case someone is looking for
+ them. This may be superfluous or wrong.
+
+ *)
+
+
+ WORD (TY_u32, (rva export_dir_fixup));
+ WORD (TY_u32, (M_SZ export_dir_fixup));
+
+ WORD (TY_u32, (rva import_dir_fixup));
+ WORD (TY_u32, (M_SZ import_dir_fixup));
+
+ zero32; zero32; (* Resource dir. *)
+ zero32; zero32; (* Exception dir. *)
+ zero32; zero32; (* Security dir. *)
+ zero32; zero32; (* Base reloc dir. *)
+ zero32; zero32; (* Debug dir. *)
+ zero32; zero32; (* Image desc dir. *)
+ zero32; zero32; (* Mach spec dir. *)
+ zero32; zero32; (* TLS dir. *)
+
+ zero32; zero32; (* Load config. *)
+ zero32; zero32; (* Bound import. *)
+ zero32; zero32; (* IAT *)
+ zero32; zero32; (* Delay import. *)
+ zero32; zero32; (* COM descriptor *)
+ zero32; zero32; (* ???????? *)
+ |])
+
+;;
+
+
+type pe_section_id =
+ (* Maybe support more later. *)
+ SECTION_ID_TEXT
+ | SECTION_ID_DATA
+ | SECTION_ID_RDATA
+ | SECTION_ID_BSS
+ | SECTION_ID_IMPORTS
+ | SECTION_ID_EXPORTS
+ | SECTION_ID_DEBUG_ARANGES
+ | SECTION_ID_DEBUG_PUBNAMES
+ | SECTION_ID_DEBUG_INFO
+ | SECTION_ID_DEBUG_ABBREV
+ | SECTION_ID_DEBUG_LINE
+ | SECTION_ID_DEBUG_FRAME
+ | SECTION_ID_NOTE_RUST
+;;
+
+type pe_section_characteristics =
+ (* Maybe support more later. *)
+ IMAGE_SCN_CNT_CODE
+ | IMAGE_SCN_CNT_INITIALIZED_DATA
+ | IMAGE_SCN_CNT_UNINITIALIZED_DATA
+ | IMAGE_SCN_MEM_DISCARDABLE
+ | IMAGE_SCN_MEM_SHARED
+ | IMAGE_SCN_MEM_EXECUTE
+ | IMAGE_SCN_MEM_READ
+ | IMAGE_SCN_MEM_WRITE
+
+let pe_section_header
+ ~(id:pe_section_id)
+ ~(hdr_fixup:fixup)
+ : frag =
+ let
+ characteristics =
+ match id with
+ SECTION_ID_TEXT -> [ IMAGE_SCN_CNT_CODE;
+ IMAGE_SCN_MEM_READ;
+ IMAGE_SCN_MEM_EXECUTE ]
+ | SECTION_ID_DATA -> [ IMAGE_SCN_CNT_INITIALIZED_DATA;
+ IMAGE_SCN_MEM_READ;
+ IMAGE_SCN_MEM_WRITE ]
+ | SECTION_ID_BSS -> [ IMAGE_SCN_CNT_UNINITIALIZED_DATA;
+ IMAGE_SCN_MEM_READ;
+ IMAGE_SCN_MEM_WRITE ]
+ | SECTION_ID_IMPORTS -> [ IMAGE_SCN_CNT_INITIALIZED_DATA;
+ IMAGE_SCN_MEM_READ;
+ IMAGE_SCN_MEM_WRITE ]
+ | SECTION_ID_EXPORTS -> [ IMAGE_SCN_CNT_INITIALIZED_DATA;
+ IMAGE_SCN_MEM_READ ]
+ | SECTION_ID_RDATA
+ | SECTION_ID_DEBUG_ARANGES
+ | SECTION_ID_DEBUG_PUBNAMES
+ | SECTION_ID_DEBUG_INFO
+ | SECTION_ID_DEBUG_ABBREV
+ | SECTION_ID_DEBUG_LINE
+ | SECTION_ID_DEBUG_FRAME
+ | SECTION_ID_NOTE_RUST -> [ IMAGE_SCN_CNT_INITIALIZED_DATA;
+ IMAGE_SCN_MEM_READ ]
+ in
+ SEQ [|
+ STRING
+ begin
+ match id with
+ SECTION_ID_TEXT -> ".text\x00\x00\x00"
+ | SECTION_ID_DATA -> ".data\x00\x00\x00"
+ | SECTION_ID_RDATA -> ".rdata\x00\x00"
+ | SECTION_ID_BSS -> ".bss\x00\x00\x00\x00"
+ | SECTION_ID_IMPORTS -> ".idata\x00\x00"
+ | SECTION_ID_EXPORTS -> ".edata\x00\x00"
+
+ (* There is a bizarre Microsoft COFF extension to account
+ * for longer-than-8-char section names: you emit a single
+ * '/' character then the ASCII-numeric encoding of the
+ * offset within the file's string table of the full name.
+ * So we put all our extended section names at the
+ * beginning of the string table in a very specific order
+ * and hard-wire the offsets as "names" here. You could
+ * theoretically extend this to a "new kind" of fixup
+ * reference (ASCII_POS or such), if you feel this is
+ * something you want to twiddle with.
+ *)
+
+ | SECTION_ID_DEBUG_ARANGES -> "/4\x00\x00\x00\x00\x00\x00"
+ | SECTION_ID_DEBUG_PUBNAMES -> "/19\x00\x00\x00\x00\x00"
+ | SECTION_ID_DEBUG_INFO -> "/35\x00\x00\x00\x00\x00"
+ | SECTION_ID_DEBUG_ABBREV -> "/47\x00\x00\x00\x00\x00"
+ | SECTION_ID_DEBUG_LINE -> "/61\x00\x00\x00\x00\x00"
+ | SECTION_ID_DEBUG_FRAME -> "/73\x00\x00\x00\x00\x00"
+ | SECTION_ID_NOTE_RUST -> "/86\x00\x00\x00\x00\x00"
+ end;
+
+ (* The next two pairs are only supposed to be different if the
+ file and section alignments differ. This is a stupid emitter
+ so they're not, no problem. *)
+
+ WORD (TY_u32, (M_SZ hdr_fixup)); (* "Virtual size" *)
+ WORD (TY_u32, (rva hdr_fixup)); (* "Virtual address" *)
+
+ WORD (TY_u32, (F_SZ hdr_fixup)); (* "Size of raw data" *)
+ WORD (TY_u32, (F_POS hdr_fixup)); (* "Pointer to raw data" *)
+
+ zero32; (* Reserved. *)
+ zero32; (* Reserved. *)
+ zero32; (* Reserved. *)
+
+ WORD (TY_u32, (IMM (fold_flags
+ (fun c -> match c with
+ IMAGE_SCN_CNT_CODE -> 0x20L
+ | IMAGE_SCN_CNT_INITIALIZED_DATA -> 0x40L
+ | IMAGE_SCN_CNT_UNINITIALIZED_DATA -> 0x80L
+ | IMAGE_SCN_MEM_DISCARDABLE -> 0x2000000L
+ | IMAGE_SCN_MEM_SHARED -> 0x10000000L
+ | IMAGE_SCN_MEM_EXECUTE -> 0x20000000L
+ | IMAGE_SCN_MEM_READ -> 0x40000000L
+ | IMAGE_SCN_MEM_WRITE -> 0x80000000L)
+ characteristics)))
+ |]
+;;
+
+
+(*
+
+ "Thunk" is a misnomer here; the thunk RVA is the address of a word
+ that the loader will store an address into. The stored address is
+ the address of the imported object.
+
+ So if the imported object is X, and the thunk slot is Y, the loader
+ is doing "Y = &X" and returning &Y as the thunk RVA. To load datum X
+ after the imports are resolved, given the thunk RVA R, you load
+ **R.
+
+*)
+
+type pe_import =
+ {
+ pe_import_name_fixup: fixup;
+ pe_import_name: string;
+ pe_import_address_fixup: fixup;
+ }
+
+type pe_import_dll_entry =
+ {
+ pe_import_dll_name_fixup: fixup;
+ pe_import_dll_name: string;
+ pe_import_dll_ILT_fixup: fixup;
+ pe_import_dll_IAT_fixup: fixup;
+ pe_import_dll_imports: pe_import array;
+ }
+
+ (*
+
+ The import section .idata has a mostly self-contained table
+ structure. You feed it a list of DLL entries, each of which names
+ a DLL and lists symbols in the DLL to import.
+
+ For each named symbol, a 4-byte slot will be reserved in an
+ "import lookup table" (ILT, also in this section). The slot is
+ a pointer to a string in this section giving the name.
+
+ Immediately *after* the ILT, there is an "import address table" (IAT),
+ which is initially identical to the ILT. The loader replaces the entries
+ in the IAT slots with the imported pointers at runtime.
+
+ A central directory at the start of the section lists all the the import
+ thunk tables. Each entry in the import directory is 20 bytes (5 words)
+ but only the last 2 are used: the second last is a pointer to the string
+ name of the DLL in question (string also in this section) and the last is
+ a pointer to the import thunk table itself (also in this section).
+
+ Curiously, of the 5 documents I've consulted on the nature of the
+ first 3 fields, I find a variety of interpretations.
+
+ *)
+
+let pe_import_section
+ ~(import_dir_fixup:fixup)
+ ~(dlls:pe_import_dll_entry array)
+ : frag =
+
+ let form_dir_entry
+ (entry:pe_import_dll_entry)
+ : frag =
+ SEQ [|
+ (* Note: documented opinions vary greatly about whether the
+ first, last, or both of the slots in one of these rows points
+ to the RVA of the name/hint used to look the import up. This
+ table format is a mess! *)
+ WORD (TY_u32,
+ (rva
+ entry.pe_import_dll_ILT_fixup)); (* Import lookup table. *)
+ WORD (TY_u32, (IMM 0L)); (* Timestamp, unused. *)
+ WORD (TY_u32, (IMM 0x0L)); (* Forwarder chain, unused. *)
+ WORD (TY_u32, (rva entry.pe_import_dll_name_fixup));
+ WORD (TY_u32,
+ (rva
+ entry.pe_import_dll_IAT_fixup)); (* Import address table.*)
+ |]
+ in
+
+ let form_ILT_slot
+ (import:pe_import)
+ : frag =
+ (WORD (TY_u32, (rva import.pe_import_name_fixup)))
+ in
+
+ let form_IAT_slot
+ (import:pe_import)
+ : frag =
+ (DEF (import.pe_import_address_fixup,
+ (WORD (TY_u32, (rva import.pe_import_name_fixup)))))
+ in
+
+ let form_tables_for_dll
+ (dll:pe_import_dll_entry)
+ : frag =
+ let terminator = WORD (TY_u32, (IMM 0L)) in
+ let ilt =
+ SEQ [|
+ SEQ (Array.map form_ILT_slot dll.pe_import_dll_imports);
+ terminator
+ |]
+ in
+ let iat =
+ SEQ [|
+ SEQ (Array.map form_IAT_slot dll.pe_import_dll_imports);
+ terminator
+ |]
+ in
+ if Array.length dll.pe_import_dll_imports < 1
+ then bug () "Pe.form_tables_for_dll: empty imports"
+ else
+ SEQ [|
+ DEF (dll.pe_import_dll_ILT_fixup, ilt);
+ DEF (dll.pe_import_dll_IAT_fixup, iat)
+ |]
+
+ in
+
+ let form_import_string
+ (import:pe_import)
+ : frag =
+ DEF
+ (import.pe_import_name_fixup,
+ SEQ [|
+ (* import string entries begin with a 2-byte "hint", but we just
+ set it to zero. *)
+ (WORD (TY_u16, (IMM 0L)));
+ ZSTRING import.pe_import_name;
+ (if String.length import.pe_import_name mod 2 == 0
+ then PAD 1
+ else PAD 0)
+ |])
+ in
+
+ let form_dir_entry_string
+ (dll:pe_import_dll_entry)
+ : frag =
+ DEF
+ (dll.pe_import_dll_name_fixup,
+ SEQ [| ZSTRING dll.pe_import_dll_name;
+ (if String.length dll.pe_import_dll_name mod 2 == 0
+ then PAD 1
+ else PAD 0);
+ SEQ (Array.map form_import_string dll.pe_import_dll_imports) |])
+ in
+
+ let dir = SEQ (Array.map form_dir_entry dlls) in
+ let dir_terminator = PAD 20 in
+ let tables = SEQ (Array.map form_tables_for_dll dlls) in
+ let strings = SEQ (Array.map form_dir_entry_string dlls)
+ in
+ def_aligned
+ import_dir_fixup
+ (SEQ
+ [|
+ dir;
+ dir_terminator;
+ tables;
+ strings
+ |])
+
+;;
+
+type pe_export =
+ {
+ pe_export_name_fixup: fixup;
+ pe_export_name: string;
+ pe_export_address_fixup: fixup;
+ }
+;;
+
+let pe_export_section
+ ~(sess:Session.sess)
+ ~(export_dir_fixup:fixup)
+ ~(exports:pe_export array)
+ : frag =
+ Array.sort (fun a b -> compare a.pe_export_name b.pe_export_name) exports;
+ let export_addr_table_fixup = new_fixup "export address table" in
+ let export_addr_table =
+ DEF
+ (export_addr_table_fixup,
+ SEQ
+ (Array.map
+ (fun e -> (WORD (TY_u32, rva e.pe_export_address_fixup)))
+ exports))
+ in
+ let export_name_pointer_table_fixup =
+ new_fixup "export name pointer table"
+ in
+ let export_name_pointer_table =
+ DEF
+ (export_name_pointer_table_fixup,
+ SEQ
+ (Array.map
+ (fun e -> (WORD (TY_u32, rva e.pe_export_name_fixup)))
+ exports))
+ in
+ let export_name_table_fixup = new_fixup "export name table" in
+ let export_name_table =
+ DEF
+ (export_name_table_fixup,
+ SEQ
+ (Array.map
+ (fun e -> (DEF (e.pe_export_name_fixup,
+ (ZSTRING e.pe_export_name))))
+ exports))
+ in
+ let export_ordinal_table_fixup = new_fixup "export ordinal table" in
+ let export_ordinal_table =
+ DEF
+ (export_ordinal_table_fixup,
+ SEQ
+ (Array.mapi
+ (fun i _ -> (WORD (TY_u16, IMM (Int64.of_int (i)))))
+ exports))
+ in
+ let image_name_fixup = new_fixup "image name fixup" in
+ let n_exports = IMM (Int64.of_int (Array.length exports)) in
+ let export_dir_table =
+ SEQ [|
+ WORD (TY_u32, IMM 0L); (* Flags, reserved. *)
+ WORD (TY_u32, IMM 0L); (* Timestamp, unused. *)
+ WORD (TY_u16, IMM 0L); (* Major vers., unused *)
+ WORD (TY_u16, IMM 0L); (* Minor vers., unused *)
+ WORD (TY_u32, rva image_name_fixup); (* Name RVA. *)
+ WORD (TY_u32, IMM 1L); (* Ordinal base = 1. *)
+ WORD (TY_u32, n_exports); (* # entries in EAT. *)
+ WORD (TY_u32, n_exports); (* # entries in ENPT/EOT.*)
+ WORD (TY_u32, rva export_addr_table_fixup); (* EAT *)
+ WORD (TY_u32, rva export_name_pointer_table_fixup); (* ENPT *)
+ WORD (TY_u32, rva export_ordinal_table_fixup); (* EOT *)
+ |]
+ in
+ def_aligned export_dir_fixup
+ (SEQ [|
+ export_dir_table;
+ export_addr_table;
+ export_name_pointer_table;
+ export_ordinal_table;
+ DEF (image_name_fixup,
+ ZSTRING (Session.filename_of sess.Session.sess_out));
+ export_name_table
+ |])
+;;
+
+let pe_text_section
+ ~(sess:Session.sess)
+ ~(sem:Semant.ctxt)
+ ~(start_fixup:fixup option)
+ ~(rust_start_fixup:fixup option)
+ ~(main_fn_fixup:fixup option)
+ ~(text_fixup:fixup)
+ ~(crate_code:frag)
+ : frag =
+ let startup =
+ match (start_fixup, rust_start_fixup, main_fn_fixup) with
+ (None, _, _)
+ | (_, None, _)
+ | (_, _, None) -> MARK
+ | (Some start_fixup,
+ Some rust_start_fixup,
+ Some main_fn_fixup) ->
+ let e = X86.new_emitter_without_vregs () in
+ (*
+ * We are called from the Microsoft C library startup routine,
+ * and assumed to be stdcall; so we have to clean up our own
+ * stack before returning.
+ *)
+ X86.objfile_start e
+ ~start_fixup
+ ~rust_start_fixup
+ ~main_fn_fixup
+ ~crate_fixup: sem.Semant.ctxt_crate_fixup
+ ~indirect_start: true;
+ X86.frags_of_emitted_quads sess e;
+ in
+ def_aligned
+ text_fixup
+ (SEQ [|
+ startup;
+ crate_code
+ |])
+;;
+
+let rustrt_imports sem =
+ let make_imports_for_lib (lib, tab) =
+ {
+ pe_import_dll_name_fixup = new_fixup "dll name";
+ pe_import_dll_name = (match lib with
+ REQUIRED_LIB_rustrt -> "rustrt.dll"
+ | REQUIRED_LIB_crt -> "msvcrt.dll"
+ | REQUIRED_LIB_rust ls
+ | REQUIRED_LIB_c ls -> ls.required_libname);
+ pe_import_dll_ILT_fixup = new_fixup "dll ILT";
+ pe_import_dll_IAT_fixup = new_fixup "dll IAT";
+ pe_import_dll_imports =
+ Array.of_list
+ (List.map
+ begin
+ fun (name, fixup) ->
+ {
+ pe_import_name_fixup = new_fixup "import name";
+ pe_import_name = name;
+ pe_import_address_fixup = fixup;
+ }
+ end
+ (htab_pairs tab))
+ }
+ in
+ Array.of_list
+ (List.map
+ make_imports_for_lib
+ (htab_pairs sem.Semant.ctxt_native_required))
+;;
+
+
+let crate_exports (sem:Semant.ctxt) : pe_export array =
+ let export_sym (name, fixup) =
+ {
+ pe_export_name_fixup = new_fixup "export name fixup";
+ pe_export_name = name;
+ pe_export_address_fixup = fixup;
+ }
+ in
+ let export_seg (_, tab) =
+ Array.of_list (List.map export_sym (htab_pairs tab))
+ in
+ Array.concat
+ (List.map export_seg
+ (htab_pairs sem.Semant.ctxt_native_provided))
+;;
+
+
+let emit_file
+ (sess:Session.sess)
+ (crate:Ast.crate)
+ (code:Asm.frag)
+ (data:Asm.frag)
+ (sem:Semant.ctxt)
+ (dw:Dwarf.debug_records)
+ : unit =
+
+ let all_hdrs_fixup = new_fixup "all headers" in
+ let all_init_data_fixup = new_fixup "all initialized data" in
+ let loader_hdr_fixup = new_fixup "loader header" in
+ let import_dir_fixup = new_fixup "import directory" in
+ let export_dir_fixup = new_fixup "export directory" in
+ let text_fixup = new_fixup "text section" in
+ let bss_fixup = new_fixup "bss section" in
+ let data_fixup = new_fixup "data section" in
+ let image_fixup = new_fixup "image fixup" in
+ let symtab_fixup = new_fixup "symbol table" in
+ let strtab_fixup = new_fixup "string table" in
+ let note_rust_fixup = new_fixup ".note.rust section" in
+
+ let (start_fixup, rust_start_fixup) =
+ if sess.Session.sess_library_mode
+ then (None, None)
+ else
+ (Some (new_fixup "start"),
+ Some (Semant.require_native sem REQUIRED_LIB_rustrt "rust_start"))
+ in
+
+ let header = (pe_header
+ ~machine: IMAGE_FILE_MACHINE_I386
+ ~symbol_table_fixup: symtab_fixup
+ ~number_of_sections: 8L
+ ~number_of_symbols: 0L
+ ~loader_hdr_fixup: loader_hdr_fixup
+ ~characteristics:([IMAGE_FILE_EXECUTABLE_IMAGE;
+ IMAGE_FILE_LINE_NUMS_STRIPPED;
+ IMAGE_FILE_32BIT_MACHINE;]
+ @
+ (if sess.Session.sess_library_mode
+ then [ IMAGE_FILE_DLL ]
+ else [ ])))
+ in
+ let symtab =
+ (*
+ * We're not actually presenting a "symbol table", but wish to
+ * provide a "string table" which comes immediately *after* the
+ * symbol table. It's a violation of the PE spec to put one of
+ * these in an executable file (as opposed to just loadable) but
+ * it's necessary to communicate the debug section names to GDB,
+ * and nobody else complains.
+ *)
+ (def_aligned
+ symtab_fixup
+ (def_aligned
+ strtab_fixup
+ (SEQ
+ [|
+ WORD (TY_u32, (F_SZ strtab_fixup));
+ ZSTRING ".debug_aranges";
+ ZSTRING ".debug_pubnames";
+ ZSTRING ".debug_info";
+ ZSTRING ".debug_abbrev";
+ ZSTRING ".debug_line";
+ ZSTRING ".debug_frame";
+ ZSTRING ".note.rust";
+ |])))
+ in
+ let loader_header = (pe_loader_header
+ ~text_fixup
+ ~init_data_fixup: all_init_data_fixup
+ ~size_of_uninit_data: 0L
+ ~entry_point_fixup: start_fixup
+ ~image_fixup: image_fixup
+ ~subsys: IMAGE_SUBSYSTEM_WINDOWS_CUI
+ ~all_hdrs_fixup
+ ~loader_hdr_fixup
+ ~import_dir_fixup
+ ~export_dir_fixup)
+ in
+ let text_header = (pe_section_header
+ ~id: SECTION_ID_TEXT
+ ~hdr_fixup: text_fixup)
+
+ in
+ let bss_header = (pe_section_header
+ ~id: SECTION_ID_BSS
+ ~hdr_fixup: bss_fixup)
+ in
+ let import_section = (pe_import_section
+ ~import_dir_fixup
+ ~dlls: (rustrt_imports sem))
+ in
+ let import_header = (pe_section_header
+ ~id: SECTION_ID_IMPORTS
+ ~hdr_fixup: import_dir_fixup)
+ in
+ let export_section = (pe_export_section
+ ~sess
+ ~export_dir_fixup
+ ~exports: (crate_exports sem))
+ in
+ let export_header = (pe_section_header
+ ~id: SECTION_ID_EXPORTS
+ ~hdr_fixup: export_dir_fixup)
+ in
+ let data_header = (pe_section_header
+ ~id: SECTION_ID_DATA
+ ~hdr_fixup: data_fixup)
+ in
+(*
+ let debug_aranges_header =
+ (pe_section_header
+ ~id: SECTION_ID_DEBUG_ARANGES
+ ~hdr_fixup: sem.Semant.ctxt_debug_aranges_fixup)
+ in
+ let debug_pubnames_header =
+ (pe_section_header
+ ~id: SECTION_ID_DEBUG_PUBNAMES
+ ~hdr_fixup: sem.Semant.ctxt_debug_pubnames_fixup)
+ in
+*)
+ let debug_info_header = (pe_section_header
+ ~id: SECTION_ID_DEBUG_INFO
+ ~hdr_fixup: sem.Semant.ctxt_debug_info_fixup)
+ in
+ let debug_abbrev_header = (pe_section_header
+ ~id: SECTION_ID_DEBUG_ABBREV
+ ~hdr_fixup: sem.Semant.ctxt_debug_abbrev_fixup)
+ in
+(*
+ let debug_line_header =
+ (pe_section_header
+ ~id: SECTION_ID_DEBUG_LINE
+ ~hdr_fixup: sem.Semant.ctxt_debug_line_fixup)
+ in
+ let debug_frame_header =
+ (pe_section_header
+ ~id: SECTION_ID_DEBUG_FRAME
+ ~hdr_fixup: sem.Semant.ctxt_debug_frame_fixup)
+ in
+*)
+ let note_rust_header = (pe_section_header
+ ~id: SECTION_ID_NOTE_RUST
+ ~hdr_fixup: note_rust_fixup)
+ in
+ let all_headers = (def_file_aligned
+ all_hdrs_fixup
+ (SEQ
+ [|
+ pe_msdos_header_and_padding;
+ header;
+ loader_header;
+ text_header;
+ bss_header;
+ import_header;
+ export_header;
+ data_header;
+ (*
+ debug_aranges_header;
+ debug_pubnames_header;
+ *)
+ debug_info_header;
+ debug_abbrev_header;
+ (*
+ debug_line_header;
+ debug_frame_header;
+ *)
+ note_rust_header;
+ |]))
+ in
+
+ let text_section = (pe_text_section
+ ~sem
+ ~sess
+ ~start_fixup
+ ~rust_start_fixup
+ ~main_fn_fixup: sem.Semant.ctxt_main_fn_fixup
+ ~text_fixup
+ ~crate_code: code)
+ in
+ let bss_section = def_aligned bss_fixup (BSS 0x10L)
+ in
+ let data_section = (def_aligned data_fixup
+ (SEQ [| data; symtab; |]))
+ in
+ let all_init_data = (def_aligned
+ all_init_data_fixup
+ (SEQ [| import_section;
+ export_section;
+ data_section; |]))
+ in
+(*
+ let debug_aranges_section =
+ def_aligned sem.Semant.ctxt_debug_aranges_fixup dw.Dwarf.debug_aranges
+ in
+ let debug_pubnames_section =
+ def_aligned sem.Semant.ctxt_debug_pubnames_fixup dw.Dwarf.debug_pubnames
+ in
+*)
+ let debug_info_section =
+ def_aligned sem.Semant.ctxt_debug_info_fixup dw.Dwarf.debug_info
+ in
+ let debug_abbrev_section =
+ def_aligned sem.Semant.ctxt_debug_abbrev_fixup dw.Dwarf.debug_abbrev
+ in
+(*
+ let debug_line_section =
+ def_aligned sem.Semant.ctxt_debug_line_fixup dw.Dwarf.debug_line
+ in
+ let debug_frame_section =
+ def_aligned sem.Semant.ctxt_debug_frame_fixup dw.Dwarf.debug_frame
+ in
+*)
+ let note_rust_section =
+ def_aligned note_rust_fixup
+ (Asm.note_rust_frags crate.node.Ast.crate_meta)
+ in
+
+ let all_frags = SEQ [| MEMPOS pe_image_base;
+ (def_file_aligned image_fixup
+ (SEQ [| DEF (sem.Semant.ctxt_image_base_fixup,
+ MARK);
+ all_headers;
+ text_section;
+ bss_section;
+ all_init_data;
+ (* debug_aranges_section; *)
+ (* debug_pubnames_section; *)
+ debug_info_section;
+ debug_abbrev_section;
+ (* debug_line_section; *)
+ (* debug_frame_section; *)
+ note_rust_section;
+ ALIGN_MEM (pe_mem_alignment, MARK)
+ |]
+ )
+ )
+ |]
+ in
+ write_out_frag sess true all_frags
+;;
+
+let pe_magic = "PE";;
+
+let sniff
+ (sess:Session.sess)
+ (filename:filename)
+ : asm_reader option =
+ try
+ let stat = Unix.stat filename in
+ if (stat.Unix.st_kind = Unix.S_REG) &&
+ (stat.Unix.st_size >= pe_file_alignment)
+ then
+ let ar = new_asm_reader sess filename in
+ let _ = log sess "sniffing PE file" in
+ (* PE header offset is at 0x3c in the MS-DOS compatibility header. *)
+ let _ = ar.asm_seek 0x3c in
+ let pe_hdr_off = ar.asm_get_u32() in
+ let _ = log sess "PE header offset: 0x%x" pe_hdr_off in
+
+ let _ = ar.asm_seek pe_hdr_off in
+ let pe_signature = ar.asm_get_zstr_padded 4 in
+ let _ = log sess " PE signature: '%s'" pe_signature in
+ if pe_signature = pe_magic
+ then (ar.asm_seek 0; Some ar)
+ else None
+ else
+ None
+ with
+ _ -> None
+;;
+
+
+let get_sections
+ (sess:Session.sess)
+ (ar:asm_reader)
+ : (string,(int*int)) Hashtbl.t =
+ let _ = log sess "reading sections" in
+ (* PE header offset is at 0x3c in the MS-DOS compatibility header. *)
+ let _ = ar.asm_seek 0x3c in
+ let pe_hdr_off = ar.asm_get_u32() in
+ let _ = log sess "PE header offset: 0x%x" pe_hdr_off in
+
+ let _ = ar.asm_seek pe_hdr_off in
+ let pe_signature = ar.asm_get_zstr_padded 4 in
+ let _ = log sess " PE signature: '%s'" pe_signature in
+ let _ = assert (pe_signature = pe_magic) in
+ let _ = ar.asm_adv_u16() in (* machine type *)
+
+ let num_sections = ar.asm_get_u16() in
+ let _ = log sess " num sections: %d" num_sections in
+
+ let _ = ar.asm_adv_u32() in (* timestamp *)
+
+ let symtab_off = ar.asm_get_u32() in
+ let _ = log sess " symtab offset: 0x%x" symtab_off in
+
+ let num_symbols = ar.asm_get_u32() in
+ let _ = log sess " num symbols: %d" num_symbols in
+
+ let loader_hdr_size = ar.asm_get_u16() in
+ let _ = log sess "loader header sz: %d" loader_hdr_size in
+
+ let _ = ar.asm_adv_u16() in (* flags *)
+ let sections_off = (ar.asm_get_off()) + loader_hdr_size in
+
+ let sects = Hashtbl.create 0 in
+
+ let _ =
+ ar.asm_seek sections_off;
+ for i = 0 to (num_sections - 1) do
+ (*
+ * Section-name encoding is crazy. ASCII-encoding offsets of
+ * long names. See pe_section_header for details.
+ *)
+ let sect_name =
+ let sect_name = ar.asm_get_zstr_padded 8 in
+ assert ((String.length sect_name) > 0);
+ if sect_name.[0] = '/'
+ then
+ let off_str =
+ String.sub sect_name 1 ((String.length sect_name) - 1)
+ in
+ let i = int_of_string off_str in
+ let curr = ar.asm_get_off() in
+ ar.asm_seek (symtab_off + i);
+ let ext_name = ar.asm_get_zstr() in
+ ar.asm_seek curr;
+ ext_name
+ else
+ sect_name
+ in
+ let _ = ar.asm_adv_u32() in (* virtual size *)
+ let _ = ar.asm_adv_u32() in (* virtual address *)
+ let file_sz = ar.asm_get_u32() in
+ let file_off = ar.asm_get_u32() in
+ let _ = ar.asm_adv_u32() in (* reserved *)
+ let _ = ar.asm_adv_u32() in (* reserved *)
+ let _ = ar.asm_adv_u32() in (* reserved *)
+ let _ = ar.asm_adv_u32() in (* flags *)
+ Hashtbl.add sects sect_name (file_off, file_sz);
+ log sess " section %d: %s, size %d, offset 0x%x"
+ i sect_name file_sz file_off;
+ done
+ in
+ sects
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+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 =
+ let explicits =
+ match q.Il.quad_body with
+ Il.Jmp { Il.jmp_targ = Il.CodeLabel lab } -> [ lab ]
+ | _ -> []
+ in
+ explicits @ q.quad_implicits;
+;;
+
+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 } -> true
+ | Il.Ret -> true
+ | _ -> false
+;;
+
+let calculate_live_bitvectors
+ (cx:ctxt)
+ : ((Bits.t array) * (Bits.t array)) =
+
+ 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 (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_defined_vrs:Bits.t array) = Array.init n_quads new_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
+
+ let outer_changed = ref true in
+
+ (* Working bit-vector. *)
+ let scratch = new_bitv() 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_defined_vrs.(i) v true)
+ (quad_defined_vregs q)
+ done;
+
+ while !outer_changed do
+ iflog cx (fun _ -> log cx "iterating outer bitvector calculation");
+ outer_changed := false;
+ for i = 0 to n_quads - 1 do
+ Bits.clear live_in_vregs.(i);
+ Bits.clear live_out_vregs.(i)
+ done;
+ let inner_changed = ref true in
+ while !inner_changed do
+ inner_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 inner_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 defined = quad_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 defined);
+ Bits.invert scratch;
+ ignore (Bits.intersect scratch live_out);
+ note_change (Bits.union live_in scratch);
+
+ done
+ done;
+ let kill_mov_to_dead_target i q =
+ match q.Il.quad_body with
+ Il.Unary { Il.unary_op=uop;
+ Il.unary_dst=Il.Reg (Il.Vreg v, _) }
+ when
+ ((Il.is_mov uop) &&
+ not (Bits.get live_out_vregs.(i) v)) ->
+ begin
+ kill_quad i cx;
+ outer_changed := true;
+ end
+ | _ -> ()
+ in
+ Array.iteri kill_mov_to_dead_target quads
+ 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
+ log cx "[%s] %s %s" (padded_num i len) (padded_str lab (!maxlablen)) qs
+ done
+;;
+
+let calculate_vreg_constraints (cx:ctxt) : Bits.t array =
+ let abi = cx.ctxt_abi in
+ let n_vregs = cx.ctxt_n_vregs in
+ let n_hregs = abi.Abi.abi_n_hardregs in
+ let constraints = Array.init n_vregs (fun _ -> Bits.create n_hregs true) in
+ Array.iteri
+ begin
+ fun i q ->
+ 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 %d = %s"
+ i (string_of_quad hr_str q);
+ let qp_reg _ r =
+ begin
+ match r with
+ Il.Hreg _ -> ()
+ | Il.Vreg v ->
+ let hregs = Bits.to_list constraints.(v) 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;
+ end
+ cx.ctxt_quads;
+ constraints
+;;
+
+(* 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) =
+ Session.time_inner "RA liveness" sess
+ (fun _ -> calculate_live_bitvectors cx)
+ in
+ let (vreg_constraints:Bits.t array) = (* vreg idx -> hreg bits.t *)
+ calculate_vreg_constraints cx
+ 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)
+ 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
+ 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 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 = 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 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 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" s;
+ (quads, 0)
+
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(*
+ * x86/ia32 instructions have 6 parts:
+ *
+ * [pre][op][modrm][sib][disp][imm]
+ *
+ * [pre] = 0..4 bytes of prefix
+ * [op] = 1..3 byte opcode
+ * [modrm] = 0 or 1 byte: [mod:2][reg/op:3][r/m:3]
+ * [sib] = 0 or 1 byte: [scale:2][index:3][base:3]
+ * [disp] = 1, 2 or 4 byte displacement
+ * [imm] = 1, 2 or 4 byte immediate
+ *
+ * So between 1 and 17 bytes total.
+ *
+ * We're not going to use sib, but modrm is worth discussing.
+ *
+ * The high two bits of modrm denote an addressing mode. The modes are:
+ *
+ * 00 - "mostly" *(reg)
+ * 01 - "mostly" *(reg) + disp8
+ * 10 - "mostly" *(reg) + disp32
+ * 11 - reg
+ *
+ * The next-lowest 3 bits denote a specific register, or a subopcode if
+ * there is a fixed register or only one operand. The instruction format
+ * reference will say "/<n>" for some number n, if a fixed subopcode is used.
+ * It'll say "/r" if the instruction uses this field to specify a register.
+ *
+ * The registers specified in this field are:
+ *
+ * 000 - EAX or XMM0
+ * 001 - ECX or XMM1
+ * 010 - EDX or XMM2
+ * 011 - EBX or XMM3
+ * 100 - ESP or XMM4
+ * 101 - EBP or XMM5
+ * 110 - ESI or XMM6
+ * 111 - EDI or XMM7
+ *
+ * The final low 3 bits denote sub-modes of the primary mode selected
+ * with the top 2 bits. In particular, they "mostly" select the reg that is
+ * to be used for effective address calculation.
+ *
+ * For the most part, these follow the same numbering order: EAX, ECX, EDX,
+ * EBX, ESP, EBP, ESI, EDI. There are two unusual deviations from the rule
+ * though:
+ *
+ * - In primary modes 00, 01 and 10, r/m=100 means "use SIB byte". You can
+ * use (unscaled) ESP as the base register in these modes by appending the
+ * SIB byte 0x24. We do that in our rm_r operand-encoder function.
+ *
+ * - In primary mode 00, r/m=101 means "just disp32", no register is
+ * involved. There is no way to use EBP in primary mode 00. If you try, we
+ * just decay into a mode 01 with an appended 8-bit immediate displacement.
+ *
+ * Some opcodes are written 0xNN +rd. This means "we decided to chew up a
+ * whole pile of opcodes here, with each opcode including a hard-wired
+ * reference to a register". For example, POP is "0x58 +rd", which means that
+ * the 1-byte insns 0x58..0x5f are chewed up for "POP EAX" ... "POP EDI"
+ * (again, the canonical order of register numberings)
+ *)
+
+(*
+ * Notes on register availability of x86:
+ *
+ * There are 8 GPRs but we use 2 of them for specific purposes:
+ *
+ * - ESP always points to the current stack frame.
+ * - EBP always points to the current frame base.
+ *
+ * We tell IL that we have 6 GPRs then, and permit most register-register ops
+ * on any of these 6, mostly-unconstrained.
+ *
+ *)
+
+open Common;;
+
+exception Unrecognized
+;;
+
+let modrm m rm reg_or_subopcode =
+ if (((m land 0b11) != m) or
+ ((rm land 0b111) != rm) or
+ ((reg_or_subopcode land 0b111) != reg_or_subopcode))
+ then raise (Invalid_argument "X86.modrm_deref")
+ else
+ ((((m land 0b11) lsl 6)
+ lor
+ (rm land 0b111))
+ lor
+ ((reg_or_subopcode land 0b111) lsl 3))
+;;
+
+let modrm_deref_reg = modrm 0b00 ;;
+let modrm_deref_disp32 = modrm 0b00 0b101 ;;
+let modrm_deref_reg_plus_disp8 = modrm 0b01 ;;
+let modrm_deref_reg_plus_disp32 = modrm 0b10 ;;
+let modrm_reg = modrm 0b11 ;;
+
+let slash0 = 0;;
+let slash1 = 1;;
+let slash2 = 2;;
+let slash3 = 3;;
+let slash4 = 4;;
+let slash5 = 5;;
+let slash6 = 6;;
+let slash7 = 7;;
+
+
+(*
+ * Translate an IL-level hwreg number from 0..nregs into the 3-bit code number
+ * used through the mod r/m byte and /r sub-register specifiers of the x86
+ * ISA.
+ *
+ * See "Table 2-2: 32-Bit Addressing Forms with the ModR/M Byte", in the IA32
+ * Architecture Software Developer's Manual, volume 2a.
+ *)
+
+let eax = 0
+let ecx = 1
+let ebx = 2
+let esi = 3
+let edi = 4
+let edx = 5
+let ebp = 6
+let esp = 7
+
+let code_eax = 0b000;;
+let code_ecx = 0b001;;
+let code_edx = 0b010;;
+let code_ebx = 0b011;;
+let code_esp = 0b100;;
+let code_ebp = 0b101;;
+let code_esi = 0b110;;
+let code_edi = 0b111;;
+
+let reg r =
+ match r with
+ 0 -> code_eax
+ | 1 -> code_ecx
+ | 2 -> code_ebx
+ | 3 -> code_esi
+ | 4 -> code_edi
+ | 5 -> code_edx
+ (* Never assigned by the register allocator, but synthetic code uses
+ them *)
+ | 6 -> code_ebp
+ | 7 -> code_esp
+ | _ -> raise (Invalid_argument "X86.reg")
+;;
+
+
+let dwarf_eax = 0;;
+let dwarf_ecx = 1;;
+let dwarf_edx = 2;;
+let dwarf_ebx = 3;;
+let dwarf_esp = 4;;
+let dwarf_ebp = 5;;
+let dwarf_esi = 6;;
+let dwarf_edi = 7;;
+
+let dwarf_reg r =
+ match r with
+ 0 -> dwarf_eax
+ | 1 -> dwarf_ecx
+ | 2 -> dwarf_ebx
+ | 3 -> dwarf_esi
+ | 4 -> dwarf_edi
+ | 5 -> dwarf_edx
+ | 6 -> dwarf_ebp
+ | 7 -> dwarf_esp
+ | _ -> raise (Invalid_argument "X86.dwarf_reg")
+
+let reg_str r =
+ match r with
+ 0 -> "eax"
+ | 1 -> "ecx"
+ | 2 -> "ebx"
+ | 3 -> "esi"
+ | 4 -> "edi"
+ | 5 -> "edx"
+ | 6 -> "ebp"
+ | 7 -> "esp"
+ | _ -> raise (Invalid_argument "X86.reg_str")
+;;
+
+(* This is a basic ABI. You might need to customize it by platform. *)
+let (n_hardregs:int) = 6;;
+let (n_callee_saves:int) = 4;;
+
+
+let is_ty32 (ty:Il.scalar_ty) : bool =
+ match ty with
+ Il.ValTy (Il.Bits32) -> true
+ | Il.AddrTy _ -> true
+ | _ -> false
+;;
+
+let is_r32 (c:Il.cell) : bool =
+ match c with
+ Il.Reg (_, st) -> is_ty32 st
+ | _ -> false
+;;
+
+let is_rm32 (c:Il.cell) : bool =
+ match c with
+ Il.Mem (_, Il.ScalarTy st) -> is_ty32 st
+ | Il.Reg (_, st) -> is_ty32 st
+ | _ -> false
+;;
+
+let is_ty8 (ty:Il.scalar_ty) : bool =
+ match ty with
+ Il.ValTy (Il.Bits8) -> true
+ | _ -> false
+;;
+
+let is_m32 (c:Il.cell) : bool =
+ match c with
+ Il.Mem (_, Il.ScalarTy st) -> is_ty32 st
+ | _ -> false
+;;
+
+let is_m8 (c:Il.cell) : bool =
+ match c with
+ Il.Mem (_, Il.ScalarTy st) -> is_ty8 st
+ | _ -> false
+;;
+
+let is_ok_r8 (r:Il.hreg) : bool =
+ (r == eax || r == ebx || r == ecx || r == edx)
+;;
+
+let is_r8 (c:Il.cell) : bool =
+ match c with
+ Il.Reg (Il.Hreg r, st) when is_ok_r8 r -> is_ty8 st
+ | _ -> false
+;;
+
+let is_rm8 (c:Il.cell) : bool =
+ match c with
+ Il.Mem (_, Il.ScalarTy st) -> is_ty8 st
+ | _ -> is_r8 c
+;;
+
+let prealloc_quad (quad':Il.quad') : Il.quad' =
+ let target_cell reg c =
+ Il.Reg (Il.Hreg reg, Il.cell_scalar_ty c)
+ in
+ let target_operand reg op =
+ Il.Cell (Il.Reg (Il.Hreg reg, Il.operand_scalar_ty op))
+ in
+
+ let target_bin_to_hreg bin dst src =
+ { bin with
+ Il.binary_rhs = target_operand src bin.Il.binary_rhs;
+ Il.binary_lhs = target_operand dst bin.Il.binary_lhs;
+ Il.binary_dst = target_cell dst bin.Il.binary_dst }
+ in
+
+ let target_cmp cmp =
+ match cmp.Il.cmp_lhs with
+ (* Immediate LHS we force to eax. *)
+ Il.Imm _ ->
+ { cmp with
+ Il.cmp_lhs = target_operand eax cmp.Il.cmp_lhs }
+ | _ -> cmp
+ in
+
+ match quad' with
+ Il.Binary bin ->
+ begin
+ Il.Binary
+ begin
+ match bin.Il.binary_op with
+ Il.IMUL | Il.UMUL
+ | Il.IDIV | Il.UDIV -> target_bin_to_hreg bin eax ecx
+ | Il.IMOD | Il.UMOD -> target_bin_to_hreg bin eax ecx
+ | _ -> bin
+ end
+ end
+
+ | Il.Cmp cmp -> Il.Cmp (target_cmp cmp)
+
+ | Il.Call c ->
+ let ty = Il.cell_scalar_ty c.Il.call_dst in
+ Il.Call { c with
+ Il.call_dst = Il.Reg ((Il.Hreg eax), ty) }
+
+ | Il.Lea le ->
+ begin
+ match (le.Il.lea_dst, le.Il.lea_src) with
+ (Il.Reg (_, dst_ty), Il.ImmPtr _)
+ when is_ty32 dst_ty ->
+ Il.Lea { le with
+ Il.lea_dst = Il.Reg (Il.Hreg eax, dst_ty) }
+ | _ -> quad'
+ end
+
+ | x -> x
+;;
+
+let constrain_vregs (q:Il.quad) (hregs:Bits.t array) : unit =
+
+ let involves_8bit_cell =
+ let b = ref false in
+ let qp_cell _ c =
+ match c with
+ Il.Reg (_, Il.ValTy Il.Bits8)
+ | Il.Mem (_, Il.ScalarTy (Il.ValTy Il.Bits8)) ->
+ (b := true; c)
+ | _ -> c
+ in
+ ignore (Il.process_quad { Il.identity_processor with
+ Il.qp_cell_read = qp_cell;
+ Il.qp_cell_write = qp_cell } q);
+ !b
+ in
+
+ let qp_mem _ m = m in
+ let qp_cell _ c =
+ begin
+ match c with
+ Il.Reg (Il.Vreg v, _) when involves_8bit_cell ->
+ (* 8-bit register cells must only be al, cl, dl, bl.
+ * Not esi/edi. *)
+ let hv = hregs.(v) in
+ List.iter (fun bad -> Bits.set hv bad false) [esi; edi]
+ | _ -> ()
+ end;
+ c
+ in
+ begin
+ match q.Il.quad_body with
+ Il.Binary b ->
+ begin
+ match b.Il.binary_op with
+ (* Shifts *)
+ | Il.LSL | Il.LSR | Il.ASR ->
+ begin
+ match b.Il.binary_rhs with
+ Il.Cell (Il.Reg (Il.Vreg v, _)) ->
+ let hv = hregs.(v) in
+ (* Shift src has to be ecx. *)
+ List.iter
+ (fun bad -> Bits.set hv bad false)
+ [eax; edx; ebx; esi; edi]
+ | _ -> ()
+ end
+ | _ -> ()
+ end
+ | _ -> ()
+ end;
+ ignore
+ (Il.process_quad { Il.identity_processor with
+ Il.qp_mem = qp_mem;
+ Il.qp_cell_read = qp_cell;
+ Il.qp_cell_write = qp_cell } q)
+;;
+
+
+let clobbers (quad:Il.quad) : Il.hreg list =
+ match quad.Il.quad_body with
+ Il.Binary bin ->
+ begin
+ match bin.Il.binary_op with
+ Il.IMUL | Il.UMUL
+ | Il.IDIV | Il.UDIV -> [ edx ]
+ | Il.IMOD | Il.UMOD -> [ edx ]
+ | _ -> []
+ end
+ | Il.Unary un ->
+ begin
+ match un.Il.unary_op with
+ Il.ZERO -> [ eax; edi; ecx ]
+ | _ -> [ ]
+ end
+ | Il.Call _ -> [ eax; ecx; edx; ]
+ | Il.Regfence -> [ eax; ecx; ebx; edx; edi; esi; ]
+ | _ -> []
+;;
+
+
+let word_sz = 4L
+;;
+
+let word_bits = Il.Bits32
+;;
+
+let word_ty = TY_u32
+;;
+
+let annotate (e:Il.emitter) (str:string) =
+ Hashtbl.add e.Il.emit_annotations e.Il.emit_pc str
+;;
+
+let c (c:Il.cell) : Il.operand = Il.Cell c ;;
+let r (r:Il.reg) : Il.cell = Il.Reg ( r, (Il.ValTy word_bits) ) ;;
+let h (x:Il.hreg) : Il.reg = Il.Hreg x ;;
+let rc (x:Il.hreg) : Il.cell = r (h x) ;;
+let ro (x:Il.hreg) : Il.operand = c (rc x) ;;
+let vreg (e:Il.emitter) : (Il.reg * Il.cell) =
+ let vr = Il.next_vreg e in
+ (vr, (Il.Reg (vr, (Il.ValTy word_bits))))
+;;
+let imm (x:Asm.expr64) : Il.operand =
+ Il.Imm (x, word_ty)
+;;
+let immi (x:int64) : Il.operand =
+ imm (Asm.IMM x)
+;;
+
+let imm_byte (x:Asm.expr64) : Il.operand =
+ Il.Imm (x, TY_u8)
+;;
+let immi_byte (x:int64) : Il.operand =
+ imm_byte (Asm.IMM x)
+;;
+
+
+let byte_off_n (i:int) : Asm.expr64 =
+ Asm.IMM (Int64.of_int i)
+;;
+
+let byte_n (reg:Il.reg) (i:int) : Il.cell =
+ let imm = byte_off_n i in
+ let mem = Il.RegIn (reg, Some imm) in
+ Il.Mem (mem, Il.ScalarTy (Il.ValTy Il.Bits8))
+;;
+
+let word_off_n (i:int) : Asm.expr64 =
+ Asm.IMM (Int64.mul (Int64.of_int i) word_sz)
+;;
+
+let word_at (reg:Il.reg) : Il.cell =
+ let mem = Il.RegIn (reg, None) in
+ Il.Mem (mem, Il.ScalarTy (Il.ValTy word_bits))
+;;
+
+let word_at_off (reg:Il.reg) (off:Asm.expr64) : Il.cell =
+ let mem = Il.RegIn (reg, Some off) in
+ Il.Mem (mem, Il.ScalarTy (Il.ValTy word_bits))
+;;
+
+let word_n (reg:Il.reg) (i:int) : Il.cell =
+ word_at_off reg (word_off_n i)
+;;
+
+let reg_codeptr (reg:Il.reg) : Il.code =
+ Il.CodePtr (Il.Cell (Il.Reg (reg, Il.AddrTy Il.CodeTy)))
+;;
+
+let word_n_low_byte (reg:Il.reg) (i:int) : Il.cell =
+ let imm = word_off_n i in
+ let mem = Il.RegIn (reg, Some imm) in
+ Il.Mem (mem, Il.ScalarTy (Il.ValTy Il.Bits8))
+;;
+
+let wordptr_n (reg:Il.reg) (i:int) : Il.cell =
+ let imm = word_off_n i in
+ let mem = Il.RegIn (reg, Some imm) in
+ Il.Mem (mem, Il.ScalarTy (Il.AddrTy (Il.ScalarTy (Il.ValTy word_bits))))
+;;
+
+let get_element_ptr = Il.get_element_ptr word_bits reg_str ;;
+
+let save_callee_saves (e:Il.emitter) : unit =
+ Il.emit e (Il.Push (ro ebp));
+ Il.emit e (Il.Push (ro edi));
+ Il.emit e (Il.Push (ro esi));
+ Il.emit e (Il.Push (ro ebx));
+;;
+
+
+let restore_callee_saves (e:Il.emitter) : unit =
+ Il.emit e (Il.Pop (rc ebx));
+ Il.emit e (Il.Pop (rc esi));
+ Il.emit e (Il.Pop (rc edi));
+ Il.emit e (Il.Pop (rc ebp));
+;;
+
+
+(* restores registers from the frame base without updating esp:
+ * - sets ebp, edi, esi, ebx to stored values from frame base
+ * - sets `retpc' register to stored retpc from frame base
+ * - sets `base' register to current fp
+ *)
+let restore_frame_base (e:Il.emitter) (base:Il.reg) (retpc:Il.reg) : unit =
+ let emit = Il.emit e in
+ let mov dst src = emit (Il.umov dst src) in
+ mov (r base) (ro ebp);
+ mov (rc ebx) (c (word_at base));
+ mov (rc esi) (c (word_n base 1));
+ mov (rc edi) (c (word_n base 2));
+ mov (rc ebp) (c (word_n base 3));
+ mov (r retpc) (c (word_n base 4));
+;;
+
+
+(*
+ * Our arrangement on x86 is this:
+ *
+ * *ebp+20+(4*N) = [argN ]
+ * ...
+ * *ebp+24 = [arg1 ] = task ptr
+ * *ebp+20 = [arg0 ] = out ptr
+ * *ebp+16 = [retpc ]
+ * *ebp+12 = [old_ebp]
+ * *ebp+8 = [old_edi]
+ * *ebp+4 = [old_esi]
+ * *ebp = [old_ebx]
+ *
+ * For x86-cdecl:
+ *
+ * %eax, %ecx, %edx are "caller save" registers
+ * %ebp, %ebx, %esi, %edi are "callee save" registers
+ *
+ *)
+
+let frame_base_words = 5 (* eip,ebp,edi,esi,ebx *) ;;
+let frame_base_sz = Int64.mul (Int64.of_int frame_base_words) word_sz;;
+
+let frame_info_words = 2 (* crate ptr, crate-rel frame info disp *) ;;
+let frame_info_sz = Int64.mul (Int64.of_int frame_info_words) word_sz;;
+
+let implicit_arg_words = 2 (* task ptr,out ptr *);;
+let implicit_args_sz = Int64.mul (Int64.of_int implicit_arg_words) word_sz;;
+
+let out_ptr = wordptr_n (Il.Hreg ebp) (frame_base_words);;
+let task_ptr = wordptr_n (Il.Hreg ebp) (frame_base_words+1);;
+let ty_param_n i =
+ wordptr_n (Il.Hreg ebp) (frame_base_words + implicit_arg_words + i);;
+
+let spill_slot (i:Il.spill) : Il.mem =
+ let imm = (Asm.IMM
+ (Int64.neg
+ (Int64.add frame_info_sz
+ (Int64.mul word_sz
+ (Int64.of_int (i+1))))))
+ in
+ Il.RegIn ((Il.Hreg ebp), Some imm)
+;;
+
+
+let get_next_pc_thunk_fixup = new_fixup "glue$get_next_pc"
+;;
+
+let emit_get_next_pc_thunk (e:Il.emitter) : unit =
+ let sty = Il.AddrTy Il.CodeTy in
+ let rty = Il.ScalarTy sty in
+ let deref_esp = Il.Mem (Il.RegIn (Il.Hreg esp, None), rty) in
+ let eax = (Il.Reg (Il.Hreg eax, sty)) in
+ Il.emit_full e (Some get_next_pc_thunk_fixup) []
+ (Il.umov eax (Il.Cell deref_esp));
+ Il.emit e Il.Ret;
+;;
+
+let get_next_pc_thunk : (Il.reg * fixup * (Il.emitter -> unit)) =
+ (Il.Hreg eax, get_next_pc_thunk_fixup, emit_get_next_pc_thunk)
+;;
+
+let emit_c_call
+ (e:Il.emitter)
+ (ret:Il.cell)
+ (tmp1:Il.reg)
+ (tmp2:Il.reg)
+ (nabi:nabi)
+ (in_prologue:bool)
+ (fptr:Il.code)
+ (args:Il.operand array)
+ : unit =
+
+ let emit = Il.emit e in
+ let mov dst src = emit (Il.umov dst src) in
+ let binary op dst imm = emit (Il.binary op dst (c dst) (immi imm)) in
+
+ (* rust calls get task as arg0 *)
+ let args =
+ if nabi.nabi_convention = CONV_rust
+ then Array.append [| c task_ptr |] args
+ else args
+ in
+ let nargs = Array.length args in
+ let arg_sz = Int64.mul (Int64.of_int nargs) word_sz
+ in
+
+ mov (r tmp1) (c task_ptr); (* tmp1 = task from argv[-1] *)
+ mov (r tmp2) (ro esp); (* tmp2 = esp *)
+ mov (* task->rust_sp = tmp2 *)
+ (word_n tmp1 Abi.task_field_rust_sp)
+ (c (r tmp2));
+ mov (* esp = task->runtime_sp *)
+ (rc esp)
+ (c (word_n tmp1 Abi.task_field_runtime_sp));
+
+ binary Il.SUB (rc esp) arg_sz; (* make room on the stack *)
+ binary Il.AND (rc esp) (* and 16-byte align sp *)
+ 0xfffffffffffffff0L;
+
+ Array.iteri
+ begin
+ fun i (arg:Il.operand) -> (* write args to C stack *)
+ match arg with
+ Il.Cell (Il.Mem (a, ty)) ->
+ begin
+ match a with
+ Il.RegIn (Il.Hreg base, off) when base == esp ->
+ mov (r tmp1) (c (Il.Mem (Il.RegIn (tmp2, off), ty)));
+ mov (word_n (h esp) i) (c (r tmp1));
+ | _ ->
+ mov (r tmp1) arg;
+ mov (word_n (h esp) i) (c (r tmp1));
+ end
+ | _ ->
+ mov (word_n (h esp) i) arg
+ end
+ args;
+
+ match ret with
+ Il.Mem (Il.RegIn (Il.Hreg base, _), _) when base == esp ->
+ assert (not in_prologue);
+
+ (* If ret is esp-relative, use a temporary register until we
+ switched stacks. *)
+
+ emit (Il.call (r tmp1) fptr);
+ mov (r tmp2) (c task_ptr);
+ mov (rc esp) (c (word_n tmp2 Abi.task_field_rust_sp));
+ mov ret (c (r tmp1));
+
+ | _ when in_prologue ->
+ (*
+ * We have to do something a little surprising here:
+ * we're doing a 'grow' call so ebp is going to point
+ * into a dead stack frame on call-return. So we
+ * temporarily store task-ptr into ebp and then reload
+ * esp *and* ebp via ebp->rust_sp on the other side of
+ * the call.
+ *)
+ mov (rc ebp) (c task_ptr);
+ emit (Il.call ret fptr);
+ mov (rc esp) (c (word_n (h ebp) Abi.task_field_rust_sp));
+ mov (rc ebp) (ro esp);
+
+ | _ ->
+ emit (Il.call ret fptr);
+ mov (r tmp2) (c task_ptr);
+ mov (rc esp) (c (word_n tmp2 Abi.task_field_rust_sp));
+;;
+
+let emit_void_prologue_call
+ (e:Il.emitter)
+ (nabi:nabi)
+ (fn:fixup)
+ (args:Il.operand array)
+ : unit =
+ let callee = Abi.load_fixup_codeptr e (h eax) fn true nabi.nabi_indirect in
+ emit_c_call e (rc eax) (h edx) (h ecx) nabi true callee args
+;;
+
+let emit_native_call
+ (e:Il.emitter)
+ (ret:Il.cell)
+ (nabi:nabi)
+ (fn:fixup)
+ (args:Il.operand array)
+ : unit =
+
+ let (tmp1, _) = vreg e in
+ let (tmp2, _) = vreg e in
+ let (freg, _) = vreg e in
+ let callee = Abi.load_fixup_codeptr e freg fn true nabi.nabi_indirect in
+ emit_c_call e ret tmp1 tmp2 nabi false callee args
+;;
+
+let emit_native_void_call
+ (e:Il.emitter)
+ (nabi:nabi)
+ (fn:fixup)
+ (args:Il.operand array)
+ : unit =
+
+ let (ret, _) = vreg e in
+ emit_native_call e (r ret) nabi fn args
+;;
+
+let emit_native_call_in_thunk
+ (e:Il.emitter)
+ (ret:Il.cell)
+ (nabi:nabi)
+ (fn:Il.operand)
+ (args:Il.operand array)
+ : unit =
+
+ let emit = Il.emit e in
+ let mov dst src = emit (Il.umov dst src) in
+
+ begin
+ match fn with
+ (*
+ * NB: old path, remove when/if you're sure you don't
+ * want native-linker-symbol-driven requirements.
+ *)
+ Il.ImmPtr (fix, _) ->
+ let code =
+ Abi.load_fixup_codeptr e (h eax) fix true nabi.nabi_indirect
+ in
+ emit_c_call e (rc eax) (h edx) (h ecx) nabi false code args;
+
+ | _ ->
+ (*
+ * NB: new path, ignores nabi_indirect, assumes
+ * indirect via pointer from upcall_require_c_sym
+ * or crate cache.
+ *)
+ mov (rc eax) fn;
+ let cell = Il.Reg (h eax, Il.AddrTy Il.CodeTy) in
+ let fptr = Il.CodePtr (Il.Cell cell) in
+ emit_c_call e (rc eax) (h edx) (h ecx) nabi false fptr args;
+ end;
+
+ match ret with
+ Il.Reg (r, _) -> mov (word_at r) (ro eax)
+ | _ -> mov (rc edx) (c ret);
+ mov (word_at (h edx)) (ro eax)
+;;
+
+let unwind_glue
+ (e:Il.emitter)
+ (nabi:nabi)
+ (exit_task_fixup:fixup)
+ : unit =
+
+ let fp_n = word_n (Il.Hreg ebp) in
+ let edx_n = word_n (Il.Hreg edx) in
+ let emit = Il.emit e in
+ let mov dst src = emit (Il.umov dst src) in
+ let push x = emit (Il.Push x) in
+ let pop x = emit (Il.Pop x) in
+ let add x y = emit (Il.binary Il.ADD (rc x) (ro x) (ro y)) in
+ let codefix fix = Il.CodePtr (Il.ImmPtr (fix, Il.CodeTy)) in
+ let mark fix = Il.emit_full e (Some fix) [] Il.Dead in
+ let glue_field = Abi.frame_glue_fns_field_drop in
+
+ let repeat_jmp_fix = new_fixup "repeat jump" in
+ let skip_jmp_fix = new_fixup "skip jump" in
+ let exit_jmp_fix = new_fixup "exit jump" in
+
+ mov (rc edx) (c task_ptr); (* switch back to rust stack *)
+ mov
+ (rc esp)
+ (c (edx_n Abi.task_field_rust_sp));
+
+ mark repeat_jmp_fix;
+
+ mov (rc esi) (c (fp_n (-1))); (* esi <- crate ptr *)
+ mov (rc edx) (c (fp_n (-2))); (* edx <- frame glue functions. *)
+ emit (Il.cmp (ro edx) (immi 0L));
+
+ emit
+ (Il.jmp Il.JE
+ (codefix skip_jmp_fix)); (* if struct* is nonzero *)
+ add edx esi; (* add crate ptr to disp. *)
+ mov
+ (rc ecx)
+ (c (edx_n glue_field)); (* ecx <- drop glue *)
+ emit (Il.cmp (ro ecx) (immi 0L));
+
+ emit
+ (Il.jmp Il.JE
+ (codefix skip_jmp_fix)); (* if glue-fn is nonzero *)
+ add ecx esi; (* add crate ptr to disp. *)
+ push (ro ebp); (* frame-to-drop *)
+ push (c task_ptr); (* form usual call to glue *)
+ push (immi 0L); (* outptr *)
+ emit (Il.call (rc eax)
+ (reg_codeptr (h ecx))); (* call glue_fn, trashing eax. *)
+ pop (rc eax);
+ pop (rc eax);
+ pop (rc eax);
+
+ mark skip_jmp_fix;
+ mov (rc edx) (c (fp_n 3)); (* load next fp (callee-saves[3]) *)
+ emit (Il.cmp (ro edx) (immi 0L));
+ emit (Il.jmp Il.JE
+ (codefix exit_jmp_fix)); (* if nonzero *)
+ mov (rc ebp) (ro edx); (* move to next frame *)
+ emit (Il.jmp Il.JMP
+ (codefix repeat_jmp_fix)); (* loop *)
+
+ (* exit path. *)
+ mark exit_jmp_fix;
+
+ let callee =
+ Abi.load_fixup_codeptr
+ e (h eax) exit_task_fixup false nabi.nabi_indirect
+ in
+ emit_c_call
+ e (rc eax) (h edx) (h ecx) nabi false callee [| (c task_ptr) |];
+;;
+
+(* Puts result in eax; clobbers ecx, edx in the process. *)
+let rec calculate_sz (e:Il.emitter) (size:size) : unit =
+ let emit = Il.emit e in
+ let mov dst src = emit (Il.umov dst src) in
+ let push x = emit (Il.Push x) in
+ let pop x = emit (Il.Pop x) in
+ let neg x = emit (Il.unary Il.NEG (rc x) (ro x)) in
+ let bnot x = emit (Il.unary Il.NOT (rc x) (ro x)) in
+ let band x y = emit (Il.binary Il.AND (rc x) (ro x) (ro y)) in
+ let add x y = emit (Il.binary Il.ADD (rc x) (ro x) (ro y)) in
+ let mul x y = emit (Il.binary Il.UMUL (rc x) (ro x) (ro y)) in
+ let subi x y = emit (Il.binary Il.SUB (rc x) (ro x) (immi y)) in
+ let eax_gets_a_and_ecx_gets_b a b =
+ calculate_sz e b;
+ push (ro eax);
+ calculate_sz e a;
+ pop (rc ecx);
+ in
+ match size with
+ SIZE_fixed i ->
+ mov (rc eax) (immi i)
+
+ | SIZE_fixup_mem_sz f ->
+ mov (rc eax) (imm (Asm.M_SZ f))
+
+ | SIZE_fixup_mem_pos f ->
+ mov (rc eax) (imm (Asm.M_POS f))
+
+ | SIZE_param_size i ->
+ mov (rc eax) (Il.Cell (ty_param_n i));
+ mov (rc eax) (Il.Cell (word_n (h eax) Abi.tydesc_field_size))
+
+ | SIZE_param_align i ->
+ mov (rc eax) (Il.Cell (ty_param_n i));
+ mov (rc eax) (Il.Cell (word_n (h eax) Abi.tydesc_field_align))
+
+ | SIZE_rt_neg a ->
+ calculate_sz e a;
+ neg eax
+
+ | SIZE_rt_add (a, b) ->
+ eax_gets_a_and_ecx_gets_b a b;
+ add eax ecx
+
+ | SIZE_rt_mul (a, b) ->
+ eax_gets_a_and_ecx_gets_b a b;
+ mul eax ecx
+
+ | SIZE_rt_max (a, b) ->
+ eax_gets_a_and_ecx_gets_b a b;
+ emit (Il.cmp (ro eax) (ro ecx));
+ let jmp_pc = e.Il.emit_pc in
+ emit (Il.jmp Il.JAE Il.CodeNone);
+ mov (rc eax) (ro ecx);
+ Il.patch_jump e jmp_pc e.Il.emit_pc;
+
+ | SIZE_rt_align (align, off) ->
+ (*
+ * calculate off + pad where:
+ *
+ * pad = (align - (off mod align)) mod align
+ *
+ * In our case it's always a power of two,
+ * so we can just do:
+ *
+ * mask = align-1
+ * off += mask
+ * off &= ~mask
+ *
+ *)
+ eax_gets_a_and_ecx_gets_b off align;
+ subi ecx 1L;
+ add eax ecx;
+ bnot ecx;
+ band eax ecx;
+;;
+
+let rec size_calculation_stack_highwater (size:size) : int =
+ match size with
+ SIZE_fixed _
+ | SIZE_fixup_mem_sz _
+ | SIZE_fixup_mem_pos _
+ | SIZE_param_size _
+ | SIZE_param_align _ -> 0
+ | SIZE_rt_neg a ->
+ (size_calculation_stack_highwater a)
+ | SIZE_rt_max (a, b) ->
+ (size_calculation_stack_highwater a)
+ + (size_calculation_stack_highwater b)
+ | SIZE_rt_add (a, b)
+ | SIZE_rt_mul (a, b)
+ | SIZE_rt_align (a, b) ->
+ (size_calculation_stack_highwater a)
+ + (size_calculation_stack_highwater b)
+ + 1
+;;
+
+let boundary_sz =
+ (Asm.IMM
+ (Int64.add (* Extra non-frame room: *)
+ frame_base_sz (* to safely enter the next frame, *)
+ frame_base_sz)) (* and make a 'grow' upcall there. *)
+;;
+
+let stack_growth_check
+ (e:Il.emitter)
+ (nabi:nabi)
+ (grow_task_fixup:fixup)
+ (growsz:Il.operand)
+ (grow_jmp:Il.label option)
+ (restart_pc:Il.label)
+ (end_reg:Il.reg) (*
+ * stack limit on entry,
+ * new stack pointer on exit
+ *)
+ (tmp_reg:Il.reg) (* temporary (trashed) *)
+ : unit =
+ let emit = Il.emit e in
+ let mov dst src = emit (Il.umov dst src) in
+ let add dst src = emit (Il.binary Il.ADD dst (Il.Cell dst) src) in
+ let sub dst src = emit (Il.binary Il.SUB dst (Il.Cell dst) src) in
+ mov (r tmp_reg) (ro esp); (* tmp = esp *)
+ sub (r tmp_reg) growsz; (* tmp -= size-request *)
+ emit (Il.cmp (c (r end_reg)) (c (r tmp_reg)));
+ (*
+ * Jump *over* 'grow' upcall on non-underflow:
+ * if end_reg <= tmp_reg
+ *)
+
+ let bypass_grow_upcall_jmp_pc = e.Il.emit_pc in
+ emit (Il.jmp Il.JBE Il.CodeNone);
+
+ begin
+ match grow_jmp with
+ None -> ()
+ | Some j -> Il.patch_jump e j e.Il.emit_pc
+ end;
+ (* Extract growth-amount from tmp_reg. *)
+ mov (r end_reg) (ro esp);
+ sub (r end_reg) (c (r tmp_reg));
+ add (r end_reg) (Il.Imm (boundary_sz, word_ty));
+ (* Perform 'grow' upcall, then restart frame-entry. *)
+ emit_void_prologue_call e nabi grow_task_fixup [| c (r end_reg) |];
+ emit (Il.jmp Il.JMP (Il.CodeLabel restart_pc));
+ Il.patch_jump e bypass_grow_upcall_jmp_pc e.Il.emit_pc
+;;
+
+let fn_prologue
+ (e:Il.emitter)
+ (framesz:size)
+ (callsz:size)
+ (nabi:nabi)
+ (grow_task_fixup:fixup)
+ : unit =
+
+ let esi_n = word_n (h esi) in
+ let emit = Il.emit e in
+ let mov dst src = emit (Il.umov dst src) in
+ let add dst src = emit (Il.binary Il.ADD dst (Il.Cell dst) src) in
+ let sub dst src = emit (Il.binary Il.SUB dst (Il.Cell dst) src) in
+
+ (* We may be in a dynamic-sized frame. This makes matters complex,
+ * as we can't just perform a simple growth check in terms of a
+ * static size. The check is against a dynamic size, and we need to
+ * calculate that size.
+ *
+ * Unlike size-calculations in 'trans', we do not use vregs to
+ * calculate the frame size; instead we use a PUSH/POP stack-machine
+ * translation that doesn't disturb the registers we're
+ * somewhat-carefully *using* during frame setup.
+ *
+ * This only pushes the problem back a little ways though: we still
+ * need to be sure we have enough room to do the PUSH/POP
+ * calculation. We refer to this amount of space as the 'primordial'
+ * frame size, which can *thankfully* be calculated exactly from the
+ * arithmetic expression we're aiming to calculate. So we make room
+ * for the primordial frame, run the calculation of the full dynamic
+ * frame size, then make room *again* for this dynamic size.
+ *
+ * Our caller reserved enough room for us to push our own frame-base,
+ * as well as the frame-base that it will cost to do an upcall.
+ *)
+
+ (*
+ * After we save callee-saves, We have a stack like this:
+ *
+ * | ... |
+ * | caller frame |
+ * | + spill |
+ * | caller arg K |
+ * | ... |
+ * | caller arg 0 |
+ * | retpc | <-- sp we received, top of callee frame
+ * | callee save 1 |
+ * | ... |
+ * | callee save N | <-- ebp and esp after saving callee-saves
+ * | ... |
+ * | callee frame |
+ * | + spill |
+ * | callee arg J |
+ * | ... |
+ * | callee arg 0 | <-- bottom of callee frame
+ * | next retpc |
+ * | next save 1 |
+ * | ... |
+ * | next save N | <-- bottom of region we must reserve
+ * | ... |
+ *
+ * A "frame base" is the retpc and set of callee-saves.
+ *
+ * We need to reserve room for our frame *and* the next frame-base, because
+ * we're going to be blindly entering the next frame-base (pushing eip and
+ * callee-saves) before we perform the next check.
+ *)
+
+ (*
+ * We double the reserved callsz because we need a 'temporary tail-call
+ * region' above the actual call region, in case there's a drop call at the
+ * end of assembling the tail-call args and before copying them to callee
+ * position.
+ *)
+
+ let callsz = add_sz callsz callsz in
+ let n_glue_args = Int64.of_int Abi.worst_case_glue_call_args in
+ let n_glue_words = Int64.mul word_sz n_glue_args in
+
+ (*
+ * Add in *another* word to handle an extra-awkward spill of the
+ * callee address that might occur during an indirect tail call.
+ *)
+ let callsz = add_sz (SIZE_fixed word_sz) callsz in
+
+ (*
+ * Add in enough words for a glue-call (these occur underneath esp)
+ *)
+ let callsz = add_sz (SIZE_fixed n_glue_words) callsz in
+
+ (*
+ * Cumulative dynamic-frame size.
+ *)
+ let call_and_frame_sz = add_sz callsz framesz in
+
+ (* Already have room to save regs on entry. *)
+ save_callee_saves e;
+
+ let restart_pc = e.Il.emit_pc in
+
+ mov (rc ebp) (ro esp); (* Establish frame base. *)
+ mov (rc esi) (c task_ptr); (* esi = task *)
+ mov
+ (rc esi)
+ (c (esi_n Abi.task_field_stk)); (* esi = task->stk *)
+ add (rc esi) (imm
+ (Asm.ADD
+ ((word_off_n Abi.stk_field_data),
+ boundary_sz)));
+
+ let (dynamic_frame_sz, dynamic_grow_jmp) =
+ match Il.size_to_expr64 call_and_frame_sz with
+ None ->
+ begin
+ let primordial_frame_sz =
+ Asm.IMM
+ (Int64.mul word_sz
+ (Int64.of_int
+ (size_calculation_stack_highwater
+ call_and_frame_sz)))
+ in
+ (* Primordial size-check. *)
+ mov (rc edi) (ro esp); (* edi = esp *)
+ sub (* edi -= size-request *)
+ (rc edi)
+ (imm primordial_frame_sz);
+ emit (Il.cmp (ro esi) (ro edi));
+
+ (* Jump to 'grow' upcall on underflow: if esi (bottom) is >
+ edi (proposed-esp) *)
+
+ let primordial_underflow_jmp_pc = e.Il.emit_pc in
+ emit (Il.jmp Il.JA Il.CodeNone);
+
+ (* Calculate dynamic frame size. *)
+ calculate_sz e call_and_frame_sz;
+ ((ro eax), Some primordial_underflow_jmp_pc)
+ end
+ | Some e -> ((imm e), None)
+ in
+
+ (* "Full" frame size-check. *)
+ stack_growth_check e nabi grow_task_fixup
+ dynamic_frame_sz dynamic_grow_jmp restart_pc (h esi) (h edi);
+
+
+ (* Establish a frame, wherever we landed. *)
+ sub (rc esp) dynamic_frame_sz;
+
+ (* Zero the frame.
+ *
+ * FIXME: this is awful, will go away when we have proper CFI.
+ *)
+
+ mov (rc edi) (ro esp);
+ mov (rc ecx) dynamic_frame_sz;
+ emit (Il.unary Il.ZERO (word_at (h edi)) (ro ecx));
+
+ (* Move esp back up over the glue region. *)
+ add (rc esp) (immi n_glue_words);
+;;
+
+
+let fn_epilogue (e:Il.emitter) : unit =
+
+ (* Tear down existing frame. *)
+ let emit = Il.emit e in
+ let mov dst src = emit (Il.umov dst src) in
+ mov (rc esp) (ro ebp);
+ restore_callee_saves e;
+ emit Il.Ret;
+;;
+
+let inline_memcpy
+ (e:Il.emitter)
+ (n_bytes:int64)
+ (dst_ptr:Il.reg)
+ (src_ptr:Il.reg)
+ (tmp_reg:Il.reg)
+ (ascending:bool)
+ : unit =
+ let emit = Il.emit e in
+ let mov dst src = emit (Il.umov dst src) in
+ let bpw = Int64.to_int word_sz in
+ let w = Int64.to_int (Int64.div n_bytes word_sz) in
+ let b = Int64.to_int (Int64.rem n_bytes word_sz) in
+ if ascending
+ then
+ begin
+ for i = 0 to (w-1) do
+ mov (r tmp_reg) (c (word_n src_ptr i));
+ mov (word_n dst_ptr i) (c (r tmp_reg));
+ done;
+ for i = 0 to (b-1) do
+ let off = (w*bpw) + i in
+ mov (r tmp_reg) (c (byte_n src_ptr off));
+ mov (byte_n dst_ptr off) (c (r tmp_reg));
+ done;
+ end
+ else
+ begin
+ for i = (b-1) downto 0 do
+ let off = (w*bpw) + i in
+ mov (r tmp_reg) (c (byte_n src_ptr off));
+ mov (byte_n dst_ptr off) (c (r tmp_reg));
+ done;
+ for i = (w-1) downto 0 do
+ mov (r tmp_reg) (c (word_n src_ptr i));
+ mov (word_n dst_ptr i) (c (r tmp_reg));
+ done;
+ end
+;;
+
+
+
+let fn_tail_call
+ (e:Il.emitter)
+ (caller_callsz:int64)
+ (caller_argsz:int64)
+ (callee_code:Il.code)
+ (callee_argsz:int64)
+ : unit =
+ let emit = Il.emit e in
+ let binary op dst imm = emit (Il.binary op dst (c dst) (immi imm)) in
+ let mov dst src = emit (Il.umov dst src) in
+ let argsz_diff = Int64.sub caller_argsz callee_argsz in
+ let callee_spill_cell = word_at_off (h esp) (Asm.IMM caller_callsz) in
+
+ (*
+ * Our outgoing arguments were prepared in a region above the call region;
+ * this is reserved for the purpose of making tail-calls *only*, so we do
+ * not collide with glue calls we had to make while dropping the frame,
+ * after assembling our arg region.
+ *
+ * Thus, esp points to the "normal" arg region, and we need to move it
+ * to point to the tail-call arg region. To make matters simple, both
+ * regions are the same size, one atop the other.
+ *)
+
+ annotate e "tail call: move esp to temporary tail call arg-prep area";
+ binary Il.ADD (rc esp) caller_callsz;
+
+ (*
+ * If we're given a non-ImmPtr callee, we may need to move it to a known
+ * cell to avoid clobbering its register while we do the argument shuffle
+ * below.
+ *
+ * Sadly, we are too register-starved to just flush our callee to a reg;
+ * so we carve out an extra word of the temporary call-region and use
+ * it.
+ *
+ * This is ridiculous, but works.
+ *)
+ begin
+ match callee_code with
+ Il.CodePtr (Il.Cell c) ->
+ annotate e "tail call: spill callee-ptr to temporary memory";
+ mov callee_spill_cell (Il.Cell c);
+
+ | _ -> ()
+ end;
+
+ (* edx <- ebp; restore ebp, edi, esi, ebx; ecx <- retpc *)
+ annotate e "tail call: restore callee-saves from frame base";
+ restore_frame_base e (h edx) (h ecx);
+ (* move edx past frame base and adjust for difference in call sizes *)
+ annotate e "tail call: adjust temporary fp";
+ binary Il.ADD (rc edx) (Int64.add frame_base_sz argsz_diff);
+
+ (*
+ * stack grows downwards; copy from high to low
+ *
+ * bpw = word_sz
+ * w = floor(callee_argsz / word_sz)
+ * b = callee_argsz % word_sz
+ *
+ * byte copies:
+ * +------------------------+
+ * | |
+ * +------------------------+ <-- base + (w * word_sz) + (b - 1)
+ * . .
+ * +------------------------+
+ * | |
+ * +------------------------+ <-- base + (w * word_sz) + (b - b)
+ * word copies: =
+ * +------------------------+ <-- base + ((w-0) * word_sz)
+ * | bytes |
+ * | (w-1)*bpw..w*bpw-1 |
+ * +------------------------+ <-- base + ((w-1) * word_sz)
+ * | bytes |
+ * | (w-2)*bpw..(w-1)*bpw-1 |
+ * +------------------------+ <-- base + ((w-2) * word_sz)
+ * . .
+ * . .
+ * . .
+ * +------------------------+
+ * | bytes |
+ * | 0..bpw - 1 |
+ * +------------------------+ <-- base + ((w-w) * word_sz)
+ *)
+
+ annotate e "tail call: move arg-tuple up to top of frame";
+ (* NOTE: must copy top-to-bottom in case the regions overlap *)
+ inline_memcpy e callee_argsz (h edx) (h esp) (h eax) false;
+
+ (*
+ * We're done with eax now; so in the case where we had to spill
+ * our callee codeptr, we can reload it into eax here and rewrite
+ * our callee into *eax.
+ *)
+ let callee_code =
+ match callee_code with
+ Il.CodePtr (Il.Cell _) ->
+ annotate e "tail call: reload callee-ptr from temporary memory";
+ mov (rc eax) (Il.Cell callee_spill_cell);
+ reg_codeptr (h eax)
+
+ | _ -> callee_code
+ in
+
+
+ (* esp <- edx *)
+ annotate e "tail call: adjust stack pointer";
+ mov (rc esp) (ro edx);
+ (* PUSH ecx (retpc) *)
+ annotate e "tail call: push retpc";
+ emit (Il.Push (ro ecx));
+ (* JMP callee_code *)
+ emit (Il.jmp Il.JMP callee_code);
+;;
+
+
+let loop_info_field_retpc = 0;;
+let loop_info_field_sp = 1;;
+let loop_info_field_fp = 2;;
+
+let self_args_cell (self_args_rty:Il.referent_ty) : Il.cell =
+ Il.Mem (Il.RegIn (h ebp, Some (Asm.IMM frame_base_sz)), self_args_rty)
+;;
+
+let activate_glue (e:Il.emitter) : unit =
+ (*
+ * This is a bit of glue-code. It should be emitted once per
+ * compilation unit.
+ *
+ * - save regs on C stack
+ * - align sp on a 16-byte boundary
+ * - save sp to task.runtime_sp (runtime_sp is thus always aligned)
+ * - load saved task sp (switch stack)
+ * - restore saved task regs
+ * - return to saved task pc
+ *
+ * Our incoming stack looks like this:
+ *
+ * *esp+4 = [arg1 ] = task ptr
+ * *esp = [retpc ]
+ *)
+
+ let sp_n = word_n (Il.Hreg esp) in
+ let edx_n = word_n (Il.Hreg edx) in
+ let emit = Il.emit e in
+ let mov dst src = emit (Il.umov dst src) in
+ let binary op dst imm = emit (Il.binary op dst (c dst) (immi imm)) in
+
+ mov (rc edx) (c (sp_n 1)); (* edx <- task *)
+ save_callee_saves e;
+ mov
+ (edx_n Abi.task_field_runtime_sp)
+ (ro esp); (* task->runtime_sp <- esp *)
+ mov
+ (rc esp)
+ (c (edx_n Abi.task_field_rust_sp)); (* esp <- task->rust_sp *)
+
+ (*
+ * There are two paths we can arrive at this code from:
+ *
+ *
+ * 1. We are activating a task for the first time. When we switch into
+ * the task stack and 'ret' to its first instruction, we'll start
+ * doing whatever the first instruction says. Probably saving
+ * registers and starting to establish a frame. Harmless stuff,
+ * doesn't look at task->rust_sp again except when it clobbers it
+ * during a later upcall.
+ *
+ *
+ * 2. We are resuming a task that was descheduled by the yield glue
+ * below. When we switch into the task stack and 'ret', we'll be
+ * ret'ing to a very particular instruction:
+ *
+ * "esp <- task->rust_sp"
+ *
+ * this is the first instruction we 'ret' to after this glue, because
+ * it is the first instruction following *any* upcall, and the task
+ * we are activating was descheduled mid-upcall.
+ *
+ * Unfortunately for us, we have already restored esp from
+ * task->rust_sp and are about to eat the 5 words off the top of it.
+ *
+ *
+ * | ... | <-- where esp will be once we restore + ret, below,
+ * | retpc | and where we'd *like* task->rust_sp to wind up.
+ * | ebp |
+ * | edi |
+ * | esi |
+ * | ebx | <-- current task->rust_sp == current esp
+ *
+ *
+ * This is a problem. If we return to "esp <- task->rust_sp" it will
+ * push esp back down by 5 words. This manifests as a rust stack that
+ * grows by 5 words on each yield/reactivate. Not good.
+ *
+ * So what we do here is just adjust task->rust_sp up 5 words as
+ * well, to mirror the movement in esp we're about to perform. That
+ * way the "esp <- task->rust_sp" we 'ret' to below will be a
+ * no-op. Esp won't move, and the task's stack won't grow.
+ *)
+
+ binary Il.ADD (edx_n Abi.task_field_rust_sp)
+ (Int64.mul (Int64.of_int (n_callee_saves + 1)) word_sz);
+
+ (**** IN TASK STACK ****)
+ restore_callee_saves e;
+ emit Il.Ret;
+ (***********************)
+ ()
+;;
+
+let yield_glue (e:Il.emitter) : unit =
+
+ (* More glue code, this time the 'bottom half' of yielding.
+ *
+ * We arrived here because an upcall decided to deschedule the
+ * running task. So the upcall's return address got patched to the
+ * first instruction of this glue code.
+ *
+ * When the upcall does 'ret' it will come here, and its esp will be
+ * pointing to the last argument pushed on the C stack before making
+ * the upcall: the 0th argument to the upcall, which is always the
+ * task ptr performing the upcall. That's where we take over.
+ *
+ * Our goal is to complete the descheduling
+ *
+ * - Switch over to the task stack temporarily.
+ *
+ * - Save the task's callee-saves onto the task stack.
+ * (the task is now 'descheduled', safe to set aside)
+ *
+ * - Switch *back* to the C stack.
+ *
+ * - Restore the C-stack callee-saves.
+ *
+ * - Return to the caller on the C stack that activated the task.
+ *
+ *)
+ let esp_n = word_n (Il.Hreg esp) in
+ let edx_n = word_n (Il.Hreg edx) in
+ let emit = Il.emit e in
+ let mov dst src = emit (Il.umov dst src) in
+
+ mov
+ (rc edx) (c (esp_n 0)); (* edx <- arg0 (task) *)
+ mov
+ (rc esp)
+ (c (edx_n Abi.task_field_rust_sp)); (* esp <- task->rust_sp *)
+ save_callee_saves e;
+ mov (* task->rust_sp <- esp *)
+ (edx_n Abi.task_field_rust_sp)
+ (ro esp);
+ mov
+ (rc esp)
+ (c (edx_n Abi.task_field_runtime_sp)); (* esp <- task->runtime_sp *)
+
+ (**** IN C STACK ****)
+ restore_callee_saves e;
+ emit Il.Ret;
+ (***********************)
+ ()
+;;
+
+
+let push_pos32 (e:Il.emitter) (fix:fixup) : unit =
+ let (reg, _, _) = get_next_pc_thunk in
+ Abi.load_fixup_addr e reg fix Il.OpaqueTy;
+ Il.emit e (Il.Push (Il.Cell (Il.Reg (reg, Il.AddrTy Il.OpaqueTy))))
+;;
+
+let objfile_start
+ (e:Il.emitter)
+ ~(start_fixup:fixup)
+ ~(rust_start_fixup:fixup)
+ ~(main_fn_fixup:fixup)
+ ~(crate_fixup:fixup)
+ ~(indirect_start:bool)
+ : unit =
+ let ebp_n = word_n (Il.Hreg ebp) in
+ let emit = Il.emit e in
+ let mov dst src = emit (Il.umov dst src) in
+ let push_pos32 = push_pos32 e in
+ Il.emit_full e (Some start_fixup) [] Il.Dead;
+ save_callee_saves e;
+ mov (rc ebp) (ro esp);
+
+ (* If we're very lucky, the platform will have left us with
+ * something sensible in the startup stack like so:
+ *
+ * *ebp+24 = [arg1 ] = argv
+ * *ebp+20 = [arg0 ] = argc
+ * *ebp+16 = [retpc ]
+ * *ebp+12 = [old_ebp]
+ * *ebp+8 = [old_edi]
+ * *ebp+4 = [old_esi]
+ * *ebp = [old_ebx]
+ *
+ * This is not the case everywhere, but we start with this
+ * assumption and correct it in the runtime library.
+ *)
+
+ (* Copy argv. *)
+ mov (rc eax) (c (ebp_n (2 + n_callee_saves)));
+ Il.emit e (Il.Push (ro eax));
+
+ (* Copy argc. *)
+ mov (rc eax) (c (ebp_n (1 + n_callee_saves)));
+ Il.emit e (Il.Push (ro eax));
+
+ push_pos32 crate_fixup;
+ push_pos32 main_fn_fixup;
+ let fptr =
+ Abi.load_fixup_codeptr e (h eax) rust_start_fixup true indirect_start
+ in
+ Il.emit e (Il.call (rc eax) fptr);
+ Il.emit e (Il.Pop (rc ecx));
+ Il.emit e (Il.Pop (rc ecx));
+ Il.emit e (Il.Pop (rc ecx));
+ Il.emit e (Il.Pop (rc ecx));
+ Il.emit e (Il.umov (rc esp) (ro ebp));
+ restore_callee_saves e;
+ Il.emit e Il.Ret;
+;;
+
+let (abi:Abi.abi) =
+ {
+ Abi.abi_word_sz = word_sz;
+ Abi.abi_word_bits = word_bits;
+ Abi.abi_word_ty = word_ty;
+
+ Abi.abi_is_2addr_machine = true;
+ Abi.abi_has_pcrel_data = false;
+ Abi.abi_has_pcrel_code = true;
+
+ Abi.abi_n_hardregs = n_hardregs;
+ Abi.abi_str_of_hardreg = reg_str;
+ Abi.abi_prealloc_quad = prealloc_quad;
+ Abi.abi_constrain_vregs = constrain_vregs;
+
+ Abi.abi_emit_fn_prologue = fn_prologue;
+ Abi.abi_emit_fn_epilogue = fn_epilogue;
+ Abi.abi_emit_fn_tail_call = fn_tail_call;
+ Abi.abi_clobbers = clobbers;
+
+ Abi.abi_emit_native_call = emit_native_call;
+ Abi.abi_emit_native_void_call = emit_native_void_call;
+ Abi.abi_emit_native_call_in_thunk = emit_native_call_in_thunk;
+ Abi.abi_emit_inline_memcpy = inline_memcpy;
+
+ Abi.abi_activate = activate_glue;
+ Abi.abi_yield = yield_glue;
+ Abi.abi_unwind = unwind_glue;
+ Abi.abi_get_next_pc_thunk = Some get_next_pc_thunk;
+
+ Abi.abi_sp_reg = (Il.Hreg esp);
+ Abi.abi_fp_reg = (Il.Hreg ebp);
+ Abi.abi_dwarf_fp_reg = dwarf_ebp;
+ Abi.abi_tp_cell = task_ptr;
+ Abi.abi_frame_base_sz = frame_base_sz;
+ Abi.abi_frame_info_sz = frame_info_sz;
+ Abi.abi_implicit_args_sz = implicit_args_sz;
+ Abi.abi_spill_slot = spill_slot;
+ }
+
+
+(*
+ * NB: factor the instruction selector often. There's lots of
+ * semi-redundancy in the ISA.
+ *)
+
+
+let imm_is_signed_byte (n:int64) : bool =
+ (i64_le (-128L) n) && (i64_le n 127L)
+;;
+
+let imm_is_unsigned_byte (n:int64) : bool =
+ (i64_le (0L) n) && (i64_le n 255L)
+;;
+
+
+let rm_r (c:Il.cell) (r:int) : Asm.frag =
+ let reg_ebp = 6 in
+ let reg_esp = 7 in
+
+ (*
+ * We do a little contortion here to accommodate the special case of
+ * being asked to form esp-relative addresses; these require SIB
+ * bytes on x86. Of course!
+ *)
+ let sib_esp_base = Asm.BYTE 0x24 in
+ let seq1 rm modrm =
+ if rm = reg_esp
+ then Asm.SEQ [| modrm; sib_esp_base |]
+ else modrm
+ in
+ let seq2 rm modrm disp =
+ if rm = reg_esp
+ then Asm.SEQ [| modrm; sib_esp_base; disp |]
+ else Asm.SEQ [| modrm; disp |]
+ in
+
+ match c with
+ Il.Reg ((Il.Hreg rm), _) ->
+ Asm.BYTE (modrm_reg (reg rm) r)
+ | Il.Mem (a, _) ->
+ begin
+ match a with
+ Il.Abs disp ->
+ Asm.SEQ [| Asm.BYTE (modrm_deref_disp32 r);
+ Asm.WORD (TY_i32, disp) |]
+
+ | Il.RegIn ((Il.Hreg rm), None) when rm != reg_ebp ->
+ seq1 rm (Asm.BYTE (modrm_deref_reg (reg rm) r))
+
+ | Il.RegIn ((Il.Hreg rm), Some (Asm.IMM 0L))
+ when rm != reg_ebp ->
+ seq1 rm (Asm.BYTE (modrm_deref_reg (reg rm) r))
+
+ (* The next two are just to save the relaxation system some
+ * churn.
+ *)
+
+ | Il.RegIn ((Il.Hreg rm), Some (Asm.IMM n))
+ when imm_is_signed_byte n ->
+ seq2 rm
+ (Asm.BYTE (modrm_deref_reg_plus_disp8 (reg rm) r))
+ (Asm.WORD (TY_i8, Asm.IMM n))
+
+ | Il.RegIn ((Il.Hreg rm), Some (Asm.IMM n)) ->
+ seq2 rm
+ (Asm.BYTE (modrm_deref_reg_plus_disp32 (reg rm) r))
+ (Asm.WORD (TY_i32, Asm.IMM n))
+
+ | Il.RegIn ((Il.Hreg rm), Some disp) ->
+ Asm.new_relaxation
+ [|
+ seq2 rm
+ (Asm.BYTE (modrm_deref_reg_plus_disp32 (reg rm) r))
+ (Asm.WORD (TY_i32, disp));
+ seq2 rm
+ (Asm.BYTE (modrm_deref_reg_plus_disp8 (reg rm) r))
+ (Asm.WORD (TY_i8, disp))
+ |]
+ | _ -> raise Unrecognized
+ end
+ | _ -> raise Unrecognized
+;;
+
+
+let insn_rm_r (op:int) (c:Il.cell) (r:int) : Asm.frag =
+ Asm.SEQ [| Asm.BYTE op; rm_r c r |]
+;;
+
+
+let insn_rm_r_imm
+ (op:int)
+ (c:Il.cell)
+ (r:int)
+ (ty:ty_mach)
+ (i:Asm.expr64)
+ : Asm.frag =
+ Asm.SEQ [| Asm.BYTE op; rm_r c r; Asm.WORD (ty, i) |]
+;;
+
+let insn_rm_r_imm_s8_s32
+ (op8:int)
+ (op32:int)
+ (c:Il.cell)
+ (r:int)
+ (i:Asm.expr64)
+ : Asm.frag =
+ match i with
+ Asm.IMM n when imm_is_signed_byte n ->
+ insn_rm_r_imm op8 c r TY_i8 i
+ | _ ->
+ Asm.new_relaxation
+ [|
+ insn_rm_r_imm op32 c r TY_i32 i;
+ insn_rm_r_imm op8 c r TY_i8 i
+ |]
+;;
+
+let insn_rm_r_imm_u8_u32
+ (op8:int)
+ (op32:int)
+ (c:Il.cell)
+ (r:int)
+ (i:Asm.expr64)
+ : Asm.frag =
+ match i with
+ Asm.IMM n when imm_is_unsigned_byte n ->
+ insn_rm_r_imm op8 c r TY_u8 i
+ | _ ->
+ Asm.new_relaxation
+ [|
+ insn_rm_r_imm op32 c r TY_u32 i;
+ insn_rm_r_imm op8 c r TY_u8 i
+ |]
+;;
+
+
+let insn_pcrel_relax
+ (op8_frag:Asm.frag)
+ (op32_frag:Asm.frag)
+ (fix:fixup)
+ : Asm.frag =
+ let pcrel_mark_fixup = new_fixup "pcrel mark fixup" in
+ let def = Asm.DEF (pcrel_mark_fixup, Asm.MARK) in
+ let pcrel_expr = (Asm.SUB (Asm.M_POS fix,
+ Asm.M_POS pcrel_mark_fixup))
+ in
+ Asm.new_relaxation
+ [|
+ Asm.SEQ [| op32_frag; Asm.WORD (TY_i32, pcrel_expr); def |];
+ Asm.SEQ [| op8_frag; Asm.WORD (TY_i8, pcrel_expr); def |];
+ |]
+;;
+
+let insn_pcrel_simple (op32:int) (fix:fixup) : Asm.frag =
+ let pcrel_mark_fixup = new_fixup "pcrel mark fixup" in
+ let def = Asm.DEF (pcrel_mark_fixup, Asm.MARK) in
+ let pcrel_expr = (Asm.SUB (Asm.M_POS fix,
+ Asm.M_POS pcrel_mark_fixup))
+ in
+ Asm.SEQ [| Asm.BYTE op32; Asm.WORD (TY_i32, pcrel_expr); def |]
+;;
+
+let insn_pcrel (op8:int) (op32:int) (fix:fixup) : Asm.frag =
+ insn_pcrel_relax (Asm.BYTE op8) (Asm.BYTE op32) fix
+;;
+
+let insn_pcrel_prefix32
+ (op8:int)
+ (prefix32:int)
+ (op32:int)
+ (fix:fixup)
+ : Asm.frag =
+ insn_pcrel_relax (Asm.BYTE op8) (Asm.BYTES [| prefix32; op32 |]) fix
+;;
+
+(* FIXME: tighten imm-based dispatch by imm type. *)
+let cmp (a:Il.operand) (b:Il.operand) : Asm.frag =
+ match (a,b) with
+ (Il.Cell c, Il.Imm (i, TY_i8)) when is_rm8 c ->
+ insn_rm_r_imm 0x80 c slash7 TY_i8 i
+ | (Il.Cell c, Il.Imm (i, TY_u8)) when is_rm8 c ->
+ insn_rm_r_imm 0x80 c slash7 TY_u8 i
+ | (Il.Cell c, Il.Imm (i, _)) when is_rm32 c ->
+ (*
+ * NB: We can't switch on signed-ness here, as 'cmp' is
+ * defined to sign-extend its operand; i.e. we have to treat
+ * it as though you're emitting a signed byte (in the sense of
+ * immediate-size selection) even if the incoming value is
+ * unsigned.
+ *)
+ insn_rm_r_imm_s8_s32 0x83 0x81 c slash7 i
+ | (Il.Cell c, Il.Cell (Il.Reg (Il.Hreg r, _))) ->
+ insn_rm_r 0x39 c (reg r)
+ | (Il.Cell (Il.Reg (Il.Hreg r, _)), Il.Cell c) ->
+ insn_rm_r 0x3b c (reg r)
+ | _ -> raise Unrecognized
+;;
+
+let zero (dst:Il.cell) (count:Il.operand) : Asm.frag =
+ match (dst, count) with
+
+ ((Il.Mem (Il.RegIn ((Il.Hreg dst_ptr), None), _)),
+ Il.Cell (Il.Reg ((Il.Hreg count), _)))
+ when dst_ptr = edi && count = ecx ->
+ Asm.BYTES [|
+ 0xb0; 0x0; (* mov %eax, 0 : move a zero into al. *)
+ 0xf3; 0xaa; (* rep stos m8 : fill ecx bytes at [edi] with al *)
+ |]
+
+ | _ -> raise Unrecognized
+;;
+
+let mov (signed:bool) (dst:Il.cell) (src:Il.operand) : Asm.frag =
+ if is_ty8 (Il.cell_scalar_ty dst) || is_ty8 (Il.operand_scalar_ty src)
+ then
+ begin
+ (match dst with
+ Il.Reg (Il.Hreg r, _)
+ -> assert (is_ok_r8 r) | _ -> ());
+ (match src with
+ Il.Cell (Il.Reg (Il.Hreg r, _))
+ -> assert (is_ok_r8 r) | _ -> ());
+ end;
+
+ match (signed, dst, src) with
+
+ (* m8 <- r??, r8 or truncate(r32). *)
+ (_, _, Il.Cell (Il.Reg ((Il.Hreg r), _)))
+ when is_m8 dst ->
+ insn_rm_r 0x88 dst (reg r)
+
+ (* r8 <- r8: treat as r32 <- r32. *)
+ | (_, Il.Reg ((Il.Hreg r), _), Il.Cell src_cell)
+ when is_r8 dst && is_r8 src_cell ->
+ insn_rm_r 0x8b src_cell (reg r)
+
+ (* rm32 <- r32 *)
+ | (_, _, Il.Cell (Il.Reg ((Il.Hreg r), src_ty)))
+ when (is_r8 dst || is_rm32 dst) && is_ty32 src_ty ->
+ insn_rm_r 0x89 dst (reg r)
+
+ (* r32 <- rm32 *)
+ | (_, (Il.Reg ((Il.Hreg r), dst_ty)), Il.Cell src_cell)
+ when is_ty32 dst_ty && is_rm32 src_cell ->
+ insn_rm_r 0x8b src_cell (reg r)
+
+ (* MOVZX: r8/r32 <- zx(rm8) *)
+ | (false, Il.Reg ((Il.Hreg r, _)), Il.Cell src_cell)
+ when (is_r8 dst || is_r32 dst) && is_rm8 src_cell ->
+ Asm.SEQ [| Asm.BYTE 0x0f;
+ insn_rm_r 0xb6 src_cell (reg r) |]
+
+ (* MOVZX: m32 <- zx(r8) *)
+ | (false, _, (Il.Cell (Il.Reg ((Il.Hreg r), _) as src_cell)))
+ when (is_m32 dst) && is_r8 src_cell ->
+ (* Fake with 2 insns:
+ *
+ * movzx r32 <- r8; (in-place zero-extension)
+ * mov m32 <- r32; (NB: must happen in AL/CL/DL/BL)
+ *)
+ Asm.SEQ [| Asm.BYTE 0x0f;
+ insn_rm_r 0xb6 src_cell (reg r);
+ insn_rm_r 0x89 dst (reg r);
+ |]
+
+ (* MOVSX: r8/r32 <- sx(rm8) *)
+ | (true, Il.Reg ((Il.Hreg r), _), Il.Cell src_cell)
+ when (is_r8 dst || is_r32 dst) && is_rm8 src_cell ->
+ Asm.SEQ [| Asm.BYTE 0x0f;
+ insn_rm_r 0xbe src_cell (reg r) |]
+
+ (* MOVSX: m32 <- sx(r8) *)
+ | (true, _, (Il.Cell (Il.Reg ((Il.Hreg r), _) as src_cell)))
+ when (is_m32 dst) && is_r8 src_cell ->
+ (* Fake with 2 insns:
+ *
+ * movsx r32 <- r8; (in-place sign-extension)
+ * mov m32 <- r32; (NB: must happen in AL/CL/DL/BL)
+ *)
+ Asm.SEQ [| Asm.BYTE 0x0f;
+ insn_rm_r 0xbe src_cell (reg r);
+ insn_rm_r 0x89 dst (reg r);
+ |]
+
+ (* m8 <- imm8 (signed) *)
+ | (_, _, Il.Imm ((Asm.IMM n), _))
+ when is_m8 dst && imm_is_signed_byte n && signed ->
+ insn_rm_r_imm 0xc6 dst slash0 TY_i8 (Asm.IMM n)
+
+ (* m8 <- imm8 (unsigned) *)
+ | (_, _, Il.Imm ((Asm.IMM n), _))
+ when is_m8 dst && imm_is_unsigned_byte n && (not signed) ->
+ insn_rm_r_imm 0xc6 dst slash0 TY_u8 (Asm.IMM n)
+
+ (* rm32 <- imm32 *)
+ | (_, _, Il.Imm (i, _)) when is_rm32 dst || is_r8 dst ->
+ let t = if signed then TY_u32 else TY_i32 in
+ insn_rm_r_imm 0xc7 dst slash0 t i
+
+ | _ -> raise Unrecognized
+;;
+
+
+let lea (dst:Il.cell) (src:Il.operand) : Asm.frag =
+ match (dst, src) with
+ (Il.Reg ((Il.Hreg r), dst_ty),
+ Il.Cell (Il.Mem (mem, _)))
+ when is_ty32 dst_ty ->
+ insn_rm_r 0x8d (Il.Mem (mem, Il.OpaqueTy)) (reg r)
+
+ | (Il.Reg ((Il.Hreg r), dst_ty),
+ Il.ImmPtr (fix, _))
+ when is_ty32 dst_ty && r = eax ->
+ let anchor = new_fixup "anchor" in
+ let fix_off = Asm.SUB ((Asm.M_POS fix),
+ (Asm.M_POS anchor))
+ in
+ (* NB: These instructions must come as a
+ * cluster, w/o any separation.
+ *)
+ Asm.SEQ [|
+ insn_pcrel_simple 0xe8 get_next_pc_thunk_fixup;
+ Asm.DEF (anchor, insn_rm_r_imm 0x81 dst slash0 TY_i32 fix_off);
+ |]
+
+ | _ -> raise Unrecognized
+;;
+
+
+let select_insn_misc (q:Il.quad') : Asm.frag =
+
+ match q with
+ Il.Call c ->
+ begin
+ match c.Il.call_dst with
+ Il.Reg ((Il.Hreg dst), _) when dst = eax ->
+ begin
+ match c.Il.call_targ with
+
+ Il.CodePtr (Il.Cell c)
+ when Il.cell_referent_ty c
+ = Il.ScalarTy (Il.AddrTy Il.CodeTy) ->
+ insn_rm_r 0xff c slash2
+
+ | Il.CodePtr (Il.ImmPtr (f, Il.CodeTy)) ->
+ insn_pcrel_simple 0xe8 f
+
+ | _ -> raise Unrecognized
+ end
+ | _ -> raise Unrecognized
+ end
+
+ | Il.Push (Il.Cell (Il.Reg ((Il.Hreg r), t))) when is_ty32 t ->
+ Asm.BYTE (0x50 + (reg r))
+
+ | Il.Push (Il.Cell c) when is_rm32 c ->
+ insn_rm_r 0xff c slash6
+
+ | Il.Push (Il.Imm (Asm.IMM i, _)) when imm_is_unsigned_byte i ->
+ Asm.SEQ [| Asm.BYTE 0x6a; Asm.WORD (TY_u8, (Asm.IMM i)) |]
+
+ | Il.Push (Il.Imm (i, _)) ->
+ Asm.SEQ [| Asm.BYTE 0x68; Asm.WORD (TY_u32, i) |]
+
+ | Il.Pop (Il.Reg ((Il.Hreg r), t)) when is_ty32 t ->
+ Asm.BYTE (0x58 + (reg r))
+
+ | Il.Pop c when is_rm32 c ->
+ insn_rm_r 0x8f c slash0
+
+ | Il.Ret -> Asm.BYTE 0xc3
+
+ | Il.Jmp j ->
+ begin
+ match (j.Il.jmp_op, j.Il.jmp_targ) with
+
+ (Il.JMP, Il.CodePtr (Il.ImmPtr (f, Il.CodeTy))) ->
+ insn_pcrel 0xeb 0xe9 f
+
+ | (Il.JMP, Il.CodePtr (Il.Cell c))
+ when Il.cell_referent_ty c
+ = Il.ScalarTy (Il.AddrTy Il.CodeTy) ->
+ insn_rm_r 0xff c slash4
+
+ (* FIXME: refactor this to handle cell-based jumps
+ * if we ever need them. So far not. *)
+ | (_, Il.CodePtr (Il.ImmPtr (f, Il.CodeTy))) ->
+ let (op8, op32) =
+ match j.Il.jmp_op with
+ | Il.JC -> (0x72, 0x82)
+ | Il.JNC -> (0x73, 0x83)
+ | Il.JZ -> (0x74, 0x84)
+ | Il.JNZ -> (0x75, 0x85)
+ | Il.JO -> (0x70, 0x80)
+ | Il.JNO -> (0x71, 0x81)
+ | Il.JE -> (0x74, 0x84)
+ | Il.JNE -> (0x75, 0x85)
+
+ | Il.JL -> (0x7c, 0x8c)
+ | Il.JLE -> (0x7e, 0x8e)
+ | Il.JG -> (0x7f, 0x8f)
+ | Il.JGE -> (0x7d, 0x8d)
+
+ | Il.JB -> (0x72, 0x82)
+ | Il.JBE -> (0x76, 0x86)
+ | Il.JA -> (0x77, 0x87)
+ | Il.JAE -> (0x73, 0x83)
+ | _ -> raise Unrecognized
+ in
+ let prefix32 = 0x0f in
+ insn_pcrel_prefix32 op8 prefix32 op32 f
+
+ | _ -> raise Unrecognized
+ end
+
+ | Il.Dead -> Asm.MARK
+ | Il.Debug -> Asm.BYTES [| 0xcc |] (* int 3 *)
+ | Il.Regfence -> Asm.MARK
+ | Il.End -> Asm.BYTES [| 0x90 |]
+ | Il.Nop -> Asm.BYTES [| 0x90 |]
+ | _ -> raise Unrecognized
+;;
+
+
+type alu_binop_codes =
+ {
+ insn: string;
+ immslash: int; (* mod/rm "slash" code for imm-src variant *)
+ rm_dst_op8: int; (* opcode for 8-bit r/m dst variant *)
+ rm_dst_op32: int; (* opcode for 32-bit r/m dst variant *)
+ rm_src_op8: int; (* opcode for 8-bit r/m src variant *)
+ rm_src_op32: int; (* opcode for 32-bit r/m src variant *)
+ }
+;;
+
+let alu_binop
+ (dst:Il.cell) (src:Il.operand) (codes:alu_binop_codes)
+ : Asm.frag =
+ match (dst, src) with
+ (Il.Reg ((Il.Hreg r), dst_ty), Il.Cell c)
+ when (is_ty32 dst_ty && is_rm32 c) || (is_ty8 dst_ty && is_rm8 c)
+ -> insn_rm_r codes.rm_src_op32 c (reg r)
+
+ | (_, Il.Cell (Il.Reg ((Il.Hreg r), src_ty)))
+ when (is_rm32 dst && is_ty32 src_ty) || (is_rm8 dst && is_ty8 src_ty)
+ -> insn_rm_r codes.rm_dst_op32 dst (reg r)
+
+ | (_, Il.Imm (i, _)) when is_rm32 dst || is_rm8 dst
+ -> insn_rm_r_imm_s8_s32 0x83 0x81 dst codes.immslash i
+
+ | _ -> raise Unrecognized
+;;
+
+
+let mul_like (src:Il.operand) (signed:bool) (slash:int)
+ : Asm.frag =
+ match src with
+ Il.Cell src when is_rm32 src ->
+ insn_rm_r 0xf7 src slash
+
+ | Il.Cell src when is_rm8 src ->
+ insn_rm_r 0xf6 src slash
+
+ | Il.Imm (_, TY_u32)
+ | Il.Imm (_, TY_i32) ->
+ let tmp = Il.Reg ((Il.Hreg edx), Il.ValTy Il.Bits32) in
+ Asm.SEQ [| mov signed tmp src;
+ insn_rm_r 0xf7 tmp slash |]
+
+ | Il.Imm (_, TY_u8)
+ | Il.Imm (_, TY_i8) ->
+ let tmp = Il.Reg ((Il.Hreg edx), Il.ValTy Il.Bits8) in
+ Asm.SEQ [| mov signed tmp src;
+ insn_rm_r 0xf6 tmp slash |]
+
+ | _ -> raise Unrecognized
+;;
+
+
+let select_insn (q:Il.quad) : Asm.frag =
+ match q.Il.quad_body with
+ Il.Unary u ->
+ let unop s =
+ if u.Il.unary_src = Il.Cell u.Il.unary_dst
+ then insn_rm_r 0xf7 u.Il.unary_dst s
+ else raise Unrecognized
+ in
+ begin
+ match u.Il.unary_op with
+ Il.UMOV -> mov false u.Il.unary_dst u.Il.unary_src
+ | Il.IMOV -> mov true u.Il.unary_dst u.Il.unary_src
+ | Il.NEG -> unop slash3
+ | Il.NOT -> unop slash2
+ | Il.ZERO -> zero u.Il.unary_dst u.Il.unary_src
+ end
+
+ | Il.Lea le -> lea le.Il.lea_dst le.Il.lea_src
+
+ | Il.Cmp c -> cmp c.Il.cmp_lhs c.Il.cmp_rhs
+
+ | Il.Binary b ->
+ begin
+ if Il.Cell b.Il.binary_dst = b.Il.binary_lhs
+ then
+ let binop = alu_binop b.Il.binary_dst b.Il.binary_rhs in
+ let mulop = mul_like b.Il.binary_rhs in
+
+ let divop signed slash =
+ Asm.SEQ [|
+ (* xor edx edx, then mul_like. *)
+ insn_rm_r 0x33 (rc edx) (reg edx);
+ mul_like b.Il.binary_rhs signed slash
+ |]
+ in
+
+ let modop signed slash =
+ Asm.SEQ [|
+ (* divop, then mov remainder to eax instead. *)
+ divop signed slash;
+ mov false (rc eax) (ro edx)
+ |]
+ in
+
+ let shiftop slash =
+ let src = b.Il.binary_rhs in
+ let dst = b.Il.binary_dst in
+ let mask i = Asm.AND (i, Asm.IMM 0xffL) in
+ if is_rm8 dst
+ then
+ match src with
+ Il.Imm (i, _) ->
+ insn_rm_r_imm 0xC0 dst slash TY_u8 (mask i)
+ | Il.Cell (Il.Reg ((Il.Hreg r), _))
+ when r = ecx ->
+ Asm.SEQ [| Asm.BYTE 0xD2; rm_r dst slash |]
+ | _ -> raise Unrecognized
+ else
+ match src with
+ Il.Imm (i, _) ->
+ insn_rm_r_imm 0xC1 dst slash TY_u8 (mask i)
+ | Il.Cell (Il.Reg ((Il.Hreg r), _))
+ when r = ecx ->
+ Asm.SEQ [| Asm.BYTE 0xD3; rm_r dst slash |]
+ | _ -> raise Unrecognized
+ in
+
+ match (b.Il.binary_dst, b.Il.binary_op) with
+ (_, Il.ADD) -> binop { insn="ADD";
+ immslash=slash0;
+ rm_dst_op8=0x0;
+ rm_dst_op32=0x1;
+ rm_src_op8=0x2;
+ rm_src_op32=0x3; }
+ | (_, Il.SUB) -> binop { insn="SUB";
+ immslash=slash5;
+ rm_dst_op8=0x28;
+ rm_dst_op32=0x29;
+ rm_src_op8=0x2a;
+ rm_src_op32=0x2b; }
+ | (_, Il.AND) -> binop { insn="AND";
+ immslash=slash4;
+ rm_dst_op8=0x20;
+ rm_dst_op32=0x21;
+ rm_src_op8=0x22;
+ rm_src_op32=0x23; }
+ | (_, Il.OR) -> binop { insn="OR";
+ immslash=slash1;
+ rm_dst_op8=0x08;
+ rm_dst_op32=0x09;
+ rm_src_op8=0x0a;
+ rm_src_op32=0x0b; }
+ | (_, Il.XOR) -> binop { insn="XOR";
+ immslash=slash6;
+ rm_dst_op8=0x30;
+ rm_dst_op32=0x31;
+ rm_src_op8=0x32;
+ rm_src_op32=0x33; }
+
+ | (_, Il.LSL) -> shiftop slash4
+ | (_, Il.LSR) -> shiftop slash5
+ | (_, Il.ASR) -> shiftop slash7
+
+ | (Il.Reg (Il.Hreg r, t), Il.UMUL)
+ when (is_ty32 t || is_ty8 t) && r = eax ->
+ mulop false slash4
+
+ | (Il.Reg (Il.Hreg r, t), Il.IMUL)
+ when (is_ty32 t || is_ty8 t) && r = eax ->
+ mulop true slash5
+
+ | (Il.Reg (Il.Hreg r, t), Il.UDIV)
+ when (is_ty32 t || is_ty8 t) && r = eax ->
+ divop false slash6
+
+ | (Il.Reg (Il.Hreg r, t), Il.IDIV)
+ when (is_ty32 t || is_ty8 t) && r = eax ->
+ divop true slash7
+
+ | (Il.Reg (Il.Hreg r, t), Il.UMOD)
+ when (is_ty32 t || is_ty8 t) && r = eax ->
+ modop false slash6
+
+ | (Il.Reg (Il.Hreg r, t), Il.IMOD)
+ when (is_ty32 t || is_ty8 t) && r = eax ->
+ modop true slash7
+
+ | _ -> raise Unrecognized
+ else raise Unrecognized
+ end
+ | _ -> select_insn_misc q.Il.quad_body
+;;
+
+
+let new_emitter_without_vregs _ : Il.emitter =
+ Il.new_emitter
+ abi.Abi.abi_prealloc_quad
+ abi.Abi.abi_is_2addr_machine
+ false None
+;;
+
+let select_insns (sess:Session.sess) (q:Il.quads) : Asm.frag =
+ let scopes = Stack.create () in
+ let fixups = Stack.create () in
+ let pop_frags _ =
+ Asm.SEQ (Array.of_list
+ (List.rev
+ (!(Stack.pop scopes))))
+ in
+ ignore (Stack.push (ref []) scopes);
+ for i = 0 to (Array.length q) - 1 do
+ let append frag =
+ let frags = Stack.top scopes in
+ frags := frag :: (!frags)
+ in
+ begin
+ match q.(i).Il.quad_fixup with
+ None -> ()
+ | Some f -> append (Asm.DEF (f, Asm.MARK))
+ end;
+ begin
+ match q.(i).Il.quad_body with
+ Il.Enter f ->
+ Stack.push f fixups;
+ Stack.push (ref []) scopes;
+ | Il.Leave ->
+ append (Asm.DEF (Stack.pop fixups, pop_frags ()))
+ | _ ->
+ try
+ append (select_insn q.(i))
+ with
+ Unrecognized ->
+ Session.fail sess
+ "E:Assembly error: unrecognized quad: %s\n%!"
+ (Il.string_of_quad reg_str q.(i));
+ ()
+ end
+ done;
+ pop_frags()
+;;
+
+let frags_of_emitted_quads (sess:Session.sess) (e:Il.emitter) : Asm.frag =
+ let frag = select_insns sess e.Il.emit_quads in
+ if sess.Session.sess_failed
+ then raise Unrecognized
+ else frag
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+open Common;;
+
+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 ()
+;;
+
+(* FIXME: 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
+ 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
+ in
+ Some (ar, (get_sections sess ar))
+ end
+;;
+
+let get_meta
+ (sess:Session.sess)
+ (filename:filename)
+ : Ast.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)
+ (nref:node_id ref)
+ (oref:opaque_id ref)
+ : Ast.mod_items =
+ let dies = get_dies sess filename in
+ let items = Hashtbl.create 0 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)
+ (nref:node_id ref)
+ (oref:opaque_id ref)
+ : (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"
+ in
+ let rec meta_matches i f_meta =
+ if i >= (Array.length meta)
+ then true
+ else
+ match meta.(i) with
+ (* FIXME: 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 file = Unix.readdir dh in
+ log sess "considering file %s" file;
+ if (Filename.check_suffix file suffix) &&
+ (file_matches file)
+ then
+ begin
+ iflog sess
+ begin
+ fun _ ->
+ log sess "matched against library %s" file;
+ match get_meta sess file with
+ None -> ()
+ | Some meta ->
+ Array.iter
+ (fun (k,v) -> log sess "%s = %S" k v)
+ meta;
+ end;
+ Queue.add file 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 = Queue.pop found in
+ let items = get_file_mod sess abi filename nref oref 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"
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(*
+ * Glue for the LLVM backend.
+ *)
+
+let alt_argspecs sess = [
+ ("-llvm", Arg.Unit (fun _ -> sess.Session.sess_alt_backend <- true),
+ "emit LLVM bitcode")
+];;
+
+let alt_pipeline sess sem_cx crate =
+ let process processor =
+ processor sem_cx crate;
+ if sess.Session.sess_failed then exit 1 else ()
+ in
+ Array.iter process
+ [|
+ Resolve.process_crate;
+ Type.process_crate;
+ Effect.process_crate;
+ Typestate.process_crate;
+ Loop.process_crate;
+ Alias.process_crate;
+ Dead.process_crate;
+ Layout.process_crate
+ |];
+ Llemit.trans_and_process_crate sess sem_cx crate
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
+
--- /dev/null
+
+open Common;;
+
+let _ =
+ Gc.set { (Gc.get()) with
+ Gc.space_overhead = 400; }
+;;
+
+let (targ:Common.target) =
+ match Sys.os_type with
+ "Unix" ->
+ (* FIXME: this is an absurd heuristic. *)
+ if Sys.file_exists "/System/Library"
+ then MacOS_x86_macho
+ else Linux_x86_elf
+ | "Win32" -> Win32_x86_pe
+ | "Cygwin" -> Win32_x86_pe
+ | _ -> 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;
+ (* FIXME: 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_resolve = false;
+ Session.sess_log_type = false;
+ Session.sess_log_effect = 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_out = stdout;
+ 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_gc = false;
+ Session.sess_report_deps = false;
+ Session.sess_timings = Hashtbl.create 0;
+ Session.sess_lib_dirs = Queue.create ();
+ }
+;;
+
+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 -> ""
+ | 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 (ref (Node 0)) (ref (Opaque 0)) in
+ Printf.fprintf stdout "%s\n" (Ast.fmt_to_str Ast.fmt_mod_items items);
+ 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 flag f opt desc =
+ (opt, Arg.Unit f, desc)
+;;
+
+let argspecs =
+ [
+ ("-t", Arg.Symbol (["linux-x86-elf"; "win32-x86-pe"; "macos-x86-macho"],
+ fun s -> (sess.Session.sess_targ <-
+ (match s with
+ "win32-x86-pe" -> Win32_x86_pe
+ | "macos-x86-macho" -> MacOS_x86_macho
+ | _ -> 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"
+ ) ^ ")"));
+ ("-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_resolve <- true)
+ "-lresolve" "log resolution");
+ (flag (fun _ -> sess.Session.sess_log_type <- true)
+ "-ltype" "log type checking");
+ (flag (fun _ -> sess.Session.sess_log_effect <- true)
+ "-leffect" "log effect 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");
+
+ (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_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");
+ ] @ (Glue.alt_argspecs sess)
+;;
+
+let exit_if_failed _ =
+ if sess.Session.sess_failed
+ then exit 1
+ else ()
+;;
+
+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 (crate: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)
+ else
+ if Filename.check_suffix infile ".rs"
+ then
+ Cexp.parse_src_file sess
+ (Lib.get_mod sess abi)
+ (Lib.infer_lib_name sess)
+ else
+ begin
+ Printf.fprintf stderr
+ "Error: unrecognized input file type: %s\n"
+ infile;
+ exit 1
+ end
+ in
+ 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
+ | 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
+;;
+
+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" (Ast.fmt_to_str Ast.fmt_crate 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;
+ Type.process_crate;
+ Effect.process_crate;
+ Typestate.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 -> 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 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
+ in
+ Session.time_inner "emit" sess
+ (fun _ -> emitter sess crate code data sem_cx dwarf);
+ exit_if_failed ()
+;;
+
+if sess.Session.sess_alt_backend
+then Glue.alt_pipeline sess sem_cx crate
+else main_pipeline ()
+;;
+
+if sess.Session.sess_report_timing
+then
+ begin
+ Printf.fprintf stdout "timing:\n\n";
+ Array.iter
+ begin
+ fun name ->
+ Printf.fprintf stdout "%20s: %f\n" name
+ (Hashtbl.find sess.Session.sess_timings name)
+ end
+ (sorted_htab_keys sess.Session.sess_timings)
+ 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 ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(*
+ * 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 sess =
+{
+ mutable sess_in: filename option;
+ mutable sess_out: filename option;
+ mutable sess_library_mode: bool;
+ mutable sess_alt_backend: bool;
+ mutable sess_targ: target;
+ mutable sess_log_lex: bool;
+ mutable sess_log_parse: bool;
+ mutable sess_log_ast: bool;
+ mutable sess_log_resolve: bool;
+ mutable sess_log_type: bool;
+ mutable sess_log_effect: 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_out: 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_gc: bool;
+ mutable sess_report_deps: bool;
+ sess_timings: (string, float) Hashtbl.t;
+ sess_spans: (node_id,span) Hashtbl.t;
+ sess_lib_dirs: filename Queue.t;
+}
+;;
+
+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_out
+;;
+
+
+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
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(*
+ * 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 ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
+
--- /dev/null
+(*
+ * There are two kinds of rust files:
+ *
+ * .rc files, containing crates.
+ * .rs files, containing source.
+ *
+ *)
+
+open Common;;
+
+(*
+ * Slot names are given by a dot-separated path within the current
+ * module namespace.
+ *)
+
+type ident = string
+;;
+
+type slot_key =
+ KEY_ident of ident
+ | KEY_temp of temp_id
+;;
+
+(* "names" are statically computable references to particular items;
+ they never involve dynamic indexing (nor even static tuple-indexing;
+ you could add it but there are few contexts that need names that would
+ benefit from it).
+
+ Each component of a name may also be type-parametric; you must
+ supply type parameters to reference through a type-parametric name
+ component. So for example if foo is parametric in 2 types, you can
+ write foo[int,int].bar but not foo.bar.
+ *)
+
+type effect =
+ PURE
+ | IO
+ | STATE
+ | UNSAFE
+;;
+
+type name_base =
+ BASE_ident of ident
+ | BASE_temp of temp_id
+ | BASE_app of (ident * (ty array))
+
+and name_component =
+ COMP_ident of ident
+ | COMP_app of (ident * (ty array))
+ | COMP_idx of int
+
+and name =
+ NAME_base of name_base
+ | NAME_ext of (name * name_component)
+
+(*
+ * Type expressions are transparent to type names, their equality is
+ * structural. (after normalization)
+ *)
+and ty =
+
+ TY_any
+ | TY_nil
+ | TY_bool
+ | TY_mach of ty_mach
+ | TY_int
+ | TY_uint
+ | TY_char
+ | TY_str
+
+ | TY_tup of ty_tup
+ | TY_vec of slot
+ | TY_rec of ty_rec
+
+ (*
+ * Note that ty_idx is only valid inside a slot of a ty_iso group, not
+ * in a general type term.
+ *)
+ | TY_tag of ty_tag
+ | TY_iso of ty_iso
+ | TY_idx of int
+
+ | TY_fn of ty_fn
+ | TY_chan of ty
+ | TY_port of ty
+
+ | TY_obj of ty_obj
+ | TY_task
+
+ | TY_native of opaque_id
+ | TY_param of (ty_param_idx * effect)
+ | TY_named of name
+ | TY_type
+
+ | TY_constrained of (ty * constrs)
+
+and mode =
+ MODE_exterior
+ | MODE_interior
+ | MODE_alias
+
+and slot = { slot_mode: mode;
+ slot_mutable: bool;
+ slot_ty: ty option; }
+
+and ty_tup = slot array
+
+(* In closed type terms a constraint may refer to components of the term by
+ * anchoring off the "formal symbol" '*', which represents "the term this
+ * constraint is attached to".
+ *
+ *
+ * For example, if I have a tuple type tup(int,int), I may wish to enforce the
+ * lt predicate on it; I can write this as a constrained type term like:
+ *
+ * tup(int,int) : lt( *._0, *._1 )
+ *
+ * In fact all tuple types are converted to this form for purpose of
+ * type-compatibility testing; the argument tuple in a function
+ *
+ * fn (int x, int y) : lt(x, y) -> int
+ *
+ * desugars to
+ *
+ * fn (tup(int, int) : lt( *._1, *._2 )) -> int
+ *
+ *)
+
+and carg_base =
+ BASE_formal
+ | BASE_named of name_base
+
+and carg_path =
+ CARG_base of carg_base
+ | CARG_ext of (carg_path * name_component)
+
+and carg =
+ CARG_path of carg_path
+ | CARG_lit of lit
+
+and constr =
+ {
+ constr_name: name;
+ constr_args: carg array;
+ }
+
+and constrs = constr array
+
+and ty_rec = (ident * slot) array
+
+(* ty_tag is a sum type.
+ *
+ * a tag type expression either normalizes to a TY_tag or a TY_iso,
+ * which (like in ocaml) is an indexed projection from an iso-recursive
+ * group of TY_tags.
+ *)
+
+and ty_tag = (name, ty_tup) Hashtbl.t
+
+and ty_iso =
+ {
+ iso_index: int;
+ iso_group: ty_tag array
+ }
+
+and ty_sig =
+ {
+ sig_input_slots: slot array;
+ sig_input_constrs: constrs;
+ sig_output_slot: slot;
+ }
+
+and ty_fn_aux =
+ {
+ fn_is_iter: bool;
+ fn_effect: effect;
+ }
+
+and ty_fn = (ty_sig * ty_fn_aux)
+
+and ty_obj_header = (slot array * constrs)
+
+and ty_obj = (effect * ((ident,ty_fn) Hashtbl.t))
+
+and check_calls = (lval * (atom array)) array
+
+and rec_input = (ident * mode * bool * atom)
+
+and tup_input = (mode * bool * atom)
+
+and stmt' =
+
+ (* lval-assigning stmts. *)
+ STMT_spawn of (lval * domain * lval * (atom array))
+ | STMT_init_rec of (lval * (rec_input array) * lval option)
+ | STMT_init_tup of (lval * (tup_input array))
+ | STMT_init_vec of (lval * slot * (atom array))
+ | STMT_init_str of (lval * string)
+ | STMT_init_port of lval
+ | STMT_init_chan of (lval * (lval option))
+ | STMT_copy of (lval * expr)
+ | STMT_copy_binop of (lval * binop * atom)
+ | STMT_call of (lval * lval * (atom array))
+ | STMT_bind of (lval * lval * ((atom option) array))
+ | STMT_recv of (lval * lval)
+ | STMT_slice of (lval * lval * slice)
+
+ (* control-flow stmts. *)
+ | STMT_while of stmt_while
+ | STMT_do_while of stmt_while
+ | STMT_for of stmt_for
+ | STMT_for_each of stmt_for_each
+ | STMT_if of stmt_if
+ | STMT_put of (atom option)
+ | STMT_put_each of (lval * (atom array))
+ | STMT_ret of (atom option)
+ | STMT_be of (lval * (atom array))
+ | STMT_alt_tag of stmt_alt_tag
+ | STMT_alt_type of stmt_alt_type
+ | STMT_alt_port of stmt_alt_port
+
+ (* structural and misc stmts. *)
+ | STMT_fail
+ | STMT_yield
+ | STMT_join of lval
+ | STMT_send of (lval * lval)
+ | STMT_log of atom
+ | STMT_note of atom
+ | STMT_prove of (constrs)
+ | STMT_check of (constrs * check_calls)
+ | STMT_check_expr of expr
+ | STMT_check_if of (constrs * check_calls * block)
+ | STMT_block of block
+ | STMT_decl of stmt_decl
+
+and stmt = stmt' identified
+
+and stmt_alt_tag =
+ {
+ alt_tag_lval: lval;
+ alt_tag_arms: arm array;
+ }
+
+and stmt_alt_type =
+ {
+ alt_type_lval: lval;
+ alt_type_arms: (ident * slot * stmt) array;
+ alt_type_else: stmt option;
+ }
+
+and block' = stmt array
+and block = block' identified
+
+and stmt_decl =
+ DECL_mod_item of (ident * mod_item)
+ | DECL_slot of (slot_key * (slot identified))
+
+and stmt_alt_port =
+ {
+ (* else lval is a timeout value. *)
+ alt_port_arms: (lval * lval) array;
+ alt_port_else: (lval * stmt) option;
+ }
+
+and stmt_while =
+ {
+ while_lval: ((stmt array) * expr);
+ while_body: block;
+ }
+
+and stmt_for_each =
+ {
+ for_each_slot: (slot identified * ident);
+ for_each_call: (lval * atom array);
+ for_each_head: block;
+ for_each_body: block;
+ }
+
+and stmt_for =
+ {
+ for_slot: (slot identified * ident);
+ for_seq: ((stmt array) * lval);
+ for_body: block;
+ }
+
+and stmt_if =
+ {
+ if_test: expr;
+ if_then: block;
+ if_else: block option;
+ }
+
+and slice =
+ { slice_start: atom option;
+ slice_len: atom option; }
+
+and domain =
+ DOMAIN_local
+ | DOMAIN_thread
+
+and pat =
+ PAT_lit of lit
+ | PAT_tag of ident * (pat array)
+ | PAT_slot of ((slot identified) * ident)
+ | PAT_wild
+
+and arm' = pat * block
+and arm = arm' identified
+
+and atom =
+ ATOM_literal of (lit identified)
+ | ATOM_lval of lval
+
+and expr =
+ EXPR_binary of (binop * atom * atom)
+ | EXPR_unary of (unop * atom)
+ | EXPR_atom of atom
+
+and lit =
+ | LIT_nil
+ | LIT_bool of bool
+ | LIT_mach of (ty_mach * int64 * string)
+ | LIT_int of (int64 * string)
+ | LIT_uint of (int64 * string)
+ | LIT_char of int
+
+
+and lval_component =
+ COMP_named of name_component
+ | COMP_atom of atom
+
+
+and lval =
+ LVAL_base of name_base identified
+ | LVAL_ext of (lval * lval_component)
+
+and binop =
+ BINOP_or
+ | BINOP_and
+ | BINOP_xor
+
+ | BINOP_eq
+ | BINOP_ne
+
+ | BINOP_lt
+ | BINOP_le
+ | BINOP_ge
+ | BINOP_gt
+
+ | BINOP_lsl
+ | BINOP_lsr
+ | BINOP_asr
+
+ | BINOP_add
+ | BINOP_sub
+ | BINOP_mul
+ | BINOP_div
+ | BINOP_mod
+ | BINOP_send
+
+and unop =
+ UNOP_not
+ | UNOP_bitnot
+ | UNOP_neg
+ | UNOP_cast of ty identified
+
+
+and header_slots = ((slot identified) * ident) array
+
+and header_tup = (slot identified) array
+
+and fn =
+ {
+ fn_input_slots: header_slots;
+ fn_input_constrs: constrs;
+ fn_output_slot: slot identified;
+ fn_aux: ty_fn_aux;
+ fn_body: block;
+ }
+
+and obj =
+ {
+ obj_state: header_slots;
+ obj_effect: effect;
+ obj_constrs: constrs;
+ obj_fns: (ident,fn identified) Hashtbl.t;
+ obj_drop: block option;
+ }
+
+(*
+ * An 'a decl is a sort-of-thing that represents a parametric (generative)
+ * declaration. Every reference to one of these involves applying 0 or more
+ * type arguments, as part of *name resolution*.
+ *
+ * Slots are *not* parametric declarations. A slot has a specific type
+ * even if it's a type that's bound by a quantifier in its environment.
+ *)
+
+and ty_param = ident * (ty_param_idx * effect)
+
+and mod_item' =
+ MOD_ITEM_type of ty
+ | MOD_ITEM_tag of (header_tup * ty_tag * node_id)
+ | MOD_ITEM_mod of (mod_view * mod_items)
+ | MOD_ITEM_fn of fn
+ | MOD_ITEM_obj of obj
+
+and mod_item_decl =
+ {
+ decl_params: (ty_param identified) array;
+ decl_item: mod_item';
+ }
+
+and mod_item = mod_item_decl identified
+and mod_items = (ident, mod_item) Hashtbl.t
+
+and export =
+ EXPORT_all_decls
+ | EXPORT_ident of ident
+
+and mod_view =
+ {
+ view_imports: (ident, name) Hashtbl.t;
+ view_exports: (export, unit) Hashtbl.t;
+ }
+
+and meta = (ident * string) array
+
+and meta_pat = (ident * string option) array
+
+and crate' =
+ {
+ crate_items: (mod_view * mod_items);
+ crate_meta: meta;
+ crate_auth: (name, effect) Hashtbl.t;
+ crate_required: (node_id, (required_lib * nabi_conv)) Hashtbl.t;
+ crate_required_syms: (node_id, string) Hashtbl.t;
+ crate_files: (node_id,filename) Hashtbl.t;
+ crate_main: name option;
+ }
+and crate = crate' identified
+;;
+
+(*
+ * NB: names can only be type-parametric in their *last* path-entry.
+ * All path-entries before that must be ident or idx (non-parametric).
+ *)
+let sane_name (n:name) : bool =
+ let rec sane_prefix (n:name) : bool =
+ match n with
+ NAME_base (BASE_ident _)
+ | NAME_base (BASE_temp _) -> true
+ | NAME_ext (prefix, COMP_ident _)
+ | NAME_ext (prefix, COMP_idx _) -> sane_prefix prefix
+ | _ -> false
+ in
+ match n with
+ NAME_base _ -> true
+ | NAME_ext (prefix, _) -> sane_prefix prefix
+;;
+
+
+(***********************************************************************)
+
+(* FIXME (issue #19): finish all parts with ?foo? as their output. *)
+
+let fmt = Format.fprintf;;
+
+let fmt_ident (ff:Format.formatter) (i:ident) : unit =
+ fmt ff "%s" i
+
+let fmt_temp (ff:Format.formatter) (t:temp_id) : unit =
+ fmt ff ".t%d" (int_of_temp t)
+
+let fmt_slot_key ff (s:slot_key) : unit =
+ match s with
+ KEY_ident i -> fmt_ident ff i
+ | KEY_temp t -> fmt_temp ff t
+
+let rec fmt_app (ff:Format.formatter) (i:ident) (tys:ty array) : unit =
+ fmt ff "%s" i;
+ fmt_app_args ff tys
+
+and fmt_app_args (ff:Format.formatter) (tys:ty array) : unit =
+ fmt ff "[@[";
+ for i = 0 to (Array.length tys) - 1;
+ do
+ if i != 0
+ then fmt ff ",@ ";
+ fmt_ty ff tys.(i);
+ done;
+ fmt ff "@]]"
+
+and fmt_name_base (ff:Format.formatter) (nb:name_base) : unit =
+ match nb with
+ BASE_ident i -> fmt_ident ff i
+ | BASE_temp t -> fmt_temp ff t
+ | BASE_app (id, tys) -> fmt_app ff id tys
+
+and fmt_name_component (ff:Format.formatter) (nc:name_component) : unit =
+ match nc with
+ COMP_ident i -> fmt_ident ff i
+ | COMP_app (id, tys) -> fmt_app ff id tys
+ | COMP_idx i -> fmt ff "_%d" i
+
+and fmt_name (ff:Format.formatter) (n:name) : unit =
+ match n with
+ NAME_base nb -> fmt_name_base ff nb
+ | NAME_ext (n, nc) ->
+ fmt_name ff n;
+ fmt ff ".";
+ fmt_name_component ff nc
+
+and fmt_mutable (ff:Format.formatter) (m:bool) : unit =
+ if m
+ then fmt ff "mutable ";
+
+and fmt_mode (ff:Format.formatter) (m:mode) : unit =
+ match m with
+ MODE_exterior -> fmt ff "@@"
+ | MODE_alias -> fmt ff "&"
+ | MODE_interior -> ()
+
+and fmt_slot (ff:Format.formatter) (s:slot) : unit =
+ match s.slot_ty with
+ None -> fmt ff "auto"
+ | Some t ->
+ fmt_mutable ff s.slot_mutable;
+ fmt_mode ff s.slot_mode;
+ fmt_ty ff t
+
+and fmt_slots
+ (ff:Format.formatter)
+ (slots:slot array)
+ (idents:(ident array) option)
+ : unit =
+ fmt ff "(@[";
+ for i = 0 to (Array.length slots) - 1
+ do
+ if i != 0
+ then fmt ff ",@ ";
+ fmt_slot ff slots.(i);
+ begin
+ match idents with
+ None -> ()
+ | Some ids -> (fmt ff " "; fmt_ident ff ids.(i))
+ end;
+ done;
+ fmt ff "@])"
+
+and fmt_effect
+ (ff:Format.formatter)
+ (effect:effect)
+ : unit =
+ match effect with
+ PURE -> ()
+ | IO -> fmt ff "io"
+ | STATE -> fmt ff "state"
+ | UNSAFE -> fmt ff "unsafe"
+
+and fmt_ty_fn
+ (ff:Format.formatter)
+ (ident_and_params:(ident * ty_param array) option)
+ (tf:ty_fn)
+ : unit =
+ let (tsig, ta) = tf in
+ fmt_effect ff ta.fn_effect;
+ if ta.fn_effect <> PURE then fmt ff " ";
+ fmt ff "%s" (if ta.fn_is_iter then "iter" else "fn");
+ begin
+ match ident_and_params with
+ Some (id, params) ->
+ fmt ff " ";
+ fmt_ident_and_params ff id params
+ | None -> ()
+ end;
+ fmt_slots ff tsig.sig_input_slots None;
+ fmt_decl_constrs ff tsig.sig_input_constrs;
+ fmt ff " -> ";
+ fmt_slot ff tsig.sig_output_slot;
+
+and fmt_tag (ff:Format.formatter) (ttag:ty_tag) : unit =
+ fmt ff "@[tag(@[";
+ let first = ref true in
+ Hashtbl.iter
+ begin
+ fun name ttup ->
+ (if !first
+ then first := false
+ else fmt ff ",@ ");
+ fmt_name ff name;
+ fmt_slots ff ttup None
+ end
+ ttag;
+ fmt ff "@])@]"
+
+and fmt_iso (ff:Format.formatter) (tiso:ty_iso) : unit =
+ fmt ff "@[iso [@[";
+ for i = 0 to (Array.length tiso.iso_group) - 1
+ do
+ if i != 0
+ then fmt ff ",@ ";
+ if i == tiso.iso_index
+ then fmt ff "<%d>: " i
+ else fmt ff "%d: " i;
+ fmt_tag ff tiso.iso_group.(i);
+ done;
+ fmt ff "@]]@]"
+
+and fmt_ty (ff:Format.formatter) (t:ty) : unit =
+ match t with
+ TY_any -> fmt ff "any"
+ | TY_nil -> fmt ff "()"
+ | TY_bool -> fmt ff "bool"
+ | TY_mach m -> fmt_mach ff m
+ | TY_int -> fmt ff "int"
+ | TY_uint -> fmt ff "uint"
+ | TY_char -> fmt ff "char"
+ | TY_str -> fmt ff "str"
+
+ | TY_tup slots -> (fmt ff "tup"; fmt_slots ff slots None)
+ | TY_vec s -> (fmt ff "vec["; fmt_slot ff s; fmt ff "]")
+ | TY_chan t -> (fmt ff "chan["; fmt_ty ff t; fmt ff "]")
+ | TY_port t -> (fmt ff "port["; fmt_ty ff t; fmt ff "]")
+
+ | TY_rec slots ->
+ let (idents, slots) =
+ let (idents, slots) = List.split (Array.to_list slots) in
+ (Array.of_list idents, Array.of_list slots)
+ in
+ fmt ff "@[rec";
+ fmt_slots ff slots (Some idents);
+ fmt ff "@]"
+
+ | TY_param (i, e) -> (fmt_effect ff e;
+ if e <> PURE then fmt ff " ";
+ fmt ff "<p#%d>" i)
+ | TY_native oid -> fmt ff "<native#%d>" (int_of_opaque oid)
+ | TY_named n -> fmt_name ff n
+ | TY_type -> fmt ff "type"
+
+ | TY_fn tfn -> fmt_ty_fn ff None tfn
+ | TY_task -> fmt ff "task"
+ | TY_tag ttag -> fmt_tag ff ttag
+ | TY_iso tiso -> fmt_iso ff tiso
+ | TY_idx idx -> fmt ff "<idx#%d>" idx
+ | TY_constrained _ -> fmt ff "?constrained?"
+
+ | TY_obj (effect, fns) ->
+ fmt_obox ff;
+ fmt_effect ff effect;
+ if effect <> PURE then fmt ff " ";
+ fmt ff "obj ";
+ fmt_obr ff;
+ Hashtbl.iter
+ begin
+ fun id fn ->
+ fmt ff "@\n";
+ fmt_ty_fn ff (Some (id, [||])) fn;
+ fmt ff ";"
+ end
+ fns;
+ fmt_cbb ff
+
+
+and fmt_constrs (ff:Format.formatter) (cc:constr array) : unit =
+ Array.iter (fmt_constr ff) cc
+
+and fmt_decl_constrs (ff:Format.formatter) (cc:constr array) : unit =
+ if Array.length cc = 0
+ then ()
+ else
+ begin
+ fmt ff " : ";
+ fmt_constrs ff cc
+ end
+
+and fmt_constr (ff:Format.formatter) (c:constr) : unit =
+ fmt_name ff c.constr_name;
+ fmt ff "(@[";
+ for i = 0 to (Array.length c.constr_args) - 1
+ do
+ if i != 0
+ then fmt ff ",@ ";
+ fmt_carg ff c.constr_args.(i);
+ done;
+ fmt ff "@])"
+
+and fmt_carg_path (ff:Format.formatter) (cp:carg_path) : unit =
+ match cp with
+ CARG_base BASE_formal -> fmt ff "*"
+ | CARG_base (BASE_named nb) -> fmt_name_base ff nb
+ | CARG_ext (base, nc) ->
+ fmt_carg_path ff base;
+ fmt ff ".";
+ fmt_name_component ff nc
+
+and fmt_carg (ff:Format.formatter) (ca:carg) : unit =
+ match ca with
+ CARG_path cp -> fmt_carg_path ff cp
+ | CARG_lit lit -> fmt_lit ff lit
+
+and fmt_obox ff = Format.pp_open_box ff 4
+and fmt_obox_3 ff = Format.pp_open_box ff 3
+and fmt_cbox ff = Format.pp_close_box ff ()
+and fmt_obr ff = fmt ff "{"
+and fmt_cbr ff = fmt ff "@\n}"
+and fmt_cbb ff = (fmt_cbox ff; fmt_cbr ff)
+
+and fmt_stmts (ff:Format.formatter) (ss:stmt array) : unit =
+ Array.iter (fmt_stmt ff) ss;
+
+and fmt_block (ff:Format.formatter) (b:stmt array) : unit =
+ fmt_obox ff;
+ fmt_obr ff;
+ fmt_stmts ff b;
+ fmt_cbb ff;
+
+and fmt_binop (ff:Format.formatter) (b:binop) : unit =
+ fmt ff "%s"
+ begin
+ match b with
+ BINOP_or -> "|"
+ | BINOP_and -> "&"
+ | BINOP_xor -> "^"
+
+ | BINOP_eq -> "=="
+ | BINOP_ne -> "!="
+
+ | BINOP_lt -> "<"
+ | BINOP_le -> "<="
+ | BINOP_ge -> ">="
+ | BINOP_gt -> ">"
+
+ | BINOP_lsl -> "<<"
+ | BINOP_lsr -> ">>"
+ | BINOP_asr -> ">>>"
+
+ | BINOP_add -> "+"
+ | BINOP_sub -> "-"
+ | BINOP_mul -> "*"
+ | BINOP_div -> "/"
+ | BINOP_mod -> "%"
+ | BINOP_send -> "<|"
+ end
+
+
+and fmt_unop (ff:Format.formatter) (u:unop) (a:atom) : unit =
+ begin
+ match u with
+ UNOP_not ->
+ fmt ff "!";
+ fmt_atom ff a
+
+ | UNOP_bitnot ->
+ fmt ff "~";
+ fmt_atom ff a
+
+ | UNOP_neg ->
+ fmt ff "-";
+ fmt_atom ff a
+
+ | UNOP_cast t ->
+ fmt_atom ff a;
+ fmt ff " as ";
+ fmt_ty ff t.node;
+ end
+
+and fmt_expr (ff:Format.formatter) (e:expr) : unit =
+ match e with
+ EXPR_binary (b,a1,a2) ->
+ begin
+ fmt_atom ff a1;
+ fmt ff " ";
+ fmt_binop ff b;
+ fmt ff " ";
+ fmt_atom ff a2
+ end
+ | EXPR_unary (u,a) ->
+ begin
+ fmt_unop ff u a;
+ end
+ | EXPR_atom a -> fmt_atom ff a
+
+and fmt_mach (ff:Format.formatter) (m:ty_mach) : unit =
+ match m with
+ TY_u8 -> fmt ff "u8"
+ | TY_u16 -> fmt ff "u16"
+ | TY_u32 -> fmt ff "u32"
+ | TY_u64 -> fmt ff "u64"
+ | TY_i8 -> fmt ff "i8"
+ | TY_i16 -> fmt ff "i16"
+ | TY_i32 -> fmt ff "i32"
+ | TY_i64 -> fmt ff "i64"
+ | TY_f32 -> fmt ff "f32"
+ | TY_f64 -> fmt ff "f64"
+
+and fmt_lit (ff:Format.formatter) (l:lit) : unit =
+ match l with
+ | LIT_nil -> fmt ff "()"
+ | LIT_bool true -> fmt ff "true"
+ | LIT_bool false -> fmt ff "false"
+ | LIT_mach (m, _, s) ->
+ begin
+ fmt_mach ff m;
+ fmt ff "(%s)" s
+ end
+ | LIT_int (_,s) -> fmt ff "%s" s
+ | LIT_uint (_,s) -> fmt ff "%s" s
+ | LIT_char c -> fmt ff "'%s'" (Common.escaped_char c)
+
+and fmt_domain (ff:Format.formatter) (d:domain) : unit =
+ match d with
+ DOMAIN_local -> ()
+ | DOMAIN_thread -> fmt ff "thread "
+
+and fmt_atom (ff:Format.formatter) (a:atom) : unit =
+ match a with
+ ATOM_literal lit -> fmt_lit ff lit.node
+ | ATOM_lval lval -> fmt_lval ff lval
+
+and fmt_atoms (ff:Format.formatter) (az:atom array) : unit =
+ fmt ff "(";
+ Array.iteri
+ begin
+ fun i a ->
+ if i != 0
+ then fmt ff ", ";
+ fmt_atom ff a;
+ end
+ az;
+ fmt ff ")"
+
+and fmt_atom_opts (ff:Format.formatter) (az:(atom option) array) : unit =
+ fmt ff "(";
+ Array.iteri
+ begin
+ fun i a ->
+ if i != 0
+ then fmt ff ", ";
+ match a with
+ None -> fmt ff "_"
+ | Some a -> fmt_atom ff a;
+ end
+ az;
+ fmt ff ")"
+
+and fmt_lval_component (ff:Format.formatter) (lvc:lval_component) : unit =
+ match lvc with
+ COMP_named nc -> fmt_name_component ff nc
+ | COMP_atom a ->
+ begin
+ fmt ff "(";
+ fmt_atom ff a;
+ fmt ff ")"
+ end
+
+and fmt_lval (ff:Format.formatter) (l:lval) : unit =
+ match l with
+ LVAL_base nbi -> fmt_name_base ff nbi.node
+ | LVAL_ext (lv, lvc) ->
+ begin
+ fmt_lval ff lv;
+ fmt ff ".";
+ fmt_lval_component ff lvc
+ end
+
+and fmt_stmt (ff:Format.formatter) (s:stmt) : unit =
+ fmt ff "@\n";
+ fmt_stmt_body ff s
+
+and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
+ begin
+ match s.node with
+ STMT_log at ->
+ begin
+ fmt ff "log ";
+ fmt_atom ff at;
+ fmt ff ";"
+ end
+
+ | STMT_spawn (dst, domain, fn, args) ->
+ fmt_lval ff dst;
+ fmt ff " = spawn ";
+ fmt_domain ff domain;
+ fmt_lval ff fn;
+ fmt_atoms ff args;
+ fmt ff ";";
+
+ | STMT_while sw ->
+ let (stmts, e) = sw.while_lval in
+ begin
+ fmt_obox ff;
+ fmt ff "while (";
+ if Array.length stmts != 0
+ then fmt_block ff stmts;
+ fmt_expr ff e;
+ fmt ff ") ";
+ fmt_obr ff;
+ fmt_stmts ff sw.while_body.node;
+ fmt_cbb ff
+ end
+
+ | STMT_do_while sw ->
+ let (stmts, e) = sw.while_lval in
+ begin
+ fmt_obox ff;
+ fmt ff "do ";
+ fmt_obr ff;
+ fmt_stmts ff sw.while_body.node;
+ fmt ff "while (";
+ if Array.length stmts != 0
+ then fmt_block ff stmts;
+ fmt_expr ff e;
+ fmt ff ");";
+ fmt_cbb ff
+ end
+
+ | STMT_if sif ->
+ fmt_obox ff;
+ fmt ff "if (";
+ fmt_expr ff sif.if_test;
+ fmt ff ") ";
+ fmt_obr ff;
+ fmt_stmts ff sif.if_then.node;
+ begin
+ match sif.if_else with
+ None -> ()
+ | Some e ->
+ begin
+ fmt_cbb ff;
+ fmt_obox_3 ff;
+ fmt ff " else ";
+ fmt_obr ff;
+ fmt_stmts ff e.node
+ end
+ end;
+ fmt_cbb ff
+
+ | STMT_ret (ao) ->
+ fmt ff "ret";
+ begin
+ match ao with
+ None -> ()
+ | Some at ->
+ fmt ff " ";
+ fmt_atom ff at
+ end;
+ fmt ff ";"
+
+ | STMT_be (fn, az) ->
+ fmt ff "be ";
+ fmt_lval ff fn;
+ fmt_atoms ff az;
+ fmt ff ";";
+
+ | STMT_block b -> fmt_block ff b.node
+
+ | STMT_copy (lv, ex) ->
+ fmt_lval ff lv;
+ fmt ff " = ";
+ fmt_expr ff ex;
+ fmt ff ";"
+
+ | STMT_copy_binop (lv, binop, at) ->
+ fmt_lval ff lv;
+ fmt ff " ";
+ fmt_binop ff binop;
+ fmt ff "=";
+ fmt_atom ff at;
+ fmt ff ";"
+
+ | STMT_call (dst, fn, args) ->
+ fmt_lval ff dst;
+ fmt ff " = ";
+ fmt_lval ff fn;
+ fmt_atoms ff args;
+ fmt ff ";";
+
+ | STMT_bind (dst, fn, arg_opts) ->
+ fmt_lval ff dst;
+ fmt ff " = ";
+ fmt_lval ff fn;
+ fmt_atom_opts ff arg_opts;
+ fmt ff ";";
+
+ | STMT_decl (DECL_slot (skey, sloti)) ->
+ if sloti.node.slot_ty != None then fmt ff "let ";
+ fmt_slot ff sloti.node;
+ fmt ff " ";
+ fmt_slot_key ff skey;
+ fmt ff ";"
+
+ | STMT_decl (DECL_mod_item (ident, item)) ->
+ fmt_mod_item ff ident item
+
+ | STMT_init_rec (dst, entries, base) ->
+ fmt_lval ff dst;
+ fmt ff " = rec(";
+ for i = 0 to (Array.length entries) - 1
+ do
+ if i != 0
+ then fmt ff ", ";
+ let (ident, mode, mut, atom) = entries.(i) in
+ fmt_ident ff ident;
+ fmt ff " = ";
+ fmt_mutable ff mut;
+ fmt_mode ff mode;
+ fmt_atom ff atom;
+ done;
+ begin
+ match base with
+ None -> ()
+ | Some b ->
+ fmt ff " with ";
+ fmt_lval ff b
+ end;
+ fmt ff ");"
+
+ | STMT_init_vec (dst, _, atoms) ->
+ fmt_lval ff dst;
+ fmt ff " = vec(";
+ for i = 0 to (Array.length atoms) - 1
+ do
+ if i != 0
+ then fmt ff ", ";
+ fmt_atom ff atoms.(i);
+ done;
+ fmt ff ");"
+
+ | STMT_init_tup (dst, entries) ->
+ fmt_lval ff dst;
+ fmt ff " = (";
+ for i = 0 to (Array.length entries) - 1
+ do
+ if i != 0
+ then fmt ff ", ";
+ let (mode, mut, atom) = entries.(i) in
+ fmt_mutable ff mut;
+ fmt_mode ff mode;
+ fmt_atom ff atom;
+ done;
+ fmt ff ");";
+
+ | STMT_init_str (dst, s) ->
+ fmt_lval ff dst;
+ fmt ff " = \"%s\"" (String.escaped s)
+
+ | STMT_init_port dst ->
+ fmt_lval ff dst;
+ fmt ff " = port();"
+
+ | STMT_init_chan (dst, port_opt) ->
+ fmt_lval ff dst;
+ fmt ff " = chan(";
+ begin
+ match port_opt with
+ None -> ()
+ | Some lv -> fmt_lval ff lv
+ end;
+ fmt ff ");"
+
+ | STMT_check_expr expr ->
+ fmt ff "check (";
+ fmt_expr ff expr;
+ fmt ff ");"
+
+ | STMT_check_if (constrs, _, block) ->
+ fmt_obox ff;
+ fmt ff "check if (";
+ fmt_constrs ff constrs;
+ fmt ff ")";
+ fmt_obr ff;
+ fmt_stmts ff block.node;
+ fmt_cbb ff
+
+ | STMT_check (constrs, _) ->
+ fmt ff "check ";
+ fmt_constrs ff constrs;
+ fmt ff ";"
+
+ | STMT_prove constrs ->
+ fmt ff "prove ";
+ fmt_constrs ff constrs;
+ fmt ff ";"
+
+ | STMT_for sfor ->
+ let (slot, ident) = sfor.for_slot in
+ let (stmts, lval) = sfor.for_seq in
+ begin
+ fmt_obox ff;
+ fmt ff "for (";
+ fmt_slot ff slot.node;
+ fmt ff " ";
+ fmt_ident ff ident;
+ fmt ff " in ";
+ fmt_stmts ff stmts;
+ fmt_lval ff lval;
+ fmt ff ") ";
+ fmt_obr ff;
+ fmt_stmts ff sfor.for_body.node;
+ fmt_cbb ff
+ end
+
+ | STMT_for_each sf ->
+ let (slot, ident) = sf.for_each_slot in
+ let (f, az) = sf.for_each_call in
+ begin
+ fmt_obox ff;
+ fmt ff "for each (";
+ fmt_slot ff slot.node;
+ fmt ff " ";
+ fmt_ident ff ident;
+ fmt ff " = ";
+ fmt_lval ff f;
+ fmt_atoms ff az;
+ fmt ff " ";
+ fmt_obr ff;
+ fmt_stmts ff sf.for_each_body.node;
+ fmt_cbb ff
+ end
+
+ | STMT_put (atom) ->
+ fmt ff "put ";
+ begin
+ match atom with
+ Some a -> (fmt ff " "; fmt_atom ff a)
+ | None -> ()
+ end;
+ fmt ff ";"
+
+ | STMT_put_each (f, az) ->
+ fmt ff "put each ";
+ fmt_lval ff f;
+ fmt_atoms ff az;
+ fmt ff ";"
+
+ | STMT_fail -> fmt ff "fail;"
+ | STMT_yield -> fmt ff "yield;"
+
+ | STMT_send (chan, v) ->
+ fmt_lval ff chan;
+ fmt ff " <| ";
+ fmt_lval ff v;
+ fmt ff ";";
+
+ | STMT_recv (d, port) ->
+ fmt_lval ff d;
+ fmt ff " <- ";
+ fmt_lval ff port;
+ fmt ff ";";
+
+ | STMT_join t ->
+ fmt ff "join ";
+ fmt_lval ff t;
+ fmt ff ";"
+
+ | STMT_alt_tag _ -> fmt ff "?stmt_alt_tag?"
+ | STMT_alt_type _ -> fmt ff "?stmt_alt_type?"
+ | STMT_alt_port _ -> fmt ff "?stmt_alt_port?"
+ | STMT_note _ -> fmt ff "?stmt_note?"
+ | STMT_slice _ -> fmt ff "?stmt_slice?"
+ end
+
+and fmt_decl_params (ff:Format.formatter) (params:ty_param array) : unit =
+ if Array.length params = 0
+ then ()
+ else
+ begin
+ fmt ff "[";
+ for i = 0 to (Array.length params) - 1
+ do
+ if i <> 0
+ then fmt ff ", ";
+ let (ident, (i, e)) = params.(i) in
+ fmt_effect ff e;
+ if e <> PURE then fmt ff " ";
+ fmt_ident ff ident;
+ fmt ff "=<p#%d>" i
+ done;
+ fmt ff "]"
+ end;
+
+and fmt_header_slots (ff:Format.formatter) (hslots:header_slots) : unit =
+ fmt_slots ff
+ (Array.map (fun (s,_) -> s.node) hslots)
+ (Some (Array.map (fun (_, i) -> i) hslots))
+
+and fmt_ident_and_params
+ (ff:Format.formatter)
+ (id:ident)
+ (params:ty_param array)
+ : unit =
+ fmt_ident ff id;
+ fmt_decl_params ff params
+
+and fmt_fn
+ (ff:Format.formatter)
+ (id:ident)
+ (params:ty_param array)
+ (f:fn)
+ : unit =
+ fmt_obox ff;
+ fmt_effect ff f.fn_aux.fn_effect;
+ if f.fn_aux.fn_effect <> PURE then fmt ff " ";
+ fmt ff "%s "(if f.fn_aux.fn_is_iter then "iter" else "fn");
+ fmt_ident_and_params ff id params;
+ fmt_header_slots ff f.fn_input_slots;
+ fmt_decl_constrs ff f.fn_input_constrs;
+ fmt ff " -> ";
+ fmt_slot ff f.fn_output_slot.node;
+ fmt ff " ";
+ fmt_obr ff;
+ fmt_stmts ff f.fn_body.node;
+ fmt_cbb ff
+
+
+and fmt_obj
+ (ff:Format.formatter)
+ (id:ident)
+ (params:ty_param array)
+ (obj:obj)
+ : unit =
+ fmt_obox ff;
+ fmt_effect ff obj.obj_effect;
+ if obj.obj_effect <> PURE then fmt ff " ";
+ fmt ff "obj ";
+ fmt_ident_and_params ff id params;
+ fmt_header_slots ff obj.obj_state;
+ fmt_decl_constrs ff obj.obj_constrs;
+ fmt ff " ";
+ fmt_obr ff;
+ Hashtbl.iter
+ begin
+ fun id fn ->
+ fmt ff "@\n";
+ fmt_fn ff id [||] fn.node
+ end
+ obj.obj_fns;
+ begin
+ match obj.obj_drop with
+ None -> ()
+ | Some d ->
+ begin
+ fmt ff "@\n";
+ fmt_obox ff;
+ fmt ff "drop ";
+ fmt_obr ff;
+ fmt_stmts ff d.node;
+ fmt_cbb ff;
+ end
+ end;
+ fmt_cbb ff
+
+
+and fmt_mod_item (ff:Format.formatter) (id:ident) (item:mod_item) : unit =
+ fmt ff "@\n";
+ let params = item.node.decl_params in
+ let params = Array.map (fun i -> i.node) params in
+ begin
+ match item.node.decl_item with
+ MOD_ITEM_type ty ->
+ fmt ff "type ";
+ fmt_ident_and_params ff id params;
+ fmt ff " = ";
+ fmt_ty ff ty;
+ fmt ff ";";
+
+ | MOD_ITEM_tag (hdr, ttag, _) ->
+ fmt ff "fn ";
+ fmt_ident_and_params ff id params;
+ fmt_header_slots ff
+ (Array.mapi (fun i s -> (s,(Printf.sprintf "_%d" i))) hdr);
+ fmt ff " -> ";
+ fmt_ty ff (TY_tag ttag);
+ fmt ff ";";
+
+ | MOD_ITEM_mod (view,items) ->
+ fmt_obox ff;
+ fmt ff "mod ";
+ fmt_ident_and_params ff id params;
+ fmt ff " ";
+ fmt_obr ff;
+ fmt_mod_view ff view;
+ fmt_mod_items ff items;
+ fmt_cbb ff
+
+ | MOD_ITEM_fn f ->
+ fmt_fn ff id params f
+
+ | MOD_ITEM_obj obj ->
+ fmt_obj ff id params obj
+ end
+
+and fmt_import (ff:Format.formatter) (ident:ident) (name:name) : unit =
+ fmt ff "@\n";
+ fmt ff "import ";
+ fmt ff "%s = " ident;
+ fmt_name ff name;
+
+and fmt_export (ff:Format.formatter) (export:export) _ : unit =
+ fmt ff "@\n";
+ match export with
+ EXPORT_all_decls -> fmt ff "export *;"
+ | EXPORT_ident i -> fmt ff "export %s;" i
+
+and fmt_mod_view (ff:Format.formatter) (mv:mod_view) : unit =
+ Hashtbl.iter (fmt_import ff) mv.view_imports;
+ Hashtbl.iter (fmt_export ff) mv.view_exports
+
+and fmt_mod_items (ff:Format.formatter) (mi:mod_items) : unit =
+ Hashtbl.iter (fmt_mod_item ff) mi
+
+and fmt_crate (ff:Format.formatter) (c:crate) : unit =
+ let (view,items) = c.node.crate_items in
+ fmt_mod_view ff view;
+ fmt_mod_items ff items
+
+
+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)
+
+
+let sprintf_expr = sprintf_fmt fmt_expr;;
+let sprintf_name = sprintf_fmt fmt_name;;
+let sprintf_lval = sprintf_fmt fmt_lval;;
+let sprintf_lval_component = sprintf_fmt fmt_lval_component;;
+let sprintf_atom = sprintf_fmt fmt_atom;;
+let sprintf_slot = sprintf_fmt fmt_slot;;
+let sprintf_slot_key = sprintf_fmt fmt_slot_key;;
+let sprintf_mutable = sprintf_fmt fmt_mutable;;
+let sprintf_ty = sprintf_fmt fmt_ty;;
+let sprintf_effect = sprintf_fmt fmt_effect;;
+let sprintf_tag = sprintf_fmt fmt_tag;;
+let sprintf_carg = sprintf_fmt fmt_carg;;
+let sprintf_constr = sprintf_fmt fmt_constr;;
+let sprintf_stmt = sprintf_fmt fmt_stmt;;
+let sprintf_mod_items = sprintf_fmt fmt_mod_items;;
+let sprintf_decl_params = sprintf_fmt fmt_decl_params;;
+let sprintf_app_args = sprintf_fmt fmt_app_args;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+
+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 * Pexp.pexp) array;;
+
+type meta_pat = (Ast.ident * (Pexp.pexp option)) array;;
+
+type auth = (Ast.name * Ast.effect);;
+
+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: Pexp.pexp;
+ alt_arms: (Pexp.pexp * cexp array) array;
+ alt_else: cexp array }
+
+and cexp_let =
+ { let_ident: Ast.ident;
+ let_value: Pexp.pexp;
+ let_body: cexp array; }
+
+and cexp_src =
+ { src_ident: Ast.ident;
+ src_path: Pexp.pexp option }
+
+and cexp_dir =
+ { dir_ident: Ast.ident;
+ dir_path: Pexp.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: Pexp.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 * Pexp.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 (Pexp.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 =
+ let (ident, item) = Item.parse_mod_item_from_signature ps in
+ htab_put items ident item;
+ 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 effect = Pexp.parse_effect ps in
+ expect ps SEMI;
+ let bpos = lexpos ps in
+ CEXP_auth (span ps apos bpos (name, effect))
+
+ | _ -> raise (unexpected ps)
+
+
+and parse_eq_pexp_opt (ps:pstate) : Pexp.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_num of int64
+ | PVAL_bool of bool
+;;
+
+type cdir =
+ CDIR_meta of ((Ast.ident * string) array)
+ | CDIR_syntax of Ast.name
+ | CDIR_check of (Ast.name * pval array)
+ | CDIR_mod of (Ast.ident * Ast.mod_item)
+ | CDIR_auth of auth
+
+type env = { env_bindings: (Ast.ident * pval) list;
+ 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_num i -> "num " ^ (Int64.to_string i)
+ | PVAL_bool b -> if b then "bool true" else "bool false"
+ in
+ (* FIXME: 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} ->
+ 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} ->
+ let ident = cl.let_ident in
+ let v = eval_pexp env cl.let_value in
+ let env = { env with
+ env_bindings = ((ident,v)::env.env_bindings ) }
+ in
+ eval_cexps env cl.let_body
+
+ | 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_temp_id
+ ps.pstate_node_id
+ ps.pstate_opaque_id
+ ps.pstate_sess
+ ps.pstate_get_mod
+ 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_node_id ps.pstate_opaque_id
+ 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:Pexp.pexp) : pval =
+ match exp.node with
+ | Pexp.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_num av) in
+ let bv = (need_num bv) in
+ PVAL_num
+ 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
+
+ | Pexp.PEXP_unop (uop, a) ->
+ begin
+ match uop with
+ Ast.UNOP_not ->
+ PVAL_bool (not (eval_pexp_to_bool env a))
+ | Ast.UNOP_neg ->
+ PVAL_num (Int64.neg (eval_pexp_to_num env a))
+ | _ -> bug () "Unexpected unop in Cexp.eval_pexp"
+ end
+
+ | Pexp.PEXP_lval (Pexp.PLVAL_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
+
+ | Pexp.PEXP_lit (Ast.LIT_bool b) ->
+ PVAL_bool b
+
+ | Pexp.PEXP_lit (Ast.LIT_int (i, _)) ->
+ PVAL_num i
+
+ | Pexp.PEXP_str s ->
+ PVAL_str s
+
+ | _ -> bug () "unexpected Pexp in Cexp.eval_pexp"
+
+
+and eval_pexp_to_str (env:env) (exp:Pexp.pexp) : string =
+ match eval_pexp env exp with
+ PVAL_str s -> s
+ | v -> unexpected_val "str" v
+
+and need_num (cv:pval) : int64 =
+ match cv with
+ PVAL_num n -> n
+ | v -> unexpected_val "num" v
+
+and eval_pexp_to_num (env:env) (exp:Pexp.pexp) : int64 =
+ need_num (eval_pexp env exp)
+
+and eval_pexp_to_bool (env:env) (exp:Pexp.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 "Parse error: %s\n%!" str;
+ List.iter
+ (fun (cx,pos) ->
+ Session.fail sess "%s:E (parse context): %s\n%!"
+ (Session.string_of_pos pos) cx)
+ ps.pstate_ctxt;
+ let apos = lexpos ps in
+ span ps apos apos
+ { Ast.crate_items = (Item.empty_view, Hashtbl.create 0);
+ Ast.crate_meta = [||];
+ Ast.crate_auth = Hashtbl.create 0;
+ Ast.crate_required = Hashtbl.create 0;
+ Ast.crate_required_syms = Hashtbl.create 0;
+ Ast.crate_main = None;
+ Ast.crate_files = Hashtbl.create 0 }
+;;
+
+
+let parse_crate_file
+ (sess:Session.sess)
+ (get_mod:get_mod_fn)
+ (infer_lib_name:(Ast.ident -> filename))
+ : Ast.crate =
+ let fname = Session.filename_of sess.Session.sess_in in
+ let tref = ref (Temp 0) in
+ let nref = ref (Node 0) in
+ let oref = ref (Opaque 0) in
+ let required = Hashtbl.create 4 in
+ let required_syms = Hashtbl.create 4 in
+ let ps =
+ make_parser tref nref oref sess get_mod
+ infer_lib_name required required_syms fname
+ 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")
+ | 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 initial_bindings =
+ target_bindings
+ @ build_bindings
+ in
+ let env = { env_bindings = initial_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) -> htab_put 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))
+ : Ast.crate =
+ let fname = Session.filename_of sess.Session.sess_in in
+ let tref = ref (Temp 0) in
+ let nref = ref (Node 0) in
+ let oref = ref (Opaque 0) in
+ let required = Hashtbl.create 0 in
+ let required_syms = Hashtbl.create 0 in
+ let ps =
+ make_parser tref nref oref sess get_mod
+ 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 ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+
+open Common;;
+open Token;;
+open Parser;;
+
+(* Item grammar. *)
+
+let default_exports =
+ let e = Hashtbl.create 0 in
+ Hashtbl.add e Ast.EXPORT_all_decls ();
+ e
+;;
+
+let empty_view = { Ast.view_imports = Hashtbl.create 0;
+ Ast.view_exports = default_exports }
+;;
+
+let rec parse_expr (ps:pstate) : (Ast.stmt array * Ast.expr) =
+ let pexp = ctxt "expr" Pexp.parse_pexp ps in
+ Pexp.desugar_expr ps pexp
+
+and parse_expr_atom (ps:pstate) : (Ast.stmt array * Ast.atom) =
+ let pexp = ctxt "expr" Pexp.parse_pexp ps in
+ Pexp.desugar_expr_atom ps pexp
+
+and parse_expr_atom_list
+ (bra:token)
+ (ket:token)
+ (ps:pstate)
+ : (Ast.stmt array * Ast.atom array) =
+ arj1st (bracketed_zero_or_more bra ket (Some COMMA)
+ (ctxt "expr-atom list" parse_expr_atom) ps)
+
+and parse_expr_init (lv:Ast.lval) (ps:pstate) : (Ast.stmt array) =
+ let pexp = ctxt "expr" Pexp.parse_pexp ps in
+ Pexp.desugar_expr_init ps lv pexp
+
+and parse_lval (ps:pstate) : (Ast.stmt array * Ast.lval) =
+ let pexp = Pexp.parse_pexp ps in
+ Pexp.desugar_lval ps pexp
+
+and parse_identified_slot_and_ident
+ (aliases_ok:bool)
+ (ps:pstate)
+ : (Ast.slot identified * Ast.ident) =
+ let slot =
+ ctxt "identified slot and ident: slot"
+ (Pexp.parse_identified_slot aliases_ok) ps
+ in
+ let ident =
+ ctxt "identified slot and ident: ident" Pexp.parse_ident ps
+ in
+ (slot, ident)
+
+and parse_zero_or_more_identified_slot_ident_pairs
+ (aliases_ok:bool)
+ (ps:pstate)
+ : (((Ast.slot identified) * Ast.ident) array) =
+ ctxt "zero+ slots and idents"
+ (paren_comma_list
+ (parse_identified_slot_and_ident aliases_ok)) ps
+
+and parse_block (ps:pstate) : Ast.block =
+ let apos = lexpos ps in
+ let stmts =
+ arj (ctxt "block: stmts"
+ (bracketed_zero_or_more LBRACE RBRACE
+ None parse_stmts) ps)
+ in
+ let bpos = lexpos ps in
+ span ps apos bpos stmts
+
+and parse_block_stmt (ps:pstate) : Ast.stmt =
+ let apos = lexpos ps in
+ let block = parse_block ps in
+ let bpos = lexpos ps in
+ span ps apos bpos (Ast.STMT_block block)
+
+and parse_init
+ (lval:Ast.lval)
+ (ps:pstate)
+ : Ast.stmt array =
+ let apos = lexpos ps in
+ let stmts =
+ match peek ps with
+ EQ ->
+ bump ps;
+ parse_expr_init lval ps
+ | LARROW ->
+ bump ps;
+ let (stmts, rhs) = ctxt "init: port" parse_lval ps in
+ let bpos = lexpos ps in
+ let stmt = Ast.STMT_recv (lval, rhs) in
+ Array.append stmts [| (span ps apos bpos stmt) |]
+ | _ -> arr []
+ in
+ let _ = expect ps SEMI in
+ stmts
+
+and parse_slot_and_ident_and_init
+ (ps:pstate)
+ : (Ast.stmt array * Ast.slot * Ast.ident) =
+ let apos = lexpos ps in
+ let (slot, ident) =
+ ctxt "slot, ident and init: slot and ident"
+ (Pexp.parse_slot_and_ident false) ps
+ in
+ let bpos = lexpos ps in
+ let lval = Ast.LVAL_base (span ps apos bpos (Ast.BASE_ident ident)) in
+ let stmts = ctxt "slot, ident and init: init" (parse_init lval) ps in
+ (stmts, slot, ident)
+
+and parse_auto_slot_and_init
+ (ps:pstate)
+ : (Ast.stmt array * Ast.slot * Ast.ident) =
+ let apos = lexpos ps in
+ let ident = Pexp.parse_ident ps in
+ let bpos = lexpos ps in
+ let lval = Ast.LVAL_base (span ps apos bpos (Ast.BASE_ident ident)) in
+ let stmts = ctxt "slot, ident and init: init" (parse_init lval) ps in
+ (stmts, slot_auto, ident)
+
+(*
+ * We have no way to parse a single Ast.stmt; any incoming syntactic statement
+ * may desugar to N>1 real Ast.stmts
+ *)
+
+and parse_stmts (ps:pstate) : Ast.stmt array =
+ let apos = lexpos ps in
+ match peek ps with
+
+ LOG ->
+ bump ps;
+ let (stmts, atom) = ctxt "stmts: log value" parse_expr_atom ps in
+ expect ps SEMI;
+ spans ps stmts apos (Ast.STMT_log atom)
+
+ | CHECK ->
+ bump ps;
+ begin
+
+ let rec name_to_lval (bpos:pos) (name:Ast.name)
+ : Ast.lval =
+ match name with
+ Ast.NAME_base nb ->
+ Ast.LVAL_base (span ps apos bpos nb)
+ | Ast.NAME_ext (n, nc) ->
+ Ast.LVAL_ext (name_to_lval bpos n, Ast.COMP_named nc)
+ in
+
+ let rec carg_path_to_lval (bpos:pos) (path:Ast.carg_path)
+ : Ast.lval =
+ match path with
+ Ast.CARG_base Ast.BASE_formal ->
+ raise (err "converting formal constraint-arg to atom" ps)
+ | Ast.CARG_base (Ast.BASE_named nb) ->
+ Ast.LVAL_base (span ps apos bpos nb)
+ | Ast.CARG_ext (pth, nc) ->
+ Ast.LVAL_ext (carg_path_to_lval bpos pth,
+ Ast.COMP_named nc)
+ in
+
+ let carg_to_atom (bpos:pos) (carg:Ast.carg)
+ : Ast.atom =
+ match carg with
+ Ast.CARG_lit lit ->
+ Ast.ATOM_literal (span ps apos bpos lit)
+ | Ast.CARG_path pth ->
+ Ast.ATOM_lval (carg_path_to_lval bpos pth)
+ in
+
+ let synthesise_check_call (bpos:pos) (constr:Ast.constr)
+ : (Ast.lval * (Ast.atom array)) =
+ let lval = name_to_lval bpos constr.Ast.constr_name in
+ let args =
+ Array.map (carg_to_atom bpos) constr.Ast.constr_args
+ in
+ (lval, args)
+ in
+
+ let synthesise_check_calls (bpos:pos) (constrs:Ast.constrs)
+ : Ast.check_calls =
+ Array.map (synthesise_check_call bpos) constrs
+ in
+
+ match peek ps with
+ LPAREN ->
+ bump ps;
+ let (stmts, expr) =
+ ctxt "stmts: check value" parse_expr ps
+ in
+ expect ps RPAREN;
+ expect ps SEMI;
+ spans ps stmts apos (Ast.STMT_check_expr expr)
+
+ | IF ->
+ bump ps;
+ expect ps LPAREN;
+ let constrs = Pexp.parse_constrs ps in
+ expect ps RPAREN;
+ let block = parse_block ps in
+ let bpos = lexpos ps in
+ let calls = synthesise_check_calls bpos constrs in
+ [| span ps apos bpos
+ (Ast.STMT_check_if (constrs, calls, block))
+ |]
+
+ | _ ->
+ let constrs = Pexp.parse_constrs ps in
+ expect ps SEMI;
+ let bpos = lexpos ps in
+ let calls = synthesise_check_calls bpos constrs in
+ [| span ps apos bpos
+ (Ast.STMT_check (constrs, calls))
+ |]
+ end
+
+ | ALT ->
+ bump ps;
+ begin
+ match peek ps with
+ TYPE -> [| |]
+ | LPAREN ->
+ let (stmts, lval) = bracketed LPAREN RPAREN parse_lval ps in
+ let rec parse_pat ps =
+ match peek ps with
+ IDENT ident ->
+ let apos = lexpos ps in
+ bump ps;
+ let bpos = lexpos ps in
+
+ (* TODO: nullary constructors *)
+ if peek ps != LPAREN then
+ let slot =
+ { Ast.slot_mode = Ast.MODE_interior;
+ Ast.slot_mutable = false;
+ Ast.slot_ty = None }
+ in
+ Ast.PAT_slot ((span ps apos bpos slot), ident)
+ else
+ let pats =
+ paren_comma_list parse_pat ps
+ in
+ Ast.PAT_tag (ident, pats)
+ | LIT_INT _ | LIT_CHAR _ | LIT_BOOL _ ->
+ Ast.PAT_lit (Pexp.parse_lit ps)
+ | UNDERSCORE -> bump ps; Ast.PAT_wild
+ | tok -> raise (Parse_err (ps,
+ "Expected pattern but found '" ^
+ (string_of_tok tok) ^ "'"))
+ in
+ let rec parse_arms ps =
+ match peek ps with
+ CASE ->
+ bump ps;
+ let pat = bracketed LPAREN RPAREN parse_pat ps in
+ let block = parse_block ps in
+ let arm = (pat, block) in
+ (span ps apos (lexpos ps) arm)::(parse_arms ps)
+ | _ -> []
+ in
+ let parse_alt_block ps =
+ let arms = ctxt "alt tag arms" parse_arms ps in
+ spans ps stmts apos begin
+ Ast.STMT_alt_tag {
+ Ast.alt_tag_lval = lval;
+ Ast.alt_tag_arms = Array.of_list arms
+ }
+ end
+ in
+ bracketed LBRACE RBRACE parse_alt_block ps
+ | _ -> [| |]
+ end
+
+ | IF ->
+ let final_else = ref None in
+ let rec parse_stmt_if _ =
+ bump ps;
+ let (stmts, expr) =
+ ctxt "stmts: if cond"
+ (bracketed LPAREN RPAREN parse_expr) ps
+ in
+ let then_block = ctxt "stmts: if-then" parse_block ps in
+ begin
+ match peek ps with
+ ELSE ->
+ begin
+ bump ps;
+ match peek ps with
+ IF ->
+ let nested_if = parse_stmt_if () in
+ let bpos = lexpos ps in
+ final_else :=
+ Some (span ps apos bpos nested_if)
+ | _ ->
+ final_else :=
+ Some (ctxt "stmts: if-else" parse_block ps)
+ end
+ | _ -> ()
+ end;
+ let res =
+ spans ps stmts apos
+ (Ast.STMT_if
+ { Ast.if_test = expr;
+ Ast.if_then = then_block;
+ Ast.if_else = !final_else; })
+ in
+ final_else := None;
+ res
+ in
+ parse_stmt_if()
+
+ | FOR ->
+ bump ps;
+ begin
+ match peek ps with
+ EACH ->
+ bump ps;
+ let inner ps : ((Ast.slot identified * Ast.ident)
+ * Ast.stmt array
+ * (Ast.lval * Ast.atom array)) =
+ let slot = (parse_identified_slot_and_ident true ps) in
+ let _ = (expect ps IN) in
+ let (stmts1, iter) = (rstr true parse_lval) ps in
+ let (stmts2, args) =
+ parse_expr_atom_list LPAREN RPAREN ps
+ in
+ (slot, Array.append stmts1 stmts2, (iter, args))
+ in
+ let (slot, stmts, call) = ctxt "stmts: foreach head"
+ (bracketed LPAREN RPAREN inner) ps
+ in
+ let body_block =
+ ctxt "stmts: foreach body" parse_block ps
+ in
+ let bpos = lexpos ps in
+ let head_block =
+ (*
+ * Slightly weird, but we put an extra nesting level of
+ * block here to separate the part that lives in our frame
+ * (the iter slot) from the part that lives in the callee
+ * frame (the body block).
+ *)
+ span ps apos bpos [|
+ span ps apos bpos (Ast.STMT_block body_block);
+ |]
+ in
+ Array.append stmts
+ [| span ps apos bpos
+ (Ast.STMT_for_each
+ { Ast.for_each_slot = slot;
+ Ast.for_each_call = call;
+ Ast.for_each_head = head_block;
+ Ast.for_each_body = body_block; }) |]
+ | _ ->
+ let inner ps =
+ let slot = (parse_identified_slot_and_ident false ps) in
+ let _ = (expect ps IN) in
+ let lval = (parse_lval ps) in
+ (slot, lval) in
+ let (slot, seq) =
+ ctxt "stmts: for head" (bracketed LPAREN RPAREN inner) ps
+ in
+ let body_block = ctxt "stmts: for body" parse_block ps in
+ let bpos = lexpos ps in
+ [| span ps apos bpos
+ (Ast.STMT_for
+ { Ast.for_slot = slot;
+ Ast.for_seq = seq;
+ Ast.for_body = body_block; }) |]
+ end
+
+ | WHILE ->
+ bump ps;
+ let (stmts, test) =
+ ctxt "stmts: while cond" (bracketed LPAREN RPAREN parse_expr) ps
+ in
+ let body_block = ctxt "stmts: while body" parse_block ps in
+ let bpos = lexpos ps in
+ [| span ps apos bpos
+ (Ast.STMT_while
+ { Ast.while_lval = (stmts, test);
+ Ast.while_body = body_block; }) |]
+
+ | PUT ->
+ begin
+ bump ps;
+ match peek ps with
+ EACH ->
+ bump ps;
+ let (lstmts, lval) =
+ ctxt "put each: lval" (rstr true parse_lval) ps
+ in
+ let (astmts, args) =
+ ctxt "put each: args"
+ (parse_expr_atom_list LPAREN RPAREN) ps
+ in
+ let bpos = lexpos ps in
+ let be =
+ span ps apos bpos (Ast.STMT_put_each (lval, args))
+ in
+ expect ps SEMI;
+ Array.concat [ lstmts; astmts; [| be |] ]
+
+ | _ ->
+ begin
+ let (stmts, e) =
+ match peek ps with
+ SEMI -> (arr [], None)
+ | _ ->
+ let (stmts, expr) =
+ ctxt "stmts: put expr" parse_expr_atom ps
+ in
+ expect ps SEMI;
+ (stmts, Some expr)
+ in
+ spans ps stmts apos (Ast.STMT_put e)
+ end
+ end
+
+ | RET ->
+ bump ps;
+ let (stmts, e) =
+ match peek ps with
+ SEMI -> (bump ps; (arr [], None))
+ | _ ->
+ let (stmts, expr) =
+ ctxt "stmts: ret expr" parse_expr_atom ps
+ in
+ expect ps SEMI;
+ (stmts, Some expr)
+ in
+ spans ps stmts apos (Ast.STMT_ret e)
+
+ | BE ->
+ bump ps;
+ let (lstmts, lval) = ctxt "be: lval" (rstr true parse_lval) ps in
+ let (astmts, args) =
+ ctxt "be: args" (parse_expr_atom_list LPAREN RPAREN) ps
+ in
+ let bpos = lexpos ps in
+ let be = span ps apos bpos (Ast.STMT_be (lval, args)) in
+ expect ps SEMI;
+ Array.concat [ lstmts; astmts; [| be |] ]
+
+ | LBRACE -> [| ctxt "stmts: block" parse_block_stmt ps |]
+
+ | LET ->
+ bump ps;
+ let (stmts, slot, ident) =
+ ctxt "stmt slot" parse_slot_and_ident_and_init ps in
+ let slot = Pexp.apply_mutability slot true in
+ let bpos = lexpos ps in
+ let decl = Ast.DECL_slot (Ast.KEY_ident ident,
+ (span ps apos bpos slot))
+ in
+ Array.concat [[| span ps apos bpos (Ast.STMT_decl decl) |]; stmts]
+
+ | AUTO ->
+ bump ps;
+ let (stmts, slot, ident) =
+ ctxt "stmt slot" parse_auto_slot_and_init ps in
+ let slot = Pexp.apply_mutability slot true in
+ let bpos = lexpos ps in
+ let decl = Ast.DECL_slot (Ast.KEY_ident ident,
+ (span ps apos bpos slot))
+ in
+ Array.concat [[| span ps apos bpos (Ast.STMT_decl decl) |]; stmts]
+
+ | YIELD ->
+ bump ps;
+ expect ps SEMI;
+ let bpos = lexpos ps in
+ [| span ps apos bpos Ast.STMT_yield |]
+
+ | FAIL ->
+ bump ps;
+ expect ps SEMI;
+ let bpos = lexpos ps in
+ [| span ps apos bpos Ast.STMT_fail |]
+
+ | JOIN ->
+ bump ps;
+ let (stmts, lval) = ctxt "stmts: task expr" parse_lval ps in
+ expect ps SEMI;
+ spans ps stmts apos (Ast.STMT_join lval)
+
+ | MOD | OBJ | TYPE | FN | USE | NATIVE ->
+ let (ident, item) = ctxt "stmt: decl" parse_mod_item ps in
+ let decl = Ast.DECL_mod_item (ident, item) in
+ let stmts = expand_tags_to_stmts ps item in
+ spans ps stmts apos (Ast.STMT_decl decl)
+
+ | _ ->
+ let (lstmts, lval) = ctxt "stmt: lval" parse_lval ps in
+ begin
+ match peek ps with
+
+ SEMI -> (bump ps; lstmts)
+
+ | EQ -> parse_init lval ps
+
+ | OPEQ binop_token ->
+ bump ps;
+ let (stmts, rhs) =
+ ctxt "stmt: opeq rhs" parse_expr_atom ps
+ in
+ let binop =
+ match binop_token with
+ PLUS -> Ast.BINOP_add
+ | MINUS -> Ast.BINOP_sub
+ | STAR -> Ast.BINOP_mul
+ | SLASH -> Ast.BINOP_div
+ | PERCENT -> Ast.BINOP_mod
+ | AND -> Ast.BINOP_and
+ | OR -> Ast.BINOP_or
+ | CARET -> Ast.BINOP_xor
+ | LSL -> Ast.BINOP_lsl
+ | LSR -> Ast.BINOP_lsr
+ | ASR -> Ast.BINOP_asr
+ | _ -> raise (err "unknown opeq token" ps)
+ in
+ expect ps SEMI;
+ spans ps stmts apos
+ (Ast.STMT_copy_binop (lval, binop, rhs))
+
+ | LARROW ->
+ bump ps;
+ let (stmts, rhs) = ctxt "stmt: recv rhs" parse_lval ps in
+ let _ = expect ps SEMI in
+ spans ps stmts apos (Ast.STMT_recv (lval, rhs))
+
+ | SEND ->
+ bump ps;
+ let (stmts, rhs) =
+ ctxt "stmt: send rhs" parse_expr_atom ps
+ in
+ let _ = expect ps SEMI in
+ let bpos = lexpos ps in
+ let (src, copy) = match rhs with
+ Ast.ATOM_lval lv -> (lv, [| |])
+ | _ ->
+ let (_, tmp, tempdecl) =
+ build_tmp ps slot_auto apos bpos
+ in
+ let copy = span ps apos bpos
+ (Ast.STMT_copy (tmp, Ast.EXPR_atom rhs)) in
+ ((clone_lval ps tmp), [| tempdecl; copy |])
+ in
+ let send =
+ span ps apos bpos
+ (Ast.STMT_send (lval, src))
+ in
+ Array.concat [ stmts; copy; [| send |] ]
+
+ | _ -> raise (unexpected ps)
+ end
+
+
+and parse_ty_param (iref:int ref) (ps:pstate) : Ast.ty_param identified =
+ let apos = lexpos ps in
+ let e = Pexp.parse_effect ps in
+ let ident = Pexp.parse_ident ps in
+ let i = !iref in
+ let bpos = lexpos ps in
+ incr iref;
+ span ps apos bpos (ident, (i, e))
+
+and parse_ty_params (ps:pstate)
+ : (Ast.ty_param identified) array =
+ match peek ps with
+ LBRACKET ->
+ bracketed_zero_or_more LBRACKET RBRACKET (Some COMMA)
+ (parse_ty_param (ref 0)) ps
+ | _ -> arr []
+
+and parse_ident_and_params (ps:pstate) (cstr:string)
+ : (Ast.ident * (Ast.ty_param identified) array) =
+ let ident = ctxt ("mod " ^ cstr ^ " item: ident") Pexp.parse_ident ps in
+ let params =
+ ctxt ("mod " ^ cstr ^ " item: type params") parse_ty_params ps
+ in
+ (ident, params)
+
+and parse_inputs
+ (ps:pstate)
+ : ((Ast.slot identified * Ast.ident) array * Ast.constrs) =
+ let slots =
+ match peek ps with
+ LPAREN -> ctxt "inputs: input idents and slots"
+ (parse_zero_or_more_identified_slot_ident_pairs true) ps
+ | _ -> raise (unexpected ps)
+ in
+ let constrs =
+ match peek ps with
+ COLON -> (bump ps; ctxt "inputs: constrs" Pexp.parse_constrs ps)
+ | _ -> [| |]
+ in
+ let rec rewrite_carg_path cp =
+ match cp with
+ Ast.CARG_base (Ast.BASE_named (Ast.BASE_ident ident)) ->
+ begin
+ let res = ref cp in
+ for i = 0 to (Array.length slots) - 1
+ do
+ let (_, ident') = slots.(i) in
+ if ident' = ident
+ then res := Ast.CARG_ext (Ast.CARG_base Ast.BASE_formal,
+ Ast.COMP_idx i)
+ else ()
+ done;
+ !res
+ end
+ | Ast.CARG_base _ -> cp
+ | Ast.CARG_ext (cp, ext) ->
+ Ast.CARG_ext (rewrite_carg_path cp, ext)
+ in
+ (* Rewrite constrs with input tuple as BASE_formal. *)
+ Array.iter
+ begin
+ fun constr ->
+ let args = constr.Ast.constr_args in
+ Array.iteri
+ begin
+ fun i carg ->
+ match carg with
+ Ast.CARG_path cp ->
+ args.(i) <- Ast.CARG_path (rewrite_carg_path cp)
+ | _ -> ()
+ end
+ args
+ end
+ constrs;
+ (slots, constrs)
+
+
+and parse_in_and_out
+ (ps:pstate)
+ : ((Ast.slot identified * Ast.ident) array
+ * Ast.constrs
+ * Ast.slot identified) =
+ let (inputs, constrs) = parse_inputs ps in
+ let output =
+ match peek ps with
+ RARROW ->
+ bump ps;
+ ctxt "fn in and out: output slot"
+ (Pexp.parse_identified_slot true) ps
+ | _ ->
+ let apos = lexpos ps in
+ span ps apos apos slot_nil
+ in
+ (inputs, constrs, output)
+
+
+(* parse_fn starts at the first lparen of the sig. *)
+and parse_fn
+ (is_iter:bool)
+ (effect:Ast.effect)
+ (ps:pstate)
+ : Ast.fn =
+ let (inputs, constrs, output) =
+ ctxt "fn: in_and_out" parse_in_and_out ps
+ in
+ let body = ctxt "fn: body" parse_block ps in
+ { Ast.fn_input_slots = inputs;
+ Ast.fn_input_constrs = constrs;
+ Ast.fn_output_slot = output;
+ Ast.fn_aux = { Ast.fn_effect = effect;
+ Ast.fn_is_iter = is_iter; };
+ Ast.fn_body = body; }
+
+and parse_meta_input (ps:pstate) : (Ast.ident * string 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
+ | LIT_STR s -> bump ps; Some s
+ | _ -> raise (unexpected ps)
+ in
+ (lab, v)
+ | _ -> raise (unexpected ps)
+
+and parse_meta_pat (ps:pstate) : Ast.meta_pat =
+ bracketed_zero_or_more LPAREN RPAREN
+ (Some COMMA) parse_meta_input ps
+
+and parse_meta (ps:pstate) : Ast.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)
+
+and parse_optional_meta_pat (ps:pstate) (ident:Ast.ident) : Ast.meta_pat =
+ match peek ps with
+ LPAREN -> parse_meta_pat ps
+ | _ -> [| ("name", Some ident) |]
+
+
+and parse_obj_item
+ (ps:pstate)
+ (apos:pos)
+ (effect:Ast.effect)
+ : (Ast.ident * Ast.mod_item) =
+ expect ps OBJ;
+ let (ident, params) = parse_ident_and_params ps "obj" in
+ let (state, constrs) = (ctxt "obj state" parse_inputs ps) in
+ let drop = ref None in
+ expect ps LBRACE;
+ let fns = Hashtbl.create 0 in
+ while (not (peek ps = RBRACE))
+ do
+ let apos = lexpos ps in
+ match peek ps with
+ IO | STATE | UNSAFE | FN | ITER ->
+ let effect = Pexp.parse_effect ps in
+ let is_iter = (peek ps) = ITER in
+ bump ps;
+ let ident = ctxt "obj fn: ident" Pexp.parse_ident ps in
+ let fn = ctxt "obj fn: fn" (parse_fn is_iter effect) ps in
+ let bpos = lexpos ps in
+ htab_put fns ident (span ps apos bpos fn)
+ | DROP ->
+ bump ps;
+ drop := Some (parse_block ps)
+ | RBRACE -> ()
+ | _ -> raise (unexpected ps)
+ done;
+ expect ps RBRACE;
+ let bpos = lexpos ps in
+ let obj = { Ast.obj_state = state;
+ Ast.obj_effect = effect;
+ Ast.obj_constrs = constrs;
+ Ast.obj_fns = fns;
+ Ast.obj_drop = !drop }
+ in
+ (ident,
+ span ps apos bpos
+ (decl params (Ast.MOD_ITEM_obj obj)))
+
+
+and parse_mod_item (ps:pstate) : (Ast.ident * Ast.mod_item) =
+ let apos = lexpos ps in
+ let parse_lib_name ident =
+ match peek ps with
+ EQ ->
+ begin
+ bump ps;
+ match peek ps with
+ LIT_STR s -> (bump ps; s)
+ | _ -> raise (unexpected ps)
+ end
+ | _ -> ps.pstate_infer_lib_name ident
+ in
+
+ match peek ps with
+
+ IO | STATE | UNSAFE | OBJ | FN | ITER ->
+ let effect = Pexp.parse_effect ps in
+ begin
+ match peek ps with
+ OBJ -> parse_obj_item ps apos effect
+ | _ ->
+ let is_iter = (peek ps) = ITER in
+ bump ps;
+ let (ident, params) = parse_ident_and_params ps "fn" in
+ let fn =
+ ctxt "mod fn item: fn" (parse_fn is_iter effect) ps
+ in
+ let bpos = lexpos ps in
+ (ident,
+ span ps apos bpos
+ (decl params (Ast.MOD_ITEM_fn fn)))
+ end
+
+ | TYPE ->
+ bump ps;
+ let (ident, params) = parse_ident_and_params ps "type" in
+ let _ = expect ps EQ in
+ let ty = ctxt "mod type item: ty" Pexp.parse_ty ps in
+ let _ = expect ps SEMI in
+ let bpos = lexpos ps in
+ let item = Ast.MOD_ITEM_type ty in
+ (ident, span ps apos bpos (decl params item))
+
+ | MOD ->
+ bump ps;
+ let (ident, params) = parse_ident_and_params ps "mod" in
+ expect ps LBRACE;
+ let items = parse_mod_items ps RBRACE in
+ let bpos = lexpos ps in
+ (ident,
+ span ps apos bpos
+ (decl params (Ast.MOD_ITEM_mod items)))
+
+ | NATIVE ->
+ begin
+ bump ps;
+ let conv =
+ match peek ps with
+ LIT_STR s ->
+ bump ps;
+ begin
+ match string_to_conv s with
+ None -> raise (unexpected ps)
+ | Some c -> c
+ end
+ | _ -> CONV_cdecl
+ in
+ expect ps MOD;
+ let (ident, params) = parse_ident_and_params ps "native mod" in
+ let path = parse_lib_name ident in
+ let items = parse_mod_items_from_signature ps in
+ let bpos = lexpos ps in
+ let rlib = REQUIRED_LIB_c { required_libname = path;
+ required_prefix = ps.pstate_depth }
+ in
+ let item = decl params (Ast.MOD_ITEM_mod items) in
+ let item = span ps apos bpos item in
+ note_required_mod ps {lo=apos; hi=bpos} conv rlib item;
+ (ident, item)
+ end
+
+ | USE ->
+ begin
+ bump ps;
+ let ident = ctxt "use mod: ident" Pexp.parse_ident ps in
+ let meta =
+ ctxt "use mod: meta" parse_optional_meta_pat ps ident
+ in
+ let bpos = lexpos ps in
+ let id = (span ps apos bpos ()).id in
+ let (path, items) =
+ ps.pstate_get_mod meta id ps.pstate_node_id ps.pstate_opaque_id
+ in
+ let bpos = lexpos ps in
+ expect ps SEMI;
+ let rlib =
+ REQUIRED_LIB_rust { required_libname = path;
+ required_prefix = ps.pstate_depth }
+ in
+ iflog ps
+ begin
+ fun _ ->
+ log ps "extracted mod from %s (binding to %s)"
+ path ident;
+ log ps "%a" Ast.sprintf_mod_items items;
+ end;
+ let item = decl [||] (Ast.MOD_ITEM_mod (empty_view, items)) in
+ let item = span ps apos bpos item in
+ note_required_mod ps {lo=apos; hi=bpos} CONV_rust rlib item;
+ (ident, item)
+ end
+
+
+
+ | _ -> raise (unexpected ps)
+
+
+and parse_mod_items_from_signature
+ (ps:pstate)
+ : (Ast.mod_view * Ast.mod_items) =
+ let mis = Hashtbl.create 0 in
+ expect ps LBRACE;
+ while not (peek ps = RBRACE)
+ do
+ let (ident, mti) = ctxt "mod items from sig: mod item"
+ parse_mod_item_from_signature ps
+ in
+ Hashtbl.add mis ident mti;
+ done;
+ expect ps RBRACE;
+ (empty_view, mis)
+
+
+and parse_mod_item_from_signature (ps:pstate)
+ : (Ast.ident * Ast.mod_item) =
+ let apos = lexpos ps in
+ match peek ps with
+ MOD ->
+ bump ps;
+ let (ident, params) = parse_ident_and_params ps "mod signature" in
+ let items = parse_mod_items_from_signature ps in
+ let bpos = lexpos ps in
+ (ident, span ps apos bpos (decl params (Ast.MOD_ITEM_mod items)))
+
+ | IO | STATE | UNSAFE | FN | ITER ->
+ let effect = Pexp.parse_effect ps in
+ let is_iter = (peek ps) = ITER in
+ bump ps;
+ let (ident, params) = parse_ident_and_params ps "fn signature" in
+ let (inputs, constrs, output) = parse_in_and_out ps in
+ let bpos = lexpos ps in
+ let body = span ps apos bpos [| |] in
+ let fn =
+ Ast.MOD_ITEM_fn
+ { Ast.fn_input_slots = inputs;
+ Ast.fn_input_constrs = constrs;
+ Ast.fn_output_slot = output;
+ Ast.fn_aux = { Ast.fn_effect = effect;
+ Ast.fn_is_iter = is_iter; };
+ Ast.fn_body = body; }
+ in
+ let node = span ps apos bpos (decl params fn) in
+ begin
+ match peek ps with
+ EQ ->
+ bump ps;
+ begin
+ match peek ps with
+ LIT_STR s ->
+ bump ps;
+ htab_put ps.pstate_required_syms node.id s
+ | _ -> raise (unexpected ps)
+ end;
+ | _ -> ()
+ end;
+ expect ps SEMI;
+ (ident, node)
+
+ | TYPE ->
+ bump ps;
+ let (ident, params) = parse_ident_and_params ps "type type" in
+ let t =
+ match peek ps with
+ SEMI -> Ast.TY_native (next_opaque_id ps)
+ | _ -> Pexp.parse_ty ps
+ in
+ expect ps SEMI;
+ let bpos = lexpos ps in
+ (ident, span ps apos bpos (decl params (Ast.MOD_ITEM_type t)))
+
+ (* FIXME: parse obj. *)
+ | _ -> raise (unexpected ps)
+
+
+and expand_tags
+ (ps:pstate)
+ (item:Ast.mod_item)
+ : (Ast.ident * Ast.mod_item) array =
+ let handle_ty_tag id ttag =
+ let tags = ref [] in
+ Hashtbl.iter
+ begin
+ fun name tup ->
+ let ident = match name with
+ Ast.NAME_base (Ast.BASE_ident ident) -> ident
+ | _ ->
+ raise (Parse_err
+ (ps, "unexpected name type while expanding tag"))
+ in
+ let header =
+ Array.map (fun slot -> (clone_span ps item slot)) tup
+ in
+ let tag_item' = Ast.MOD_ITEM_tag (header, ttag, id) in
+ let cloned_params =
+ Array.map (fun p -> clone_span ps p p.node)
+ item.node.Ast.decl_params
+ in
+ let tag_item =
+ clone_span ps item (decl cloned_params tag_item')
+ in
+ tags := (ident, tag_item) :: (!tags)
+ end
+ ttag;
+ arr (!tags)
+ in
+ let handle_ty_decl id tyd =
+ match tyd with
+ Ast.TY_tag ttag -> handle_ty_tag id ttag
+ | _ -> [| |]
+ in
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_type tyd -> handle_ty_decl item.id tyd
+ | _ -> [| |]
+
+
+and expand_tags_to_stmts
+ (ps:pstate)
+ (item:Ast.mod_item)
+ : Ast.stmt array =
+ let id_items = expand_tags ps item in
+ Array.map
+ (fun (ident, tag_item) ->
+ clone_span ps item
+ (Ast.STMT_decl
+ (Ast.DECL_mod_item (ident, tag_item))))
+ id_items
+
+
+and expand_tags_to_items
+ (ps:pstate)
+ (item:Ast.mod_item)
+ (items:Ast.mod_items)
+ : unit =
+ let id_items = expand_tags ps item in
+ Array.iter
+ (fun (ident, item) -> htab_put items ident item)
+ id_items
+
+
+and note_required_mod
+ (ps:pstate)
+ (sp:span)
+ (conv:nabi_conv)
+ (rlib:required_lib)
+ (item:Ast.mod_item)
+ : unit =
+ iflog ps
+ begin
+ fun _ -> log ps "marking item #%d as required" (int_of_node item.id)
+ end;
+ htab_put ps.pstate_required item.id (rlib, conv);
+ if not (Hashtbl.mem ps.pstate_sess.Session.sess_spans item.id)
+ then Hashtbl.add ps.pstate_sess.Session.sess_spans item.id sp;
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_mod (_, items) ->
+ Hashtbl.iter
+ begin
+ fun _ sub ->
+ note_required_mod ps sp conv rlib sub
+ end
+ items
+ | _ -> ()
+
+
+and parse_import
+ (ps:pstate)
+ (imports:(Ast.ident, Ast.name) Hashtbl.t)
+ : unit =
+ let import a n =
+ let a = match a with
+ None ->
+ begin
+ match n with
+ Ast.NAME_ext (_, Ast.COMP_ident i)
+ | Ast.NAME_ext (_, Ast.COMP_app (i, _))
+ | Ast.NAME_base (Ast.BASE_ident i)
+ | Ast.NAME_base (Ast.BASE_app (i, _)) -> i
+ | _ -> raise (Parse_err (ps, "bad import specification"))
+ end
+ | Some i -> i
+ in
+ Hashtbl.add imports a n
+ in
+ match peek ps with
+ IDENT i ->
+ begin
+ bump ps;
+ match peek ps with
+ EQ ->
+ (*
+ * import x = ...
+ *)
+ bump ps;
+ import (Some i) (Pexp.parse_name ps)
+ | _ ->
+ (*
+ * import x...
+ *)
+ import None (Pexp.parse_name_ext ps
+ (Ast.NAME_base
+ (Ast.BASE_ident i)))
+ end
+ | _ ->
+ import None (Pexp.parse_name ps)
+
+
+and parse_export
+ (ps:pstate)
+ (exports:(Ast.export, unit) Hashtbl.t)
+ : unit =
+ let e =
+ match peek ps with
+ STAR -> bump ps; Ast.EXPORT_all_decls
+ | IDENT i -> bump ps; Ast.EXPORT_ident i
+ | _ -> raise (unexpected ps)
+ in
+ Hashtbl.add exports e ()
+
+
+and parse_mod_items
+ (ps:pstate)
+ (terminal:token)
+ : (Ast.mod_view * Ast.mod_items) =
+ ps.pstate_depth <- ps.pstate_depth + 1;
+ let imports = Hashtbl.create 0 in
+ let exports = Hashtbl.create 0 in
+ let in_view = ref true in
+ let items = Hashtbl.create 4 in
+ while (not (peek ps = terminal))
+ do
+ if !in_view
+ then
+ match peek ps with
+ IMPORT ->
+ bump ps;
+ parse_import ps imports;
+ expect ps SEMI;
+ | EXPORT ->
+ bump ps;
+ parse_export ps exports;
+ expect ps SEMI;
+ | _ ->
+ in_view := false
+ else
+ let (ident, item) = parse_mod_item ps in
+ htab_put items ident item;
+ expand_tags_to_items ps item items;
+ done;
+ if (Hashtbl.length exports) = 0
+ then Hashtbl.add exports Ast.EXPORT_all_decls ();
+ expect ps terminal;
+ ps.pstate_depth <- ps.pstate_depth - 1;
+ let view = { Ast.view_imports = imports;
+ Ast.view_exports = exports }
+ in
+ (view, items)
+;;
+
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+
+
+{
+
+ 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 keyword_table = Hashtbl.create 100
+ 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);
+ ("claim", CLAIM);
+ ("prove", PROVE);
+
+ ("io", IO);
+ ("state", STATE);
+ ("unsafe", UNSAFE);
+
+ ("native", NATIVE);
+ ("mutable", MUTABLE);
+ ("auto", AUTO);
+
+ ("fn", FN);
+ ("iter", ITER);
+
+ ("import", IMPORT);
+ ("export", EXPORT);
+
+ ("let", LET);
+
+ ("log", LOG);
+ ("spawn", SPAWN);
+ ("thread", THREAD);
+ ("yield", YIELD);
+ ("join", JOIN);
+
+ ("bool", BOOL);
+
+ ("int", INT);
+ ("uint", UINT);
+
+ ("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 hexdig = ['0'-'9' 'a'-'f' 'A'-'F']
+let bin = "0b" ['0' '1']['0' '1' '_']*
+let hex = "0x" hexdig ['0'-'9' 'a'-'f' 'A'-'F' '_']*
+let dec = ['0'-'9']+
+let exp = ['e''E']['-''+']? dec
+let flo = (dec '.' dec (exp?)) | (dec exp)
+
+let ws = [ ' ' '\t' '\r' ]
+
+let id = ['a'-'z' 'A'-'Z' '_']['a'-'z' 'A'-'Z' '0'-'9' '_']*
+
+rule token = parse
+ ws+ { token lexbuf }
+| '\n' { lexbuf.Lexing.lex_curr_p
+ <- (bump_line lexbuf.Lexing.lex_curr_p);
+ token lexbuf }
+| "//" [^'\n']* { token lexbuf }
+
+| '+' { PLUS }
+| '-' { MINUS }
+| '*' { STAR }
+| '/' { SLASH }
+| '%' { PERCENT }
+| '=' { EQ }
+| '<' { LT }
+| "<=" { LE }
+| "==" { EQEQ }
+| "!=" { NE }
+| ">=" { GE }
+| '>' { GT }
+| '!' { NOT }
+| '&' { AND }
+| "&&" { ANDAND }
+| '|' { OR }
+| "||" { OROR }
+| "<<" { LSL }
+| ">>" { LSR }
+| ">>>" { ASR }
+| '~' { TILDE }
+| '{' { LBRACE }
+| '_' (dec 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 }
+| "<-" { LARROW }
+| "<|" { SEND }
+| "->" { RARROW }
+| '(' { LPAREN }
+| ')' { RPAREN }
+| '[' { LBRACKET }
+| ']' { RBRACKET }
+
+| id as i
+ { try
+ Hashtbl.find keyword_table i
+ with
+ Not_found -> IDENT (i)
+ }
+
+| bin as n { LIT_INT (Int64.of_string n, n) }
+| hex as n { LIT_INT (Int64.of_string n, n) }
+| dec as n { LIT_INT (Int64.of_string n, n) }
+| flo as n { LIT_FLO n }
+
+| '\'' { char lexbuf }
+| '"' { let buf = Buffer.create 32 in
+ str buf lexbuf }
+
+| 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 }
+
+
+| [^'\\' '{' '}']+ { let s = Lexing.lexeme lexbuf in
+ Buffer.add_string buf s;
+ bracequote buf depth lexbuf }
--- /dev/null
+
+open Common;;
+open Token;;
+
+(* Fundamental parser types and actions *)
+
+type get_mod_fn = (Ast.meta_pat
+ -> node_id
+ -> (node_id ref)
+ -> (opaque_id ref)
+ -> (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_temp_id : temp_id ref;
+ pstate_node_id : node_id ref;
+ pstate_opaque_id : opaque_id ref;
+ pstate_get_mod : get_mod_fn;
+ 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
+ (tref:temp_id ref)
+ (nref:node_id ref)
+ (oref:opaque_id ref)
+ (sess:Session.sess)
+ (get_mod:get_mod_fn)
+ (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_temp_id = tref;
+ pstate_node_id = nref;
+ pstate_opaque_id = oref;
+ pstate_get_mod = get_mod;
+ 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 id = !(ps.pstate_node_id) in
+ ps.pstate_node_id := Node ((int_of_node id)+1);
+ id
+;;
+
+let next_opaque_id (ps:pstate) : opaque_id =
+ let id = !(ps.pstate_opaque_id) in
+ ps.pstate_opaque_id := 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)
+;;
+
+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_interior;
+ Ast.slot_mutable = false;
+ Ast.slot_ty = Some Ast.TY_nil }
+;;
+
+let (slot_auto:Ast.slot) =
+ { Ast.slot_mode = Ast.MODE_interior;
+ Ast.slot_mutable = true;
+ Ast.slot_ty = None }
+;;
+
+let build_tmp
+ (ps:pstate)
+ (slot:Ast.slot)
+ (apos:pos)
+ (bpos:pos)
+ : (temp_id * Ast.lval * Ast.stmt) =
+ let nonce = !(ps.pstate_temp_id) in
+ ps.pstate_temp_id := Temp ((int_of_temp nonce)+1);
+ iflog ps
+ (fun _ -> log ps "building temporary %d" (int_of_temp nonce));
+ let decl = Ast.DECL_slot (Ast.KEY_temp nonce, (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 nonce)) in
+ (nonce, tmp, declstmt)
+;;
+
+(* Simple helpers *)
+
+(* FIXME: 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 ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+
+open Common;;
+open Token;;
+open Parser;;
+
+(* NB: pexps (parser-expressions) are only used transiently during
+ * parsing, static-evaluation and syntax-expansion. They're desugared
+ * into the general "item" AST and/or evaluated as part of the
+ * outermost "cexp" expressions. Expressions that can show up in source
+ * correspond to this loose grammar and have a wide-ish flexibility in
+ * *theoretical* composition; only subsets of those compositions are
+ * legal in various AST contexts.
+ *
+ * Desugaring on the fly is unfortunately complicated enough to require
+ * -- or at least "make much more convenient" -- this two-pass
+ * routine.
+ *)
+
+type pexp' =
+ PEXP_call of (pexp * pexp array)
+ | PEXP_spawn of (Ast.domain * pexp)
+ | PEXP_bind of (pexp * pexp option array)
+ | PEXP_rec of ((Ast.ident * pexp) array * pexp option)
+ | PEXP_tup of (pexp array)
+ | PEXP_vec of (Ast.slot * (pexp array))
+ | PEXP_port
+ | PEXP_chan of (pexp option)
+ | PEXP_binop of (Ast.binop * pexp * pexp)
+ | PEXP_lazy_and of (pexp * pexp)
+ | PEXP_lazy_or of (pexp * pexp)
+ | PEXP_unop of (Ast.unop * pexp)
+ | PEXP_lval of plval
+ | PEXP_lit of Ast.lit
+ | PEXP_str of string
+ | PEXP_mutable of pexp
+ | PEXP_exterior of pexp
+ | PEXP_custom of Ast.name * (token array) * (string option)
+
+and plval =
+ PLVAL_ident of Ast.ident
+ | PLVAL_app of (Ast.ident * (Ast.ty array))
+ | PLVAL_ext_name of (pexp * Ast.name_component)
+ | PLVAL_ext_pexp of (pexp * pexp)
+
+and pexp = pexp' Common.identified
+;;
+
+(* Pexp grammar. Includes names, idents, types, constrs, binops and unops,
+ etc. *)
+
+let parse_ident (ps:pstate) : Ast.ident =
+ match peek ps with
+ IDENT id -> (bump ps; id)
+ (* Decay IDX tokens to identifiers if they occur ousdide name paths. *)
+ | IDX i -> (bump ps; string_of_tok (IDX i))
+ | _ -> raise (unexpected ps)
+;;
+
+(* Enforces the restricted pexp grammar when applicable (e.g. after "bind") *)
+let check_rstr_start (ps:pstate) : 'a =
+ if (ps.pstate_rstr) then
+ match peek ps with
+ IDENT _ | LPAREN -> ()
+ | _ -> raise (unexpected ps)
+;;
+
+let rec parse_name_component (ps:pstate) : Ast.name_component =
+ match peek ps with
+ IDENT id ->
+ (bump ps;
+ match peek ps with
+ LBRACKET ->
+ let tys =
+ ctxt "name_component: apply"
+ (bracketed_one_or_more LBRACKET RBRACKET
+ (Some COMMA) parse_ty) ps
+ in
+ Ast.COMP_app (id, tys)
+ | _ -> Ast.COMP_ident id)
+
+ | IDX i ->
+ bump ps;
+ Ast.COMP_idx i
+ | _ -> raise (unexpected ps)
+
+and parse_name_base (ps:pstate) : Ast.name_base =
+ match peek ps with
+ IDENT i ->
+ (bump ps;
+ match peek ps with
+ LBRACKET ->
+ let tys =
+ ctxt "name_base: apply"
+ (bracketed_one_or_more LBRACKET RBRACKET
+ (Some COMMA) parse_ty) ps
+ in
+ Ast.BASE_app (i, tys)
+ | _ -> Ast.BASE_ident i)
+ | _ -> raise (unexpected ps)
+
+and parse_name_ext (ps:pstate) (base:Ast.name) : Ast.name =
+ match peek ps with
+ DOT ->
+ bump ps;
+ let comps = one_or_more DOT parse_name_component ps in
+ Array.fold_left (fun x y -> Ast.NAME_ext (x, y)) base comps
+ | _ -> base
+
+
+and parse_name (ps:pstate) : Ast.name =
+ let base = Ast.NAME_base (parse_name_base ps) in
+ let name = parse_name_ext ps base in
+ if Ast.sane_name name
+ then name
+ else raise (err "malformed name" ps)
+
+and parse_carg_base (ps:pstate) : Ast.carg_base =
+ match peek ps with
+ STAR -> bump ps; Ast.BASE_formal
+ | _ -> Ast.BASE_named (parse_name_base ps)
+
+and parse_carg (ps:pstate) : Ast.carg =
+ match peek ps with
+ IDENT _ ->
+ begin
+ let base = Ast.CARG_base (parse_carg_base ps) in
+ let path =
+ match peek ps with
+ DOT ->
+ bump ps;
+ let comps = one_or_more DOT parse_name_component ps in
+ Array.fold_left
+ (fun x y -> Ast.CARG_ext (x, y)) base comps
+ | _ -> base
+ in
+ Ast.CARG_path path
+ end
+ | _ ->
+ Ast.CARG_lit (parse_lit ps)
+
+
+and parse_constraint (ps:pstate) : Ast.constr =
+ match peek ps with
+
+ (*
+ * NB: A constraint *looks* a lot like an EXPR_call, but is restricted
+ * syntactically: the constraint name needs to be a name (not an lval)
+ * and the constraint args all need to be cargs, which are similar to
+ * names but can begin with the 'formal' base anchor '*'.
+ *)
+
+ IDENT _ ->
+ let n = ctxt "constraint: name" parse_name ps in
+ let args = ctxt "constraint: args"
+ (bracketed_zero_or_more
+ LPAREN RPAREN (Some COMMA)
+ parse_carg) ps
+ in
+ { Ast.constr_name = n;
+ Ast.constr_args = args }
+ | _ -> raise (unexpected ps)
+
+
+and parse_constrs (ps:pstate) : Ast.constrs =
+ ctxt "state: constraints" (one_or_more COMMA parse_constraint) ps
+
+and parse_optional_trailing_constrs (ps:pstate) : Ast.constrs =
+ match peek ps with
+ COLON -> (bump ps; parse_constrs ps)
+ | _ -> [| |]
+
+and parse_effect (ps:pstate) : Ast.effect =
+ match peek ps with
+ IO -> bump ps; Ast.IO
+ | STATE -> bump ps; Ast.STATE
+ | UNSAFE -> bump ps; Ast.UNSAFE
+ | _ -> Ast.PURE
+
+and parse_ty_fn
+ (effect:Ast.effect)
+ (ps:pstate)
+ : (Ast.ty_fn * Ast.ident option) =
+ match peek ps with
+ FN | ITER ->
+ let is_iter = (peek ps) = ITER in
+ bump ps;
+ let ident =
+ match peek ps with
+ IDENT i -> bump ps; Some i
+ | _ -> None
+ in
+ let in_slots =
+ match peek ps with
+ _ ->
+ bracketed_zero_or_more LPAREN RPAREN (Some COMMA)
+ (parse_slot_and_optional_ignored_ident true) ps
+ in
+ let out_slot =
+ match peek ps with
+ RARROW -> (bump ps; parse_slot false ps)
+ | _ -> slot_nil
+ in
+ let constrs = parse_optional_trailing_constrs ps in
+ let tsig = { Ast.sig_input_slots = in_slots;
+ Ast.sig_input_constrs = constrs;
+ Ast.sig_output_slot = out_slot; }
+ in
+ let taux = { Ast.fn_effect = effect;
+ Ast.fn_is_iter = is_iter; }
+ in
+ let tfn = (tsig, taux) in
+ (tfn, ident)
+
+ | _ -> raise (unexpected ps)
+
+and check_dup_rec_labels ps labels =
+ arr_check_dups labels
+ (fun l _ ->
+ raise (err (Printf.sprintf
+ "duplicate record label: %s" l) ps));
+
+
+and parse_atomic_ty (ps:pstate) : Ast.ty =
+ match peek ps with
+
+ BOOL ->
+ bump ps;
+ Ast.TY_bool
+
+ | INT ->
+ bump ps;
+ Ast.TY_int
+
+ | UINT ->
+ bump ps;
+ Ast.TY_uint
+
+ | CHAR ->
+ bump ps;
+ Ast.TY_char
+
+ | STR ->
+ bump ps;
+ Ast.TY_str
+
+ | ANY ->
+ bump ps;
+ Ast.TY_any
+
+ | TASK ->
+ bump ps;
+ Ast.TY_task
+
+ | CHAN ->
+ bump ps;
+ Ast.TY_chan (bracketed LBRACKET RBRACKET parse_ty ps)
+
+ | PORT ->
+ bump ps;
+ Ast.TY_port (bracketed LBRACKET RBRACKET parse_ty ps)
+
+ | VEC ->
+ bump ps;
+ Ast.TY_vec (bracketed LBRACKET RBRACKET (parse_slot false) ps)
+
+ | IDENT _ -> Ast.TY_named (parse_name ps)
+
+
+ | TAG ->
+ bump ps;
+ let htab = Hashtbl.create 4 in
+ let parse_tag_entry ps =
+ let ident = parse_ident ps in
+ let tup =
+ match peek ps with
+ LPAREN -> paren_comma_list (parse_slot false) ps
+ | _ -> raise (err "tag variant missing argument list" ps)
+ in
+ htab_put htab (Ast.NAME_base (Ast.BASE_ident ident)) tup
+ in
+ let _ =
+ bracketed_one_or_more LPAREN RPAREN
+ (Some COMMA) (ctxt "tag: variant" parse_tag_entry) ps
+ in
+ Ast.TY_tag htab
+
+ | REC ->
+ bump ps;
+ let parse_rec_entry ps =
+ let mut = parse_mutability ps in
+ let (slot, ident) = parse_slot_and_ident false ps in
+ (ident, apply_mutability slot mut)
+ in
+ let entries = paren_comma_list parse_rec_entry ps in
+ let labels = Array.map (fun (l, _) -> l) entries in
+ begin
+ check_dup_rec_labels ps labels;
+ Ast.TY_rec entries
+ end
+
+ | TUP ->
+ bump ps;
+ let slots = paren_comma_list (parse_slot false) ps in
+ Ast.TY_tup slots
+
+ | MACH m ->
+ bump ps;
+ Ast.TY_mach m
+
+ | IO | STATE | UNSAFE | OBJ | FN | ITER ->
+ let effect = parse_effect ps in
+ begin
+ match peek ps with
+ OBJ ->
+ bump ps;
+ let methods = Hashtbl.create 0 in
+ let parse_method ps =
+ let effect = parse_effect ps in
+ let (tfn, ident) = parse_ty_fn effect ps in
+ expect ps SEMI;
+ match ident with
+ None ->
+ raise (err (Printf.sprintf
+ "missing method identifier") ps)
+ | Some i -> htab_put methods i tfn
+ in
+ ignore (bracketed_zero_or_more LBRACE RBRACE
+ None parse_method ps);
+ Ast.TY_obj (effect, methods)
+
+ | FN | ITER ->
+ Ast.TY_fn (fst (parse_ty_fn effect ps))
+ | _ -> raise (unexpected ps)
+ end
+
+ | LPAREN ->
+ begin
+ bump ps;
+ match peek ps with
+ RPAREN ->
+ bump ps;
+ Ast.TY_nil
+ | _ ->
+ let t = parse_ty ps in
+ expect ps RPAREN;
+ t
+ end
+
+ | _ -> raise (unexpected ps)
+
+and flag (ps:pstate) (tok:token) : bool =
+ if peek ps = tok
+ then (bump ps; true)
+ else false
+
+and parse_mutability (ps:pstate) : bool =
+ flag ps MUTABLE
+
+and apply_mutability (slot:Ast.slot) (mut:bool) : Ast.slot =
+ { slot with Ast.slot_mutable = mut }
+
+and parse_slot (aliases_ok:bool) (ps:pstate) : Ast.slot =
+ let mut = parse_mutability ps in
+ let mode =
+ match (peek ps, aliases_ok) with
+ (AT, _) -> bump ps; Ast.MODE_exterior
+ | (AND, true) -> bump ps; Ast.MODE_alias
+ | (AND, false) -> raise (err "alias slot in prohibited context" ps)
+ | _ -> Ast.MODE_interior
+ in
+ let ty = parse_ty ps in
+ { Ast.slot_mode = mode;
+ Ast.slot_mutable = mut;
+ Ast.slot_ty = Some ty }
+
+and parse_slot_and_ident
+ (aliases_ok:bool)
+ (ps:pstate)
+ : (Ast.slot * Ast.ident) =
+ let slot = ctxt "slot and ident: slot" (parse_slot aliases_ok) ps in
+ let ident = ctxt "slot and ident: ident" parse_ident ps in
+ (slot, ident)
+
+and parse_slot_and_optional_ignored_ident
+ (aliases_ok:bool)
+ (ps:pstate)
+ : Ast.slot =
+ let slot = parse_slot aliases_ok ps in
+ begin
+ match peek ps with
+ IDENT _ -> bump ps
+ | _ -> ()
+ end;
+ slot
+
+and parse_identified_slot
+ (aliases_ok:bool)
+ (ps:pstate)
+ : Ast.slot identified =
+ let apos = lexpos ps in
+ let slot = parse_slot aliases_ok ps in
+ let bpos = lexpos ps in
+ span ps apos bpos slot
+
+and parse_constrained_ty (ps:pstate) : Ast.ty =
+ let base = ctxt "ty: base" parse_atomic_ty ps in
+ match peek ps with
+ COLON ->
+ bump ps;
+ let constrs = ctxt "ty: constrs" parse_constrs ps in
+ Ast.TY_constrained (base, constrs)
+
+ | _ -> base
+
+and parse_ty (ps:pstate) : Ast.ty =
+ parse_constrained_ty ps
+
+
+and parse_rec_input (ps:pstate) : (Ast.ident * pexp) =
+ let lab = (ctxt "rec input: label" parse_ident ps) in
+ match peek ps with
+ EQ ->
+ bump ps;
+ let pexp = ctxt "rec input: expr" parse_pexp ps in
+ (lab, pexp)
+ | _ -> raise (unexpected ps)
+
+
+and parse_rec_body (ps:pstate) : pexp' = (*((Ast.ident * pexp) array) =*)
+ begin
+ expect ps LPAREN;
+ match peek ps with
+ RPAREN -> PEXP_rec ([||], None)
+ | WITH -> raise (err "empty record extension" ps)
+ | _ ->
+ let inputs = one_or_more COMMA parse_rec_input ps in
+ let labels = Array.map (fun (l, _) -> l) inputs in
+ begin
+ check_dup_rec_labels ps labels;
+ match peek ps with
+ RPAREN -> (bump ps; PEXP_rec (inputs, None))
+ | WITH ->
+ begin
+ bump ps;
+ let base =
+ ctxt "rec input: extension base"
+ parse_pexp ps
+ in
+ expect ps RPAREN;
+ PEXP_rec (inputs, Some base)
+ end
+ | _ -> raise (err "expected 'with' or ')'" ps)
+ end
+ end
+
+
+and parse_lit (ps:pstate) : Ast.lit =
+ match peek ps with
+ LIT_INT (n,s) -> (bump ps; Ast.LIT_int (n,s))
+ | LIT_CHAR c -> (bump ps; Ast.LIT_char c)
+ | LIT_BOOL b -> (bump ps; Ast.LIT_bool b)
+ | _ -> raise (unexpected ps)
+
+
+and parse_bottom_pexp (ps:pstate) : pexp =
+ check_rstr_start ps;
+ let apos = lexpos ps in
+ match peek ps with
+
+ MUTABLE ->
+ bump ps;
+ let inner = parse_pexp ps in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_mutable inner)
+
+ | AT ->
+ bump ps;
+ let inner = parse_pexp ps in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_exterior inner)
+
+ | TUP ->
+ bump ps;
+ let pexps = ctxt "paren pexps(s)" (rstr false parse_pexp_list) ps in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_tup pexps)
+
+ | REC ->
+ bump ps;
+ let body = ctxt "rec pexp: rec body" parse_rec_body ps in
+ let bpos = lexpos ps in
+ span ps apos bpos body
+
+ | VEC ->
+ bump ps;
+ begin
+ let slot =
+ match peek ps with
+ LBRACKET -> bracketed LBRACKET RBRACKET (parse_slot false) ps
+ | _ -> { Ast.slot_mode = Ast.MODE_interior;
+ Ast.slot_mutable = false;
+ Ast.slot_ty = None }
+ in
+ let pexps = ctxt "vec pexp: exprs" parse_pexp_list ps in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_vec (slot, pexps))
+ end
+
+
+ | LIT_STR s ->
+ bump ps;
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_str s)
+
+ | PORT ->
+ begin
+ bump ps;
+ expect ps LPAREN;
+ expect ps RPAREN;
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_port)
+ end
+
+ | CHAN ->
+ begin
+ bump ps;
+ let port =
+ match peek ps with
+ LPAREN ->
+ begin
+ bump ps;
+ match peek ps with
+ RPAREN -> (bump ps; None)
+ | _ ->
+ let lv = parse_pexp ps in
+ expect ps RPAREN;
+ Some lv
+ end
+ | _ -> raise (unexpected ps)
+ in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_chan port)
+ end
+
+ | SPAWN ->
+ bump ps;
+ let domain =
+ match peek ps with
+ THREAD -> bump ps; Ast.DOMAIN_thread
+ | _ -> Ast.DOMAIN_local
+ in
+ let pexp = ctxt "spawn [domain] pexp: init call" parse_pexp ps in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_spawn (domain, pexp))
+
+ | BIND ->
+ let apos = lexpos ps in
+ begin
+ bump ps;
+ let pexp = ctxt "bind pexp: function" (rstr true parse_pexp) ps in
+ let args =
+ ctxt "bind args"
+ (paren_comma_list parse_bind_arg) ps
+ in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_bind (pexp, args))
+ end
+
+ | IDENT i ->
+ begin
+ bump ps;
+ match peek ps with
+ LBRACKET ->
+ begin
+ let tys =
+ ctxt "apply-type expr"
+ (bracketed_one_or_more LBRACKET RBRACKET
+ (Some COMMA) parse_ty) ps
+ in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_lval (PLVAL_app (i, tys)))
+ end
+
+ | _ ->
+ begin
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_lval (PLVAL_ident i))
+ end
+ end
+
+ | (INT | UINT | CHAR | BOOL) as tok ->
+ begin
+ bump ps;
+ expect ps LPAREN;
+ match peek ps with
+ (LIT_INT _ | LIT_CHAR _ | LIT_BOOL _) as tok2 ->
+ bump ps;
+ expect ps RPAREN;
+ let i = match tok2 with
+ LIT_INT i -> i
+ | LIT_CHAR c -> (Int64.of_int c,
+ Common.escaped_char c)
+ | LIT_BOOL b -> if b then (1L, "1") else (0L, "0")
+ | _ -> bug () "expected int/char literal"
+ in
+ let bpos = lexpos ps in
+ span ps apos bpos
+ (PEXP_lit
+ (match tok with
+ INT -> Ast.LIT_int i
+ | UINT -> Ast.LIT_uint i
+ | CHAR ->
+ Ast.LIT_char
+ (Int64.to_int (fst i))
+ | BOOL -> Ast.LIT_bool (fst i <> 0L)
+ | _ -> bug () "expected int/uint/char/bool token"))
+
+ | _ ->
+ let pexp = parse_pexp ps in
+ expect ps RPAREN;
+ let bpos = lexpos ps in
+ let t =
+ match tok with
+ INT -> Ast.TY_int
+ | UINT -> Ast.TY_uint
+ | CHAR -> Ast.TY_char
+ | BOOL -> Ast.TY_bool
+ | _ -> bug () "expected int/uint/char/bool token"
+ in
+ let t = span ps apos bpos t in
+ span ps apos bpos
+ (PEXP_unop ((Ast.UNOP_cast t), pexp))
+ end
+
+ | MACH m ->
+ let literal (num, str) =
+ let _ = bump ps in
+ let _ = expect ps RPAREN in
+ let bpos = lexpos ps in
+ let check_range (lo:int64) (hi:int64) : unit =
+ if (num < lo) or (num > hi)
+ then raise (err (Printf.sprintf
+ "integral literal %Ld out of range [%Ld,%Ld]"
+ num lo hi) ps)
+ else ()
+ in
+ begin
+ match m with
+ TY_u8 -> check_range 0L 0xffL
+ | TY_u16 -> check_range 0L 0xffffL
+ | TY_u32 -> check_range 0L 0xffffffffL
+ (* | TY_u64 -> ... *)
+ | TY_i8 -> check_range (-128L) 127L
+ | TY_i16 -> check_range (-32768L) 32767L
+ | TY_i32 -> check_range (-2147483648L) 2147483647L
+ (*
+ | TY_i64 -> ...
+ | TY_f32 -> ...
+ | TY_f64 -> ...
+ *)
+ | _ -> ()
+ end;
+ span ps apos bpos
+ (PEXP_lit
+ (Ast.LIT_mach
+ (m, num, str)))
+
+ in
+ begin
+ bump ps;
+ expect ps LPAREN;
+ match peek ps with
+ LIT_INT (n,s) -> literal (n,s)
+ | MINUS ->
+ begin
+ bump ps;
+ match peek ps with
+ LIT_INT (n,s) ->
+ literal (Int64.neg n, "-" ^ s)
+ | _ -> raise (unexpected ps)
+ end
+ | _ ->
+ let pexp = parse_pexp ps in
+ expect ps RPAREN;
+ let bpos = lexpos ps in
+ let t = span ps apos bpos (Ast.TY_mach m) in
+ span ps apos bpos
+ (PEXP_unop ((Ast.UNOP_cast t), pexp))
+ end
+
+ | POUND ->
+ bump ps;
+ let name = parse_name ps in
+ let toks =
+ match peek ps with
+ LPAREN ->
+ bump ps;
+ let toks = Queue.create () in
+ while (peek ps) <> RPAREN
+ do
+ Queue.add (peek ps) toks;
+ bump ps;
+ done;
+ expect ps RPAREN;
+ queue_to_arr toks
+ | _ -> [| |]
+ in
+ let str =
+ match peek ps with
+ LBRACE ->
+ begin
+ bump_bracequote ps;
+ match peek ps with
+ BRACEQUOTE s -> bump ps; Some s
+ | _ -> raise (unexpected ps)
+ end
+ | _ -> None
+ in
+ let bpos = lexpos ps in
+ span ps apos bpos
+ (PEXP_custom (name, toks, str))
+
+ | LPAREN ->
+ begin
+ bump ps;
+ match peek ps with
+ RPAREN ->
+ bump ps;
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_lit Ast.LIT_nil)
+ | _ ->
+ let pexp = parse_pexp ps in
+ expect ps RPAREN;
+ pexp
+ end
+
+ | _ ->
+ let lit = parse_lit ps in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_lit lit)
+
+
+and parse_bind_arg (ps:pstate) : pexp option =
+ match peek ps with
+ UNDERSCORE -> (bump ps; None)
+ | _ -> Some (parse_pexp ps)
+
+
+and parse_ext_pexp (ps:pstate) (pexp:pexp) : pexp =
+ let apos = lexpos ps in
+ match peek ps with
+ LPAREN ->
+ if ps.pstate_rstr
+ then pexp
+ else
+ let args = parse_pexp_list ps in
+ let bpos = lexpos ps in
+ let ext = span ps apos bpos (PEXP_call (pexp, args)) in
+ parse_ext_pexp ps ext
+
+ | DOT ->
+ begin
+ bump ps;
+ let ext =
+ match peek ps with
+ LPAREN ->
+ bump ps;
+ let rhs = rstr false parse_pexp ps in
+ expect ps RPAREN;
+ let bpos = lexpos ps in
+ span ps apos bpos
+ (PEXP_lval (PLVAL_ext_pexp (pexp, rhs)))
+ | _ ->
+ let rhs = parse_name_component ps in
+ let bpos = lexpos ps in
+ span ps apos bpos
+ (PEXP_lval (PLVAL_ext_name (pexp, rhs)))
+ in
+ parse_ext_pexp ps ext
+ end
+
+ | _ -> pexp
+
+
+and parse_negation_pexp (ps:pstate) : pexp =
+ let apos = lexpos ps in
+ match peek ps with
+ NOT ->
+ bump ps;
+ let rhs = ctxt "negation pexp" parse_negation_pexp ps in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_unop (Ast.UNOP_not, rhs))
+
+ | TILDE ->
+ bump ps;
+ let rhs = ctxt "negation pexp" parse_negation_pexp ps in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_unop (Ast.UNOP_bitnot, rhs))
+
+ | MINUS ->
+ bump ps;
+ let rhs = ctxt "negation pexp" parse_negation_pexp ps in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_unop (Ast.UNOP_neg, rhs))
+
+ | _ ->
+ let lhs = parse_bottom_pexp ps in
+ parse_ext_pexp ps lhs
+
+
+(* Binops are all left-associative, *)
+(* so we factor out some of the parsing code here. *)
+and binop_rhs
+ (ps:pstate)
+ (name:string)
+ (apos:pos)
+ (lhs:pexp)
+ (rhs_parse_fn:pstate -> pexp)
+ (op:Ast.binop)
+ : pexp =
+ bump ps;
+ let rhs = (ctxt (name ^ " rhs") rhs_parse_fn ps) in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_binop (op, lhs, rhs))
+
+
+and parse_factor_pexp (ps:pstate) : pexp =
+ let name = "factor pexp" in
+ let apos = lexpos ps in
+ let lhs = ctxt (name ^ " lhs") parse_negation_pexp ps in
+ match peek ps with
+ STAR -> binop_rhs ps name apos lhs parse_factor_pexp Ast.BINOP_mul
+ | SLASH -> binop_rhs ps name apos lhs parse_factor_pexp Ast.BINOP_div
+ | PERCENT -> binop_rhs ps name apos lhs parse_factor_pexp Ast.BINOP_mod
+ | _ -> lhs
+
+
+and parse_term_pexp (ps:pstate) : pexp =
+ let name = "term pexp" in
+ let apos = lexpos ps in
+ let lhs = ctxt (name ^ " lhs") parse_factor_pexp ps in
+ match peek ps with
+ PLUS -> binop_rhs ps name apos lhs parse_term_pexp Ast.BINOP_add
+ | MINUS -> binop_rhs ps name apos lhs parse_term_pexp Ast.BINOP_sub
+ | _ -> lhs
+
+
+and parse_shift_pexp (ps:pstate) : pexp =
+ let name = "shift pexp" in
+ let apos = lexpos ps in
+ let lhs = ctxt (name ^ " lhs") parse_term_pexp ps in
+ match peek ps with
+ LSL -> binop_rhs ps name apos lhs parse_shift_pexp Ast.BINOP_lsl
+ | LSR -> binop_rhs ps name apos lhs parse_shift_pexp Ast.BINOP_lsr
+ | ASR -> binop_rhs ps name apos lhs parse_shift_pexp Ast.BINOP_asr
+ | _ -> lhs
+
+
+and parse_and_pexp (ps:pstate) : pexp =
+ let name = "and pexp" in
+ let apos = lexpos ps in
+ let lhs = ctxt (name ^ " lhs") parse_shift_pexp ps in
+ match peek ps with
+ AND -> binop_rhs ps name apos lhs parse_and_pexp Ast.BINOP_and
+ | _ -> lhs
+
+
+and parse_xor_pexp (ps:pstate) : pexp =
+ let name = "xor pexp" in
+ let apos = lexpos ps in
+ let lhs = ctxt (name ^ " lhs") parse_and_pexp ps in
+ match peek ps with
+ CARET -> binop_rhs ps name apos lhs parse_xor_pexp Ast.BINOP_xor
+ | _ -> lhs
+
+
+and parse_or_pexp (ps:pstate) : pexp =
+ let name = "or pexp" in
+ let apos = lexpos ps in
+ let lhs = ctxt (name ^ " lhs") parse_xor_pexp ps in
+ match peek ps with
+ OR -> binop_rhs ps name apos lhs parse_or_pexp Ast.BINOP_or
+ | _ -> lhs
+
+
+and parse_relational_pexp (ps:pstate) : pexp =
+ let name = "relational pexp" in
+ let apos = lexpos ps in
+ let lhs = ctxt (name ^ " lhs") parse_or_pexp ps in
+ match peek ps with
+ LT -> binop_rhs ps name apos lhs parse_relational_pexp Ast.BINOP_lt
+ | LE -> binop_rhs ps name apos lhs parse_relational_pexp Ast.BINOP_le
+ | GE -> binop_rhs ps name apos lhs parse_relational_pexp Ast.BINOP_ge
+ | GT -> binop_rhs ps name apos lhs parse_relational_pexp Ast.BINOP_gt
+ | _ -> lhs
+
+
+and parse_equality_pexp (ps:pstate) : pexp =
+ let name = "equality pexp" in
+ let apos = lexpos ps in
+ let lhs = ctxt (name ^ " lhs") parse_relational_pexp ps in
+ match peek ps with
+ EQEQ -> binop_rhs ps name apos lhs parse_equality_pexp Ast.BINOP_eq
+ | NE -> binop_rhs ps name apos lhs parse_equality_pexp Ast.BINOP_ne
+ | _ -> lhs
+
+
+and parse_andand_pexp (ps:pstate) : pexp =
+ let name = "andand pexp" in
+ let apos = lexpos ps in
+ let lhs = ctxt (name ^ " lhs") parse_equality_pexp ps in
+ match peek ps with
+ ANDAND ->
+ bump ps;
+ let rhs = parse_andand_pexp ps in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_lazy_and (lhs, rhs))
+
+ | _ -> lhs
+
+
+and parse_oror_pexp (ps:pstate) : pexp =
+ let name = "oror pexp" in
+ let apos = lexpos ps in
+ let lhs = ctxt (name ^ " lhs") parse_andand_pexp ps in
+ match peek ps with
+ OROR ->
+ bump ps;
+ let rhs = parse_oror_pexp ps in
+ let bpos = lexpos ps in
+ span ps apos bpos (PEXP_lazy_or (lhs, rhs))
+
+ | _ -> lhs
+
+and parse_as_pexp (ps:pstate) : pexp =
+ let apos = lexpos ps in
+ let pexp = ctxt "as pexp" parse_oror_pexp ps in
+ match peek ps with
+ AS ->
+ bump ps;
+ let tapos = lexpos ps in
+ let t = parse_ty ps in
+ let bpos = lexpos ps in
+ let t = span ps tapos bpos t in
+ span ps apos bpos
+ (PEXP_unop ((Ast.UNOP_cast t), pexp))
+
+ | _ -> pexp
+
+and parse_pexp (ps:pstate) : pexp =
+ parse_as_pexp ps
+
+
+and parse_pexp_list (ps:pstate) : pexp array =
+ match peek ps with
+ LPAREN ->
+ bracketed_zero_or_more LPAREN RPAREN (Some COMMA)
+ (ctxt "pexp list" parse_pexp) ps
+ | _ -> raise (unexpected ps)
+
+;;
+
+(*
+ * 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 in the bootstrap compiler. 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.
+ *)
+
+let expand_pexp_custom
+ (ps:pstate)
+ (name:Ast.name)
+ (args:token array)
+ (body:string option)
+ : pexp' =
+ let nstr = Ast.fmt_to_str Ast.fmt_name name in
+ match (nstr, (Array.length args), body) with
+
+ ("shell", 0, Some cmd) ->
+ let c = Unix.open_process_in cmd in
+ let b = Buffer.create 32 in
+ let rec r _ =
+ try
+ Buffer.add_char b (input_char c);
+ r ()
+ with
+ End_of_file ->
+ ignore (Unix.close_process_in c);
+ Buffer.contents b
+ in
+ PEXP_str (r ())
+
+ | _ ->
+ raise (err ("unsupported syntax extension: " ^ nstr) ps)
+;;
+
+(*
+ * Desugarings depend on context:
+ *
+ * - If a pexp is used on the RHS of an assignment, it's turned into
+ * an initialization statement such as STMT_init_rec or such. This
+ * removes the possibility of initializing into a temp only to
+ * copy out. If the topmost pexp in such a desugaring is an atom,
+ * unop or binop, of course, it will still just emit a STMT_copy
+ * on a primitive expression.
+ *
+ * - If a pexp is used in the context where an atom is required, a
+ * statement declaring a temporary and initializing it with the
+ * result of the pexp is prepended, and the temporary atom is used.
+ *)
+
+let rec desugar_lval (ps:pstate) (pexp:pexp) : (Ast.stmt array * Ast.lval) =
+ let s = Hashtbl.find ps.pstate_sess.Session.sess_spans pexp.id in
+ let (apos, bpos) = (s.lo, s.hi) in
+ match pexp.node with
+
+ PEXP_lval (PLVAL_ident ident) ->
+ let nb = span ps apos bpos (Ast.BASE_ident ident) in
+ ([||], Ast.LVAL_base nb)
+
+ | PEXP_lval (PLVAL_app (ident, tys)) ->
+ let nb = span ps apos bpos (Ast.BASE_app (ident, tys)) in
+ ([||], Ast.LVAL_base nb)
+
+ | PEXP_lval (PLVAL_ext_name (base_pexp, comp)) ->
+ let (base_stmts, base_atom) = desugar_expr_atom ps base_pexp in
+ let base_lval = atom_lval ps base_atom in
+ (base_stmts, Ast.LVAL_ext (base_lval, Ast.COMP_named comp))
+
+ | PEXP_lval (PLVAL_ext_pexp (base_pexp, ext_pexp)) ->
+ let (base_stmts, base_atom) = desugar_expr_atom ps base_pexp in
+ let (ext_stmts, ext_atom) = desugar_expr_atom ps ext_pexp in
+ let base_lval = atom_lval ps base_atom in
+ (Array.append base_stmts ext_stmts,
+ Ast.LVAL_ext (base_lval, Ast.COMP_atom (clone_atom ps ext_atom)))
+
+ | _ ->
+ let (stmts, atom) = desugar_expr_atom ps pexp in
+ (stmts, atom_lval ps atom)
+
+
+and desugar_expr
+ (ps:pstate)
+ (pexp:pexp)
+ : (Ast.stmt array * Ast.expr) =
+ match pexp.node with
+
+ PEXP_unop (op, pe) ->
+ let (stmts, at) = desugar_expr_atom ps pe in
+ (stmts, Ast.EXPR_unary (op, at))
+
+ | PEXP_binop (op, lhs, rhs) ->
+ let (lhs_stmts, lhs_atom) = desugar_expr_atom ps lhs in
+ let (rhs_stmts, rhs_atom) = desugar_expr_atom ps rhs in
+ (Array.append lhs_stmts rhs_stmts,
+ Ast.EXPR_binary (op, lhs_atom, rhs_atom))
+
+ | _ ->
+ let (stmts, at) = desugar_expr_atom ps pexp in
+ (stmts, Ast.EXPR_atom at)
+
+
+and desugar_opt_expr_atom
+ (ps:pstate)
+ (po:pexp option)
+ : (Ast.stmt array * Ast.atom option) =
+ match po with
+ None -> ([| |], None)
+ | Some pexp ->
+ let (stmts, atom) = desugar_expr_atom ps pexp in
+ (stmts, Some atom)
+
+
+and desugar_expr_atom
+ (ps:pstate)
+ (pexp:pexp)
+ : (Ast.stmt array * Ast.atom) =
+ let s = Hashtbl.find ps.pstate_sess.Session.sess_spans pexp.id in
+ let (apos, bpos) = (s.lo, s.hi) in
+ match pexp.node with
+
+ PEXP_unop _
+ | PEXP_binop _
+ | PEXP_lazy_or _
+ | PEXP_lazy_and _
+ | PEXP_rec _
+ | PEXP_tup _
+ | PEXP_str _
+ | PEXP_vec _
+ | PEXP_port
+ | PEXP_chan _
+ | PEXP_call _
+ | PEXP_bind _
+ | PEXP_spawn _ ->
+ let (_, tmp, decl_stmt) = build_tmp ps slot_auto apos bpos in
+ let stmts = desugar_expr_init ps tmp pexp in
+ (Array.append [| decl_stmt |] stmts,
+ Ast.ATOM_lval (clone_lval ps tmp))
+
+ | PEXP_lit lit ->
+ ([||], Ast.ATOM_literal (span ps apos bpos lit))
+
+ | PEXP_lval _ ->
+ let (stmts, lval) = desugar_lval ps pexp in
+ (stmts, Ast.ATOM_lval lval)
+
+ | PEXP_exterior _ ->
+ raise (err "exterior symbol in atom context" ps)
+
+ | PEXP_mutable _ ->
+ raise (err "mutable keyword in atom context" ps)
+
+ | PEXP_custom (n, a, b) ->
+ desugar_expr_atom ps
+ { pexp with node = expand_pexp_custom ps n a b }
+
+
+and desugar_expr_mode_mut_atom
+ (ps:pstate)
+ (pexp:pexp)
+ : (Ast.stmt array * (Ast.mode * bool * Ast.atom)) =
+ let desugar_inner mode mut e =
+ let (stmts, atom) = desugar_expr_atom ps e in
+ (stmts, (mode, mut, atom))
+ in
+ match pexp.node with
+ PEXP_mutable {node=(PEXP_exterior e); id=_} ->
+ desugar_inner Ast.MODE_exterior true e
+ | PEXP_exterior e ->
+ desugar_inner Ast.MODE_exterior false e
+ | PEXP_mutable e ->
+ desugar_inner Ast.MODE_interior true e
+ | _ ->
+ desugar_inner Ast.MODE_interior false pexp
+
+and desugar_expr_atoms
+ (ps:pstate)
+ (pexps:pexp array)
+ : (Ast.stmt array * Ast.atom array) =
+ arj1st (Array.map (desugar_expr_atom ps) pexps)
+
+and desugar_opt_expr_atoms
+ (ps:pstate)
+ (pexps:pexp option array)
+ : (Ast.stmt array * Ast.atom option array) =
+ arj1st (Array.map (desugar_opt_expr_atom ps) pexps)
+
+and desugar_expr_mode_mut_atoms
+ (ps:pstate)
+ (pexps:pexp array)
+ : (Ast.stmt array * (Ast.mode * bool * Ast.atom) array) =
+ arj1st (Array.map (desugar_expr_mode_mut_atom ps) pexps)
+
+and desugar_expr_init
+ (ps:pstate)
+ (dst_lval:Ast.lval)
+ (pexp:pexp)
+ : (Ast.stmt array) =
+ let s = Hashtbl.find ps.pstate_sess.Session.sess_spans pexp.id in
+ let (apos, bpos) = (s.lo, s.hi) in
+
+ (* Helpers. *)
+ let ss x = span ps apos bpos x in
+ let cp v = Ast.STMT_copy (clone_lval ps dst_lval, v) in
+ let aa x y = Array.append x y in
+ let ac xs = Array.concat xs in
+
+ match pexp.node with
+
+ PEXP_lit _
+ | PEXP_lval _ ->
+ let (stmts, atom) = desugar_expr_atom ps pexp in
+ aa stmts [| ss (cp (Ast.EXPR_atom atom)) |]
+
+ | PEXP_binop (op, lhs, rhs) ->
+ let (lhs_stmts, lhs_atom) = desugar_expr_atom ps lhs in
+ let (rhs_stmts, rhs_atom) = desugar_expr_atom ps rhs in
+ let copy_stmt =
+ ss (cp (Ast.EXPR_binary (op, lhs_atom, rhs_atom)))
+ in
+ ac [ lhs_stmts; rhs_stmts; [| copy_stmt |] ]
+
+ (* x = a && b ==> if (a) { x = b; } else { x = false; } *)
+
+ | PEXP_lazy_and (lhs, rhs) ->
+ let (lhs_stmts, lhs_atom) = desugar_expr_atom ps lhs in
+ let (rhs_stmts, rhs_atom) = desugar_expr_atom ps rhs in
+ let sthen =
+ ss (aa rhs_stmts [| ss (cp (Ast.EXPR_atom rhs_atom)) |])
+ in
+ let selse =
+ ss [| ss (cp (Ast.EXPR_atom
+ (Ast.ATOM_literal (ss (Ast.LIT_bool false))))) |]
+ in
+ let sif =
+ ss (Ast.STMT_if { Ast.if_test = Ast.EXPR_atom lhs_atom;
+ Ast.if_then = sthen;
+ Ast.if_else = Some selse })
+ in
+ aa lhs_stmts [| sif |]
+
+ (* x = a || b ==> if (a) { x = true; } else { x = b; } *)
+
+ | PEXP_lazy_or (lhs, rhs) ->
+ let (lhs_stmts, lhs_atom) = desugar_expr_atom ps lhs in
+ let (rhs_stmts, rhs_atom) = desugar_expr_atom ps rhs in
+ let sthen =
+ ss [| ss (cp (Ast.EXPR_atom
+ (Ast.ATOM_literal (ss (Ast.LIT_bool true))))) |]
+ in
+ let selse =
+ ss (aa rhs_stmts [| ss (cp (Ast.EXPR_atom rhs_atom)) |])
+ in
+ let sif =
+ ss (Ast.STMT_if { Ast.if_test = Ast.EXPR_atom lhs_atom;
+ Ast.if_then = sthen;
+ Ast.if_else = Some selse })
+ in
+ aa lhs_stmts [| sif |]
+
+
+ | PEXP_unop (op, rhs) ->
+ let (rhs_stmts, rhs_atom) = desugar_expr_atom ps rhs in
+ let expr = Ast.EXPR_unary (op, rhs_atom) in
+ let copy_stmt = ss (cp expr) in
+ aa rhs_stmts [| copy_stmt |]
+
+ | PEXP_call (fn, args) ->
+ let (fn_stmts, fn_atom) = desugar_expr_atom ps fn in
+ let (arg_stmts, arg_atoms) = desugar_expr_atoms ps args in
+ let fn_lval = atom_lval ps fn_atom in
+ let call_stmt = ss (Ast.STMT_call (dst_lval, fn_lval, arg_atoms)) in
+ ac [ fn_stmts; arg_stmts; [| call_stmt |] ]
+
+ | PEXP_bind (fn, args) ->
+ let (fn_stmts, fn_atom) = desugar_expr_atom ps fn in
+ let (arg_stmts, arg_atoms) = desugar_opt_expr_atoms ps args in
+ let fn_lval = atom_lval ps fn_atom in
+ let bind_stmt = ss (Ast.STMT_bind (dst_lval, fn_lval, arg_atoms)) in
+ ac [ fn_stmts; arg_stmts; [| bind_stmt |] ]
+
+ | PEXP_spawn (domain, sub) ->
+ begin
+ match sub.node with
+ PEXP_call (fn, args) ->
+ let (fn_stmts, fn_atom) = desugar_expr_atom ps fn in
+ let (arg_stmts, arg_atoms) = desugar_expr_atoms ps args in
+ let fn_lval = atom_lval ps fn_atom in
+ let spawn_stmt =
+ ss (Ast.STMT_spawn (dst_lval, domain, fn_lval, arg_atoms))
+ in
+ ac [ fn_stmts; arg_stmts; [| spawn_stmt |] ]
+ | _ -> raise (err "non-call spawn" ps)
+ end
+
+ | PEXP_rec (args, base) ->
+ let (arg_stmts, entries) =
+ arj1st
+ begin
+ Array.map
+ begin
+ fun (ident, pexp) ->
+ let (stmts, (mode, mut, atom)) =
+ desugar_expr_mode_mut_atom ps pexp
+ in
+ (stmts, (ident, mode, mut, atom))
+ end
+ args
+ end
+ in
+ begin
+ match base with
+ Some base ->
+ let (base_stmts, base_lval) = desugar_lval ps base in
+ let rec_stmt =
+ ss (Ast.STMT_init_rec
+ (dst_lval, entries, Some base_lval))
+ in
+ ac [ arg_stmts; base_stmts; [| rec_stmt |] ]
+ | None ->
+ let rec_stmt =
+ ss (Ast.STMT_init_rec (dst_lval, entries, None))
+ in
+ aa arg_stmts [| rec_stmt |]
+ end
+
+ | PEXP_tup args ->
+ let (arg_stmts, arg_mode_atoms) =
+ desugar_expr_mode_mut_atoms ps args
+ in
+ let stmt = ss (Ast.STMT_init_tup (dst_lval, arg_mode_atoms)) in
+ aa arg_stmts [| stmt |]
+
+ | PEXP_str s ->
+ let stmt = ss (Ast.STMT_init_str (dst_lval, s)) in
+ [| stmt |]
+
+ | PEXP_vec (slot, args) ->
+ let (arg_stmts, arg_atoms) = desugar_expr_atoms ps args in
+ let stmt = ss (Ast.STMT_init_vec (dst_lval, slot, arg_atoms)) in
+ aa arg_stmts [| stmt |]
+
+ | PEXP_port ->
+ [| ss (Ast.STMT_init_port dst_lval) |]
+
+ | PEXP_chan pexp_opt ->
+ let (port_stmts, port_opt) =
+ match pexp_opt with
+ None -> ([||], None)
+ | Some port_pexp ->
+ begin
+ let (port_stmts, port_atom) =
+ desugar_expr_atom ps port_pexp
+ in
+ let port_lval = atom_lval ps port_atom in
+ (port_stmts, Some port_lval)
+ end
+ in
+ let chan_stmt =
+ ss
+ (Ast.STMT_init_chan (dst_lval, port_opt))
+ in
+ aa port_stmts [| chan_stmt |]
+
+ | PEXP_exterior _ ->
+ raise (err "exterior symbol in initialiser context" ps)
+
+ | PEXP_mutable _ ->
+ raise (err "mutable keyword in initialiser context" ps)
+
+ | PEXP_custom (n, a, b) ->
+ desugar_expr_init ps dst_lval
+ { pexp with node = expand_pexp_custom ps n a b }
+
+
+and atom_lval (ps:pstate) (at:Ast.atom) : Ast.lval =
+ match at with
+ Ast.ATOM_lval lv -> lv
+ | Ast.ATOM_literal _ -> raise (err "literal where lval expected" ps)
+;;
+
+
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+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
+ | 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
+
+ (* Type and type-state keywords *)
+ | TYPE
+ | CHECK
+ | CLAIM
+ | PROVE
+
+ (* Effect keywords *)
+ | IO
+ | STATE
+ | UNSAFE
+
+ (* Type qualifiers *)
+ | NATIVE
+ | AUTO
+ | MUTABLE
+
+ (* Name management *)
+ | IMPORT
+ | EXPORT
+
+ (* Value / stmt declarators *)
+ | LET
+
+ (* Magic runtime services *)
+ | LOG
+ | SPAWN
+ | BIND
+ | THREAD
+ | YIELD
+ | JOIN
+
+ (* Literals *)
+ | LIT_INT of (int64 * string)
+ | LIT_FLO of string
+ | 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
+ | 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 -> ":"
+ | 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"
+
+ (* Type and type-state keywords *)
+ | TYPE -> "type"
+ | CHECK -> "check"
+ | CLAIM -> "claim"
+ | PROVE -> "prove"
+
+ (* Effect keywords *)
+ | IO -> "io"
+ | STATE -> "state"
+ | UNSAFE -> "unsafe"
+
+ (* Type qualifiers *)
+ | NATIVE -> "native"
+ | AUTO -> "auto"
+ | MUTABLE -> "mutable"
+
+ (* Name management *)
+ | IMPORT -> "import"
+ | EXPORT -> "export"
+
+ (* Value / stmt declarators. *)
+ | LET -> "let"
+
+ (* Magic runtime services *)
+ | LOG -> "log"
+ | SPAWN -> "spawn"
+ | BIND -> "bind"
+ | THREAD -> "thread"
+ | YIELD -> "yield"
+ | JOIN -> "join"
+
+ (* Literals *)
+ | LIT_INT (_,s) -> s
+ | LIT_FLO n -> n
+ | 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"
+ | 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 -> "fn"
+
+ (* 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 ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(*
+ * LLVM integration with the Rust runtime.
+ *)
+
+type abi = {
+ crate_ty: Llvm.lltype;
+ task_ty: Llvm.lltype;
+ word_ty: Llvm.lltype;
+ rust_start: Llvm.llvalue;
+};;
+
+let declare_abi (llctx:Llvm.llcontext) (llmod:Llvm.llmodule) : abi =
+ let i32 = Llvm.i32_type llctx in
+
+ let crate_ty =
+ (* TODO: other architectures besides x86 *)
+ let crate_opaque_ty = Llvm.opaque_type llctx in
+ let crate_tyhandle = Llvm.handle_to_type (Llvm.struct_type llctx [|
+ i32; (* ptrdiff_t image_base_off *)
+ Llvm.pointer_type crate_opaque_ty;(* uintptr_t self_addr *)
+ i32; (* ptrdiff_t debug_abbrev_off *)
+ i32; (* size_t debug_abbrev_sz *)
+ i32; (* ptrdiff_t debug_info_off *)
+ i32; (* size_t debug_info_sz *)
+ i32; (* size_t activate_glue_off *)
+ i32; (* size_t main_exit_task_glue_off *)
+ i32; (* size_t unwind_glue_off *)
+ i32; (* size_t yield_glue_off *)
+ i32; (* int n_rust_syms *)
+ i32; (* int n_c_syms *)
+ i32 (* int n_libs *)
+ |])
+ in
+ Llvm.refine_type crate_opaque_ty (Llvm.type_of_handle crate_tyhandle);
+ Llvm.type_of_handle crate_tyhandle
+ in
+ ignore (Llvm.define_type_name "rust_crate" crate_ty llmod);
+
+ let task_ty =
+ (* TODO: other architectures besides x86 *)
+ Llvm.struct_type llctx [|
+ i32; (* size_t refcnt *)
+ Llvm.pointer_type i32; (* stk_seg *stk *)
+ Llvm.pointer_type i32; (* uintptr_t runtime_sp *)
+ Llvm.pointer_type i32; (* uintptr_t rust_sp *)
+ Llvm.pointer_type i32; (* rust_rt *rt *)
+ Llvm.pointer_type i32 (* rust_crate_cache *cache *)
+ |]
+ in
+ ignore (Llvm.define_type_name "rust_task" task_ty llmod);
+
+ let rust_start_ty =
+ let task_ptr_ty = Llvm.pointer_type task_ty in
+ let llnilty = Llvm.array_type (Llvm.i1_type llctx) 0 in
+ let main_ty = Llvm.function_type (Llvm.void_type llctx)
+ [| Llvm.pointer_type llnilty; task_ptr_ty; |]
+ in
+ let args_ty = Array.map Llvm.pointer_type [| main_ty; crate_ty; |] in
+ let args_ty = Array.append args_ty [| i32; i32 |] in
+ Llvm.function_type i32 args_ty
+ in
+ {
+ crate_ty = crate_ty;
+ task_ty = task_ty;
+ word_ty = i32;
+ rust_start = Llvm.declare_function "rust_start" rust_start_ty llmod
+ }
+;;
+
--- /dev/null
+(*
+ * machine-specific assembler routines.
+ *)
+
+open Common;;
+
+type asm_glue =
+ {
+ asm_activate_glue : Llvm.llvalue;
+ asm_yield_glue : Llvm.llvalue;
+ asm_upcall_glues : Llvm.llvalue array;
+ }
+;;
+
+let n_upcall_glues = 7
+;;
+
+(* x86-specific asm. *)
+
+let x86_glue
+ (llctx:Llvm.llcontext)
+ (llmod:Llvm.llmodule)
+ (abi:Llabi.abi)
+ (sess:Session.sess)
+ : asm_glue =
+ let (prefix,align) =
+ match sess.Session.sess_targ with
+ Linux_x86_elf
+ | Win32_x86_pe -> ("",4)
+ | MacOS_x86_macho -> ("_", 16)
+ in
+ let save_callee_saves =
+ ["pushl %ebp";
+ "pushl %edi";
+ "pushl %esi";
+ "pushl %ebx";]
+ in
+ let restore_callee_saves =
+ ["popl %ebx";
+ "popl %esi";
+ "popl %edi";
+ "popl %ebp";]
+ in
+ let load_esp_from_rust_sp = ["movl 12(%edx), %esp"] in
+ let load_esp_from_runtime_sp = ["movl 8(%edx), %esp"] in
+ let store_esp_to_rust_sp = ["movl %esp, 12(%edx)"] in
+ let store_esp_to_runtime_sp = ["movl %esp, 8(%edx)"] in
+ let list_init i f = (Array.to_list (Array.init i f)) in
+ let list_init_concat i f = List.concat (list_init i f) in
+
+ let glue =
+ [
+ ("rust_activate_glue",
+ String.concat "\n\t"
+ (["movl 4(%esp), %edx # edx = rust_task"]
+ @ save_callee_saves
+ @ store_esp_to_runtime_sp
+ @ load_esp_from_rust_sp
+ (*
+ * This 'add' instruction is a bit surprising.
+ * See lengthy comment in boot/be/x86.ml activate_glue.
+ *)
+ @ ["addl $20, 12(%edx)"]
+ @ restore_callee_saves
+ @ ["ret"]));
+
+ ("rust_yield_glue",
+ String.concat "\n\t"
+
+ (["movl 0(%esp), %edx # edx = rust_task"]
+ @ load_esp_from_rust_sp
+ @ save_callee_saves
+ @ store_esp_to_rust_sp
+ @ load_esp_from_runtime_sp
+ @ restore_callee_saves
+ @ ["ret"]))
+ ]
+ @ list_init n_upcall_glues
+ begin
+ fun i ->
+ (*
+ * 0, 4, 8, 12 are callee-saves
+ * 16 is retpc
+ * 20 is taskptr
+ * 24 is callee
+ * 28 .. (7+i) * 4 are args
+ *)
+
+ ((Printf.sprintf "rust_upcall_%d" i),
+ String.concat "\n\t"
+ (save_callee_saves
+ @ ["movl %esp, %ebp # ebp = rust_sp";
+ "movl 20(%esp), %edx # edx = rust_task"]
+ @ store_esp_to_rust_sp
+ @ load_esp_from_runtime_sp
+ @ [Printf.sprintf
+ "subl $%d, %%esp # esp -= args" ((i+1)*4);
+ "andl $~0xf, %esp # align esp down";
+ "movl %edx, (%esp) # arg[0] = rust_task "]
+
+ @ (list_init_concat i
+ begin
+ fun j ->
+ [ Printf.sprintf "movl %d(%%ebp),%%edx" ((j+7)*4);
+ Printf.sprintf "movl %%edx,%d(%%esp)" ((j+1)*4) ]
+ end)
+
+ @ ["movl 24(%ebp), %edx # edx = callee";
+ "call *%edx # call *%edx";
+ "movl 20(%ebp), %edx # edx = rust_task"]
+ @ load_esp_from_rust_sp
+ @ restore_callee_saves
+ @ ["ret"]))
+ end
+ in
+
+ let _ =
+ Llvm.set_module_inline_asm llmod
+ begin
+ String.concat "\n"
+ begin
+ List.map
+ begin
+ fun (sym,asm) ->
+ Printf.sprintf
+ "\t.globl %s%s\n\t.balign %d\n%s%s:\n\t%s"
+ prefix sym align prefix sym asm
+ end
+ glue
+ end
+ end
+ in
+
+ let decl_cdecl_fn name out_ty arg_tys =
+ let ty = Llvm.function_type out_ty arg_tys in
+ let fn = Llvm.declare_function name ty llmod in
+ Llvm.set_function_call_conv Llvm.CallConv.c fn;
+ fn
+ in
+
+ let decl_glue s =
+ let task_ptr_ty = Llvm.pointer_type abi.Llabi.task_ty in
+ let void_ty = Llvm.void_type llctx in
+ decl_cdecl_fn s void_ty [| task_ptr_ty |]
+ in
+
+ let decl_upcall n =
+ let task_ptr_ty = Llvm.pointer_type abi.Llabi.task_ty in
+ let word_ty = abi.Llabi.word_ty in
+ let callee_ty = word_ty in
+ let args_ty =
+ Array.append
+ [| task_ptr_ty; callee_ty |]
+ (Array.init n (fun _ -> word_ty))
+ in
+ let name = Printf.sprintf "rust_upcall_%d" n in
+ decl_cdecl_fn name word_ty args_ty
+ in
+ {
+ asm_activate_glue = decl_glue "rust_activate_glue";
+ asm_yield_glue = decl_glue "rust_yield_glue";
+ asm_upcall_glues = Array.init n_upcall_glues decl_upcall;
+ }
+;;
+
+(* x64-specific asm. *)
+(* arm-specific asm. *)
+(* ... *)
+
+
+let get_glue
+ (llctx:Llvm.llcontext)
+ (llmod:Llvm.llmodule)
+ (abi:Llabi.abi)
+ (sess:Session.sess)
+ : asm_glue =
+ match sess.Session.sess_targ with
+ Linux_x86_elf
+ | Win32_x86_pe
+ | MacOS_x86_macho ->
+ x86_glue llctx llmod abi sess
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(*
+ * LLVM emitter.
+ *)
+
+(* The top-level interface to the LLVM translation subsystem. *)
+let trans_and_process_crate
+ (sess:Session.sess)
+ (sem_cx:Semant.ctxt)
+ (crate:Ast.crate)
+ : unit =
+ let llcontext = Llvm.create_context () in
+ let emit_file (llmod:Llvm.llmodule) : unit =
+ let filename = Session.filename_of sess.Session.sess_out in
+ if not (Llvm_bitwriter.write_bitcode_file llmod filename)
+ then raise (Failure ("failed to write the LLVM bitcode '" ^ filename
+ ^ "'"))
+ in
+ let llmod = Lltrans.trans_crate sem_cx llcontext sess crate in
+ begin
+ try
+ emit_file llmod
+ with e -> Llvm.dispose_module llmod; raise e
+ end;
+ Llvm.dispose_module llmod;
+ Llvm.dispose_context llcontext
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
+
--- /dev/null
+(*
+ * LLVM ABI-level stuff that needs to happen after modules have been
+ * translated.
+ *)
+
+let finalize_module
+ (llctx:Llvm.llcontext)
+ (llmod:Llvm.llmodule)
+ (abi:Llabi.abi)
+ (asm_glue:Llasm.asm_glue)
+ (exit_task_glue:Llvm.llvalue)
+ (crate_ptr:Llvm.llvalue)
+ : unit =
+ let i32 = Llvm.i32_type llctx in
+
+ (*
+ * Count the number of Rust functions and the number of C functions by
+ * simply (and crudely) testing whether each function in the module begins
+ * with "_rust_".
+ *)
+
+ let (rust_fn_count, c_fn_count) =
+ let count (rust_fn_count, c_fn_count) fn =
+ let begins_with prefix str =
+ let (str_len, prefix_len) =
+ (String.length str, String.length prefix)
+ in
+ prefix_len <= str_len && (String.sub str 0 prefix_len) = prefix
+ in
+ if begins_with "_rust_" (Llvm.value_name fn) then
+ (rust_fn_count + 1, c_fn_count)
+ else
+ (rust_fn_count, c_fn_count + 1)
+ in
+ Llvm.fold_left_functions count (0, 0) llmod
+ in
+
+ let crate_val =
+ let crate_addr = Llvm.const_ptrtoint crate_ptr i32 in
+ let glue_off glue =
+ let addr = Llvm.const_ptrtoint glue i32 in
+ Llvm.const_sub addr crate_addr
+ in
+ let activate_glue_off = glue_off asm_glue.Llasm.asm_activate_glue in
+ let yield_glue_off = glue_off asm_glue.Llasm.asm_yield_glue in
+ let exit_task_glue_off = glue_off exit_task_glue in
+
+ Llvm.const_struct llctx [|
+ Llvm.const_int i32 0; (* ptrdiff_t image_base_off *)
+ crate_ptr; (* uintptr_t self_addr *)
+ Llvm.const_int i32 0; (* ptrdiff_t debug_abbrev_off *)
+ Llvm.const_int i32 0; (* size_t debug_abbrev_sz *)
+ Llvm.const_int i32 0; (* ptrdiff_t debug_info_off *)
+ Llvm.const_int i32 0; (* size_t debug_info_sz *)
+ activate_glue_off; (* size_t activate_glue_off *)
+ exit_task_glue_off; (* size_t main_exit_task_glue_off *)
+ Llvm.const_int i32 0; (* size_t unwind_glue_off *)
+ yield_glue_off; (* size_t yield_glue_off *)
+ Llvm.const_int i32 rust_fn_count; (* int n_rust_syms *)
+ Llvm.const_int i32 c_fn_count; (* int n_c_syms *)
+ Llvm.const_int i32 0 (* int n_libs *)
+ |]
+ in
+
+ Llvm.set_initializer crate_val crate_ptr;
+
+ (* Define the main function for crt0 to call. *)
+ let main_fn =
+ let main_ty = Llvm.function_type i32 [| i32; i32 |] in
+ Llvm.define_function "main" main_ty llmod
+ in
+ let argc = Llvm.param main_fn 0 in
+ let argv = Llvm.param main_fn 1 in
+ let main_builder = Llvm.builder_at_end llctx (Llvm.entry_block main_fn) in
+ let rust_main_fn =
+ match Llvm.lookup_function "_rust_main" llmod with
+ None -> raise (Failure "no main function found")
+ | Some fn -> fn
+ in
+ let rust_start = abi.Llabi.rust_start in
+ let rust_start_args = [| rust_main_fn; crate_ptr; argc; argv |] in
+ ignore (Llvm.build_call
+ rust_start rust_start_args "start_rust" main_builder);
+ ignore (Llvm.build_ret (Llvm.const_int i32 0) main_builder)
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
+
--- /dev/null
+(*
+ * LLVM translator.
+ *)
+
+open Common;;
+open Transutil;;
+
+let log cx = Session.log "trans"
+ cx.Semant.ctxt_sess.Session.sess_log_trans
+ cx.Semant.ctxt_sess.Session.sess_log_out
+;;
+
+let trans_crate
+ (sem_cx:Semant.ctxt)
+ (llctx:Llvm.llcontext)
+ (sess:Session.sess)
+ (crate:Ast.crate)
+ : Llvm.llmodule =
+
+ let iflog thunk =
+ if sess.Session.sess_log_trans
+ then thunk ()
+ else ()
+ in
+
+ (* Helpers for adding metadata. *)
+ let (dbg_mdkind:int) = Llvm.mdkind_id llctx "dbg" in
+ let set_dbg_metadata (inst:Llvm.llvalue) (md:Llvm.llvalue) : unit =
+ Llvm.set_metadata inst dbg_mdkind md
+ in
+ let md_str (s:string) : Llvm.llvalue = Llvm.mdstring llctx s in
+ let md_node (vals:Llvm.llvalue array) : Llvm.llvalue =
+ Llvm.mdnode llctx vals
+ in
+ let const_i32 (i:int) : Llvm.llvalue =
+ Llvm.const_int (Llvm.i32_type llctx) i
+ in
+ let const_i1 (i:int) : Llvm.llvalue =
+ Llvm.const_int (Llvm.i1_type llctx) i
+ in
+ let llvm_debug_version : int = 0x8 lsl 16 in
+ let const_dw_tag (tag:Dwarf.dw_tag) : Llvm.llvalue =
+ const_i32 (llvm_debug_version lor (Dwarf.dw_tag_to_int tag))
+ in
+
+ (* Translation of our node_ids into LLVM identifiers, which are strings. *)
+ let next_anon_llid = ref 0 in
+ let num_llid num klass = Printf.sprintf "%s%d" klass num in
+ let anon_llid klass =
+ let llid = num_llid !next_anon_llid klass in
+ next_anon_llid := !next_anon_llid + 1;
+ llid
+ in
+ let node_llid (node_id_opt:node_id option) : (string -> string) =
+ match node_id_opt with
+ None -> anon_llid
+ | Some (Node num) -> num_llid num
+ in
+
+ (*
+ * Returns a bogus value for use in stub code that hasn't been implemented
+ * yet.
+ *
+ * TODO: On some joyous day, remove me.
+ *)
+ let bogus = Llvm.const_null (Llvm.i32_type llctx) in
+ let bogus_ptr = Llvm.const_null (Llvm.pointer_type (Llvm.i32_type llctx)) in
+
+ let llnilty = Llvm.array_type (Llvm.i1_type llctx) 0 in
+ let llnil = Llvm.const_array (Llvm.i1_type llctx) [| |] in
+
+ let ty_of_item = Hashtbl.find sem_cx.Semant.ctxt_all_item_types in
+ let ty_of_slot n = Semant.slot_ty (Semant.get_slot sem_cx n) in
+
+ let filename = Session.filename_of sess.Session.sess_in in
+ let llmod = Llvm.create_module llctx filename in
+
+ let (abi:Llabi.abi) = Llabi.declare_abi llctx llmod in
+ let (crate_ptr:Llvm.llvalue) =
+ Llvm.declare_global abi.Llabi.crate_ty "rust_crate" llmod
+ in
+
+ let (void_ty:Llvm.lltype) = Llvm.void_type llctx in
+ let (word_ty:Llvm.lltype) = abi.Llabi.word_ty in
+ let (wordptr_ty:Llvm.lltype) = Llvm.pointer_type word_ty in
+ let (task_ty:Llvm.lltype) = abi.Llabi.task_ty in
+ let (task_ptr_ty:Llvm.lltype) = Llvm.pointer_type task_ty in
+ let fn_ty (out:Llvm.lltype) (args:Llvm.lltype array) : Llvm.lltype =
+ Llvm.function_type out args
+ in
+
+ let imm (i:int64) : Llvm.llvalue =
+ Llvm.const_int word_ty (Int64.to_int i)
+ in
+
+ let asm_glue = Llasm.get_glue llctx llmod abi sess in
+
+ let llty_str llty =
+ Llvm.string_of_lltype llty
+ in
+
+ let llval_str llv =
+ let ts = llty_str (Llvm.type_of llv) in
+ match Llvm.value_name llv with
+ "" ->
+ Printf.sprintf "<anon=%s>" ts
+ | s -> Printf.sprintf "<%s=%s>" s ts
+ in
+
+ let llvals_str llvals =
+ (String.concat ", "
+ (Array.to_list
+ (Array.map llval_str llvals)))
+ in
+
+ let build_call callee args rvid builder =
+ iflog
+ begin
+ fun _ ->
+ let name = Llvm.value_name callee in
+ log sem_cx "build_call: %s(%s)" name (llvals_str args);
+ log sem_cx "build_call: typeof(%s) = %s"
+ name (llty_str (Llvm.type_of callee))
+ end;
+ Llvm.build_call callee args rvid builder
+ in
+
+ (* Upcall translation *)
+
+ let extern_upcalls = Hashtbl.create 0 in
+ let trans_upcall
+ (llbuilder:Llvm.llbuilder)
+ (lltask:Llvm.llvalue)
+ (name:string)
+ (lldest:Llvm.llvalue option)
+ (llargs:Llvm.llvalue array) =
+ let n = Array.length llargs in
+ let llglue = asm_glue.Llasm.asm_upcall_glues.(n) in
+ let llupcall = htab_search_or_add extern_upcalls name
+ begin
+ fun _ ->
+ let args_ty =
+ Array.append
+ [| task_ptr_ty |]
+ (Array.init n (fun i -> Llvm.type_of llargs.(i)))
+ in
+ let out_ty = match lldest with
+ None -> void_ty
+ | Some v -> Llvm.type_of v
+ in
+ let fty = fn_ty out_ty args_ty in
+ (*
+ * NB: At this point it actually doesn't matter what type
+ * we gave the upcall function, as we're just going to
+ * pointercast it to a word and pass it to the upcall-glue
+ * for now. But possibly in the future it might matter if
+ * we develop a proper upcall calling convention.
+ *)
+ Llvm.declare_function name fty llmod
+ end
+ in
+ (* Cast everything to plain words so we can hand off to the glue. *)
+ let llupcall = Llvm.const_pointercast llupcall word_ty in
+ let llargs =
+ Array.map
+ (fun arg ->
+ Llvm.build_pointercast arg word_ty
+ (anon_llid "arg") llbuilder)
+ llargs
+ in
+ let llallargs = Array.append [| lltask; llupcall |] llargs in
+ let llid = anon_llid "rv" in
+ let llrv = build_call llglue llallargs llid llbuilder in
+ Llvm.set_instruction_call_conv Llvm.CallConv.c llrv;
+ match lldest with
+ None -> ()
+ | Some lldest ->
+ let lldest =
+ Llvm.build_pointercast lldest wordptr_ty "" llbuilder
+ in
+ ignore (Llvm.build_store llrv lldest llbuilder);
+ in
+
+ let upcall
+ (llbuilder:Llvm.llbuilder)
+ (lltask:Llvm.llvalue)
+ (name:string)
+ (lldest:Llvm.llvalue option)
+ (llargs:Llvm.llvalue array)
+ : unit =
+ trans_upcall llbuilder lltask name lldest llargs
+ in
+
+ let trans_free
+ (llbuilder:Llvm.llbuilder)
+ (lltask:Llvm.llvalue)
+ (src:Llvm.llvalue)
+ : unit =
+ upcall llbuilder lltask "upcall_free" None [| src |]
+ in
+
+ (*
+ * let trans_malloc (llbuilder:Llvm.llbuilder)
+ * (dst:Llvm.llvalue) (nbytes:int64) : unit =
+ * upcall llbuilder "upcall_malloc" (Some dst) [| imm nbytes |]
+ * in
+ *)
+
+ (* Type translation *)
+
+ let lltys = Hashtbl.create 0 in
+
+ let trans_mach_ty (mty:ty_mach) : Llvm.lltype =
+ let tycon =
+ match mty with
+ TY_u8 | TY_i8 -> Llvm.i8_type
+ | TY_u16 | TY_i16 -> Llvm.i16_type
+ | TY_u32 | TY_i32 -> Llvm.i32_type
+ | TY_u64 | TY_i64 -> Llvm.i64_type
+ | TY_f32 -> Llvm.float_type
+ | TY_f64 -> Llvm.double_type
+ in
+ tycon llctx
+ in
+
+
+ let rec trans_ty_full (ty:Ast.ty) : Llvm.lltype =
+ let p t = Llvm.pointer_type t in
+ let s ts = Llvm.struct_type llctx ts in
+ let opaque _ = Llvm.opaque_type llctx in
+ let vec_body_ty _ =
+ s [| word_ty; word_ty; word_ty; (opaque()) |]
+ in
+ let rc_opaque_ty =
+ s [| word_ty; (opaque()) |]
+ in
+ match ty with
+ Ast.TY_any -> opaque ()
+ | Ast.TY_nil -> llnilty
+ | Ast.TY_bool -> Llvm.i1_type llctx
+ | Ast.TY_mach mty -> trans_mach_ty mty
+ | Ast.TY_int -> word_ty
+ | Ast.TY_uint -> word_ty
+ | Ast.TY_char -> Llvm.i32_type llctx
+ | Ast.TY_vec _
+ | Ast.TY_str -> p (vec_body_ty())
+
+ | Ast.TY_fn tfn ->
+ let (tsig, _) = tfn in
+ let lloutptr = p (trans_slot None tsig.Ast.sig_output_slot) in
+ let lltaskty = p abi.Llabi.task_ty in
+ let llins = Array.map (trans_slot None) tsig.Ast.sig_input_slots in
+ fn_ty void_ty (Array.append [| lloutptr; lltaskty |] llins)
+
+ | Ast.TY_tup slots ->
+ s (Array.map (trans_slot None) slots)
+
+ | Ast.TY_rec entries ->
+ s (Array.map (fun e -> trans_slot None (snd e)) entries)
+
+ | Ast.TY_constrained (ty', _) -> trans_ty ty'
+
+ | Ast.TY_chan _ | Ast.TY_port _ | Ast.TY_task ->
+ p rc_opaque_ty
+
+ | Ast.TY_native _ ->
+ word_ty
+
+ | Ast.TY_tag _ | Ast.TY_iso _ | Ast.TY_idx _
+ | Ast.TY_obj _ | Ast.TY_type -> (opaque()) (* TODO *)
+
+ | Ast.TY_param _ | Ast.TY_named _ ->
+ bug () "unresolved type in lltrans"
+
+ and trans_ty t =
+ htab_search_or_add lltys t (fun _ -> trans_ty_full t)
+
+ (* Translates the type of a slot into the corresponding LLVM type. If the
+ * id_opt parameter is specified, then the type will be fetched from the
+ * context. *)
+ and trans_slot (id_opt:node_id option) (slot:Ast.slot) : Llvm.lltype =
+ let ty =
+ match id_opt with
+ Some id -> ty_of_slot id
+ | None -> Semant.slot_ty slot
+ in
+ let base_llty = trans_ty ty in
+ match slot.Ast.slot_mode with
+ Ast.MODE_exterior _
+ | Ast.MODE_alias _ ->
+ Llvm.pointer_type base_llty
+ | Ast.MODE_interior _ -> base_llty
+ in
+
+ let get_element_ptr
+ (llbuilder:Llvm.llbuilder)
+ (ptr:Llvm.llvalue)
+ (i:int)
+ : Llvm.llvalue =
+ (*
+ * GEP takes a first-index of zero. Because it must! And this is
+ * sufficiently surprising that the GEP FAQ exists. And you must
+ * read it.
+ *)
+ let deref_ptr = Llvm.const_int (Llvm.i32_type llctx) 0 in
+ let idx = Llvm.const_int (Llvm.i32_type llctx) i in
+ Llvm.build_gep ptr [| deref_ptr; idx |] (anon_llid "gep") llbuilder
+ in
+
+ let free_ty
+ (llbuilder:Llvm.llbuilder)
+ (lltask:Llvm.llvalue)
+ (ty:Ast.ty)
+ (ptr:Llvm.llvalue)
+ : unit =
+ match ty with
+ Ast.TY_port _
+ | Ast.TY_chan _
+ | Ast.TY_task -> bug () "unimplemented ty in Lltrans.free_ty"
+ | _ -> trans_free llbuilder lltask ptr
+ in
+
+ let rec iter_ty_slots_full
+ (llbuilder:Llvm.llbuilder ref)
+ (ty:Ast.ty)
+ (dst_ptr:Llvm.llvalue)
+ (src_ptr:Llvm.llvalue)
+ (f:(Llvm.llvalue
+ -> Llvm.llvalue
+ -> Ast.slot
+ -> (Ast.ty_iso option)
+ -> unit))
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+
+ (* NB: must deref llbuilder at call-time; don't curry this. *)
+ let gep p i = get_element_ptr (!llbuilder) p i in
+
+ match ty with
+ Ast.TY_rec entries ->
+ iter_rec_slots gep dst_ptr src_ptr entries f curr_iso
+
+ | Ast.TY_tup slots ->
+ iter_tup_slots gep dst_ptr src_ptr slots f curr_iso
+
+ | Ast.TY_tag _
+ | Ast.TY_iso _
+ | Ast.TY_fn _
+ | Ast.TY_obj _ ->
+ bug () "unimplemented ty in Lltrans.iter_ty_slots_full"
+
+ | _ -> ()
+
+ and iter_ty_slots
+ (llbuilder:Llvm.llbuilder ref)
+ (ty:Ast.ty)
+ (ptr:Llvm.llvalue)
+ (f:Llvm.llvalue -> Ast.slot -> (Ast.ty_iso option) -> unit)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ iter_ty_slots_full llbuilder ty ptr ptr
+ (fun _ src_ptr slot curr_iso -> f src_ptr slot curr_iso)
+ curr_iso
+
+ and drop_ty
+ (llbuilder:Llvm.llbuilder ref)
+ (lltask:Llvm.llvalue)
+ (ty:Ast.ty)
+ (ptr:Llvm.llvalue)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ iter_ty_slots llbuilder ty ptr (drop_slot llbuilder lltask) curr_iso
+
+ and drop_slot
+ (llbuilder:Llvm.llbuilder ref)
+ (lltask:Llvm.llvalue)
+ (slot_ptr:Llvm.llvalue)
+ (slot:Ast.slot)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+
+ let llfn = Llvm.block_parent (Llvm.insertion_block (!llbuilder)) in
+ let llty = trans_slot None slot in
+ let ty = Semant.slot_ty slot in
+
+ let new_block klass =
+ let llblock = Llvm.append_block llctx (anon_llid klass) llfn in
+ let llbuilder = Llvm.builder_at_end llctx llblock in
+ (llblock, llbuilder)
+ in
+
+ let if_ptr_in_slot_not_null
+ (inner:Llvm.llvalue -> Llvm.llbuilder -> Llvm.llbuilder)
+ (llbuilder:Llvm.llbuilder)
+ : Llvm.llbuilder =
+ let ptr = Llvm.build_load slot_ptr (anon_llid "tmp") llbuilder in
+ let null = Llvm.const_pointer_null llty in
+ let test =
+ Llvm.build_icmp Llvm.Icmp.Ne null ptr (anon_llid "nullp") llbuilder
+ in
+ let (llthen, llthen_builder) = new_block "then" in
+ let (llnext, llnext_builder) = new_block "next" in
+ ignore (Llvm.build_cond_br test llthen llnext llbuilder);
+ let llthen_builder = inner ptr llthen_builder in
+ ignore (Llvm.build_br llnext llthen_builder);
+ llnext_builder
+ in
+
+ let decr_refcnt_and_if_zero
+ (rc_elt:int)
+ (inner:Llvm.llvalue -> Llvm.llbuilder -> Llvm.llbuilder)
+ (ptr:Llvm.llvalue)
+ (llbuilder:Llvm.llbuilder)
+ : Llvm.llbuilder =
+ let rc_ptr = get_element_ptr llbuilder ptr rc_elt in
+ let rc = Llvm.build_load rc_ptr (anon_llid "rc") llbuilder in
+ let rc = Llvm.build_sub rc (imm 1L) (anon_llid "tmp") llbuilder in
+ let _ = Llvm.build_store rc rc_ptr llbuilder in
+ log sem_cx "rc type: %s" (llval_str rc);
+ let test =
+ Llvm.build_icmp Llvm.Icmp.Eq
+ rc (imm 0L) (anon_llid "zerop") llbuilder
+ in
+ let (llthen, llthen_builder) = new_block "then" in
+ let (llnext, llnext_builder) = new_block "next" in
+ ignore (Llvm.build_cond_br test llthen llnext llbuilder);
+ let llthen_builder = inner ptr llthen_builder in
+ ignore (Llvm.build_br llnext llthen_builder);
+ llnext_builder
+ in
+
+ let free_and_null_out_slot
+ (ptr:Llvm.llvalue)
+ (llbuilder:Llvm.llbuilder)
+ : Llvm.llbuilder =
+ free_ty llbuilder lltask ty ptr;
+ let null = Llvm.const_pointer_null llty in
+ ignore (Llvm.build_store null slot_ptr llbuilder);
+ llbuilder
+ in
+
+ begin
+ match slot_mem_ctrl slot with
+ MEM_rc_struct
+ | MEM_gc ->
+ llbuilder :=
+ if_ptr_in_slot_not_null
+ (decr_refcnt_and_if_zero
+ Abi.exterior_rc_slot_field_refcnt
+ free_and_null_out_slot)
+ (!llbuilder)
+
+ | MEM_rc_opaque ->
+ llbuilder :=
+ if_ptr_in_slot_not_null
+ (decr_refcnt_and_if_zero
+ Abi.exterior_rc_slot_field_refcnt
+ free_and_null_out_slot)
+ (!llbuilder)
+
+ | MEM_interior when Semant.type_is_structured ty ->
+ (* FIXME: to handle recursive types, need to call drop
+ glue here, not inline. *)
+ drop_ty llbuilder lltask ty slot_ptr curr_iso
+
+ | _ -> ()
+ end
+ in
+
+ let (llitems:(node_id, Llvm.llvalue) Hashtbl.t) = Hashtbl.create 0 in
+ let declare_mod_item
+ (name:Ast.ident)
+ { node = { Ast.decl_item = (item:Ast.mod_item') }; id = id }
+ : unit =
+ let full_name = Semant.item_str sem_cx id in
+ let line_num =
+ match Session.get_span sess id with
+ None -> 0
+ | Some span ->
+ let (_, line, _) = span.lo in
+ line
+ in
+ match item with
+ Ast.MOD_ITEM_fn _ ->
+ let llty = trans_ty (ty_of_item id) in
+ let llfn = Llvm.declare_function ("_rust_" ^ name) llty llmod in
+ let meta =
+ md_node
+ [|
+ const_dw_tag Dwarf.DW_TAG_subprogram;
+ const_i32 0; (* unused *)
+ const_i32 0; (* context metadata llvalue *)
+ md_str name;
+ md_str full_name;
+ md_str full_name;
+ const_i32 0; (* file metadata llvalue *)
+ const_i32 line_num;
+ const_i32 0; (* type descriptor metadata llvalue *)
+ const_i1 1; (* flag: local to compile unit? *)
+ const_i1 1; (* flag: defined in compile unit? *)
+ |]
+ in
+ Llvm.set_function_call_conv Llvm.CallConv.c llfn;
+ Hashtbl.add llitems id llfn;
+
+ (* FIXME: Adding metadata does not work yet. . *)
+ let _ = fun _ -> set_dbg_metadata llfn meta in
+ ()
+
+ | _ -> () (* TODO *)
+ in
+
+ let trans_fn
+ ({
+ Ast.fn_input_slots = (header_slots:Ast.header_slots);
+ Ast.fn_body = (body:Ast.block)
+ }:Ast.fn)
+ (fn_id:node_id)
+ : unit =
+ let llfn = Hashtbl.find llitems fn_id in
+ let lloutptr = Llvm.param llfn 0 in
+ let lltask = Llvm.param llfn 1 in
+
+ (* LLVM requires that functions be grouped into basic blocks terminated by
+ * terminator instructions, while our AST is less strict. So we have to do
+ * a little trickery here to wrangle the statement sequence into LLVM's
+ * format. *)
+
+ let new_block id_opt klass =
+ let llblock = Llvm.append_block llctx (node_llid id_opt klass) llfn in
+ let llbuilder = Llvm.builder_at_end llctx llblock in
+ (llblock, llbuilder)
+ in
+
+ (* Build up the slot-to-llvalue mapping, allocating space along the
+ * way. *)
+ let slot_to_llvalue = Hashtbl.create 0 in
+ let (_, llinitbuilder) = new_block None "init" in
+
+ (* Allocate space for arguments (needed because arguments are lvalues in
+ * Rust), and store them in the slot-to-llvalue mapping. *)
+ let n_implicit_args = 2 in
+ let build_arg idx llargval =
+ if idx >= n_implicit_args
+ then
+ let ({ id = id }, ident) = header_slots.(idx - 2) in
+ Llvm.set_value_name ident llargval;
+ let llarg =
+ let llty = Llvm.type_of llargval in
+ Llvm.build_alloca llty (ident ^ "_ptr") llinitbuilder
+ in
+ ignore (Llvm.build_store llargval llarg llinitbuilder);
+ Hashtbl.add slot_to_llvalue id llarg
+ in
+ Array.iteri build_arg (Llvm.params llfn);
+
+ (* Allocate space for all the blocks' slots.
+ * and zero the exteriors. *)
+ let init_block (block_id:node_id) : unit =
+ let init_slot
+ (key:Ast.slot_key)
+ (slot_id:node_id)
+ (slot:Ast.slot)
+ : unit =
+ let name = Ast.sprintf_slot_key () key in
+ let llty = trans_slot (Some slot_id) slot in
+ let llptr = Llvm.build_alloca llty name llinitbuilder in
+ begin
+ match slot_mem_ctrl slot with
+ MEM_rc_struct
+ | MEM_rc_opaque
+ | MEM_gc ->
+ ignore (Llvm.build_store
+ (Llvm.const_pointer_null llty)
+ llptr llinitbuilder);
+ | _ -> ()
+ end;
+ Hashtbl.add slot_to_llvalue slot_id llptr
+ in
+ iter_block_slots sem_cx block_id init_slot
+ in
+
+ let exit_block
+ (llbuilder:Llvm.llbuilder)
+ (block_id:node_id)
+ : Llvm.llbuilder =
+ let r = ref llbuilder in
+ iter_block_slots sem_cx block_id
+ begin
+ fun _ slot_id slot ->
+ if (not (Semant.slot_is_obj_state sem_cx slot_id))
+ then
+ let ptr = Hashtbl.find slot_to_llvalue slot_id in
+ drop_slot r lltask ptr slot None
+ end;
+ !r
+ in
+
+ List.iter init_block (Hashtbl.find sem_cx.Semant.ctxt_frame_blocks fn_id);
+
+ let static_str (s:string) : Llvm.llvalue =
+ Llvm.define_global (anon_llid "str") (Llvm.const_stringz llctx s) llmod
+ in
+
+
+ (* Translates a list of AST statements to a sequence of LLVM instructions.
+ * The supplied "terminate" function appends the appropriate terminator
+ * instruction to the instruction stream. It may or may not be called,
+ * depending on whether the AST contains a terminating instruction
+ * explicitly. *)
+ let rec trans_stmts
+ (block_id:node_id)
+ (llbuilder:Llvm.llbuilder)
+ (stmts:Ast.stmt list)
+ (terminate:(Llvm.llbuilder -> node_id -> unit))
+ : unit =
+ let trans_literal
+ (lit:Ast.lit)
+ : Llvm.llvalue =
+ match lit with
+ Ast.LIT_nil -> llnil
+ | Ast.LIT_bool value ->
+ Llvm.const_int (Llvm.i1_type llctx) (if value then 1 else 0)
+ | Ast.LIT_mach (mty, value, _) ->
+ let llty = trans_mach_ty mty in
+ Llvm.const_of_int64 llty value (mach_is_signed mty)
+ | Ast.LIT_int (value, _) ->
+ Llvm.const_of_int64 (Llvm.i32_type llctx) value true
+ | Ast.LIT_uint (value, _) ->
+ Llvm.const_of_int64 (Llvm.i32_type llctx) value false
+ | Ast.LIT_char ch ->
+ Llvm.const_int (Llvm.i32_type llctx) ch
+ in
+
+ (* Translates an lval by reference into the appropriate pointer
+ * value. *)
+ let trans_lval (lval:Ast.lval) : Llvm.llvalue =
+ iflog (fun _ -> log sem_cx "trans_lval: %a" Ast.sprintf_lval lval);
+ match lval with
+ Ast.LVAL_base { id = base_id } ->
+ let id =
+ Hashtbl.find sem_cx.Semant.ctxt_lval_to_referent base_id
+ in
+ let referent = Hashtbl.find sem_cx.Semant.ctxt_all_defns id in
+ begin
+ match referent with
+ Semant.DEFN_slot _ -> Hashtbl.find slot_to_llvalue id
+ | Semant.DEFN_item _ -> Hashtbl.find llitems id
+ | _ -> bogus_ptr (* TODO *)
+ end
+ | Ast.LVAL_ext _ -> bogus_ptr (* TODO *)
+ in
+
+ let trans_atom (atom:Ast.atom) : Llvm.llvalue =
+ iflog (fun _ -> log sem_cx "trans_atom: %a" Ast.sprintf_atom atom);
+ match atom with
+ Ast.ATOM_literal { node = lit } -> trans_literal lit
+ | Ast.ATOM_lval lval ->
+ Llvm.build_load (trans_lval lval) (anon_llid "tmp") llbuilder
+ in
+
+ let trans_binary_expr
+ ((op:Ast.binop), (lhs:Ast.atom), (rhs:Ast.atom))
+ : Llvm.llvalue =
+ (* Evaluate the operands in the proper order. *)
+ let (lllhs, llrhs) =
+ match op with
+ Ast.BINOP_or | Ast.BINOP_and | Ast.BINOP_eq | Ast.BINOP_ne
+ | Ast.BINOP_lt | Ast.BINOP_le | Ast.BINOP_ge | Ast.BINOP_gt
+ | Ast.BINOP_lsl | Ast.BINOP_lsr | Ast.BINOP_asr
+ | Ast.BINOP_add | Ast.BINOP_sub | Ast.BINOP_mul
+ | Ast.BINOP_div | Ast.BINOP_mod | Ast.BINOP_xor ->
+ (trans_atom lhs, trans_atom rhs)
+ | Ast.BINOP_send ->
+ let llrhs = trans_atom rhs in
+ let lllhs = trans_atom lhs in
+ (lllhs, llrhs)
+ in
+ let llid = anon_llid "expr" in
+ match op with
+ Ast.BINOP_eq ->
+ (* TODO: equality works on more than just integers *)
+ Llvm.build_icmp Llvm.Icmp.Eq lllhs llrhs llid llbuilder
+
+ (* TODO: signed/unsigned distinction, floating point *)
+ | Ast.BINOP_add -> Llvm.build_add lllhs llrhs llid llbuilder
+ | Ast.BINOP_sub -> Llvm.build_sub lllhs llrhs llid llbuilder
+ | Ast.BINOP_mul -> Llvm.build_mul lllhs llrhs llid llbuilder
+ | Ast.BINOP_div -> Llvm.build_sdiv lllhs llrhs llid llbuilder
+ | Ast.BINOP_mod -> Llvm.build_srem lllhs llrhs llid llbuilder
+
+ | _ -> bogus (* TODO *)
+ in
+
+ let trans_unary_expr _ = bogus in (* TODO *)
+
+ let trans_expr (expr:Ast.expr) : Llvm.llvalue =
+ iflog (fun _ -> log sem_cx "trans_expr: %a" Ast.sprintf_expr expr);
+ match expr with
+ Ast.EXPR_binary binexp -> trans_binary_expr binexp
+ | Ast.EXPR_unary unexp -> trans_unary_expr unexp
+ | Ast.EXPR_atom atom -> trans_atom atom
+ in
+
+ let trans_log_str (atom:Ast.atom) : unit =
+ upcall llbuilder lltask "upcall_log_str" None [| trans_atom atom |]
+ in
+
+ let trans_log_int (atom:Ast.atom) : unit =
+ upcall llbuilder lltask "upcall_log_int" None [| trans_atom atom |]
+ in
+
+ let trans_fail
+ (llbuilder:Llvm.llbuilder)
+ (lltask:Llvm.llvalue)
+ (reason:string)
+ (stmt_id:node_id)
+ : unit =
+ let (file, line, _) =
+ match Session.get_span sem_cx.Semant.ctxt_sess stmt_id with
+ None -> ("<none>", 0, 0)
+ | Some sp -> sp.lo
+ in
+ upcall llbuilder lltask "upcall_fail" None [|
+ static_str reason;
+ static_str file;
+ Llvm.const_int (Llvm.i32_type llctx) line
+ |];
+ ignore (Llvm.build_unreachable llbuilder)
+ in
+
+ (* FIXME: this may be irrelevant; possibly LLVM will wind up
+ * using GOT and such wherever it needs to to achieve PIC
+ * data.
+ *)
+ (*
+ let crate_rel (v:Llvm.llvalue) : Llvm.llvalue =
+ let v_int = Llvm.const_pointercast v word_ty in
+ let c_int = Llvm.const_pointercast crate_ptr word_ty in
+ Llvm.const_sub v_int c_int
+ in
+ *)
+
+ match stmts with
+ [] -> terminate llbuilder block_id
+ | head::tail ->
+
+ iflog (fun _ ->
+ log sem_cx "trans_stmt: %a" Ast.sprintf_stmt head);
+
+ let trans_tail_with_builder llbuilder' : unit =
+ trans_stmts block_id llbuilder' tail terminate
+ in
+ let trans_tail () = trans_tail_with_builder llbuilder in
+
+ match head.node with
+ Ast.STMT_init_tup (dest, atoms) ->
+ let zero = const_i32 0 in
+ let lldest = trans_lval dest in
+ let trans_tup_atom idx (_, _, atom) =
+ let indices = [| zero; const_i32 idx |] in
+ let gep_id = anon_llid "init_tup_gep" in
+ let ptr =
+ Llvm.build_gep lldest indices gep_id llbuilder
+ in
+ ignore (Llvm.build_store (trans_atom atom) ptr llbuilder)
+ in
+ Array.iteri trans_tup_atom atoms;
+ trans_tail ()
+
+ | Ast.STMT_copy (dest, src) ->
+ let llsrc = trans_expr src in
+ let lldest = trans_lval dest in
+ ignore (Llvm.build_store llsrc lldest llbuilder);
+ trans_tail ()
+
+ | Ast.STMT_call (dest, fn, args) ->
+ let llargs = Array.map trans_atom args in
+ let lldest = trans_lval dest in
+ let llfn = trans_lval fn in
+ let llallargs = Array.append [| lldest; lltask |] llargs in
+ let llrv = build_call llfn llallargs "" llbuilder in
+ Llvm.set_instruction_call_conv Llvm.CallConv.c llrv;
+ trans_tail ()
+
+ | Ast.STMT_if sif ->
+ let llexpr = trans_expr sif.Ast.if_test in
+ let (llnext, llnextbuilder) = new_block None "next" in
+ let branch_to_next llbuilder' _ =
+ ignore (Llvm.build_br llnext llbuilder')
+ in
+ let llthen = trans_block sif.Ast.if_then branch_to_next in
+ let llelse =
+ match sif.Ast.if_else with
+ None -> llnext
+ | Some if_else -> trans_block if_else branch_to_next
+ in
+ ignore (Llvm.build_cond_br llexpr llthen llelse llbuilder);
+ trans_tail_with_builder llnextbuilder
+
+ | Ast.STMT_ret atom_opt ->
+ begin
+ match atom_opt with
+ None -> ()
+ | Some atom ->
+ ignore (Llvm.build_store (trans_atom atom)
+ lloutptr llbuilder)
+ end;
+ let llbuilder = exit_block llbuilder block_id in
+ ignore (Llvm.build_ret_void llbuilder)
+
+ | Ast.STMT_fail ->
+ trans_fail llbuilder lltask "explicit failure" head.id
+
+ | Ast.STMT_log a ->
+ begin
+ match Semant.atom_type sem_cx a with
+ (* NB: If you extend this, be sure to update the
+ * typechecking code in type.ml as well. *)
+ Ast.TY_str -> trans_log_str a
+ | Ast.TY_int | Ast.TY_uint | Ast.TY_bool | Ast.TY_char
+ | Ast.TY_mach (TY_u8) | Ast.TY_mach (TY_u16)
+ | Ast.TY_mach (TY_u32) | Ast.TY_mach (TY_i8)
+ | Ast.TY_mach (TY_i16) | Ast.TY_mach (TY_i32) ->
+ trans_log_int a
+ | _ -> Semant.bugi sem_cx head.id
+ "unimplemented logging type"
+ end;
+ trans_tail ()
+
+ | Ast.STMT_check_expr expr ->
+ let llexpr = trans_expr expr in
+ let (llfail, llfailbuilder) = new_block None "fail" in
+ let reason = Ast.fmt_to_str Ast.fmt_expr expr in
+ trans_fail llfailbuilder lltask reason head.id;
+ let (llok, llokbuilder) = new_block None "ok" in
+ ignore (Llvm.build_cond_br llexpr llok llfail llbuilder);
+ trans_tail_with_builder llokbuilder
+
+ | Ast.STMT_init_str (dst, str) ->
+ let d = trans_lval dst in
+ let s = static_str str in
+ let len =
+ Llvm.const_int word_ty ((String.length str) + 1)
+ in
+ upcall llbuilder lltask "upcall_new_str"
+ (Some d) [| s; len |];
+ trans_tail ()
+
+ | _ -> trans_stmts block_id llbuilder tail terminate
+
+ (*
+ * Translates an AST block to one or more LLVM basic blocks and returns
+ * the first basic block. The supplied callback is expected to add a
+ * terminator instruction.
+ *)
+
+ and trans_block
+ ({ node = (stmts:Ast.stmt array); id = id }:Ast.block)
+ (terminate:Llvm.llbuilder -> node_id -> unit)
+ : Llvm.llbasicblock =
+ let (llblock, llbuilder) = new_block (Some id) "bb" in
+ trans_stmts id llbuilder (Array.to_list stmts) terminate;
+ llblock
+ in
+
+ (* "Falling off the end" of a function needs to turn into an explicit
+ * return instruction. *)
+ let default_terminate llbuilder block_id =
+ let llbuilder = exit_block llbuilder block_id in
+ ignore (Llvm.build_ret_void llbuilder)
+ in
+
+ (* Build up the first body block, and link it to the end of the
+ * initialization block. *)
+ let llbodyblock = (trans_block body default_terminate) in
+ ignore (Llvm.build_br llbodyblock llinitbuilder)
+ in
+
+ let trans_mod_item
+ (_:Ast.ident)
+ { node = { Ast.decl_item = (item:Ast.mod_item') }; id = id }
+ : unit =
+ match item with
+ Ast.MOD_ITEM_fn fn -> trans_fn fn id
+ | _ -> ()
+ in
+
+ let exit_task_glue =
+ (* The exit-task glue does not get called.
+ *
+ * Rather, control arrives at it by *returning* to the first
+ * instruction of it, when control falls off the end of the task's
+ * root function.
+ *
+ * There is a "fake" frame set up by the runtime, underneath us,
+ * that we find ourselves in. This frame has the shape of a frame
+ * entered with 2 standard arguments (outptr + taskptr), then a
+ * retpc and N callee-saves sitting on the stack; all this is under
+ * ebp. Then there are 2 *outgoing* args at sp[0] and sp[1].
+ *
+ * All these are fake except the taskptr, which is the one bit we
+ * want. So we construct an equally fake cdecl llvm signature here
+ * to crudely *get* the taskptr that's sitting 2 words up from sp,
+ * and pass it to upcall_exit.
+ *
+ * The latter never returns.
+ *)
+ let llty = fn_ty void_ty [| task_ptr_ty |] in
+ let llfn = Llvm.declare_function "rust_exit_task_glue" llty llmod in
+ let lltask = Llvm.param llfn 0 in
+ let llblock = Llvm.append_block llctx "body" llfn in
+ let llbuilder = Llvm.builder_at_end llctx llblock in
+ trans_upcall llbuilder lltask "upcall_exit" None [||];
+ ignore (Llvm.build_ret_void llbuilder);
+ llfn
+ in
+
+ try
+ let crate' = crate.node in
+ let items = snd (crate'.Ast.crate_items) in
+ Hashtbl.iter declare_mod_item items;
+ Hashtbl.iter trans_mod_item items;
+ Llfinal.finalize_module
+ llctx llmod abi asm_glue exit_task_glue crate_ptr;
+ llmod
+ with e -> Llvm.dispose_module llmod; raise e
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
+
--- /dev/null
+open Semant;;
+open Common;;
+
+let log cx = Session.log "alias"
+ 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 =
+ match lval with
+ Ast.LVAL_base nb ->
+ let referent = Hashtbl.find cx.ctxt_lval_to_referent nb.id in
+ if (referent_is_slot cx referent)
+ then alias_slot referent
+ | _ -> err None "unhandled form of lval %a in alias analysis"
+ Ast.sprintf_lval lval
+ in
+
+ let alias_atom at =
+ match at with
+ Ast.ATOM_lval lv -> alias lv
+ | _ -> err None "aliasing literal"
+ 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 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_send (_, src) -> alias src
+ | Ast.STMT_recv (dst, _) -> alias dst
+ | Ast.STMT_init_port (dst) -> alias dst
+ | Ast.STMT_init_chan (dst, _) -> alias dst
+ | Ast.STMT_init_vec (dst, _, _) -> alias dst
+ | Ast.STMT_init_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_to_referent cx (lval_base_id lv) in
+ if (not (Stack.is_empty curr_stmt)) && (referent_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 path = Stack.create () in
+ let passes =
+ [|
+ (alias_analysis_visitor cx
+ Walk.empty_visitor);
+ |]
+ in
+ run_passes cx "alias" path passes (log cx "%s") crate
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(*
+ * A simple dead-code analysis that rejects code following unconditional
+ * 'ret' or 'be'.
+ *)
+
+open Semant;;
+open Common;;
+
+let log cx = Session.log "dead"
+ 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 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 { Ast.while_body = body }
+ | Ast.STMT_do_while { Ast.while_body = body }
+ | Ast.STMT_for_each { Ast.for_each_body = body }
+ | Ast.STMT_for { Ast.for_body = body } ->
+ if (Hashtbl.mem must_exit body.id) then
+ Hashtbl.add must_exit s.id ()
+
+ | Ast.STMT_if { Ast.if_then = b1; Ast.if_else = Some b2 } ->
+ 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 } ->
+ let arm_ids =
+ Array.map (fun { node = (_, block) } -> 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 } ->
+ let arm_ids = Array.map (fun (_, _, block) -> 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 path = Stack.create () in
+ let passes =
+ [|
+ (dead_code_visitor cx
+ Walk.empty_visitor)
+ |]
+ in
+
+ run_passes cx "dead" path passes (log cx "%s") crate;
+ ()
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(*
+ * Walk crate and generate DWARF-3 records. This file might also go in
+ * the be/ directory; it's half-middle-end, half-back-end. Debug info is
+ * like that.
+ *
+ * Some notes about DWARF:
+ *
+ * - Records form an ownership tree. The tree is serialized in
+ * depth-first pre-order with child lists ending with null
+ * records. When a node type is defined to have no children, no null
+ * child record is provided; it's implied.
+ *
+ * [parent]
+ * / \
+ * [child1] [child2]
+ * |
+ * [grandchild1]
+ *
+ * serializes as:
+ *
+ * [parent][child1][grandchild1][null][child2][null][null]
+ *
+ * - Sometimes you want to make it possible to scan through a sibling
+ * list quickly while skipping the sub-children of each (such as
+ * skipping the 'grandchild' above); this can be done with a
+ * DW_AT_sibling attribute that points forward to the next same-level
+ * sibling.
+ *
+ * - A DWARF consumer contains a little stack-machine interpreter for
+ * a micro-language that you can embed in DWARF records to compute
+ * values algorithmically.
+ *
+ * - DWARF is not "officially" supported by any Microsoft tools in
+ * PE files, but the Microsoft debugging information formats are
+ * proprietary and ever-shifting, and not clearly sufficient for
+ * our needs; by comparison DWARF is widely supported, stable,
+ * flexible, and required everywhere *else*. We are using DWARF to
+ * support major components of the rust runtime (reflection,
+ * unwinding, profiling) so it's helpful to not have to span
+ * technologies, just focus on DWARF. Luckily the MINGW/Cygwin
+ * communities have worked out a convention for PE, and taught BFD
+ * (thus most tools) how to digest DWARF sections trailing after
+ * the .idata section of a normal PE file. Seems to work fine.
+ *
+ * - DWARF supports variable-length coding using LEB128, and in the
+ * cases where these are symbolic or self-contained numbers, we
+ * support them in the assembler. Inter-DWARF-record references
+ * can be done via fixed-size DW_FORM_ref{1,2,4,8} or
+ * DW_FORM_ref_addr; or else via variable-size (LEB128)
+ * DW_FORM_ref_udata. It is hazardous to use the LEB128 form in
+ * our implementation of references, since we use a generic 2-pass
+ * (+ relaxation) fixup mechanism in our assembler which in
+ * general may present an information-dependency cycle for LEB128
+ * coding of offsets: you need to know the offset before you can
+ * work out the LEB128 size, and you may need to know several
+ * LEB128-sizes before you can work out the offsets of other
+ * LEB128s (possibly even the one you're currently coding). In
+ * general the assembler makes no attempt to resolve such
+ * cycles. It'll just throw if it can't handle what you ask
+ * for. So it's best to pay a little extra space and use
+ * DW_FORM_ref_addr or DW_FORM_ref{1,2,4,8} values, in all cases.
+ *)
+
+open Semant;;
+open Common;;
+open Asm;;
+
+let log cx = Session.log "dwarf"
+ cx.ctxt_sess.Session.sess_log_dwarf
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+type dw_tag =
+ DW_TAG_array_type
+ | DW_TAG_class_type
+ | DW_TAG_entry_point
+ | DW_TAG_enumeration_type
+ | DW_TAG_formal_parameter
+ | DW_TAG_imported_declaration
+ | DW_TAG_label
+ | DW_TAG_lexical_block
+ | DW_TAG_member
+ | DW_TAG_pointer_type
+ | DW_TAG_reference_type
+ | DW_TAG_compile_unit
+ | DW_TAG_string_type
+ | DW_TAG_structure_type
+ | DW_TAG_subroutine_type
+ | DW_TAG_typedef
+ | DW_TAG_union_type
+ | DW_TAG_unspecified_parameters
+ | DW_TAG_variant
+ | DW_TAG_common_block
+ | DW_TAG_common_inclusion
+ | DW_TAG_inheritance
+ | DW_TAG_inlined_subroutine
+ | DW_TAG_module
+ | DW_TAG_ptr_to_member_type
+ | DW_TAG_set_type
+ | DW_TAG_subrange_type
+ | DW_TAG_with_stmt
+ | DW_TAG_access_declaration
+ | DW_TAG_base_type
+ | DW_TAG_catch_block
+ | DW_TAG_const_type
+ | DW_TAG_constant
+ | DW_TAG_enumerator
+ | DW_TAG_file_type
+ | DW_TAG_friend
+ | DW_TAG_namelist
+ | DW_TAG_namelist_item
+ | DW_TAG_packed_type
+ | DW_TAG_subprogram
+ | DW_TAG_template_type_parameter
+ | DW_TAG_template_value_parameter
+ | DW_TAG_thrown_type
+ | DW_TAG_try_block
+ | DW_TAG_variant_part
+ | DW_TAG_variable
+ | DW_TAG_volatile_type
+ | DW_TAG_dwarf_procedure
+ | DW_TAG_restrict_type
+ | DW_TAG_interface_type
+ | DW_TAG_namespace
+ | DW_TAG_imported_module
+ | DW_TAG_unspecified_type
+ | DW_TAG_partial_unit
+ | DW_TAG_imported_unit
+ | DW_TAG_condition
+ | DW_TAG_shared_type
+ | DW_TAG_lo_user
+ | DW_TAG_rust_meta
+ | DW_TAG_hi_user
+;;
+
+
+let dw_tag_to_int (tag:dw_tag) : int =
+ match tag with
+ DW_TAG_array_type -> 0x01
+ | DW_TAG_class_type -> 0x02
+ | DW_TAG_entry_point -> 0x03
+ | DW_TAG_enumeration_type -> 0x04
+ | DW_TAG_formal_parameter -> 0x05
+ | DW_TAG_imported_declaration -> 0x08
+ | DW_TAG_label -> 0x0a
+ | DW_TAG_lexical_block -> 0x0b
+ | DW_TAG_member -> 0x0d
+ | DW_TAG_pointer_type -> 0x0f
+ | DW_TAG_reference_type -> 0x10
+ | DW_TAG_compile_unit -> 0x11
+ | DW_TAG_string_type -> 0x12
+ | DW_TAG_structure_type -> 0x13
+ | DW_TAG_subroutine_type -> 0x15
+ | DW_TAG_typedef -> 0x16
+ | DW_TAG_union_type -> 0x17
+ | DW_TAG_unspecified_parameters -> 0x18
+ | DW_TAG_variant -> 0x19
+ | DW_TAG_common_block -> 0x1a
+ | DW_TAG_common_inclusion -> 0x1b
+ | DW_TAG_inheritance -> 0x1c
+ | DW_TAG_inlined_subroutine -> 0x1d
+ | DW_TAG_module -> 0x1e
+ | DW_TAG_ptr_to_member_type -> 0x1f
+ | DW_TAG_set_type -> 0x20
+ | DW_TAG_subrange_type -> 0x21
+ | DW_TAG_with_stmt -> 0x22
+ | DW_TAG_access_declaration -> 0x23
+ | DW_TAG_base_type -> 0x24
+ | DW_TAG_catch_block -> 0x25
+ | DW_TAG_const_type -> 0x26
+ | DW_TAG_constant -> 0x27
+ | DW_TAG_enumerator -> 0x28
+ | DW_TAG_file_type -> 0x29
+ | DW_TAG_friend -> 0x2a
+ | DW_TAG_namelist -> 0x2b
+ | DW_TAG_namelist_item -> 0x2c
+ | DW_TAG_packed_type -> 0x2d
+ | DW_TAG_subprogram -> 0x2e
+ | DW_TAG_template_type_parameter -> 0x2f
+ | DW_TAG_template_value_parameter -> 0x30
+ | DW_TAG_thrown_type -> 0x31
+ | DW_TAG_try_block -> 0x32
+ | DW_TAG_variant_part -> 0x33
+ | DW_TAG_variable -> 0x34
+ | DW_TAG_volatile_type -> 0x35
+ | DW_TAG_dwarf_procedure -> 0x36
+ | DW_TAG_restrict_type -> 0x37
+ | DW_TAG_interface_type -> 0x38
+ | DW_TAG_namespace -> 0x39
+ | DW_TAG_imported_module -> 0x3a
+ | DW_TAG_unspecified_type -> 0x3b
+ | DW_TAG_partial_unit -> 0x3c
+ | DW_TAG_imported_unit -> 0x3d
+ | DW_TAG_condition -> 0x3f
+ | DW_TAG_shared_type -> 0x40
+ | DW_TAG_lo_user -> 0x4080
+ | DW_TAG_rust_meta -> 0x4300
+ | DW_TAG_hi_user -> 0xffff
+;;
+
+let dw_tag_of_int (i:int) : dw_tag =
+ match i with
+ 0x01 -> DW_TAG_array_type
+ | 0x02 -> DW_TAG_class_type
+ | 0x03 -> DW_TAG_entry_point
+ | 0x04 -> DW_TAG_enumeration_type
+ | 0x05 -> DW_TAG_formal_parameter
+ | 0x08 -> DW_TAG_imported_declaration
+ | 0x0a -> DW_TAG_label
+ | 0x0b -> DW_TAG_lexical_block
+ | 0x0d -> DW_TAG_member
+ | 0x0f -> DW_TAG_pointer_type
+ | 0x10 -> DW_TAG_reference_type
+ | 0x11 -> DW_TAG_compile_unit
+ | 0x12 -> DW_TAG_string_type
+ | 0x13 -> DW_TAG_structure_type
+ | 0x15 -> DW_TAG_subroutine_type
+ | 0x16 -> DW_TAG_typedef
+ | 0x17 -> DW_TAG_union_type
+ | 0x18 -> DW_TAG_unspecified_parameters
+ | 0x19 -> DW_TAG_variant
+ | 0x1a -> DW_TAG_common_block
+ | 0x1b -> DW_TAG_common_inclusion
+ | 0x1c -> DW_TAG_inheritance
+ | 0x1d -> DW_TAG_inlined_subroutine
+ | 0x1e -> DW_TAG_module
+ | 0x1f -> DW_TAG_ptr_to_member_type
+ | 0x20 -> DW_TAG_set_type
+ | 0x21 -> DW_TAG_subrange_type
+ | 0x22 -> DW_TAG_with_stmt
+ | 0x23 -> DW_TAG_access_declaration
+ | 0x24 -> DW_TAG_base_type
+ | 0x25 -> DW_TAG_catch_block
+ | 0x26 -> DW_TAG_const_type
+ | 0x27 -> DW_TAG_constant
+ | 0x28 -> DW_TAG_enumerator
+ | 0x29 -> DW_TAG_file_type
+ | 0x2a -> DW_TAG_friend
+ | 0x2b -> DW_TAG_namelist
+ | 0x2c -> DW_TAG_namelist_item
+ | 0x2d -> DW_TAG_packed_type
+ | 0x2e -> DW_TAG_subprogram
+ | 0x2f -> DW_TAG_template_type_parameter
+ | 0x30 -> DW_TAG_template_value_parameter
+ | 0x31 -> DW_TAG_thrown_type
+ | 0x32 -> DW_TAG_try_block
+ | 0x33 -> DW_TAG_variant_part
+ | 0x34 -> DW_TAG_variable
+ | 0x35 -> DW_TAG_volatile_type
+ | 0x36 -> DW_TAG_dwarf_procedure
+ | 0x37 -> DW_TAG_restrict_type
+ | 0x38 -> DW_TAG_interface_type
+ | 0x39 -> DW_TAG_namespace
+ | 0x3a -> DW_TAG_imported_module
+ | 0x3b -> DW_TAG_unspecified_type
+ | 0x3c -> DW_TAG_partial_unit
+ | 0x3d -> DW_TAG_imported_unit
+ | 0x3f -> DW_TAG_condition
+ | 0x40 -> DW_TAG_shared_type
+ | 0x4080 -> DW_TAG_lo_user
+ | 0x4300 -> DW_TAG_rust_meta
+ | 0xffff -> DW_TAG_hi_user
+ | _ -> bug () "bad DWARF tag code: %d" i
+;;
+
+
+let dw_tag_to_string (tag:dw_tag) : string =
+ match tag with
+ DW_TAG_array_type -> "DW_TAG_array_type"
+ | DW_TAG_class_type -> "DW_TAG_class_type"
+ | DW_TAG_entry_point -> "DW_TAG_entry_point"
+ | DW_TAG_enumeration_type -> "DW_TAG_enumeration_type"
+ | DW_TAG_formal_parameter -> "DW_TAG_formal_parameter"
+ | DW_TAG_imported_declaration -> "DW_TAG_imported_declaration"
+ | DW_TAG_label -> "DW_TAG_label"
+ | DW_TAG_lexical_block -> "DW_TAG_lexical_block"
+ | DW_TAG_member -> "DW_TAG_member"
+ | DW_TAG_pointer_type -> "DW_TAG_pointer_type"
+ | DW_TAG_reference_type -> "DW_TAG_reference_type"
+ | DW_TAG_compile_unit -> "DW_TAG_compile_unit"
+ | DW_TAG_string_type -> "DW_TAG_string_type"
+ | DW_TAG_structure_type -> "DW_TAG_structure_type"
+ | DW_TAG_subroutine_type -> "DW_TAG_subroutine_type"
+ | DW_TAG_typedef -> "DW_TAG_typedef"
+ | DW_TAG_union_type -> "DW_TAG_union_type"
+ | DW_TAG_unspecified_parameters -> "DW_TAG_unspecified_parameters"
+ | DW_TAG_variant -> "DW_TAG_variant"
+ | DW_TAG_common_block -> "DW_TAG_common_block"
+ | DW_TAG_common_inclusion -> "DW_TAG_common_inclusion"
+ | DW_TAG_inheritance -> "DW_TAG_inheritance"
+ | DW_TAG_inlined_subroutine -> "DW_TAG_inlined_subroutine"
+ | DW_TAG_module -> "DW_TAG_module"
+ | DW_TAG_ptr_to_member_type -> "DW_TAG_ptr_to_member_type"
+ | DW_TAG_set_type -> "DW_TAG_set_type"
+ | DW_TAG_subrange_type -> "DW_TAG_subrange_type"
+ | DW_TAG_with_stmt -> "DW_TAG_with_stmt"
+ | DW_TAG_access_declaration -> "DW_TAG_access_declaration"
+ | DW_TAG_base_type -> "DW_TAG_base_type"
+ | DW_TAG_catch_block -> "DW_TAG_catch_block"
+ | DW_TAG_const_type -> "DW_TAG_const_type"
+ | DW_TAG_constant -> "DW_TAG_constant"
+ | DW_TAG_enumerator -> "DW_TAG_enumerator"
+ | DW_TAG_file_type -> "DW_TAG_file_type"
+ | DW_TAG_friend -> "DW_TAG_friend"
+ | DW_TAG_namelist -> "DW_TAG_namelist"
+ | DW_TAG_namelist_item -> "DW_TAG_namelist_item"
+ | DW_TAG_packed_type -> "DW_TAG_packed_type"
+ | DW_TAG_subprogram -> "DW_TAG_subprogram"
+ | DW_TAG_template_type_parameter -> "DW_TAG_template_type_parameter"
+ | DW_TAG_template_value_parameter -> "DW_TAG_template_value_parameter"
+ | DW_TAG_thrown_type -> "DW_TAG_thrown_type"
+ | DW_TAG_try_block -> "DW_TAG_try_block"
+ | DW_TAG_variant_part -> "DW_TAG_variant_part"
+ | DW_TAG_variable -> "DW_TAG_variable"
+ | DW_TAG_volatile_type -> "DW_TAG_volatile_type"
+ | DW_TAG_dwarf_procedure -> "DW_TAG_dwarf_procedure"
+ | DW_TAG_restrict_type -> "DW_TAG_restrict_type"
+ | DW_TAG_interface_type -> "DW_TAG_interface_type"
+ | DW_TAG_namespace -> "DW_TAG_namespace"
+ | DW_TAG_imported_module -> "DW_TAG_imported_module"
+ | DW_TAG_unspecified_type -> "DW_TAG_unspecified_type"
+ | DW_TAG_partial_unit -> "DW_TAG_partial_unit"
+ | DW_TAG_imported_unit -> "DW_TAG_imported_unit"
+ | DW_TAG_condition -> "DW_TAG_condition"
+ | DW_TAG_shared_type -> "DW_TAG_shared_type"
+ | DW_TAG_lo_user -> "DW_TAG_lo_user"
+ | DW_TAG_rust_meta -> "DW_TAG_rust_meta"
+ | DW_TAG_hi_user -> "DW_TAG_hi_user"
+;;
+
+
+type dw_children =
+ DW_CHILDREN_no
+ | DW_CHILDREN_yes
+;;
+
+
+let dw_children_to_int (ch:dw_children) : int =
+ match ch with
+ DW_CHILDREN_no -> 0x00
+ | DW_CHILDREN_yes -> 0x01
+;;
+
+let dw_children_of_int (i:int) : dw_children =
+ match i with
+ 0 -> DW_CHILDREN_no
+ | 1 -> DW_CHILDREN_yes
+ | _ -> bug () "bad DWARF children code: %d" i
+;;
+
+type dw_at =
+ DW_AT_sibling
+ | DW_AT_location
+ | DW_AT_name
+ | DW_AT_ordering
+ | DW_AT_byte_size
+ | DW_AT_bit_offset
+ | DW_AT_bit_size
+ | DW_AT_stmt_list
+ | DW_AT_low_pc
+ | DW_AT_high_pc
+ | DW_AT_language
+ | DW_AT_discr
+ | DW_AT_discr_value
+ | DW_AT_visibility
+ | DW_AT_import
+ | DW_AT_string_length
+ | DW_AT_common_reference
+ | DW_AT_comp_dir
+ | DW_AT_const_value
+ | DW_AT_containing_type
+ | DW_AT_default_value
+ | DW_AT_inline
+ | DW_AT_is_optional
+ | DW_AT_lower_bound
+ | DW_AT_producer
+ | DW_AT_prototyped
+ | DW_AT_return_addr
+ | DW_AT_start_scope
+ | DW_AT_bit_stride
+ | DW_AT_upper_bound
+ | DW_AT_abstract_origin
+ | DW_AT_accessibility
+ | DW_AT_address_class
+ | DW_AT_artificial
+ | DW_AT_base_types
+ | DW_AT_calling_convention
+ | DW_AT_count
+ | DW_AT_data_member_location
+ | DW_AT_decl_column
+ | DW_AT_decl_file
+ | DW_AT_decl_line
+ | DW_AT_declaration
+ | DW_AT_discr_list
+ | DW_AT_encoding
+ | DW_AT_external
+ | DW_AT_frame_base
+ | DW_AT_friend
+ | DW_AT_identifier_case
+ | DW_AT_macro_info
+ | DW_AT_namelist_item
+ | DW_AT_priority
+ | DW_AT_segment
+ | DW_AT_specification
+ | DW_AT_static_link
+ | DW_AT_type
+ | DW_AT_use_location
+ | DW_AT_variable_parameter
+ | DW_AT_virtuality
+ | DW_AT_vtable_elem_location
+ | DW_AT_allocated
+ | DW_AT_associated
+ | DW_AT_data_location
+ | DW_AT_byte_stride
+ | DW_AT_entry_pc
+ | DW_AT_use_UTF8
+ | DW_AT_extension
+ | DW_AT_ranges
+ | DW_AT_trampoline
+ | DW_AT_call_column
+ | DW_AT_call_file
+ | DW_AT_call_line
+ | DW_AT_description
+ | DW_AT_binary_scale
+ | DW_AT_decimal_scale
+ | DW_AT_small
+ | DW_AT_decimal_sign
+ | DW_AT_digit_count
+ | DW_AT_picture_string
+ | DW_AT_mutable
+ | DW_AT_threads_scaled
+ | DW_AT_explicit
+ | DW_AT_object_pointer
+ | DW_AT_endianity
+ | DW_AT_elemental
+ | DW_AT_pure
+ | DW_AT_recursive
+ | DW_AT_lo_user
+ | DW_AT_rust_type_code
+ | DW_AT_rust_type_param_index
+ | DW_AT_rust_iterator
+ | DW_AT_rust_native_type_id
+ | DW_AT_hi_user
+;;
+
+
+let dw_at_to_int (a:dw_at) : int =
+ match a with
+ DW_AT_sibling -> 0x01
+ | DW_AT_location -> 0x02
+ | DW_AT_name -> 0x03
+ | DW_AT_ordering -> 0x09
+ | DW_AT_byte_size -> 0x0b
+ | DW_AT_bit_offset -> 0x0c
+ | DW_AT_bit_size -> 0x0d
+ | DW_AT_stmt_list -> 0x10
+ | DW_AT_low_pc -> 0x11
+ | DW_AT_high_pc -> 0x12
+ | DW_AT_language -> 0x13
+ | DW_AT_discr -> 0x15
+ | DW_AT_discr_value -> 0x16
+ | DW_AT_visibility -> 0x17
+ | DW_AT_import -> 0x18
+ | DW_AT_string_length -> 0x19
+ | DW_AT_common_reference -> 0x1a
+ | DW_AT_comp_dir -> 0x1b
+ | DW_AT_const_value -> 0x1c
+ | DW_AT_containing_type -> 0x1d
+ | DW_AT_default_value -> 0x1e
+ | DW_AT_inline -> 0x20
+ | DW_AT_is_optional -> 0x21
+ | DW_AT_lower_bound -> 0x22
+ | DW_AT_producer -> 0x25
+ | DW_AT_prototyped -> 0x27
+ | DW_AT_return_addr -> 0x2a
+ | DW_AT_start_scope -> 0x2c
+ | DW_AT_bit_stride -> 0x2e
+ | DW_AT_upper_bound -> 0x2f
+ | DW_AT_abstract_origin -> 0x31
+ | DW_AT_accessibility -> 0x32
+ | DW_AT_address_class -> 0x33
+ | DW_AT_artificial -> 0x34
+ | DW_AT_base_types -> 0x35
+ | DW_AT_calling_convention -> 0x36
+ | DW_AT_count -> 0x37
+ | DW_AT_data_member_location -> 0x38
+ | DW_AT_decl_column -> 0x39
+ | DW_AT_decl_file -> 0x3a
+ | DW_AT_decl_line -> 0x3b
+ | DW_AT_declaration -> 0x3c
+ | DW_AT_discr_list -> 0x3d
+ | DW_AT_encoding -> 0x3e
+ | DW_AT_external -> 0x3f
+ | DW_AT_frame_base -> 0x40
+ | DW_AT_friend -> 0x41
+ | DW_AT_identifier_case -> 0x42
+ | DW_AT_macro_info -> 0x43
+ | DW_AT_namelist_item -> 0x44
+ | DW_AT_priority -> 0x45
+ | DW_AT_segment -> 0x46
+ | DW_AT_specification -> 0x47
+ | DW_AT_static_link -> 0x48
+ | DW_AT_type -> 0x49
+ | DW_AT_use_location -> 0x4a
+ | DW_AT_variable_parameter -> 0x4b
+ | DW_AT_virtuality -> 0x4c
+ | DW_AT_vtable_elem_location -> 0x4d
+ | DW_AT_allocated -> 0x4e
+ | DW_AT_associated -> 0x4f
+ | DW_AT_data_location -> 0x50
+ | DW_AT_byte_stride -> 0x51
+ | DW_AT_entry_pc -> 0x52
+ | DW_AT_use_UTF8 -> 0x53
+ | DW_AT_extension -> 0x54
+ | DW_AT_ranges -> 0x55
+ | DW_AT_trampoline -> 0x56
+ | DW_AT_call_column -> 0x57
+ | DW_AT_call_file -> 0x58
+ | DW_AT_call_line -> 0x59
+ | DW_AT_description -> 0x5a
+ | DW_AT_binary_scale -> 0x5b
+ | DW_AT_decimal_scale -> 0x5c
+ | DW_AT_small -> 0x5d
+ | DW_AT_decimal_sign -> 0x5e
+ | DW_AT_digit_count -> 0x5f
+ | DW_AT_picture_string -> 0x60
+ | DW_AT_mutable -> 0x61
+ | DW_AT_threads_scaled -> 0x62
+ | DW_AT_explicit -> 0x63
+ | DW_AT_object_pointer -> 0x64
+ | DW_AT_endianity -> 0x65
+ | DW_AT_elemental -> 0x66
+ | DW_AT_pure -> 0x67
+ | DW_AT_recursive -> 0x68
+ | DW_AT_lo_user -> 0x2000
+ | DW_AT_rust_type_code -> 0x2300
+ | DW_AT_rust_type_param_index -> 0x2301
+ | DW_AT_rust_iterator -> 0x2302
+ | DW_AT_rust_native_type_id -> 0x2303
+ | DW_AT_hi_user -> 0x3fff
+;;
+
+let dw_at_of_int (i:int) : dw_at =
+ match i with
+ 0x01 -> DW_AT_sibling
+ | 0x02 -> DW_AT_location
+ | 0x03 -> DW_AT_name
+ | 0x09 -> DW_AT_ordering
+ | 0x0b -> DW_AT_byte_size
+ | 0x0c -> DW_AT_bit_offset
+ | 0x0d -> DW_AT_bit_size
+ | 0x10 -> DW_AT_stmt_list
+ | 0x11 -> DW_AT_low_pc
+ | 0x12 -> DW_AT_high_pc
+ | 0x13 -> DW_AT_language
+ | 0x15 -> DW_AT_discr
+ | 0x16 -> DW_AT_discr_value
+ | 0x17 -> DW_AT_visibility
+ | 0x18 -> DW_AT_import
+ | 0x19 -> DW_AT_string_length
+ | 0x1a -> DW_AT_common_reference
+ | 0x1b -> DW_AT_comp_dir
+ | 0x1c -> DW_AT_const_value
+ | 0x1d -> DW_AT_containing_type
+ | 0x1e -> DW_AT_default_value
+ | 0x20 -> DW_AT_inline
+ | 0x21 -> DW_AT_is_optional
+ | 0x22 -> DW_AT_lower_bound
+ | 0x25 -> DW_AT_producer
+ | 0x27 -> DW_AT_prototyped
+ | 0x2a -> DW_AT_return_addr
+ | 0x2c -> DW_AT_start_scope
+ | 0x2e -> DW_AT_bit_stride
+ | 0x2f -> DW_AT_upper_bound
+ | 0x31 -> DW_AT_abstract_origin
+ | 0x32 -> DW_AT_accessibility
+ | 0x33 -> DW_AT_address_class
+ | 0x34 -> DW_AT_artificial
+ | 0x35 -> DW_AT_base_types
+ | 0x36 -> DW_AT_calling_convention
+ | 0x37 -> DW_AT_count
+ | 0x38 -> DW_AT_data_member_location
+ | 0x39 -> DW_AT_decl_column
+ | 0x3a -> DW_AT_decl_file
+ | 0x3b -> DW_AT_decl_line
+ | 0x3c -> DW_AT_declaration
+ | 0x3d -> DW_AT_discr_list
+ | 0x3e -> DW_AT_encoding
+ | 0x3f -> DW_AT_external
+ | 0x40 -> DW_AT_frame_base
+ | 0x41 -> DW_AT_friend
+ | 0x42 -> DW_AT_identifier_case
+ | 0x43 -> DW_AT_macro_info
+ | 0x44 -> DW_AT_namelist_item
+ | 0x45 -> DW_AT_priority
+ | 0x46 -> DW_AT_segment
+ | 0x47 -> DW_AT_specification
+ | 0x48 -> DW_AT_static_link
+ | 0x49 -> DW_AT_type
+ | 0x4a -> DW_AT_use_location
+ | 0x4b -> DW_AT_variable_parameter
+ | 0x4c -> DW_AT_virtuality
+ | 0x4d -> DW_AT_vtable_elem_location
+ | 0x4e -> DW_AT_allocated
+ | 0x4f -> DW_AT_associated
+ | 0x50 -> DW_AT_data_location
+ | 0x51 -> DW_AT_byte_stride
+ | 0x52 -> DW_AT_entry_pc
+ | 0x53 -> DW_AT_use_UTF8
+ | 0x54 -> DW_AT_extension
+ | 0x55 -> DW_AT_ranges
+ | 0x56 -> DW_AT_trampoline
+ | 0x57 -> DW_AT_call_column
+ | 0x58 -> DW_AT_call_file
+ | 0x59 -> DW_AT_call_line
+ | 0x5a -> DW_AT_description
+ | 0x5b -> DW_AT_binary_scale
+ | 0x5c -> DW_AT_decimal_scale
+ | 0x5d -> DW_AT_small
+ | 0x5e -> DW_AT_decimal_sign
+ | 0x5f -> DW_AT_digit_count
+ | 0x60 -> DW_AT_picture_string
+ | 0x61 -> DW_AT_mutable
+ | 0x62 -> DW_AT_threads_scaled
+ | 0x63 -> DW_AT_explicit
+ | 0x64 -> DW_AT_object_pointer
+ | 0x65 -> DW_AT_endianity
+ | 0x66 -> DW_AT_elemental
+ | 0x67 -> DW_AT_pure
+ | 0x68 -> DW_AT_recursive
+ | 0x2000 -> DW_AT_lo_user
+ | 0x2300 -> DW_AT_rust_type_code
+ | 0x2301 -> DW_AT_rust_type_param_index
+ | 0x2302 -> DW_AT_rust_iterator
+ | 0x2303 -> DW_AT_rust_native_type_id
+ | 0x3fff -> DW_AT_hi_user
+ | _ -> bug () "bad DWARF attribute code: 0x%x" i
+;;
+
+let dw_at_to_string (a:dw_at) : string =
+ match a with
+ DW_AT_sibling -> "DW_AT_sibling"
+ | DW_AT_location -> "DW_AT_location"
+ | DW_AT_name -> "DW_AT_name"
+ | DW_AT_ordering -> "DW_AT_ordering"
+ | DW_AT_byte_size -> "DW_AT_byte_size"
+ | DW_AT_bit_offset -> "DW_AT_bit_offset"
+ | DW_AT_bit_size -> "DW_AT_bit_size"
+ | DW_AT_stmt_list -> "DW_AT_stmt_list"
+ | DW_AT_low_pc -> "DW_AT_low_pc"
+ | DW_AT_high_pc -> "DW_AT_high_pc"
+ | DW_AT_language -> "DW_AT_language"
+ | DW_AT_discr -> "DW_AT_discr"
+ | DW_AT_discr_value -> "DW_AT_discr_value"
+ | DW_AT_visibility -> "DW_AT_visibility"
+ | DW_AT_import -> "DW_AT_import"
+ | DW_AT_string_length -> "DW_AT_string_length"
+ | DW_AT_common_reference -> "DW_AT_common_reference"
+ | DW_AT_comp_dir -> "DW_AT_comp_dir"
+ | DW_AT_const_value -> "DW_AT_const_value"
+ | DW_AT_containing_type -> "DW_AT_containing_type"
+ | DW_AT_default_value -> "DW_AT_default_value"
+ | DW_AT_inline -> "DW_AT_inline"
+ | DW_AT_is_optional -> "DW_AT_is_optional"
+ | DW_AT_lower_bound -> "DW_AT_lower_bound"
+ | DW_AT_producer -> "DW_AT_producer"
+ | DW_AT_prototyped -> "DW_AT_prototyped"
+ | DW_AT_return_addr -> "DW_AT_return_addr"
+ | DW_AT_start_scope -> "DW_AT_start_scope"
+ | DW_AT_bit_stride -> "DW_AT_bit_stride"
+ | DW_AT_upper_bound -> "DW_AT_upper_bound"
+ | DW_AT_abstract_origin -> "DW_AT_abstract_origin"
+ | DW_AT_accessibility -> "DW_AT_accessibility"
+ | DW_AT_address_class -> "DW_AT_address_class"
+ | DW_AT_artificial -> "DW_AT_artificial"
+ | DW_AT_base_types -> "DW_AT_base_types"
+ | DW_AT_calling_convention -> "DW_AT_calling_convention"
+ | DW_AT_count -> "DW_AT_count"
+ | DW_AT_data_member_location -> "DW_AT_data_member_location"
+ | DW_AT_decl_column -> "DW_AT_decl_column"
+ | DW_AT_decl_file -> "DW_AT_decl_file"
+ | DW_AT_decl_line -> "DW_AT_decl_line"
+ | DW_AT_declaration -> "DW_AT_declaration"
+ | DW_AT_discr_list -> "DW_AT_discr_list"
+ | DW_AT_encoding -> "DW_AT_encoding"
+ | DW_AT_external -> "DW_AT_external"
+ | DW_AT_frame_base -> "DW_AT_frame_base"
+ | DW_AT_friend -> "DW_AT_friend"
+ | DW_AT_identifier_case -> "DW_AT_identifier_case"
+ | DW_AT_macro_info -> "DW_AT_macro_info"
+ | DW_AT_namelist_item -> "DW_AT_namelist_item"
+ | DW_AT_priority -> "DW_AT_priority"
+ | DW_AT_segment -> "DW_AT_segment"
+ | DW_AT_specification -> "DW_AT_specification"
+ | DW_AT_static_link -> "DW_AT_static_link"
+ | DW_AT_type -> "DW_AT_type"
+ | DW_AT_use_location -> "DW_AT_use_location"
+ | DW_AT_variable_parameter -> "DW_AT_variable_parameter"
+ | DW_AT_virtuality -> "DW_AT_virtuality"
+ | DW_AT_vtable_elem_location -> "DW_AT_vtable_elem_location"
+ | DW_AT_allocated -> "DW_AT_allocated"
+ | DW_AT_associated -> "DW_AT_associated"
+ | DW_AT_data_location -> "DW_AT_data_location"
+ | DW_AT_byte_stride -> "DW_AT_byte_stride"
+ | DW_AT_entry_pc -> "DW_AT_entry_pc"
+ | DW_AT_use_UTF8 -> "DW_AT_use_UTF8"
+ | DW_AT_extension -> "DW_AT_extension"
+ | DW_AT_ranges -> "DW_AT_ranges"
+ | DW_AT_trampoline -> "DW_AT_trampoline"
+ | DW_AT_call_column -> "DW_AT_call_column"
+ | DW_AT_call_file -> "DW_AT_call_file"
+ | DW_AT_call_line -> "DW_AT_call_line"
+ | DW_AT_description -> "DW_AT_description"
+ | DW_AT_binary_scale -> "DW_AT_binary_scale"
+ | DW_AT_decimal_scale -> "DW_AT_decimal_scale"
+ | DW_AT_small -> "DW_AT_small"
+ | DW_AT_decimal_sign -> "DW_AT_decimal_sign"
+ | DW_AT_digit_count -> "DW_AT_digit_count"
+ | DW_AT_picture_string -> "DW_AT_picture_string"
+ | DW_AT_mutable -> "DW_AT_mutable"
+ | DW_AT_threads_scaled -> "DW_AT_threads_scaled"
+ | DW_AT_explicit -> "DW_AT_explicit"
+ | DW_AT_object_pointer -> "DW_AT_object_pointer"
+ | DW_AT_endianity -> "DW_AT_endianity"
+ | DW_AT_elemental -> "DW_AT_elemental"
+ | DW_AT_pure -> "DW_AT_pure"
+ | DW_AT_recursive -> "DW_AT_recursive"
+ | DW_AT_lo_user -> "DW_AT_lo_user"
+ | DW_AT_rust_type_code -> "DW_AT_rust_type_code"
+ | DW_AT_rust_type_param_index -> "DW_AT_rust_type_param_index"
+ | DW_AT_rust_iterator -> "DW_AT_rust_iterator"
+ | DW_AT_rust_native_type_id -> "DW_AT_native_type_id"
+ | DW_AT_hi_user -> "DW_AT_hi_user"
+;;
+
+(*
+ * We encode our 'built-in types' using DW_TAG_pointer_type and various
+ * DW_AT_pointer_type_codes. This seems to be more gdb-compatible than
+ * the DWARF-recommended way of using DW_TAG_unspecified_type.
+ *)
+type dw_rust_type =
+ DW_RUST_type_param
+ | DW_RUST_nil
+ | DW_RUST_vec
+ | DW_RUST_chan
+ | DW_RUST_port
+ | DW_RUST_task
+ | DW_RUST_tag
+ | DW_RUST_iso
+ | DW_RUST_type
+ | DW_RUST_native
+;;
+
+let dw_rust_type_to_int (pt:dw_rust_type) : int =
+ match pt with
+ DW_RUST_type_param -> 0x1
+ | DW_RUST_nil -> 0x2
+ | DW_RUST_vec -> 0x3
+ | DW_RUST_chan -> 0x4
+ | DW_RUST_port -> 0x5
+ | DW_RUST_task -> 0x6
+ | DW_RUST_tag -> 0x7
+ | DW_RUST_iso -> 0x8
+ | DW_RUST_type -> 0x9
+ | DW_RUST_native -> 0xa
+;;
+
+let dw_rust_type_of_int (i:int) : dw_rust_type =
+ match i with
+ 0x1 -> DW_RUST_type_param
+ | 0x2 -> DW_RUST_nil
+ | 0x3 -> DW_RUST_vec
+ | 0x4 -> DW_RUST_chan
+ | 0x5 -> DW_RUST_port
+ | 0x6 -> DW_RUST_task
+ | 0x7 -> DW_RUST_tag
+ | 0x8 -> DW_RUST_iso
+ | 0x9 -> DW_RUST_type
+ | 0xa -> DW_RUST_native
+ | _ -> bug () "bad DWARF rust-pointer-type code: %d" i
+;;
+
+type dw_ate =
+ DW_ATE_address
+ | DW_ATE_boolean
+ | DW_ATE_complex_float
+ | DW_ATE_float
+ | DW_ATE_signed
+ | DW_ATE_signed_char
+ | DW_ATE_unsigned
+ | DW_ATE_unsigned_char
+ | DW_ATE_imaginary_float
+ | DW_ATE_packed_decimal
+ | DW_ATE_numeric_string
+ | DW_ATE_edited
+ | DW_ATE_signed_fixed
+ | DW_ATE_unsigned_fixed
+ | DW_ATE_decimal_float
+ | DW_ATE_lo_user
+ | DW_ATE_hi_user
+;;
+
+let dw_ate_to_int (ate:dw_ate) : int =
+ match ate with
+ DW_ATE_address -> 0x01
+ | DW_ATE_boolean -> 0x02
+ | DW_ATE_complex_float -> 0x03
+ | DW_ATE_float -> 0x04
+ | DW_ATE_signed -> 0x05
+ | DW_ATE_signed_char -> 0x06
+ | DW_ATE_unsigned -> 0x07
+ | DW_ATE_unsigned_char -> 0x08
+ | DW_ATE_imaginary_float -> 0x09
+ | DW_ATE_packed_decimal -> 0x0a
+ | DW_ATE_numeric_string -> 0x0b
+ | DW_ATE_edited -> 0x0c
+ | DW_ATE_signed_fixed -> 0x0d
+ | DW_ATE_unsigned_fixed -> 0x0e
+ | DW_ATE_decimal_float -> 0x0f
+ | DW_ATE_lo_user -> 0x80
+ | DW_ATE_hi_user -> 0xff
+;;
+
+let dw_ate_of_int (i:int) : dw_ate =
+ match i with
+ 0x01 -> DW_ATE_address
+ | 0x02 -> DW_ATE_boolean
+ | 0x03 -> DW_ATE_complex_float
+ | 0x04 -> DW_ATE_float
+ | 0x05 -> DW_ATE_signed
+ | 0x06 -> DW_ATE_signed_char
+ | 0x07 -> DW_ATE_unsigned
+ | 0x08 -> DW_ATE_unsigned_char
+ | 0x09 -> DW_ATE_imaginary_float
+ | 0x0a -> DW_ATE_packed_decimal
+ | 0x0b -> DW_ATE_numeric_string
+ | 0x0c -> DW_ATE_edited
+ | 0x0d -> DW_ATE_signed_fixed
+ | 0x0e -> DW_ATE_unsigned_fixed
+ | 0x0f -> DW_ATE_decimal_float
+ | 0x80 -> DW_ATE_lo_user
+ | 0xff -> DW_ATE_hi_user
+ | _ -> bug () "bad DWARF attribute-encoding code: %d" i
+;;
+
+type dw_form =
+ | DW_FORM_addr
+ | DW_FORM_block2
+ | DW_FORM_block4
+ | DW_FORM_data2
+ | DW_FORM_data4
+ | DW_FORM_data8
+ | DW_FORM_string
+ | DW_FORM_block
+ | DW_FORM_block1
+ | DW_FORM_data1
+ | DW_FORM_flag
+ | DW_FORM_sdata
+ | DW_FORM_strp
+ | DW_FORM_udata
+ | DW_FORM_ref_addr
+ | DW_FORM_ref1
+ | DW_FORM_ref2
+ | DW_FORM_ref4
+ | DW_FORM_ref8
+ | DW_FORM_ref_udata
+ | DW_FORM_indirect
+;;
+
+
+let dw_form_to_int (f:dw_form) : int =
+ match f with
+ | DW_FORM_addr -> 0x01
+ | DW_FORM_block2 -> 0x03
+ | DW_FORM_block4 -> 0x04
+ | DW_FORM_data2 -> 0x05
+ | DW_FORM_data4 -> 0x06
+ | DW_FORM_data8 -> 0x07
+ | DW_FORM_string -> 0x08
+ | DW_FORM_block -> 0x09
+ | DW_FORM_block1 -> 0x0a
+ | DW_FORM_data1 -> 0x0b
+ | DW_FORM_flag -> 0x0c
+ | DW_FORM_sdata -> 0x0d
+ | DW_FORM_strp -> 0x0e
+ | DW_FORM_udata -> 0x0f
+ | DW_FORM_ref_addr -> 0x10
+ | DW_FORM_ref1 -> 0x11
+ | DW_FORM_ref2 -> 0x12
+ | DW_FORM_ref4 -> 0x13
+ | DW_FORM_ref8 -> 0x14
+ | DW_FORM_ref_udata -> 0x15
+ | DW_FORM_indirect -> 0x16
+;;
+
+let dw_form_of_int (i:int) : dw_form =
+ match i with
+ | 0x01 -> DW_FORM_addr
+ | 0x03 -> DW_FORM_block2
+ | 0x04 -> DW_FORM_block4
+ | 0x05 -> DW_FORM_data2
+ | 0x06 -> DW_FORM_data4
+ | 0x07 -> DW_FORM_data8
+ | 0x08 -> DW_FORM_string
+ | 0x09 -> DW_FORM_block
+ | 0x0a -> DW_FORM_block1
+ | 0x0b -> DW_FORM_data1
+ | 0x0c -> DW_FORM_flag
+ | 0x0d -> DW_FORM_sdata
+ | 0x0e -> DW_FORM_strp
+ | 0x0f -> DW_FORM_udata
+ | 0x10 -> DW_FORM_ref_addr
+ | 0x11 -> DW_FORM_ref1
+ | 0x12 -> DW_FORM_ref2
+ | 0x13 -> DW_FORM_ref4
+ | 0x14 -> DW_FORM_ref8
+ | 0x15 -> DW_FORM_ref_udata
+ | 0x16 -> DW_FORM_indirect
+ | _ -> bug () "bad DWARF form code: 0x%x" i
+;;
+
+let dw_form_to_string (f:dw_form) : string =
+ match f with
+ | DW_FORM_addr -> "DW_FORM_addr"
+ | DW_FORM_block2 -> "DW_FORM_block2"
+ | DW_FORM_block4 -> "DW_FORM_block4"
+ | DW_FORM_data2 -> "DW_FORM_data2"
+ | DW_FORM_data4 -> "DW_FORM_data4"
+ | DW_FORM_data8 -> "DW_FORM_data8"
+ | DW_FORM_string -> "DW_FORM_string"
+ | DW_FORM_block -> "DW_FORM_block"
+ | DW_FORM_block1 -> "DW_FORM_block1"
+ | DW_FORM_data1 -> "DW_FORM_data1"
+ | DW_FORM_flag -> "DW_FORM_flag"
+ | DW_FORM_sdata -> "DW_FORM_sdata"
+ | DW_FORM_strp -> "DW_FORM_strp"
+ | DW_FORM_udata -> "DW_FORM_udata"
+ | DW_FORM_ref_addr -> "DW_FORM_ref_addr"
+ | DW_FORM_ref1 -> "DW_FORM_ref1"
+ | DW_FORM_ref2 -> "DW_FORM_ref2"
+ | DW_FORM_ref4 -> "DW_FORM_ref4"
+ | DW_FORM_ref8 -> "DW_FORM_ref8"
+ | DW_FORM_ref_udata -> "DW_FORM_ref_udata"
+ | DW_FORM_indirect -> "DW_FORM_indirect"
+;;
+
+type dw_op =
+ DW_OP_lit of int
+ | DW_OP_addr of Asm.expr64
+ | DW_OP_const1u of Asm.expr64
+ | DW_OP_const1s of Asm.expr64
+ | DW_OP_const2u of Asm.expr64
+ | DW_OP_const2s of Asm.expr64
+ | DW_OP_const4u of Asm.expr64
+ | DW_OP_const4s of Asm.expr64
+ | DW_OP_const8u of Asm.expr64
+ | DW_OP_const8s of Asm.expr64
+ | DW_OP_constu of Asm.expr64
+ | DW_OP_consts of Asm.expr64
+ | DW_OP_fbreg of Asm.expr64
+ | DW_OP_reg of int
+ | DW_OP_regx of Asm.expr64
+ | DW_OP_breg of (int * Asm.expr64)
+ | DW_OP_bregx of (Asm.expr64 * Asm.expr64)
+ | DW_OP_dup
+ | DW_OP_drop
+ | DW_OP_pick of Asm.expr64
+ | DW_OP_over
+ | DW_OP_swap
+ | DW_OP_rot
+ | DW_OP_piece of Asm.expr64
+ | DW_OP_bit_piece of (Asm.expr64 * Asm.expr64)
+ | DW_OP_deref
+ | DW_OP_deref_size of Asm.expr64
+ | DW_OP_xderef
+ | DW_OP_xderef_size of Asm.expr64
+ | DW_OP_push_object_address
+ | DW_OP_form_tls_address
+ | DW_OP_call_frame_cfa
+ | DW_OP_abs
+ | DW_OP_and
+ | DW_OP_div
+ | DW_OP_minus
+ | DW_OP_mod
+ | DW_OP_mul
+ | DW_OP_neg
+ | DW_OP_not
+ | DW_OP_or
+ | DW_OP_plus
+ | DW_OP_plus_uconst of Asm.expr64
+ | DW_OP_shl
+ | DW_OP_shr
+ | DW_OP_shra
+ | DW_OP_xor
+ | DW_OP_le
+ | DW_OP_ge
+ | DW_OP_eq
+ | DW_OP_lt
+ | DW_OP_gt
+ | DW_OP_ne
+ | DW_OP_skip of Asm.expr64
+ | DW_OP_bra of Asm.expr64
+ | DW_OP_call2 of Asm.expr64
+ | DW_OP_call4 of Asm.expr64
+ | DW_OP_call_ref of Asm.expr64
+ | DW_OP_nop
+;;
+
+let dw_op_to_frag (abi:Abi.abi) (op:dw_op) : Asm.frag =
+ match op with
+
+ DW_OP_addr e -> SEQ [| BYTE 0x03; WORD (abi.Abi.abi_word_ty, e) |]
+ | DW_OP_deref -> BYTE 0x06
+ | DW_OP_const1u e -> SEQ [| BYTE 0x08; WORD (TY_u8, e) |]
+ | DW_OP_const1s e -> SEQ [| BYTE 0x09; WORD (TY_i8, e) |]
+ | DW_OP_const2u e -> SEQ [| BYTE 0x0a; WORD (TY_u16, e) |]
+ | DW_OP_const2s e -> SEQ [| BYTE 0x0b; WORD (TY_i16, e) |]
+ | DW_OP_const4u e -> SEQ [| BYTE 0x0c; WORD (TY_u32, e) |]
+ | DW_OP_const4s e -> SEQ [| BYTE 0x0d; WORD (TY_i32, e) |]
+ | DW_OP_const8u e -> SEQ [| BYTE 0x0e; WORD (TY_u64, e) |]
+ | DW_OP_const8s e -> SEQ [| BYTE 0x0f; WORD (TY_i64, e) |]
+ | DW_OP_constu e -> SEQ [| BYTE 0x10; ULEB128 e |]
+ | DW_OP_consts e -> SEQ [| BYTE 0x11; SLEB128 e |]
+ | DW_OP_dup -> BYTE 0x12
+ | DW_OP_drop -> BYTE 0x13
+ | DW_OP_over -> BYTE 0x14
+ | DW_OP_pick e -> SEQ [| BYTE 0x15; WORD (TY_u8, e) |]
+ | DW_OP_swap -> BYTE 0x16
+ | DW_OP_rot -> BYTE 0x17
+ | DW_OP_xderef -> BYTE 0x18
+ | DW_OP_abs -> BYTE 0x19
+ | DW_OP_and -> BYTE 0x1a
+ | DW_OP_div -> BYTE 0x1b
+ | DW_OP_minus -> BYTE 0x1c
+ | DW_OP_mod -> BYTE 0x1d
+ | DW_OP_mul -> BYTE 0x1e
+ | DW_OP_neg -> BYTE 0x1f
+ | DW_OP_not -> BYTE 0x20
+ | DW_OP_or -> BYTE 0x21
+ | DW_OP_plus -> BYTE 0x22
+ | DW_OP_plus_uconst e -> SEQ [| BYTE 0x23; ULEB128 e |]
+ | DW_OP_shl -> BYTE 0x24
+ | DW_OP_shr -> BYTE 0x25
+ | DW_OP_shra -> BYTE 0x26
+ | DW_OP_xor -> BYTE 0x27
+ | DW_OP_skip e -> SEQ [| BYTE 0x2f; WORD (TY_i16, e) |]
+ | DW_OP_bra e -> SEQ [| BYTE 0x28; WORD (TY_i16, e) |]
+ | DW_OP_eq -> BYTE 0x29
+ | DW_OP_ge -> BYTE 0x2a
+ | DW_OP_gt -> BYTE 0x2b
+ | DW_OP_le -> BYTE 0x2c
+ | DW_OP_lt -> BYTE 0x2d
+ | DW_OP_ne -> BYTE 0x2e
+
+ | DW_OP_lit i ->
+ assert (0 <= i && i < 32);
+ BYTE (i + 0x30)
+
+ | DW_OP_reg i ->
+ assert (0 <= i && i < 32);
+ BYTE (i + 0x50)
+
+ | DW_OP_breg (i, e) ->
+ assert (0 <= i && i < 32);
+ SEQ [| BYTE (i + 0x70); SLEB128 e |]
+
+ | DW_OP_regx e -> SEQ [| BYTE 0x90; ULEB128 e|]
+ | DW_OP_fbreg e -> SEQ [| BYTE 0x91; SLEB128 e |]
+ | DW_OP_bregx (r, off) -> SEQ [| BYTE 0x92; ULEB128 r; SLEB128 off |]
+ | DW_OP_piece e -> SEQ [| BYTE 0x93; ULEB128 e |]
+ | DW_OP_deref_size e -> SEQ [| BYTE 0x94; WORD (TY_u8, e) |]
+ | DW_OP_xderef_size e -> SEQ [| BYTE 0x95; WORD (TY_u8, e) |]
+ | DW_OP_nop -> BYTE 0x96
+ | DW_OP_push_object_address -> BYTE 0x97
+ | DW_OP_call2 e -> SEQ [| BYTE 0x98; WORD (TY_u16, e) |]
+ | DW_OP_call4 e -> SEQ [| BYTE 0x99; WORD (TY_u32, e) |]
+ | DW_OP_call_ref e -> SEQ [| BYTE 0x9a; WORD (abi.Abi.abi_word_ty, e) |]
+ | DW_OP_form_tls_address -> BYTE 0x9b
+ | DW_OP_call_frame_cfa -> BYTE 0x9c
+ | DW_OP_bit_piece (sz, off) ->
+ SEQ [| BYTE 0x9d; ULEB128 sz; ULEB128 off |]
+;;
+
+type dw_lns =
+ DW_LNS_copy
+ | DW_LNS_advance_pc
+ | DW_LNS_advance_line
+ | DW_LNS_set_file
+ | DW_LNS_set_column
+ | DW_LNS_negage_stmt
+ | DW_LNS_set_basic_block
+ | DW_LNS_const_add_pc
+ | DW_LNS_fixed_advance_pc
+ | DW_LNS_set_prologue_end
+ | DW_LNS_set_epilogue_begin
+ | DW_LNS_set_isa
+;;
+
+let int_to_dw_lns i =
+ match i with
+ 1 -> DW_LNS_copy
+ | 2 -> DW_LNS_advance_pc
+ | 3 -> DW_LNS_advance_line
+ | 4 -> DW_LNS_set_file
+ | 5 -> DW_LNS_set_column
+ | 6 -> DW_LNS_negage_stmt
+ | 7 -> DW_LNS_set_basic_block
+ | 8 -> DW_LNS_const_add_pc
+ | 9 -> DW_LNS_fixed_advance_pc
+ | 10 -> DW_LNS_set_prologue_end
+ | 11 -> DW_LNS_set_epilogue_begin
+ | 12 -> DW_LNS_set_isa
+ | _ -> bug () "Internal logic error: (Dwarf.int_to_dw_lns %d)" i
+;;
+
+let dw_lns_to_int lns =
+ match lns with
+ DW_LNS_copy -> 1
+ | DW_LNS_advance_pc -> 2
+ | DW_LNS_advance_line -> 3
+ | DW_LNS_set_file -> 4
+ | DW_LNS_set_column -> 5
+ | DW_LNS_negage_stmt -> 6
+ | DW_LNS_set_basic_block -> 7
+ | DW_LNS_const_add_pc -> 8
+ | DW_LNS_fixed_advance_pc -> 9
+ | DW_LNS_set_prologue_end -> 10
+ | DW_LNS_set_epilogue_begin -> 11
+ | DW_LNS_set_isa -> 12
+;;
+
+let max_dw_lns = 12;;
+
+let dw_lns_arity lns =
+ match lns with
+ DW_LNS_copy -> 0
+ | DW_LNS_advance_pc -> 1
+ | DW_LNS_advance_line -> 1
+ | DW_LNS_set_file -> 1
+ | DW_LNS_set_column -> 1
+ | DW_LNS_negage_stmt -> 0
+ | DW_LNS_set_basic_block -> 0
+ | DW_LNS_const_add_pc -> 0
+ | DW_LNS_fixed_advance_pc -> 1
+ | DW_LNS_set_prologue_end -> 0
+ | DW_LNS_set_epilogue_begin -> 0
+ | DW_LNS_set_isa -> 1
+;;
+
+type debug_records =
+ {
+ debug_aranges: Asm.frag;
+ debug_pubnames: Asm.frag;
+ debug_info: Asm.frag;
+ debug_abbrev: Asm.frag;
+ debug_line: Asm.frag;
+ debug_frame: Asm.frag;
+ }
+
+type abbrev = (dw_tag * dw_children * ((dw_at * dw_form) array));;
+
+let (abbrev_crate_cu:abbrev) =
+ (DW_TAG_compile_unit, DW_CHILDREN_yes,
+ [|
+ (DW_AT_producer, DW_FORM_string);
+ (DW_AT_language, DW_FORM_data4);
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_comp_dir, DW_FORM_string);
+ (DW_AT_low_pc, DW_FORM_addr);
+ (DW_AT_high_pc, DW_FORM_addr);
+ (DW_AT_use_UTF8, DW_FORM_flag)
+ |])
+ ;;
+
+let (abbrev_meta:abbrev) =
+ (DW_TAG_rust_meta, DW_CHILDREN_no,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_const_value, DW_FORM_string)
+ |])
+;;
+
+let (abbrev_srcfile_cu:abbrev) =
+ (DW_TAG_compile_unit, DW_CHILDREN_yes,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_comp_dir, DW_FORM_string);
+ (DW_AT_low_pc, DW_FORM_addr);
+ (DW_AT_high_pc, DW_FORM_addr);
+ |])
+;;
+
+
+let (abbrev_module:abbrev) =
+ (DW_TAG_module, DW_CHILDREN_yes,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ |])
+;;
+
+let (abbrev_subprogram:abbrev) =
+ (DW_TAG_subprogram, DW_CHILDREN_yes,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_type, DW_FORM_ref_addr);
+ (DW_AT_low_pc, DW_FORM_addr);
+ (DW_AT_high_pc, DW_FORM_addr);
+ (DW_AT_frame_base, DW_FORM_block1);
+ (DW_AT_return_addr, DW_FORM_block1);
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_pure, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_typedef:abbrev) =
+ (DW_TAG_typedef, DW_CHILDREN_yes,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_type, DW_FORM_ref_addr)
+ |])
+;;
+
+let (abbrev_lexical_block:abbrev) =
+ (DW_TAG_lexical_block, DW_CHILDREN_yes,
+ [|
+ (DW_AT_low_pc, DW_FORM_addr);
+ (DW_AT_high_pc, DW_FORM_addr);
+ |])
+;;
+
+let (abbrev_variable:abbrev) =
+ (DW_TAG_variable, DW_CHILDREN_no,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_location, DW_FORM_block1);
+ (DW_AT_type, DW_FORM_ref_addr)
+ |])
+;;
+
+(* NB: must have same abbrev-body as abbrev_variable. *)
+let (abbrev_formal:abbrev) =
+ (DW_TAG_formal_parameter, DW_CHILDREN_no,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_location, DW_FORM_block1);
+ (DW_AT_type, DW_FORM_ref_addr)
+ |])
+;;
+
+let (abbrev_unspecified_anon_structure_type:abbrev) =
+ (DW_TAG_structure_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_declaration, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_unspecified_structure_type:abbrev) =
+ (DW_TAG_structure_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_rust_type_code, DW_FORM_data1);
+ (DW_AT_declaration, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_unspecified_pointer_type:abbrev) =
+ (DW_TAG_pointer_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_rust_type_code, DW_FORM_data1);
+ (DW_AT_declaration, DW_FORM_flag);
+ (DW_AT_type, DW_FORM_ref_addr)
+ |])
+;;
+
+let (abbrev_native_pointer_type:abbrev) =
+ (DW_TAG_pointer_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_rust_type_code, DW_FORM_data1);
+ (DW_AT_rust_native_type_id, DW_FORM_data4)
+ |])
+;;
+
+let (abbrev_rust_type_param:abbrev) =
+ (DW_TAG_pointer_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_rust_type_code, DW_FORM_data1);
+ (DW_AT_rust_type_param_index, DW_FORM_data4);
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_pure, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_rust_type_param_decl:abbrev) =
+ (DW_TAG_formal_parameter, DW_CHILDREN_no,
+ [|
+ (DW_AT_rust_type_code, DW_FORM_data1);
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_rust_type_param_index, DW_FORM_data4);
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_pure, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_base_type:abbrev) =
+ (DW_TAG_base_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_encoding, DW_FORM_data1);
+ (DW_AT_byte_size, DW_FORM_data1)
+ |])
+;;
+
+let (abbrev_alias_slot:abbrev) =
+ (DW_TAG_reference_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_type, DW_FORM_ref_addr);
+ (DW_AT_mutable, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_exterior_slot:abbrev) =
+ (DW_TAG_reference_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_type, DW_FORM_ref_addr);
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_data_location, DW_FORM_block1);
+ |])
+;;
+
+let (abbrev_struct_type:abbrev) =
+ (DW_TAG_structure_type, DW_CHILDREN_yes,
+ [|
+ (DW_AT_byte_size, DW_FORM_block4)
+ |])
+;;
+
+let (abbrev_struct_type_member:abbrev) =
+ (DW_TAG_member, DW_CHILDREN_no,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_type, DW_FORM_ref_addr);
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_data_member_location, DW_FORM_block4);
+ (DW_AT_byte_size, DW_FORM_block4)
+ |])
+;;
+
+let (abbrev_subroutine_type:abbrev) =
+ (DW_TAG_subroutine_type, DW_CHILDREN_yes,
+ [|
+ (* FIXME: model effects properly. *)
+ (DW_AT_type, DW_FORM_ref_addr); (* NB: output type. *)
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_pure, DW_FORM_flag);
+ (DW_AT_rust_iterator, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_formal_type:abbrev) =
+ (DW_TAG_formal_parameter, DW_CHILDREN_no,
+ [|
+ (DW_AT_type, DW_FORM_ref_addr)
+ |])
+;;
+
+
+let (abbrev_obj_subroutine_type:abbrev) =
+ (DW_TAG_subroutine_type, DW_CHILDREN_yes,
+ [|
+ (* FIXME: model effects properly. *)
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_type, DW_FORM_ref_addr); (* NB: output type. *)
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_pure, DW_FORM_flag);
+ (DW_AT_rust_iterator, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_obj_type:abbrev) =
+ (DW_TAG_interface_type, DW_CHILDREN_yes,
+ [|
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_pure, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_string_type:abbrev) =
+ (DW_TAG_string_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_string_length, DW_FORM_block1);
+ (DW_AT_data_location, DW_FORM_block1);
+ |])
+;;
+
+
+let prepend lref x = lref := x :: (!lref)
+;;
+
+
+let dwarf_visitor
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ (path:Ast.name_component Stack.t)
+ (cu_info_section_fixup:fixup)
+ (cu_aranges:(frag list) ref)
+ (cu_pubnames:(frag list) ref)
+ (cu_infos:(frag list) ref)
+ (cu_abbrevs:(frag list) ref)
+ (cu_lines:(frag list) ref)
+ (cu_frames:(frag list) ref)
+ : Walk.visitor =
+
+ let (abi:Abi.abi) = cx.ctxt_abi in
+ let (word_sz:int64) = abi.Abi.abi_word_sz in
+ let (word_sz_int:int) = Int64.to_int word_sz in
+ let (word_bits:Il.bits) = abi.Abi.abi_word_bits in
+ let (word_ty_mach:ty_mach) =
+ match word_bits with
+ Il.Bits8 -> TY_u8
+ | Il.Bits16 -> TY_u16
+ | Il.Bits32 -> TY_u32
+ | Il.Bits64 -> TY_u64
+ in
+ let (signed_word_ty_mach:ty_mach) =
+ match word_bits with
+ Il.Bits8 -> TY_i8
+ | Il.Bits16 -> TY_i16
+ | Il.Bits32 -> TY_i32
+ | Il.Bits64 -> TY_i64
+ in
+
+ let path_name _ = Ast.fmt_to_str Ast.fmt_name (Walk.path_to_name path) in
+
+ let (abbrev_table:(abbrev, int) Hashtbl.t) = Hashtbl.create 0 in
+
+ let uleb i = ULEB128 (IMM (Int64.of_int i)) in
+
+ let get_abbrev_code
+ (ab:abbrev)
+ : int =
+ if Hashtbl.mem abbrev_table ab
+ then Hashtbl.find abbrev_table ab
+ else
+ let n = (Hashtbl.length abbrev_table) + 1 in
+ let (tag, children, attrs) = ab in
+ let attr_ulebs = Array.create ((Array.length attrs) * 2) MARK in
+ for i = 0 to (Array.length attrs) - 1 do
+ let (attr, form) = attrs.(i) in
+ attr_ulebs.(2*i) <- uleb (dw_at_to_int attr);
+ attr_ulebs.((2*i)+1) <- uleb (dw_form_to_int form)
+ done;
+ let ab_frag =
+ (SEQ [|
+ uleb n;
+ uleb (dw_tag_to_int tag);
+ BYTE (dw_children_to_int children);
+ SEQ attr_ulebs;
+ uleb 0; uleb 0;
+ |])
+ in
+ prepend cu_abbrevs ab_frag;
+ htab_put abbrev_table ab n;
+ n
+ in
+
+ let (curr_cu_aranges:(frag list) ref) = ref [] in
+ let (curr_cu_pubnames:(frag list) ref) = ref [] in
+ let (curr_cu_infos:(frag list) ref) = ref [] in
+ let (curr_cu_line:(frag list) ref) = ref [] in
+ let (curr_cu_frame:(frag list) ref) = ref [] in
+
+ let emit_die die = prepend curr_cu_infos die in
+ let emit_null_die _ = emit_die (BYTE 0) in
+
+ let dw_form_block1 (ops:dw_op array) : Asm.frag =
+ let frag = SEQ (Array.map (dw_op_to_frag abi) ops) in
+ let block_fixup = new_fixup "DW_FORM_block1 fixup" in
+ SEQ [| WORD (TY_u8, F_SZ block_fixup);
+ DEF (block_fixup, frag) |]
+ in
+
+ let dw_form_ref_addr (fix:fixup) : Asm.frag =
+ WORD (signed_word_ty_mach,
+ SUB ((M_POS fix), M_POS cu_info_section_fixup))
+ in
+
+ let encode_effect eff =
+ (* Note: weird encoding: mutable+pure = unsafe. *)
+ let mut_byte, pure_byte =
+ match eff with
+ Ast.UNSAFE -> (1,1)
+ | Ast.STATE -> (1,0)
+ | Ast.IO -> (0,0)
+ | Ast.PURE -> (0,1)
+ in
+ SEQ [|
+ (* DW_AT_mutable: DW_FORM_flag *)
+ BYTE mut_byte;
+ (* DW_AT_pure: DW_FORM_flag *)
+ BYTE pure_byte;
+ |]
+ in
+
+ (* Type-param DIEs. *)
+
+ let type_param_die (p:(ty_param_idx * Ast.effect)) =
+ let (idx, eff) = p in
+ SEQ [|
+ uleb (get_abbrev_code abbrev_rust_type_param);
+ (* DW_AT_rust_type_code: DW_FORM_data1 *)
+ BYTE (dw_rust_type_to_int DW_RUST_type_param);
+ (* DW_AT_rust_type_param_index: DW_FORM_data4 *)
+ WORD (word_ty_mach, IMM (Int64.of_int idx));
+ encode_effect eff;
+ |]
+ in
+
+ (* Type DIEs. *)
+
+ let (emitted_types:(Ast.ty, Asm.frag) Hashtbl.t) = Hashtbl.create 0 in
+ let (emitted_slots:(Ast.slot, Asm.frag) Hashtbl.t) = Hashtbl.create 0 in
+
+ let rec ref_slot_die
+ (slot:Ast.slot)
+ : frag =
+ if Hashtbl.mem emitted_slots slot
+ then Hashtbl.find emitted_slots slot
+ else
+ let ref_addr_for_fix fix =
+ let res = dw_form_ref_addr fix in
+ Hashtbl.add emitted_slots slot res;
+ res
+ in
+
+ match slot.Ast.slot_mode with
+ Ast.MODE_exterior ->
+ let fix = new_fixup "exterior DIE" in
+ let body_off =
+ word_sz_int * Abi.exterior_rc_slot_field_body
+ in
+ emit_die (DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_exterior_slot);
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_type_die (slot_ty slot));
+ (* DW_AT_mutable: DW_FORM_flag *)
+ BYTE (if slot.Ast.slot_mutable
+ then 1 else 0);
+ (* DW_AT_data_location: DW_FORM_block1 *)
+ (* This is a DWARF expression for moving
+ from the address of an exterior
+ allocation to the address of its
+ body. *)
+ dw_form_block1
+ [| DW_OP_push_object_address;
+ DW_OP_lit body_off;
+ DW_OP_plus;
+ DW_OP_deref |]
+ |]));
+ ref_addr_for_fix fix
+
+ (* FIXME: encode mutable-ness of interiors. *)
+ | Ast.MODE_interior -> ref_type_die (slot_ty slot)
+
+ | Ast.MODE_alias ->
+ let fix = new_fixup "alias DIE" in
+ emit_die (DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_alias_slot);
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_type_die (slot_ty slot));
+ (* DW_AT_mutable: DW_FORM_flag *)
+ BYTE (if slot.Ast.slot_mutable then 1 else 0)
+ |]));
+ ref_addr_for_fix fix
+
+
+ and size_block4 (sz:size) (add_to_base:bool) : frag =
+ (* NB: typarams = "words following implicit args" by convention in
+ * ABI/x86.
+ *)
+ let abi = cx.ctxt_abi in
+ let typarams =
+ Int64.add abi.Abi.abi_frame_base_sz abi.Abi.abi_implicit_args_sz
+ in
+ let word_n n = Int64.mul abi.Abi.abi_word_sz (Int64.of_int n) in
+ let param_n n = Int64.add typarams (word_n n) in
+ let param_n_field_k n k =
+ [ DW_OP_fbreg (IMM (param_n n));
+ DW_OP_deref;
+ DW_OP_constu (IMM (word_n k));
+ DW_OP_plus;
+ DW_OP_deref ]
+ in
+ let rec sz_ops (sz:size) : dw_op list =
+ match sz with
+ SIZE_fixed i ->
+ [ DW_OP_constu (IMM i) ]
+
+ | SIZE_fixup_mem_sz fix ->
+ [ DW_OP_constu (M_SZ fix) ]
+
+ | SIZE_fixup_mem_pos fix ->
+ [ DW_OP_constu (M_POS fix) ]
+
+ | SIZE_param_size i ->
+ param_n_field_k i Abi.tydesc_field_size
+
+ | SIZE_param_align i ->
+ param_n_field_k i Abi.tydesc_field_align
+
+ | SIZE_rt_neg s ->
+ (sz_ops s) @ [ DW_OP_neg ]
+
+ | SIZE_rt_add (a, b) ->
+ (sz_ops a) @ (sz_ops b) @ [ DW_OP_plus ]
+
+ | SIZE_rt_mul (a, b) ->
+ (sz_ops a) @ (sz_ops b) @ [ DW_OP_mul ]
+
+ | SIZE_rt_max (a, b) ->
+ (sz_ops a) @ (sz_ops b) @
+ [ DW_OP_over; (* ... a b a *)
+ DW_OP_over; (* ... a b a b *)
+ DW_OP_ge; (* ... a b (a>=b?1:0) *)
+
+ (* jump +1 byte of dwarf ops if 1 *)
+ DW_OP_bra (IMM 1L);
+
+ (* do this if 0, when b is max. *)
+ DW_OP_swap; (* ... b a *)
+
+ (* jump to here when a is max. *)
+ DW_OP_drop; (* ... max *)
+ ]
+
+ | SIZE_rt_align (align, off) ->
+ (*
+ * calculate off + pad where:
+ *
+ * pad = (align - (off mod align)) mod align
+ *
+ * In our case it's always a power of two,
+ * so we can just do:
+ *
+ * mask = align-1
+ * off += mask
+ * off &= ~mask
+ *
+ *)
+ (sz_ops off) @ (sz_ops align) @
+ [
+ DW_OP_lit 1; (* ... off align 1 *)
+ DW_OP_minus; (* ... off mask *)
+ DW_OP_dup; (* ... off mask mask *)
+ DW_OP_not; (* ... off mask ~mask *)
+ DW_OP_rot; (* ... ~mask off mask *)
+ DW_OP_plus; (* ... ~mask (off+mask) *)
+ DW_OP_and; (* ... aligned *)
+ ]
+ in
+ let ops = sz_ops sz in
+ let ops =
+ if add_to_base
+ then ops @ [ DW_OP_plus ]
+ else ops
+ in
+ let frag = SEQ (Array.map (dw_op_to_frag abi) (Array.of_list ops)) in
+ let block_fixup = new_fixup "DW_FORM_block4 fixup" in
+ SEQ [| WORD (TY_u32, F_SZ block_fixup);
+ DEF (block_fixup, frag) |]
+
+
+ and ref_type_die
+ (ty:Ast.ty)
+ : frag =
+ (* Returns a DW_FORM_ref_addr to the type. *)
+ if Hashtbl.mem emitted_types ty
+ then Hashtbl.find emitted_types ty
+ else
+ let ref_addr_for_fix fix =
+ let res = dw_form_ref_addr fix in
+ Hashtbl.add emitted_types ty res;
+ res
+ in
+
+ let record trec =
+ let rty = referent_type abi (Ast.TY_rec trec) in
+ let rty_sz = Il.referent_ty_size abi.Abi.abi_word_bits in
+ let fix = new_fixup "record type DIE" in
+ let die = DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_struct_type);
+ (* DW_AT_byte_size: DW_FORM_block4 *)
+ size_block4 (rty_sz rty) false
+ |]);
+ in
+ let rtys =
+ match rty with
+ Il.StructTy rtys -> rtys
+ | _ -> bug () "record type became non-struct referent_ty"
+ in
+ emit_die die;
+ Array.iteri
+ begin
+ fun i (ident, slot) ->
+ emit_die (SEQ [|
+ uleb (get_abbrev_code abbrev_struct_type_member);
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING ident;
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_slot_die slot);
+ (* DW_AT_mutable: DW_FORM_flag *)
+ BYTE (if slot.Ast.slot_mutable then 1 else 0);
+ (* DW_AT_data_member_location: DW_FORM_block4 *)
+ size_block4
+ (Il.get_element_offset word_bits rtys i)
+ true;
+ (* DW_AT_byte_size: DW_FORM_block4 *)
+ size_block4 (rty_sz rtys.(i)) false |]);
+ end
+ trec;
+ emit_null_die ();
+ ref_addr_for_fix fix
+ in
+
+ let string_type _ =
+ (*
+ * Strings, like vecs, are &[rc,alloc,fill,data...]
+ *)
+ let fix = new_fixup "string type DIE" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_string_type);
+ (* (DW_AT_byte_size, DW_FORM_block1); *)
+ dw_form_block1 [| DW_OP_push_object_address;
+ DW_OP_deref;
+ DW_OP_lit (word_sz_int * 2);
+ DW_OP_plus; |];
+ (* (DW_AT_data_location, DW_FORM_block1); *)
+ dw_form_block1 [| DW_OP_push_object_address;
+ DW_OP_deref;
+ DW_OP_lit (word_sz_int * 3);
+ DW_OP_plus |]
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let base (name, encoding, byte_size) =
+ let fix = new_fixup ("base type DIE: " ^ name) in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_base_type);
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING name;
+ (* DW_AT_encoding: DW_FORM_data1 *)
+ BYTE (dw_ate_to_int encoding);
+ (* DW_AT_byte_size: DW_FORM_data1 *)
+ BYTE byte_size
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let unspecified_anon_struct _ =
+ let fix = new_fixup "unspecified-anon-struct DIE" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code
+ abbrev_unspecified_anon_structure_type);
+ (* DW_AT_declaration: DW_FORM_flag *)
+ BYTE 1;
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let unspecified_struct rust_ty =
+ let fix = new_fixup "unspecified-struct DIE" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_unspecified_structure_type);
+ (* DW_AT_rust_type_code: DW_FORM_data1 *)
+ BYTE (dw_rust_type_to_int rust_ty);
+ (* DW_AT_declaration: DW_FORM_flag *)
+ BYTE 1;
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let rust_type_param (p:(ty_param_idx * Ast.effect)) =
+ let fix = new_fixup "rust-type-param DIE" in
+ let die = DEF (fix, type_param_die p) in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let unspecified_ptr_with_ref rust_ty ref_addr =
+ let fix = new_fixup ("unspecified-pointer-type-with-ref DIE") in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_unspecified_pointer_type);
+ (* DW_AT_rust_type_code: DW_FORM_data1 *)
+ BYTE (dw_rust_type_to_int rust_ty);
+ (* DW_AT_declaration: DW_FORM_flag *)
+ BYTE 1;
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ ref_addr
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let formal_type slot =
+ let fix = new_fixup "formal type" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_formal_type);
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_slot_die slot);
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let fn_type tfn =
+ let (tsig, taux) = tfn in
+ let fix = new_fixup "fn type" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_subroutine_type);
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_slot_die tsig.Ast.sig_output_slot);
+ encode_effect taux.Ast.fn_effect;
+ (* DW_AT_rust_iterator: DW_FORM_flag *)
+ BYTE (if taux.Ast.fn_is_iter then 1 else 0)
+ |])
+ in
+ emit_die die;
+ Array.iter
+ (fun s -> ignore (formal_type s))
+ tsig.Ast.sig_input_slots;
+ emit_null_die ();
+ ref_addr_for_fix fix
+ in
+
+ let obj_fn_type ident tfn =
+ let (tsig, taux) = tfn in
+ let fix = new_fixup "fn type" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_obj_subroutine_type);
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING ident;
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_slot_die tsig.Ast.sig_output_slot);
+ encode_effect taux.Ast.fn_effect;
+ (* DW_AT_rust_iterator: DW_FORM_flag *)
+ BYTE (if taux.Ast.fn_is_iter then 1 else 0)
+ |])
+ in
+ emit_die die;
+ Array.iter
+ (fun s -> ignore (formal_type s))
+ tsig.Ast.sig_input_slots;
+ emit_null_die ();
+ ref_addr_for_fix fix
+ in
+
+ let obj_type (eff,ob) =
+ let fix = new_fixup "object type" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_obj_type);
+ encode_effect eff;
+ |])
+ in
+ emit_die die;
+ Hashtbl.iter (fun k v -> ignore (obj_fn_type k v)) ob;
+ emit_null_die ();
+ ref_addr_for_fix fix
+ in
+
+ let unspecified_ptr_with_ref_ty rust_ty ty =
+ unspecified_ptr_with_ref rust_ty (ref_type_die ty)
+ in
+
+ let unspecified_ptr_with_ref_slot rust_ty slot =
+ unspecified_ptr_with_ref rust_ty (ref_slot_die slot)
+ in
+
+ let unspecified_ptr rust_ty =
+ unspecified_ptr_with_ref rust_ty (unspecified_anon_struct ())
+ in
+
+ let native_ptr_type oid =
+ let fix = new_fixup "native type" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_native_pointer_type);
+ (* DW_AT_rust_type_code: DW_FORM_data1 *)
+ BYTE (dw_rust_type_to_int DW_RUST_native);
+ (* DW_AT_rust_native_type_id: DW_FORM_data4 *)
+ WORD (word_ty_mach, IMM (Int64.of_int (int_of_opaque oid)));
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ match ty with
+ Ast.TY_nil -> unspecified_struct DW_RUST_nil
+ | Ast.TY_bool -> base ("bool", DW_ATE_boolean, 1)
+ | Ast.TY_mach (TY_u8) -> base ("u8", DW_ATE_unsigned, 1)
+ | Ast.TY_mach (TY_u16) -> base ("u16", DW_ATE_unsigned, 2)
+ | Ast.TY_mach (TY_u32) -> base ("u32", DW_ATE_unsigned, 4)
+ | Ast.TY_mach (TY_u64) -> base ("u64", DW_ATE_unsigned, 8)
+ | Ast.TY_mach (TY_i8) -> base ("i8", DW_ATE_signed, 1)
+ | Ast.TY_mach (TY_i16) -> base ("i16", DW_ATE_signed, 2)
+ | Ast.TY_mach (TY_i32) -> base ("i32", DW_ATE_signed, 4)
+ | Ast.TY_mach (TY_i64) -> base ("i64", DW_ATE_signed, 8)
+ | Ast.TY_int -> base ("int", DW_ATE_signed, word_sz_int)
+ | Ast.TY_uint -> base ("uint", DW_ATE_unsigned, word_sz_int)
+ | Ast.TY_char -> base ("char", DW_ATE_unsigned_char, 4)
+ | Ast.TY_str -> string_type ()
+ | Ast.TY_rec trec -> record trec
+ | Ast.TY_tup ttup ->
+ record (Array.mapi (fun i s ->
+ ("_" ^ (string_of_int i), s))
+ ttup)
+
+ | Ast.TY_vec s -> unspecified_ptr_with_ref_slot DW_RUST_vec s
+ | Ast.TY_chan t -> unspecified_ptr_with_ref_ty DW_RUST_chan t
+ | Ast.TY_port t -> unspecified_ptr_with_ref_ty DW_RUST_port t
+ | Ast.TY_task -> unspecified_ptr DW_RUST_task
+ | Ast.TY_fn fn -> fn_type fn
+ | Ast.TY_tag _ -> unspecified_ptr DW_RUST_tag
+ | Ast.TY_iso _ -> unspecified_ptr DW_RUST_iso
+ | Ast.TY_type -> unspecified_ptr DW_RUST_type
+ | Ast.TY_native i -> native_ptr_type i
+ | Ast.TY_param p -> rust_type_param p
+ | Ast.TY_obj ob -> obj_type ob
+ | _ ->
+ bug () "unimplemented dwarf encoding for type %a"
+ Ast.sprintf_ty ty
+ in
+
+ let finish_crate_cu_and_compose_headers _ =
+
+ let pubnames_header_and_curr_pubnames =
+ SEQ [| (BYTE 0) |]
+ in
+
+ let aranges_header_and_curr_aranges =
+ SEQ [| (BYTE 0) |]
+ in
+
+ let cu_info_fixup = new_fixup "CU debug_info fixup" in
+ let info_header_fixup = new_fixup "CU debug_info header" in
+ let info_header_and_curr_infos =
+ SEQ
+ [|
+ WORD (TY_u32, (* unit_length: *)
+ (ADD
+ ((F_SZ cu_info_fixup), (* including this header,*)
+ (F_SZ info_header_fixup)))); (* excluding this word. *)
+ DEF (info_header_fixup,
+ (SEQ [|
+ WORD (TY_u16, IMM 2L); (* DWARF version *)
+ (* Since we share abbrevs across all CUs,
+ * offset is always 0.
+ *)
+ WORD (TY_u32, IMM 0L); (* CU-abbrev offset. *)
+ BYTE 4; (* Size of an address. *)
+ |]));
+ DEF (cu_info_fixup,
+ SEQ (Array.of_list (List.rev (!curr_cu_infos))));
+ |]
+ in
+
+ let cu_line_fixup = new_fixup "CU debug_line fixup" in
+ let cu_line_header_fixup = new_fixup "CU debug_line header" in
+ let line_header_fixup = new_fixup "CU debug_line header" in
+ let line_header_and_curr_line =
+ SEQ
+ [|
+ WORD
+ (TY_u32, (* unit_length: *)
+ (ADD
+ ((F_SZ cu_line_fixup), (* including this header,*)
+ (F_SZ cu_line_header_fixup)))); (* excluding this word. *)
+ DEF (cu_line_header_fixup,
+ (SEQ [|
+ WORD (TY_u16, IMM 2L); (* DWARF version. *)
+ WORD
+ (TY_u32,
+ (F_SZ line_header_fixup)); (* Another header-length.*)
+ DEF (line_header_fixup,
+ SEQ [|
+ BYTE 1; (* Minimum insn length. *)
+ BYTE 1; (* default_is_stmt *)
+ BYTE 0; (* line_base *)
+ BYTE 0; (* line_range *)
+ BYTE (max_dw_lns + 1); (* opcode_base *)
+ BYTES (* opcode arity array. *)
+ (Array.init max_dw_lns
+ (fun i ->
+ (dw_lns_arity
+ (int_to_dw_lns
+ (i+1)))));
+ (BYTE 0); (* List of include dirs. *)
+ (BYTE 0); (* List of file entries. *)
+ |])|]));
+ DEF (cu_line_fixup,
+ SEQ (Array.of_list (List.rev (!curr_cu_line))));
+ |]
+ in
+ let frame_header_and_curr_frame =
+ SEQ [| (BYTE 0) |]
+ in
+ let prepend_and_reset (curr_ref, accum_ref, header_and_curr) =
+ prepend accum_ref header_and_curr;
+ curr_ref := []
+ in
+ List.iter prepend_and_reset
+ [ (curr_cu_aranges, cu_aranges, aranges_header_and_curr_aranges);
+ (curr_cu_pubnames, cu_pubnames, pubnames_header_and_curr_pubnames);
+ (curr_cu_infos, cu_infos, info_header_and_curr_infos);
+ (curr_cu_line, cu_lines, line_header_and_curr_line);
+ (curr_cu_frame, cu_frames, frame_header_and_curr_frame) ]
+ in
+
+ let image_base_rel (fix:fixup) : expr64 =
+ SUB (M_POS (fix), M_POS (cx.ctxt_image_base_fixup))
+ in
+
+ let addr_ranges (fix:fixup) : frag =
+ let image_is_relocated =
+ match cx.ctxt_sess.Session.sess_targ with
+ Win32_x86_pe ->
+ cx.ctxt_sess.Session.sess_library_mode
+ | _ -> true
+ in
+ let lo =
+ if image_is_relocated
+ then image_base_rel fix
+ else M_POS fix
+ in
+ SEQ [|
+ (* DW_AT_low_pc, DW_FORM_addr *)
+ WORD (word_ty_mach, lo);
+ (* DW_AT_high_pc, DW_FORM_addr *)
+ WORD (word_ty_mach, ADD ((lo),
+ (M_SZ fix)))
+ |]
+ in
+
+ let emit_srcfile_cu_die
+ (name:string)
+ (cu_text_fixup:fixup)
+ : unit =
+ let abbrev_code = get_abbrev_code abbrev_srcfile_cu in
+ let srcfile_cu_die =
+ (SEQ [|
+ uleb abbrev_code;
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING (Filename.basename name);
+ (* DW_AT_comp_dir: DW_FORM_string *)
+ ZSTRING (Filename.concat (Sys.getcwd()) (Filename.dirname name));
+ addr_ranges cu_text_fixup;
+ |])
+ in
+ emit_die srcfile_cu_die
+ in
+
+ let emit_meta_die
+ (meta:(Ast.ident * string))
+ : unit =
+ let abbrev_code = get_abbrev_code abbrev_meta in
+ let die =
+ SEQ [| uleb abbrev_code;
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING (fst meta);
+ (* DW_AT_const_value: DW_FORM_string *)
+ ZSTRING (snd meta);
+ |]
+ in
+ emit_die die
+ in
+
+ let begin_crate_cu_and_emit_cu_die
+ (name:string)
+
+ (cu_text_fixup:fixup)
+ : unit =
+ let abbrev_code = get_abbrev_code abbrev_crate_cu in
+ let crate_cu_die =
+ (SEQ [|
+ uleb abbrev_code;
+ (* DW_AT_producer: DW_FORM_string *)
+ ZSTRING "Rustboot pre-release";
+ (* DW_AT_language: DW_FORM_data4 *)
+ WORD (word_ty_mach, IMM 0x2L); (* DW_LANG_C *)
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING (Filename.basename name);
+ (* DW_AT_comp_dir: DW_FORM_string *)
+ ZSTRING (Filename.concat (Sys.getcwd()) (Filename.dirname name));
+ addr_ranges cu_text_fixup;
+ (* DW_AT_use_UTF8, DW_FORM_flag *)
+ BYTE 1
+ |])
+ in
+ curr_cu_infos := [crate_cu_die];
+ curr_cu_line := []
+ in
+
+ let type_param_decl_die (p:(Ast.ident * (ty_param_idx * Ast.effect))) =
+ let (ident, (idx, eff)) = p in
+ SEQ [|
+ uleb (get_abbrev_code abbrev_rust_type_param_decl);
+ (* DW_AT_rust_type_code: DW_FORM_data1 *)
+ BYTE (dw_rust_type_to_int DW_RUST_type_param);
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING (Filename.basename ident);
+ (* DW_AT_rust_type_param_index: DW_FORM_data4 *)
+ WORD (word_ty_mach, IMM (Int64.of_int idx));
+ encode_effect eff;
+ |]
+ in
+
+ let emit_type_param_decl_dies
+ (params:(Ast.ty_param identified) array)
+ : unit =
+ Array.iter
+ (fun p ->
+ emit_die (type_param_decl_die p.node))
+ params;
+ in
+
+ let emit_module_die
+ (id:Ast.ident)
+ : unit =
+ let abbrev_code = get_abbrev_code abbrev_module in
+ let module_die =
+ (SEQ [|
+ uleb abbrev_code;
+ (* DW_AT_name *)
+ ZSTRING id;
+ |])
+ in
+ emit_die module_die;
+ in
+
+ let emit_subprogram_die
+ (id:Ast.ident)
+ (ret_slot:Ast.slot)
+ (effect:Ast.effect)
+ (fix:fixup)
+ : unit =
+ (* NB: retpc = "top word of frame-base" by convention in ABI/x86. *)
+ let abi = cx.ctxt_abi in
+ let retpc = Int64.sub abi.Abi.abi_frame_base_sz abi.Abi.abi_word_sz in
+ let abbrev_code = get_abbrev_code abbrev_subprogram in
+ let subprogram_die =
+ (SEQ [|
+ uleb abbrev_code;
+ (* DW_AT_name *)
+ ZSTRING id;
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ ref_slot_die ret_slot;
+ addr_ranges fix;
+ (* DW_AT_frame_base *)
+ dw_form_block1 [| DW_OP_reg abi.Abi.abi_dwarf_fp_reg |];
+ (* DW_AT_return_addr *)
+ dw_form_block1 [| DW_OP_fbreg (Asm.IMM retpc); |];
+ encode_effect effect;
+ |])
+ in
+ emit_die subprogram_die
+ in
+
+ let emit_typedef_die
+ (id:Ast.ident)
+ (ty:Ast.ty)
+ : unit =
+ let abbrev_code = get_abbrev_code abbrev_typedef in
+ let typedef_die =
+ (SEQ [|
+ uleb abbrev_code;
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING id;
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_type_die ty);
+ |])
+ in
+ emit_die typedef_die
+ in
+
+ let visit_crate_pre
+ (crate:Ast.crate)
+ : unit =
+ let filename = (Hashtbl.find cx.ctxt_item_files crate.id) in
+ log cx "walking crate CU '%s'" filename;
+ begin_crate_cu_and_emit_cu_die filename
+ (Hashtbl.find cx.ctxt_file_fixups crate.id);
+ Array.iter emit_meta_die crate.node.Ast.crate_meta;
+ inner.Walk.visit_crate_pre crate
+ in
+
+ let visit_mod_item_pre
+ (id:Ast.ident)
+ (params:(Ast.ty_param identified) array)
+ (item:Ast.mod_item)
+ : unit =
+ if Hashtbl.mem cx.ctxt_item_files item.id
+ then
+ begin
+ let filename = (Hashtbl.find cx.ctxt_item_files item.id) in
+ log cx "walking srcfile CU '%s'" filename;
+ emit_srcfile_cu_die filename
+ (Hashtbl.find cx.ctxt_file_fixups item.id);
+ end
+ else
+ ();
+ begin
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_mod _ ->
+ begin
+ log cx "walking module '%s' with %d type params"
+ (path_name())
+ (Array.length item.node.Ast.decl_params);
+ emit_module_die id;
+ emit_type_param_decl_dies item.node.Ast.decl_params;
+ end
+ | Ast.MOD_ITEM_fn _ ->
+ begin
+ let ty = Hashtbl.find cx.ctxt_all_item_types item.id in
+ let (tsig,taux) =
+ match ty with
+ Ast.TY_fn tfn -> tfn
+ | _ ->
+ bug ()
+ "non-fn type when emitting dwarf for MOD_ITEM_fn"
+ in
+ log cx "walking function '%s' with %d type params"
+ (path_name())
+ (Array.length item.node.Ast.decl_params);
+ emit_subprogram_die
+ id tsig.Ast.sig_output_slot taux.Ast.fn_effect
+ (Hashtbl.find cx.ctxt_fn_fixups item.id);
+ emit_type_param_decl_dies item.node.Ast.decl_params;
+ end
+ | Ast.MOD_ITEM_type _ ->
+ begin
+ log cx "walking typedef '%s' with %d type params"
+ (path_name())
+ (Array.length item.node.Ast.decl_params);
+ emit_typedef_die
+ id (Hashtbl.find cx.ctxt_all_type_items item.id);
+ emit_type_param_decl_dies item.node.Ast.decl_params;
+ end
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre id params item
+ in
+
+ let visit_crate_post
+ (crate:Ast.crate)
+ : unit =
+ inner.Walk.visit_crate_post crate;
+ assert (Hashtbl.mem cx.ctxt_item_files crate.id);
+ emit_null_die();
+ log cx
+ "finishing crate CU and composing headers (%d DIEs collected)"
+ (List.length (!curr_cu_infos));
+ finish_crate_cu_and_compose_headers ()
+ in
+
+ let visit_mod_item_post
+ (id:Ast.ident)
+ (params:(Ast.ty_param identified) array)
+ (item:Ast.mod_item)
+ : unit =
+ inner.Walk.visit_mod_item_post id params item;
+ begin
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_mod _
+ | Ast.MOD_ITEM_fn _
+ | Ast.MOD_ITEM_type _ -> emit_null_die ()
+ | _ -> ()
+ end;
+ if Hashtbl.mem cx.ctxt_item_files item.id
+ then emit_null_die()
+ in
+
+ let visit_block_pre (b:Ast.block) : unit =
+ log cx "entering lexical block";
+ let fix = Hashtbl.find cx.ctxt_block_fixups b.id in
+ let abbrev_code = get_abbrev_code abbrev_lexical_block in
+ let block_die =
+ SEQ [|
+ uleb abbrev_code;
+ addr_ranges fix;
+ |]
+ in
+ emit_die block_die;
+ inner.Walk.visit_block_pre b
+ in
+
+ let visit_block_post (b:Ast.block) : unit =
+ inner.Walk.visit_block_post b;
+ log cx "leaving lexical block, terminating with NULL DIE";
+ emit_null_die ()
+ in
+
+ let visit_slot_identified_pre (s:Ast.slot identified) : unit =
+ begin
+ match htab_search cx.ctxt_slot_keys s.id with
+ None
+ | Some Ast.KEY_temp _ -> ()
+ | Some Ast.KEY_ident ident ->
+ begin
+ let abbrev_code =
+ if Hashtbl.mem cx.ctxt_slot_is_arg s.id
+ then get_abbrev_code abbrev_formal
+ else get_abbrev_code abbrev_variable
+ in
+ let resolved_slot = referent_to_slot cx s.id in
+ let emit_var_die slot_loc =
+ let var_die =
+ SEQ [|
+ uleb abbrev_code;
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING ident;
+ (* DW_AT_location: DW_FORM_block1 *)
+ dw_form_block1 slot_loc;
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ ref_slot_die resolved_slot
+ |]
+ in
+ emit_die var_die;
+ in
+ match htab_search cx.ctxt_slot_offsets s.id with
+ Some off ->
+ begin
+ match Il.size_to_expr64 off with
+ (* FIXME: handle dynamic-size slots. *)
+ None -> ()
+ | Some off ->
+ emit_var_die
+ [| DW_OP_fbreg off |]
+ end
+ | None ->
+ (* FIXME (issue #28): handle slots assigned to
+ * vregs.
+ *)
+ ()
+ end
+ end;
+ inner.Walk.visit_slot_identified_pre s
+ in
+
+ { inner with
+ Walk.visit_crate_pre = visit_crate_pre;
+ Walk.visit_crate_post = visit_crate_post;
+ Walk.visit_mod_item_pre = visit_mod_item_pre;
+ Walk.visit_mod_item_post = visit_mod_item_post;
+ Walk.visit_block_pre = visit_block_pre;
+ Walk.visit_block_post = visit_block_post;
+ Walk.visit_slot_identified_pre = visit_slot_identified_pre
+ }
+;;
+
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : debug_records =
+
+ let cu_aranges = ref [] in
+ let cu_pubnames = ref [] in
+ let cu_infos = ref [] in
+ let cu_abbrevs = ref [] in
+ let cu_lines = ref [] in
+ let cu_frames = ref [] in
+
+ let path = Stack.create () in
+
+ let passes =
+ [|
+ dwarf_visitor cx Walk.empty_visitor path
+ cx.ctxt_debug_info_fixup
+ cu_aranges cu_pubnames
+ cu_infos cu_abbrevs
+ cu_lines cu_frames
+ |];
+ in
+
+ log cx "emitting DWARF records";
+ run_passes cx "dwarf" path passes (log cx "%s") crate;
+
+ (* Terminate the tables. *)
+ {
+ debug_aranges = SEQ (Array.of_list (List.rev (!cu_aranges)));
+ debug_pubnames = SEQ (Array.of_list (List.rev (!cu_pubnames)));
+ debug_info = SEQ (Array.of_list (List.rev (!cu_infos)));
+ debug_abbrev = SEQ (Array.of_list (List.rev (!cu_abbrevs)));
+ debug_line = SEQ (Array.of_list (List.rev (!cu_lines)));
+ debug_frame = SEQ (Array.of_list (List.rev (!cu_frames)));
+ }
+;;
+
+(*
+ * Support for reconstituting a DWARF tree from a file, and various
+ * artifacts we can distill back from said DWARF.
+ *)
+
+let log sess = Session.log "dwarf"
+ sess.Session.sess_log_dwarf
+ sess.Session.sess_log_out
+;;
+
+
+let iflog (sess:Session.sess) (thunk:(unit -> unit)) : unit =
+ if sess.Session.sess_log_dwarf
+ then thunk ()
+ else ()
+;;
+
+let read_abbrevs
+ (sess:Session.sess)
+ (ar:asm_reader)
+ ((off:int),(sz:int))
+ : (int,abbrev) Hashtbl.t =
+ ar.asm_seek off;
+ let abs = Hashtbl.create 0 in
+ let rec read_abbrevs _ =
+ if ar.asm_get_off() >= (off + sz)
+ then abs
+ else
+ begin
+ let n = ar.asm_get_uleb() in
+ let tag = ar.asm_get_uleb() in
+ let has_children = ar.asm_get_u8() in
+ let pairs = ref [] in
+ let _ =
+ log sess "abbrev: %d, tag: %d, has_children: %d"
+ n tag has_children
+ in
+ let rec read_pairs _ =
+ let attr = ar.asm_get_uleb() in
+ let form = ar.asm_get_uleb() in
+ let _ = log sess "attr: %d, form: %d" attr form in
+ match (attr,form) with
+ (0,0) -> Array.of_list (List.rev (!pairs))
+ | _ ->
+ begin
+ pairs := (dw_at_of_int attr,
+ dw_form_of_int form) :: (!pairs);
+ read_pairs()
+ end
+ in
+ let pairs = read_pairs() in
+ Hashtbl.add abs n (dw_tag_of_int tag,
+ dw_children_of_int has_children,
+ pairs);
+ read_abbrevs()
+ end;
+ in
+ read_abbrevs()
+;;
+
+type data =
+ DATA_str of string
+ | DATA_num of int
+ | DATA_other
+;;
+
+type die =
+ { die_off: int;
+ die_tag: dw_tag;
+ die_attrs: (dw_at * (dw_form * data)) array;
+ die_children: die array; }
+;;
+
+type rooted_dies = (int * (int,die) Hashtbl.t)
+;;
+
+let fmt_dies
+ (ff:Format.formatter)
+ (dies:rooted_dies)
+ : unit =
+ let ((root:int),(dies:(int,die) Hashtbl.t)) = dies in
+ let rec fmt_die die =
+ Ast.fmt ff "@\nDIE <0x%x> %s" die.die_off (dw_tag_to_string die.die_tag);
+ Array.iter
+ begin
+ fun (at,(form,data)) ->
+ Ast.fmt ff "@\n %s = " (dw_at_to_string at);
+ begin
+ match data with
+ DATA_num n -> Ast.fmt ff "0x%x" n
+ | DATA_str s -> Ast.fmt ff "\"%s\"" s
+ | DATA_other -> Ast.fmt ff "<other>"
+ end;
+ Ast.fmt ff " (%s)" (dw_form_to_string form)
+ end
+ die.die_attrs;
+ if (Array.length die.die_children) != 0
+ then
+ begin
+ Ast.fmt ff "@\n";
+ Ast.fmt_obox ff;
+ Ast.fmt ff " children: ";
+ Ast.fmt_obr ff;
+ Array.iter fmt_die die.die_children;
+ Ast.fmt_cbb ff
+ end;
+ in
+ fmt_die (Hashtbl.find dies root)
+;;
+
+let read_dies
+ (sess:Session.sess)
+ (ar:asm_reader)
+ ((off:int),(sz:int))
+ (abbrevs:(int,abbrev) Hashtbl.t)
+ : (int * ((int,die) Hashtbl.t)) =
+ ar.asm_seek off;
+ let cu_len = ar.asm_get_u32() in
+ let _ = log sess "debug_info cu_len: %d, section size %d" cu_len sz in
+ let _ = assert ((cu_len + 4) = sz) in
+ let dwarf_vers = ar.asm_get_u16() in
+ let _ = assert (dwarf_vers >= 2) in
+ let cu_abbrev_off = ar.asm_get_u32() in
+ let _ = assert (cu_abbrev_off = 0) in
+ let sizeof_addr = ar.asm_get_u8() in
+ let _ = assert (sizeof_addr = 4) in
+
+ let adv_block1 _ =
+ let len = ar.asm_get_u8() in
+ ar.asm_adv len
+ in
+
+ let adv_block4 _ =
+ let len = ar.asm_get_u32() in
+ ar.asm_adv len
+ in
+
+ let all_dies = Hashtbl.create 0 in
+ let root = (ar.asm_get_off()) - off in
+
+ let rec read_dies (dies:(die list) ref) =
+ let die_arr _ = Array.of_list (List.rev (!dies)) in
+ if ar.asm_get_off() >= (off + sz)
+ then die_arr()
+ else
+ begin
+ let die_off = (ar.asm_get_off()) - off in
+ let abbrev_num = ar.asm_get_uleb() in
+ if abbrev_num = 0
+ then die_arr()
+ else
+ let _ =
+ log sess "DIE at off <%d> with abbrev %d"
+ die_off abbrev_num
+ in
+ let abbrev = Hashtbl.find abbrevs abbrev_num in
+ let (tag, children, attrs) = abbrev in
+ let attrs =
+ Array.map
+ begin
+ fun (attr,form) ->
+ let data =
+ match form with
+ DW_FORM_string -> DATA_str (ar.asm_get_zstr())
+ | DW_FORM_addr -> DATA_num (ar.asm_get_u32())
+ | DW_FORM_ref_addr -> DATA_num (ar.asm_get_u32())
+ | DW_FORM_data1 -> DATA_num (ar.asm_get_u8())
+ | DW_FORM_data4 -> DATA_num (ar.asm_get_u32())
+ | DW_FORM_flag -> DATA_num (ar.asm_get_u8())
+ | DW_FORM_block1 -> (adv_block1(); DATA_other)
+ | DW_FORM_block4 -> (adv_block4(); DATA_other)
+ | _ ->
+ bug () "unknown DWARF form %d"
+ (dw_form_to_int form)
+ in
+ (attr, (form, data))
+ end
+ attrs;
+ in
+ let children =
+ match children with
+ DW_CHILDREN_yes -> read_dies (ref [])
+ | DW_CHILDREN_no -> [| |]
+ in
+ let die = { die_off = die_off;
+ die_tag = tag;
+ die_attrs = attrs;
+ die_children = children }
+ in
+ prepend dies die;
+ htab_put all_dies die_off die;
+ read_dies dies
+ end
+ in
+ ignore (read_dies (ref []));
+ iflog sess
+ begin
+ fun _ ->
+ log sess "read DIEs:";
+ log sess "%s" (Ast.fmt_to_str fmt_dies (root, all_dies));
+ end;
+ (root, all_dies)
+;;
+
+let rec extract_meta
+ ((i:int),(dies:(int,die) Hashtbl.t))
+ : (Ast.ident * string) array =
+ let meta = Queue.create () in
+
+ let get_attr die attr =
+ atab_find die.die_attrs attr
+ in
+
+ let get_str die attr =
+ match get_attr die attr with
+ (_, DATA_str s) -> s
+ | _ -> bug () "unexpected num form for %s" (dw_at_to_string attr)
+ in
+
+ let die = Hashtbl.find dies i in
+ begin
+ match die.die_tag with
+ DW_TAG_rust_meta ->
+ let n = get_str die DW_AT_name in
+ let v = get_str die DW_AT_const_value in
+ Queue.add (n,v) meta
+
+ | DW_TAG_compile_unit ->
+ Array.iter
+ (fun child ->
+ Array.iter (fun m -> Queue.add m meta)
+ (extract_meta (child.die_off,dies)))
+ die.die_children
+
+ | _ -> ()
+ end;
+ queue_to_arr meta
+;;
+
+
+let rec extract_mod_items
+ (nref:node_id ref)
+ (oref:opaque_id ref)
+ (abi:Abi.abi)
+ (mis:Ast.mod_items)
+ ((i:int),(dies:(int,die) Hashtbl.t))
+ : unit =
+
+ let next_node_id _ : node_id =
+ let id = !nref in
+ nref:= Node ((int_of_node id)+1);
+ id
+ in
+
+ let next_opaque_id _ : opaque_id =
+ let id = !oref in
+ oref:= Opaque ((int_of_opaque id)+1);
+ id
+ in
+
+ let external_opaques = Hashtbl.create 0 in
+ let get_opaque_of o =
+ htab_search_or_add external_opaques o
+ (fun _ -> next_opaque_id())
+ in
+
+
+ let (word_sz:int64) = abi.Abi.abi_word_sz in
+ let (word_sz_int:int) = Int64.to_int word_sz in
+
+ let get_die i =
+ Hashtbl.find dies i
+ in
+
+ let get_attr die attr =
+ atab_find die.die_attrs attr
+ in
+
+ let get_str die attr =
+ match get_attr die attr with
+ (_, DATA_str s) -> s
+ | _ -> bug () "unexpected num form for %s" (dw_at_to_string attr)
+ in
+
+ let get_num die attr =
+ match get_attr die attr with
+ (_, DATA_num n) -> n
+ | _ -> bug () "unexpected str form for %s" (dw_at_to_string attr)
+ in
+
+ let get_flag die attr =
+ match get_attr die attr with
+ (_, DATA_num 0) -> false
+ | (_, DATA_num 1) -> true
+ | _ -> bug () "unexpected non-flag form for %s" (dw_at_to_string attr)
+ in
+
+ let get_effect die =
+ match (get_flag die DW_AT_mutable, get_flag die DW_AT_pure) with
+ (* Note: weird encoding: mutable+pure = unsafe. *)
+ (true, true) -> Ast.UNSAFE
+ | (true, false) -> Ast.STATE
+ | (false, false) -> Ast.IO
+ | (false, true) -> Ast.PURE
+ in
+
+ let get_name die = get_str die DW_AT_name in
+
+ let get_type_param die =
+ let idx = get_num die DW_AT_rust_type_param_index in
+ let e = get_effect die in
+ (idx, e)
+ in
+
+ let get_native_id die =
+ get_num die DW_AT_rust_native_type_id
+ in
+
+ let get_type_param_decl die =
+ ((get_str die DW_AT_name), (get_type_param die))
+ in
+
+ let is_rust_type die t =
+ match atab_search die.die_attrs DW_AT_rust_type_code with
+ Some (_, DATA_num n) -> (dw_rust_type_of_int n) = t
+ | _ -> false
+ in
+
+ let rec get_ty die : Ast.ty =
+ match die.die_tag with
+
+ DW_TAG_structure_type
+ when is_rust_type die DW_RUST_nil ->
+ Ast.TY_nil
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_task ->
+ Ast.TY_task
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_type ->
+ Ast.TY_type
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_port ->
+ Ast.TY_port (get_referenced_ty die)
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_chan ->
+ Ast.TY_chan (get_referenced_ty die)
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_vec ->
+ Ast.TY_vec (get_referenced_slot die)
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_type_param ->
+ Ast.TY_param (get_type_param die)
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_native ->
+ Ast.TY_native (get_opaque_of (get_native_id die))
+
+ | DW_TAG_string_type -> Ast.TY_str
+
+ | DW_TAG_base_type ->
+ begin
+ match ((get_name die),
+ (dw_ate_of_int (get_num die DW_AT_encoding)),
+ (get_num die DW_AT_byte_size)) with
+ ("bool", DW_ATE_boolean, 1) -> Ast.TY_bool
+ | ("u8", DW_ATE_unsigned, 1) -> Ast.TY_mach TY_u8
+ | ("u16", DW_ATE_unsigned, 2) -> Ast.TY_mach TY_u16
+ | ("u32", DW_ATE_unsigned, 4) -> Ast.TY_mach TY_u32
+ | ("u64", DW_ATE_unsigned, 8) -> Ast.TY_mach TY_u64
+ | ("i8", DW_ATE_signed, 1) -> Ast.TY_mach TY_i8
+ | ("i16", DW_ATE_signed, 2) -> Ast.TY_mach TY_i16
+ | ("i32", DW_ATE_signed, 4) -> Ast.TY_mach TY_i32
+ | ("i64", DW_ATE_signed, 8) -> Ast.TY_mach TY_i64
+ | ("char", DW_ATE_unsigned_char, 4) -> Ast.TY_char
+ | ("int", DW_ATE_signed, sz)
+ when sz = word_sz_int -> Ast.TY_int
+ | ("uint", DW_ATE_unsigned, sz)
+ when sz = word_sz_int -> Ast.TY_uint
+ | _ -> bug () "unexpected type of DW_TAG_base_type"
+ end
+
+ | DW_TAG_structure_type ->
+ begin
+ let is_num_idx s =
+ let len = String.length s in
+ if len >= 2 && s.[0] = '_'
+ then
+ let ok = ref true in
+ String.iter
+ (fun c -> ok := (!ok) && '0' <= c && c <= '9')
+ (String.sub s 1 (len-1));
+ !ok
+ else
+ false
+ in
+ let members = arr_map_partial
+ die.die_children
+ begin
+ fun child ->
+ if child.die_tag = DW_TAG_member
+ then Some child
+ else None
+ end
+ in
+ assert ((Array.length members) > 0);
+ if is_num_idx (get_name members.(0))
+ then
+ let slots = Array.map get_referenced_slot members in
+ Ast.TY_tup slots
+ else
+ let entries =
+ Array.map
+ (fun member_die -> ((get_name member_die),
+ (get_referenced_slot member_die)))
+ members
+ in
+ Ast.TY_rec entries
+ end
+
+ | DW_TAG_interface_type ->
+ let eff = get_effect die in
+ let fns = Hashtbl.create 0 in
+ Array.iter
+ begin
+ fun child ->
+ if child.die_tag = DW_TAG_subroutine_type
+ then
+ Hashtbl.add fns (get_name child) (get_ty_fn child)
+ end
+ die.die_children;
+ Ast.TY_obj (eff,fns)
+
+ | DW_TAG_subroutine_type ->
+ Ast.TY_fn (get_ty_fn die)
+
+ | _ ->
+ bug () "unexpected tag in get_ty: %s"
+ (dw_tag_to_string die.die_tag)
+
+ and get_slot die : Ast.slot =
+ match die.die_tag with
+ DW_TAG_reference_type ->
+ let ty = get_referenced_ty die in
+ let mut = get_flag die DW_AT_mutable in
+ let mode =
+ (* Exterior slots have a 'data_location' attr. *)
+ match atab_search die.die_attrs DW_AT_data_location with
+ Some _ -> Ast.MODE_exterior
+ | None -> Ast.MODE_alias
+ in
+ { Ast.slot_mode = mode;
+ Ast.slot_mutable = mut;
+ Ast.slot_ty = Some ty }
+ | _ ->
+ let ty = get_ty die in
+ (* FIXME: encode mutability of interior slots properly. *)
+ { Ast.slot_mode = Ast.MODE_interior;
+ Ast.slot_mutable = false;
+ Ast.slot_ty = Some ty }
+
+ and get_referenced_ty die =
+ match get_attr die DW_AT_type with
+ (DW_FORM_ref_addr, DATA_num n) -> get_ty (get_die n)
+ | _ -> bug () "unexpected form of DW_AT_type in get_referenced_ty"
+
+ and get_referenced_slot die =
+ match get_attr die DW_AT_type with
+ (DW_FORM_ref_addr, DATA_num n) -> get_slot (get_die n)
+ | _ -> bug () "unexpected form of DW_AT_type in get_referenced_slot"
+
+ and get_ty_fn die =
+ let out = get_referenced_slot die in
+ let ins =
+ arr_map_partial
+ die.die_children
+ begin
+ fun child ->
+ if child.die_tag = DW_TAG_formal_parameter
+ then Some (get_referenced_slot child)
+ else None
+ end
+ in
+ let effect = get_effect die in
+ let iter = get_flag die DW_AT_rust_iterator in
+ let tsig =
+ { Ast.sig_input_slots = ins;
+ Ast.sig_input_constrs = [| |];
+ Ast.sig_output_slot = out; }
+ in
+ let taux =
+ { Ast.fn_is_iter = iter;
+ Ast.fn_effect = effect }
+ in
+ (tsig, taux)
+ in
+
+ let wrap n =
+ { id = next_node_id ();
+ node = n }
+ in
+
+ let decl p i =
+ wrap { Ast.decl_params = p;
+ Ast.decl_item = i; }
+ in
+
+ let get_formals die =
+ let islots = Queue.create () in
+ let params = Queue.create () in
+ Array.iter
+ begin
+ fun child ->
+ match child.die_tag with
+ DW_TAG_formal_parameter ->
+ if (is_rust_type child DW_RUST_type_param)
+ then Queue.push (wrap (get_type_param_decl child)) params
+ else Queue.push (get_referenced_slot child) islots
+ | _ -> ()
+ end
+ die.die_children;
+ (queue_to_arr params, queue_to_arr islots)
+ in
+
+ let extract_children mis die =
+ Array.iter
+ (fun child ->
+ extract_mod_items nref oref abi mis (child.die_off,dies))
+ die.die_children
+ in
+
+ let get_mod_items die =
+ let len = Array.length die.die_children in
+ let mis = Hashtbl.create len in
+ extract_children mis die;
+ mis
+ in
+
+ let form_header_slots slots =
+ Array.mapi
+ (fun i slot -> (wrap slot, "_" ^ (string_of_int i)))
+ slots
+ in
+
+ let die = Hashtbl.find dies i in
+ match die.die_tag with
+ DW_TAG_typedef ->
+ let ident = get_name die in
+ let ty = get_referenced_ty die in
+ let tyi = Ast.MOD_ITEM_type ty in
+ let (params, islots) = get_formals die in
+ assert ((Array.length islots) = 0);
+ htab_put mis ident (decl params tyi)
+
+ | DW_TAG_compile_unit ->
+ extract_children mis die
+
+ | DW_TAG_module ->
+ let ident = get_name die in
+ let sub_mis = get_mod_items die in
+ let exports = Hashtbl.create 0 in
+ let _ = Hashtbl.add exports Ast.EXPORT_all_decls () in
+ let view = { Ast.view_imports = Hashtbl.create 0;
+ Ast.view_exports = exports }
+ in
+ let mi = Ast.MOD_ITEM_mod (view, sub_mis) in
+ htab_put mis ident (decl [||] mi)
+
+ | DW_TAG_subprogram ->
+ (* FIXME: finish this. *)
+ let ident = get_name die in
+ let oslot = get_referenced_slot die in
+ let effect = get_effect die in
+ let (params, islots) = get_formals die in
+ let taux = { Ast.fn_effect = effect;
+ Ast.fn_is_iter = false }
+ in
+ let tfn = { Ast.fn_input_slots = form_header_slots islots;
+ Ast.fn_input_constrs = [| |];
+ Ast.fn_output_slot = wrap oslot;
+ Ast.fn_aux = taux;
+ Ast.fn_body = (wrap [||]); }
+ in
+ let fn = Ast.MOD_ITEM_fn tfn in
+ htab_put mis ident (decl params fn)
+
+ | _ -> ()
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
+
--- /dev/null
+open Semant;;
+open Common;;
+
+let log cx = Session.log "effect"
+ cx.ctxt_sess.Session.sess_log_effect
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+let iflog cx thunk =
+ if cx.ctxt_sess.Session.sess_log_effect
+ then thunk ()
+ else ()
+;;
+
+let mutability_checking_visitor
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ (*
+ * This visitor enforces the following rules:
+ *
+ * - A channel type carrying a mutable 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 t' ->
+ err None "channel of mutable type: %a " Ast.sprintf_ty t'
+ | _ -> ()
+ in
+
+ let check_write id dst =
+ let dst_slot = lval_slot cx dst in
+ if (dst_slot.Ast.slot_mutable or
+ (Hashtbl.mem cx.ctxt_copy_stmt_is_init id))
+ then ()
+ else err (Some id) "writing to non-mutable slot"
+ in
+ (* FIXME: enforce the no-write-alias-to-immutable-slot rule. *)
+ let visit_stmt_pre s =
+ begin
+ match s.node with
+ Ast.STMT_copy (dst, _) -> check_write s.id dst
+ | Ast.STMT_copy_binop (dst, _, _) -> check_write s.id dst
+ | Ast.STMT_call (dst, _, _) -> check_write s.id dst
+ | Ast.STMT_recv (dst, _) -> check_write s.id 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 function_effect_propagation_visitor
+ (item_effect:(node_id, Ast.effect) Hashtbl.t)
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ (*
+ * This visitor calculates the effect of each function according to
+ * its statements:
+ *
+ * - Communication lowers to 'io'
+ * - Native calls lower to 'unsafe'
+ * - Calling a function with effect e lowers to e.
+ *)
+ let curr_fn = Stack.create () in
+ let visit_mod_item_pre n p i =
+ begin
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn _ -> Stack.push i.id curr_fn
+ | _ -> ()
+ 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;
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn _ -> ignore (Stack.pop curr_fn)
+ | _ -> ()
+ in
+ let visit_obj_drop_pre o b =
+ Stack.push b.id curr_fn;
+ inner.Walk.visit_obj_drop_pre o b
+ in
+ let visit_obj_drop_post o b =
+ inner.Walk.visit_obj_drop_post o b;
+ ignore (Stack.pop curr_fn);
+ in
+
+ let lower_to s ne =
+ let fn_id = Stack.top curr_fn in
+ let e =
+ match htab_search item_effect fn_id with
+ None -> Ast.PURE
+ | Some e -> e
+ in
+ let ne = lower_effect_of ne e in
+ if ne <> e
+ then
+ begin
+ iflog cx
+ begin
+ fun _ ->
+ let name = Hashtbl.find cx.ctxt_all_item_names fn_id in
+ log cx "lowering calculated effect on '%a': '%a' -> '%a'"
+ Ast.sprintf_name name
+ Ast.sprintf_effect e
+ Ast.sprintf_effect ne;
+ log cx "at stmt %a" Ast.sprintf_stmt s
+ end;
+ Hashtbl.replace item_effect fn_id ne
+ end;
+ in
+
+ let visit_stmt_pre s =
+ begin
+ match s.node with
+ Ast.STMT_send _
+ | Ast.STMT_recv _ -> lower_to s Ast.IO
+
+ | Ast.STMT_call (_, fn, _) ->
+ let lower_to_callee_ty t =
+ match t with
+ Ast.TY_fn (_, taux) ->
+ lower_to s taux.Ast.fn_effect;
+ | _ -> bug () "non-fn callee"
+ in
+ if lval_is_slot cx fn
+ then
+ let t = lval_slot cx fn in
+ lower_to_callee_ty (slot_ty t)
+ else
+ begin
+ let item = lval_item cx fn in
+ let t = Hashtbl.find cx.ctxt_all_item_types item.id in
+ lower_to_callee_ty t;
+ match htab_search cx.ctxt_required_items item.id with
+ None -> ()
+ | Some (REQUIRED_LIB_rust _, _) -> ()
+ | Some _ -> lower_to s Ast.UNSAFE
+ end
+ | _ -> ()
+ 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_drop_pre = visit_obj_drop_pre;
+ Walk.visit_obj_drop_post = visit_obj_drop_post;
+ Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+let binding_effect_propagation_visitor
+ ((*cx*)_:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ (* This visitor lowers the effect of an object or binding according
+ * to its slots: holding a 'state' slot lowers any obj item, or
+ * bind-stmt LHS, to 'state'.
+ *
+ * Binding (or implicitly just making a native 1st-class) makes the LHS
+ * unsafe.
+ *)
+ inner
+;;
+
+let effect_checking_visitor
+ (item_auth:(node_id, Ast.effect) Hashtbl.t)
+ (item_effect:(node_id, Ast.effect) Hashtbl.t)
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ (*
+ * This visitor checks that each type, item and obj declares
+ * effects consistent with what we calculated.
+ *)
+ let auth_stack = Stack.create () in
+ let visit_mod_item_pre n p i =
+ begin
+ match htab_search item_auth i.id with
+ None -> ()
+ | Some e ->
+ let curr =
+ if Stack.is_empty auth_stack
+ then Ast.PURE
+ else Stack.top auth_stack
+ in
+ let next = lower_effect_of e curr in
+ Stack.push next auth_stack;
+ iflog cx
+ begin
+ fun _ ->
+ let name = Hashtbl.find cx.ctxt_all_item_names i.id in
+ log cx
+ "entering '%a', adjusting auth effect: '%a' -> '%a'"
+ Ast.sprintf_name name
+ Ast.sprintf_effect curr
+ Ast.sprintf_effect next
+ end
+ end;
+ begin
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f ->
+ let e =
+ match htab_search item_effect i.id with
+ None -> Ast.PURE
+ | Some e -> e
+ in
+ let fe = f.Ast.fn_aux.Ast.fn_effect in
+ let ae =
+ if Stack.is_empty auth_stack
+ then None
+ else Some (Stack.top auth_stack)
+ in
+ if e <> fe && (ae <> (Some e))
+ then
+ begin
+ let name = Hashtbl.find cx.ctxt_all_item_names i.id in
+ err (Some i.id)
+ "%a claims effect '%a' but calculated effect is '%a'%s"
+ Ast.sprintf_name name
+ Ast.sprintf_effect fe
+ Ast.sprintf_effect e
+ begin
+ match ae with
+ Some ae when ae <> fe ->
+ Printf.sprintf " (auth effect is '%a')"
+ Ast.sprintf_effect ae
+ | _ -> ""
+ end
+ end
+ | _ -> ()
+ 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;
+ match htab_search item_auth i.id with
+ None -> ()
+ | Some _ ->
+ let curr = Stack.pop auth_stack in
+ let next =
+ if Stack.is_empty auth_stack
+ then Ast.PURE
+ else Stack.top auth_stack
+ in
+ iflog cx
+ begin
+ fun _ ->
+ let name = Hashtbl.find cx.ctxt_all_item_names i.id in
+ log cx
+ "leaving '%a', restoring auth effect: '%a' -> '%a'"
+ Ast.sprintf_name name
+ Ast.sprintf_effect curr
+ Ast.sprintf_effect next
+ end
+ in
+ { inner with
+ Walk.visit_mod_item_pre = visit_mod_item_pre;
+ Walk.visit_mod_item_post = visit_mod_item_post; }
+;;
+
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : unit =
+ let path = Stack.create () in
+ let item_auth = Hashtbl.create 0 in
+ let item_effect = Hashtbl.create 0 in
+ let passes =
+ [|
+ (mutability_checking_visitor cx
+ Walk.empty_visitor);
+ (function_effect_propagation_visitor item_effect cx
+ Walk.empty_visitor);
+ (binding_effect_propagation_visitor cx
+ Walk.empty_visitor);
+ (effect_checking_visitor item_auth item_effect cx
+ Walk.empty_visitor);
+ |]
+ in
+ let root_scope = [ SCOPE_crate crate ] in
+ let auth_effect name eff =
+ match lookup_by_name cx root_scope name with
+ None -> ()
+ | Some (_, id) ->
+ if referent_is_item cx id
+ then htab_put item_auth id eff
+ else err (Some id) "auth clause in crate refers to non-item"
+ in
+ Hashtbl.iter auth_effect crate.node.Ast.crate_auth;
+ run_passes cx "effect" path passes (log cx "%s") crate
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+open Semant;;
+open Common;;
+
+let log cx = Session.log "layout"
+ 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
+ * |task ptr (implicit arg) | + abi_implicit_args_sz
+ * |output ptr (implicit arg) |
+ * +----------------------------+ <-- fp + abi_frame_base_sz
+ * |return pc |
+ * |callee-save registers |
+ * |... |
+ * +----------------------------+ <-- fp
+ * |crate ptr |
+ * |crate-rel frame info disp |
+ * +----------------------------+ <-- fp - abi_frame_info_sz
+ * |spills determined in ra |
+ * |... |
+ * |... |
+ * +----------------------------+ <-- fp - (abi_frame_info_sz
+ * |... | + spillsz)
+ * |frame-allocated stuff |
+ * |determined in resolve |
+ * |laid out in layout |
+ * |... |
+ * |... |
+ * +----------------------------+ <-- fp - framesz
+ * |call space | == sp + callsz
+ * |... |
+ * |... |
+ * +----------------------------+ <-- fp - (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.ctxt_abi 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 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 = referent_to_slot cx id in
+ let rt = slot_referent_type cx.ctxt_abi slot in
+ let (elt_size, elt_align) = rty_layout rt in
+ if vregs_ok
+ && (is_subword_size elt_size)
+ && (not (type_is_structured (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.ctxt_abi 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.exterior_rc_slot_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 =
+ 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 = interior_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 (header_slots, _, _) ->
+ enter_frame i.id;
+ layout_header i.id
+ (Array.map (fun sid -> sid.id) header_slots)
+
+ | 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_tag _
+ | Ast.MOD_ITEM_obj _ -> 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 info_sz = SIZE_fixed cx.ctxt_abi.Abi.abi_frame_info_sz in
+ let locals_off = add_sz spill_sz info_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 =
+ match resolve_lval cx callee with
+ DEFN_item i -> Array.length i.Ast.decl_params
+ | _ -> 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 path = Stack.create () in
+ let passes =
+ [|
+ (layout_visitor cx
+ Walk.empty_visitor)
+ |];
+ in
+ run_passes cx "layout" path passes (log cx "%s") crate
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(*
+ * Computes iterator-loop nesting depths and max depth of each function.
+ *)
+
+open Semant;;
+open Common;;
+
+let log cx = Session.log "loop"
+ 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 ();
+ 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 path = Stack.create () in
+ let passes =
+ [|
+ (loop_depth_visitor cx
+ Walk.empty_visitor)
+ |]
+ in
+
+ run_passes cx "loop" path passes (log cx "%s") crate;
+ ()
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+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. )
+ *
+ *)
+
+
+let log cx = Session.log "resolve"
+ cx.ctxt_sess.Session.sess_log_resolve
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+let iflog cx thunk =
+ if 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) =
+ 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 } ->
+ let rec resolve_pat block pat =
+ match pat with
+ Ast.PAT_slot ({ id = slot_id }, 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) } -> 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)
+ (path:Ast.name_component Stack.t)
+ (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 (Walk.path_to_name path);
+ log cx "collected item #%d: %s" (int_of_node i.id) n;
+ begin
+ (* FIXME: this is incomplete. *)
+ 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 (header_slots, _, _) ->
+ let skey i = Printf.sprintf "_%d" i in
+ note_header i.id
+ (Array.mapi (fun i s -> (s, skey i)) header_slots)
+ | _ -> ()
+ 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 (Walk.path_to_name 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 (Walk.path_to_name 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
+ (Walk.path_to_name 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
+ None -> err None "unknown name: %a" Ast.sprintf_name name
+ | Some (_, id) ->
+ match htab_search cx.ctxt_all_defns id with
+ Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_type _ })
+ | Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_obj _ })
+ | Some (DEFN_ty_param _) -> id
+ | _ ->
+ err None "Found non-type binding for %a"
+ Ast.sprintf_name name
+;;
+
+
+let get_ty_references
+ (t:Ast.ty)
+ (cx:ctxt)
+ (scopes:scope list)
+ : node_id list =
+ let base = ty_fold_list_concat () in
+ let ty_fold_named n =
+ [ lookup_type_node_by_name cx scopes n ]
+ in
+ let fold = { base with ty_fold_named = ty_fold_named } in
+ fold_ty fold t
+;;
+
+
+let type_reference_and_tag_extracting_visitor
+ (cx:ctxt)
+ (scopes:(scope list) ref)
+ (node_to_references:(node_id,node_id list) Hashtbl.t)
+ (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ let visit_mod_item_pre id params item =
+ begin
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_type ty ->
+ begin
+ log cx "extracting references for type node %d"
+ (int_of_node item.id);
+ let referenced = get_ty_references ty cx (!scopes) in
+ List.iter
+ (fun i -> log cx "type %d references type %d"
+ (int_of_node item.id) (int_of_node i)) referenced;
+ htab_put node_to_references item.id referenced;
+ match ty with
+ Ast.TY_tag ttag ->
+ htab_put all_tags item.id (ttag, (!scopes))
+ | _ -> ()
+ end
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre id params item
+ in
+ { inner with
+ Walk.visit_mod_item_pre = visit_mod_item_pre }
+;;
+
+
+type recur_info =
+ { recur_all_nodes: node_id list;
+ recur_curr_iso: (node_id array) option; }
+;;
+
+let empty_recur_info =
+ { recur_all_nodes = [];
+ recur_curr_iso = None }
+;;
+
+let push_node r n =
+ { r with recur_all_nodes = n :: r.recur_all_nodes }
+;;
+
+let set_iso r i =
+ { r with recur_curr_iso = Some i }
+;;
+
+
+let index_in_curr_iso (recur:recur_info) (node:node_id) : int option =
+ match recur.recur_curr_iso with
+ None -> None
+ | Some iso ->
+ let rec search i =
+ if i >= (Array.length iso)
+ then None
+ else
+ if iso.(i) = node
+ then Some i
+ else search (i+1)
+ in
+ search 0
+;;
+
+let need_ty_tag t =
+ match t with
+ Ast.TY_tag ttag -> ttag
+ | _ -> err None "needed ty_tag"
+;;
+
+
+let rec ty_iso_of
+ (cx:ctxt)
+ (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+ (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+ (n:node_id)
+ : Ast.ty =
+ let _ = iflog cx (fun _ -> log cx "+++ ty_iso_of #%d" (int_of_node n)) in
+ let group_table = Hashtbl.find recursive_tag_groups n in
+ let group_array = Array.of_list (htab_keys group_table) in
+ let compare_nodes a_id b_id =
+ (* FIXME: this should sort by the sorted name-lists of the
+ *constructors* of the tag, not the tag type name. *)
+ let a_name = Hashtbl.find cx.ctxt_all_item_names a_id in
+ let b_name = Hashtbl.find cx.ctxt_all_item_names b_id in
+ compare a_name b_name
+ in
+ let recur = set_iso (push_node empty_recur_info n) group_array in
+ let resolve_member member =
+ let (tag, scopes) = Hashtbl.find all_tags member in
+ let ty = Ast.TY_tag tag in
+ let ty = resolve_type cx scopes recursive_tag_groups all_tags recur ty in
+ need_ty_tag ty
+ in
+ Array.sort compare_nodes group_array;
+ log cx "resolving node %d, %d-member iso group"
+ (int_of_node n) (Array.length group_array);
+ Array.iteri (fun i n -> log cx "member %d: %d" i
+ (int_of_node n)) group_array;
+ let group = Array.map resolve_member group_array in
+ let rec search i =
+ if i >= (Array.length group_array)
+ then err None "node is not a member of its own iso group"
+ else
+ if group_array.(i) = n
+ then i
+ else search (i+1)
+ in
+ let iso =
+ Ast.TY_iso { Ast.iso_index = (search 0);
+ Ast.iso_group = group }
+ in
+ iflog cx (fun _ ->
+ log cx "--- ty_iso_of #%d ==> %a"
+ (int_of_node n) Ast.sprintf_ty iso);
+ iso
+
+
+and lookup_type_by_name
+ (cx:ctxt)
+ (scopes:scope list)
+ (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+ (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+ (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 cx scopes name with
+ None -> err None "unknown name: %a" Ast.sprintf_name name
+ | Some (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 None "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 cx scopes recursive_tag_groups
+ all_tags 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"
+ (Ast.fmt_to_str Ast.fmt_decl_params params);
+ log cx "args: %s"
+ (Ast.fmt_to_str Ast.fmt_app_args args);
+ end;
+ let ty = rebuild_ty_under_params 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
+ (cx:ctxt)
+ (scopes:(scope list))
+ (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+ (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+ (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 cx scopes recursive_tag_groups all_tags 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);
+ match index_in_curr_iso recur node with
+ Some i -> Ast.TY_idx i
+ | None ->
+ if Hashtbl.mem recursive_tag_groups node
+ then
+ begin
+ let ttag = need_ty_tag t in
+ Hashtbl.replace all_tags node (ttag, scopes);
+ ty_iso_of cx recursive_tag_groups all_tags node
+ end
+ else
+ 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);
+ resolve_type cx scopes recursive_tag_groups all_tags recur t
+ in
+ let fold =
+ { base with
+ ty_fold_named = ty_fold_named; }
+ in
+ let t' = fold_ty 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)
+ (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+ (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let resolve_ty (t:Ast.ty) : Ast.ty =
+ resolve_type cx (!scopes) recursive_tag_groups all_tags empty_recur_info t
+ 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);
+ log cx "collected resolved slot #%d with type %s" (int_of_node slot.id)
+ (match slot.node.Ast.slot_ty with
+ None -> "??"
+ | Some t -> (Ast.fmt_to_str Ast.fmt_ty t));
+ inner.Walk.visit_slot_identified_pre slot
+ in
+
+ let visit_mod_item_pre id params item =
+ begin
+ try
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_type ty ->
+ let ty =
+ resolve_type cx (!scopes) recursive_tag_groups
+ all_tags empty_recur_info ty
+ in
+ 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
+
+ (*
+ * Don't resolve the "type" of a mod item; just resolve its
+ * members.
+ *)
+ | Ast.MOD_ITEM_mod _ -> ()
+
+ | Ast.MOD_ITEM_tag (header_slots, _, nid)
+ when Hashtbl.mem recursive_tag_groups nid ->
+ begin
+ match ty_of_mod_item true item with
+ Ast.TY_fn (tsig, taux) ->
+ let input_slots =
+ Array.map
+ (fun sloti -> resolve_slot sloti.node)
+ header_slots
+ in
+ let output_slot =
+ interior_slot (ty_iso_of cx recursive_tag_groups
+ all_tags nid)
+ in
+ let ty =
+ Ast.TY_fn
+ ({tsig with
+ Ast.sig_input_slots = input_slots;
+ Ast.sig_output_slot = output_slot }, taux)
+ in
+ log cx "resolved recursive tag %s, type as %a"
+ id Ast.sprintf_ty ty;
+ htab_put cx.ctxt_all_item_types item.id ty
+ | _ -> bug () "recursive tag with non-function type"
+ end
+
+ | _ ->
+ let t = ty_of_mod_item true item in
+ let ty =
+ resolve_type cx (!scopes) recursive_tag_groups
+ all_tags empty_recur_info t
+ in
+ log cx "resolved item %s, type as %a" id Ast.sprintf_ty ty;
+ htab_put cx.ctxt_all_item_types item.id ty;
+ 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_type cx (!scopes) recursive_tag_groups all_tags
+ empty_recur_info (Ast.TY_fn (ty_fn_of_fn fn.node))
+ in
+ 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 visit_lval_pre lv =
+ let rec rebuild_lval' lv =
+ match lv with
+ Ast.LVAL_ext (base, ext) ->
+ let ext =
+ match ext with
+ 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_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
+
+ { 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; }
+;;
+
+
+let lval_base_resolving_visitor
+ (cx:ctxt)
+ (scopes:(scope list) ref)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ let lookup_referent_by_ident id ident =
+ log cx "looking up slot or item with ident '%s'" ident;
+ match lookup cx (!scopes) (Ast.KEY_ident ident) with
+ None -> err (Some id) "unresolved identifier '%s'" ident
+ | Some (_, id) -> (log cx "resolved to node id #%d"
+ (int_of_node id); id)
+ in
+ let lookup_slot_by_temp id temp =
+ log cx "looking up temp slot #%d" (int_of_temp temp);
+ let res = lookup cx (!scopes) (Ast.KEY_temp temp) in
+ match res with
+ None -> err
+ (Some id) "unresolved temp node #%d" (int_of_temp temp)
+ | Some (_, id) ->
+ (log cx "resolved to node id #%d" (int_of_node id); id)
+ in
+ let lookup_referent_by_name_base id nb =
+ match nb with
+ Ast.BASE_ident ident
+ | Ast.BASE_app (ident, _) -> lookup_referent_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 referent_id = lookup_referent_by_name_base nb.id nb.node in
+ iflog cx (fun _ -> log cx "resolved lval #%d to referent #%d"
+ (int_of_node nb.id) (int_of_node referent_id));
+ htab_put cx.ctxt_lval_to_referent nb.id referent_id
+ in
+ lookup_lval lv;
+ inner.Walk.visit_lval_pre lv
+ in
+ { inner with
+ Walk.visit_lval_pre = visit_lval_pre }
+;;
+
+
+
+(*
+ * iso-recursion groups are very complicated.
+ *
+ * - iso groups are always rooted at *named* ty_tag nodes
+ *
+ * - consider:
+ *
+ * type colour = tag(red, green, blue);
+ * type list = tag(cons(colour, @list), nil())
+ *
+ * this should include list as an iso but not colour,
+ * should result in:
+ *
+ * type list = iso[<0>:tag(cons(tag(red,green,blue),@#1))]
+ *
+ * - consider:
+ *
+ * type colour = tag(red, green, blue);
+ * type tree = tag(children(@list), leaf(colour))
+ * type list = tag(cons(@tree, @list), nil())
+ *
+ * this should result in:
+ *
+ * type list = iso[<0>:tag(cons(@#2, @#1),nil());
+ * 1: tag(children(@#1),leaf(tag(red,green,blue)))]
+ *
+ * - how can you calculate these?
+ *
+ * - start by making a map from named-tag-node-id -> referenced-other-nodes
+ * - for each member in the set, if you can get from itself to itself, keep
+ * it, otherwise it's non-recursive => non-interesting, delete it.
+ * - group the members (now all recursive) by dependency
+ * - assign index-number to each elt of group
+ * - fully resolve each elt of group, turning names into numbers or chasing
+ * through to fully-resolving targets as necessary
+ * - place group in iso, store differently-indexed value in table for each
+ *
+ *
+ * - what are the illegal forms?
+ * - recursion that takes indefinite storage to form a tag, eg.
+ *
+ * type t = tag(foo(t));
+ *
+ * - recursion that makes a tag unconstructable, eg:
+ *
+ * type t = tag(foo(@t));
+ *)
+
+let resolve_recursion
+ (cx:ctxt)
+ (node_to_references:(node_id,node_id list) Hashtbl.t)
+ (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+ : unit =
+
+ let recursive_tag_types = Hashtbl.create 0 in
+
+ let rec can_reach
+ (target:node_id)
+ (visited:node_id list)
+ (curr:node_id)
+ : bool =
+ if List.mem curr visited
+ then false
+ else
+ match htab_search node_to_references curr with
+ None -> false
+ | Some referenced ->
+ if List.mem target referenced
+ then true
+ else List.exists (can_reach target (curr :: visited)) referenced
+ in
+
+ let extract_recursive_tags _ =
+ Hashtbl.iter
+ begin fun id _ ->
+ if can_reach id [] id
+ then begin
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_item
+ { Ast.decl_item = Ast.MOD_ITEM_type (Ast.TY_tag _) } ->
+ log cx "type %d is a recursive tag" (int_of_node id);
+ Hashtbl.replace recursive_tag_types id ()
+ | _ ->
+ log cx "type %d is recursive, but not a tag" (int_of_node id);
+ end
+ else log cx "type %d is non-recursive" (int_of_node id);
+ end
+ node_to_references
+ in
+
+ let group_recursive_tags _ =
+ while (Hashtbl.length recursive_tag_types) != 0 do
+ let keys = htab_keys recursive_tag_types in
+ let root = List.hd keys in
+ let group = Hashtbl.create 0 in
+ let rec walk visited node =
+ if List.mem node visited
+ then ()
+ else
+ begin
+ if Hashtbl.mem recursive_tag_types node
+ then
+ begin
+ Hashtbl.remove recursive_tag_types node;
+ htab_put recursive_tag_groups node group;
+ htab_put group node ();
+ log cx "recursion group rooted at tag %d contains tag %d"
+ (int_of_node root) (int_of_node node);
+ end;
+ match htab_search node_to_references node with
+ None -> ()
+ | Some referenced ->
+ List.iter (walk (node :: visited)) referenced
+ end
+ in
+ walk [] root;
+ done
+ in
+
+ begin
+ extract_recursive_tags ();
+ group_recursive_tags ();
+ log cx "found %d independent type-recursion groups"
+ (Hashtbl.length recursive_tag_groups);
+ end
+;;
+
+let pattern_resolving_visitor
+ (cx:ctxt)
+ (scopes:scope list ref)
+ (inner:Walk.visitor) : Walk.visitor =
+ let visit_stmt_pre stmt =
+ begin
+ match stmt.node with
+ Ast.STMT_alt_tag { Ast.alt_tag_lval = _; Ast.alt_tag_arms = arms } ->
+ let resolve_arm { node = arm } =
+ match fst arm with
+ Ast.PAT_tag (ident, _) ->
+ begin
+ match lookup_by_ident cx !scopes ident with
+ None ->
+ err None "unresolved tag constructor '%s'" ident
+ | Some (_, tag_id) ->
+ match Hashtbl.find cx.ctxt_all_defns tag_id with
+ DEFN_item {
+ Ast.decl_item = Ast.MOD_ITEM_tag _
+ } -> ()
+ | _ ->
+ err None "'%s' is not a tag constructor" ident
+ end
+ | _ -> ()
+
+ in
+ Array.iter resolve_arm arms
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre stmt
+ in
+ { inner with Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : unit =
+ let (scopes:(scope list) ref) = ref [] in
+ let path = Stack.create () in
+
+ let node_to_references = Hashtbl.create 0 in
+ let all_tags = Hashtbl.create 0 in
+ let recursive_tag_groups = Hashtbl.create 0 in
+
+ let passes_0 =
+ [|
+ (block_scope_forming_visitor cx Walk.empty_visitor);
+ (stmt_collecting_visitor cx
+ (all_item_collecting_visitor cx path
+ Walk.empty_visitor));
+ (scope_stack_managing_visitor scopes
+ (type_reference_and_tag_extracting_visitor
+ cx scopes node_to_references all_tags
+ Walk.empty_visitor))
+ |]
+ in
+ let passes_1 =
+ [|
+ (scope_stack_managing_visitor scopes
+ (type_resolving_visitor cx scopes
+ recursive_tag_groups all_tags
+ (lval_base_resolving_visitor cx scopes
+ Walk.empty_visitor)));
+ |]
+ in
+ let passes_2 =
+ [|
+ (scope_stack_managing_visitor scopes
+ (pattern_resolving_visitor cx scopes
+ Walk.empty_visitor))
+ |]
+ in
+ log cx "running primary resolve passes";
+ run_passes cx "resolve collect" path passes_0 (log cx "%s") crate;
+ resolve_recursion cx node_to_references recursive_tag_groups;
+ log cx "running secondary resolve passes";
+ run_passes cx "resolve bind" path passes_1 (log cx "%s") crate;
+ log cx "running tertiary resolve passes";
+ run_passes cx "resolve patterns" path passes_2 (log cx "%s") crate
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
+
--- /dev/null
+
+open Common;;
+
+type slots_table = (Ast.slot_key,node_id) Hashtbl.t
+type items_table = (Ast.ident,node_id) Hashtbl.t
+type block_slots_table = (node_id,slots_table) Hashtbl.t
+type block_items_table = (node_id,items_table) Hashtbl.t
+;;
+
+
+type code = {
+ code_fixup: fixup;
+ code_quads: Il.quads;
+ code_vregs_and_spill: (int * fixup) option;
+}
+;;
+
+type glue =
+ GLUE_activate
+ | GLUE_yield
+ | GLUE_exit_main_task
+ | GLUE_exit_task
+ | GLUE_mark of Ast.ty
+ | GLUE_drop of Ast.ty
+ | GLUE_free of Ast.ty
+ | GLUE_copy of Ast.ty (* One-level copy. *)
+ | GLUE_clone of Ast.ty (* Deep copy. *)
+ | GLUE_compare of Ast.ty
+ | GLUE_hash of Ast.ty
+ | GLUE_write of Ast.ty
+ | GLUE_read of Ast.ty
+ | GLUE_unwind
+ | GLUE_get_next_pc
+ | GLUE_mark_frame of node_id (* node is the frame *)
+ | GLUE_drop_frame of node_id (* node is the frame *)
+ | GLUE_reloc_frame of node_id (* node is the frame *)
+ | GLUE_fn_binding of node_id (* node is the 'bind' stmt *)
+ | GLUE_obj_drop of node_id (* node is the obj *)
+ | GLUE_loop_body of node_id (* node is the 'for each' body block *)
+ | GLUE_forward of (Ast.ident * Ast.ty_obj * Ast.ty_obj)
+;;
+
+type data =
+ DATA_str of string
+ | DATA_name of Ast.name
+ | DATA_tydesc of Ast.ty
+ | DATA_frame_glue_fns of node_id
+ | DATA_obj_vtbl of node_id
+ | DATA_forwarding_vtbl of (Ast.ty_obj * Ast.ty_obj)
+ | DATA_crate
+;;
+
+type defn =
+ DEFN_slot of Ast.slot
+ | DEFN_item of Ast.mod_item_decl
+ | DEFN_ty_param of Ast.ty_param
+ | DEFN_obj_fn of (node_id * Ast.fn)
+ | DEFN_obj_drop of node_id
+ | DEFN_loop_body of node_id
+;;
+
+type glue_code = (glue, code) Hashtbl.t;;
+type item_code = (node_id, code) Hashtbl.t;;
+type file_code = (node_id, item_code) Hashtbl.t;;
+type data_frags = (data, (fixup * Asm.frag)) Hashtbl.t;;
+
+let string_of_name (n:Ast.name) : string =
+ Ast.fmt_to_str Ast.fmt_name n
+;;
+
+(* The only need for a carg is to uniquely identify a constraint-arg
+ * in a scope-independent fashion. So we just look up the node that's
+ * used as the base of any such arg and glue it on the front of the
+ * symbolic name.
+ *)
+
+type constr_key_arg = Constr_arg_node of (node_id * Ast.carg_path)
+ | Constr_arg_lit of Ast.lit
+type constr_key =
+ Constr_pred of (node_id * constr_key_arg array)
+ | Constr_init of node_id
+
+type ctxt =
+ { ctxt_sess: Session.sess;
+ ctxt_frame_args: (node_id,node_id list) Hashtbl.t;
+ ctxt_frame_blocks: (node_id,node_id list) Hashtbl.t;
+ ctxt_block_slots: block_slots_table;
+ ctxt_block_items: block_items_table;
+ ctxt_slot_is_arg: (node_id,unit) Hashtbl.t;
+ ctxt_slot_keys: (node_id,Ast.slot_key) Hashtbl.t;
+ ctxt_all_item_names: (node_id,Ast.name) Hashtbl.t;
+ ctxt_all_item_types: (node_id,Ast.ty) Hashtbl.t;
+ ctxt_all_lval_types: (node_id,Ast.ty) Hashtbl.t;
+ ctxt_all_cast_types: (node_id,Ast.ty) Hashtbl.t;
+ ctxt_all_type_items: (node_id,Ast.ty) Hashtbl.t;
+ ctxt_all_stmts: (node_id,Ast.stmt) Hashtbl.t;
+ ctxt_item_files: (node_id,filename) Hashtbl.t;
+ ctxt_all_lvals: (node_id,Ast.lval) Hashtbl.t;
+
+ (* definition id --> definition *)
+ ctxt_all_defns: (node_id,defn) Hashtbl.t;
+
+ (* reference id --> definition id *)
+ ctxt_lval_to_referent: (node_id,node_id) Hashtbl.t;
+
+ ctxt_required_items: (node_id, (required_lib * nabi_conv)) Hashtbl.t;
+ ctxt_required_syms: (node_id, string) Hashtbl.t;
+
+ (* Layout-y stuff. *)
+ ctxt_slot_aliased: (node_id,unit) Hashtbl.t;
+ ctxt_slot_is_obj_state: (node_id,unit) Hashtbl.t;
+ ctxt_slot_vregs: (node_id,((int option) ref)) Hashtbl.t;
+ ctxt_slot_offsets: (node_id,size) Hashtbl.t;
+ ctxt_frame_sizes: (node_id,size) Hashtbl.t;
+ ctxt_call_sizes: (node_id,size) Hashtbl.t;
+ ctxt_block_is_loop_body: (node_id,unit) Hashtbl.t;
+ ctxt_stmt_loop_depths: (node_id,int) Hashtbl.t;
+ ctxt_slot_loop_depths: (node_id,int) Hashtbl.t;
+
+ (* Typestate-y stuff. *)
+ ctxt_constrs: (constr_id,constr_key) Hashtbl.t;
+ ctxt_constr_ids: (constr_key,constr_id) Hashtbl.t;
+ ctxt_preconditions: (node_id,Bits.t) Hashtbl.t;
+ ctxt_postconditions: (node_id,Bits.t) Hashtbl.t;
+ ctxt_prestates: (node_id,Bits.t) Hashtbl.t;
+ ctxt_poststates: (node_id,Bits.t) Hashtbl.t;
+ ctxt_call_lval_params: (node_id,Ast.ty array) Hashtbl.t;
+ ctxt_copy_stmt_is_init: (node_id,unit) Hashtbl.t;
+ ctxt_post_stmt_slot_drops: (node_id,node_id list) Hashtbl.t;
+
+ (* Translation-y stuff. *)
+ ctxt_fn_fixups: (node_id,fixup) Hashtbl.t;
+ ctxt_block_fixups: (node_id,fixup) Hashtbl.t;
+ ctxt_file_fixups: (node_id,fixup) Hashtbl.t;
+ ctxt_spill_fixups: (node_id,fixup) Hashtbl.t;
+ ctxt_abi: Abi.abi;
+ ctxt_activate_fixup: fixup;
+ ctxt_yield_fixup: fixup;
+ ctxt_unwind_fixup: fixup;
+ ctxt_exit_task_fixup: fixup;
+
+ ctxt_debug_aranges_fixup: fixup;
+ ctxt_debug_pubnames_fixup: fixup;
+ ctxt_debug_info_fixup: fixup;
+ ctxt_debug_abbrev_fixup: fixup;
+ ctxt_debug_line_fixup: fixup;
+ ctxt_debug_frame_fixup: fixup;
+
+ ctxt_image_base_fixup: fixup;
+ ctxt_crate_fixup: fixup;
+
+ ctxt_file_code: file_code;
+ ctxt_all_item_code: item_code;
+ ctxt_glue_code: glue_code;
+ ctxt_data: data_frags;
+
+ ctxt_native_required:
+ (required_lib,((string,fixup) Hashtbl.t)) Hashtbl.t;
+ ctxt_native_provided:
+ (segment,((string, fixup) Hashtbl.t)) Hashtbl.t;
+
+ ctxt_required_rust_sym_num: (node_id, int) Hashtbl.t;
+ ctxt_required_c_sym_num: ((required_lib * string), int) Hashtbl.t;
+ ctxt_required_lib_num: (required_lib, int) Hashtbl.t;
+
+ ctxt_main_fn_fixup: fixup option;
+ ctxt_main_name: string option;
+ }
+;;
+
+let new_ctxt sess abi crate =
+ { ctxt_sess = sess;
+ ctxt_frame_args = Hashtbl.create 0;
+ ctxt_frame_blocks = Hashtbl.create 0;
+ ctxt_block_slots = Hashtbl.create 0;
+ ctxt_block_items = Hashtbl.create 0;
+ ctxt_slot_is_arg = Hashtbl.create 0;
+ ctxt_slot_keys = Hashtbl.create 0;
+ ctxt_all_item_names = Hashtbl.create 0;
+ ctxt_all_item_types = Hashtbl.create 0;
+ ctxt_all_lval_types = Hashtbl.create 0;
+ ctxt_all_cast_types = Hashtbl.create 0;
+ ctxt_all_type_items = Hashtbl.create 0;
+ ctxt_all_stmts = Hashtbl.create 0;
+ ctxt_item_files = crate.Ast.crate_files;
+ ctxt_all_lvals = Hashtbl.create 0;
+ ctxt_all_defns = Hashtbl.create 0;
+ ctxt_lval_to_referent = Hashtbl.create 0;
+ ctxt_required_items = crate.Ast.crate_required;
+ ctxt_required_syms = crate.Ast.crate_required_syms;
+
+ ctxt_constrs = Hashtbl.create 0;
+ ctxt_constr_ids = Hashtbl.create 0;
+ ctxt_preconditions = Hashtbl.create 0;
+ ctxt_postconditions = Hashtbl.create 0;
+ ctxt_prestates = Hashtbl.create 0;
+ ctxt_poststates = Hashtbl.create 0;
+ ctxt_copy_stmt_is_init = Hashtbl.create 0;
+ ctxt_post_stmt_slot_drops = Hashtbl.create 0;
+ ctxt_call_lval_params = Hashtbl.create 0;
+
+ ctxt_slot_aliased = Hashtbl.create 0;
+ ctxt_slot_is_obj_state = Hashtbl.create 0;
+ ctxt_slot_vregs = Hashtbl.create 0;
+ ctxt_slot_offsets = Hashtbl.create 0;
+ ctxt_frame_sizes = Hashtbl.create 0;
+ ctxt_call_sizes = Hashtbl.create 0;
+
+ ctxt_block_is_loop_body = Hashtbl.create 0;
+ ctxt_slot_loop_depths = Hashtbl.create 0;
+ ctxt_stmt_loop_depths = Hashtbl.create 0;
+
+ ctxt_fn_fixups = Hashtbl.create 0;
+ ctxt_block_fixups = Hashtbl.create 0;
+ ctxt_file_fixups = Hashtbl.create 0;
+ ctxt_spill_fixups = Hashtbl.create 0;
+ ctxt_abi = abi;
+ ctxt_activate_fixup = new_fixup "activate glue";
+ ctxt_yield_fixup = new_fixup "yield glue";
+ ctxt_unwind_fixup = new_fixup "unwind glue";
+ ctxt_exit_task_fixup = new_fixup "exit-task glue";
+
+ ctxt_debug_aranges_fixup = new_fixup "debug_aranges section";
+ ctxt_debug_pubnames_fixup = new_fixup "debug_pubnames section";
+ ctxt_debug_info_fixup = new_fixup "debug_info section";
+ ctxt_debug_abbrev_fixup = new_fixup "debug_abbrev section";
+ ctxt_debug_line_fixup = new_fixup "debug_line section";
+ ctxt_debug_frame_fixup = new_fixup "debug_frame section";
+
+ ctxt_image_base_fixup = new_fixup "loaded image base";
+ ctxt_crate_fixup = new_fixup "root crate structure";
+ ctxt_file_code = Hashtbl.create 0;
+ ctxt_all_item_code = Hashtbl.create 0;
+ ctxt_glue_code = Hashtbl.create 0;
+ ctxt_data = Hashtbl.create 0;
+
+ ctxt_native_required = Hashtbl.create 0;
+ ctxt_native_provided = Hashtbl.create 0;
+
+ ctxt_required_rust_sym_num = Hashtbl.create 0;
+ ctxt_required_c_sym_num = Hashtbl.create 0;
+ ctxt_required_lib_num = Hashtbl.create 0;
+
+ ctxt_main_fn_fixup =
+ (match crate.Ast.crate_main with
+ None -> None
+ | Some n -> Some (new_fixup (string_of_name n)));
+
+ ctxt_main_name =
+ (match crate.Ast.crate_main with
+ None -> None
+ | Some n -> Some (string_of_name n));
+ }
+;;
+
+let report_err cx ido str =
+ let sess = cx.ctxt_sess in
+ let spano = match ido with
+ None -> None
+ | Some id -> (Session.get_span sess id)
+ in
+ match spano with
+ None ->
+ Session.fail sess "Error: %s\n%!" str
+ | Some span ->
+ Session.fail sess "%s:E:Error: %s\n%!"
+ (Session.string_of_span span) str
+;;
+
+let bugi (cx:ctxt) (i:node_id) =
+ let k s =
+ report_err cx (Some i) s;
+ failwith s
+ in Printf.ksprintf k
+;;
+
+(* Convenience accessors. *)
+
+(* resolve an lval reference id to the id of its definition *)
+let lval_to_referent (cx:ctxt) (id:node_id) : node_id =
+ if Hashtbl.mem cx.ctxt_lval_to_referent id
+ then Hashtbl.find cx.ctxt_lval_to_referent id
+ else bug () "unresolved lval"
+;;
+
+(* resolve an lval reference id to its definition *)
+let resolve_lval_id (cx:ctxt) (id:node_id) : defn =
+ Hashtbl.find cx.ctxt_all_defns (lval_to_referent cx id)
+;;
+
+let referent_is_slot (cx:ctxt) (id:node_id) : bool =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_slot _ -> true
+ | _ -> false
+;;
+
+let referent_is_item (cx:ctxt) (id:node_id) : bool =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_item _ -> true
+ | _ -> false
+;;
+
+(* coerce an lval definition id to a slot *)
+let referent_to_slot (cx:ctxt) (id:node_id) : Ast.slot =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_slot slot -> slot
+ | _ -> bugi cx id "unknown slot"
+;;
+
+(* coerce an lval reference id to its definition slot *)
+let lval_to_slot (cx:ctxt) (id:node_id) : Ast.slot =
+ match resolve_lval_id cx id with
+ DEFN_slot slot -> slot
+ | _ -> bugi cx id "unknown slot"
+;;
+
+let get_stmt_depth (cx:ctxt) (id:node_id) : int =
+ Hashtbl.find cx.ctxt_stmt_loop_depths id
+;;
+
+let get_slot_depth (cx:ctxt) (id:node_id) : int =
+ Hashtbl.find cx.ctxt_slot_loop_depths id
+;;
+
+let get_fn_fixup (cx:ctxt) (id:node_id) : fixup =
+ if Hashtbl.mem cx.ctxt_fn_fixups id
+ then Hashtbl.find cx.ctxt_fn_fixups id
+ else bugi cx id "fn without fixup"
+;;
+
+let get_framesz (cx:ctxt) (id:node_id) : size =
+ if Hashtbl.mem cx.ctxt_frame_sizes id
+ then Hashtbl.find cx.ctxt_frame_sizes id
+ else bugi cx id "missing framesz"
+;;
+
+let get_callsz (cx:ctxt) (id:node_id) : size =
+ if Hashtbl.mem cx.ctxt_call_sizes id
+ then Hashtbl.find cx.ctxt_call_sizes id
+ else bugi cx id "missing callsz"
+;;
+
+let rec n_item_ty_params (cx:ctxt) (id:node_id) : int =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_item i -> Array.length i.Ast.decl_params
+ | DEFN_obj_fn (oid,_) -> n_item_ty_params cx oid
+ | DEFN_obj_drop oid -> n_item_ty_params cx oid
+ | DEFN_loop_body fid -> n_item_ty_params cx fid
+ | _ -> bugi cx id "n_item_ty_params on non-item"
+;;
+
+let item_is_obj_fn (cx:ctxt) (id:node_id) : bool =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_obj_fn _
+ | DEFN_obj_drop _ -> true
+ | _ -> false
+;;
+
+let get_spill (cx:ctxt) (id:node_id) : fixup =
+ if Hashtbl.mem cx.ctxt_spill_fixups id
+ then Hashtbl.find cx.ctxt_spill_fixups id
+ else bugi cx id "missing spill fixup"
+;;
+
+let require_native (cx:ctxt) (lib:required_lib) (name:string) : fixup =
+ let lib_tab = (htab_search_or_add cx.ctxt_native_required lib
+ (fun _ -> Hashtbl.create 0))
+ in
+ htab_search_or_add lib_tab name
+ (fun _ -> new_fixup ("require: " ^ name))
+;;
+
+let provide_native (cx:ctxt) (seg:segment) (name:string) : fixup =
+ let seg_tab = (htab_search_or_add cx.ctxt_native_provided seg
+ (fun _ -> Hashtbl.create 0))
+ in
+ htab_search_or_add seg_tab name
+ (fun _ -> new_fixup ("provide: " ^ name))
+;;
+
+let provide_existing_native
+ (cx:ctxt)
+ (seg:segment)
+ (name:string)
+ (fix:fixup)
+ : unit =
+ let seg_tab = (htab_search_or_add cx.ctxt_native_provided seg
+ (fun _ -> Hashtbl.create 0))
+ in
+ htab_put seg_tab name fix
+;;
+
+let slot_ty (s:Ast.slot) : Ast.ty =
+ match s.Ast.slot_ty with
+ Some t -> t
+ | None -> bug () "untyped slot"
+;;
+
+let defn_is_slot (d:defn) : bool =
+ match d with
+ DEFN_slot _ -> true
+ | _ -> false
+;;
+
+let defn_is_item (d:defn) : bool =
+ match d with
+ DEFN_item _ -> true
+ | _ -> false
+;;
+
+let slot_is_obj_state (cx:ctxt) (sid:node_id) : bool =
+ Hashtbl.mem cx.ctxt_slot_is_obj_state sid
+;;
+
+
+(* determines whether d defines a statically-known value *)
+let defn_is_static (d:defn) : bool =
+ not (defn_is_slot d)
+;;
+
+let defn_is_callable (d:defn) : bool =
+ match d with
+ DEFN_slot { Ast.slot_ty = Some Ast.TY_fn _ }
+ | DEFN_item { Ast.decl_item = (Ast.MOD_ITEM_fn _ ) } -> true
+ | _ -> false
+;;
+
+(* Constraint manipulation. *)
+
+let rec apply_names_to_carg_path
+ (names:(Ast.name_base option) array)
+ (cp:Ast.carg_path)
+ : Ast.carg_path =
+ match cp with
+ Ast.CARG_ext (Ast.CARG_base Ast.BASE_formal,
+ Ast.COMP_idx i) ->
+ begin
+ match names.(i) with
+ Some nb ->
+ Ast.CARG_base (Ast.BASE_named nb)
+ | None -> bug () "Indexing off non-named carg"
+ end
+ | Ast.CARG_ext (cp', e) ->
+ Ast.CARG_ext (apply_names_to_carg_path names cp', e)
+ | _ -> cp
+;;
+
+let apply_names_to_carg
+ (names:(Ast.name_base option) array)
+ (carg:Ast.carg)
+ : Ast.carg =
+ match carg with
+ Ast.CARG_path cp ->
+ Ast.CARG_path (apply_names_to_carg_path names cp)
+ | Ast.CARG_lit _ -> carg
+;;
+
+let apply_names_to_constr
+ (names:(Ast.name_base option) array)
+ (constr:Ast.constr)
+ : Ast.constr =
+ { constr with
+ Ast.constr_args =
+ Array.map (apply_names_to_carg names) constr.Ast.constr_args }
+;;
+
+let atoms_to_names (atoms:Ast.atom array)
+ : (Ast.name_base option) array =
+ Array.map
+ begin
+ fun atom ->
+ match atom with
+ Ast.ATOM_lval (Ast.LVAL_base nbi) -> Some nbi.node
+ | _ -> None
+ end
+ atoms
+;;
+
+let rec lval_base_id (lv:Ast.lval) : node_id =
+ match lv with
+ Ast.LVAL_base nbi -> nbi.id
+ | Ast.LVAL_ext (lv, _) -> lval_base_id lv
+;;
+
+let rec lval_base_slot (cx:ctxt) (lv:Ast.lval) : node_id option =
+ match lv with
+ Ast.LVAL_base nbi ->
+ let referent = lval_to_referent cx nbi.id in
+ if referent_is_slot cx referent
+ then Some referent
+ else None
+ | Ast.LVAL_ext (lv, _) -> lval_base_slot cx lv
+;;
+
+let rec lval_slots (cx:ctxt) (lv:Ast.lval) : node_id array =
+ match lv with
+ Ast.LVAL_base nbi ->
+ let referent = lval_to_referent cx nbi.id in
+ if referent_is_slot cx referent
+ then [| referent |]
+ else [| |]
+ | Ast.LVAL_ext (lv, Ast.COMP_named _) -> lval_slots cx lv
+ | Ast.LVAL_ext (lv, Ast.COMP_atom a) ->
+ Array.append (lval_slots cx lv) (atom_slots cx a)
+
+and atom_slots (cx:ctxt) (a:Ast.atom) : node_id array =
+ match a with
+ Ast.ATOM_literal _ -> [| |]
+ | Ast.ATOM_lval lv -> lval_slots cx lv
+;;
+
+let lval_option_slots (cx:ctxt) (lv:Ast.lval option) : node_id array =
+ match lv with
+ None -> [| |]
+ | Some lv -> lval_slots cx lv
+;;
+
+let resolve_lval (cx:ctxt) (lv:Ast.lval) : defn =
+ resolve_lval_id cx (lval_base_id lv)
+;;
+
+let atoms_slots (cx:ctxt) (az:Ast.atom array) : node_id array =
+ Array.concat (List.map (atom_slots cx) (Array.to_list az))
+;;
+
+let tup_inputs_slots (cx:ctxt) (az:Ast.tup_input array) : node_id array =
+ Array.concat (List.map
+ (fun (_,_,a) -> atom_slots cx a)
+ (Array.to_list az))
+;;
+
+let rec_inputs_slots (cx:ctxt)
+ (inputs:Ast.rec_input array) : node_id array =
+ Array.concat (List.map
+ (fun (_, _, _, atom) -> atom_slots cx atom)
+ (Array.to_list inputs))
+;;
+
+let expr_slots (cx:ctxt) (e:Ast.expr) : node_id array =
+ match e with
+ Ast.EXPR_binary (_, a, b) ->
+ Array.append (atom_slots cx a) (atom_slots cx b)
+ | Ast.EXPR_unary (_, u) -> atom_slots cx u
+ | Ast.EXPR_atom a -> atom_slots cx a
+;;
+
+
+(* Type extraction. *)
+
+let interior_slot_full mut ty : Ast.slot =
+ { Ast.slot_mode = Ast.MODE_interior;
+ Ast.slot_mutable = mut;
+ Ast.slot_ty = Some ty }
+;;
+
+let exterior_slot_full mut ty : Ast.slot =
+ { Ast.slot_mode = Ast.MODE_exterior;
+ Ast.slot_mutable = mut;
+ Ast.slot_ty = Some ty }
+;;
+
+let interior_slot ty : Ast.slot = interior_slot_full false ty
+;;
+
+let exterior_slot ty : Ast.slot = exterior_slot_full false ty
+;;
+
+
+(* General folds of Ast.ty. *)
+
+type ('ty, 'slot, 'slots, 'tag) ty_fold =
+ {
+ (* Functions that correspond to interior nodes in Ast.ty. *)
+ ty_fold_slot : (Ast.mode * bool * 'ty) -> 'slot;
+ ty_fold_slots : ('slot array) -> 'slots;
+ ty_fold_tags : (Ast.name, 'slots) Hashtbl.t -> 'tag;
+
+ (* Functions that correspond to the Ast.ty constructors. *)
+ ty_fold_any: unit -> 'ty;
+ ty_fold_nil : unit -> 'ty;
+ ty_fold_bool : unit -> 'ty;
+ ty_fold_mach : ty_mach -> 'ty;
+ ty_fold_int : unit -> 'ty;
+ ty_fold_uint : unit -> 'ty;
+ ty_fold_char : unit -> 'ty;
+ ty_fold_str : unit -> 'ty;
+ ty_fold_tup : 'slots -> 'ty;
+ ty_fold_vec : 'slot -> 'ty;
+ ty_fold_rec : (Ast.ident * 'slot) array -> 'ty;
+ ty_fold_tag : 'tag -> 'ty;
+ ty_fold_iso : (int * 'tag array) -> 'ty;
+ ty_fold_idx : int -> 'ty;
+ ty_fold_fn : (('slots * Ast.constrs * 'slot) * Ast.ty_fn_aux) -> 'ty;
+ ty_fold_obj : (Ast.effect
+ * (Ast.ident, (('slots * Ast.constrs * 'slot) *
+ Ast.ty_fn_aux)) Hashtbl.t) -> 'ty;
+ ty_fold_chan : 'ty -> 'ty;
+ ty_fold_port : 'ty -> 'ty;
+ ty_fold_task : unit -> 'ty;
+ ty_fold_native : opaque_id -> 'ty;
+ ty_fold_param : (int * Ast.effect) -> 'ty;
+ ty_fold_named : Ast.name -> 'ty;
+ ty_fold_type : unit -> 'ty;
+ ty_fold_constrained : ('ty * Ast.constrs) -> 'ty }
+;;
+
+let rec fold_ty (f:('ty, 'slot, 'slots, 'tag) ty_fold) (ty:Ast.ty) : 'ty =
+ let fold_slot (s:Ast.slot) : 'slot =
+ f.ty_fold_slot (s.Ast.slot_mode,
+ s.Ast.slot_mutable,
+ fold_ty f (slot_ty s))
+ in
+ let fold_slots (slots:Ast.slot array) : 'slots =
+ f.ty_fold_slots (Array.map fold_slot slots)
+ in
+ let fold_tags (ttag:Ast.ty_tag) : 'tag =
+ f.ty_fold_tags (htab_map ttag (fun k v -> (k, fold_slots v)))
+ in
+ let fold_sig tsig =
+ (fold_slots tsig.Ast.sig_input_slots,
+ tsig.Ast.sig_input_constrs,
+ fold_slot tsig.Ast.sig_output_slot)
+ in
+ let fold_obj fns =
+ htab_map fns (fun i (tsig, taux) -> (i, (fold_sig tsig, taux)))
+ in
+ match ty with
+ Ast.TY_any -> f.ty_fold_any ()
+ | Ast.TY_nil -> f.ty_fold_nil ()
+ | Ast.TY_bool -> f.ty_fold_bool ()
+ | Ast.TY_mach m -> f.ty_fold_mach m
+ | Ast.TY_int -> f.ty_fold_int ()
+ | Ast.TY_uint -> f.ty_fold_uint ()
+ | Ast.TY_char -> f.ty_fold_char ()
+ | Ast.TY_str -> f.ty_fold_str ()
+
+ | Ast.TY_tup t -> f.ty_fold_tup (fold_slots t)
+ | Ast.TY_vec s -> f.ty_fold_vec (fold_slot s)
+ | Ast.TY_rec r -> f.ty_fold_rec (Array.map (fun (k,v) -> (k,fold_slot v)) r)
+
+ | Ast.TY_tag tt -> f.ty_fold_tag (fold_tags tt)
+ | Ast.TY_iso ti -> f.ty_fold_iso (ti.Ast.iso_index,
+ (Array.map fold_tags ti.Ast.iso_group))
+ | Ast.TY_idx i -> f.ty_fold_idx i
+
+ | Ast.TY_fn (tsig,taux) -> f.ty_fold_fn (fold_sig tsig, taux)
+ | Ast.TY_chan t -> f.ty_fold_chan (fold_ty f t)
+ | Ast.TY_port t -> f.ty_fold_port (fold_ty f t)
+
+ | Ast.TY_obj (eff,t) -> f.ty_fold_obj (eff, (fold_obj t))
+ | Ast.TY_task -> f.ty_fold_task ()
+
+ | Ast.TY_native x -> f.ty_fold_native x
+ | Ast.TY_param x -> f.ty_fold_param x
+ | Ast.TY_named n -> f.ty_fold_named n
+ | Ast.TY_type -> f.ty_fold_type ()
+
+ | Ast.TY_constrained (t, constrs) ->
+ f.ty_fold_constrained (fold_ty f t, constrs)
+
+;;
+
+type 'a simple_ty_fold = ('a, 'a, 'a, 'a) ty_fold
+;;
+
+let ty_fold_default (default:'a) : 'a simple_ty_fold =
+ { ty_fold_slot = (fun _ -> default);
+ ty_fold_slots = (fun _ -> default);
+ ty_fold_tags = (fun _ -> default);
+ ty_fold_any = (fun _ -> default);
+ ty_fold_nil = (fun _ -> default);
+ ty_fold_bool = (fun _ -> default);
+ ty_fold_mach = (fun _ -> default);
+ ty_fold_int = (fun _ -> default);
+ ty_fold_uint = (fun _ -> default);
+ ty_fold_char = (fun _ -> default);
+ ty_fold_str = (fun _ -> default);
+ ty_fold_tup = (fun _ -> default);
+ ty_fold_vec = (fun _ -> default);
+ ty_fold_rec = (fun _ -> default);
+ ty_fold_tag = (fun _ -> default);
+ ty_fold_iso = (fun _ -> default);
+ ty_fold_idx = (fun _ -> default);
+ ty_fold_fn = (fun _ -> default);
+ ty_fold_obj = (fun _ -> default);
+ ty_fold_chan = (fun _ -> default);
+ ty_fold_port = (fun _ -> default);
+ ty_fold_task = (fun _ -> default);
+ ty_fold_native = (fun _ -> default);
+ ty_fold_param = (fun _ -> default);
+ ty_fold_named = (fun _ -> default);
+ ty_fold_type = (fun _ -> default);
+ ty_fold_constrained = (fun _ -> default) }
+;;
+
+let ty_fold_rebuild (id:Ast.ty -> Ast.ty)
+ : (Ast.ty, Ast.slot, Ast.slot array, Ast.ty_tag) ty_fold =
+ let rebuild_fn ((islots, constrs, oslot), aux) =
+ ({ Ast.sig_input_slots = islots;
+ Ast.sig_input_constrs = constrs;
+ Ast.sig_output_slot = oslot }, aux)
+ in
+ { ty_fold_slot = (fun (mode, mut, t) ->
+ { Ast.slot_mode = mode;
+ Ast.slot_mutable = mut;
+ Ast.slot_ty = Some t });
+ ty_fold_slots = (fun slots -> slots);
+ ty_fold_tags = (fun htab -> htab);
+ ty_fold_any = (fun _ -> id Ast.TY_any);
+ ty_fold_nil = (fun _ -> id Ast.TY_nil);
+ ty_fold_bool = (fun _ -> id Ast.TY_bool);
+ ty_fold_mach = (fun m -> id (Ast.TY_mach m));
+ ty_fold_int = (fun _ -> id Ast.TY_int);
+ ty_fold_uint = (fun _ -> id Ast.TY_uint);
+ ty_fold_char = (fun _ -> id Ast.TY_char);
+ ty_fold_str = (fun _ -> id Ast.TY_str);
+ ty_fold_tup = (fun slots -> id (Ast.TY_tup slots));
+ ty_fold_vec = (fun slot -> id (Ast.TY_vec slot));
+ ty_fold_rec = (fun entries -> id (Ast.TY_rec entries));
+ ty_fold_tag = (fun tag -> id (Ast.TY_tag tag));
+ ty_fold_iso = (fun (i, tags) -> id (Ast.TY_iso { Ast.iso_index = i;
+ Ast.iso_group = tags }));
+ ty_fold_idx = (fun i -> id (Ast.TY_idx i));
+ ty_fold_fn = (fun t -> id (Ast.TY_fn (rebuild_fn t)));
+ ty_fold_obj = (fun (eff,fns) ->
+ id (Ast.TY_obj
+ (eff, (htab_map fns
+ (fun id fn -> (id, rebuild_fn fn))))));
+ ty_fold_chan = (fun t -> id (Ast.TY_chan t));
+ ty_fold_port = (fun t -> id (Ast.TY_port t));
+ ty_fold_task = (fun _ -> id Ast.TY_task);
+ ty_fold_native = (fun oid -> id (Ast.TY_native oid));
+ ty_fold_param = (fun (i, mut) -> id (Ast.TY_param (i, mut)));
+ ty_fold_named = (fun n -> id (Ast.TY_named n));
+ ty_fold_type = (fun _ -> id (Ast.TY_type));
+ ty_fold_constrained = (fun (t, constrs) ->
+ id (Ast.TY_constrained (t, constrs))) }
+;;
+
+let rebuild_ty_under_params
+ (ty:Ast.ty)
+ (params:Ast.ty_param array)
+ (args:Ast.ty array)
+ (resolve_names:bool)
+ : Ast.ty =
+ if (Array.length params) <> (Array.length args)
+ then err None "mismatched type-params"
+ else
+ let nmap = Hashtbl.create (Array.length args) in
+ let pmap = Hashtbl.create (Array.length args) in
+ let _ =
+ Array.iteri
+ begin
+ fun i (ident, param) ->
+ htab_put pmap (Ast.TY_param param) args.(i);
+ if resolve_names
+ then
+ htab_put nmap ident args.(i)
+ end
+ params
+ in
+ let substituted = ref false in
+ let rec rebuild_ty t =
+ let base = ty_fold_rebuild (fun t -> t) in
+ let ty_fold_param (i, mut) =
+ let param = Ast.TY_param (i, mut) in
+ match htab_search pmap param with
+ None -> param
+ | Some arg -> (substituted := true; arg)
+ in
+ let ty_fold_named n =
+ let rec rebuild_name n =
+ match n with
+ Ast.NAME_base nb ->
+ Ast.NAME_base (rebuild_name_base nb)
+ | Ast.NAME_ext (n, nc) ->
+ Ast.NAME_ext (rebuild_name n,
+ rebuild_name_component nc)
+
+ and rebuild_name_base nb =
+ match nb with
+ Ast.BASE_ident i ->
+ Ast.BASE_ident i
+ | Ast.BASE_temp t ->
+ Ast.BASE_temp t
+ | Ast.BASE_app (i, tys) ->
+ Ast.BASE_app (i, rebuild_tys tys)
+
+ and rebuild_name_component nc =
+ match nc with
+ Ast.COMP_ident i ->
+ Ast.COMP_ident i
+ | Ast.COMP_app (i, tys) ->
+ Ast.COMP_app (i, rebuild_tys tys)
+ | Ast.COMP_idx i ->
+ Ast.COMP_idx i
+
+ and rebuild_tys tys =
+ Array.map (fun t -> rebuild_ty t) tys
+ in
+ let n = rebuild_name n in
+ match n with
+ Ast.NAME_base (Ast.BASE_ident id)
+ when resolve_names ->
+ begin
+ match htab_search nmap id with
+ None -> Ast.TY_named n
+ | Some arg -> (substituted := true; arg)
+ end
+ | _ -> Ast.TY_named n
+ in
+ let fold =
+ { base with
+ ty_fold_param = ty_fold_param;
+ ty_fold_named = ty_fold_named;
+ }
+ in
+ let t' = fold_ty fold t in
+ (*
+ * FIXME: "substituted" and "ty'" here are only required
+ * because the current type-equality-comparison code in Type
+ * uses <> and will judge some cases, such as rebuilt tags, as
+ * unequal simply due to the different hashtable order in the
+ * fold.
+ *)
+ if !substituted
+ then t'
+ else t
+ in
+ rebuild_ty ty
+;;
+
+let associative_binary_op_ty_fold
+ (default:'a)
+ (fn:'a -> 'a -> 'a)
+ : 'a simple_ty_fold =
+ let base = ty_fold_default default in
+ let reduce ls =
+ match ls with
+ [] -> default
+ | x::xs -> List.fold_left fn x xs
+ in
+ let reduce_fn ((islots, _, oslot), _) =
+ fn islots oslot
+ in
+ { base with
+ ty_fold_slots = (fun slots -> reduce (Array.to_list slots));
+ ty_fold_slot = (fun (_, _, a) -> a);
+ ty_fold_tags = (fun tab -> reduce (htab_vals tab));
+ ty_fold_tup = (fun a -> a);
+ ty_fold_vec = (fun a -> a);
+ ty_fold_rec = (fun sz ->
+ reduce (Array.to_list
+ (Array.map (fun (_, s) -> s) sz)));
+ ty_fold_tag = (fun a -> a);
+ ty_fold_iso = (fun (_,iso) -> reduce (Array.to_list iso));
+ ty_fold_fn = reduce_fn;
+ ty_fold_obj = (fun (_,fns) ->
+ reduce (List.map reduce_fn (htab_vals fns)));
+ ty_fold_chan = (fun a -> a);
+ ty_fold_port = (fun a -> a);
+ ty_fold_constrained = (fun (a, _) -> a) }
+
+let ty_fold_bool_and (default:bool) : bool simple_ty_fold =
+ associative_binary_op_ty_fold default (fun a b -> a & b)
+;;
+
+let ty_fold_bool_or (default:bool) : bool simple_ty_fold =
+ associative_binary_op_ty_fold default (fun a b -> a || b)
+;;
+
+let ty_fold_int_max (default:int) : int simple_ty_fold =
+ associative_binary_op_ty_fold default (fun a b -> max a b)
+;;
+
+let ty_fold_list_concat _ : ('a list) simple_ty_fold =
+ associative_binary_op_ty_fold [] (fun a b -> a @ b)
+;;
+
+let type_is_structured (t:Ast.ty) : bool =
+ let fold = ty_fold_bool_or false in
+ let fold = { fold with
+ ty_fold_tup = (fun _ -> true);
+ ty_fold_vec = (fun _ -> true);
+ ty_fold_rec = (fun _ -> true);
+ ty_fold_tag = (fun _ -> true);
+ ty_fold_iso = (fun _ -> true);
+ ty_fold_idx = (fun _ -> true);
+ ty_fold_fn = (fun _ -> true);
+ ty_fold_obj = (fun _ -> true) }
+ in
+ fold_ty fold t
+;;
+
+(* Effect analysis. *)
+let effect_le x y =
+ match (x,y) with
+ (Ast.UNSAFE, _) -> true
+ | (Ast.STATE, Ast.PURE) -> true
+ | (Ast.STATE, Ast.IO) -> true
+ | (Ast.STATE, Ast.STATE) -> true
+ | (Ast.IO, Ast.PURE) -> true
+ | (Ast.IO, Ast.IO) -> true
+ | (Ast.PURE, Ast.PURE) -> true
+ | _ -> false
+;;
+
+let lower_effect_of x y =
+ if effect_le x y then x else y
+;;
+
+let type_effect (t:Ast.ty) : Ast.effect =
+ let fold_slot ((*mode*)_, mut, eff) =
+ if mut
+ then lower_effect_of Ast.STATE eff
+ else eff
+ in
+ let fold = associative_binary_op_ty_fold Ast.PURE lower_effect_of in
+ let fold = { fold with ty_fold_slot = fold_slot } in
+ fold_ty fold t
+;;
+
+let type_has_state (t:Ast.ty) : bool =
+ effect_le (type_effect t) Ast.STATE
+;;
+
+
+(* Various type analyses. *)
+
+let is_prim_type (t:Ast.ty) : bool =
+ match t with
+ Ast.TY_int
+ | Ast.TY_uint
+ | Ast.TY_char
+ | Ast.TY_mach _
+ | Ast.TY_bool -> true
+ | _ -> false
+;;
+
+let type_contains_chan (t:Ast.ty) : bool =
+ let fold_chan _ = true in
+ let fold = ty_fold_bool_or false in
+ let fold = { fold with ty_fold_chan = fold_chan } in
+ fold_ty fold t
+;;
+
+
+let type_is_unsigned_2s_complement t =
+ match t with
+ Ast.TY_mach TY_u8
+ | Ast.TY_mach TY_u16
+ | Ast.TY_mach TY_u32
+ | Ast.TY_mach TY_u64
+ | Ast.TY_char
+ | Ast.TY_uint
+ | Ast.TY_bool -> true
+ | _ -> false
+;;
+
+
+let type_is_signed_2s_complement t =
+ match t with
+ Ast.TY_mach TY_i8
+ | Ast.TY_mach TY_i16
+ | Ast.TY_mach TY_i32
+ | Ast.TY_mach TY_i64
+ | Ast.TY_int -> true
+ | _ -> false
+;;
+
+
+let type_is_2s_complement t =
+ (type_is_unsigned_2s_complement t)
+ || (type_is_signed_2s_complement t)
+;;
+
+let n_used_type_params t =
+ let fold_param (i,_) = i+1 in
+ let fold = ty_fold_int_max 0 in
+ let fold = { fold with ty_fold_param = fold_param } in
+ fold_ty fold t
+;;
+
+
+
+let check_concrete params thing =
+ if Array.length params = 0
+ then thing
+ else bug () "unhandled parametric binding"
+;;
+
+
+let project_type_to_slot
+ (base_ty:Ast.ty)
+ (comp:Ast.lval_component)
+ : Ast.slot =
+ match (base_ty, comp) with
+ (Ast.TY_rec elts, Ast.COMP_named (Ast.COMP_ident id)) ->
+ begin
+ match atab_search elts id with
+ Some slot -> slot
+ | None -> err None "unknown record-member '%s'" id
+ end
+
+ | (Ast.TY_tup elts, Ast.COMP_named (Ast.COMP_idx i)) ->
+ if 0 <= i && i < (Array.length elts)
+ then elts.(i)
+ else err None "out-of-range tuple index %d" i
+
+ | (Ast.TY_vec slot, Ast.COMP_atom _) ->
+ slot
+
+ | (Ast.TY_str, Ast.COMP_atom _) ->
+ interior_slot (Ast.TY_mach TY_u8)
+
+ | (Ast.TY_obj (_, fns), Ast.COMP_named (Ast.COMP_ident id)) ->
+ interior_slot (Ast.TY_fn (Hashtbl.find fns id))
+
+ | (_,_) ->
+ bug ()
+ "unhandled form of lval-ext in Semant."
+ "project_slot: %a indexed by %a"
+ Ast.sprintf_ty base_ty Ast.sprintf_lval_component comp
+;;
+
+
+(* NB: this will fail if lval is not a slot. *)
+let rec lval_slot (cx:ctxt) (lval:Ast.lval) : Ast.slot =
+ match lval with
+ Ast.LVAL_base nb -> lval_to_slot cx nb.id
+ | Ast.LVAL_ext (base, comp) ->
+ let base_ty = slot_ty (lval_slot cx base) in
+ project_type_to_slot base_ty comp
+;;
+
+let exports_permit (view:Ast.mod_view) (ident:Ast.ident) : bool =
+ (Hashtbl.mem view.Ast.view_exports Ast.EXPORT_all_decls) ||
+ (Hashtbl.mem view.Ast.view_exports (Ast.EXPORT_ident ident))
+;;
+
+(* NB: this will fail if lval is not an item. *)
+let rec lval_item (cx:ctxt) (lval:Ast.lval) : Ast.mod_item =
+ match lval with
+ Ast.LVAL_base nb ->
+ begin
+ let referent = lval_to_referent cx nb.id in
+ match htab_search cx.ctxt_all_defns referent with
+ Some (DEFN_item item) -> {node=item; id=referent}
+ | _ -> err (Some (lval_base_id lval))
+ "lval does not name an item"
+ end
+ | Ast.LVAL_ext (base, comp) ->
+ let base_item = lval_item cx base in
+ match base_item.node.Ast.decl_item with
+ Ast.MOD_ITEM_mod (view, items) ->
+ begin
+ let i, args =
+ match comp with
+ Ast.COMP_named (Ast.COMP_ident i) -> (i, [||])
+ | Ast.COMP_named (Ast.COMP_app (i, args)) -> (i, args)
+ | _ ->
+ bug ()
+ "unhandled lval-component '%a' in Semant.lval_item"
+ Ast.sprintf_lval_component comp
+ in
+ match htab_search items i with
+ | Some sub when exports_permit view i ->
+ assert
+ ((Array.length sub.node.Ast.decl_params) =
+ (Array.length args));
+ check_concrete base_item.node.Ast.decl_params sub
+ | _ -> err (Some (lval_base_id lval))
+ "unknown module item '%s'" i
+ end
+ | _ -> err (Some (lval_base_id lval))
+ "lval base %a does not name a module" Ast.sprintf_lval base
+;;
+
+let lval_is_slot (cx:ctxt) (lval:Ast.lval) : bool =
+ match resolve_lval cx lval with
+ DEFN_slot _ -> true
+ | _ -> false
+;;
+
+let lval_is_item (cx:ctxt) (lval:Ast.lval) : bool =
+ match resolve_lval cx lval with
+ DEFN_item _ -> true
+ | _ -> false
+;;
+
+let lval_is_direct_fn (cx:ctxt) (lval:Ast.lval) : bool =
+ let defn = resolve_lval cx lval in
+ (defn_is_static defn) && (defn_is_callable defn)
+;;
+
+let lval_is_direct_mod (cx:ctxt) (lval:Ast.lval) : bool =
+ let defn = resolve_lval cx lval in
+ if not (defn_is_static defn)
+ then false
+ else
+ match defn with
+ DEFN_item { Ast.decl_item = Ast.MOD_ITEM_mod _ } -> true
+ | _ -> false
+;;
+
+let lval_is_static (cx:ctxt) (lval:Ast.lval) : bool =
+ defn_is_static (resolve_lval cx lval)
+;;
+
+let lval_is_callable (cx:ctxt) (lval:Ast.lval) : bool =
+ defn_is_callable (resolve_lval cx lval)
+;;
+
+let lval_is_obj_vtbl (cx:ctxt) (lval:Ast.lval) : bool =
+ if lval_is_slot cx lval
+ then
+ match lval with
+ Ast.LVAL_ext (base, _) ->
+ begin
+ match slot_ty (lval_slot cx base) with
+ Ast.TY_obj _ -> true
+ | _ -> false
+ end
+ | _ -> false
+ else false
+;;
+
+let rec lval_ty (cx:ctxt) (lval:Ast.lval) : Ast.ty =
+ let base_id = lval_base_id lval in
+ Hashtbl.find cx.ctxt_all_lval_types base_id
+;;
+
+let rec atom_type (cx:ctxt) (at:Ast.atom) : Ast.ty =
+ match at with
+ Ast.ATOM_literal {node=(Ast.LIT_int _); id=_} -> Ast.TY_int
+ | Ast.ATOM_literal {node=(Ast.LIT_uint _); id=_} -> Ast.TY_uint
+ | Ast.ATOM_literal {node=(Ast.LIT_bool _); id=_} -> Ast.TY_bool
+ | Ast.ATOM_literal {node=(Ast.LIT_char _); id=_} -> Ast.TY_char
+ | Ast.ATOM_literal {node=(Ast.LIT_nil); id=_} -> Ast.TY_nil
+ | Ast.ATOM_literal {node=(Ast.LIT_mach (m,_,_)); id=_} -> Ast.TY_mach m
+ | Ast.ATOM_lval lv -> lval_ty cx lv
+;;
+
+let expr_type (cx:ctxt) (e:Ast.expr) : Ast.ty =
+ match e with
+ Ast.EXPR_binary (op, a, _) ->
+ begin
+ match op with
+ Ast.BINOP_eq | Ast.BINOP_ne | Ast.BINOP_lt | Ast.BINOP_le
+ | Ast.BINOP_ge | Ast.BINOP_gt -> Ast.TY_bool
+ | _ -> atom_type cx a
+ end
+ | Ast.EXPR_unary (Ast.UNOP_not, _) -> Ast.TY_bool
+ | Ast.EXPR_unary (_, a) -> atom_type cx a
+ | Ast.EXPR_atom a -> atom_type cx a
+;;
+
+(* Mappings between mod items and their respective types. *)
+
+let arg_slots (slots:Ast.header_slots) : Ast.slot array =
+ Array.map (fun (sid,_) -> sid.node) slots
+;;
+
+let tup_slots (slots:Ast.header_tup) : Ast.slot array =
+ Array.map (fun sid -> sid.node) slots
+;;
+
+let ty_fn_of_fn (fn:Ast.fn) : Ast.ty_fn =
+ ({ Ast.sig_input_slots = arg_slots fn.Ast.fn_input_slots;
+ Ast.sig_input_constrs = fn.Ast.fn_input_constrs;
+ Ast.sig_output_slot = fn.Ast.fn_output_slot.node },
+ fn.Ast.fn_aux )
+;;
+
+let ty_obj_of_obj (obj:Ast.obj) : Ast.ty_obj =
+ (obj.Ast.obj_effect,
+ htab_map obj.Ast.obj_fns (fun i f -> (i, ty_fn_of_fn f.node)))
+;;
+
+let ty_of_mod_item ((*inside*)_:bool) (item:Ast.mod_item) : Ast.ty =
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_type _ -> Ast.TY_type
+ | Ast.MOD_ITEM_fn f -> (Ast.TY_fn (ty_fn_of_fn f))
+ | Ast.MOD_ITEM_mod _ -> bug () "Semant.ty_of_mod_item on mod"
+ | Ast.MOD_ITEM_obj ob ->
+ let taux = { Ast.fn_effect = Ast.PURE;
+ Ast.fn_is_iter = false }
+ in
+ let tobj = Ast.TY_obj (ty_obj_of_obj ob) in
+ let tsig = { Ast.sig_input_slots = arg_slots ob.Ast.obj_state;
+ Ast.sig_input_constrs = ob.Ast.obj_constrs;
+ Ast.sig_output_slot = interior_slot tobj }
+ in
+ (Ast.TY_fn (tsig, taux))
+
+ | Ast.MOD_ITEM_tag (htup, ttag, _) ->
+ let taux = { Ast.fn_effect = Ast.PURE;
+ Ast.fn_is_iter = false }
+ in
+ let tsig = { Ast.sig_input_slots = tup_slots htup;
+ Ast.sig_input_constrs = [| |];
+ Ast.sig_output_slot = interior_slot (Ast.TY_tag ttag) }
+ in
+ (Ast.TY_fn (tsig, taux))
+;;
+
+(* Scopes and the visitor that builds them. *)
+
+type scope =
+ SCOPE_block of node_id
+ | SCOPE_mod_item of Ast.mod_item
+ | SCOPE_obj_fn of (Ast.fn identified)
+ | SCOPE_crate of Ast.crate
+;;
+
+let id_of_scope (sco:scope) : node_id =
+ match sco with
+ SCOPE_block id -> id
+ | SCOPE_mod_item i -> i.id
+ | SCOPE_obj_fn f -> f.id
+ | SCOPE_crate c -> c.id
+;;
+
+let scope_stack_managing_visitor
+ (scopes:(scope list) ref)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ let push s =
+ scopes := s :: (!scopes)
+ in
+ let pop _ =
+ scopes := List.tl (!scopes)
+ in
+ let visit_block_pre b =
+ push (SCOPE_block b.id);
+ inner.Walk.visit_block_pre b
+ in
+ let visit_block_post b =
+ inner.Walk.visit_block_post b;
+ pop();
+ in
+ let visit_mod_item_pre n p i =
+ push (SCOPE_mod_item i);
+ 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;
+ pop();
+ in
+ let visit_obj_fn_pre obj ident fn =
+ push (SCOPE_obj_fn fn);
+ 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;
+ pop();
+ in
+ let visit_crate_pre c =
+ push (SCOPE_crate c);
+ inner.Walk.visit_crate_pre c
+ in
+ let visit_crate_post c =
+ inner.Walk.visit_crate_post c;
+ pop()
+ in
+ { inner with
+ Walk.visit_block_pre = visit_block_pre;
+ Walk.visit_block_post = visit_block_post;
+ 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_crate_pre = visit_crate_pre;
+ Walk.visit_crate_post = visit_crate_post; }
+;;
+
+(* Generic lookup, used for slots, items, types, etc. *)
+
+type resolved = ((scope list * node_id) option) ;;
+
+let get_item (cx:ctxt) (node:node_id) : Ast.mod_item_decl =
+ match htab_search cx.ctxt_all_defns node with
+ Some (DEFN_item item) -> item
+ | Some _ -> err (Some node) "defn is not an item"
+ | None -> bug () "missing defn"
+;;
+
+let get_slot (cx:ctxt) (node:node_id) : Ast.slot =
+ match htab_search cx.ctxt_all_defns node with
+ Some (DEFN_slot slot) -> slot
+ | Some _ -> err (Some node) "defn is not a slot"
+ | None -> bug () "missing defn"
+;;
+
+let get_mod_item
+ (cx:ctxt)
+ (node:node_id)
+ : (Ast.mod_view * Ast.mod_items) =
+ match get_item cx node with
+ { Ast.decl_item = Ast.MOD_ITEM_mod md } -> md
+ | _ -> err (Some node) "defn is not a mod"
+;;
+
+let get_name_comp_ident
+ (comp:Ast.name_component)
+ : Ast.ident =
+ match comp with
+ Ast.COMP_ident i -> i
+ | Ast.COMP_app (i, _) -> i
+ | Ast.COMP_idx i -> string_of_int i
+;;
+
+let get_name_base_ident
+ (comp:Ast.name_base)
+ : Ast.ident =
+ match comp with
+ Ast.BASE_ident i -> i
+ | Ast.BASE_app (i, _) -> i
+ | Ast.BASE_temp _ ->
+ bug () "get_name_base_ident on BASE_temp"
+;;
+
+let rec project_ident_from_items
+ (cx:ctxt)
+ (scopes:scope list)
+ ((view:Ast.mod_view),(items:Ast.mod_items))
+ (ident:Ast.ident)
+ (inside:bool)
+ : resolved =
+ if not (inside || (exports_permit view ident))
+ then None
+ else
+ match htab_search items ident with
+ Some i -> Some (scopes, i.id)
+ | None ->
+ match htab_search view.Ast.view_imports ident with
+ None -> None
+ | Some name -> lookup_by_name cx scopes name
+
+and project_name_comp_from_resolved
+ (cx:ctxt)
+ (mod_res:resolved)
+ (ext:Ast.name_component)
+ : resolved =
+ match mod_res with
+ None -> None
+ | Some (scopes, id) ->
+ let scope = (SCOPE_mod_item {id=id; node=get_item cx id}) in
+ let scopes = scope :: scopes in
+ let ident = get_name_comp_ident ext in
+ let md = get_mod_item cx id in
+ project_ident_from_items cx scopes md ident false
+
+and lookup_by_name
+ (cx:ctxt)
+ (scopes:scope list)
+ (name:Ast.name)
+ : resolved =
+ assert (Ast.sane_name name);
+ match name with
+ Ast.NAME_base nb ->
+ let ident = get_name_base_ident nb in
+ lookup_by_ident cx scopes ident
+ | Ast.NAME_ext (name, ext) ->
+ let base_res = lookup_by_name cx scopes name in
+ project_name_comp_from_resolved cx base_res ext
+
+and lookup_by_ident
+ (cx:ctxt)
+ (scopes:scope list)
+ (ident:Ast.ident)
+ : resolved =
+ let check_slots scopes islots =
+ arr_search islots
+ (fun _ (sloti,ident') ->
+ if ident = ident'
+ then Some (scopes, sloti.id)
+ else None)
+ in
+ let check_params scopes params =
+ arr_search params
+ (fun _ {node=(i,_); id=id} ->
+ if i = ident then Some (scopes, id) else None)
+ in
+ let passed_capture_scope = ref false in
+ let would_capture r =
+ match r with
+ None -> None
+ | Some _ ->
+ if !passed_capture_scope
+ then err None "attempted dynamic environment-capture"
+ else r
+ in
+ let check_scope scopes scope =
+ match scope with
+ SCOPE_block block_id ->
+ let block_slots = Hashtbl.find cx.ctxt_block_slots block_id in
+ let block_items = Hashtbl.find cx.ctxt_block_items block_id in
+ begin
+ match htab_search block_slots (Ast.KEY_ident ident) with
+ Some id -> would_capture (Some (scopes, id))
+ | None ->
+ match htab_search block_items ident with
+ Some id -> Some (scopes, id)
+ | None -> None
+ end
+
+ | SCOPE_crate crate ->
+ project_ident_from_items
+ cx scopes crate.node.Ast.crate_items ident true
+
+ | SCOPE_obj_fn fn ->
+ would_capture (check_slots scopes fn.node.Ast.fn_input_slots)
+
+ | SCOPE_mod_item item ->
+ begin
+ let item_match =
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f ->
+ check_slots scopes f.Ast.fn_input_slots
+
+ | Ast.MOD_ITEM_obj obj ->
+ begin
+ match htab_search obj.Ast.obj_fns ident with
+ Some fn -> Some (scopes, fn.id)
+ | None -> check_slots scopes obj.Ast.obj_state
+ end
+
+ | Ast.MOD_ITEM_mod md ->
+ project_ident_from_items cx scopes md ident true
+
+ | _ -> None
+ in
+ match item_match with
+ Some _ -> item_match
+ | None ->
+ would_capture
+ (check_params scopes item.node.Ast.decl_params)
+ end
+ in
+ let rec search scopes =
+ match scopes with
+ [] -> None
+ | scope::rest ->
+ match check_scope scopes scope with
+ None ->
+ begin
+ let is_ty_item i =
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_type _ -> true
+ | _ -> false
+ in
+ match scope with
+ SCOPE_block _
+ | SCOPE_obj_fn _ ->
+ search rest
+
+ | SCOPE_mod_item item when is_ty_item item ->
+ search rest
+
+ | _ ->
+ passed_capture_scope := true;
+ search rest
+ end
+ | x -> x
+ in
+ search scopes
+;;
+
+let lookup_by_temp
+ (cx:ctxt)
+ (scopes:scope list)
+ (temp:temp_id)
+ : ((scope list * node_id) option) =
+ let passed_item_scope = ref false in
+ let check_scope scope =
+ if !passed_item_scope
+ then None
+ else
+ match scope with
+ SCOPE_block block_id ->
+ let block_slots = Hashtbl.find cx.ctxt_block_slots block_id in
+ htab_search block_slots (Ast.KEY_temp temp)
+ | _ ->
+ passed_item_scope := true;
+ None
+ in
+ list_search_ctxt scopes check_scope
+;;
+
+let lookup
+ (cx:ctxt)
+ (scopes:scope list)
+ (key:Ast.slot_key)
+ : ((scope list * node_id) option) =
+ match key with
+ Ast.KEY_temp temp -> lookup_by_temp cx scopes temp
+ | Ast.KEY_ident ident -> lookup_by_ident cx scopes ident
+;;
+
+
+let run_passes
+ (cx:ctxt)
+ (name:string)
+ (path:Ast.name_component Stack.t)
+ (passes:Walk.visitor array)
+ (log:string->unit)
+ (crate:Ast.crate)
+ : unit =
+ let do_pass i pass =
+ let logger s = log (Printf.sprintf "pass %d: %s" i s) in
+ Walk.walk_crate
+ (Walk.path_managing_visitor path
+ (Walk.mod_item_logging_visitor logger path pass))
+ crate
+ in
+ let sess = cx.ctxt_sess in
+ if sess.Session.sess_failed
+ then ()
+ else
+ try
+ Session.time_inner name sess
+ (fun _ -> Array.iteri do_pass passes)
+ with
+ Semant_err (ido, str) -> report_err cx ido str
+;;
+
+(* Rust type -> IL type conversion. *)
+
+let word_sty (abi:Abi.abi) : Il.scalar_ty =
+ Il.ValTy abi.Abi.abi_word_bits
+;;
+
+let word_rty (abi:Abi.abi) : Il.referent_ty =
+ Il.ScalarTy (word_sty abi)
+;;
+
+let tydesc_rty (abi:Abi.abi) : Il.referent_ty =
+ (*
+ * NB: must match corresponding tydesc structure
+ * in trans and offsets in ABI exactly.
+ *)
+ Il.StructTy
+ [|
+ word_rty abi; (* Abi.tydesc_field_first_param *)
+ word_rty abi; (* Abi.tydesc_field_size *)
+ word_rty abi; (* Abi.tydesc_field_align *)
+ Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_copy_glue *)
+ Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_drop_glue *)
+ Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_free_glue *)
+ Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_mark_glue *)
+ Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_obj_drop_glue *)
+ |]
+;;
+
+let obj_closure_rty (abi:Abi.abi) : Il.referent_ty =
+ Il.StructTy [| word_rty abi;
+ Il.ScalarTy (Il.AddrTy (tydesc_rty abi));
+ word_rty abi (* A lie: it's opaque, but this permits
+ * GEP'ing to it. *)
+ |]
+;;
+
+let rec referent_type (abi:Abi.abi) (t:Ast.ty) : Il.referent_ty =
+ let s t = Il.ScalarTy t in
+ let v b = Il.ValTy b in
+ let p t = Il.AddrTy t in
+ let sv b = s (v b) in
+ let sp t = s (p t) in
+
+ let word = word_rty abi in
+ let ptr = sp Il.OpaqueTy in
+ let rc_ptr = sp (Il.StructTy [| word; Il.OpaqueTy |]) in
+ let codeptr = sp Il.CodeTy in
+ let tup ttup = Il.StructTy (Array.map (slot_referent_type abi) ttup) in
+ let tag ttag =
+ let union =
+ Il.UnionTy
+ (Array.map
+ (fun key -> tup (Hashtbl.find ttag key))
+ (sorted_htab_keys ttag))
+ in
+ let discriminant = word in
+ Il.StructTy [| discriminant; union |]
+ in
+
+ match t with
+ Ast.TY_any -> Il.StructTy [| word; ptr |]
+ | Ast.TY_nil -> Il.NilTy
+ | Ast.TY_int
+ | Ast.TY_uint -> word
+
+ | Ast.TY_bool -> sv Il.Bits8
+
+ | Ast.TY_mach (TY_u8)
+ | Ast.TY_mach (TY_i8) -> sv Il.Bits8
+
+ | Ast.TY_mach (TY_u16)
+ | Ast.TY_mach (TY_i16) -> sv Il.Bits16
+
+ | Ast.TY_mach (TY_u32)
+ | Ast.TY_mach (TY_i32)
+ | Ast.TY_mach (TY_f32)
+ | Ast.TY_char -> sv Il.Bits32
+
+ | Ast.TY_mach (TY_u64)
+ | Ast.TY_mach (TY_i64)
+ | Ast.TY_mach (TY_f64) -> sv Il.Bits64
+
+ | Ast.TY_str -> sp (Il.StructTy [| word; word; word; ptr |])
+ | Ast.TY_vec _ -> sp (Il.StructTy [| word; word; word; ptr |])
+ | Ast.TY_tup tt -> tup tt
+ | Ast.TY_rec tr -> tup (Array.map snd tr)
+
+ | Ast.TY_fn _ ->
+ let fn_closure_ptr = sp (Il.StructTy [| word; Il.OpaqueTy |]) in
+ Il.StructTy [| codeptr; fn_closure_ptr |]
+
+ | Ast.TY_obj _ ->
+ let obj_closure_ptr = sp (obj_closure_rty abi) in
+ Il.StructTy [| ptr; obj_closure_ptr |]
+
+ | Ast.TY_tag ttag -> tag ttag
+ | Ast.TY_iso tiso -> tag tiso.Ast.iso_group.(tiso.Ast.iso_index)
+
+ | Ast.TY_idx _ -> word (* A lie, but permits GEP'ing to it. *)
+
+ | Ast.TY_chan _
+ | Ast.TY_port _
+ | Ast.TY_task -> rc_ptr
+
+ | Ast.TY_type -> sp (tydesc_rty abi)
+
+ | Ast.TY_native _ -> ptr
+
+ | Ast.TY_param (i, _) -> Il.ParamTy i
+
+ | Ast.TY_named _ -> bug () "named type in referent_type"
+ | Ast.TY_constrained (t, _) -> referent_type abi t
+
+and slot_referent_type (abi:Abi.abi) (sl:Ast.slot) : Il.referent_ty =
+ let s t = Il.ScalarTy t in
+ let v b = Il.ValTy b in
+ let p t = Il.AddrTy t in
+ let sv b = s (v b) in
+ let sp t = s (p t) in
+
+ let word = sv abi.Abi.abi_word_bits in
+
+ let rty = referent_type abi (slot_ty sl) in
+ match sl.Ast.slot_mode with
+ Ast.MODE_exterior _ -> sp (Il.StructTy [| word; rty |])
+ | Ast.MODE_interior _ -> rty
+ | Ast.MODE_alias _ -> sp rty
+;;
+
+let task_rty (abi:Abi.abi) : Il.referent_ty =
+ Il.StructTy
+ begin
+ Array.init
+ Abi.n_visible_task_fields
+ (fun _ -> word_rty abi)
+ end
+;;
+
+let call_args_referent_type_full
+ (abi:Abi.abi)
+ (out_slot:Ast.slot)
+ (n_ty_params:int)
+ (in_slots:Ast.slot array)
+ (iterator_arg_rtys:Il.referent_ty array)
+ (indirect_arg_rtys:Il.referent_ty array)
+ : Il.referent_ty =
+ let out_slot_rty = slot_referent_type abi out_slot in
+ let out_ptr_rty = Il.ScalarTy (Il.AddrTy out_slot_rty) in
+ let task_ptr_rty = Il.ScalarTy (Il.AddrTy (task_rty abi)) in
+ let ty_param_rtys =
+ let td = Il.ScalarTy (Il.AddrTy (tydesc_rty abi)) in
+ Il.StructTy (Array.init n_ty_params (fun _ -> td))
+ in
+ let arg_rtys = Il.StructTy (Array.map (slot_referent_type abi) in_slots) in
+ (*
+ * NB: must match corresponding calltup structure in trans and
+ * member indices in ABI exactly.
+ *)
+ Il.StructTy
+ [|
+ out_ptr_rty; (* Abi.calltup_elt_out_ptr *)
+ task_ptr_rty; (* Abi.calltup_elt_task_ptr *)
+ ty_param_rtys; (* Abi.calltup_elt_ty_params *)
+ arg_rtys; (* Abi.calltup_elt_args *)
+ Il.StructTy iterator_arg_rtys; (* Abi.calltup_elt_iterator_args *)
+ Il.StructTy indirect_arg_rtys (* Abi.calltup_elt_indirect_args *)
+ |]
+;;
+
+let call_args_referent_type
+ (cx:ctxt)
+ (n_ty_params:int)
+ (callee_ty:Ast.ty)
+ (closure:Il.referent_ty option)
+ : Il.referent_ty =
+ let indirect_arg_rtys =
+ match closure with
+ None -> [| |]
+ | Some c ->
+ [|
+ (* Abi.indirect_args_elt_closure *)
+ Il.ScalarTy (Il.AddrTy c)
+ |]
+ in
+ let iterator_arg_rtys _ =
+ [|
+ (* Abi.iterator_args_elt_loop_size *)
+ Il.ScalarTy (Il.ValTy cx.ctxt_abi.Abi.abi_word_bits);
+ (* Abi.iterator_args_elt_loop_info_ptr *)
+ Il.ScalarTy (Il.AddrTy Il.OpaqueTy)
+ |]
+ in
+ match callee_ty with
+ Ast.TY_fn (tsig, taux) ->
+ call_args_referent_type_full
+ cx.ctxt_abi
+ tsig.Ast.sig_output_slot
+ n_ty_params
+ tsig.Ast.sig_input_slots
+ (if taux.Ast.fn_is_iter then (iterator_arg_rtys()) else [||])
+ indirect_arg_rtys
+
+ | _ -> bug cx "Semant.call_args_referent_type on non-callable type"
+;;
+
+let indirect_call_args_referent_type
+ (cx:ctxt)
+ (n_ty_params:int)
+ (callee_ty:Ast.ty)
+ (closure:Il.referent_ty)
+ : Il.referent_ty =
+ call_args_referent_type cx n_ty_params callee_ty (Some closure)
+;;
+
+let direct_call_args_referent_type
+ (cx:ctxt)
+ (callee_node:node_id)
+ : Il.referent_ty =
+ let ity = Hashtbl.find cx.ctxt_all_item_types callee_node in
+ let n_ty_params =
+ if item_is_obj_fn cx callee_node
+ then 0
+ else n_item_ty_params cx callee_node
+ in
+ call_args_referent_type cx n_ty_params ity None
+;;
+
+let ty_sz (abi:Abi.abi) (t:Ast.ty) : int64 =
+ force_sz (Il.referent_ty_size abi.Abi.abi_word_bits (referent_type abi t))
+;;
+
+let ty_align (abi:Abi.abi) (t:Ast.ty) : int64 =
+ force_sz (Il.referent_ty_align abi.Abi.abi_word_bits (referent_type abi t))
+;;
+
+let slot_sz (abi:Abi.abi) (s:Ast.slot) : int64 =
+ force_sz (Il.referent_ty_size abi.Abi.abi_word_bits
+ (slot_referent_type abi s))
+;;
+
+let word_slot (abi:Abi.abi) : Ast.slot =
+ interior_slot (Ast.TY_mach abi.Abi.abi_word_ty)
+;;
+
+let read_alias_slot (ty:Ast.ty) : Ast.slot =
+ { Ast.slot_mode = Ast.MODE_alias;
+ Ast.slot_mutable = false;
+ Ast.slot_ty = Some ty }
+;;
+
+let word_write_alias_slot (abi:Abi.abi) : Ast.slot =
+ { Ast.slot_mode = Ast.MODE_alias;
+ Ast.slot_mutable = true;
+ Ast.slot_ty = Some (Ast.TY_mach abi.Abi.abi_word_ty) }
+;;
+
+let mk_ty_fn_or_iter
+ (out_slot:Ast.slot)
+ (arg_slots:Ast.slot array)
+ (is_iter:bool)
+ : Ast.ty =
+ (* In some cases we don't care what aux or constrs are. *)
+ let taux = { Ast.fn_effect = Ast.PURE;
+ Ast.fn_is_iter = is_iter; }
+ in
+ let tsig = { Ast.sig_input_slots = arg_slots;
+ Ast.sig_input_constrs = [| |];
+ Ast.sig_output_slot = out_slot; }
+ in
+ Ast.TY_fn (tsig, taux)
+;;
+
+let mk_ty_fn
+ (out_slot:Ast.slot)
+ (arg_slots:Ast.slot array)
+ : Ast.ty =
+ mk_ty_fn_or_iter out_slot arg_slots false
+;;
+
+let mk_simple_ty_fn
+ (arg_slots:Ast.slot array)
+ : Ast.ty =
+ (* In some cases we don't care what the output slot is. *)
+ let out_slot = interior_slot Ast.TY_nil in
+ mk_ty_fn out_slot arg_slots
+;;
+
+let mk_simple_ty_iter
+ (arg_slots:Ast.slot array)
+ : Ast.ty =
+ (* In some cases we don't care what the output slot is. *)
+ let out_slot = interior_slot Ast.TY_nil in
+ mk_ty_fn_or_iter out_slot arg_slots true
+;;
+
+
+(* name mangling support. *)
+
+let item_name (cx:ctxt) (id:node_id) : Ast.name =
+ Hashtbl.find cx.ctxt_all_item_names id
+;;
+
+let item_str (cx:ctxt) (id:node_id) : string =
+ string_of_name (item_name cx id)
+;;
+
+let ty_str (ty:Ast.ty) : string =
+ let base = associative_binary_op_ty_fold "" (fun a b -> a ^ b) in
+ let fold_slot (mode,mut,ty) =
+ (if mut then "m" else "")
+ ^ (match mode with
+ Ast.MODE_exterior -> "e"
+ | Ast.MODE_alias -> "a"
+ | Ast.MODE_interior -> "")
+ ^ ty
+ in
+ let num n = (string_of_int n) ^ "$" in
+ let len a = num (Array.length a) in
+ let join az = Array.fold_left (fun a b -> a ^ b) "" az in
+ let fold_slots slots =
+ "t"
+ ^ (len slots)
+ ^ (join slots)
+ in
+ let fold_rec entries =
+ "r"
+ ^ (len entries)
+ ^ (Array.fold_left
+ (fun str (ident, s) -> str ^ "$" ^ ident ^ "$" ^ s)
+ "" entries)
+ in
+ let fold_tags tags =
+ "g"
+ ^ (num (Hashtbl.length tags))
+ ^ (Array.fold_left
+ (fun str key -> str ^ (string_of_name key) ^ (Hashtbl.find tags key))
+ "" (sorted_htab_keys tags))
+ in
+ let fold_iso (n, tags) =
+ "G"
+ ^ (num n)
+ ^ (len tags)
+ ^ (join tags)
+ in
+ let fold_mach m =
+ match m with
+ TY_u8 -> "U0"
+ | TY_u16 -> "U1"
+ | TY_u32 -> "U2"
+ | TY_u64 -> "U3"
+ | TY_i8 -> "I0"
+ | TY_i16 -> "I1"
+ | TY_i32 -> "I2"
+ | TY_i64 -> "I3"
+ | TY_f32 -> "F2"
+ | TY_f64 -> "F3"
+ in
+ let fold =
+ { base with
+ (* Structural types. *)
+ ty_fold_slot = fold_slot;
+ ty_fold_slots = fold_slots;
+ ty_fold_tags = fold_tags;
+ ty_fold_rec = fold_rec;
+ ty_fold_nil = (fun _ -> "n");
+ ty_fold_bool = (fun _ -> "b");
+ ty_fold_mach = fold_mach;
+ ty_fold_int = (fun _ -> "i");
+ ty_fold_uint = (fun _ -> "u");
+ ty_fold_char = (fun _ -> "c");
+ ty_fold_obj = (fun _ -> "o");
+ ty_fold_str = (fun _ -> "s");
+ ty_fold_vec = (fun s -> "v" ^ s);
+ ty_fold_iso = fold_iso;
+ ty_fold_idx = (fun i -> "x" ^ (string_of_int i));
+ (* FIXME: encode constrs, aux as well. *)
+ ty_fold_fn = (fun ((ins,_,out),_) -> "f" ^ ins ^ out);
+
+ (* Built-in special types. *)
+ ty_fold_any = (fun _ -> "A");
+ ty_fold_chan = (fun t -> "H" ^ t);
+ ty_fold_port = (fun t -> "R" ^ t);
+ ty_fold_task = (fun _ -> "T");
+ ty_fold_native = (fun _ -> "N");
+ ty_fold_param = (fun _ -> "P");
+ ty_fold_type = (fun _ -> "Y");
+
+ (* FIXME: encode obj types. *)
+ (* FIXME: encode opaque and param numbers. *)
+ ty_fold_named = (fun _ -> bug () "string-encoding named type");
+ (* FIXME: encode constrs as well. *)
+ ty_fold_constrained = (fun (t,_)-> t) }
+ in
+ fold_ty fold ty
+;;
+
+let glue_str (cx:ctxt) (g:glue) : string =
+ match g with
+ GLUE_activate -> "glue$activate"
+ | GLUE_yield -> "glue$yield"
+ | GLUE_exit_main_task -> "glue$exit_main_task"
+ | GLUE_exit_task -> "glue$exit_task"
+ | GLUE_mark ty -> "glue$mark$" ^ (ty_str ty)
+ | GLUE_drop ty -> "glue$drop$" ^ (ty_str ty)
+ | GLUE_free ty -> "glue$free$" ^ (ty_str ty)
+ | GLUE_copy ty -> "glue$copy$" ^ (ty_str ty)
+ | GLUE_clone ty -> "glue$clone$" ^ (ty_str ty)
+ | GLUE_compare ty -> "glue$compare$" ^ (ty_str ty)
+ | GLUE_hash ty -> "glue$hash$" ^ (ty_str ty)
+ | GLUE_write ty -> "glue$write$" ^ (ty_str ty)
+ | GLUE_read ty -> "glue$read$" ^ (ty_str ty)
+ | GLUE_unwind -> "glue$unwind"
+ | GLUE_get_next_pc -> "glue$get_next_pc"
+ | GLUE_mark_frame i -> "glue$mark_frame$" ^ (item_str cx i)
+ | GLUE_drop_frame i -> "glue$drop_frame$" ^ (item_str cx i)
+ | GLUE_reloc_frame i -> "glue$reloc_frame$" ^ (item_str cx i)
+ (*
+ * FIXME: the node_id here isn't an item, it's a statement;
+ * lookup bind target and encode bound arg tuple type.
+ *)
+ | GLUE_fn_binding i
+ -> "glue$fn_binding$" ^ (string_of_int (int_of_node i))
+ | GLUE_obj_drop oid
+ -> (item_str cx oid) ^ ".drop"
+ | GLUE_loop_body i
+ -> "glue$loop_body$" ^ (string_of_int (int_of_node i))
+ | GLUE_forward (id, oty1, oty2)
+ -> "glue$forward$"
+ ^ id
+ ^ "$" ^ (ty_str (Ast.TY_obj oty1))
+ ^ "$" ^ (ty_str (Ast.TY_obj oty2))
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(* Translation *)
+
+open Semant;;
+open Common;;
+open Transutil;;
+
+let log cx = Session.log "trans"
+ cx.ctxt_sess.Session.sess_log_trans
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+let arr_max a = (Array.length a) - 1;;
+
+type quad_idx = int
+;;
+
+type call =
+ {
+ call_ctrl: call_ctrl;
+ call_callee_ptr: Il.operand;
+ call_callee_ty: Ast.ty;
+ call_callee_ty_params: Ast.ty array;
+ call_output: Il.cell;
+ call_args: Ast.atom array;
+ call_iterator_args: Il.operand array;
+ call_indirect_args: Il.operand array;
+ }
+;;
+
+let trans_visitor
+ (cx:ctxt)
+ (path:Ast.name_component Stack.t)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let iflog thunk =
+ if cx.ctxt_sess.Session.sess_log_trans
+ then thunk ()
+ else ()
+ in
+
+ let curr_file = Stack.create () in
+ let curr_stmt = Stack.create () in
+
+ let (abi:Abi.abi) = cx.ctxt_abi in
+ let (word_sz:int64) = word_sz abi in
+ let (word_slot:Ast.slot) = word_slot abi in
+
+ let oper_str = Il.string_of_operand abi.Abi.abi_str_of_hardreg in
+ let cell_str = Il.string_of_cell abi.Abi.abi_str_of_hardreg in
+
+ let (word_bits:Il.bits) = abi.Abi.abi_word_bits in
+ let (word_ty:Il.scalar_ty) = Il.ValTy word_bits in
+ let (word_rty:Il.referent_ty) = Il.ScalarTy word_ty in
+ let (word_ty_mach:ty_mach) =
+ match word_bits with
+ Il.Bits8 -> TY_u8
+ | Il.Bits16 -> TY_u16
+ | Il.Bits32 -> TY_u32
+ | Il.Bits64 -> TY_u64
+ in
+ let (word_ty_signed_mach:ty_mach) =
+ match word_bits with
+ Il.Bits8 -> TY_i8
+ | Il.Bits16 -> TY_i16
+ | Il.Bits32 -> TY_i32
+ | Il.Bits64 -> TY_i64
+ in
+ let word_n = word_n abi in
+ let imm_of_ty (i:int64) (tm:ty_mach) : Il.operand =
+ Il.Imm (Asm.IMM i, tm)
+ in
+
+ let imm (i:int64) : Il.operand = imm_of_ty i word_ty_mach in
+ let simm (i:int64) : Il.operand = imm_of_ty i word_ty_signed_mach in
+ let one = imm 1L in
+ let zero = imm 0L in
+ let imm_true = imm_of_ty 1L TY_u8 in
+ let imm_false = imm_of_ty 0L TY_u8 in
+ let nil_ptr = Il.Mem ((Il.Abs (Asm.IMM 0L)), Il.NilTy) in
+
+ let crate_rel fix =
+ Asm.SUB (Asm.M_POS fix, Asm.M_POS cx.ctxt_crate_fixup)
+ in
+
+ let crate_rel_word fix =
+ Asm.WORD (word_ty_signed_mach, crate_rel fix)
+ in
+
+ let crate_rel_imm (fix:fixup) : Il.operand =
+ Il.Imm (crate_rel fix, word_ty_signed_mach)
+ in
+
+ let table_of_crate_rel_fixups (fixups:fixup array) : Asm.frag =
+ Asm.SEQ (Array.map crate_rel_word fixups)
+ in
+
+ let fixup_rel_word (base:fixup) (fix:fixup) =
+ Asm.WORD (word_ty_signed_mach,
+ Asm.SUB (Asm.M_POS fix, Asm.M_POS base))
+ in
+
+ let table_of_fixup_rel_fixups
+ (fixup:fixup)
+ (fixups:fixup array)
+ : Asm.frag =
+ Asm.SEQ (Array.map (fixup_rel_word fixup) fixups)
+ in
+
+ let table_of_table_rel_fixups (fixups:fixup array) : Asm.frag =
+ let table_fix = new_fixup "vtbl" in
+ Asm.DEF (table_fix, table_of_fixup_rel_fixups table_fix fixups)
+ in
+
+ let nabi_indirect =
+ match cx.ctxt_sess.Session.sess_targ with
+ Linux_x86_elf -> false
+ | _ -> true
+ in
+
+ let nabi_rust =
+ { nabi_indirect = nabi_indirect;
+ nabi_convention = CONV_rust }
+ in
+
+ let out_mem_disp = abi.Abi.abi_frame_base_sz in
+ let arg0_disp =
+ Int64.add abi.Abi.abi_frame_base_sz abi.Abi.abi_implicit_args_sz
+ in
+ let frame_crate_ptr = word_n (-1) in
+ let frame_fns_disp = word_n (-2) in
+
+ let fn_ty (id:node_id) : Ast.ty =
+ Hashtbl.find cx.ctxt_all_item_types id
+ in
+ let fn_args_rty
+ (id:node_id)
+ (closure:Il.referent_ty option)
+ : Il.referent_ty =
+ let n_params =
+ if item_is_obj_fn cx id
+ then 0
+ else n_item_ty_params cx id
+ in
+ call_args_referent_type cx n_params (fn_ty id) closure
+ in
+
+ let emitters = Stack.create () in
+ let push_new_emitter (vregs_ok:bool) (fnid:node_id option) =
+ let e = Il.new_emitter
+ abi.Abi.abi_prealloc_quad
+ abi.Abi.abi_is_2addr_machine
+ vregs_ok fnid
+ in
+ Stack.push (Hashtbl.create 0) e.Il.emit_size_cache;
+ Stack.push e emitters;
+ in
+
+ let push_new_emitter_with_vregs fnid = push_new_emitter true fnid in
+ let push_new_emitter_without_vregs fnid = push_new_emitter false fnid in
+
+ let pop_emitter _ = ignore (Stack.pop emitters) in
+ let emitter _ = Stack.top emitters in
+ let emitter_size_cache _ = Stack.top (emitter()).Il.emit_size_cache in
+ let push_emitter_size_cache _ =
+ Stack.push
+ (Hashtbl.copy (emitter_size_cache()))
+ (emitter()).Il.emit_size_cache
+ in
+ let pop_emitter_size_cache _ =
+ ignore (Stack.pop (emitter()).Il.emit_size_cache)
+ in
+ let emit q = Il.emit (emitter()) q in
+ let next_vreg _ = Il.next_vreg (emitter()) in
+ let next_vreg_cell t = Il.next_vreg_cell (emitter()) t in
+ let next_spill_cell t =
+ let s = Il.next_spill (emitter()) in
+ let spill_mem = Il.Spill s in
+ let spill_ta = (spill_mem, Il.ScalarTy t) in
+ Il.Mem spill_ta
+ in
+ let mark _ : quad_idx = (emitter()).Il.emit_pc in
+ let patch_existing (jmp:quad_idx) (targ:quad_idx) : unit =
+ Il.patch_jump (emitter()) jmp targ
+ in
+ let patch (i:quad_idx) : unit =
+ Il.patch_jump (emitter()) i (mark());
+ (* Insert a dead quad to ensure there's an otherwise-unused
+ * jump-target here.
+ *)
+ emit Il.Dead
+ in
+
+ let current_fn () =
+ match (emitter()).Il.emit_node with
+ None -> bug () "current_fn without associated node"
+ | Some id -> id
+ in
+ let current_fn_args_rty (closure:Il.referent_ty option) : Il.referent_ty =
+ fn_args_rty (current_fn()) closure
+ in
+ let current_fn_callsz () = get_callsz cx (current_fn()) in
+
+ let annotations _ =
+ (emitter()).Il.emit_annotations
+ in
+
+ let annotate (str:string) =
+ let e = emitter() in
+ Hashtbl.add e.Il.emit_annotations e.Il.emit_pc str
+ in
+
+ let epilogue_jumps = Stack.create() in
+
+ let path_name (_:unit) : string =
+ string_of_name (Walk.path_to_name path)
+ in
+
+ let based (reg:Il.reg) : Il.mem =
+ Il.RegIn (reg, None)
+ in
+
+ let based_off (reg:Il.reg) (off:Asm.expr64) : Il.mem =
+ Il.RegIn (reg, Some off)
+ in
+
+ let based_imm (reg:Il.reg) (imm:int64) : Il.mem =
+ based_off reg (Asm.IMM imm)
+ in
+
+ let fp_imm (imm:int64) : Il.mem =
+ based_imm abi.Abi.abi_fp_reg imm
+ in
+
+ let sp_imm (imm:int64) : Il.mem =
+ based_imm abi.Abi.abi_sp_reg imm
+ in
+
+ let word_at (mem:Il.mem) : Il.cell =
+ Il.Mem (mem, Il.ScalarTy (Il.ValTy word_bits))
+ in
+
+ let wordptr_at (mem:Il.mem) : Il.cell =
+ Il.Mem (mem, Il.ScalarTy (Il.AddrTy (Il.ScalarTy (Il.ValTy word_bits))))
+ in
+
+ let mov (dst:Il.cell) (src:Il.operand) : unit =
+ emit (Il.umov dst src)
+ in
+
+ let umul (dst:Il.cell) (a:Il.operand) (b:Il.operand) : unit =
+ emit (Il.binary Il.UMUL dst a b);
+ in
+
+ let add (dst:Il.cell) (a:Il.operand) (b:Il.operand) : unit =
+ emit (Il.binary Il.ADD dst a b);
+ in
+
+ let add_to (dst:Il.cell) (src:Il.operand) : unit =
+ add dst (Il.Cell dst) src;
+ in
+
+ let sub (dst:Il.cell) (a:Il.operand) (b:Il.operand) : unit =
+ emit (Il.binary Il.SUB dst a b);
+ in
+
+ let sub_from (dst:Il.cell) (src:Il.operand) : unit =
+ sub dst (Il.Cell dst) src;
+ in
+
+ let lea (dst:Il.cell) (src:Il.mem) : unit =
+ emit (Il.lea dst (Il.Cell (Il.Mem (src, Il.OpaqueTy))))
+ in
+
+ let rty_ptr_at (mem:Il.mem) (pointee_rty:Il.referent_ty) : Il.cell =
+ Il.Mem (mem, Il.ScalarTy (Il.AddrTy pointee_rty))
+ in
+
+ let ptr_at (mem:Il.mem) (pointee_ty:Ast.ty) : Il.cell =
+ rty_ptr_at mem (referent_type abi pointee_ty)
+ in
+
+ let need_scalar_ty (rty:Il.referent_ty) : Il.scalar_ty =
+ match rty with
+ Il.ScalarTy s -> s
+ | _ -> bug () "expected ScalarTy"
+ in
+
+ let need_mem_cell (cell:Il.cell) : Il.typed_mem =
+ match cell with
+ Il.Mem a -> a
+ | Il.Reg _ -> bug ()
+ "expected address cell, got non-address register cell"
+ in
+
+ let need_cell (operand:Il.operand) : Il.cell =
+ match operand with
+ Il.Cell c -> c
+ | _ -> bug () "expected cell, got operand %s"
+ (Il.string_of_operand abi.Abi.abi_str_of_hardreg operand)
+ in
+
+ let get_element_ptr =
+ Il.get_element_ptr word_bits abi.Abi.abi_str_of_hardreg
+ in
+
+ let get_variant_ptr (mem_cell:Il.cell) (i:int) : Il.cell =
+ match mem_cell with
+ Il.Mem (mem, Il.UnionTy elts)
+ when i >= 0 && i < (Array.length elts) ->
+ assert ((Array.length elts) != 0);
+ Il.Mem (mem, elts.(i))
+
+ | _ -> bug () "get_variant_ptr %d on cell %s" i
+ (cell_str mem_cell)
+ in
+
+ let rec ptr_cast (cell:Il.cell) (rty:Il.referent_ty) : Il.cell =
+ match cell with
+ Il.Mem (mem, _) -> Il.Mem (mem, rty)
+ | Il.Reg (reg, Il.AddrTy _) -> Il.Reg (reg, Il.AddrTy rty)
+ | _ -> bug () "expected address cell in Trans.ptr_cast"
+
+ and curr_crate_ptr _ : Il.cell =
+ word_at (fp_imm frame_crate_ptr)
+
+ and crate_rel_to_ptr (rel:Il.operand) (rty:Il.referent_ty) : Il.cell =
+ let cell = next_vreg_cell (Il.AddrTy rty) in
+ mov cell (Il.Cell (curr_crate_ptr()));
+ add_to cell rel;
+ cell
+
+ (*
+ * Note: alias *requires* its cell to be in memory already, and should
+ * only be used on slots you know to be memory-resident. Use 'aliasing' or
+ * 'via_memory' if you have a cell or operand you want in memory for a very
+ * short period of time (the time spent by the code generated by the thunk).
+ *)
+
+ and alias (cell:Il.cell) : Il.cell =
+ let mem, ty = need_mem_cell cell in
+ let vreg_cell = next_vreg_cell (Il.AddrTy ty) in
+ begin
+ match ty with
+ Il.NilTy -> ()
+ | _ -> lea vreg_cell mem
+ end;
+ vreg_cell
+
+ and force_to_mem (src:Il.operand) : Il.typed_mem =
+ let do_spill op (t:Il.scalar_ty) =
+ let spill = next_spill_cell t in
+ mov spill op;
+ need_mem_cell spill
+ in
+ match src with
+ Il.Cell (Il.Mem ta) -> ta
+ | Il.Cell (Il.Reg (_, t)) -> do_spill src t
+ | Il.Imm _ -> do_spill src (Il.ValTy word_bits)
+ | Il.ImmPtr (f, rty) ->
+ do_spill
+ (Il.Cell (crate_rel_to_ptr (crate_rel_imm f) rty))
+ (Il.AddrTy rty)
+
+ and force_to_reg (op:Il.operand) : Il.typed_reg =
+ let do_mov op st =
+ let tmp = next_vreg () in
+ let regty = (tmp, st) in
+ mov (Il.Reg regty) op;
+ regty
+ in
+ match op with
+ Il.Imm (_, tm) -> do_mov op (Il.ValTy (Il.bits_of_ty_mach tm))
+ | Il.ImmPtr (f, rty) ->
+ do_mov
+ (Il.Cell (crate_rel_to_ptr (crate_rel_imm f) rty))
+ (Il.AddrTy rty)
+ | Il.Cell (Il.Reg rt) -> rt
+ | Il.Cell (Il.Mem (_, Il.ScalarTy st)) -> do_mov op st
+ | Il.Cell (Il.Mem (_, rt)) ->
+ bug () "forcing non-scalar referent of type %s to register"
+ (Il.string_of_referent_ty rt)
+
+ and via_memory (writeback:bool) (c:Il.cell) (thunk:Il.cell -> unit) : unit =
+ match c with
+ Il.Mem _ -> thunk c
+ | Il.Reg _ ->
+ let mem_c = Il.Mem (force_to_mem (Il.Cell c)) in
+ thunk mem_c;
+ if writeback
+ then
+ mov c (Il.Cell mem_c)
+
+ and aliasing (writeback:bool) (c:Il.cell) (thunk:Il.cell -> unit) : unit =
+ via_memory writeback c (fun c -> thunk (alias c))
+
+ and pointee_type (ptr:Il.cell) : Il.referent_ty =
+ match ptr with
+ Il.Reg (_, (Il.AddrTy rt)) -> rt
+ | Il.Mem (_, Il.ScalarTy (Il.AddrTy rt)) -> rt
+ | _ ->
+ bug () "taking pointee-type of non-address cell %s "
+ (cell_str ptr)
+
+ and deref (ptr:Il.cell) : Il.cell =
+ let (r, st) = force_to_reg (Il.Cell ptr) in
+ match st with
+ Il.AddrTy rt -> Il.Mem (based r, rt)
+ | _ -> bug () "dereferencing non-address cell of type %s "
+ (Il.string_of_scalar_ty st)
+
+ and deref_off (ptr:Il.cell) (off:Asm.expr64) : Il.cell =
+ let (r, st) = force_to_reg (Il.Cell ptr) in
+ match st with
+ Il.AddrTy rt -> Il.Mem (based_off r off, rt)
+ | _ -> bug () "offset-dereferencing non-address cell of type %s "
+ (Il.string_of_scalar_ty st)
+
+ and deref_imm (ptr:Il.cell) (imm:int64) : Il.cell =
+ deref_off ptr (Asm.IMM imm)
+
+ and tp_imm (imm:int64) : Il.cell =
+ deref_imm abi.Abi.abi_tp_cell imm
+ in
+
+
+ let make_tydesc_slots n =
+ Array.init n (fun _ -> interior_slot Ast.TY_type)
+ in
+
+ let cell_vreg_num (vr:(int option) ref) : int =
+ match !vr with
+ None ->
+ let v = (Il.next_vreg_num (emitter())) in
+ vr := Some v;
+ v
+ | Some v -> v
+ in
+
+ let slot_id_referent_type (slot_id:node_id) : Il.referent_ty =
+ slot_referent_type abi (referent_to_slot cx slot_id)
+ in
+
+ let caller_args_cell (args_rty:Il.referent_ty) : Il.cell =
+ Il.Mem (fp_imm out_mem_disp, args_rty)
+ in
+
+ let get_ty_param (ty_params:Il.cell) (param_idx:int) : Il.cell =
+ get_element_ptr ty_params param_idx
+ in
+
+ let get_ty_params_of_frame (fp:Il.reg) (n_params:int) : Il.cell =
+ let fn_ty = mk_simple_ty_fn [| |] in
+ let fn_rty = call_args_referent_type cx n_params fn_ty None in
+ let args_cell = Il.Mem (based_imm fp out_mem_disp, fn_rty) in
+ get_element_ptr args_cell Abi.calltup_elt_ty_params
+ in
+
+ let get_args_for_current_frame _ =
+ let curr_args_rty =
+ current_fn_args_rty (Some Il.OpaqueTy)
+ in
+ caller_args_cell curr_args_rty
+ in
+
+ let get_indirect_args_for_current_frame _ =
+ get_element_ptr (get_args_for_current_frame ())
+ Abi.calltup_elt_indirect_args
+ in
+
+ let get_iterator_args_for_current_frame _ =
+ get_element_ptr (get_args_for_current_frame ())
+ Abi.calltup_elt_iterator_args
+ in
+
+ let get_closure_for_current_frame _ =
+ let self_indirect_args =
+ get_indirect_args_for_current_frame ()
+ in
+ get_element_ptr self_indirect_args
+ Abi.indirect_args_elt_closure
+ in
+
+ let get_iter_block_fn_for_current_frame _ =
+ let self_iterator_args =
+ get_iterator_args_for_current_frame ()
+ in
+ let blk_fn = get_element_ptr self_iterator_args
+ Abi.iterator_args_elt_block_fn
+ in
+ ptr_cast blk_fn
+ (Il.ScalarTy (Il.AddrTy Il.CodeTy))
+ in
+
+ let get_iter_outer_frame_ptr_for_current_frame _ =
+ let self_iterator_args =
+ get_iterator_args_for_current_frame ()
+ in
+ get_element_ptr self_iterator_args
+ Abi.iterator_args_elt_outer_frame_ptr
+ in
+
+ let get_obj_for_current_frame _ =
+ deref (ptr_cast
+ (get_closure_for_current_frame ())
+ (Il.ScalarTy (Il.AddrTy (obj_closure_rty abi))))
+ in
+
+ let get_ty_params_of_current_frame _ : Il.cell =
+ let id = current_fn() in
+ let n_ty_params = n_item_ty_params cx id in
+ if item_is_obj_fn cx id
+ then
+ begin
+ let obj = get_obj_for_current_frame() in
+ let tydesc = get_element_ptr obj 1 in
+ let ty_params_ty = Ast.TY_tup (make_tydesc_slots n_ty_params) in
+ let ty_params_rty = referent_type abi ty_params_ty in
+ let ty_params =
+ get_element_ptr (deref tydesc) Abi.tydesc_field_first_param
+ in
+ let ty_params =
+ ptr_cast ty_params (Il.ScalarTy (Il.AddrTy ty_params_rty))
+ in
+ deref ty_params
+ end
+
+ else
+ get_ty_params_of_frame abi.Abi.abi_fp_reg n_ty_params
+ in
+
+ let get_ty_param_in_current_frame (param_idx:int) : Il.cell =
+ get_ty_param (get_ty_params_of_current_frame()) param_idx
+ in
+
+ let linearize_ty_params (ty:Ast.ty) : (Ast.ty * Il.operand array) =
+ let htab = Hashtbl.create 0 in
+ let q = Queue.create () in
+ let base = ty_fold_rebuild (fun t -> t) in
+ let ty_fold_param (i, mut) =
+ let param = Ast.TY_param (i, mut) in
+ match htab_search htab param with
+ Some p -> p
+ | None ->
+ let p = Ast.TY_param (Hashtbl.length htab, mut) in
+ htab_put htab param p;
+ Queue.add (Il.Cell (get_ty_param_in_current_frame i)) q;
+ p
+ in
+ let fold =
+ { base with
+ ty_fold_param = ty_fold_param; }
+ in
+ let ty = fold_ty fold ty in
+ (ty, queue_to_arr q)
+ in
+
+ let has_parametric_types (t:Ast.ty) : bool =
+ let base = ty_fold_bool_or false in
+ let ty_fold_param _ =
+ true
+ in
+ let fold = { base with ty_fold_param = ty_fold_param } in
+ fold_ty fold t
+ in
+
+ let rec calculate_sz (ty_params:Il.cell) (size:size) : Il.operand =
+ iflog (fun _ -> annotate
+ (Printf.sprintf "calculating size %s"
+ (string_of_size size)));
+ let sub_sz = calculate_sz ty_params in
+ match htab_search (emitter_size_cache()) size with
+ Some op -> op
+ | _ ->
+ let res =
+ match size with
+ SIZE_fixed i -> imm i
+ | SIZE_fixup_mem_pos f -> Il.Imm (Asm.M_POS f, word_ty_mach)
+ | SIZE_fixup_mem_sz f -> Il.Imm (Asm.M_SZ f, word_ty_mach)
+
+ | SIZE_param_size i ->
+ let tydesc = deref (get_ty_param ty_params i) in
+ Il.Cell (get_element_ptr tydesc Abi.tydesc_field_size)
+
+ | SIZE_param_align i ->
+ let tydesc = deref (get_ty_param ty_params i) in
+ Il.Cell (get_element_ptr tydesc Abi.tydesc_field_align)
+
+ | SIZE_rt_neg a ->
+ let op_a = sub_sz a in
+ let tmp = next_vreg_cell word_ty in
+ emit (Il.unary Il.NEG tmp op_a);
+ Il.Cell tmp
+
+ | SIZE_rt_add (a, b) ->
+ let op_a = sub_sz a in
+ let op_b = sub_sz b in
+ let tmp = next_vreg_cell word_ty in
+ add tmp op_a op_b;
+ Il.Cell tmp
+
+ | SIZE_rt_mul (a, b) ->
+ let op_a = sub_sz a in
+ let op_b = sub_sz b in
+ let tmp = next_vreg_cell word_ty in
+ emit (Il.binary Il.UMUL tmp op_a op_b);
+ Il.Cell tmp
+
+ | SIZE_rt_max (a, b) ->
+ let op_a = sub_sz a in
+ let op_b = sub_sz b in
+ let tmp = next_vreg_cell word_ty in
+ mov tmp op_a;
+ emit (Il.cmp op_a op_b);
+ let jmp = mark () in
+ emit (Il.jmp Il.JAE Il.CodeNone);
+ mov tmp op_b;
+ patch jmp;
+ Il.Cell tmp
+
+ | SIZE_rt_align (align, off) ->
+ (*
+ * calculate off + pad where:
+ *
+ * pad = (align - (off mod align)) mod align
+ *
+ * In our case it's always a power of two,
+ * so we can just do:
+ *
+ * mask = align-1
+ * off += mask
+ * off &= ~mask
+ *
+ *)
+ annotate "fetch alignment";
+ let op_align = sub_sz align in
+ annotate "fetch offset";
+ let op_off = sub_sz off in
+ let mask = next_vreg_cell word_ty in
+ let off = next_vreg_cell word_ty in
+ mov mask op_align;
+ sub_from mask one;
+ mov off op_off;
+ add_to off (Il.Cell mask);
+ emit (Il.unary Il.NOT mask (Il.Cell mask));
+ emit (Il.binary Il.AND
+ off (Il.Cell off) (Il.Cell mask));
+ Il.Cell off
+ in
+ iflog (fun _ -> annotate
+ (Printf.sprintf "calculated size %s is %s"
+ (string_of_size size)
+ (oper_str res)));
+ htab_put (emitter_size_cache()) size res;
+ res
+
+
+ and calculate_sz_in_current_frame (size:size) : Il.operand =
+ calculate_sz (get_ty_params_of_current_frame()) size
+
+ and callee_args_cell (tail_area:bool) (args_rty:Il.referent_ty) : Il.cell =
+ if tail_area
+ then
+ Il.Mem (sp_off_sz (current_fn_callsz ()), args_rty)
+ else
+ Il.Mem (sp_imm 0L, args_rty)
+
+ and based_sz (ty_params:Il.cell) (reg:Il.reg) (size:size) : Il.mem =
+ match Il.size_to_expr64 size with
+ Some e -> based_off reg e
+ | None ->
+ let runtime_size = calculate_sz ty_params size in
+ let v = next_vreg () in
+ let c = (Il.Reg (v, word_ty)) in
+ mov c (Il.Cell (Il.Reg (reg, word_ty)));
+ add_to c runtime_size;
+ based v
+
+ and fp_off_sz (size:size) : Il.mem =
+ based_sz (get_ty_params_of_current_frame()) abi.Abi.abi_fp_reg size
+
+ and sp_off_sz (size:size) : Il.mem =
+ based_sz (get_ty_params_of_current_frame()) abi.Abi.abi_sp_reg size
+ in
+
+ let slot_sz_in_current_frame (slot:Ast.slot) : Il.operand =
+ let rty = slot_referent_type abi slot in
+ let sz = Il.referent_ty_size word_bits rty in
+ calculate_sz_in_current_frame sz
+ in
+
+ let slot_sz_with_ty_params
+ (ty_params:Il.cell)
+ (slot:Ast.slot)
+ : Il.operand =
+ let rty = slot_referent_type abi slot in
+ let sz = Il.referent_ty_size word_bits rty in
+ calculate_sz ty_params sz
+ in
+
+ let get_element_ptr_dyn
+ (ty_params:Il.cell)
+ (mem_cell:Il.cell)
+ (i:int)
+ : Il.cell =
+ match mem_cell with
+ Il.Mem (mem, Il.StructTy elts)
+ when i >= 0 && i < (Array.length elts) ->
+ assert ((Array.length elts) != 0);
+ begin
+ let elt_rty = elts.(i) in
+ let elt_off = Il.get_element_offset word_bits elts i in
+ match elt_off with
+ SIZE_fixed fixed_off ->
+ Il.Mem (Il.mem_off_imm mem fixed_off, elt_rty)
+ | sz ->
+ let sz = calculate_sz ty_params sz in
+ let v = next_vreg word_ty in
+ let vc = Il.Reg (v, word_ty) in
+ lea vc mem;
+ add_to vc sz;
+ Il.Mem (based v, elt_rty)
+ end
+ | _ -> bug () "get_element_ptr_dyn %d on cell %s" i
+ (cell_str mem_cell)
+ in
+
+ let get_element_ptr_dyn_in_current_frame
+ (mem_cell:Il.cell)
+ (i:int)
+ : Il.cell =
+ get_element_ptr_dyn (get_ty_params_of_current_frame()) mem_cell i
+ in
+
+ let get_explicit_args_for_current_frame _ =
+ get_element_ptr_dyn_in_current_frame (get_args_for_current_frame ())
+ Abi.calltup_elt_args
+ in
+
+
+ let deref_off_sz
+ (ty_params:Il.cell)
+ (ptr:Il.cell)
+ (size:size)
+ : Il.cell =
+ match Il.size_to_expr64 size with
+ Some e -> deref_off ptr e
+ | None ->
+ let (r,_) = force_to_reg (Il.Cell ptr) in
+ let mem = based_sz ty_params r size in
+ Il.Mem (mem, (pointee_type ptr))
+ in
+
+ let cell_of_block_slot
+ (slot_id:node_id)
+ : Il.cell =
+ let referent_type = slot_id_referent_type slot_id in
+ match htab_search cx.ctxt_slot_vregs slot_id with
+ Some vr ->
+ begin
+ match referent_type with
+ Il.ScalarTy st -> Il.Reg (Il.Vreg (cell_vreg_num vr), st)
+ | Il.NilTy -> nil_ptr
+ | Il.StructTy _ -> bugi cx slot_id
+ "cannot treat structured referent as single operand"
+ | Il.UnionTy _ -> bugi cx slot_id
+ "cannot treat union referent as single operand"
+ | Il.ParamTy _ -> bugi cx slot_id
+ "cannot treat parametric referent as single operand"
+ | Il.OpaqueTy -> bugi cx slot_id
+ "cannot treat opaque referent as single operand"
+ | Il.CodeTy -> bugi cx slot_id
+ "cannot treat code referent as single operand"
+ end
+ | None ->
+ begin
+ match htab_search cx.ctxt_slot_offsets slot_id with
+ None -> bugi cx slot_id
+ "slot assigned to neither vreg nor offset"
+ | Some off ->
+ if slot_is_obj_state cx slot_id
+ then
+ begin
+ let state_arg = get_closure_for_current_frame () in
+ let (slot_mem, _) =
+ need_mem_cell (deref_off_sz
+ (get_ty_params_of_current_frame())
+ state_arg off)
+ in
+ Il.Mem (slot_mem, referent_type)
+ end
+ else
+ if (Stack.is_empty curr_stmt)
+ then
+ Il.Mem (fp_off_sz off, referent_type)
+ else
+ 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
+ let _ = assert (slot_depth < stmt_depth) in
+ let _ =
+ iflog
+ begin
+ fun _ ->
+ let k =
+ Hashtbl.find cx.ctxt_slot_keys slot_id
+ in
+ annotate
+ (Printf.sprintf
+ "access outer frame slot #%d = %s"
+ (int_of_node slot_id)
+ (Ast.fmt_to_str
+ Ast.fmt_slot_key k))
+ end
+ in
+ let diff = stmt_depth - slot_depth in
+ let _ = annotate "get outer frame pointer" in
+ let fp =
+ get_iter_outer_frame_ptr_for_current_frame ()
+ in
+ if diff > 1
+ then
+ bug () "unsupported nested for each loop";
+ for i = 2 to diff do
+ (* FIXME: access outer caller-block fps,
+ * given nearest caller-block fp.
+ *)
+ let _ =
+ annotate "step to outer-outer frame"
+ in
+ mov fp (Il.Cell fp)
+ done;
+ let _ = annotate "calculate size" in
+ let p =
+ based_sz (get_ty_params_of_current_frame())
+ (fst (force_to_reg (Il.Cell fp))) off
+ in
+ Il.Mem (p, referent_type)
+ else
+ Il.Mem (fp_off_sz off, referent_type)
+ end
+ in
+
+ let binop_to_jmpop (binop:Ast.binop) : Il.jmpop =
+ match binop with
+ Ast.BINOP_eq -> Il.JE
+ | Ast.BINOP_ne -> Il.JNE
+ | Ast.BINOP_lt -> Il.JL
+ | Ast.BINOP_le -> Il.JLE
+ | Ast.BINOP_ge -> Il.JGE
+ | Ast.BINOP_gt -> Il.JG
+ | _ -> bug () "Unhandled binop in binop_to_jmpop"
+ in
+
+ let get_vtbl_entry_idx (table_ptr:Il.cell) (i:int) : Il.cell =
+ (* Vtbls are encoded as tables of table-relative displacements. *)
+ let (table_mem, _) = need_mem_cell (deref table_ptr) in
+ let disp = Il.Cell (word_at (Il.mem_off_imm table_mem (word_n i))) in
+ let ptr_cell = next_vreg_cell (Il.AddrTy Il.CodeTy) in
+ mov ptr_cell (Il.Cell table_ptr);
+ add_to ptr_cell disp;
+ ptr_cell
+ in
+
+ let get_vtbl_entry
+ (obj_cell:Il.cell)
+ (obj_ty:Ast.ty_obj)
+ (id:Ast.ident)
+ : (Il.cell * Ast.ty_fn) =
+ let (_, fns) = obj_ty in
+ let sorted_idents = sorted_htab_keys fns in
+ let i = arr_idx sorted_idents id in
+ let fn_ty = Hashtbl.find fns id in
+ let table_ptr = get_element_ptr obj_cell Abi.binding_field_item in
+ (get_vtbl_entry_idx table_ptr i, fn_ty)
+ in
+
+ let rec trans_slot_lval_ext
+ (base_ty:Ast.ty)
+ (cell:Il.cell)
+ (comp:Ast.lval_component)
+ : (Il.cell * Ast.slot) =
+
+ let bounds_checked_access at slot =
+ let atop = trans_atom at in
+ let unit_sz = slot_sz_in_current_frame slot in
+ let idx = next_vreg_cell word_ty in
+ emit (Il.binary Il.UMUL idx atop unit_sz);
+ let elt_mem = trans_bounds_check (deref cell) (Il.Cell idx) in
+ (Il.Mem (elt_mem, slot_referent_type abi slot), slot)
+ in
+
+ match (base_ty, comp) with
+ (Ast.TY_rec entries,
+ Ast.COMP_named (Ast.COMP_ident id)) ->
+ let i = arr_idx (Array.map fst entries) id in
+ (get_element_ptr_dyn_in_current_frame cell i, snd entries.(i))
+
+ | (Ast.TY_tup entries,
+ Ast.COMP_named (Ast.COMP_idx i)) ->
+ (get_element_ptr_dyn_in_current_frame cell i, entries.(i))
+
+ | (Ast.TY_vec slot,
+ Ast.COMP_atom at) ->
+ bounds_checked_access at slot
+
+ | (Ast.TY_str,
+ Ast.COMP_atom at) ->
+ bounds_checked_access at (interior_slot (Ast.TY_mach TY_u8))
+
+ | (Ast.TY_obj obj_ty,
+ Ast.COMP_named (Ast.COMP_ident id)) ->
+ let (cell, fn_ty) = get_vtbl_entry cell obj_ty id in
+ (cell, (interior_slot (Ast.TY_fn fn_ty)))
+
+
+ | _ -> bug () "unhandled form of lval_ext in trans_slot_lval_ext"
+
+ (*
+ * vec: operand holding ptr to vec.
+ * mul_idx: index value * unit size.
+ * return: ptr to element.
+ *)
+ and trans_bounds_check (vec:Il.cell) (mul_idx:Il.operand) : Il.mem =
+ let (len:Il.cell) = get_element_ptr vec Abi.vec_elt_fill in
+ let (data:Il.cell) = get_element_ptr vec Abi.vec_elt_data in
+ let (base:Il.cell) = next_vreg_cell Il.voidptr_t in
+ let (elt_reg:Il.reg) = next_vreg () in
+ let (elt:Il.cell) = Il.Reg (elt_reg, Il.voidptr_t) in
+ let (diff:Il.cell) = next_vreg_cell word_ty in
+ annotate "bounds check";
+ lea base (fst (need_mem_cell data));
+ add elt (Il.Cell base) mul_idx;
+ emit (Il.binary Il.SUB diff (Il.Cell elt) (Il.Cell base));
+ let jmp = trans_compare Il.JB (Il.Cell diff) (Il.Cell len) in
+ trans_cond_fail "bounds check" jmp;
+ based elt_reg
+
+ and trans_lval_full
+ (initializing:bool)
+ (lv:Ast.lval)
+ : (Il.cell * Ast.slot) =
+
+ let rec trans_slot_lval_full (initializing:bool) lv =
+ let (cell, slot) =
+ match lv with
+ Ast.LVAL_ext (base, comp) ->
+ let (base_cell, base_slot) =
+ trans_slot_lval_full initializing base
+ in
+ let base_cell' = deref_slot initializing base_cell base_slot in
+ trans_slot_lval_ext (slot_ty base_slot) base_cell' comp
+
+ | Ast.LVAL_base nb ->
+ let slot = lval_to_slot cx nb.id in
+ let referent = lval_to_referent cx nb.id in
+ let cell = cell_of_block_slot referent in
+ (cell, slot)
+ in
+ iflog
+ begin
+ fun _ ->
+ annotate
+ (Printf.sprintf "lval %a = %s"
+ Ast.sprintf_lval lv
+ (cell_str cell))
+ end;
+ (cell, slot)
+
+ in
+ if lval_is_slot cx lv
+ then trans_slot_lval_full initializing lv
+ else
+ if initializing
+ then err None "init item"
+ else
+ begin
+ assert (lval_is_item cx lv);
+ bug ()
+ "trans_lval_full called on item lval '%a'" Ast.sprintf_lval lv
+ end
+
+ and trans_lval_maybe_init
+ (initializing:bool)
+ (lv:Ast.lval)
+ : (Il.cell * Ast.slot) =
+ trans_lval_full initializing lv
+
+ and trans_lval_init (lv:Ast.lval) : (Il.cell * Ast.slot) =
+ trans_lval_maybe_init true lv
+
+ and trans_lval (lv:Ast.lval) : (Il.cell * Ast.slot) =
+ trans_lval_maybe_init false lv
+
+ and trans_callee
+ (flv:Ast.lval)
+ : (Il.operand * Ast.ty) =
+ (* direct call to item *)
+ let fty = Hashtbl.find cx.ctxt_all_lval_types (lval_base_id flv) in
+ if lval_is_item cx flv then
+ let fn_item = lval_item cx flv in
+ let fn_ptr = code_fixup_to_ptr_operand (get_fn_fixup cx fn_item.id) in
+ (fn_ptr, fty)
+ else
+ (* indirect call to computed slot *)
+ let (cell, _) = trans_lval flv in
+ (Il.Cell cell, fty)
+
+ and trans_crate_rel_data_operand
+ (d:data)
+ (thunk:unit -> Asm.frag)
+ : Il.operand =
+ let (fix, _) =
+ htab_search_or_add cx.ctxt_data d
+ begin
+ fun _ ->
+ let fix = new_fixup "data item" in
+ let frag = Asm.DEF (fix, thunk()) in
+ (fix, frag)
+ end
+ in
+ crate_rel_imm fix
+
+ and trans_crate_rel_data_frag (d:data) (thunk:unit -> Asm.frag) : Asm.frag =
+ let (fix, _) =
+ htab_search_or_add cx.ctxt_data d
+ begin
+ fun _ ->
+ let fix = new_fixup "data item" in
+ let frag = Asm.DEF (fix, thunk()) in
+ (fix, frag)
+ end
+ in
+ crate_rel_word fix
+
+ and trans_crate_rel_static_string_operand (s:string) : Il.operand =
+ trans_crate_rel_data_operand (DATA_str s) (fun _ -> Asm.ZSTRING s)
+
+ and trans_crate_rel_static_string_frag (s:string) : Asm.frag =
+ trans_crate_rel_data_frag (DATA_str s) (fun _ -> Asm.ZSTRING s)
+
+ and trans_static_string (s:string) : Il.operand =
+ Il.Cell (crate_rel_to_ptr
+ (trans_crate_rel_static_string_operand s)
+ (referent_type abi Ast.TY_str))
+
+ and get_static_tydesc
+ (idopt:node_id option)
+ (t:Ast.ty)
+ (sz:int64)
+ (align:int64)
+ : Il.operand =
+ trans_crate_rel_data_operand
+ (DATA_tydesc t)
+ begin
+ fun _ ->
+ let tydesc_fixup = new_fixup "tydesc" in
+ log cx "tydesc for %a has sz=%Ld, align=%Ld"
+ Ast.sprintf_ty t sz align;
+ Asm.DEF
+ (tydesc_fixup,
+ Asm.SEQ
+ [|
+ Asm.WORD (word_ty_mach, Asm.IMM 0L);
+ Asm.WORD (word_ty_mach, Asm.IMM sz);
+ Asm.WORD (word_ty_mach, Asm.IMM align);
+ table_of_fixup_rel_fixups tydesc_fixup
+ [|
+ get_copy_glue t None;
+ get_drop_glue t None;
+ get_free_glue t (slot_mem_ctrl (interior_slot t)) None;
+ get_mark_glue t None;
+ |];
+ (* Include any obj-dtor, if this is an obj and has one. *)
+ begin
+ match idopt with
+ None -> Asm.WORD (word_ty_mach, Asm.IMM 0L);
+ | Some oid ->
+ begin
+ let g = GLUE_obj_drop oid in
+ match htab_search cx.ctxt_glue_code g with
+ Some code ->
+ fixup_rel_word
+ tydesc_fixup
+ code.code_fixup;
+ | None ->
+ Asm.WORD (word_ty_mach, Asm.IMM 0L);
+ end
+ end;
+ |])
+ end
+
+ and get_obj_vtbl (id:node_id) : Il.operand =
+ let obj =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_item { Ast.decl_item=Ast.MOD_ITEM_obj obj} -> obj
+ | _ -> bug () "Trans.get_obj_vtbl on non-obj referent"
+ in
+ trans_crate_rel_data_operand (DATA_obj_vtbl id)
+ begin
+ fun _ ->
+ iflog (fun _ -> log cx "emitting %d-entry obj vtbl for %s"
+ (Hashtbl.length obj.Ast.obj_fns) (path_name()));
+ table_of_table_rel_fixups
+ (Array.map
+ begin
+ fun k ->
+ let fn = Hashtbl.find obj.Ast.obj_fns k in
+ get_fn_fixup cx fn.id
+ end
+ (sorted_htab_keys obj.Ast.obj_fns))
+ end
+
+
+ and trans_copy_forward_args (args_rty:Il.referent_ty) : unit =
+ let caller_args_cell = caller_args_cell args_rty in
+ let callee_args_cell = callee_args_cell false args_rty in
+ let (dst_reg, _) = force_to_reg (Il.Cell (alias callee_args_cell)) in
+ let (src_reg, _) = force_to_reg (Il.Cell (alias caller_args_cell)) in
+ let tmp_reg = next_vreg () in
+ let nbytes = force_sz (Il.referent_ty_size word_bits args_rty) in
+ abi.Abi.abi_emit_inline_memcpy (emitter())
+ nbytes dst_reg src_reg tmp_reg false;
+
+
+ and get_forwarding_obj_fn
+ (ident:Ast.ident)
+ (caller:Ast.ty_obj)
+ (callee:Ast.ty_obj)
+ : fixup =
+ (* Forwarding "glue" is not glue in the normal sense of being called with
+ * only Abi.worst_case_glue_call_args args; the functions are full-fleged
+ * obj fns like any other, and they perform a full call to the target
+ * obj. We just use the glue facility here to store the forwarding
+ * operators somewhere.
+ *)
+ let g = GLUE_forward (ident, caller, callee) in
+ let fix = new_fixup (glue_str cx g) in
+ let fty = Hashtbl.find (snd caller) ident in
+ let self_args_rty =
+ call_args_referent_type cx 0
+ (Ast.TY_fn fty) (Some (obj_closure_rty abi))
+ in
+ let callsz = Il.referent_ty_size word_bits self_args_rty in
+ let spill = new_fixup "forwarding fn spill" in
+ trans_glue_frame_entry callsz spill;
+ let all_self_args_cell = caller_args_cell self_args_rty in
+ let self_indirect_args_cell =
+ get_element_ptr all_self_args_cell Abi.calltup_elt_indirect_args
+ in
+ (*
+ * Note: this is wrong. This assumes our closure is a vtbl,
+ * when in fact it is a pointer to a refcounted malloc slab
+ * containing an obj.
+ *)
+ let closure_cell =
+ deref (get_element_ptr self_indirect_args_cell
+ Abi.indirect_args_elt_closure)
+ in
+
+ let (callee_fn_cell, _) =
+ get_vtbl_entry closure_cell callee ident
+ in
+ iflog (fun _ -> annotate "copy args forward to callee");
+ trans_copy_forward_args self_args_rty;
+
+ iflog (fun _ -> annotate "call through to callee");
+ (* FIXME: use a tail-call here. *)
+ call_code (code_of_cell callee_fn_cell);
+ trans_glue_frame_exit fix spill g;
+ fix
+
+
+ and get_forwarding_vtbl
+ (caller:Ast.ty_obj)
+ (callee:Ast.ty_obj)
+ : Il.operand =
+ trans_crate_rel_data_operand (DATA_forwarding_vtbl (caller,callee))
+ begin
+ fun _ ->
+ let (_,fns) = caller in
+ iflog (fun _ -> log cx "emitting %d-entry obj forwarding vtbl"
+ (Hashtbl.length fns));
+ table_of_table_rel_fixups
+ (Array.map
+ begin
+ fun k ->
+ get_forwarding_obj_fn k caller callee
+ end
+ (sorted_htab_keys fns))
+ end
+
+ and trans_init_str (dst:Ast.lval) (s:string) : unit =
+ (* Include null byte. *)
+ let init_sz = Int64.of_int ((String.length s) + 1) in
+ let static = trans_static_string s in
+ let (dst, _) = trans_lval_init dst in
+ trans_upcall "upcall_new_str" dst [| static; imm init_sz |]
+
+ and trans_lit (lit:Ast.lit) : Il.operand =
+ match lit with
+ Ast.LIT_nil -> Il.Cell (nil_ptr)
+ | Ast.LIT_bool false -> imm_false
+ | Ast.LIT_bool true -> imm_true
+ | Ast.LIT_char c -> imm_of_ty (Int64.of_int c) TY_u32
+ | Ast.LIT_int (i, _) -> simm i
+ | Ast.LIT_uint (i, _) -> imm i
+ | Ast.LIT_mach (m, n, _) -> imm_of_ty n m
+
+ and trans_atom (atom:Ast.atom) : Il.operand =
+ iflog
+ begin
+ fun _ ->
+ annotate (Ast.fmt_to_str Ast.fmt_atom atom)
+ end;
+
+ match atom with
+ Ast.ATOM_lval lv ->
+ let (cell, slot) = trans_lval lv in
+ Il.Cell (deref_slot false cell slot)
+
+ | Ast.ATOM_literal lit -> trans_lit lit.node
+
+ and fixup_to_ptr_operand
+ (imm_ok:bool)
+ (fix:fixup)
+ (referent_ty:Il.referent_ty)
+ : Il.operand =
+ if imm_ok
+ then Il.ImmPtr (fix, referent_ty)
+ else Il.Cell (crate_rel_to_ptr (crate_rel_imm fix) referent_ty)
+
+ and code_fixup_to_ptr_operand (fix:fixup) : Il.operand =
+ fixup_to_ptr_operand abi.Abi.abi_has_pcrel_code fix Il.CodeTy
+
+ (* A pointer-valued op may be of the form ImmPtr, which carries its
+ * target fixup, "constant-propagated" through trans so that
+ * pc-relative addressing can make use of it whenever
+ * appropriate. Reify_ptr exists for cases when you are about to
+ * store an ImmPtr into a memory cell or other place beyond which the
+ * compiler will cease to know about its identity; at this point you
+ * should decay it to a crate-relative displacement and
+ * (computationally) add it to the crate base value, before working
+ * with it.
+ *
+ * This helps you obey the IL type-system prohibition against
+ * 'mov'-ing an ImmPtr to a cell. If you forget to call this
+ * in the right places, you will get code-generation failures.
+ *)
+ and reify_ptr (op:Il.operand) : Il.operand =
+ match op with
+ Il.ImmPtr (fix, rty) ->
+ Il.Cell (crate_rel_to_ptr (crate_rel_imm fix) rty)
+ | _ -> op
+
+ and annotate_quads (name:string) : unit =
+ let e = emitter() in
+ let quads = emitted_quads e in
+ let annotations = annotations() in
+ log cx "emitted quads for %s:" name;
+ for i = 0 to arr_max quads
+ do
+ if Hashtbl.mem annotations i
+ then
+ List.iter
+ (fun a -> log cx "// %s" a)
+ (List.rev (Hashtbl.find_all annotations i));
+ log cx "[%6d]\t%s" i
+ (Il.string_of_quad
+ abi.Abi.abi_str_of_hardreg quads.(i));
+ done
+
+
+ and write_frame_info_ptrs (fnid:node_id option) =
+ let frame_fns =
+ match fnid with
+ None -> zero
+ | Some fnid -> get_frame_glue_fns fnid
+ in
+ let crate_ptr_reg = next_vreg () in
+ let crate_ptr_cell = Il.Reg (crate_ptr_reg, (Il.AddrTy Il.OpaqueTy)) in
+ iflog (fun _ -> annotate "write frame-info pointers");
+ Abi.load_fixup_addr (emitter())
+ crate_ptr_reg cx.ctxt_crate_fixup Il.OpaqueTy;
+ mov (word_at (fp_imm frame_crate_ptr)) (Il.Cell (crate_ptr_cell));
+ mov (word_at (fp_imm frame_fns_disp)) frame_fns
+
+ and check_interrupt_flag _ =
+ let wordptr_ty = Il.AddrTy (Il.ScalarTy word_ty) in
+ let dom = next_vreg_cell wordptr_ty in
+ let flag = next_vreg_cell word_ty in
+ mov dom (Il.Cell (tp_imm (word_n Abi.task_field_dom)));
+ mov flag (Il.Cell (deref_imm dom
+ (word_n Abi.dom_field_interrupt_flag)));
+ let null_jmp = null_check flag in
+ trans_yield ();
+ patch null_jmp
+
+ and trans_glue_frame_entry
+ (callsz:size)
+ (spill:fixup)
+ : unit =
+ let framesz = SIZE_fixup_mem_sz spill in
+ push_new_emitter_with_vregs None;
+ iflog (fun _ -> annotate "prologue");
+ abi.Abi.abi_emit_fn_prologue (emitter())
+ framesz callsz nabi_rust (upcall_fixup "upcall_grow_task");
+ write_frame_info_ptrs None;
+ check_interrupt_flag ();
+ iflog (fun _ -> annotate "finished prologue");
+
+ and emitted_quads e =
+ Array.sub e.Il.emit_quads 0 e.Il.emit_pc
+
+ and capture_emitted_glue (fix:fixup) (spill:fixup) (g:glue) : unit =
+ let e = emitter() in
+ iflog (fun _ -> annotate_quads (glue_str cx g));
+ let code = { code_fixup = fix;
+ code_quads = emitted_quads e;
+ code_vregs_and_spill = Some (Il.num_vregs e, spill); }
+ in
+ htab_put cx.ctxt_glue_code g code
+
+ and trans_glue_frame_exit (fix:fixup) (spill:fixup) (g:glue) : unit =
+ iflog (fun _ -> annotate "epilogue");
+ abi.Abi.abi_emit_fn_epilogue (emitter());
+ capture_emitted_glue fix spill g;
+ pop_emitter ()
+
+ and emit_exit_task_glue (fix:fixup) (g:glue) : unit =
+ let name = glue_str cx g in
+ let spill = new_fixup (name ^ " spill") in
+ push_new_emitter_with_vregs None;
+ (*
+ * We return-to-here in a synthetic frame we did not build; our job is
+ * merely to call upcall_exit.
+ *)
+ iflog (fun _ -> annotate "assume 'exited' state");
+ trans_void_upcall "upcall_exit" [| |];
+ capture_emitted_glue fix spill g;
+ pop_emitter ()
+
+ and get_exit_task_glue _ : fixup =
+ let g = GLUE_exit_task in
+ match htab_search cx.ctxt_glue_code g with
+ Some code -> code.code_fixup
+ | None ->
+ let fix = cx.ctxt_exit_task_fixup in
+ emit_exit_task_glue fix g;
+ fix
+
+ (*
+ * Closure representation has 3 GEP-parts:
+ *
+ * ......
+ * . gc . gc control word, if mutable
+ * +----+
+ * | rc | refcount
+ * +----+
+ *
+ * +----+
+ * | tf | ----> pair of fn+binding that closure
+ * +----+ / targets
+ * | tb | --
+ * +----+
+ *
+ * +----+
+ * | b1 | bound arg1
+ * +----+
+ * . .
+ * . .
+ * . .
+ * +----+
+ * | bN | bound argN
+ * +----+
+ *)
+
+ and closure_referent_type
+ (bs:Ast.slot array)
+ (* FIXME (issue #5): mutability flag *)
+ : Il.referent_ty =
+ let rc = Il.ScalarTy word_ty in
+ let targ = referent_type abi (mk_simple_ty_fn [||]) in
+ let bindings = Array.map (slot_referent_type abi) bs in
+ Il.StructTy [| rc; targ; Il.StructTy bindings |]
+
+ (* FIXME (issue #2): this should eventually use tail calling logic *)
+
+ and emit_fn_binding_glue
+ (arg_slots:Ast.slot array)
+ (arg_bound_flags:bool array)
+ (fix:fixup)
+ (g:glue)
+ : unit =
+ let extract_slots want_bound =
+ arr_filter_some
+ (arr_map2
+ (fun slot bound ->
+ if bound = want_bound then Some slot else None)
+ arg_slots
+ arg_bound_flags)
+ in
+ let bound_slots = extract_slots true in
+ let unbound_slots = extract_slots false in
+ let (self_ty:Ast.ty) = mk_simple_ty_fn unbound_slots in
+ let (callee_ty:Ast.ty) = mk_simple_ty_fn arg_slots in
+
+ let self_closure_rty = closure_referent_type bound_slots in
+ (* FIXME: binding type parameters doesn't work. *)
+ let self_args_rty =
+ call_args_referent_type cx 0 self_ty (Some self_closure_rty)
+ in
+ let callee_args_rty =
+ call_args_referent_type cx 0 callee_ty (Some Il.OpaqueTy)
+ in
+
+ let callsz = Il.referent_ty_size word_bits callee_args_rty in
+ let spill = new_fixup "bind glue spill" in
+ trans_glue_frame_entry callsz spill;
+
+ let all_self_args_cell = caller_args_cell self_args_rty in
+ let self_indirect_args_cell =
+ get_element_ptr all_self_args_cell Abi.calltup_elt_indirect_args
+ in
+ let closure_cell =
+ deref (get_element_ptr self_indirect_args_cell
+ Abi.indirect_args_elt_closure)
+ in
+ let closure_target_cell =
+ get_element_ptr closure_cell Abi.binding_field_binding
+ in
+ let closure_target_fn_cell =
+ get_element_ptr closure_target_cell Abi.binding_field_item
+ in
+
+ merge_bound_args
+ self_args_rty callee_args_rty
+ arg_slots arg_bound_flags;
+ iflog (fun _ -> annotate "call through to closure target fn");
+
+ (*
+ * Closures, unlike first-class [disp,*binding] pairs, contain
+ * a fully-resolved target pointer, not a displacement. So we
+ * don't want to use callee_fn_ptr or the like to access the
+ * contents. We just call through the cell directly.
+ *)
+
+ call_code (code_of_cell closure_target_fn_cell);
+ trans_glue_frame_exit fix spill g
+
+
+ and get_fn_binding_glue
+ (bind_id:node_id)
+ (arg_slots:Ast.slot array)
+ (arg_bound_flags:bool array)
+ : fixup =
+ let g = GLUE_fn_binding bind_id in
+ match htab_search cx.ctxt_glue_code g with
+ Some code -> code.code_fixup
+ | None ->
+ let fix = new_fixup (glue_str cx g) in
+ emit_fn_binding_glue arg_slots arg_bound_flags fix g;
+ fix
+
+
+ (*
+ * Mem-glue functions are either 'mark', 'drop' or 'free', they take
+ * one pointer arg and return nothing.
+ *)
+
+ and trans_mem_glue_frame_entry (n_outgoing_args:int) (spill:fixup) : unit =
+ let isz = cx.ctxt_abi.Abi.abi_implicit_args_sz in
+ let callsz = SIZE_fixed (Int64.add isz (word_n n_outgoing_args)) in
+ trans_glue_frame_entry callsz spill
+
+ and get_mem_glue (g:glue) (inner:Il.mem -> unit) : fixup =
+ match htab_search cx.ctxt_glue_code g with
+ Some code -> code.code_fixup
+ | None ->
+ begin
+ let name = glue_str cx g in
+ let fix = new_fixup name in
+ (*
+ * Put a temporary code entry in the table to handle
+ * recursive emit calls during the generation of the glue
+ * function.
+ *)
+ let tmp_code = { code_fixup = fix;
+ code_quads = [| |];
+ code_vregs_and_spill = None; } in
+ let spill = new_fixup (name ^ " spill") in
+ htab_put cx.ctxt_glue_code g tmp_code;
+ log cx "emitting glue: %s" name;
+ trans_mem_glue_frame_entry Abi.worst_case_glue_call_args spill;
+ let (arg:Il.mem) = fp_imm arg0_disp in
+ inner arg;
+ Hashtbl.remove cx.ctxt_glue_code g;
+ trans_glue_frame_exit fix spill g;
+ fix
+ end
+
+ and get_typed_mem_glue
+ (g:glue)
+ (fty:Ast.ty)
+ (inner:Il.cell -> Il.cell -> unit)
+ : fixup =
+ get_mem_glue g
+ begin
+ fun _ ->
+ let n_ty_params = 0 in
+ let calltup_rty =
+ call_args_referent_type cx n_ty_params fty None
+ in
+ let calltup_cell = caller_args_cell calltup_rty in
+ let out_cell =
+ get_element_ptr calltup_cell Abi.calltup_elt_out_ptr
+ in
+ let args_cell =
+ get_element_ptr calltup_cell Abi.calltup_elt_args
+ in
+ begin
+ match Il.cell_referent_ty args_cell with
+ Il.StructTy az ->
+ assert ((Array.length az)
+ <= Abi.worst_case_glue_call_args);
+ | _ -> bug () "unexpected cell referent ty in glue args"
+ end;
+ inner out_cell args_cell
+ end
+
+ and trace_str b s =
+ if b
+ then
+ begin
+ let static = trans_static_string s in
+ trans_void_upcall "upcall_trace_str" [| static |]
+ end
+
+ and trace_word b w =
+ if b
+ then
+ trans_void_upcall "upcall_trace_word" [| Il.Cell w |]
+
+ and ty_params_covering (t:Ast.ty) : Ast.slot =
+ let n_ty_params = n_used_type_params t in
+ let params = make_tydesc_slots n_ty_params in
+ read_alias_slot (Ast.TY_tup params)
+
+ and get_drop_glue
+ (ty:Ast.ty)
+ (curr_iso:Ast.ty_iso option)
+ : fixup =
+ let g = GLUE_drop ty in
+ let inner _ (args:Il.cell) =
+ let ty_params = deref (get_element_ptr args 0) in
+ let cell = get_element_ptr args 1 in
+ note_drop_step ty "in drop-glue, dropping";
+ trace_word cx.ctxt_sess.Session.sess_trace_drop cell;
+ drop_ty ty_params ty (deref cell) curr_iso;
+ note_drop_step ty "drop-glue complete";
+ in
+ let ty_params_ptr = ty_params_covering ty in
+ let fty = mk_simple_ty_fn [| ty_params_ptr; read_alias_slot ty |] in
+ get_typed_mem_glue g fty inner
+
+
+ and get_free_glue
+ (ty:Ast.ty)
+ (mctrl:mem_ctrl)
+ (curr_iso:Ast.ty_iso option)
+ : fixup =
+ let g = GLUE_free ty in
+ let inner _ (args:Il.cell) =
+ (*
+ * Free-glue assumes it's called with a pointer to an
+ * exterior allocation with normal exterior layout. It's
+ * just a way to move drop+free out of leaf code.
+ *)
+ let ty_params = deref (get_element_ptr args 0) in
+ let cell = get_element_ptr args 1 in
+ let (body_mem, _) =
+ need_mem_cell
+ (get_element_ptr_dyn ty_params (deref cell)
+ Abi.exterior_rc_slot_field_body)
+ in
+ let vr = next_vreg_cell Il.voidptr_t in
+ lea vr body_mem;
+ note_drop_step ty "in free-glue, calling drop-glue on body";
+ trace_word cx.ctxt_sess.Session.sess_trace_drop vr;
+ trans_call_simple_static_glue
+ (get_drop_glue ty curr_iso) ty_params vr;
+ note_drop_step ty "back in free-glue, calling free";
+ if type_has_state ty
+ then
+ note_drop_step ty "type has state"
+ else
+ note_drop_step ty "type has no state";
+ if mctrl = MEM_gc
+ then
+ begin
+ note_drop_step ty "MEM_gc, adjusting pointer";
+ lea vr (fst (need_mem_cell (deref cell)));
+ emit (Il.binary Il.SUB vr (Il.Cell vr)
+ (imm
+ (word_n Abi.exterior_gc_malloc_return_adjustment)));
+ trans_free vr
+ end
+ else
+ begin
+ note_drop_step ty "not MEM_gc";
+ trans_free cell;
+ end;
+ trace_str cx.ctxt_sess.Session.sess_trace_drop
+ "free-glue complete";
+ in
+ let ty_params_ptr = ty_params_covering ty in
+ let fty = mk_simple_ty_fn [| ty_params_ptr; exterior_slot ty |] in
+ get_typed_mem_glue g fty inner
+
+
+ and get_mark_glue
+ (ty:Ast.ty)
+ (curr_iso:Ast.ty_iso option)
+ : fixup =
+ let g = GLUE_mark ty in
+ let inner _ (args:Il.cell) =
+ let ty_params = deref (get_element_ptr args 0) in
+ let cell = get_element_ptr args 1 in
+ mark_ty ty_params ty (deref cell) curr_iso
+ in
+ let ty_params_ptr = ty_params_covering ty in
+ let fty = mk_simple_ty_fn [| ty_params_ptr; read_alias_slot ty |] in
+ get_typed_mem_glue g fty inner
+
+
+ and get_clone_glue
+ (ty:Ast.ty)
+ (curr_iso:Ast.ty_iso option)
+ : fixup =
+ let g = GLUE_clone ty in
+ let inner (out_ptr:Il.cell) (args:Il.cell) =
+ let dst = deref out_ptr in
+ let ty_params = deref (get_element_ptr args 0) in
+ let src = deref (get_element_ptr args 1) in
+ let clone_task = get_element_ptr args 2 in
+ clone_ty ty_params clone_task ty dst src curr_iso
+ in
+ let ty_params_ptr = ty_params_covering ty in
+ let fty =
+ mk_ty_fn
+ (interior_slot ty) (* dst *)
+ [|
+ ty_params_ptr;
+ read_alias_slot ty; (* src *)
+ word_slot (* clone-task *)
+ |]
+ in
+ get_typed_mem_glue g fty inner
+
+
+ and get_copy_glue
+ (ty:Ast.ty)
+ (curr_iso:Ast.ty_iso option)
+ : fixup =
+ let g = GLUE_copy ty in
+ let inner (out_ptr:Il.cell) (args:Il.cell) =
+ let dst = deref out_ptr in
+ let ty_params = deref (get_element_ptr args 0) in
+ let src = deref (get_element_ptr args 1) in
+ copy_ty ty_params ty dst src curr_iso
+ in
+ let ty_params_ptr = ty_params_covering ty in
+ let fty =
+ mk_ty_fn
+ (interior_slot ty)
+ [| ty_params_ptr; read_alias_slot ty |]
+ in
+ get_typed_mem_glue g fty inner
+
+
+ (* Glue functions use mostly the same calling convention as ordinary
+ * functions.
+ *
+ * Each glue function expects its own particular arguments, which are
+ * usually aliases-- ie, caller doesn't transfer ownership to the
+ * glue. And nothing is represented in terms of AST nodes. So we
+ * don't do lvals-and-atoms here.
+ *)
+
+ and trans_call_glue
+ (code:Il.code)
+ (dst:Il.cell option)
+ (args:Il.cell array)
+ : unit =
+ let inner dst =
+ let scratch = next_vreg_cell Il.voidptr_t in
+ let pop _ = emit (Il.Pop scratch) in
+ for i = ((Array.length args) - 1) downto 0
+ do
+ emit (Il.Push (Il.Cell args.(i)))
+ done;
+ emit (Il.Push (Il.Cell abi.Abi.abi_tp_cell));
+ emit (Il.Push dst);
+ call_code code;
+ pop ();
+ pop ();
+ Array.iter (fun _ -> pop()) args;
+ in
+ match dst with
+ None -> inner zero
+ | Some dst -> aliasing true dst (fun dst -> inner (Il.Cell dst))
+
+ and trans_call_static_glue
+ (callee:Il.operand)
+ (dst:Il.cell option)
+ (args:Il.cell array)
+ : unit =
+ trans_call_glue (code_of_operand callee) dst args
+
+ and trans_call_dynamic_glue
+ (tydesc:Il.cell)
+ (idx:int)
+ (dst:Il.cell option)
+ (args:Il.cell array)
+ : unit =
+ let fptr = get_vtbl_entry_idx tydesc idx in
+ trans_call_glue (code_of_operand (Il.Cell fptr)) dst args
+
+ and trans_call_simple_static_glue
+ (fix:fixup)
+ (ty_params:Il.cell)
+ (arg:Il.cell)
+ : unit =
+ trans_call_static_glue
+ (code_fixup_to_ptr_operand fix)
+ None [| alias ty_params; arg |]
+
+ and get_tydesc_params
+ (outer_ty_params:Il.cell)
+ (td:Il.cell)
+ : Il.cell =
+ let first_param =
+ get_element_ptr (deref td) Abi.tydesc_field_first_param
+ in
+ let res = next_vreg_cell Il.voidptr_t in
+ mov res (Il.Cell (alias outer_ty_params));
+ emit (Il.cmp (Il.Cell first_param) zero);
+ let no_param_jmp = mark() in
+ emit (Il.jmp Il.JE Il.CodeNone);
+ mov res (Il.Cell first_param);
+ patch no_param_jmp;
+ res
+
+ and trans_call_simple_dynamic_glue
+ (ty_param:int)
+ (vtbl_idx:int)
+ (ty_params:Il.cell)
+ (arg:Il.cell)
+ : unit =
+ iflog (fun _ ->
+ annotate (Printf.sprintf "calling tydesc[%d].glue[%d]"
+ ty_param vtbl_idx));
+ let td = get_ty_param ty_params ty_param in
+ let ty_params_ptr = get_tydesc_params ty_params td in
+ trans_call_dynamic_glue
+ td vtbl_idx
+ None [| ty_params_ptr; arg; |]
+
+ (* trans_compare returns a quad number of the cjmp, which the caller
+ patches to the cjmp destination. *)
+ and trans_compare
+ (cjmp:Il.jmpop)
+ (lhs:Il.operand)
+ (rhs:Il.operand)
+ : quad_idx list =
+ (* FIXME: this is an x86-ism; abstract via ABI. *)
+ emit (Il.cmp (Il.Cell (Il.Reg (force_to_reg lhs))) rhs);
+ let jmp = mark() in
+ emit (Il.jmp cjmp Il.CodeNone);
+ [jmp]
+
+ and trans_cond (invert:bool) (expr:Ast.expr) : quad_idx list =
+
+ let anno _ =
+ iflog
+ begin
+ fun _ ->
+ annotate ((Ast.fmt_to_str Ast.fmt_expr expr) ^
+ ": cond, finale")
+ end
+ in
+
+ match expr with
+ Ast.EXPR_binary (binop, a, b) ->
+ let lhs = trans_atom a in
+ let rhs = trans_atom b in
+ let cjmp = binop_to_jmpop binop in
+ let cjmp' =
+ if invert then
+ match cjmp with
+ Il.JE -> Il.JNE
+ | Il.JNE -> Il.JE
+ | Il.JL -> Il.JGE
+ | Il.JLE -> Il.JG
+ | Il.JGE -> Il.JL
+ | Il.JG -> Il.JLE
+ | _ -> bug () "Unhandled inverse binop in trans_cond"
+ else
+ cjmp
+ in
+ anno ();
+ trans_compare cjmp' lhs rhs
+
+ | _ ->
+ let bool_operand = trans_expr expr in
+ anno ();
+ trans_compare Il.JNE bool_operand
+ (if invert then imm_true else imm_false)
+
+ and trans_binop (binop:Ast.binop) : Il.binop =
+ match binop with
+ Ast.BINOP_or -> Il.OR
+ | Ast.BINOP_and -> Il.AND
+ | Ast.BINOP_xor -> Il.XOR
+
+ | Ast.BINOP_lsl -> Il.LSL
+ | Ast.BINOP_lsr -> Il.LSR
+ | Ast.BINOP_asr -> Il.ASR
+
+ | Ast.BINOP_add -> Il.ADD
+ | Ast.BINOP_sub -> Il.SUB
+
+ (* FIXME (issue #57):
+ * switch on type of operands, IMUL/IDIV/IMOD etc.
+ *)
+ | Ast.BINOP_mul -> Il.UMUL
+ | Ast.BINOP_div -> Il.UDIV
+ | Ast.BINOP_mod -> Il.UMOD
+ | _ -> bug () "bad binop to Trans.trans_binop"
+
+ and trans_binary
+ (binop:Ast.binop)
+ (lhs:Il.operand)
+ (rhs:Il.operand) : Il.operand =
+ let arith op =
+ let bits = Il.operand_bits word_bits lhs in
+ let dst = Il.Reg (Il.next_vreg (emitter()), Il.ValTy bits) in
+ emit (Il.binary op dst lhs rhs);
+ Il.Cell dst
+ in
+ match binop with
+ Ast.BINOP_or | Ast.BINOP_and | Ast.BINOP_xor
+ | Ast.BINOP_lsl | Ast.BINOP_lsr | Ast.BINOP_asr
+ | Ast.BINOP_add | Ast.BINOP_sub
+ (* FIXME (issue #57):
+ * switch on type of operands, IMUL/IDIV/IMOD etc.
+ *)
+ | Ast.BINOP_mul | Ast.BINOP_div | Ast.BINOP_mod ->
+ arith (trans_binop binop)
+
+ | _ -> let dst = Il.Reg (Il.next_vreg (emitter()), Il.ValTy Il.Bits8) in
+ mov dst imm_true;
+ let jmps = trans_compare (binop_to_jmpop binop) lhs rhs in
+ mov dst imm_false;
+ List.iter patch jmps;
+ Il.Cell dst
+
+
+ and trans_expr (expr:Ast.expr) : Il.operand =
+
+ let anno _ =
+ iflog
+ begin
+ fun _ ->
+ annotate ((Ast.fmt_to_str Ast.fmt_expr expr) ^
+ ": plain exit, finale")
+ end
+ in
+ match expr with
+ Ast.EXPR_binary (binop, a, b) ->
+ assert (is_prim_type (atom_type cx a));
+ assert (is_prim_type (atom_type cx b));
+ trans_binary binop (trans_atom a) (trans_atom b)
+
+ | Ast.EXPR_unary (unop, a) ->
+ assert (is_prim_type (atom_type cx a));
+ let src = trans_atom a in
+ let bits = Il.operand_bits word_bits src in
+ let dst = Il.Reg (Il.next_vreg (emitter()), Il.ValTy bits) in
+ let op = match unop with
+ Ast.UNOP_not
+ | Ast.UNOP_bitnot -> Il.NOT
+ | Ast.UNOP_neg -> Il.NEG
+ | Ast.UNOP_cast t ->
+ let t = Hashtbl.find cx.ctxt_all_cast_types t.id in
+ let at = atom_type cx a in
+ if (type_is_2s_complement at) &&
+ (type_is_2s_complement t)
+ then
+ if type_is_unsigned_2s_complement t
+ then Il.UMOV
+ else Il.IMOV
+ else
+ err None "unsupported cast operator"
+ in
+ anno ();
+ emit (Il.unary op dst src);
+ Il.Cell dst
+
+ | Ast.EXPR_atom a ->
+ trans_atom a
+
+ and trans_block (block:Ast.block) : unit =
+ trace_str cx.ctxt_sess.Session.sess_trace_block
+ "entering block";
+ push_emitter_size_cache ();
+ emit (Il.Enter (Hashtbl.find cx.ctxt_block_fixups block.id));
+ Array.iter trans_stmt block.node;
+ trace_str cx.ctxt_sess.Session.sess_trace_block
+ "exiting block";
+ emit Il.Leave;
+ pop_emitter_size_cache ();
+ trace_str cx.ctxt_sess.Session.sess_trace_block
+ "exited block";
+
+ and upcall_fixup (name:string) : fixup =
+ Semant.require_native cx REQUIRED_LIB_rustrt name;
+
+ and trans_upcall
+ (name:string)
+ (ret:Il.cell)
+ (args:Il.operand array)
+ : unit =
+ abi.Abi.abi_emit_native_call (emitter())
+ ret nabi_rust (upcall_fixup name) args;
+
+ and trans_void_upcall
+ (name:string)
+ (args:Il.operand array)
+ : unit =
+ abi.Abi.abi_emit_native_void_call (emitter())
+ nabi_rust (upcall_fixup name) args;
+
+ and trans_log_int (a:Ast.atom) : unit =
+ trans_void_upcall "upcall_log_int" [| (trans_atom a) |]
+
+ and trans_log_str (a:Ast.atom) : unit =
+ trans_void_upcall "upcall_log_str" [| (trans_atom a) |]
+
+ and trans_spawn
+ ((*initializing*)_:bool)
+ (dst:Ast.lval)
+ (domain:Ast.domain)
+ (fn_lval:Ast.lval)
+ (args:Ast.atom array)
+ : unit =
+ let (task_cell, _) = trans_lval_init dst in
+ let (fptr_operand, fn_ty) = trans_callee fn_lval in
+ (*let fn_ty_params = [| |] in*)
+ let _ =
+ (* FIXME: handle indirect-spawns (clone closure). *)
+ if not (lval_is_direct_fn cx fn_lval)
+ then bug () "unhandled indirect-spawn"
+ in
+ let args_rty = call_args_referent_type cx 0 fn_ty None in
+ let fptr_operand = reify_ptr fptr_operand in
+ let exit_task_glue_fixup = get_exit_task_glue () in
+ let callsz =
+ calculate_sz_in_current_frame (Il.referent_ty_size word_bits args_rty)
+ in
+ let exit_task_glue_fptr =
+ code_fixup_to_ptr_operand exit_task_glue_fixup
+ in
+ let exit_task_glue_fptr = reify_ptr exit_task_glue_fptr in
+
+ iflog (fun _ -> annotate "spawn task: copy args");
+
+ let new_task = next_vreg_cell Il.voidptr_t in
+ let call = { call_ctrl = CALL_indirect;
+ call_callee_ptr = fptr_operand;
+ call_callee_ty = fn_ty;
+ call_callee_ty_params = [| |];
+ call_output = task_cell;
+ call_args = args;
+ call_iterator_args = [| |];
+ call_indirect_args = [| |] }
+ in
+ match domain with
+ Ast.DOMAIN_thread ->
+ begin
+ trans_upcall "upcall_new_thread" new_task [| |];
+ copy_fn_args false (CLONE_all new_task) call;
+ trans_upcall "upcall_start_thread" task_cell
+ [|
+ Il.Cell new_task;
+ exit_task_glue_fptr;
+ fptr_operand;
+ callsz
+ |];
+ end
+ | _ ->
+ begin
+ trans_upcall "upcall_new_task" new_task [| |];
+ copy_fn_args false (CLONE_chan new_task) call;
+ trans_upcall "upcall_start_task" task_cell
+ [|
+ Il.Cell new_task;
+ exit_task_glue_fptr;
+ fptr_operand;
+ callsz
+ |];
+ end;
+ ()
+
+ and get_curr_span _ =
+ if Stack.is_empty curr_stmt
+ then ("<none>", 0, 0)
+ else
+ let stmt_id = Stack.top curr_stmt in
+ match (Session.get_span cx.ctxt_sess stmt_id) with
+ None -> ("<none>", 0, 0)
+ | Some sp -> sp.lo
+
+ and trans_cond_fail (str:string) (fwd_jmps:quad_idx list) : unit =
+ let (filename, line, _) = get_curr_span () in
+ iflog (fun _ -> annotate ("condition-fail: " ^ str));
+ trans_void_upcall "upcall_fail"
+ [|
+ trans_static_string str;
+ trans_static_string filename;
+ imm (Int64.of_int line)
+ |];
+ List.iter patch fwd_jmps
+
+ and trans_check_expr (e:Ast.expr) : unit =
+ let fwd_jmps = trans_cond false e in
+ trans_cond_fail (Ast.fmt_to_str Ast.fmt_expr e) fwd_jmps
+
+ and trans_malloc (dst:Il.cell) (nbytes:Il.operand) : unit =
+ trans_upcall "upcall_malloc" dst [| nbytes |]
+
+ and trans_free (src:Il.cell) : unit =
+ trans_void_upcall "upcall_free" [| Il.Cell src |]
+
+ and trans_yield () : unit =
+ trans_void_upcall "upcall_yield" [| |];
+
+ and trans_fail () : unit =
+ let (filename, line, _) = get_curr_span () in
+ trans_void_upcall "upcall_fail"
+ [|
+ trans_static_string "explicit failure";
+ trans_static_string filename;
+ imm (Int64.of_int line)
+ |];
+
+ and trans_join (task:Ast.lval) : unit =
+ trans_void_upcall "upcall_join" [| trans_atom (Ast.ATOM_lval task) |]
+
+ and trans_send (chan:Ast.lval) (src:Ast.lval) : unit =
+ let (srccell, _) = trans_lval src in
+ aliasing false srccell
+ begin
+ fun src_alias ->
+ trans_void_upcall "upcall_send"
+ [| trans_atom (Ast.ATOM_lval chan);
+ Il.Cell src_alias |];
+ end
+
+ and trans_recv (initializing:bool) (dst:Ast.lval) (chan:Ast.lval) : unit =
+ let (dstcell, _) = trans_lval_maybe_init initializing dst in
+ aliasing true dstcell
+ begin
+ fun dst_alias ->
+ trans_void_upcall "upcall_recv"
+ [| Il.Cell dst_alias;
+ trans_atom (Ast.ATOM_lval chan) |];
+ end
+
+ and trans_init_port (dst:Ast.lval) : unit =
+ let (dstcell, dst_slot) = trans_lval_init dst in
+ let unit_ty = match slot_ty dst_slot with
+ Ast.TY_port t -> t
+ | _ -> bug () "init dst of port-init has non-port type"
+ in
+ let unit_sz = ty_sz abi unit_ty in
+ trans_upcall "upcall_new_port" dstcell [| imm unit_sz |]
+
+ and trans_del_port (port:Il.cell) : unit =
+ trans_void_upcall "upcall_del_port" [| Il.Cell port |]
+
+ and trans_init_chan (dst:Ast.lval) (port:Ast.lval) : unit =
+ let (dstcell, _) = trans_lval_init dst
+ in
+ trans_upcall "upcall_new_chan" dstcell
+ [| trans_atom (Ast.ATOM_lval port) |]
+
+ and trans_del_chan (chan:Il.cell) : unit =
+ trans_void_upcall "upcall_del_chan" [| Il.Cell chan |]
+
+ and trans_kill_task (task:Il.cell) : unit =
+ trans_void_upcall "upcall_kill" [| Il.Cell task |]
+
+ (*
+ * A vec is implicitly exterior: every slot vec[T] is 1 word and
+ * points to a refcounted structure. That structure has 3 words with
+ * defined meaning at the beginning; data follows the header.
+ *
+ * word 0: refcount or gc control word
+ * word 1: allocated size of data
+ * word 2: initialised size of data
+ * word 3...N: data
+ *
+ * This 3-word prefix is shared with strings, we factor the common
+ * part out for reuse in string code.
+ *)
+
+ and trans_init_vec (dst:Ast.lval) (atoms:Ast.atom array) : unit =
+ let (dst_cell, dst_slot) = trans_lval_init dst in
+ let unit_slot = match slot_ty dst_slot with
+ Ast.TY_vec s -> s
+ | _ -> bug () "init dst of vec-init has non-vec type"
+ in
+ let fill = next_vreg_cell word_ty in
+ let unit_sz = slot_sz_in_current_frame unit_slot in
+ umul fill unit_sz (imm (Int64.of_int (Array.length atoms)));
+ trans_upcall "upcall_new_vec" dst_cell [| Il.Cell fill |];
+ let vec = deref dst_cell in
+ let body_mem =
+ fst (need_mem_cell
+ (get_element_ptr_dyn_in_current_frame
+ vec Abi.vec_elt_data))
+ in
+ let unit_rty = slot_referent_type abi unit_slot in
+ let body_rty = Il.StructTy (Array.map (fun _ -> unit_rty) atoms) in
+ let body = Il.Mem (body_mem, body_rty) in
+ Array.iteri
+ begin
+ fun i atom ->
+ let cell = get_element_ptr_dyn_in_current_frame body i in
+ trans_init_slot_from_atom CLONE_none cell unit_slot atom
+ end
+ atoms;
+ mov (get_element_ptr vec Abi.vec_elt_fill) (Il.Cell fill);
+
+ and get_dynamic_tydesc (idopt:node_id option) (t:Ast.ty) : Il.cell =
+ let td = next_vreg_cell Il.voidptr_t in
+ let root_desc =
+ Il.Cell (crate_rel_to_ptr
+ (get_static_tydesc idopt t 0L 0L)
+ (tydesc_rty abi))
+ in
+ let (t, param_descs) = linearize_ty_params t in
+ let descs = Array.append [| root_desc |] param_descs in
+ let n = Array.length descs in
+ let rty = referent_type abi t in
+ let (size_sz, align_sz) = Il.referent_ty_layout word_bits rty in
+ let size = calculate_sz_in_current_frame size_sz in
+ let align = calculate_sz_in_current_frame align_sz in
+ let descs_ptr = next_vreg_cell Il.voidptr_t in
+ if (Array.length descs) > 0
+ then
+ (* FIXME: this relies on knowledge that spills are contiguous. *)
+ let spills =
+ Array.map (fun _ -> next_spill_cell Il.voidptr_t) descs
+ in
+ Array.iteri (fun i t -> mov spills.(n-(i+1)) t) descs;
+ lea descs_ptr (fst (need_mem_cell spills.(n-1)))
+ else
+ mov descs_ptr zero;
+ trans_upcall "upcall_get_type_desc" td
+ [| Il.Cell (curr_crate_ptr());
+ size; align; imm (Int64.of_int n);
+ Il.Cell descs_ptr |];
+ td
+
+ and get_tydesc (idopt:node_id option) (ty:Ast.ty) : Il.cell =
+ log cx "getting tydesc for %a" Ast.sprintf_ty ty;
+ match ty with
+ Ast.TY_param (idx, _) ->
+ (get_ty_param_in_current_frame idx)
+ | t when has_parametric_types t ->
+ (get_dynamic_tydesc idopt t)
+ | _ ->
+ (crate_rel_to_ptr (get_static_tydesc idopt ty
+ (ty_sz abi ty)
+ (ty_align abi ty))
+ (tydesc_rty abi))
+
+ and exterior_ctrl_cell (cell:Il.cell) (off:int) : Il.cell =
+ let (rc_mem, _) = need_mem_cell (deref_imm cell (word_n off)) in
+ word_at rc_mem
+
+ and exterior_rc_cell (cell:Il.cell) : Il.cell =
+ exterior_ctrl_cell cell Abi.exterior_rc_slot_field_refcnt
+
+ and exterior_gc_ctrl_cell (cell:Il.cell) : Il.cell =
+ exterior_ctrl_cell cell Abi.exterior_gc_slot_field_ctrl
+
+ and exterior_gc_next_cell (cell:Il.cell) : Il.cell =
+ exterior_ctrl_cell cell Abi.exterior_gc_slot_field_next
+
+ and exterior_allocation_size
+ (slot:Ast.slot)
+ : Il.operand =
+ let header_sz =
+ match slot_mem_ctrl slot with
+ MEM_gc -> word_n Abi.exterior_gc_header_size
+ | MEM_rc_opaque
+ | MEM_rc_struct -> word_n Abi.exterior_rc_header_size
+ | MEM_interior -> bug () "exterior_allocation_size of MEM_interior"
+ in
+ let t = slot_ty slot in
+ let refty_sz =
+ Il.referent_ty_size abi.Abi.abi_word_bits (referent_type abi t)
+ in
+ match refty_sz with
+ SIZE_fixed _ -> imm (Int64.add (ty_sz abi t) header_sz)
+ | _ ->
+ let ty_params = get_ty_params_of_current_frame() in
+ let refty_sz = calculate_sz ty_params refty_sz in
+ let v = next_vreg word_ty in
+ let vc = Il.Reg (v, word_ty) in
+ mov vc refty_sz;
+ add_to vc (imm header_sz);
+ Il.Cell vc;
+
+ and iter_tag_slots
+ (ty_params:Il.cell)
+ (dst_cell:Il.cell)
+ (src_cell:Il.cell)
+ (ttag:Ast.ty_tag)
+ (f:Il.cell -> Il.cell -> Ast.slot -> (Ast.ty_iso option) -> unit)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ let tag_keys = sorted_htab_keys ttag in
+ let src_tag = get_element_ptr src_cell 0 in
+ let dst_tag = get_element_ptr dst_cell 0 in
+ let src_union = get_element_ptr_dyn ty_params src_cell 1 in
+ let dst_union = get_element_ptr_dyn ty_params dst_cell 1 in
+ let tmp = next_vreg_cell word_ty in
+ f dst_tag src_tag word_slot curr_iso;
+ mov tmp (Il.Cell src_tag);
+ Array.iteri
+ begin
+ fun i key ->
+ (iflog (fun _ ->
+ annotate (Printf.sprintf "tag case #%i == %a" i
+ Ast.sprintf_name key)));
+ let jmps =
+ trans_compare Il.JNE (Il.Cell tmp) (imm (Int64.of_int i))
+ in
+ let ttup = Hashtbl.find ttag key in
+ iter_tup_slots
+ (get_element_ptr_dyn ty_params)
+ (get_variant_ptr dst_union i)
+ (get_variant_ptr src_union i)
+ ttup f curr_iso;
+ List.iter patch jmps
+ end
+ tag_keys
+
+ and get_iso_tag tiso =
+ tiso.Ast.iso_group.(tiso.Ast.iso_index)
+
+
+ and seq_unit_slot (seq:Ast.ty) : Ast.slot =
+ match seq with
+ Ast.TY_vec s -> s
+ | Ast.TY_str -> (interior_slot (Ast.TY_mach TY_u8))
+ | _ -> bug () "seq_unit_slot of non-vec, non-str type"
+
+
+ and iter_seq_slots
+ (ty_params:Il.cell)
+ (dst_cell:Il.cell)
+ (src_cell:Il.cell)
+ (unit_slot:Ast.slot)
+ (f:Il.cell -> Il.cell -> Ast.slot -> (Ast.ty_iso option) -> unit)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ let unit_sz = slot_sz_with_ty_params ty_params unit_slot in
+ (*
+ * Unlike most of the iter_ty_slots helpers; this one allocates a
+ * vreg and so has to be aware of when it's iterating over 2
+ * sequences of cells or just 1.
+ *)
+ check_exterior_rty src_cell;
+ check_exterior_rty dst_cell;
+ if dst_cell = src_cell
+ then
+ begin
+ let src_cell = deref src_cell in
+ let data =
+ get_element_ptr_dyn ty_params src_cell Abi.vec_elt_data
+ in
+ let len = get_element_ptr src_cell Abi.vec_elt_fill in
+ let ptr = next_vreg_cell Il.voidptr_t in
+ let lim = next_vreg_cell Il.voidptr_t in
+ lea lim (fst (need_mem_cell data));
+ mov ptr (Il.Cell lim);
+ add_to lim (Il.Cell len);
+ let back_jmp_target = mark () in
+ let fwd_jmps = trans_compare Il.JAE (Il.Cell ptr) (Il.Cell lim) in
+ let unit_cell =
+ deref (ptr_cast ptr (slot_referent_type abi unit_slot))
+ in
+ f unit_cell unit_cell unit_slot curr_iso;
+ add_to ptr unit_sz;
+ check_interrupt_flag ();
+ emit (Il.jmp Il.JMP (Il.CodeLabel back_jmp_target));
+ List.iter patch fwd_jmps;
+ end
+ else
+ begin
+ bug () "Unsupported form of seq iter: src != dst."
+ end
+
+
+ and iter_ty_slots_full
+ (ty_params:Il.cell)
+ (ty:Ast.ty)
+ (dst_cell:Il.cell)
+ (src_cell:Il.cell)
+ (f:Il.cell -> Il.cell -> Ast.slot -> (Ast.ty_iso option) -> unit)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ (*
+ * FIXME: this will require some reworking if we support
+ * rec, tag or tup slots that fit in a vreg. It requires
+ * addrs presently.
+ *)
+ match ty with
+ Ast.TY_rec entries ->
+ iter_rec_slots
+ (get_element_ptr_dyn ty_params) dst_cell src_cell
+ entries f curr_iso
+
+ | Ast.TY_tup slots ->
+ iter_tup_slots
+ (get_element_ptr_dyn ty_params) dst_cell src_cell
+ slots f curr_iso
+
+ | Ast.TY_tag tag ->
+ iter_tag_slots ty_params dst_cell src_cell tag f curr_iso
+
+ | Ast.TY_iso tiso ->
+ let ttag = get_iso_tag tiso in
+ iter_tag_slots ty_params dst_cell src_cell ttag f (Some tiso)
+
+ | Ast.TY_fn _
+ | Ast.TY_obj _ -> bug () "Attempting to iterate over fn/pred/obj slots"
+
+ | Ast.TY_vec _
+ | Ast.TY_str ->
+ let unit_slot = seq_unit_slot ty in
+ iter_seq_slots ty_params dst_cell src_cell unit_slot f curr_iso
+
+ | _ -> ()
+
+ (*
+ * This just calls iter_ty_slots_full with your cell as both src and
+ * dst, with an adaptor function that discards the dst slots of the
+ * parallel traversal and and calls your provided function on the
+ * passed-in src slots.
+ *)
+ and iter_ty_slots
+ (ty_params:Il.cell)
+ (ty:Ast.ty)
+ (cell:Il.cell)
+ (f:Il.cell -> Ast.slot -> (Ast.ty_iso option) -> unit)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ iter_ty_slots_full ty_params ty cell cell
+ (fun _ src_cell slot curr_iso -> f src_cell slot curr_iso)
+ curr_iso
+
+ and drop_ty
+ (ty_params:Il.cell)
+ (ty:Ast.ty)
+ (cell:Il.cell)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ match ty with
+ Ast.TY_param (i, _) ->
+ iflog (fun _ -> annotate
+ (Printf.sprintf "drop_ty: parametric drop %#d" i));
+ aliasing false cell
+ begin
+ fun cell ->
+ trans_call_simple_dynamic_glue
+ i Abi.tydesc_field_drop_glue ty_params cell
+ end
+
+ | Ast.TY_fn _ ->
+ begin
+ let binding = get_element_ptr cell Abi.binding_field_binding in
+ let null_jmp = null_check binding in
+ (* Drop non-null bindings. *)
+ (* FIXME (issue #58): this is completely wrong,
+ * need a second thunk that generates code to make
+ * use of a runtime type descriptor extracted from
+ * a binding tuple. For now this only works by
+ * accident.
+ *)
+ drop_slot ty_params binding
+ (exterior_slot Ast.TY_int) curr_iso;
+ patch null_jmp
+ end
+
+ | Ast.TY_obj _ ->
+ begin
+ let binding = get_element_ptr cell Abi.binding_field_binding in
+ let null_jmp = null_check binding in
+ let obj = deref binding in
+ let rc = get_element_ptr obj 0 in
+ let rc_jmp = drop_refcount_and_cmp rc in
+ let tydesc = get_element_ptr obj 1 in
+ let body = get_element_ptr obj 2 in
+ let ty_params =
+ get_element_ptr (deref tydesc) Abi.tydesc_field_first_param
+ in
+ let dtor =
+ get_element_ptr (deref tydesc) Abi.tydesc_field_obj_drop_glue
+ in
+ let null_dtor_jmp = null_check dtor in
+ (* Call any dtor, if present. *)
+ trans_call_dynamic_glue tydesc
+ Abi.tydesc_field_obj_drop_glue None [| binding |];
+ patch null_dtor_jmp;
+ (* Drop the body. *)
+ trans_call_dynamic_glue tydesc
+ Abi.tydesc_field_drop_glue None [| ty_params; alias body |];
+ trans_free binding;
+ mov binding zero;
+ patch rc_jmp;
+ patch null_jmp
+ end
+
+
+ | _ ->
+ iter_ty_slots ty_params ty cell (drop_slot ty_params) curr_iso
+
+ and mark_ty
+ (ty_params:Il.cell)
+ (ty:Ast.ty)
+ (cell:Il.cell)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ match ty with
+ | Ast.TY_fn _
+ | Ast.TY_obj _ -> ()
+ | _ ->
+ iter_ty_slots ty_params ty cell (mark_slot ty_params) curr_iso
+
+ and clone_ty
+ (ty_params:Il.cell)
+ (clone_task:Il.cell)
+ (ty:Ast.ty)
+ (dst:Il.cell)
+ (src:Il.cell)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ match ty with
+ Ast.TY_chan _ ->
+ trans_upcall "upcall_clone_chan" dst
+ [| (Il.Cell clone_task); (Il.Cell src) |]
+ | Ast.TY_task
+ | Ast.TY_port _
+ | _ when type_has_state ty
+ -> bug () "cloning mutable type"
+ | _ when i64_le (ty_sz abi ty) word_sz
+ -> mov dst (Il.Cell src)
+ | Ast.TY_fn _
+ | Ast.TY_obj _ -> ()
+ | _ ->
+ iter_ty_slots_full ty_params ty dst src
+ (clone_slot ty_params clone_task) curr_iso
+
+ and copy_ty
+ (ty_params:Il.cell)
+ (ty:Ast.ty)
+ (dst:Il.cell)
+ (src:Il.cell)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ iflog (fun _ ->
+ annotate ("copy_ty: referent data of type " ^
+ (Ast.fmt_to_str Ast.fmt_ty ty)));
+ match ty with
+ Ast.TY_nil
+ | Ast.TY_bool
+ | Ast.TY_mach _
+ | Ast.TY_int
+ | Ast.TY_uint
+ | Ast.TY_native _
+ | Ast.TY_type
+ | Ast.TY_char ->
+ iflog
+ (fun _ -> annotate
+ (Printf.sprintf "copy_ty: simple mov (%Ld byte scalar)"
+ (ty_sz abi ty)));
+ mov dst (Il.Cell src)
+
+ | Ast.TY_param (i, _) ->
+ iflog
+ (fun _ -> annotate
+ (Printf.sprintf "copy_ty: parametric copy %#d" i));
+ aliasing false src
+ begin
+ fun src ->
+ let td = get_ty_param ty_params i in
+ let ty_params_ptr = get_tydesc_params ty_params td in
+ trans_call_dynamic_glue
+ td Abi.tydesc_field_copy_glue
+ (Some dst) [| ty_params_ptr; src; |]
+ end
+
+ | Ast.TY_fn _
+ | Ast.TY_obj _ ->
+ begin
+ let src_item = get_element_ptr src Abi.binding_field_item in
+ let dst_item = get_element_ptr dst Abi.binding_field_item in
+ let src_binding = get_element_ptr src Abi.binding_field_binding in
+ let dst_binding = get_element_ptr dst Abi.binding_field_binding in
+ mov dst_item (Il.Cell src_item);
+ let null_jmp = null_check src_binding in
+ (* Copy if we have a src binding. *)
+ (* FIXME (issue #58): this is completely wrong, call
+ * through to the binding's self-copy fptr. For now
+ * this only works by accident.
+ *)
+ trans_copy_slot ty_params true
+ dst_binding (exterior_slot Ast.TY_int)
+ src_binding (exterior_slot Ast.TY_int)
+ curr_iso;
+ patch null_jmp
+ end
+
+ | _ ->
+ iter_ty_slots_full ty_params ty dst src
+ (fun dst src slot curr_iso ->
+ trans_copy_slot ty_params true
+ dst slot src slot curr_iso)
+ curr_iso
+
+ and free_ty
+ (ty_params:Il.cell)
+ (ty:Ast.ty)
+ (cell:Il.cell)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ match ty with
+ Ast.TY_port _ -> trans_del_port cell
+ | Ast.TY_chan _ -> trans_del_chan cell
+ | Ast.TY_task -> trans_kill_task cell
+ | Ast.TY_vec s ->
+ iter_seq_slots ty_params cell cell s
+ (fun _ src slot iso -> drop_slot ty_params src slot iso) curr_iso;
+ trans_free cell
+
+ | _ -> trans_free cell
+
+ and maybe_iso
+ (curr_iso:Ast.ty_iso option)
+ (t:Ast.ty)
+ : Ast.ty =
+ match (curr_iso, t) with
+ (Some iso, Ast.TY_idx n) ->
+ Ast.TY_iso { iso with Ast.iso_index = n }
+ | (None, Ast.TY_idx _) ->
+ bug () "TY_idx outside TY_iso"
+ | _ -> t
+
+ and maybe_enter_iso
+ (t:Ast.ty)
+ (curr_iso:Ast.ty_iso option)
+ : Ast.ty_iso option =
+ match t with
+ Ast.TY_iso tiso -> Some tiso
+ | _ -> curr_iso
+
+ and mark_slot
+ (ty_params:Il.cell)
+ (cell:Il.cell)
+ (slot:Ast.slot)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ let ty = slot_ty slot in
+ match slot_mem_ctrl slot with
+ MEM_gc ->
+ note_gc_step slot "mark GC slot: check for null:";
+ emit (Il.cmp (Il.Cell cell) zero);
+ let null_cell_jump = mark () in
+ emit (Il.jmp Il.JE Il.CodeNone);
+ let gc_word = exterior_gc_ctrl_cell cell in
+ let tmp = next_vreg_cell Il.voidptr_t in
+ (* if this has been marked already, jump to exit.*)
+ note_gc_step slot "mark GC slot: check for mark:";
+ emit (Il.binary Il.AND tmp (Il.Cell gc_word) one);
+ let already_marked_jump = mark () in
+ emit (Il.jmp Il.JZ Il.CodeNone);
+ (* Set mark bit in allocation header. *)
+ note_gc_step slot "mark GC slot: mark:";
+ emit (Il.binary Il.OR gc_word (Il.Cell gc_word) one);
+ (* Iterate over exterior slots marking outgoing links. *)
+ log cx "slot rty: %s" (cell_str cell);
+ let (body_mem, _) =
+ need_mem_cell
+ (get_element_ptr (deref cell)
+ Abi.exterior_gc_slot_field_body)
+ in
+ let ty = maybe_iso curr_iso ty in
+ let curr_iso = maybe_enter_iso ty curr_iso in
+ lea tmp body_mem;
+ trans_call_simple_static_glue
+ (get_mark_glue ty curr_iso)
+ ty_params tmp;
+ patch null_cell_jump;
+ patch already_marked_jump;
+ note_gc_step slot "mark GC slot: done marking:";
+
+ | MEM_interior when type_is_structured ty ->
+ (iflog (fun _ ->
+ annotate ("mark interior slot " ^
+ (Ast.fmt_to_str Ast.fmt_slot slot))));
+ let (mem, _) = need_mem_cell cell in
+ let tmp = next_vreg_cell Il.voidptr_t in
+ let ty = maybe_iso curr_iso ty in
+ let curr_iso = maybe_enter_iso ty curr_iso in
+ lea tmp mem;
+ trans_call_simple_static_glue
+ (get_mark_glue ty curr_iso)
+ ty_params tmp
+
+ | _ -> ()
+
+ and check_exterior_rty cell =
+ match cell with
+ Il.Reg (_, Il.AddrTy (Il.StructTy fields))
+ | Il.Mem (_, Il.ScalarTy (Il.AddrTy (Il.StructTy fields)))
+ when (((Array.length fields) > 0) && (fields.(0) = word_rty)) -> ()
+ | _ -> bug ()
+ "expected plausibly-exterior cell, got %s"
+ (Il.string_of_referent_ty (Il.cell_referent_ty cell))
+
+ and clone_slot
+ (ty_params:Il.cell)
+ (clone_task:Il.cell)
+ (dst:Il.cell)
+ (src:Il.cell)
+ (dst_slot:Ast.slot)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ let ty = slot_ty dst_slot in
+ match dst_slot.Ast.slot_mode with
+ Ast.MODE_exterior _ ->
+ let ty = maybe_iso curr_iso ty in
+ let curr_iso = maybe_enter_iso ty curr_iso in
+ let dst = deref_slot true dst dst_slot in
+ let glue_fix = get_clone_glue (slot_ty dst_slot) curr_iso in
+ trans_call_static_glue
+ (code_fixup_to_ptr_operand glue_fix)
+ (Some dst)
+ [| alias ty_params; src; clone_task |]
+
+ | Ast.MODE_alias _ -> bug () "cloning into alias slot"
+ | Ast.MODE_interior _ ->
+ clone_ty ty_params clone_task ty dst src curr_iso
+
+ and drop_slot_in_current_frame
+ (cell:Il.cell)
+ (slot:Ast.slot)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ drop_slot (get_ty_params_of_current_frame()) cell slot curr_iso
+
+ and null_check (cell:Il.cell) : quad_idx =
+ emit (Il.cmp (Il.Cell cell) zero);
+ let j = mark() in
+ emit (Il.jmp Il.JE Il.CodeNone);
+ j
+
+ and drop_refcount_and_cmp (rc:Il.cell) : quad_idx =
+ iflog (fun _ -> annotate "drop refcount and maybe free");
+ emit (Il.binary Il.SUB rc (Il.Cell rc) one);
+ emit (Il.cmp (Il.Cell rc) zero);
+ let j = mark () in
+ emit (Il.jmp Il.JNE Il.CodeNone);
+ j
+
+ and drop_slot
+ (ty_params:Il.cell)
+ (cell:Il.cell)
+ (slot:Ast.slot)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ let ty = slot_ty slot in
+ let ty = maybe_iso curr_iso ty in
+ let curr_iso = maybe_enter_iso ty curr_iso in
+ let slot = {slot with Ast.slot_ty = Some ty} in
+ let mctrl = slot_mem_ctrl slot in
+ match mctrl with
+ MEM_rc_opaque ->
+ (* Refcounted opaque objects we handle without glue functions. *)
+ let _ = check_exterior_rty cell in
+ let null_jmp = null_check cell in
+ let j = drop_refcount_and_cmp (exterior_rc_cell cell) in
+ free_ty ty_params ty cell curr_iso;
+ (* Null the slot out to prevent double-free if the frame
+ * unwinds.
+ *)
+ mov cell zero;
+ patch j;
+ patch null_jmp
+
+ | MEM_gc
+ | MEM_rc_struct ->
+ (* Refcounted "structured exterior" objects we handle via
+ * glue functions.
+ *)
+
+ (*
+ * 'GC memory' is treated similarly, just happens to have
+ * an extra couple cells on the front.
+ *)
+
+ (* FIXME (issue #25): check to see that the exterior has
+ * further exterior members; if it doesn't we can elide the
+ * call to the glue function. *)
+ let _ = check_exterior_rty cell in
+ let null_jmp = null_check cell in
+ let rc = exterior_rc_cell cell in
+ let _ = note_gc_step slot "dropping refcount on " in
+ let _ = trace_word cx.ctxt_sess.Session.sess_trace_gc rc in
+ let j = drop_refcount_and_cmp rc in
+ trans_call_simple_static_glue
+ (get_free_glue ty mctrl curr_iso)
+ ty_params cell;
+ (* Null the slot out to prevent double-free if the frame
+ * unwinds.
+ *)
+ mov cell zero;
+ patch j;
+ patch null_jmp
+
+ | MEM_interior when type_is_structured ty ->
+ (iflog (fun _ ->
+ annotate ("drop interior slot " ^
+ (Ast.fmt_to_str Ast.fmt_slot slot))));
+ let (mem, _) = need_mem_cell cell in
+ let vr = next_vreg_cell Il.voidptr_t in
+ lea vr mem;
+ trans_call_simple_static_glue
+ (get_drop_glue ty curr_iso)
+ ty_params vr
+
+ | MEM_interior ->
+ (* Interior allocation of all-interior value: free directly. *)
+ let ty = maybe_iso curr_iso ty in
+ drop_ty ty_params ty cell curr_iso
+
+ and note_drop_step ty step =
+ if cx.ctxt_sess.Session.sess_trace_drop ||
+ cx.ctxt_sess.Session.sess_log_trans
+ then
+ let slotstr = Ast.fmt_to_str Ast.fmt_ty ty in
+ let str = step ^ " " ^ slotstr in
+ begin
+ annotate str;
+ trace_str cx.ctxt_sess.Session.sess_trace_drop str
+ end
+
+ and note_gc_step slot step =
+ if cx.ctxt_sess.Session.sess_trace_gc ||
+ cx.ctxt_sess.Session.sess_log_trans
+ then
+ let mctrl_str =
+ match slot_mem_ctrl slot with
+ MEM_gc -> "MEM_gc"
+ | MEM_rc_struct -> "MEM_rc_struct"
+ | MEM_rc_opaque -> "MEM_rc_struct"
+ | MEM_interior -> "MEM_rc_struct"
+ in
+ let slotstr = Ast.fmt_to_str Ast.fmt_slot slot in
+ let str = step ^ " " ^ mctrl_str ^ " " ^ slotstr in
+ begin
+ annotate str;
+ trace_str cx.ctxt_sess.Session.sess_trace_gc str
+ end
+
+ (* Returns the offset of the slot-body in the initialized allocation. *)
+ and init_exterior_slot (cell:Il.cell) (slot:Ast.slot) : unit =
+ match slot_mem_ctrl slot with
+ MEM_gc ->
+ iflog (fun _ -> annotate "init GC exterior: malloc");
+ let sz = exterior_allocation_size slot in
+ (*
+ * Malloc and then immediately shift down to point to
+ * the pseudo-rc cell.
+ *)
+ note_gc_step slot "init GC exterior: malloc slot:";
+ trans_malloc cell sz;
+ add_to cell
+ (imm (word_n Abi.exterior_gc_malloc_return_adjustment));
+ note_gc_step slot "init GC exterior: load control word";
+ let ctrl = exterior_gc_ctrl_cell cell in
+ let tydesc = get_tydesc None (slot_ty slot) in
+ let rc = exterior_rc_cell cell in
+ note_gc_step slot "init GC exterior: set refcount";
+ mov rc one;
+ trace_word cx.ctxt_sess.Session.sess_trace_gc rc;
+ mov ctrl (Il.Cell tydesc);
+ note_gc_step slot "init GC exterior: load chain next-ptr";
+ let next = exterior_gc_next_cell cell in
+ let chain = tp_imm (word_n Abi.task_field_gc_alloc_chain) in
+ mov next (Il.Cell chain);
+ note_gc_step slot "init GC exterior: link GC mem to chain";
+ mov chain (Il.Cell cell);
+ note_gc_step slot "init GC exterior: done initializing"
+
+ | MEM_rc_opaque
+ | MEM_rc_struct ->
+ iflog (fun _ -> annotate "init RC exterior: malloc");
+ let sz = exterior_allocation_size slot in
+ trans_malloc cell sz;
+ iflog (fun _ -> annotate "init RC exterior: load refcount");
+ let rc = exterior_rc_cell cell in
+ mov rc one
+
+ | MEM_interior -> bug () "init_exterior_slot of MEM_interior"
+
+ and deref_slot
+ (initializing:bool)
+ (cell:Il.cell)
+ (slot:Ast.slot)
+ : Il.cell =
+ match slot.Ast.slot_mode with
+ Ast.MODE_interior _ ->
+ cell
+
+ | Ast.MODE_exterior _ ->
+ check_exterior_rty cell;
+ if initializing
+ then init_exterior_slot cell slot;
+ get_element_ptr_dyn_in_current_frame
+ (deref cell)
+ Abi.exterior_rc_slot_field_body
+
+ | Ast.MODE_alias _ ->
+ if initializing
+ then cell
+ else deref cell
+
+ and trans_copy_tup
+ (ty_params:Il.cell)
+ (initializing:bool)
+ (dst:Il.cell)
+ (src:Il.cell)
+ (slots:Ast.ty_tup)
+ : unit =
+ Array.iteri
+ begin
+ fun i slot ->
+ let sub_dst_cell = get_element_ptr_dyn ty_params dst i in
+ let sub_src_cell = get_element_ptr_dyn ty_params src i in
+ trans_copy_slot
+ ty_params initializing
+ sub_dst_cell slot sub_src_cell slot None
+ end
+ slots
+
+ and trans_copy_slot
+ (ty_params:Il.cell)
+ (initializing:bool)
+ (dst:Il.cell) (dst_slot:Ast.slot)
+ (src:Il.cell) (src_slot:Ast.slot)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ let anno (weight:string) : unit =
+ iflog
+ begin
+ fun _ ->
+ annotate
+ (Printf.sprintf "%sweight copy: %a <- %a"
+ weight
+ Ast.sprintf_slot dst_slot
+ Ast.sprintf_slot src_slot)
+ end;
+ in
+ assert (slot_ty src_slot = slot_ty dst_slot);
+ match (slot_mem_ctrl src_slot,
+ slot_mem_ctrl dst_slot) with
+
+ | (MEM_rc_opaque, MEM_rc_opaque)
+ | (MEM_gc, MEM_gc)
+ | (MEM_rc_struct, MEM_rc_struct) ->
+ (* Lightweight copy: twiddle refcounts, move pointer. *)
+ anno "refcounted light";
+ add_to (exterior_rc_cell src) one;
+ if not initializing
+ then
+ drop_slot ty_params dst dst_slot None;
+ mov dst (Il.Cell src)
+
+ | _ ->
+ (* Heavyweight copy: duplicate 1 level of the referent. *)
+ anno "heavy";
+ trans_copy_slot_heavy ty_params initializing
+ dst dst_slot src src_slot curr_iso
+
+ (* NB: heavyweight copying here does not mean "producing a deep
+ * clone of the entire data tree rooted at the src operand". It means
+ * "replicating a single level of the tree".
+ *
+ * There is no general-recursion entailed in performing a heavy
+ * copy. There is only "one level" to each heavy copy call.
+ *
+ * In other words, this is a lightweight copy:
+ *
+ * [dstptr] <-copy- [srcptr]
+ * \ |
+ * \ |
+ * [some record.rc++]
+ * |
+ * [some other record]
+ *
+ * Whereas this is a heavyweight copy:
+ *
+ * [dstptr] <-copy- [srcptr]
+ * | |
+ * | |
+ * [some record] [some record]
+ * | |
+ * [some other record]
+ *
+ *)
+
+ and trans_copy_slot_heavy
+ (ty_params:Il.cell)
+ (initializing:bool)
+ (dst:Il.cell) (dst_slot:Ast.slot)
+ (src:Il.cell) (src_slot:Ast.slot)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ assert (slot_ty src_slot = slot_ty dst_slot);
+ iflog (fun _ ->
+ annotate ("heavy copy: slot preparation"));
+
+ let ty = slot_ty src_slot in
+ let ty = maybe_iso curr_iso ty in
+ let curr_iso = maybe_enter_iso ty curr_iso in
+ let dst_slot = { dst_slot with Ast.slot_ty = Some ty } in
+ let src_slot = { src_slot with Ast.slot_ty = Some ty } in
+ let dst = deref_slot initializing dst dst_slot in
+ let src = deref_slot false src src_slot in
+ copy_ty ty_params ty dst src curr_iso
+
+ and trans_copy
+ (initializing:bool)
+ (dst:Ast.lval)
+ (src:Ast.expr)
+ : unit =
+ let (dst_cell, dst_slot) = trans_lval_maybe_init initializing dst in
+ match (slot_ty dst_slot, src) with
+ (Ast.TY_vec _,
+ Ast.EXPR_binary (Ast.BINOP_add,
+ Ast.ATOM_lval a, Ast.ATOM_lval b))
+ | (Ast.TY_str,
+ Ast.EXPR_binary (Ast.BINOP_add,
+ Ast.ATOM_lval a, Ast.ATOM_lval b)) ->
+ (*
+ * Translate str or vec
+ *
+ * s = a + b
+ *
+ * as
+ *
+ * s = a;
+ * s += b;
+ *)
+ let (a_cell, a_slot) = trans_lval a in
+ let (b_cell, b_slot) = trans_lval b in
+ trans_copy_slot
+ (get_ty_params_of_current_frame())
+ initializing dst_cell dst_slot
+ a_cell a_slot None;
+ trans_vec_append dst_cell dst_slot
+ (Il.Cell b_cell) (slot_ty b_slot)
+
+
+ | (Ast.TY_obj caller_obj_ty,
+ Ast.EXPR_unary (Ast.UNOP_cast t, a)) ->
+ let src_ty = atom_type cx a in
+ let _ = assert (not (is_prim_type (src_ty))) in
+ begin
+ let t = Hashtbl.find cx.ctxt_all_cast_types t.id in
+ let _ = assert (t = (Ast.TY_obj caller_obj_ty)) in
+ let callee_obj_ty =
+ match atom_type cx a with
+ Ast.TY_obj t -> t
+ | _ -> bug () "obj cast from non-obj type"
+ in
+ let src_cell = need_cell (trans_atom a) in
+ let src_slot = interior_slot src_ty in
+
+ (* FIXME: this is wrong. It treats the underlying obj-state
+ * as the same as the callee and simply substitutes the
+ * forwarding vtbl, which would be great if it had any way
+ * convey the callee vtbl to the forwarding functions. But it
+ * doesn't. Instead, we have to malloc a fresh 3-word
+ * refcounted obj to hold the callee's vtbl+state pair, copy
+ * that in as the state here.
+ *)
+ let _ =
+ trans_copy_slot (get_ty_params_of_current_frame())
+ initializing
+ dst_cell dst_slot
+ src_cell src_slot
+ in
+ let caller_vtbl_oper =
+ get_forwarding_vtbl caller_obj_ty callee_obj_ty
+ in
+ let caller_obj =
+ deref_slot initializing dst_cell dst_slot
+ in
+ let caller_vtbl =
+ get_element_ptr caller_obj Abi.binding_field_item
+ in
+ mov caller_vtbl caller_vtbl_oper
+ end
+
+ | (_, Ast.EXPR_binary _)
+ | (_, Ast.EXPR_unary _)
+ | (_, Ast.EXPR_atom (Ast.ATOM_literal _)) ->
+ (*
+ * Translations of these expr types yield vregs,
+ * so copy is just MOV into the lval.
+ *)
+ let src_operand = trans_expr src in
+ mov (deref_slot false dst_cell dst_slot) src_operand
+
+ | (_, Ast.EXPR_atom (Ast.ATOM_lval src_lval)) ->
+ if lval_is_direct_fn cx src_lval then
+ trans_copy_direct_fn dst_cell src_lval
+ else
+ (* Possibly-large structure copying *)
+ let (src_cell, src_slot) = trans_lval src_lval in
+ trans_copy_slot
+ (get_ty_params_of_current_frame())
+ initializing
+ dst_cell dst_slot
+ src_cell src_slot
+ None
+
+ and trans_copy_direct_fn
+ (dst_cell:Il.cell)
+ (flv:Ast.lval)
+ : unit =
+ let item = lval_item cx flv in
+ let fix = Hashtbl.find cx.ctxt_fn_fixups item.id in
+
+ let dst_pair_item_cell =
+ get_element_ptr dst_cell Abi.binding_field_item
+ in
+ let dst_pair_binding_cell =
+ get_element_ptr dst_cell Abi.binding_field_binding
+ in
+
+ mov dst_pair_item_cell (crate_rel_imm fix);
+ mov dst_pair_binding_cell zero
+
+
+ and trans_init_structural_from_atoms
+ (dst:Il.cell)
+ (dst_slots:Ast.slot array)
+ (atoms:Ast.atom array)
+ : unit =
+ Array.iteri
+ begin
+ fun i atom ->
+ trans_init_slot_from_atom
+ CLONE_none
+ (get_element_ptr_dyn_in_current_frame dst i)
+ dst_slots.(i)
+ atom
+ end
+ atoms
+
+ and trans_init_rec_update
+ (dst:Il.cell)
+ (dst_slots:Ast.slot array)
+ (trec:Ast.ty_rec)
+ (atab:(Ast.ident * Ast.mode * bool * Ast.atom) array)
+ (base:Ast.lval)
+ : unit =
+ Array.iteri
+ begin
+ fun i (fml_ident, _) ->
+ let fml_entry _ (act_ident, _, _, atom) =
+ if act_ident = fml_ident then Some atom else None
+ in
+ let slot = dst_slots.(i) in
+ match arr_search atab fml_entry with
+ Some atom ->
+ trans_init_slot_from_atom
+ CLONE_none
+ (get_element_ptr_dyn_in_current_frame dst i)
+ slot
+ atom
+ | None ->
+ let (src, _) = trans_lval base in
+ trans_copy_slot
+ (get_ty_params_of_current_frame()) true
+ (get_element_ptr_dyn_in_current_frame dst i) slot
+ (get_element_ptr_dyn_in_current_frame src i) slot
+ None
+ end
+ trec
+
+ and trans_init_slot_from_atom
+ (clone:clone_ctrl)
+ (dst:Il.cell) (dst_slot:Ast.slot)
+ (atom:Ast.atom)
+ : unit =
+ let is_alias_cell =
+ match dst_slot.Ast.slot_mode with
+ Ast.MODE_alias _ -> true
+ | _ -> false
+ in
+ match atom with
+ | Ast.ATOM_literal _ ->
+ let src = trans_atom atom in
+ if is_alias_cell
+ then
+ match clone with
+ CLONE_none ->
+ (*
+ * FIXME: this won't work on mutable aliases, it
+ * doesn't know to reload. Try something
+ * else.
+ *)
+ mov dst (Il.Cell (alias (Il.Mem (force_to_mem src))))
+ | _ ->
+ bug () "attempting to clone alias cell"
+ else
+ mov (deref_slot true dst dst_slot) src
+ | Ast.ATOM_lval src_lval ->
+ let (src, src_slot) = trans_lval src_lval in
+ trans_init_slot_from_cell clone dst dst_slot src src_slot
+
+ and trans_init_slot_from_cell
+ (clone:clone_ctrl)
+ (dst:Il.cell) (dst_slot:Ast.slot)
+ (src:Il.cell) (src_slot:Ast.slot)
+ : unit =
+ assert (slot_ty src_slot = slot_ty dst_slot);
+ let is_alias_cell =
+ match dst_slot.Ast.slot_mode with
+ Ast.MODE_alias _ -> true
+ | _ -> false
+ in
+ match clone with
+ CLONE_chan clone_task ->
+ let clone =
+ if (type_contains_chan (slot_ty src_slot))
+ then CLONE_all clone_task
+ else CLONE_none
+ in
+ trans_init_slot_from_cell clone dst dst_slot src src_slot
+ | CLONE_none ->
+ if is_alias_cell
+ then mov dst (Il.Cell (alias src))
+ else
+ trans_copy_slot
+ (get_ty_params_of_current_frame())
+ true dst dst_slot src src_slot None
+ | CLONE_all clone_task ->
+ if is_alias_cell
+ then bug () "attempting to clone alias cell"
+ else
+ clone_slot
+ (get_ty_params_of_current_frame())
+ clone_task dst src dst_slot None
+
+ and trans_be_fn
+ (cx:ctxt)
+ (dst_cell:Il.cell)
+ (flv:Ast.lval)
+ (ty_params:Ast.ty array)
+ (args:Ast.atom array)
+ : unit =
+ let (ptr, fn_ty) = trans_callee flv in
+ let cc = call_ctrl flv in
+ let call = { call_ctrl = cc;
+ call_callee_ptr = ptr;
+ call_callee_ty = fn_ty;
+ call_callee_ty_params = ty_params;
+ call_output = dst_cell;
+ call_args = args;
+ call_iterator_args = call_iterator_args None;
+ call_indirect_args = call_indirect_args flv cc }
+ in
+ (* FIXME: true if caller is object fn *)
+ let caller_is_closure = false in
+ log cx "trans_be_fn: %s call to lval %a"
+ (call_ctrl_string cc) Ast.sprintf_lval flv;
+ trans_be (fun () -> Ast.sprintf_lval () flv) caller_is_closure call
+
+ and trans_prepare_fn_call
+ (initializing:bool)
+ (cx:ctxt)
+ (dst_cell:Il.cell)
+ (flv:Ast.lval)
+ (ty_params:Ast.ty array)
+ (fco:for_each_ctrl option)
+ (args:Ast.atom array)
+ : Il.operand =
+ let (ptr, fn_ty) = trans_callee flv in
+ let cc = call_ctrl flv in
+ let call = { call_ctrl = cc;
+ call_callee_ptr = ptr;
+ call_callee_ty = fn_ty;
+ call_callee_ty_params = ty_params;
+ call_output = dst_cell;
+ call_args = args;
+ call_iterator_args = call_iterator_args fco;
+ call_indirect_args = call_indirect_args flv cc }
+ in
+ iflog
+ begin
+ fun _ ->
+ log cx "trans_prepare_fn_call: %s call to lval %a"
+ (call_ctrl_string cc) Ast.sprintf_lval flv;
+ log cx "lval type: %a" Ast.sprintf_ty fn_ty;
+ Array.iteri (fun i t -> log cx "ty param %d = %a"
+ i Ast.sprintf_ty t)
+ ty_params;
+ end;
+ trans_prepare_call initializing (fun () -> Ast.sprintf_lval () flv) call
+
+ and trans_call_pred_and_check
+ (constr:Ast.constr)
+ (flv:Ast.lval)
+ (args:Ast.atom array)
+ : unit =
+ let (ptr, fn_ty) = trans_callee flv in
+ let dst_cell = Il.Mem (force_to_mem imm_false) in
+ let call = { call_ctrl = call_ctrl flv;
+ call_callee_ptr = ptr;
+ call_callee_ty = fn_ty;
+ call_callee_ty_params = [| |];
+ call_output = dst_cell;
+ call_args = args;
+ call_iterator_args = [| |];
+ call_indirect_args = [| |] }
+ in
+ iflog (fun _ -> annotate "predicate call");
+ let fn_ptr =
+ trans_prepare_call true (fun _ -> Ast.sprintf_lval () flv) call
+ in
+ call_code (code_of_operand fn_ptr);
+ iflog (fun _ -> annotate "predicate check/fail");
+ let jmp = trans_compare Il.JE (Il.Cell dst_cell) imm_true in
+ let errstr = Printf.sprintf "predicate check: %a"
+ Ast.sprintf_constr constr
+ in
+ trans_cond_fail errstr jmp
+
+ and trans_init_closure
+ (closure_cell:Il.cell)
+ (target_fn_ptr:Il.operand)
+ (target_binding_ptr:Il.operand)
+ (bound_arg_slots:Ast.slot array)
+ (bound_args:Ast.atom array)
+ : unit =
+
+ let rc_cell = get_element_ptr closure_cell 0 in
+ let targ_cell = get_element_ptr closure_cell 1 in
+ let args_cell = get_element_ptr closure_cell 2 in
+
+ iflog (fun _ -> annotate "init closure refcount");
+ mov rc_cell one;
+ iflog (fun _ -> annotate "set closure target code ptr");
+ mov (get_element_ptr targ_cell 0) (reify_ptr target_fn_ptr);
+ iflog (fun _ -> annotate "set closure target binding ptr");
+ mov (get_element_ptr targ_cell 1) (reify_ptr target_binding_ptr);
+
+ iflog (fun _ -> annotate "set closure bound args");
+ copy_bound_args args_cell bound_arg_slots bound_args
+
+ and trans_bind_fn
+ (initializing:bool)
+ (cc:call_ctrl)
+ (bind_id:node_id)
+ (dst:Ast.lval)
+ (flv:Ast.lval)
+ (fn_sig:Ast.ty_sig)
+ (args:Ast.atom option array)
+ : unit =
+ let (dst_cell, _) = trans_lval_maybe_init initializing dst in
+ let (target_ptr, _) = trans_callee flv in
+ let arg_bound_flags = Array.map bool_of_option args in
+ let arg_slots =
+ arr_map2
+ (fun arg_slot bound_flag ->
+ if bound_flag then Some arg_slot else None)
+ fn_sig.Ast.sig_input_slots
+ arg_bound_flags
+ in
+ let bound_arg_slots = arr_filter_some arg_slots in
+ let bound_args = arr_filter_some args in
+ let glue_fixup =
+ get_fn_binding_glue bind_id fn_sig.Ast.sig_input_slots arg_bound_flags
+ in
+ let target_fn_ptr = callee_fn_ptr target_ptr cc in
+ let target_binding_ptr = callee_binding_ptr flv cc in
+ let closure_rty = closure_referent_type bound_arg_slots in
+ let closure_sz = force_sz (Il.referent_ty_size word_bits closure_rty) in
+ let fn_cell = get_element_ptr dst_cell Abi.binding_field_item in
+ let closure_cell =
+ ptr_cast
+ (get_element_ptr dst_cell Abi.binding_field_binding)
+ (Il.ScalarTy (Il.AddrTy (closure_rty)))
+ in
+ iflog (fun _ -> annotate "assign glue-code to fn slot of pair");
+ mov fn_cell (crate_rel_imm glue_fixup);
+ iflog (fun _ ->
+ annotate "heap-allocate closure to binding slot of pair");
+ trans_malloc closure_cell (imm closure_sz);
+ trans_init_closure
+ (deref closure_cell)
+ target_fn_ptr target_binding_ptr
+ bound_arg_slots bound_args
+
+
+ and trans_arg0 (arg_cell:Il.cell) (output_cell:Il.cell) : unit =
+ (* Emit arg0 of any call: the output slot. *)
+ iflog (fun _ -> annotate "fn-call arg 0: output slot");
+ trans_init_slot_from_cell
+ CLONE_none
+ arg_cell (word_write_alias_slot abi)
+ output_cell word_slot
+
+ and trans_arg1 (arg_cell:Il.cell) : unit =
+ (* Emit arg1 of any call: the task pointer. *)
+ iflog (fun _ -> annotate "fn-call arg 1: task pointer");
+ trans_init_slot_from_cell
+ CLONE_none
+ arg_cell word_slot
+ abi.Abi.abi_tp_cell word_slot
+
+ and trans_argN
+ (clone:clone_ctrl)
+ (arg_cell:Il.cell)
+ (arg_slot:Ast.slot)
+ (arg:Ast.atom)
+ : unit =
+ trans_init_slot_from_atom clone arg_cell arg_slot arg
+
+ and code_of_cell (cell:Il.cell) : Il.code =
+ match cell with
+ Il.Mem (_, Il.ScalarTy (Il.AddrTy Il.CodeTy))
+ | Il.Reg (_, Il.AddrTy Il.CodeTy) -> Il.CodePtr (Il.Cell cell)
+ | _ ->
+ bug () "expected code-pointer cell, found %s"
+ (cell_str cell)
+
+ and code_of_operand (operand:Il.operand) : Il.code =
+ match operand with
+ Il.Cell c -> code_of_cell c
+ | Il.ImmPtr (_, Il.CodeTy) -> Il.CodePtr operand
+ | _ ->
+ bug () "expected code-pointer operand, got %s"
+ (oper_str operand)
+
+ and ty_arg_slots (ty:Ast.ty) : Ast.slot array =
+ match ty with
+ Ast.TY_fn (tsig, _) -> tsig.Ast.sig_input_slots
+ | _ -> bug () "Trans.ty_arg_slots on non-callable type: %a"
+ Ast.sprintf_ty ty
+
+ and copy_fn_args
+ (tail_area:bool)
+ (clone:clone_ctrl)
+ (call:call)
+ : unit =
+
+ let n_ty_params = Array.length call.call_callee_ty_params in
+ let all_callee_args_rty =
+ let clo =
+ if call.call_ctrl = CALL_direct
+ then None
+ else (Some Il.OpaqueTy)
+ in
+ call_args_referent_type cx n_ty_params call.call_callee_ty clo
+ in
+ let all_callee_args_cell =
+ callee_args_cell tail_area all_callee_args_rty
+ in
+
+ let _ = iflog (fun _ -> annotate
+ (Printf.sprintf
+ "copying fn args to %d-ty-param call with rty: %s\n"
+ n_ty_params (Il.string_of_referent_ty
+ all_callee_args_rty)))
+ in
+ let callee_arg_slots = ty_arg_slots call.call_callee_ty in
+ let callee_output_cell =
+ get_element_ptr all_callee_args_cell Abi.calltup_elt_out_ptr
+ in
+ let callee_task_cell =
+ get_element_ptr all_callee_args_cell Abi.calltup_elt_task_ptr
+ in
+ let callee_ty_params =
+ get_element_ptr all_callee_args_cell Abi.calltup_elt_ty_params
+ in
+ let callee_args =
+ get_element_ptr_dyn_in_current_frame
+ all_callee_args_cell Abi.calltup_elt_args
+ in
+ let callee_iterator_args =
+ get_element_ptr_dyn_in_current_frame
+ all_callee_args_cell Abi.calltup_elt_iterator_args
+ in
+ let callee_indirect_args =
+ get_element_ptr_dyn_in_current_frame
+ all_callee_args_cell Abi.calltup_elt_indirect_args
+ in
+
+ let n_args = Array.length call.call_args in
+ let n_iterators = Array.length call.call_iterator_args in
+ let n_indirects = Array.length call.call_indirect_args in
+
+ Array.iteri
+ begin
+ fun i arg_atom ->
+ iflog (fun _ ->
+ annotate
+ (Printf.sprintf "fn-call arg %d of %d (+ %d indirect)"
+ i n_args n_indirects));
+ trans_argN
+ clone
+ (get_element_ptr_dyn_in_current_frame callee_args i)
+ callee_arg_slots.(i)
+ arg_atom
+ end
+ call.call_args;
+
+ Array.iteri
+ begin
+ fun i iterator_arg_operand ->
+ iflog (fun _ ->
+ annotate (Printf.sprintf "fn-call iterator-arg %d of %d"
+ i n_iterators));
+ mov
+ (get_element_ptr_dyn_in_current_frame callee_iterator_args i)
+ iterator_arg_operand
+ end
+ call.call_iterator_args;
+
+ Array.iteri
+ begin
+ fun i indirect_arg_operand ->
+ iflog (fun _ ->
+ annotate (Printf.sprintf "fn-call indirect-arg %d of %d"
+ i n_indirects));
+ mov
+ (get_element_ptr_dyn_in_current_frame callee_indirect_args i)
+ indirect_arg_operand
+ end
+ call.call_indirect_args;
+
+ Array.iteri
+ begin
+ fun i ty_param ->
+ iflog (fun _ ->
+ annotate
+ (Printf.sprintf "fn-call ty param %d of %d"
+ i n_ty_params));
+ trans_init_slot_from_cell CLONE_none
+ (get_element_ptr callee_ty_params i) word_slot
+ (get_tydesc None ty_param) word_slot
+ end
+ call.call_callee_ty_params;
+
+ trans_arg1 callee_task_cell;
+
+ trans_arg0 callee_output_cell call.call_output
+
+
+
+ and call_code (code:Il.code) : unit =
+ let vr = next_vreg_cell Il.voidptr_t in
+ emit (Il.call vr code);
+
+
+ and copy_bound_args
+ (dst_cell:Il.cell)
+ (bound_arg_slots:Ast.slot array)
+ (bound_args:Ast.atom array)
+ : unit =
+ let n_slots = Array.length bound_arg_slots in
+ Array.iteri
+ begin
+ fun i slot ->
+ iflog (fun _ ->
+ annotate (Printf.sprintf
+ "copy bound arg %d of %d" i n_slots));
+ trans_argN CLONE_none
+ (get_element_ptr dst_cell i)
+ slot bound_args.(i)
+ end
+ bound_arg_slots
+
+ and merge_bound_args
+ (all_self_args_rty:Il.referent_ty)
+ (all_callee_args_rty:Il.referent_ty)
+ (arg_slots:Ast.slot array)
+ (arg_bound_flags:bool array)
+ : unit =
+ begin
+ (*
+ * NB: 'all_*_args', both self and callee, are always 4-tuples:
+ *
+ * [out_ptr, task_ptr, [args], [indirect_args]]
+ *
+ * The first few bindings here just destructure those via GEP.
+ *
+ *)
+ let all_self_args_cell = caller_args_cell all_self_args_rty in
+ let all_callee_args_cell = callee_args_cell false all_callee_args_rty in
+
+ let self_args_cell =
+ get_element_ptr all_self_args_cell Abi.calltup_elt_args
+ in
+ let self_ty_params_cell =
+ get_element_ptr all_self_args_cell Abi.calltup_elt_ty_params
+ in
+ let callee_args_cell =
+ get_element_ptr all_callee_args_cell Abi.calltup_elt_args
+ in
+ let self_indirect_args_cell =
+ get_element_ptr all_self_args_cell Abi.calltup_elt_indirect_args
+ in
+
+ let n_args = Array.length arg_bound_flags in
+ let bound_i = ref 0 in
+ let unbound_i = ref 0 in
+
+ iflog (fun _ -> annotate "copy out-ptr");
+ mov
+ (get_element_ptr all_callee_args_cell Abi.calltup_elt_out_ptr)
+ (Il.Cell (get_element_ptr all_self_args_cell
+ Abi.calltup_elt_out_ptr));
+
+ iflog (fun _ -> annotate "copy task-ptr");
+ mov
+ (get_element_ptr all_callee_args_cell Abi.calltup_elt_task_ptr)
+ (Il.Cell (get_element_ptr all_self_args_cell
+ Abi.calltup_elt_task_ptr));
+
+ iflog (fun _ -> annotate "extract closure indirect-arg");
+ let closure_cell =
+ deref (get_element_ptr self_indirect_args_cell
+ Abi.indirect_args_elt_closure)
+ in
+ let closure_args_cell = get_element_ptr closure_cell 2 in
+
+ for arg_i = 0 to (n_args - 1) do
+ let dst_cell = get_element_ptr callee_args_cell arg_i in
+ let slot = arg_slots.(arg_i) in
+ let is_bound = arg_bound_flags.(arg_i) in
+ let src_cell =
+ if is_bound then
+ begin
+ iflog (fun _ -> annotate
+ (Printf.sprintf
+ "extract bound arg %d as actual arg %d"
+ !bound_i arg_i));
+ get_element_ptr closure_args_cell (!bound_i);
+ end
+ else
+ begin
+ iflog (fun _ -> annotate
+ (Printf.sprintf
+ "extract unbound arg %d as actual arg %d"
+ !unbound_i arg_i));
+ get_element_ptr self_args_cell (!unbound_i);
+ end
+ in
+ iflog (fun _ -> annotate
+ (Printf.sprintf
+ "copy into actual-arg %d" arg_i));
+ trans_copy_slot
+ self_ty_params_cell
+ true dst_cell slot src_cell slot None;
+ incr (if is_bound then bound_i else unbound_i);
+ done;
+ assert ((!bound_i + !unbound_i) == n_args)
+ end
+
+
+ and callee_fn_ptr
+ (fptr:Il.operand)
+ (cc:call_ctrl)
+ : Il.operand =
+ match cc with
+ CALL_direct
+ | CALL_vtbl -> fptr
+ | CALL_indirect ->
+ (* fptr is a pair [disp, binding*] *)
+ let pair_cell = need_cell (reify_ptr fptr) in
+ let disp_cell = get_element_ptr pair_cell Abi.binding_field_item in
+ Il.Cell (crate_rel_to_ptr (Il.Cell disp_cell) Il.CodeTy)
+
+ and callee_binding_ptr
+ (pair_lval:Ast.lval)
+ (cc:call_ctrl)
+ : Il.operand =
+ if cc = CALL_direct
+ then zero
+ else
+ let (pair_cell, _) = trans_lval pair_lval in
+ Il.Cell (get_element_ptr pair_cell Abi.binding_field_binding)
+
+ and call_ctrl flv : call_ctrl =
+ if lval_is_static cx flv
+ then CALL_direct
+ else
+ if lval_is_obj_vtbl cx flv
+ then CALL_vtbl
+ else CALL_indirect
+
+ and call_ctrl_string cc =
+ match cc with
+ CALL_direct -> "direct"
+ | CALL_indirect -> "indirect"
+ | CALL_vtbl -> "vtbl"
+
+ and call_iterator_args
+ (fco:for_each_ctrl option)
+ : Il.operand array =
+ match fco with
+ None -> [| |]
+ | Some fco ->
+ begin
+ iflog (fun _ -> annotate "calculate iterator args");
+ [| reify_ptr (code_fixup_to_ptr_operand fco.for_each_fixup);
+ Il.Cell (Il.Reg (abi.Abi.abi_fp_reg, Il.voidptr_t)); |]
+ end
+
+ and call_indirect_args
+ (flv:Ast.lval)
+ (cc:call_ctrl)
+ : Il.operand array =
+ begin
+ match cc with
+ CALL_direct -> [| |]
+ | CALL_indirect -> [| callee_binding_ptr flv cc |]
+ | CALL_vtbl ->
+ begin
+ match flv with
+ (*
+ * FIXME: will need to pass both words of obj if we add
+ * a 'self' value for self-dispatch within objs.
+ *)
+ Ast.LVAL_ext (base, _) -> [| callee_binding_ptr base cc |]
+ | _ ->
+ bug (lval_base_id flv)
+ "call_indirect_args on obj-fn without base obj"
+ end
+ end
+
+ and trans_be
+ (logname:(unit -> string))
+ (caller_is_closure:bool)
+ (call:call)
+ : unit =
+ let callee_fptr = callee_fn_ptr call.call_callee_ptr call.call_ctrl in
+ let callee_code = code_of_operand callee_fptr in
+ let callee_args_rty =
+ call_args_referent_type cx 0 call.call_callee_ty
+ (if call.call_ctrl = CALL_direct then None else (Some Il.OpaqueTy))
+ in
+ let callee_argsz =
+ force_sz (Il.referent_ty_size word_bits callee_args_rty)
+ in
+ let closure_rty =
+ if caller_is_closure
+ then Some Il.OpaqueTy
+ else None
+ in
+ let caller_args_rty = current_fn_args_rty closure_rty in
+ let caller_argsz =
+ force_sz (Il.referent_ty_size word_bits caller_args_rty)
+ in
+ iflog (fun _ -> annotate
+ (Printf.sprintf "copy args for tail call to %s" (logname ())));
+ copy_fn_args true CLONE_none call;
+ drop_slots_at_curr_stmt();
+ abi.Abi.abi_emit_fn_tail_call (emitter())
+ (force_sz (current_fn_callsz()))
+ caller_argsz callee_code callee_argsz;
+
+
+ and trans_prepare_call
+ ((*initializing*)_:bool)
+ (logname:(unit -> string))
+ (call:call)
+ : Il.operand =
+
+ let callee_fptr = callee_fn_ptr call.call_callee_ptr call.call_ctrl in
+ iflog (fun _ -> annotate
+ (Printf.sprintf "copy args for call to %s" (logname ())));
+ copy_fn_args false CLONE_none call;
+ iflog (fun _ -> annotate (Printf.sprintf "call %s" (logname ())));
+ (* FIXME (issue #24): we need to actually handle writing to an
+ * already-initialised slot. Currently we blindly assume we're
+ * initializing, overwrite the slot; this is ok if we're writing
+ * to an interior output slot, but we'll leak any exteriors as we
+ * do that. *)
+ callee_fptr
+
+ and callee_drop_slot
+ (k:Ast.slot_key)
+ (slot_id:node_id)
+ (slot:Ast.slot)
+ : unit =
+ iflog (fun _ ->
+ annotate (Printf.sprintf "callee_drop_slot %d = %s "
+ (int_of_node slot_id)
+ (Ast.fmt_to_str Ast.fmt_slot_key k)));
+ drop_slot_in_current_frame (cell_of_block_slot slot_id) slot None
+
+
+ and trans_alt_tag { Ast.alt_tag_lval = lval; Ast.alt_tag_arms = arms } =
+ let ((lval_cell:Il.cell), { Ast.slot_ty = ty_opt }) = trans_lval lval in
+ let lval_ty =
+ match ty_opt with
+ Some ty -> ty
+ | None -> bug cx "expected lval type"
+ in
+
+ let trans_arm { node = (pat, block) } : quad_idx =
+ (* Translates the pattern and returns the addresses of the branch
+ * instructions, which are taken if the match fails. *)
+ let rec trans_pat pat cell (ty:Ast.ty) =
+ match pat with
+ Ast.PAT_lit lit ->
+ let operand = trans_lit lit in
+ emit (Il.cmp (Il.Cell cell) operand);
+ let next_jump = mark() in
+ emit (Il.jmp Il.JNE Il.CodeNone);
+ [ next_jump ]
+
+ | Ast.PAT_tag (ident, pats) ->
+ let ty_tag =
+ match ty with
+ Ast.TY_tag tag_ty -> tag_ty
+ | Ast.TY_iso ti -> (ti.Ast.iso_group).(ti.Ast.iso_index)
+ | _ -> bug cx "expected tag type"
+ in
+ let tag_keys = sorted_htab_keys ty_tag in
+ let tag_name = Ast.NAME_base (Ast.BASE_ident ident) in
+ let tag_number = arr_idx tag_keys tag_name in
+ let ty_tup = Hashtbl.find ty_tag tag_name in
+
+ let tag_cell:Il.cell = get_element_ptr cell 0 in
+ let union_cell = get_element_ptr_dyn_in_current_frame cell 1 in
+
+ emit (Il.cmp
+ (Il.Cell tag_cell)
+ (imm (Int64.of_int tag_number)));
+ let next_jump = mark() in
+ emit (Il.jmp Il.JNE Il.CodeNone);
+
+ let tup_cell:Il.cell = get_variant_ptr union_cell tag_number in
+
+ let trans_elem_pat i elem_pat : quad_idx list =
+ let elem_cell =
+ get_element_ptr_dyn_in_current_frame tup_cell i
+ in
+ let elem_ty =
+ match ty_tup.(i).Ast.slot_ty with
+ Some ty -> ty
+ | None -> bug cx "expected element type"
+ in
+ trans_pat elem_pat elem_cell elem_ty
+ in
+
+ let elem_jumps = Array.mapi trans_elem_pat pats in
+ next_jump::(List.concat (Array.to_list elem_jumps))
+
+ | Ast.PAT_slot ({ node = dst_slot; id = dst_id }, _) ->
+ let dst_cell = cell_of_block_slot dst_id in
+ let src_cell = Il.Cell cell in
+ mov (deref_slot true dst_cell dst_slot) src_cell;
+ [] (* irrefutable *)
+
+ | Ast.PAT_wild -> [] (* irrefutable *)
+ in
+
+ let next_jumps = trans_pat pat lval_cell lval_ty in
+ trans_block block;
+ let last_jump = mark() in
+ emit (Il.jmp Il.JMP Il.CodeNone);
+ List.iter patch next_jumps;
+ last_jump
+ in
+ let last_jumps = Array.map trans_arm arms in
+ Array.iter patch last_jumps
+
+ and drop_slots_at_curr_stmt _ : unit =
+ let stmt = Stack.top curr_stmt in
+ match htab_search cx.ctxt_post_stmt_slot_drops stmt with
+ None -> ()
+ | Some slots ->
+ List.iter
+ begin
+ fun slot_id ->
+ let slot = get_slot cx slot_id in
+ let k = Hashtbl.find cx.ctxt_slot_keys slot_id in
+ iflog (fun _ ->
+ annotate
+ (Printf.sprintf
+ "post-stmt, drop_slot %d = %s "
+ (int_of_node slot_id)
+ (Ast.fmt_to_str Ast.fmt_slot_key k)));
+ drop_slot_in_current_frame
+ (cell_of_block_slot slot_id) slot None
+ end
+ slots
+
+ and trans_stmt (stmt:Ast.stmt) : unit =
+ (* Helper to localize errors by stmt, at minimum. *)
+ try
+ iflog
+ begin
+ fun _ ->
+ let s = Ast.fmt_to_str Ast.fmt_stmt_body stmt in
+ log cx "translating stmt: %s" s;
+ annotate s;
+ end;
+ Stack.push stmt.id curr_stmt;
+ trans_stmt_full stmt;
+ begin
+ match stmt.node with
+ Ast.STMT_be _
+ | Ast.STMT_ret _ -> ()
+ | _ -> drop_slots_at_curr_stmt();
+ end;
+ ignore (Stack.pop curr_stmt);
+ with
+ Semant_err (None, msg) -> raise (Semant_err ((Some stmt.id), msg))
+
+
+ and maybe_init (id:node_id) (action:string) (dst:Ast.lval) : bool =
+ let b = Hashtbl.mem cx.ctxt_copy_stmt_is_init id in
+ let act = if b then ("initializing-" ^ action) else action in
+ iflog
+ (fun _ ->
+ annotate (Printf.sprintf "%s on dst lval %a"
+ act Ast.sprintf_lval dst));
+ b
+
+
+ and trans_set_outptr (at:Ast.atom) : unit =
+ let (dst_mem, _) =
+ need_mem_cell
+ (deref (wordptr_at (fp_imm out_mem_disp)))
+ in
+ let atom_ty = atom_type cx at in
+ let dst_slot = interior_slot atom_ty in
+ let dst_ty = referent_type abi atom_ty in
+ let dst_cell = Il.Mem (dst_mem, dst_ty) in
+ trans_init_slot_from_atom
+ CLONE_none dst_cell dst_slot at
+
+
+ and trans_for_loop (fo:Ast.stmt_for) : unit =
+ let ty_params = get_ty_params_of_current_frame () in
+ let (dst_slot, _) = fo.Ast.for_slot in
+ let dst_cell = cell_of_block_slot dst_slot.id in
+ let (head_stmts, seq) = fo.Ast.for_seq in
+ let (seq_cell, seq_slot) = trans_lval_full false seq in
+ let unit_slot = seq_unit_slot (slot_ty seq_slot) in
+ Array.iter trans_stmt head_stmts;
+ iter_seq_slots ty_params seq_cell seq_cell unit_slot
+ begin
+ fun _ src_cell unit_slot curr_iso ->
+ trans_copy_slot
+ ty_params true
+ dst_cell dst_slot.node
+ src_cell unit_slot curr_iso;
+ trans_block fo.Ast.for_body;
+ end
+ None
+
+ and trans_for_each_loop (stmt_id:node_id) (fe:Ast.stmt_for_each) : unit =
+ let id = fe.Ast.for_each_body.id in
+ let g = GLUE_loop_body id in
+ let name = glue_str cx g in
+ let fix = new_fixup name in
+ let framesz = get_framesz cx id in
+ let callsz = get_callsz cx id in
+ let spill = Hashtbl.find cx.ctxt_spill_fixups id in
+ push_new_emitter_with_vregs (Some id);
+ iflog (fun _ -> annotate "prologue");
+ abi.Abi.abi_emit_fn_prologue (emitter())
+ framesz callsz nabi_rust (upcall_fixup "upcall_grow_task");
+ write_frame_info_ptrs None;
+ iflog (fun _ -> annotate "finished prologue");
+ trans_block fe.Ast.for_each_body;
+ trans_glue_frame_exit fix spill g;
+
+ (*
+ * We've now emitted the body helper-fn. Next, set up a loop that
+ * calls the iter and passes the helper-fn in.
+ *)
+ emit (Il.Enter
+ (Hashtbl.find
+ cx.ctxt_block_fixups
+ fe.Ast.for_each_head.id));
+ let (dst_slot, _) = fe.Ast.for_each_slot in
+ let dst_cell = cell_of_block_slot dst_slot.id in
+ let (flv, args) = fe.Ast.for_each_call in
+ let ty_params =
+ match htab_search cx.ctxt_call_lval_params (lval_base_id flv) with
+ Some params -> params
+ | None -> [| |]
+ in
+ let depth = Hashtbl.find cx.ctxt_stmt_loop_depths stmt_id in
+ let fc = { for_each_fixup = fix; for_each_depth = depth } in
+ iflog (fun _ ->
+ log cx "for-each at depth %d\n" depth);
+ let fn_ptr =
+ trans_prepare_fn_call true cx dst_cell flv ty_params (Some fc) args
+ in
+ call_code (code_of_operand fn_ptr);
+ emit Il.Leave;
+
+ and trans_put (atom_opt:Ast.atom option) : unit =
+ begin
+ match atom_opt with
+ None -> ()
+ | Some at -> trans_set_outptr at
+ end;
+ let block_fptr = Il.Cell (get_iter_block_fn_for_current_frame ()) in
+ let fp = get_iter_outer_frame_ptr_for_current_frame () in
+ let vr = next_vreg_cell Il.voidptr_t in
+ mov vr zero;
+ trans_call_glue (code_of_operand block_fptr) None [| vr; fp |]
+
+ and trans_vec_append dst_cell dst_slot src_oper src_ty =
+ let (dst_elt_slot, trim_trailing_null) =
+ match slot_ty dst_slot with
+ Ast.TY_str -> (interior_slot (Ast.TY_mach TY_u8), true)
+ | Ast.TY_vec e -> (e, false)
+ | _ -> bug () "unexpected dst type in trans_vec_append"
+ in
+ match src_ty with
+ Ast.TY_str
+ | Ast.TY_vec _ ->
+ let src_cell = need_cell src_oper in
+ let src_vec = deref src_cell in
+ let src_fill = get_element_ptr src_vec Abi.vec_elt_fill in
+ let src_elt_slot =
+ match src_ty with
+ Ast.TY_str -> interior_slot (Ast.TY_mach TY_u8)
+ | Ast.TY_vec e -> e
+ | _ -> bug () "unexpected src type in trans_vec_append"
+ in
+ let dst_vec = deref dst_cell in
+ let dst_fill = get_element_ptr dst_vec Abi.vec_elt_fill in
+ if trim_trailing_null
+ then sub_from dst_fill (imm 1L);
+ trans_upcall "upcall_vec_grow"
+ dst_cell
+ [| Il.Cell dst_cell;
+ Il.Cell src_fill |];
+
+ (*
+ * By now, dst_cell points to a vec/str with room for us
+ * to add to.
+ *)
+
+ (* Reload dst vec, fill; might have changed. *)
+ let dst_vec = deref dst_cell in
+ let dst_fill = get_element_ptr dst_vec Abi.vec_elt_fill in
+
+ (* Copy loop: *)
+ let pty s = Il.AddrTy (slot_referent_type abi s) in
+ let dptr = next_vreg_cell (pty dst_elt_slot) in
+ let sptr = next_vreg_cell (pty src_elt_slot) in
+ let dlim = next_vreg_cell (pty dst_elt_slot) in
+ let dst_elt_sz = slot_sz_in_current_frame dst_elt_slot in
+ let src_elt_sz = slot_sz_in_current_frame src_elt_slot in
+ let dst_data =
+ get_element_ptr_dyn_in_current_frame
+ dst_vec Abi.vec_elt_data
+ in
+ let src_data =
+ get_element_ptr_dyn_in_current_frame
+ src_vec Abi.vec_elt_data
+ in
+ lea dptr (fst (need_mem_cell dst_data));
+ lea sptr (fst (need_mem_cell src_data));
+ add_to dptr (Il.Cell dst_fill);
+ mov dlim (Il.Cell dptr);
+ add_to dlim (Il.Cell src_fill);
+ let fwd_jmp = mark () in
+ emit (Il.jmp Il.JMP Il.CodeNone);
+ let back_jmp_targ = mark () in
+ (* copy slot *)
+ trans_copy_slot
+ (get_ty_params_of_current_frame()) true
+ (deref dptr) dst_elt_slot
+ (deref sptr) src_elt_slot
+ None;
+ add_to dptr dst_elt_sz;
+ add_to sptr src_elt_sz;
+ patch fwd_jmp;
+ check_interrupt_flag ();
+ let back_jmp =
+ trans_compare Il.JB (Il.Cell dptr) (Il.Cell dlim) in
+ List.iter
+ (fun j -> patch_existing j back_jmp_targ) back_jmp;
+ let v = next_vreg_cell word_ty in
+ mov v (Il.Cell src_fill);
+ add_to dst_fill (Il.Cell v);
+ | t ->
+ begin
+ bug () "unsupported vector-append type %a" Ast.sprintf_ty t
+ end
+
+
+ and trans_copy_binop dst binop a_src =
+ let (dst_cell, dst_slot) = trans_lval_maybe_init false dst in
+ let src_oper = trans_atom a_src in
+ match slot_ty dst_slot with
+ Ast.TY_str
+ | Ast.TY_vec _ when binop = Ast.BINOP_add ->
+ trans_vec_append dst_cell dst_slot src_oper (atom_type cx a_src)
+ | _ ->
+ let dst_cell = deref_slot false dst_cell dst_slot in
+ let op = trans_binop binop in
+ emit (Il.binary op dst_cell (Il.Cell dst_cell) src_oper);
+
+
+
+ and trans_stmt_full (stmt:Ast.stmt) : unit =
+ match stmt.node with
+
+ Ast.STMT_log a ->
+ begin
+ match atom_type cx a with
+ (* NB: If you extend this, be sure to update the
+ * typechecking code in type.ml as well. *)
+ Ast.TY_str -> trans_log_str a
+ | Ast.TY_int | Ast.TY_uint | Ast.TY_bool
+ | Ast.TY_char | Ast.TY_mach (TY_u8)
+ | Ast.TY_mach (TY_u16) | Ast.TY_mach (TY_u32)
+ | Ast.TY_mach (TY_i8) | Ast.TY_mach (TY_i16)
+ | Ast.TY_mach (TY_i32) ->
+ trans_log_int a
+ | _ -> bugi cx stmt.id "unimplemented logging type"
+ end
+
+ | Ast.STMT_check_expr e ->
+ begin
+ match expr_type cx e with
+ Ast.TY_bool -> trans_check_expr e
+ | _ -> bugi cx stmt.id "check expr on non-bool"
+ end
+
+ | Ast.STMT_yield ->
+ trans_yield ()
+
+ | Ast.STMT_fail ->
+ trans_fail ()
+
+ | Ast.STMT_join task ->
+ trans_join task
+
+ | Ast.STMT_send (chan,src) ->
+ trans_send chan src
+
+ | Ast.STMT_spawn (dst, domain, plv, args) ->
+ trans_spawn (maybe_init stmt.id "spawn" dst) dst domain plv args
+
+ | Ast.STMT_recv (dst, chan) ->
+ trans_recv (maybe_init stmt.id "recv" dst) dst chan
+
+ | Ast.STMT_copy (dst, e_src) ->
+ trans_copy (maybe_init stmt.id "copy" dst) dst e_src
+
+ | Ast.STMT_copy_binop (dst, binop, a_src) ->
+ trans_copy_binop dst binop a_src
+
+ | Ast.STMT_call (dst, flv, args) ->
+ begin
+ let init = maybe_init stmt.id "call" dst in
+ let ty = lval_ty cx flv in
+ let ty_params =
+ match
+ htab_search
+ cx.ctxt_call_lval_params (lval_base_id flv)
+ with
+ Some params -> params
+ | None -> [| |]
+ in
+ match ty with
+ Ast.TY_fn _ ->
+ let (dst_cell, _) = trans_lval_maybe_init init dst in
+ let fn_ptr =
+ trans_prepare_fn_call init cx dst_cell flv
+ ty_params None args
+ in
+ call_code (code_of_operand fn_ptr)
+ | _ -> bug () "Calling unexpected lval."
+ end
+
+ | Ast.STMT_bind (dst, flv, args) ->
+ begin
+ let init = maybe_init stmt.id "bind" dst in
+ match lval_ty cx flv with
+ Ast.TY_fn (tsig, _) ->
+ trans_bind_fn
+ init (call_ctrl flv) stmt.id dst flv tsig args
+ | _ -> bug () "Binding unexpected lval."
+ end
+
+ | Ast.STMT_init_rec (dst, atab, base) ->
+ let (slot_cell, slot) = trans_lval_init dst in
+ let (trec, dst_slots) =
+ match slot_ty slot with
+ Ast.TY_rec trec -> (trec, Array.map snd trec)
+ | _ ->
+ bugi cx stmt.id
+ "non-rec destination type in stmt_init_rec"
+ in
+ let dst_cell = deref_slot true slot_cell slot in
+ begin
+ match base with
+ None ->
+ let atoms =
+ Array.map (fun (_, _, _, atom) -> atom) atab
+ in
+ trans_init_structural_from_atoms
+ dst_cell dst_slots atoms
+ | Some base_lval ->
+ trans_init_rec_update
+ dst_cell dst_slots trec atab base_lval
+ end
+
+ | Ast.STMT_init_tup (dst, mode_atoms) ->
+ let (slot_cell, slot) = trans_lval_init dst in
+ let dst_slots =
+ match slot_ty slot with
+ Ast.TY_tup ttup -> ttup
+ | _ ->
+ bugi cx stmt.id
+ "non-tup destination type in stmt_init_tup"
+ in
+ let atoms = Array.map (fun (_, _, atom) -> atom) mode_atoms in
+ let dst_cell = deref_slot true slot_cell slot in
+ trans_init_structural_from_atoms dst_cell dst_slots atoms
+
+
+ | Ast.STMT_init_str (dst, s) ->
+ trans_init_str dst s
+
+ | Ast.STMT_init_vec (dst, _, atoms) ->
+ trans_init_vec dst atoms
+
+ | Ast.STMT_init_port dst ->
+ trans_init_port dst
+
+ | Ast.STMT_init_chan (dst, port) ->
+ begin
+ match port with
+ None ->
+ let (dst_cell, _) =
+ trans_lval_init dst
+ in
+ mov dst_cell imm_false
+ | Some p ->
+ trans_init_chan dst p
+ end
+
+ | Ast.STMT_block block ->
+ trans_block block
+
+ | Ast.STMT_while sw ->
+ let (head_stmts, head_expr) = sw.Ast.while_lval in
+ let fwd_jmp = mark () in
+ emit (Il.jmp Il.JMP Il.CodeNone);
+ let block_begin = mark () in
+ trans_block sw.Ast.while_body;
+ patch fwd_jmp;
+ Array.iter trans_stmt head_stmts;
+ check_interrupt_flag ();
+ let back_jmps = trans_cond false head_expr in
+ List.iter (fun j -> patch_existing j block_begin) back_jmps;
+
+ | Ast.STMT_if si ->
+ let skip_thn_jmps = trans_cond true si.Ast.if_test in
+ trans_block si.Ast.if_then;
+ begin
+ match si.Ast.if_else with
+ None -> List.iter patch skip_thn_jmps
+ | Some els ->
+ let skip_els_jmp = mark () in
+ begin
+ emit (Il.jmp Il.JMP Il.CodeNone);
+ List.iter patch skip_thn_jmps;
+ trans_block els;
+ patch skip_els_jmp
+ end
+ end
+
+ | Ast.STMT_check (preds, calls) ->
+ Array.iteri
+ (fun i (fn, args) -> trans_call_pred_and_check preds.(i) fn args)
+ calls
+
+ | Ast.STMT_ret atom_opt ->
+ begin
+ match atom_opt with
+ None -> ()
+ | Some at -> trans_set_outptr at
+ end;
+ drop_slots_at_curr_stmt();
+ Stack.push (mark()) (Stack.top epilogue_jumps);
+ emit (Il.jmp Il.JMP Il.CodeNone)
+
+ | Ast.STMT_be (flv, args) ->
+ let ty = lval_ty cx flv in
+ let ty_params =
+ match htab_search cx.ctxt_call_lval_params (lval_base_id flv) with
+ Some params -> params
+ | None -> [| |]
+ in
+ begin
+ match ty with
+ Ast.TY_fn (tsig, _) ->
+ let result_ty = slot_ty tsig.Ast.sig_output_slot in
+ let (dst_mem, _) =
+ need_mem_cell
+ (deref (wordptr_at (fp_imm out_mem_disp)))
+ in
+ let dst_rty = referent_type abi result_ty in
+ let dst_cell = Il.Mem (dst_mem, dst_rty) in
+ trans_be_fn cx dst_cell flv ty_params args
+
+ | _ -> bug () "Calling unexpected lval."
+ end
+
+ | Ast.STMT_put atom_opt ->
+ trans_put atom_opt
+
+ | Ast.STMT_alt_tag stmt_alt_tag -> trans_alt_tag stmt_alt_tag
+
+ | Ast.STMT_decl _ -> ()
+
+ | Ast.STMT_for fo ->
+ trans_for_loop fo
+
+ | Ast.STMT_for_each fe ->
+ trans_for_each_loop stmt.id fe
+
+ | _ -> bugi cx stmt.id "unhandled form of statement in trans_stmt %a"
+ Ast.sprintf_stmt stmt
+
+ and capture_emitted_quads (fix:fixup) (node:node_id) : unit =
+ let e = emitter() in
+ let n_vregs = Il.num_vregs e in
+ let quads = emitted_quads e in
+ let name = path_name () in
+ let f =
+ if Stack.is_empty curr_file
+ then bugi cx node "missing file scope when capturing quads."
+ else Stack.top curr_file
+ in
+ let item_code = Hashtbl.find cx.ctxt_file_code f in
+ begin
+ iflog (fun _ ->
+ log cx "capturing quads for item #%d" (int_of_node node);
+ annotate_quads name);
+ let vr_s =
+ match htab_search cx.ctxt_spill_fixups node with
+ None -> (assert (n_vregs = 0); None)
+ | Some spill -> Some (n_vregs, spill)
+ in
+ let code = { code_fixup = fix;
+ code_quads = quads;
+ code_vregs_and_spill = vr_s; }
+ in
+ htab_put item_code node code;
+ htab_put cx.ctxt_all_item_code node code
+ end
+
+ and get_frame_glue_fns (fnid:node_id) : Il.operand =
+ let n_ty_params = n_item_ty_params cx fnid in
+ let get_frame_glue glue inner =
+ get_mem_glue glue
+ begin
+ fun mem ->
+ iter_frame_and_arg_slots cx fnid
+ begin
+ fun key slot_id slot ->
+ match htab_search cx.ctxt_slot_offsets slot_id with
+ Some off when not (slot_is_obj_state cx slot_id) ->
+ let referent_type = slot_id_referent_type slot_id in
+ let fp_cell = rty_ptr_at mem referent_type in
+ let (fp, st) = force_to_reg (Il.Cell fp_cell) in
+ let ty_params =
+ get_ty_params_of_frame fp n_ty_params
+ in
+ let slot_cell =
+ deref_off_sz ty_params (Il.Reg (fp,st)) off
+ in
+ inner key slot_id ty_params slot slot_cell
+ | _ -> ()
+ end
+ end
+ in
+ trans_crate_rel_data_operand
+ (DATA_frame_glue_fns fnid)
+ begin
+ fun _ ->
+ let mark_frame_glue_fixup =
+ get_frame_glue (GLUE_mark_frame fnid)
+ begin
+ fun _ _ ty_params slot slot_cell ->
+ mark_slot ty_params slot_cell slot None
+ end
+ in
+ let drop_frame_glue_fixup =
+ get_frame_glue (GLUE_drop_frame fnid)
+ begin
+ fun _ _ ty_params slot slot_cell ->
+ drop_slot ty_params slot_cell slot None
+ end
+ in
+ let reloc_frame_glue_fixup =
+ get_frame_glue (GLUE_reloc_frame fnid)
+ begin
+ fun _ _ _ _ _ ->
+ ()
+ end
+ in
+ table_of_crate_rel_fixups
+ [|
+ (*
+ * NB: this must match the struct-offsets given in ABI
+ * & rust runtime library.
+ *)
+ mark_frame_glue_fixup;
+ drop_frame_glue_fixup;
+ reloc_frame_glue_fixup;
+ |]
+ end
+ in
+
+ let trans_frame_entry (fnid:node_id) : unit =
+ let framesz = get_framesz cx fnid in
+ let callsz = get_callsz cx fnid in
+ Stack.push (Stack.create()) epilogue_jumps;
+ push_new_emitter_with_vregs (Some fnid);
+ iflog (fun _ -> annotate "prologue");
+ iflog (fun _ -> annotate (Printf.sprintf
+ "framesz %s"
+ (string_of_size framesz)));
+ iflog (fun _ -> annotate (Printf.sprintf
+ "callsz %s"
+ (string_of_size callsz)));
+ abi.Abi.abi_emit_fn_prologue
+ (emitter()) framesz callsz nabi_rust
+ (upcall_fixup "upcall_grow_task");
+
+ write_frame_info_ptrs (Some fnid);
+ check_interrupt_flag ();
+ iflog (fun _ -> annotate "finished prologue");
+ in
+
+ let trans_frame_exit (fnid:node_id) (drop_args:bool) : unit =
+ Stack.iter patch (Stack.pop epilogue_jumps);
+ if drop_args
+ then
+ begin
+ iflog (fun _ -> annotate "drop args");
+ iter_arg_slots cx fnid callee_drop_slot;
+ end;
+ iflog (fun _ -> annotate "epilogue");
+ abi.Abi.abi_emit_fn_epilogue (emitter());
+ capture_emitted_quads (get_fn_fixup cx fnid) fnid;
+ pop_emitter ()
+ in
+
+ let trans_fn
+ (fnid:node_id)
+ (body:Ast.block)
+ : unit =
+ trans_frame_entry fnid;
+ trans_block body;
+ trans_frame_exit fnid true;
+ in
+
+ let trans_obj_ctor
+ (obj_id:node_id)
+ (state:Ast.header_slots)
+ : unit =
+ trans_frame_entry obj_id;
+
+ let all_args_rty = current_fn_args_rty None in
+ let all_args_cell = caller_args_cell all_args_rty in
+ let frame_args =
+ get_element_ptr_dyn_in_current_frame
+ all_args_cell Abi.calltup_elt_args
+ in
+ let frame_ty_params =
+ get_element_ptr_dyn_in_current_frame
+ all_args_cell Abi.calltup_elt_ty_params
+ in
+
+ let obj_args_tup = Array.map (fun (sloti,_) -> sloti.node) state in
+ let obj_args_slot = interior_slot (Ast.TY_tup obj_args_tup) in
+ let state_ty =
+ Ast.TY_tup [| interior_slot Ast.TY_type;
+ obj_args_slot |]
+ in
+ let state_rty = slot_referent_type abi (interior_slot state_ty) in
+ let state_ptr_slot = exterior_slot state_ty in
+ let state_ptr_rty = slot_referent_type abi state_ptr_slot in
+ let state_malloc_sz =
+ calculate_sz_in_current_frame
+ (SIZE_rt_add
+ ((SIZE_fixed (word_n Abi.exterior_rc_header_size)),
+ (Il.referent_ty_size word_bits state_rty)))
+ in
+
+ let ctor_ty = Hashtbl.find cx.ctxt_all_item_types obj_id in
+ let obj_ty =
+ match ctor_ty with
+ Ast.TY_fn (tsig, _) -> slot_ty tsig.Ast.sig_output_slot
+ | _ -> bug () "object constructor doesn't have function type"
+ in
+ let vtbl_ptr = get_obj_vtbl obj_id in
+ let _ =
+ iflog (fun _ -> annotate "calculate vtbl-ptr from displacement")
+ in
+ let vtbl_cell = crate_rel_to_ptr vtbl_ptr Il.CodeTy in
+
+ let _ = iflog (fun _ -> annotate "load destination obj pair ptr") in
+ let dst_pair_cell = deref (ptr_at (fp_imm out_mem_disp) obj_ty) in
+ let dst_pair_item_cell =
+ get_element_ptr dst_pair_cell Abi.binding_field_item
+ in
+ let dst_pair_state_cell =
+ get_element_ptr dst_pair_cell Abi.binding_field_binding
+ in
+
+ (* Load first cell of pair with vtbl ptr.*)
+ iflog (fun _ -> annotate "mov vtbl-ptr to obj.item cell");
+ mov dst_pair_item_cell (Il.Cell vtbl_cell);
+
+ (* Load second cell of pair with pointer to fresh state tuple.*)
+ iflog (fun _ -> annotate "malloc state-tuple to obj.state cell");
+ trans_malloc dst_pair_state_cell state_malloc_sz;
+
+ (* Copy args into the state tuple. *)
+ let state_ptr = next_vreg_cell (need_scalar_ty state_ptr_rty) in
+ iflog (fun _ -> annotate "load obj.state ptr to vreg");
+ mov state_ptr (Il.Cell dst_pair_state_cell);
+ let state = deref state_ptr in
+ let refcnt = get_element_ptr_dyn_in_current_frame state 0 in
+ let body = get_element_ptr_dyn_in_current_frame state 1 in
+ let obj_tydesc = get_element_ptr_dyn_in_current_frame body 0 in
+ let obj_args = get_element_ptr_dyn_in_current_frame body 1 in
+ iflog (fun _ -> annotate "write refcnt=1 to obj state");
+ mov refcnt one;
+ iflog (fun _ -> annotate "get args-tup tydesc");
+ mov obj_tydesc
+ (Il.Cell (get_tydesc
+ (Some obj_id)
+ (Ast.TY_tup obj_args_tup)));
+ iflog (fun _ -> annotate "copy ctor args to obj args");
+ trans_copy_tup
+ frame_ty_params true
+ obj_args frame_args obj_args_tup;
+ (* We have to do something curious here: we can't drop the
+ * arg slots directly as in the normal frame-exit sequence,
+ * because the arg slot ids are actually given layout
+ * positions inside the object state, and are at different
+ * offsets within that state than within the current
+ * frame. So we manually drop the argument tuple here,
+ * without mentioning the arg slot ids.
+ *)
+ drop_slot frame_ty_params frame_args obj_args_slot None;
+ trans_frame_exit obj_id false;
+ in
+
+ let string_of_name_component (nc:Ast.name_component) : string =
+ match nc with
+ Ast.COMP_ident i -> i
+ | _ -> bug ()
+ "Trans.string_of_name_component on non-COMP_ident"
+ in
+
+
+ let trans_static_name_components
+ (ncs:Ast.name_component list)
+ : Il.operand =
+ let f nc =
+ trans_crate_rel_static_string_frag (string_of_name_component nc)
+ in
+ trans_crate_rel_data_operand
+ (DATA_name (Walk.name_of ncs))
+ (fun _ -> Asm.SEQ (Array.append
+ (Array.map f (Array.of_list ncs))
+ [| Asm.WORD (word_ty_mach, Asm.IMM 0L) |]))
+ in
+
+ let trans_required_fn (fnid:node_id) (blockid:node_id) : unit =
+ trans_frame_entry fnid;
+ emit (Il.Enter (Hashtbl.find cx.ctxt_block_fixups blockid));
+ let (ilib, conv) = Hashtbl.find cx.ctxt_required_items fnid in
+ let lib_num =
+ htab_search_or_add cx.ctxt_required_lib_num ilib
+ (fun _ -> Hashtbl.length cx.ctxt_required_lib_num)
+ in
+ let f = next_vreg_cell (Il.AddrTy (Il.CodeTy)) in
+ let n_ty_params = n_item_ty_params cx fnid in
+ let args_rty = direct_call_args_referent_type cx fnid in
+ let caller_args_cell = caller_args_cell args_rty in
+ begin
+ match ilib with
+ REQUIRED_LIB_rust ls ->
+ begin
+ let c_sym_num =
+ htab_search_or_add cx.ctxt_required_c_sym_num
+ (ilib, "rust_crate")
+ (fun _ -> Hashtbl.length cx.ctxt_required_c_sym_num)
+ in
+ let rust_sym_num =
+ htab_search_or_add cx.ctxt_required_rust_sym_num fnid
+ (fun _ -> Hashtbl.length cx.ctxt_required_rust_sym_num)
+ in
+ let path_elts = stk_elts_from_bot path in
+ let _ =
+ assert (ls.required_prefix < (List.length path_elts))
+ in
+ let relative_path_elts =
+ list_drop ls.required_prefix path_elts
+ in
+ let libstr = trans_static_string ls.required_libname in
+ let relpath =
+ trans_static_name_components relative_path_elts
+ in
+ trans_upcall "upcall_require_rust_sym" f
+ [| Il.Cell (curr_crate_ptr());
+ imm (Int64.of_int lib_num);
+ imm (Int64.of_int c_sym_num);
+ imm (Int64.of_int rust_sym_num);
+ libstr;
+ relpath |];
+
+ trans_copy_forward_args args_rty;
+
+ call_code (code_of_operand (Il.Cell f));
+ end
+
+ | REQUIRED_LIB_c ls ->
+ begin
+ let c_sym_str =
+ match htab_search cx.ctxt_required_syms fnid with
+ Some s -> s
+ | None ->
+ string_of_name_component (Stack.top path)
+ in
+ let c_sym_num =
+ (* FIXME: permit remapping symbol names to handle
+ * mangled variants.
+ *)
+ htab_search_or_add cx.ctxt_required_c_sym_num
+ (ilib, c_sym_str)
+ (fun _ -> Hashtbl.length cx.ctxt_required_c_sym_num)
+ in
+ let libstr = trans_static_string ls.required_libname in
+ let symstr = trans_static_string c_sym_str in
+ let check_rty_sz rty =
+ let sz = force_sz (Il.referent_ty_size word_bits rty) in
+ if sz = 0L || sz = word_sz
+ then ()
+ else bug () "bad arg or ret cell size for native require"
+ in
+ let out =
+ get_element_ptr caller_args_cell Abi.calltup_elt_out_ptr
+ in
+ let _ = check_rty_sz (pointee_type out) in
+ let args =
+ let ty_params_cell =
+ get_element_ptr caller_args_cell Abi.calltup_elt_ty_params
+ in
+ let args_cell =
+ get_element_ptr caller_args_cell Abi.calltup_elt_args
+ in
+ let n_args =
+ match args_cell with
+ Il.Mem (_, Il.StructTy elts) -> Array.length elts
+ | _ -> bug () "non-StructTy in Trans.trans_required_fn"
+ in
+ let mk_ty_param i =
+ Il.Cell (get_element_ptr ty_params_cell i)
+ in
+ let mk_arg i =
+ let arg = get_element_ptr args_cell i in
+ let _ = check_rty_sz (Il.cell_referent_ty arg) in
+ Il.Cell arg
+ in
+ Array.append
+ (Array.init n_ty_params mk_ty_param)
+ (Array.init n_args mk_arg)
+ in
+ let nabi = { nabi_convention = conv;
+ nabi_indirect = true }
+ in
+ if conv <> CONV_rust
+ then assert (n_ty_params = 0);
+ trans_upcall "upcall_require_c_sym" f
+ [| Il.Cell (curr_crate_ptr());
+ imm (Int64.of_int lib_num);
+ imm (Int64.of_int c_sym_num);
+ libstr;
+ symstr |];
+
+ abi.Abi.abi_emit_native_call_in_thunk (emitter())
+ out nabi (Il.Cell f) args;
+ end
+
+ | _ -> bug ()
+ "Trans.required_rust_fn on unexpected form of require library"
+ end;
+ emit Il.Leave;
+ match ilib with
+ REQUIRED_LIB_rust _ ->
+ trans_frame_exit fnid false;
+ | REQUIRED_LIB_c _ ->
+ trans_frame_exit fnid true;
+ | _ -> bug ()
+ "Trans.required_rust_fn on unexpected form of require library"
+ in
+
+ let trans_tag
+ (n:Ast.ident)
+ (tagid:node_id)
+ (tag:(Ast.header_tup * Ast.ty_tag * node_id))
+ : unit =
+ trans_frame_entry tagid;
+ trace_str cx.ctxt_sess.Session.sess_trace_tag
+ ("in tag constructor " ^ n);
+ let (header_tup, _, _) = tag in
+ let ctor_ty = Hashtbl.find cx.ctxt_all_item_types tagid in
+ let ttag =
+ match ctor_ty with
+ Ast.TY_fn (tsig, _) ->
+ begin
+ match slot_ty tsig.Ast.sig_output_slot with
+ Ast.TY_tag ttag -> ttag
+ | Ast.TY_iso tiso -> get_iso_tag tiso
+ | _ -> bugi cx tagid "unexpected fn type for tag constructor"
+ end
+ | _ -> bugi cx tagid "unexpected type for tag constructor"
+ in
+ let slots =
+ Array.map (fun sloti -> referent_to_slot cx sloti.id) header_tup
+ in
+ let tag_keys = sorted_htab_keys ttag in
+ let i = arr_idx tag_keys (Ast.NAME_base (Ast.BASE_ident n)) in
+ let _ = log cx "tag variant: %s -> tag value #%d" n i in
+ let out_cell = deref (ptr_at (fp_imm out_mem_disp) (Ast.TY_tag ttag)) in
+ let tag_cell = get_element_ptr out_cell 0 in
+ let union_cell = get_element_ptr_dyn_in_current_frame out_cell 1 in
+ let dst = get_variant_ptr union_cell i in
+ let dst_ty = snd (need_mem_cell dst) in
+ let src = get_explicit_args_for_current_frame () in
+ (* A clever compiler will inline this. We are not clever. *)
+ iflog (fun _ -> annotate (Printf.sprintf "write tag #%d" i));
+ mov tag_cell (imm (Int64.of_int i));
+ iflog (fun _ -> annotate ("copy tag-content tuple: dst_ty=" ^
+ (Il.string_of_referent_ty dst_ty)));
+ trans_copy_tup (get_ty_params_of_current_frame()) true dst src slots;
+ trace_str cx.ctxt_sess.Session.sess_trace_tag
+ ("finished tag constructor " ^ n);
+ trans_frame_exit tagid true;
+ in
+
+ let enter_file_for id =
+ if Hashtbl.mem cx.ctxt_item_files id
+ then Stack.push id curr_file
+ in
+
+ let leave_file_for id =
+ if Hashtbl.mem cx.ctxt_item_files id
+ then
+ if Stack.is_empty curr_file
+ then bugi cx id "Missing source file on file-scope exit."
+ else ignore (Stack.pop curr_file)
+ in
+
+ let visit_local_mod_item_pre n _ i =
+ iflog (fun _ -> log cx "translating local item #%d = %s"
+ (int_of_node i.id) (path_name()));
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f -> trans_fn i.id f.Ast.fn_body
+ | Ast.MOD_ITEM_tag t -> trans_tag n i.id t
+ | Ast.MOD_ITEM_obj ob ->
+ trans_obj_ctor i.id
+ (Array.map (fun (sloti,ident) ->
+ ({sloti with node = get_slot cx sloti.id},ident))
+ ob.Ast.obj_state)
+ | _ -> ()
+ in
+
+ let visit_required_mod_item_pre _ _ i =
+ iflog (fun _ -> log cx "translating required item #%d = %s"
+ (int_of_node i.id) (path_name()));
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f -> trans_required_fn i.id f.Ast.fn_body.id
+ | Ast.MOD_ITEM_mod _ -> ()
+ | Ast.MOD_ITEM_type _ -> ()
+ | _ -> bugi cx i.id "unsupported type of require: %s" (path_name())
+ in
+
+ let visit_obj_drop_pre obj b =
+ let g = GLUE_obj_drop obj.id in
+ let fix =
+ match htab_search cx.ctxt_glue_code g with
+ Some code -> code.code_fixup
+ | None -> bug () "visit_obj_drop_pre without assigned fixup"
+ in
+ let framesz = get_framesz cx b.id in
+ let callsz = get_callsz cx b.id in
+ let spill = Hashtbl.find cx.ctxt_spill_fixups b.id in
+ push_new_emitter_with_vregs (Some b.id);
+ iflog (fun _ -> annotate "prologue");
+ abi.Abi.abi_emit_fn_prologue (emitter())
+ framesz callsz nabi_rust (upcall_fixup "upcall_grow_task");
+ write_frame_info_ptrs None;
+ iflog (fun _ -> annotate "finished prologue");
+ trans_block b;
+ Hashtbl.remove cx.ctxt_glue_code g;
+ trans_glue_frame_exit fix spill g;
+ inner.Walk.visit_obj_drop_pre obj b
+ in
+
+ let visit_local_obj_fn_pre _ _ fn =
+ trans_fn fn.id fn.node.Ast.fn_body
+ in
+
+ let visit_required_obj_fn_pre _ _ _ =
+ ()
+ in
+
+ let visit_obj_fn_pre obj ident fn =
+ enter_file_for fn.id;
+ begin
+ if Hashtbl.mem cx.ctxt_required_items fn.id
+ then
+ visit_required_obj_fn_pre obj ident fn
+ else
+ visit_local_obj_fn_pre obj ident fn;
+ end;
+ inner.Walk.visit_obj_fn_pre obj ident fn
+ in
+
+ let visit_mod_item_pre n p i =
+ enter_file_for i.id;
+ begin
+ if Hashtbl.mem cx.ctxt_required_items i.id
+ then
+ visit_required_mod_item_pre n p i
+ else
+ visit_local_mod_item_pre n p i
+ 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;
+ leave_file_for i.id
+ in
+
+ let visit_obj_fn_post obj ident fn =
+ inner.Walk.visit_obj_fn_post obj ident fn;
+ leave_file_for fn.id
+ in
+
+ let visit_crate_pre crate =
+ enter_file_for crate.id;
+ inner.Walk.visit_crate_pre crate
+ in
+
+ let visit_crate_post crate =
+
+ inner.Walk.visit_crate_post crate;
+
+ let emit_aux_global_glue cx glue fix fn =
+ let glue_name = glue_str cx glue in
+ push_new_emitter_without_vregs None;
+ let e = emitter() in
+ fn e;
+ iflog (fun _ -> annotate_quads glue_name);
+ if (Il.num_vregs e) != 0
+ then bug () "%s uses nonzero vregs" glue_name;
+ pop_emitter();
+ let code =
+ { code_fixup = fix;
+ code_quads = emitted_quads e;
+ code_vregs_and_spill = None; }
+ in
+ htab_put cx.ctxt_glue_code glue code
+ in
+
+ let tab_sz htab =
+ Asm.WORD (word_ty_mach, Asm.IMM (Int64.of_int (Hashtbl.length htab)))
+ in
+
+ let crate_data =
+ (cx.ctxt_crate_fixup,
+ Asm.DEF
+ (cx.ctxt_crate_fixup,
+ Asm.SEQ [|
+ (*
+ * NB: this must match the rust_crate structure
+ * in the rust runtime library.
+ *)
+ crate_rel_word cx.ctxt_image_base_fixup;
+ Asm.WORD (word_ty_mach, Asm.M_POS cx.ctxt_crate_fixup);
+
+ crate_rel_word cx.ctxt_debug_abbrev_fixup;
+ Asm.WORD (word_ty_mach, Asm.M_SZ cx.ctxt_debug_abbrev_fixup);
+
+ crate_rel_word cx.ctxt_debug_info_fixup;
+ Asm.WORD (word_ty_mach, Asm.M_SZ cx.ctxt_debug_info_fixup);
+
+ crate_rel_word cx.ctxt_activate_fixup;
+ crate_rel_word cx.ctxt_exit_task_fixup;
+ crate_rel_word cx.ctxt_unwind_fixup;
+ crate_rel_word cx.ctxt_yield_fixup;
+
+ tab_sz cx.ctxt_required_rust_sym_num;
+ tab_sz cx.ctxt_required_c_sym_num;
+ tab_sz cx.ctxt_required_lib_num;
+ |]))
+ in
+
+ (* Emit additional glue we didn't do elsewhere. *)
+ emit_aux_global_glue cx GLUE_activate
+ cx.ctxt_activate_fixup
+ abi.Abi.abi_activate;
+
+ emit_aux_global_glue cx GLUE_yield
+ cx.ctxt_yield_fixup
+ abi.Abi.abi_yield;
+
+ emit_aux_global_glue cx GLUE_unwind
+ cx.ctxt_unwind_fixup
+ (fun e -> abi.Abi.abi_unwind
+ e nabi_rust (upcall_fixup "upcall_exit"));
+
+ ignore (get_exit_task_glue ());
+
+ begin
+ match abi.Abi.abi_get_next_pc_thunk with
+ None -> ()
+ | Some (_, fix, fn) ->
+ emit_aux_global_glue cx GLUE_get_next_pc fix fn
+ end;
+
+ htab_put cx.ctxt_data
+ DATA_crate crate_data;
+
+ provide_existing_native cx SEG_data "rust_crate" cx.ctxt_crate_fixup;
+
+ leave_file_for crate.id
+ in
+
+ { inner with
+ Walk.visit_crate_pre = visit_crate_pre;
+ Walk.visit_crate_post = visit_crate_post;
+ 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;
+ }
+;;
+
+
+let fixup_assigning_visitor
+ (cx:ctxt)
+ (path:Ast.name_component Stack.t)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let path_name (_:unit) : string =
+ Ast.fmt_to_str Ast.fmt_name (Walk.path_to_name path)
+ in
+
+ let enter_file_for id =
+ if Hashtbl.mem cx.ctxt_item_files id
+ then
+ begin
+ let name =
+ if Stack.is_empty path
+ then "crate root"
+ else path_name()
+ in
+ htab_put cx.ctxt_file_fixups id (new_fixup name);
+ if not (Hashtbl.mem cx.ctxt_file_code id)
+ then htab_put cx.ctxt_file_code id (Hashtbl.create 0);
+ end
+ in
+
+ let visit_mod_item_pre n p i =
+ enter_file_for i.id;
+ begin
+ match i.node.Ast.decl_item with
+
+ Ast.MOD_ITEM_tag _ ->
+ htab_put cx.ctxt_fn_fixups i.id
+ (new_fixup (path_name()));
+
+ | Ast.MOD_ITEM_fn _ ->
+ begin
+ let path = path_name () in
+ let fixup =
+ if (not cx.ctxt_sess.Session.sess_library_mode)
+ && (Some path) = cx.ctxt_main_name
+ then
+ match cx.ctxt_main_fn_fixup with
+ None -> bug () "missing main fixup in trans"
+ | Some fix -> fix
+ else
+ new_fixup path
+ in
+ htab_put cx.ctxt_fn_fixups i.id fixup;
+ end
+
+ | Ast.MOD_ITEM_obj _ ->
+ htab_put cx.ctxt_fn_fixups i.id
+ (new_fixup (path_name()));
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre n p i
+ in
+
+ let visit_obj_fn_pre obj ident fn =
+ htab_put cx.ctxt_fn_fixups fn.id
+ (new_fixup (path_name()));
+ inner.Walk.visit_obj_fn_pre obj ident fn
+ in
+
+ let visit_obj_drop_pre obj b =
+ let g = GLUE_obj_drop obj.id in
+ let fix = new_fixup (path_name()) in
+ let tmp_code = { code_fixup = fix;
+ code_quads = [| |];
+ code_vregs_and_spill = None; } in
+ htab_put cx.ctxt_glue_code g tmp_code;
+ inner.Walk.visit_obj_drop_pre obj b
+ in
+
+ let visit_block_pre b =
+ htab_put cx.ctxt_block_fixups b.id (new_fixup "lexical block");
+ inner.Walk.visit_block_pre b
+ in
+
+ let visit_crate_pre c =
+ enter_file_for c.id;
+ inner.Walk.visit_crate_pre c
+ in
+
+ { inner with
+ Walk.visit_crate_pre = visit_crate_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_block_pre = visit_block_pre; }
+
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : unit =
+ let path = Stack.create () in
+ let passes =
+ [|
+ (fixup_assigning_visitor cx path
+ Walk.empty_visitor);
+ (Walk.mod_item_logging_visitor
+ (log cx "translation pass: %s")
+ path
+ (trans_visitor cx path
+ Walk.empty_visitor))
+ |];
+ in
+ log cx "translating crate";
+ begin
+ match cx.ctxt_main_name with
+ None -> ()
+ | Some m -> log cx "with main fn %s" m
+ end;
+ run_passes cx "trans" path passes (log cx "%s") crate;
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+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 exterior 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 exterior 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 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 slot_mem_ctrl (slot:Ast.slot) : mem_ctrl =
+ let ty = slot_ty slot in
+ match ty with
+ Ast.TY_port _
+ | Ast.TY_chan _
+ | Ast.TY_task
+ | Ast.TY_vec _
+ | Ast.TY_str -> MEM_rc_opaque
+ | _ ->
+ match slot.Ast.slot_mode with
+ Ast.MODE_exterior _ when type_is_structured ty ->
+ if type_has_state ty
+ then MEM_gc
+ else MEM_rc_struct
+ | Ast.MODE_exterior _ ->
+ MEM_rc_opaque
+ | _ ->
+ MEM_interior
+;;
+
+
+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 = referent_to_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 = referent_to_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_slots
+ (get_element_ptr:'a -> int -> 'a)
+ (dst_ptr:'a)
+ (src_ptr:'a)
+ (slots:Ast.ty_tup)
+ (f:'a -> 'a -> Ast.slot -> (Ast.ty_iso option) -> unit)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ Array.iteri
+ begin
+ fun i slot ->
+ f (get_element_ptr dst_ptr i)
+ (get_element_ptr src_ptr i)
+ slot curr_iso
+ end
+ slots
+;;
+
+let iter_rec_slots
+ (get_element_ptr:'a -> int -> 'a)
+ (dst_ptr:'a)
+ (src_ptr:'a)
+ (entries:Ast.ty_rec)
+ (f:'a -> 'a -> Ast.slot -> (Ast.ty_iso option) -> unit)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ iter_tup_slots get_element_ptr dst_ptr src_ptr
+ (Array.map snd entries) f curr_iso
+;;
+
+
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+open Common;;
+open Semant;;
+
+type tyspec =
+ TYSPEC_equiv of tyvar
+ | TYSPEC_all
+ | TYSPEC_resolved of (Ast.ty_param array) * Ast.ty
+ | TYSPEC_callable of (tyvar * tyvar array) (* out, ins *)
+ | TYSPEC_collection of tyvar (* vec or str *)
+ | TYSPEC_comparable (* comparable with = and != *)
+ | TYSPEC_plusable (* nums, vecs, and strings *)
+ | TYSPEC_dictionary of dict
+ | TYSPEC_integral (* int-like *)
+ | TYSPEC_loggable
+ | TYSPEC_numeric (* int-like or float-like *)
+ | TYSPEC_ordered (* comparable with < etc. *)
+ | TYSPEC_record of dict
+ | TYSPEC_tuple of tyvar array (* heterogeneous tuple *)
+ | TYSPEC_vector of tyvar
+ | TYSPEC_app of (tyvar * Ast.ty array)
+
+and dict = (Ast.ident, tyvar) Hashtbl.t
+
+and tyvar = tyspec ref;;
+
+(* Signatures for binary operators. *)
+type binopsig =
+ BINOPSIG_bool_bool_bool (* bool * bool -> bool *)
+ | BINOPSIG_comp_comp_bool (* comparable a * comparable a -> bool *)
+ | BINOPSIG_ord_ord_bool (* ordered a * ordered a -> bool *)
+ | BINOPSIG_integ_integ_integ (* integral a * integral a -> integral a *)
+ | BINOPSIG_num_num_num (* numeric a * numeric a -> numeric a *)
+ | BINOPSIG_plus_plus_plus (* plusable a * plusable a -> plusable a *)
+;;
+
+let rec tyspec_to_str (ts:tyspec) : string =
+
+ let fmt = Format.fprintf in
+ let fmt_ident (ff:Format.formatter) (i:Ast.ident) : unit =
+ fmt ff "%s" i
+ in
+ let fmt_obox ff = Format.pp_open_box ff 4 in
+ let fmt_cbox ff = Format.pp_close_box ff () in
+ let fmt_obr ff = fmt ff "<" in
+ let fmt_cbr ff = fmt ff ">" in
+ let fmt_obb ff = (fmt_obox ff; fmt_obr ff) in
+ let fmt_cbb ff = (fmt_cbox ff; fmt_cbr ff) in
+
+ let rec fmt_fields (flav:string) (ff:Format.formatter) (flds:dict) : unit =
+ fmt_obb ff;
+ fmt ff "%s :" flav;
+ let fmt_entry ident tv =
+ fmt ff "@\n";
+ fmt_ident ff ident;
+ fmt ff " : ";
+ fmt_tyspec ff (!tv);
+ in
+ Hashtbl.iter fmt_entry flds;
+ fmt_cbb ff
+
+ and fmt_app ff tv args =
+ begin
+ assert (Array.length args <> 0);
+ fmt_obb ff;
+ fmt ff "app(";
+ fmt_tyspec ff (!tv);
+ fmt ff ")";
+ Ast.fmt_app_args ff args;
+ fmt_cbb ff;
+ end
+
+ and fmt_tvs ff tvs =
+ fmt_obox ff;
+ let fmt_tv i tv =
+ if i <> 0
+ then fmt ff ", ";
+ fmt_tyspec ff (!tv)
+ in
+ Array.iteri fmt_tv tvs;
+ fmt_cbox ff;
+
+ and fmt_tyspec ff ts =
+ match ts with
+ TYSPEC_all -> fmt ff "<?>"
+ | TYSPEC_comparable -> fmt ff "<comparable>"
+ | TYSPEC_plusable -> fmt ff "<plusable>"
+ | TYSPEC_integral -> fmt ff "<integral>"
+ | TYSPEC_loggable -> fmt ff "<loggable>"
+ | TYSPEC_numeric -> fmt ff "<numeric>"
+ | TYSPEC_ordered -> fmt ff "<ordered>"
+ | TYSPEC_resolved (params, ty) ->
+ if Array.length params <> 0
+ then
+ begin
+ fmt ff "abs";
+ Ast.fmt_decl_params ff params;
+ fmt ff "(";
+ Ast.fmt_ty ff ty;
+ fmt ff ")"
+ end
+ else
+ Ast.fmt_ty ff ty
+
+ | TYSPEC_equiv tv ->
+ fmt_tyspec ff (!tv)
+
+ | TYSPEC_callable (out, ins) ->
+ fmt_obb ff;
+ fmt ff "callable fn(";
+ fmt_tvs ff ins;
+ fmt ff ") -> ";
+ fmt_tyspec ff (!out);
+ fmt_cbb ff;
+
+ | TYSPEC_collection tv ->
+ fmt_obb ff;
+ fmt ff "collection : ";
+ fmt_tyspec ff (!tv);
+ fmt_cbb ff;
+
+ | TYSPEC_tuple tvs ->
+ fmt ff "(";
+ fmt_tvs ff tvs;
+ fmt ff ")";
+
+ | TYSPEC_vector tv ->
+ fmt_obb ff;
+ fmt ff "vector ";
+ fmt_tyspec ff (!tv);
+ fmt_cbb ff;
+
+ | TYSPEC_dictionary dct ->
+ fmt_fields "dictionary" ff dct
+
+ | TYSPEC_record dct ->
+ fmt_fields "record" ff dct
+
+ | TYSPEC_app (tv, args) ->
+ fmt_app ff tv args
+
+ in
+ let buf = Buffer.create 16 in
+ let bf = Format.formatter_of_buffer buf in
+ begin
+ fmt_tyspec bf ts;
+ Format.pp_print_flush bf ();
+ Buffer.contents buf
+ end
+;;
+
+let iflog cx thunk =
+ if cx.ctxt_sess.Session.sess_log_type
+ then thunk ()
+ else ()
+;;
+
+let rec resolve_tyvar (tv:tyvar) : tyvar =
+ match !tv with
+ TYSPEC_equiv subtv -> resolve_tyvar subtv
+ | _ -> tv
+;;
+
+let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
+ let log cx = Session.log "type"
+ cx.ctxt_sess.Session.sess_log_type
+ cx.ctxt_sess.Session.sess_log_out
+ in
+ let retval_tvs = Stack.create () in
+ let push_retval_tv tv =
+ Stack.push tv retval_tvs
+ in
+ let pop_retval_tv _ =
+ ignore (Stack.pop retval_tvs)
+ in
+ let retval_tv _ =
+ Stack.top retval_tvs
+ in
+ let (bindings:(node_id, tyvar) Hashtbl.t) = Hashtbl.create 10 in
+ let (item_params:(node_id, tyvar array) Hashtbl.t) = Hashtbl.create 10 in
+ let (lval_tyvars:(node_id, tyvar) Hashtbl.t) = Hashtbl.create 0 in
+
+ let path = Stack.create () in
+
+ let visitor (cx:ctxt) (inner:Walk.visitor) : Walk.visitor =
+
+ let rec unify_slot
+ (slot:Ast.slot)
+ (id_opt:node_id option)
+ (tv:tyvar) : unit =
+ match id_opt with
+ Some id -> unify_tyvars (Hashtbl.find bindings id) tv
+ | None ->
+ match slot.Ast.slot_ty with
+ None -> bug () "untyped unidentified slot"
+ | Some ty -> unify_ty ty tv
+
+ and check_sane_tyvar tv =
+ match !tv with
+ TYSPEC_resolved (_, (Ast.TY_named _)) ->
+ bug () "named-type in type checker"
+ | _ -> ()
+
+ and unify_tyvars (av:tyvar) (bv:tyvar) : unit =
+ iflog cx (fun _ ->
+ log cx "unifying types:";
+ log cx "input tyvar A: %s" (tyspec_to_str !av);
+ log cx "input tyvar B: %s" (tyspec_to_str !bv));
+ check_sane_tyvar av;
+ check_sane_tyvar bv;
+
+ unify_tyvars' av bv;
+
+ iflog cx (fun _ ->
+ log cx "unified types:";
+ log cx "output tyvar A: %s" (tyspec_to_str !av);
+ log cx "output tyvar B: %s" (tyspec_to_str !bv));
+ check_sane_tyvar av;
+ check_sane_tyvar bv;
+
+ and unify_tyvars' (av:tyvar) (bv:tyvar) : unit =
+ let (a, b) = ((resolve_tyvar av), (resolve_tyvar bv)) in
+ let fail () =
+ err None "mismatched types: %s vs. %s" (tyspec_to_str !av)
+ (tyspec_to_str !bv);
+ in
+
+ let merge_dicts a b =
+ let c = Hashtbl.create ((Hashtbl.length a) + (Hashtbl.length b)) in
+ let merge ident tv_a =
+ if Hashtbl.mem c ident
+ then unify_tyvars (Hashtbl.find c ident) tv_a
+ else Hashtbl.add c ident tv_a
+ in
+ Hashtbl.iter (Hashtbl.add c) b;
+ Hashtbl.iter merge a;
+ c
+ in
+
+ let unify_dict_with_record_fields
+ (dct:dict)
+ (fields:Ast.ty_rec)
+ : unit =
+ let rec find_slot (query:Ast.ident) i : Ast.slot =
+ if i = Array.length fields
+ then fail ()
+ else match fields.(i) with
+ (ident, slot) ->
+ if ident = query then slot
+ else find_slot query (i + 1)
+ in
+
+ let check_entry ident tv =
+ unify_slot (find_slot ident 0) None tv
+ in
+ Hashtbl.iter check_entry dct
+ in
+
+ let unify_dict_with_obj_fns
+ (dct:dict)
+ (fns:(Ast.ident,Ast.ty_fn) Hashtbl.t) : unit =
+ let check_entry (query:Ast.ident) tv : unit =
+ match htab_search fns query with
+ None -> fail ()
+ | Some fn -> unify_ty (Ast.TY_fn fn) tv
+ in
+ Hashtbl.iter check_entry dct
+ in
+
+ let rec is_comparable_or_ordered (comparable:bool) (ty:Ast.ty) : bool =
+ match ty with
+ Ast.TY_mach _ | Ast.TY_int | Ast.TY_uint
+ | Ast.TY_char | Ast.TY_str -> true
+ | Ast.TY_any | Ast.TY_nil | Ast.TY_bool | Ast.TY_chan _
+ | Ast.TY_port _ | Ast.TY_task | Ast.TY_tup _ | Ast.TY_vec _
+ | Ast.TY_rec _ | Ast.TY_tag _ | Ast.TY_iso _ | Ast.TY_idx _ ->
+ comparable
+ | Ast.TY_fn _ | Ast.TY_obj _
+ | Ast.TY_param _ | Ast.TY_native _ | Ast.TY_type -> false
+ | Ast.TY_named _ -> bug () "unexpected named type"
+ | Ast.TY_constrained (ty, _) ->
+ is_comparable_or_ordered comparable ty
+ in
+
+ let floating (ty:Ast.ty) : bool =
+ match ty with
+ Ast.TY_mach TY_f32 | Ast.TY_mach TY_f64 -> true
+ | _ -> false
+ in
+
+ let integral (ty:Ast.ty) : bool =
+ match ty with
+ Ast.TY_int | Ast.TY_mach TY_u8 | Ast.TY_mach TY_u16
+ | Ast.TY_mach TY_u32 | Ast.TY_mach TY_u64 | Ast.TY_mach TY_i8
+ | Ast.TY_mach TY_i16 | Ast.TY_mach TY_i32
+ | Ast.TY_mach TY_i64 ->
+ true
+ | _ -> false
+ in
+
+ let numeric (ty:Ast.ty) : bool = (integral ty) || (floating ty) in
+
+ let plusable (ty:Ast.ty) : bool =
+ match ty with
+ Ast.TY_str -> true
+ | Ast.TY_vec _ -> true
+ | _ -> numeric ty
+ in
+
+ let loggable (ty:Ast.ty) : bool =
+ match ty with
+ Ast.TY_str | Ast.TY_bool | Ast.TY_int | Ast.TY_uint
+ | Ast.TY_char
+ | Ast.TY_mach TY_u8 | Ast.TY_mach TY_u16 | Ast.TY_mach TY_u32
+ | Ast.TY_mach TY_i8 | Ast.TY_mach TY_i16 | Ast.TY_mach TY_i32
+ -> true
+ | _ -> false
+ in
+
+ let result =
+ match (!a, !b) with
+ (TYSPEC_equiv _, _) | (_, TYSPEC_equiv _) ->
+ bug () "equiv found even though tyvar was resolved"
+
+ | (TYSPEC_all, other) | (other, TYSPEC_all) -> other
+
+ (* resolved *)
+
+ | (TYSPEC_resolved (params_a, ty_a),
+ TYSPEC_resolved (params_b, ty_b)) ->
+ if params_a <> params_b || ty_a <> ty_b
+ then fail()
+ else TYSPEC_resolved (params_a, ty_a)
+
+ | (TYSPEC_resolved (params, ty),
+ TYSPEC_callable (out_tv, in_tvs))
+ | (TYSPEC_callable (out_tv, in_tvs),
+ TYSPEC_resolved (params, ty)) ->
+ let unify_in_slot i in_slot =
+ unify_slot in_slot None in_tvs.(i)
+ in
+ begin
+ match ty with
+ Ast.TY_fn ({
+ Ast.sig_input_slots = in_slots;
+ Ast.sig_output_slot = out_slot
+ }, _) ->
+ if Array.length in_slots != Array.length in_tvs
+ then fail ();
+ unify_slot out_slot None out_tv;
+ Array.iteri unify_in_slot in_slots
+ | _ -> fail ()
+ end;
+ TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_collection tv)
+ | (TYSPEC_collection tv, TYSPEC_resolved (params, ty)) ->
+ begin
+ match ty with
+ Ast.TY_vec slot -> unify_slot slot None tv
+ | Ast.TY_str -> unify_ty (Ast.TY_mach TY_u8) tv
+ | _ -> fail ()
+ end;
+ TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_comparable)
+ | (TYSPEC_comparable, TYSPEC_resolved (params, ty)) ->
+ if not (is_comparable_or_ordered true ty) then fail ()
+ else TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_plusable)
+ | (TYSPEC_plusable, TYSPEC_resolved (params, ty)) ->
+ if not (plusable ty) then fail ()
+ else TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_dictionary dct)
+ | (TYSPEC_dictionary dct, TYSPEC_resolved (params, ty)) ->
+ begin
+ match ty with
+ Ast.TY_rec fields ->
+ unify_dict_with_record_fields dct fields
+ | Ast.TY_obj (_, fns) ->
+ unify_dict_with_obj_fns dct fns
+ | _ -> fail ()
+ end;
+ TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_integral)
+ | (TYSPEC_integral, TYSPEC_resolved (params, ty)) ->
+ if not (integral ty)
+ then fail ()
+ else TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_loggable)
+ | (TYSPEC_loggable, TYSPEC_resolved (params, ty)) ->
+ if not (loggable ty)
+ then fail ()
+ else TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_numeric)
+ | (TYSPEC_numeric, TYSPEC_resolved (params, ty)) ->
+ if not (numeric ty) then fail ()
+ else TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_ordered)
+ | (TYSPEC_ordered, TYSPEC_resolved (params, ty)) ->
+ if not (is_comparable_or_ordered false ty) then fail ()
+ else TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_app (tv, args))
+ | (TYSPEC_app (tv, args), TYSPEC_resolved (params, ty)) ->
+ let ty = rebuild_ty_under_params ty params args false in
+ unify_ty ty tv;
+ TYSPEC_resolved ([| |], ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_record dct)
+ | (TYSPEC_record dct, TYSPEC_resolved (params, ty)) ->
+ begin
+ match ty with
+ Ast.TY_rec fields ->
+ unify_dict_with_record_fields dct fields
+ | _ -> fail ()
+ end;
+ TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_tuple tvs)
+ | (TYSPEC_tuple tvs, TYSPEC_resolved (params, ty)) ->
+ begin
+ match ty with
+ Ast.TY_tup (elem_slots:Ast.slot array) ->
+ if (Array.length elem_slots) < (Array.length tvs)
+ then fail ()
+ else
+ let check_elem i tv =
+ unify_slot (elem_slots.(i)) None tv
+ in
+ Array.iteri check_elem tvs
+ | _ -> fail ()
+ end;
+ TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_vector tv)
+ | (TYSPEC_vector tv, TYSPEC_resolved (params, ty)) ->
+ begin
+ match ty with
+ Ast.TY_vec slot ->
+ unify_slot slot None tv;
+ TYSPEC_resolved (params, ty)
+ | _ -> fail ()
+ end
+
+ (* callable *)
+
+ | (TYSPEC_callable (a_out_tv, a_in_tvs),
+ TYSPEC_callable (b_out_tv, b_in_tvs)) ->
+ unify_tyvars a_out_tv b_out_tv;
+ let check_in_tv i a_in_tv =
+ unify_tyvars a_in_tv b_in_tvs.(i)
+ in
+ Array.iteri check_in_tv a_in_tvs;
+ TYSPEC_callable (a_out_tv, a_in_tvs)
+
+ | (TYSPEC_callable _, TYSPEC_collection _)
+ | (TYSPEC_callable _, TYSPEC_comparable)
+ | (TYSPEC_callable _, TYSPEC_plusable)
+ | (TYSPEC_callable _, TYSPEC_dictionary _)
+ | (TYSPEC_callable _, TYSPEC_integral)
+ | (TYSPEC_callable _, TYSPEC_loggable)
+ | (TYSPEC_callable _, TYSPEC_numeric)
+ | (TYSPEC_callable _, TYSPEC_ordered)
+ | (TYSPEC_callable _, TYSPEC_app _)
+ | (TYSPEC_callable _, TYSPEC_record _)
+ | (TYSPEC_callable _, TYSPEC_tuple _)
+ | (TYSPEC_callable _, TYSPEC_vector _)
+ | (TYSPEC_collection _, TYSPEC_callable _)
+ | (TYSPEC_comparable, TYSPEC_callable _)
+ | (TYSPEC_plusable, TYSPEC_callable _)
+ | (TYSPEC_dictionary _, TYSPEC_callable _)
+ | (TYSPEC_integral, TYSPEC_callable _)
+ | (TYSPEC_loggable, TYSPEC_callable _)
+ | (TYSPEC_numeric, TYSPEC_callable _)
+ | (TYSPEC_ordered, TYSPEC_callable _)
+ | (TYSPEC_app _, TYSPEC_callable _)
+ | (TYSPEC_record _, TYSPEC_callable _)
+ | (TYSPEC_tuple _, TYSPEC_callable _)
+ | (TYSPEC_vector _, TYSPEC_callable _) -> fail ()
+
+ (* collection *)
+
+ | (TYSPEC_collection av, TYSPEC_collection bv) ->
+ unify_tyvars av bv;
+ TYSPEC_collection av
+
+ | (TYSPEC_collection av, TYSPEC_comparable)
+ | (TYSPEC_comparable, TYSPEC_collection av) ->
+ TYSPEC_collection av
+
+ | (TYSPEC_collection v, TYSPEC_plusable)
+ | (TYSPEC_plusable, TYSPEC_collection v) -> TYSPEC_collection v
+
+ | (TYSPEC_collection _, TYSPEC_dictionary _)
+ | (TYSPEC_collection _, TYSPEC_integral)
+ | (TYSPEC_collection _, TYSPEC_loggable)
+ | (TYSPEC_collection _, TYSPEC_numeric)
+ | (TYSPEC_collection _, TYSPEC_ordered)
+ | (TYSPEC_collection _, TYSPEC_app _)
+ | (TYSPEC_collection _, TYSPEC_record _)
+ | (TYSPEC_collection _, TYSPEC_tuple _)
+ | (TYSPEC_dictionary _, TYSPEC_collection _)
+ | (TYSPEC_integral, TYSPEC_collection _)
+ | (TYSPEC_loggable, TYSPEC_collection _)
+ | (TYSPEC_numeric, TYSPEC_collection _)
+ | (TYSPEC_ordered, TYSPEC_collection _)
+ | (TYSPEC_app _, TYSPEC_collection _)
+ | (TYSPEC_record _, TYSPEC_collection _)
+ | (TYSPEC_tuple _, TYSPEC_collection _) -> fail ()
+
+ | (TYSPEC_collection av, TYSPEC_vector bv)
+ | (TYSPEC_vector bv, TYSPEC_collection av) ->
+ unify_tyvars av bv;
+ TYSPEC_vector av
+
+ (* comparable *)
+
+ | (TYSPEC_comparable, TYSPEC_comparable) -> TYSPEC_comparable
+
+ | (TYSPEC_comparable, TYSPEC_plusable)
+ | (TYSPEC_plusable, TYSPEC_comparable) -> TYSPEC_plusable
+
+ | (TYSPEC_comparable, TYSPEC_dictionary dict)
+ | (TYSPEC_dictionary dict, TYSPEC_comparable) ->
+ TYSPEC_dictionary dict
+
+ | (TYSPEC_comparable, TYSPEC_integral)
+ | (TYSPEC_integral, TYSPEC_comparable) -> TYSPEC_integral
+
+ | (TYSPEC_comparable, TYSPEC_loggable)
+ | (TYSPEC_loggable, TYSPEC_comparable) -> TYSPEC_loggable
+
+ | (TYSPEC_comparable, TYSPEC_numeric)
+ | (TYSPEC_numeric, TYSPEC_comparable) -> TYSPEC_numeric
+
+ | (TYSPEC_comparable, TYSPEC_ordered)
+ | (TYSPEC_ordered, TYSPEC_comparable) -> TYSPEC_ordered
+
+ | (TYSPEC_comparable, TYSPEC_app _)
+ | (TYSPEC_app _, TYSPEC_comparable) -> fail ()
+
+ | (TYSPEC_comparable, TYSPEC_record r)
+ | (TYSPEC_record r, TYSPEC_comparable) -> TYSPEC_record r
+
+ | (TYSPEC_comparable, TYSPEC_tuple t)
+ | (TYSPEC_tuple t, TYSPEC_comparable) -> TYSPEC_tuple t
+
+ | (TYSPEC_comparable, TYSPEC_vector v)
+ | (TYSPEC_vector v, TYSPEC_comparable) -> TYSPEC_vector v
+
+ (* plusable *)
+
+ | (TYSPEC_plusable, TYSPEC_plusable) -> TYSPEC_plusable
+
+ | (TYSPEC_plusable, TYSPEC_dictionary _)
+ | (TYSPEC_dictionary _, TYSPEC_plusable) -> fail ()
+
+ | (TYSPEC_plusable, TYSPEC_integral)
+ | (TYSPEC_integral, TYSPEC_plusable) -> TYSPEC_integral
+
+ | (TYSPEC_plusable, TYSPEC_loggable)
+ | (TYSPEC_loggable, TYSPEC_plusable) -> TYSPEC_plusable
+
+ | (TYSPEC_plusable, TYSPEC_numeric)
+ | (TYSPEC_numeric, TYSPEC_plusable) -> TYSPEC_numeric
+
+ | (TYSPEC_plusable, TYSPEC_ordered)
+ | (TYSPEC_ordered, TYSPEC_plusable) -> TYSPEC_plusable
+
+ | (TYSPEC_plusable, TYSPEC_record _)
+ | (TYSPEC_record _, TYSPEC_plusable) -> fail ()
+
+ | (TYSPEC_plusable, TYSPEC_tuple _)
+ | (TYSPEC_tuple _, TYSPEC_plusable) -> fail ()
+
+ | (TYSPEC_plusable, TYSPEC_vector v)
+ | (TYSPEC_vector v, TYSPEC_plusable) -> TYSPEC_vector v
+
+ | (TYSPEC_plusable, TYSPEC_app _)
+ | (TYSPEC_app _, TYSPEC_plusable) -> fail ()
+
+ (* dictionary *)
+
+ | (TYSPEC_dictionary da, TYSPEC_dictionary db) ->
+ TYSPEC_dictionary (merge_dicts da db)
+
+ | (TYSPEC_dictionary _, TYSPEC_integral)
+ | (TYSPEC_dictionary _, TYSPEC_loggable)
+ | (TYSPEC_dictionary _, TYSPEC_numeric)
+ | (TYSPEC_dictionary _, TYSPEC_ordered)
+ | (TYSPEC_dictionary _, TYSPEC_app _)
+ | (TYSPEC_integral, TYSPEC_dictionary _)
+ | (TYSPEC_loggable, TYSPEC_dictionary _)
+ | (TYSPEC_numeric, TYSPEC_dictionary _)
+ | (TYSPEC_ordered, TYSPEC_dictionary _)
+ | (TYSPEC_app _, TYSPEC_dictionary _) -> fail ()
+
+ | (TYSPEC_dictionary d, TYSPEC_record r)
+ | (TYSPEC_record r, TYSPEC_dictionary d) ->
+ TYSPEC_record (merge_dicts d r)
+
+ | (TYSPEC_dictionary _, TYSPEC_tuple _)
+ | (TYSPEC_dictionary _, TYSPEC_vector _)
+ | (TYSPEC_tuple _, TYSPEC_dictionary _)
+ | (TYSPEC_vector _, TYSPEC_dictionary _) -> fail ()
+
+ (* integral *)
+
+ | (TYSPEC_integral, TYSPEC_integral)
+ | (TYSPEC_integral, TYSPEC_loggable)
+ | (TYSPEC_integral, TYSPEC_numeric)
+ | (TYSPEC_integral, TYSPEC_ordered)
+ | (TYSPEC_loggable, TYSPEC_integral)
+ | (TYSPEC_numeric, TYSPEC_integral)
+ | (TYSPEC_ordered, TYSPEC_integral) -> TYSPEC_integral
+
+ | (TYSPEC_integral, TYSPEC_app _)
+ | (TYSPEC_integral, TYSPEC_record _)
+ | (TYSPEC_integral, TYSPEC_tuple _)
+ | (TYSPEC_integral, TYSPEC_vector _)
+ | (TYSPEC_app _, TYSPEC_integral)
+ | (TYSPEC_record _, TYSPEC_integral)
+ | (TYSPEC_tuple _, TYSPEC_integral)
+ | (TYSPEC_vector _, TYSPEC_integral) -> fail ()
+
+ (* loggable *)
+
+ | (TYSPEC_loggable, TYSPEC_loggable) -> TYSPEC_loggable
+
+ | (TYSPEC_loggable, TYSPEC_numeric)
+ | (TYSPEC_numeric, TYSPEC_loggable) -> TYSPEC_numeric
+
+ | (TYSPEC_loggable, TYSPEC_ordered)
+ | (TYSPEC_ordered, TYSPEC_loggable) -> TYSPEC_ordered
+
+ | (TYSPEC_loggable, TYSPEC_app _)
+ | (TYSPEC_loggable, TYSPEC_record _)
+ | (TYSPEC_loggable, TYSPEC_tuple _)
+ | (TYSPEC_loggable, TYSPEC_vector _)
+ | (TYSPEC_app _, TYSPEC_loggable)
+ | (TYSPEC_record _, TYSPEC_loggable)
+ | (TYSPEC_tuple _, TYSPEC_loggable)
+ | (TYSPEC_vector _, TYSPEC_loggable) -> fail ()
+
+ (* numeric *)
+
+ | (TYSPEC_numeric, TYSPEC_numeric) -> TYSPEC_numeric
+
+ | (TYSPEC_numeric, TYSPEC_ordered)
+ | (TYSPEC_ordered, TYSPEC_numeric) -> TYSPEC_ordered
+
+ | (TYSPEC_numeric, TYSPEC_app _)
+ | (TYSPEC_numeric, TYSPEC_record _)
+ | (TYSPEC_numeric, TYSPEC_tuple _)
+ | (TYSPEC_numeric, TYSPEC_vector _)
+ | (TYSPEC_app _, TYSPEC_numeric)
+ | (TYSPEC_record _, TYSPEC_numeric)
+ | (TYSPEC_tuple _, TYSPEC_numeric)
+ | (TYSPEC_vector _, TYSPEC_numeric) -> fail ()
+
+ (* ordered *)
+
+ | (TYSPEC_ordered, TYSPEC_ordered) -> TYSPEC_ordered
+
+ | (TYSPEC_ordered, TYSPEC_app _)
+ | (TYSPEC_ordered, TYSPEC_record _)
+ | (TYSPEC_ordered, TYSPEC_tuple _)
+ | (TYSPEC_ordered, TYSPEC_vector _)
+ | (TYSPEC_app _, TYSPEC_ordered)
+ | (TYSPEC_record _, TYSPEC_ordered)
+ | (TYSPEC_tuple _, TYSPEC_ordered)
+ | (TYSPEC_vector _, TYSPEC_ordered) -> fail ()
+
+ (* app *)
+
+ | (TYSPEC_app (tv_a, args_a),
+ TYSPEC_app (tv_b, args_b)) ->
+ if args_a <> args_b
+ then fail()
+ else
+ begin
+ unify_tyvars tv_a tv_b;
+ TYSPEC_app (tv_a, args_a)
+ end
+
+ | (TYSPEC_app _, TYSPEC_record _)
+ | (TYSPEC_app _, TYSPEC_tuple _)
+ | (TYSPEC_app _, TYSPEC_vector _)
+ | (TYSPEC_record _, TYSPEC_app _)
+ | (TYSPEC_tuple _, TYSPEC_app _)
+ | (TYSPEC_vector _, TYSPEC_app _) -> fail ()
+
+ (* record *)
+
+ | (TYSPEC_record da, TYSPEC_record db) ->
+ TYSPEC_record (merge_dicts da db)
+
+ | (TYSPEC_record _, TYSPEC_tuple _)
+ | (TYSPEC_record _, TYSPEC_vector _)
+ | (TYSPEC_tuple _, TYSPEC_record _)
+ | (TYSPEC_vector _, TYSPEC_record _) -> fail ()
+
+ (* tuple *)
+
+ | (TYSPEC_tuple tvs_a, TYSPEC_tuple tvs_b) ->
+ let len_a = Array.length tvs_a in
+ let len_b = Array.length tvs_b in
+ let max_len = max len_a len_b in
+ let init_tuple_elem i =
+ if i >= len_a
+ then tvs_b.(i)
+ else if i >= len_b
+ then tvs_a.(i)
+ else begin
+ unify_tyvars tvs_a.(i) tvs_b.(i);
+ tvs_a.(i)
+ end
+ in
+ TYSPEC_tuple (Array.init max_len init_tuple_elem)
+
+ | (TYSPEC_tuple _, TYSPEC_vector _)
+ | (TYSPEC_vector _, TYSPEC_tuple _) -> fail ()
+
+ (* vector *)
+
+ | (TYSPEC_vector av, TYSPEC_vector bv) ->
+ unify_tyvars av bv;
+ TYSPEC_vector av
+ in
+ let c = ref result in
+ a := TYSPEC_equiv c;
+ b := TYSPEC_equiv c
+
+ and unify_ty (ty:Ast.ty) (tv:tyvar) : unit =
+ unify_tyvars (ref (TYSPEC_resolved ([||], ty))) tv
+ in
+
+ let rec unify_atom (atom:Ast.atom) (tv:tyvar) : unit =
+ match atom with
+ Ast.ATOM_literal { node = literal; id = _ } ->
+ let ty = match literal with
+ Ast.LIT_nil -> Ast.TY_nil
+ | Ast.LIT_bool _ -> Ast.TY_bool
+ | Ast.LIT_mach (mty, _, _) -> Ast.TY_mach mty
+ | Ast.LIT_int (_, _) -> Ast.TY_int
+ | Ast.LIT_uint (_, _) -> Ast.TY_uint
+ | Ast.LIT_char _ -> Ast.TY_char
+ in
+ unify_ty ty tv
+ | Ast.ATOM_lval lval -> unify_lval lval tv
+
+ and unify_expr (expr:Ast.expr) (tv:tyvar) : unit =
+ match expr with
+ Ast.EXPR_binary (binop, lhs, rhs) ->
+ let binop_sig = match binop with
+ Ast.BINOP_eq
+ | Ast.BINOP_ne -> BINOPSIG_comp_comp_bool
+
+ | Ast.BINOP_lt
+ | Ast.BINOP_le
+ | Ast.BINOP_ge
+ | Ast.BINOP_gt -> BINOPSIG_ord_ord_bool
+
+ | Ast.BINOP_or
+ | Ast.BINOP_and
+ | Ast.BINOP_xor
+ | Ast.BINOP_lsl
+ | Ast.BINOP_lsr
+ | Ast.BINOP_asr -> BINOPSIG_integ_integ_integ
+
+ | Ast.BINOP_add -> BINOPSIG_plus_plus_plus
+
+ | Ast.BINOP_sub
+ | Ast.BINOP_mul
+ | Ast.BINOP_div
+ | Ast.BINOP_mod -> BINOPSIG_num_num_num
+
+ | Ast.BINOP_send -> bug () "BINOP_send found in expr"
+ in
+ begin
+ match binop_sig with
+ BINOPSIG_bool_bool_bool ->
+ unify_atom lhs
+ (ref (TYSPEC_resolved ([||], Ast.TY_bool)));
+ unify_atom rhs
+ (ref (TYSPEC_resolved ([||], Ast.TY_bool)));
+ unify_ty Ast.TY_bool tv
+ | BINOPSIG_comp_comp_bool ->
+ let tv_a = ref TYSPEC_comparable in
+ unify_atom lhs tv_a;
+ unify_atom rhs tv_a;
+ unify_ty Ast.TY_bool tv
+ | BINOPSIG_ord_ord_bool ->
+ let tv_a = ref TYSPEC_ordered in
+ unify_atom lhs tv_a;
+ unify_atom rhs tv_a;
+ unify_ty Ast.TY_bool tv
+ | BINOPSIG_integ_integ_integ ->
+ let tv_a = ref TYSPEC_integral in
+ unify_atom lhs tv_a;
+ unify_atom rhs tv_a;
+ unify_tyvars tv tv_a
+ | BINOPSIG_num_num_num ->
+ let tv_a = ref TYSPEC_numeric in
+ unify_atom lhs tv_a;
+ unify_atom rhs tv_a;
+ unify_tyvars tv tv_a
+ | BINOPSIG_plus_plus_plus ->
+ let tv_a = ref TYSPEC_plusable in
+ unify_atom lhs tv_a;
+ unify_atom rhs tv_a;
+ unify_tyvars tv tv_a
+ end
+ | Ast.EXPR_unary (unop, atom) ->
+ begin
+ match unop with
+ Ast.UNOP_not ->
+ unify_atom atom
+ (ref (TYSPEC_resolved ([||], Ast.TY_bool)));
+ unify_ty Ast.TY_bool tv
+ | Ast.UNOP_bitnot ->
+ let tv_a = ref TYSPEC_integral in
+ unify_atom atom tv_a;
+ unify_tyvars tv tv_a
+ | Ast.UNOP_neg ->
+ let tv_a = ref TYSPEC_numeric in
+ unify_atom atom tv_a;
+ unify_tyvars tv tv_a
+ | Ast.UNOP_cast t ->
+ (*
+ * FIXME: check cast-validity in post-typecheck pass.
+ * Only some casts make sense.
+ *)
+ let tv_a = ref TYSPEC_all in
+ let t = Hashtbl.find cx.ctxt_all_cast_types t.id in
+ unify_atom atom tv_a;
+ unify_ty t tv
+ end
+ | Ast.EXPR_atom atom -> unify_atom atom tv
+
+ and unify_lval' (lval:Ast.lval) (tv:tyvar) : unit =
+ let note_args args =
+ iflog cx (fun _ -> log cx "noting lval '%a' type arguments: %a"
+ Ast.sprintf_lval lval Ast.sprintf_app_args args);
+ Hashtbl.add
+ cx.ctxt_call_lval_params
+ (lval_base_id lval)
+ args;
+ in
+ match lval with
+ Ast.LVAL_base nbi ->
+ let referent = Hashtbl.find cx.ctxt_lval_to_referent nbi.id in
+ begin
+ match Hashtbl.find cx.ctxt_all_defns referent with
+ DEFN_slot slot ->
+ iflog cx
+ begin
+ fun _ ->
+ let tv = Hashtbl.find bindings referent in
+ log cx "lval-base slot tyspec for %a = %s"
+ Ast.sprintf_lval lval (tyspec_to_str (!tv));
+ end;
+ unify_slot slot (Some referent) tv
+
+ | _ ->
+ let spec = (!(Hashtbl.find bindings referent)) in
+ let _ =
+ iflog cx
+ begin
+ fun _ ->
+ log cx "lval-base item tyspec for %a = %s"
+ Ast.sprintf_lval lval (tyspec_to_str spec);
+ log cx "unifying with supplied spec %s"
+ (tyspec_to_str !tv)
+ end
+ in
+ let tv =
+ match nbi.node with
+ Ast.BASE_ident _ -> tv
+ | Ast.BASE_app (_, args) ->
+ note_args args;
+ ref (TYSPEC_app (tv, args))
+ | _ -> err None "bad lval / tyspec combination"
+ in
+ unify_tyvars (ref spec) tv
+ end
+ | Ast.LVAL_ext (base, comp) ->
+ let base_ts = match comp with
+ Ast.COMP_named (Ast.COMP_ident id) ->
+ let names = Hashtbl.create 1 in
+ Hashtbl.add names id tv;
+ TYSPEC_dictionary names
+
+ | Ast.COMP_named (Ast.COMP_app (id, args)) ->
+ note_args args;
+ let tv = ref (TYSPEC_app (tv, args)) in
+ let names = Hashtbl.create 1 in
+ Hashtbl.add names id tv;
+ TYSPEC_dictionary names
+
+ | Ast.COMP_named (Ast.COMP_idx i) ->
+ let init j = if i + 1 == j then tv else ref TYSPEC_all in
+ TYSPEC_tuple (Array.init (i + 1) init)
+
+ | Ast.COMP_atom atom ->
+ unify_atom atom (ref (TYSPEC_resolved ([||], Ast.TY_int)));
+ TYSPEC_collection tv
+ in
+ let base_tv = ref base_ts in
+ unify_lval' base base_tv;
+ match !(resolve_tyvar base_tv) with
+ TYSPEC_resolved (_, ty) ->
+ unify_ty (slot_ty (project_type_to_slot ty comp)) tv
+ | _ ->
+ ()
+
+ and unify_lval (lval:Ast.lval) (tv:tyvar) : unit =
+ let id = lval_base_id lval in
+ (* Fetch lval with type components resolved. *)
+ let lval = Hashtbl.find cx.ctxt_all_lvals id in
+ iflog cx (fun _ -> log cx
+ "fetched resolved version of lval #%d = %a"
+ (int_of_node id) Ast.sprintf_lval lval);
+ Hashtbl.add lval_tyvars id tv;
+ unify_lval' lval tv
+
+ in
+ let gen_atom_tvs atoms =
+ let gen_atom_tv atom =
+ let tv = ref TYSPEC_all in
+ unify_atom atom tv;
+ tv
+ in
+ Array.map gen_atom_tv atoms
+ in
+ let visit_stmt_pre_full (stmt:Ast.stmt) : unit =
+
+ let check_callable out_tv callee args =
+ let in_tvs = gen_atom_tvs args in
+ let callee_tv = ref (TYSPEC_callable (out_tv, in_tvs)) in
+ unify_lval callee callee_tv;
+ in
+ match stmt.node with
+ Ast.STMT_spawn (out, _, callee, args) ->
+ let out_tv = ref (TYSPEC_resolved ([||], Ast.TY_nil)) in
+ unify_lval out (ref (TYSPEC_resolved ([||], Ast.TY_task)));
+ check_callable out_tv callee args
+
+ | Ast.STMT_init_rec (lval, fields, Some base) ->
+ let dct = Hashtbl.create 10 in
+ let tvrec = ref (TYSPEC_record dct) in
+ let add_field (ident, _, _, atom) =
+ let tv = ref TYSPEC_all in
+ unify_atom atom tv;
+ Hashtbl.add dct ident tv
+ in
+ Array.iter add_field fields;
+ let tvbase = ref TYSPEC_all in
+ unify_lval base tvbase;
+ unify_tyvars tvrec tvbase;
+ unify_lval lval tvrec
+
+ | Ast.STMT_init_rec (lval, fields, None) ->
+ let dct = Hashtbl.create 10 in
+ let add_field (ident, _, _, atom) =
+ let tv = ref TYSPEC_all in
+ unify_atom atom tv;
+ Hashtbl.add dct ident tv
+ in
+ Array.iter add_field fields;
+ unify_lval lval (ref (TYSPEC_record dct))
+
+ | Ast.STMT_init_tup (lval, members) ->
+ let member_to_tv (_, _, atom) =
+ let tv = ref TYSPEC_all in
+ unify_atom atom tv;
+ tv
+ in
+ let member_tvs = Array.map member_to_tv members in
+ unify_lval lval (ref (TYSPEC_tuple member_tvs))
+
+ | Ast.STMT_init_vec (lval, _, atoms) ->
+ let tv = ref TYSPEC_all in
+ let unify_with_tv atom = unify_atom atom tv in
+ Array.iter unify_with_tv atoms;
+ unify_lval lval (ref (TYSPEC_vector tv))
+
+ | Ast.STMT_init_str (lval, _) ->
+ unify_lval lval (ref (TYSPEC_resolved ([||], Ast.TY_str)))
+
+ | Ast.STMT_copy (lval, expr) ->
+ let tv = ref TYSPEC_all in
+ unify_expr expr tv;
+ unify_lval lval tv
+
+ | Ast.STMT_copy_binop (lval, binop, at) ->
+ let tv = ref TYSPEC_all in
+ unify_expr (Ast.EXPR_binary (binop, Ast.ATOM_lval lval, at)) tv;
+ unify_lval lval tv;
+
+ | Ast.STMT_call (out, callee, args) ->
+ let out_tv = ref TYSPEC_all in
+ unify_lval out out_tv;
+ check_callable out_tv callee args
+
+ | Ast.STMT_log atom -> unify_atom atom (ref TYSPEC_loggable)
+
+ | Ast.STMT_check_expr expr ->
+ unify_expr expr (ref (TYSPEC_resolved ([||], Ast.TY_bool)))
+
+ | Ast.STMT_check (_, check_calls) ->
+ let out_tv = ref (TYSPEC_resolved ([||], Ast.TY_bool)) in
+ Array.iter
+ (fun (callee, args) ->
+ check_callable out_tv callee args)
+ check_calls
+
+ | Ast.STMT_while { Ast.while_lval = (_, expr); Ast.while_body = _ } ->
+ unify_expr expr (ref (TYSPEC_resolved ([||], Ast.TY_bool)))
+
+ | Ast.STMT_if { Ast.if_test = if_test } ->
+ unify_expr if_test (ref (TYSPEC_resolved ([||], Ast.TY_bool)));
+
+ | Ast.STMT_decl _ -> ()
+
+ (* FIXME: deal with difference between return-type vs. put-type *)
+ | Ast.STMT_ret atom_opt
+ | Ast.STMT_put atom_opt ->
+ begin
+ match atom_opt with
+ None -> unify_ty Ast.TY_nil (retval_tv())
+ | Some atom -> unify_atom atom (retval_tv())
+ end
+
+ | Ast.STMT_be (callee, args) ->
+ check_callable (retval_tv()) callee args
+
+ | Ast.STMT_bind (bound, callee, arg_opts) ->
+ (* FIXME: handle binding type parameters eventually. *)
+ let out_tv = ref TYSPEC_all in
+ let residue = ref [] in
+ let gen_atom_opt_tvs atoms =
+ let gen_atom_tv atom_opt =
+ let tv = ref TYSPEC_all in
+ begin
+ match atom_opt with
+ None -> residue := tv :: (!residue);
+ | Some atom -> unify_atom atom tv
+ end;
+ tv
+ in
+ Array.map gen_atom_tv atoms
+ in
+
+ let in_tvs = gen_atom_opt_tvs arg_opts in
+ let arg_residue_tvs = Array.of_list (List.rev (!residue)) in
+ let callee_tv = ref (TYSPEC_callable (out_tv, in_tvs)) in
+ let bound_tv = ref (TYSPEC_callable (out_tv, arg_residue_tvs)) in
+ unify_lval callee callee_tv;
+ unify_lval bound bound_tv
+
+ | Ast.STMT_for_each fe ->
+ let out_tv = ref TYSPEC_all in
+ let (si, _) = fe.Ast.for_each_slot in
+ let (callee, args) = fe.Ast.for_each_call in
+ unify_slot si.node (Some si.id) out_tv;
+ check_callable out_tv callee args
+
+ | Ast.STMT_for fo ->
+ let mem_tv = ref TYSPEC_all in
+ let seq_tv = ref (TYSPEC_collection mem_tv) in
+ let (si, _) = fo.Ast.for_slot in
+ let (_, seq) = fo.Ast.for_seq in
+ unify_lval seq seq_tv;
+ unify_slot si.node (Some si.id) mem_tv
+
+ (* FIXME (issue #52): plenty more to handle here. *)
+ | _ ->
+ log cx "warning: not typechecking stmt %s\n"
+ (Ast.sprintf_stmt () stmt)
+ in
+
+ let visit_stmt_pre (stmt:Ast.stmt) : unit =
+ try
+ visit_stmt_pre_full stmt;
+ (*
+ * Reset any item-parameters that were resolved to types
+ * during inference for this statement.
+ *)
+ Hashtbl.iter
+ (fun _ params -> Array.iter (fun tv -> tv := TYSPEC_all) params)
+ item_params;
+ with
+ Semant_err (None, msg) ->
+ raise (Semant_err ((Some stmt.id), msg))
+ in
+
+ let enter_fn fn retspec =
+ let out = fn.Ast.fn_output_slot in
+ push_retval_tv (ref retspec);
+ unify_slot out.node (Some out.id) (retval_tv())
+ in
+
+ let visit_obj_fn_pre obj ident fn =
+ enter_fn fn.node TYSPEC_all;
+ 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;
+ pop_retval_tv ();
+ in
+
+ let visit_mod_item_pre n p mod_item =
+ begin
+ try
+ match mod_item.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn fn ->
+ enter_fn fn TYSPEC_all
+
+ | _ -> ()
+ with Semant_err (None, msg) ->
+ raise (Semant_err ((Some mod_item.id), msg))
+ end;
+ inner.Walk.visit_mod_item_pre n p mod_item
+ in
+
+ let path_name (_:unit) : string =
+ string_of_name (Walk.path_to_name path)
+ in
+
+ let visit_mod_item_post n p mod_item =
+ inner.Walk.visit_mod_item_post n p mod_item;
+ match mod_item.node.Ast.decl_item with
+
+ | Ast.MOD_ITEM_fn _ ->
+ pop_retval_tv ();
+ if (Some (path_name())) = cx.ctxt_main_name
+ then
+ begin
+ match Hashtbl.find cx.ctxt_all_item_types mod_item.id with
+ Ast.TY_fn (tsig, _) ->
+ begin
+ let vec_str =
+ interior_slot (Ast.TY_vec
+ (interior_slot Ast.TY_str))
+ in
+ match tsig.Ast.sig_input_slots with
+ [| |] -> ()
+ | [| vs |] when vs = vec_str -> ()
+ | _ -> err (Some mod_item.id)
+ "main fn has bad type signature"
+ end
+ | _ ->
+ err (Some mod_item.id) "main item is not a function"
+ end
+ | _ -> ()
+ 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_stmt_pre = visit_stmt_pre
+ }
+
+ in
+ try
+ let auto_queue = Queue.create () in
+
+ let init_slot_tyvar id defn =
+ match defn with
+ DEFN_slot { Ast.slot_mode = _; Ast.slot_ty = None } ->
+ Queue.add id auto_queue;
+ Hashtbl.add bindings id (ref TYSPEC_all)
+ | DEFN_slot { Ast.slot_mode = _; Ast.slot_ty = Some ty } ->
+ let _ = iflog cx (fun _ -> log cx "initial slot #%d type: %a"
+ (int_of_node id) Ast.sprintf_ty ty)
+ in
+ Hashtbl.add bindings id (ref (TYSPEC_resolved ([||], ty)))
+ | _ -> ()
+ in
+
+ let init_item_tyvar id ty =
+ let _ = iflog cx (fun _ -> log cx "initial item #%d type: %a"
+ (int_of_node id) Ast.sprintf_ty ty)
+ in
+ let params =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_item i -> Array.map (fun p -> p.node) i.Ast.decl_params
+ | DEFN_obj_fn _ -> [| |]
+ | DEFN_obj_drop _ -> [| |]
+ | DEFN_loop_body _ -> [| |]
+ | _ -> err (Some id) "expected item defn for item tyvar"
+ in
+ let spec = TYSPEC_resolved (params, ty) in
+ Hashtbl.add bindings id (ref spec)
+ in
+
+ let init_mod_dict id defn =
+ let rec tv_of_item id item =
+ match item.Ast.decl_item with
+ Ast.MOD_ITEM_mod (_, items) ->
+ if Hashtbl.mem bindings id
+ then Hashtbl.find bindings id
+ else
+ let dict = htab_map items
+ (fun i item -> (i, tv_of_item item.id item.node))
+ in
+ let spec = TYSPEC_dictionary dict in
+ let tv = ref spec in
+ Hashtbl.add bindings id tv;
+ tv
+ | _ ->
+ Hashtbl.find bindings id
+ in
+ match defn with
+ DEFN_item ({ Ast.decl_item=Ast.MOD_ITEM_mod _ } as item) ->
+ ignore (tv_of_item id item)
+ | _ -> ()
+ in
+ Hashtbl.iter init_slot_tyvar cx.ctxt_all_defns;
+ Hashtbl.iter init_item_tyvar cx.ctxt_all_item_types;
+ Hashtbl.iter init_mod_dict cx.ctxt_all_defns;
+ Walk.walk_crate
+ (Walk.path_managing_visitor path
+ (Walk.mod_item_logging_visitor
+ (log cx "typechecking pass: %s")
+ path
+ (visitor cx Walk.empty_visitor)))
+ crate;
+
+ let update_auto_tyvar id ty =
+ let defn = Hashtbl.find cx.ctxt_all_defns id in
+ match defn with
+ DEFN_slot slot_defn ->
+ Hashtbl.replace cx.ctxt_all_defns id
+ (DEFN_slot { slot_defn with Ast.slot_ty = Some ty })
+ | _ -> bug () "check_auto_tyvar: no slot defn"
+ in
+
+ let get_resolved_ty tv id =
+ let ts = !(resolve_tyvar tv) in
+ match ts with
+ TYSPEC_resolved ([||], ty) -> ty
+ | TYSPEC_vector (tv) ->
+ begin
+ match !(resolve_tyvar tv) with
+ TYSPEC_resolved ([||], ty) ->
+ (Ast.TY_vec (interior_slot ty))
+ | _ ->
+ err (Some id)
+ "unresolved vector-element type in %s (%d)"
+ (tyspec_to_str ts) (int_of_node id)
+ end
+ | _ -> err (Some id)
+ "unresolved type %s (%d)"
+ (tyspec_to_str ts)
+ (int_of_node id)
+ in
+
+ let check_auto_tyvar id =
+ let tv = Hashtbl.find bindings id in
+ let ty = get_resolved_ty tv id in
+ update_auto_tyvar id ty
+ in
+
+ let record_lval_ty id tv =
+ let ty = get_resolved_ty tv id in
+ Hashtbl.add cx.ctxt_all_lval_types id ty
+ in
+
+ Queue.iter check_auto_tyvar auto_queue;
+ Hashtbl.iter record_lval_ty lval_tyvars;
+ with Semant_err (ido, str) -> report_err cx ido str
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
+
--- /dev/null
+open Semant;;
+open Common;;
+
+
+let log cx = Session.log "typestate"
+ cx.ctxt_sess.Session.sess_log_typestate
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+let iflog cx thunk =
+ if cx.ctxt_sess.Session.sess_log_typestate
+ then thunk ()
+ else ()
+;;
+
+let name_base_to_slot_key (nb:Ast.name_base) : Ast.slot_key =
+ match nb with
+ Ast.BASE_ident ident -> Ast.KEY_ident ident
+ | Ast.BASE_temp tmp -> Ast.KEY_temp tmp
+ | Ast.BASE_app _ -> bug () "name_base_to_slot_key on parametric name"
+;;
+
+let determine_constr_key
+ (cx:ctxt)
+ (scopes:(scope list))
+ (formal_base:node_id option)
+ (c:Ast.constr)
+ : constr_key =
+
+ let cid =
+ match lookup_by_name cx scopes c.Ast.constr_name with
+ Some (_, cid) ->
+ if referent_is_item cx cid
+ then
+ begin
+ match Hashtbl.find cx.ctxt_all_item_types cid with
+ Ast.TY_fn (_, taux) ->
+ begin
+ if taux.Ast.fn_effect = Ast.PURE
+ then cid
+ else err (Some cid) "impure function used in constraint"
+ end
+ | _ -> bug () "bad type of predicate"
+ end
+ else
+ bug () "slot used as predicate"
+ | None -> bug () "predicate not found"
+ in
+
+ let constr_arg_of_carg carg =
+ match carg with
+ Ast.CARG_path pth ->
+ let rec node_base_of pth =
+ match pth with
+ Ast.CARG_base Ast.BASE_formal ->
+ begin
+ match formal_base with
+ Some id -> id
+ | None ->
+ bug () "formal symbol * used in free constraint"
+ end
+ | Ast.CARG_ext (pth, _) -> node_base_of pth
+ | Ast.CARG_base (Ast.BASE_named nb) ->
+ begin
+ match lookup_by_name cx scopes (Ast.NAME_base nb) with
+ None -> bug () "constraint-arg not found"
+ | Some (_, aid) ->
+ if referent_is_slot cx aid
+ then
+ if type_has_state
+ (slot_ty (referent_to_slot cx aid))
+ then err (Some aid)
+ "predicate applied to slot of mutable type"
+ else aid
+ else
+ (* Items are always constant, they're ok.
+ * Weird to be using them in a constr, but ok. *)
+ aid
+ end
+ in
+ Constr_arg_node (node_base_of pth, pth)
+
+ | Ast.CARG_lit lit -> Constr_arg_lit lit
+ in
+ Constr_pred (cid, Array.map constr_arg_of_carg c.Ast.constr_args)
+;;
+
+let fmt_constr_key cx ckey =
+ match ckey with
+ Constr_pred (cid, args) ->
+ let fmt_constr_arg carg =
+ match carg with
+ Constr_arg_lit lit ->
+ Ast.fmt_to_str Ast.fmt_lit lit
+ | Constr_arg_node (id, pth) ->
+ let rec fmt_pth pth =
+ match pth with
+ Ast.CARG_base _ ->
+ if referent_is_slot cx id
+ then
+ let key = Hashtbl.find cx.ctxt_slot_keys id in
+ Ast.fmt_to_str Ast.fmt_slot_key key
+ else
+ let n = Hashtbl.find cx.ctxt_all_item_names id in
+ Ast.fmt_to_str Ast.fmt_name n
+ | Ast.CARG_ext (pth, nc) ->
+ let b = fmt_pth pth in
+ b ^ (Ast.fmt_to_str Ast.fmt_name_component nc)
+ in
+ fmt_pth pth
+ in
+ let pred_name = Hashtbl.find cx.ctxt_all_item_names cid in
+ Printf.sprintf "%s(%s)"
+ (Ast.fmt_to_str Ast.fmt_name pred_name)
+ (String.concat ", "
+ (List.map
+ fmt_constr_arg
+ (Array.to_list args)))
+
+ | Constr_init n when Hashtbl.mem cx.ctxt_slot_keys n ->
+ Printf.sprintf "<init #%d = %s>"
+ (int_of_node n)
+ (Ast.fmt_to_str Ast.fmt_slot_key (Hashtbl.find cx.ctxt_slot_keys n))
+ | Constr_init n ->
+ Printf.sprintf "<init #%d>" (int_of_node n)
+;;
+
+let entry_keys header constrs resolver =
+ let init_keys =
+ Array.map
+ (fun (sloti, _) -> (Constr_init sloti.id))
+ header
+ in
+ let names =
+ Array.map
+ (fun (_, ident) -> (Some (Ast.BASE_ident ident)))
+ header
+ in
+ let input_constrs =
+ Array.map (apply_names_to_constr names) constrs in
+ let input_keys = Array.map resolver input_constrs in
+ (input_keys, init_keys)
+;;
+
+let obj_keys ob resolver =
+ entry_keys ob.Ast.obj_state ob.Ast.obj_constrs resolver
+;;
+
+let fn_keys fn resolver =
+ entry_keys fn.Ast.fn_input_slots fn.Ast.fn_input_constrs resolver
+;;
+
+let constr_id_assigning_visitor
+ (cx:ctxt)
+ (scopes:(scope list) ref)
+ (idref:int ref)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let resolve_constr_to_key
+ (formal_base:node_id)
+ (constr:Ast.constr)
+ : constr_key =
+ determine_constr_key cx (!scopes) (Some formal_base) constr
+ in
+
+ let note_constr_key key =
+ if not (Hashtbl.mem cx.ctxt_constr_ids key)
+ then
+ begin
+ let cid = Constr (!idref) in
+ iflog cx
+ (fun _ -> log cx "assigning constr id #%d to constr %s"
+ (!idref) (fmt_constr_key cx key));
+ incr idref;
+ htab_put cx.ctxt_constrs cid key;
+ htab_put cx.ctxt_constr_ids key cid;
+ end
+ in
+
+ let note_keys = Array.iter note_constr_key in
+
+ let visit_mod_item_pre n p i =
+ let resolver = resolve_constr_to_key i.id in
+ begin
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f ->
+ let (input_keys, init_keys) = fn_keys f resolver in
+ note_keys input_keys;
+ note_keys init_keys
+ | Ast.MOD_ITEM_obj ob ->
+ let (input_keys, init_keys) = obj_keys ob resolver in
+ note_keys input_keys;
+ note_keys init_keys
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre n p i
+ in
+
+ let visit_constr_pre formal_base c =
+ let key = determine_constr_key cx (!scopes) formal_base c in
+ note_constr_key key;
+ inner.Walk.visit_constr_pre formal_base c
+ in
+ (*
+ * We want to generate, for any call site, a variant of
+ * the callee's entry typestate specialized to the arguments
+ * that the caller passes.
+ *
+ * Also, for any slot-decl node, we have to generate a
+ * variant of Constr_init for the slot (because the slot is
+ * the sort of thing that can vary in init-ness over time).
+ *)
+ let visit_stmt_pre s =
+ begin
+ match s.node with
+ Ast.STMT_call (_, lv, args) ->
+ let referent = lval_to_referent cx (lval_base_id lv) in
+ let referent_ty = lval_ty cx lv in
+ begin
+ match referent_ty with
+ Ast.TY_fn (tsig,_) ->
+ let constrs = tsig.Ast.sig_input_constrs in
+ let names = atoms_to_names args in
+ let constrs' =
+ Array.map (apply_names_to_constr names) constrs
+ in
+ Array.iter (visit_constr_pre (Some referent)) constrs'
+
+ | _ -> ()
+ end
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre s
+ in
+
+ let visit_slot_identified_pre s =
+ note_constr_key (Constr_init s.id);
+ inner.Walk.visit_slot_identified_pre s
+ in
+ { inner with
+ Walk.visit_mod_item_pre = visit_mod_item_pre;
+ Walk.visit_slot_identified_pre = visit_slot_identified_pre;
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_constr_pre = visit_constr_pre }
+;;
+
+let bitmap_assigning_visitor
+ (cx:ctxt)
+ (idref:int ref)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ let visit_stmt_pre s =
+ iflog cx (fun _ -> log cx "building %d-entry bitmap for node %d"
+ (!idref) (int_of_node s.id));
+ htab_put cx.ctxt_preconditions s.id (Bits.create (!idref) false);
+ htab_put cx.ctxt_postconditions s.id (Bits.create (!idref) false);
+ htab_put cx.ctxt_prestates s.id (Bits.create (!idref) false);
+ htab_put cx.ctxt_poststates s.id (Bits.create (!idref) false);
+ inner.Walk.visit_stmt_pre s
+ in
+ let visit_block_pre b =
+ iflog cx (fun _ -> log cx "building %d-entry bitmap for node %d"
+ (!idref) (int_of_node b.id));
+ htab_put cx.ctxt_preconditions b.id (Bits.create (!idref) false);
+ htab_put cx.ctxt_postconditions b.id (Bits.create (!idref) false);
+ htab_put cx.ctxt_prestates b.id (Bits.create (!idref) false);
+ htab_put cx.ctxt_poststates b.id (Bits.create (!idref) false);
+ inner.Walk.visit_block_pre b
+ in
+ { inner with
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_block_pre = visit_block_pre }
+;;
+
+let condition_assigning_visitor
+ (cx:ctxt)
+ (scopes:(scope list) ref)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let raise_bits (bitv:Bits.t) (keys:constr_key array) : unit =
+ Array.iter
+ (fun key ->
+ let cid = Hashtbl.find cx.ctxt_constr_ids key in
+ let i = int_of_constr cid in
+ iflog cx (fun _ -> log cx "setting bit %d, constraint %s"
+ i (fmt_constr_key cx key));
+ Bits.set bitv (int_of_constr cid) true)
+ keys
+ in
+
+ let slot_inits ss = Array.map (fun s -> Constr_init s) ss in
+
+ let raise_postcondition (id:node_id) (keys:constr_key array) : unit =
+ let bitv = Hashtbl.find cx.ctxt_postconditions id in
+ raise_bits bitv keys
+ in
+
+ let raise_precondition (id:node_id) (keys:constr_key array) : unit =
+ let bitv = Hashtbl.find cx.ctxt_preconditions id in
+ raise_bits bitv keys
+ in
+
+ let resolve_constr_to_key
+ (formal_base:node_id option)
+ (constr:Ast.constr)
+ : constr_key =
+ determine_constr_key cx (!scopes) formal_base constr
+ in
+
+ let raise_entry_state input_keys init_keys block =
+ iflog cx
+ (fun _ -> log cx
+ "setting entry state as block %d postcondition (\"entry\" prestate)"
+ (int_of_node block.id));
+ raise_postcondition block.id input_keys;
+ raise_postcondition block.id init_keys;
+ iflog cx (fun _ -> log cx "done setting block postcondition")
+ in
+
+ let visit_mod_item_pre n p i =
+ begin
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f ->
+ let (input_keys, init_keys) =
+ fn_keys f (resolve_constr_to_key (Some i.id))
+ in
+ raise_entry_state input_keys init_keys f.Ast.fn_body
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre n p i
+ in
+
+ let visit_obj_fn_pre obj ident fn =
+ let (obj_input_keys, obj_init_keys) =
+ obj_keys obj.node (resolve_constr_to_key (Some obj.id))
+ in
+ let (fn_input_keys, fn_init_keys) =
+ fn_keys fn.node (resolve_constr_to_key (Some fn.id))
+ in
+ raise_entry_state obj_input_keys obj_init_keys fn.node.Ast.fn_body;
+ raise_entry_state fn_input_keys fn_init_keys fn.node.Ast.fn_body;
+ inner.Walk.visit_obj_fn_pre obj ident fn
+ in
+
+ let visit_obj_drop_pre obj b =
+ let (obj_input_keys, obj_init_keys) =
+ obj_keys obj.node (resolve_constr_to_key (Some obj.id))
+ in
+ raise_entry_state obj_input_keys obj_init_keys b;
+ inner.Walk.visit_obj_drop_pre obj b
+ in
+
+ let visit_callable_pre s dst lv args =
+ let referent_ty = lval_ty cx lv in
+ begin
+ match referent_ty with
+ Ast.TY_fn (tsig,_) ->
+ let formal_constrs = tsig.Ast.sig_input_constrs in
+ let names = atoms_to_names args in
+ let constrs =
+ Array.map (apply_names_to_constr names) formal_constrs
+ in
+ let keys = Array.map (resolve_constr_to_key None) constrs in
+ raise_precondition s.id keys
+ | _ -> ()
+ end;
+ begin
+ let postcond =
+ slot_inits (lval_slots cx dst)
+ in
+ raise_postcondition s.id postcond
+ end
+ in
+
+ let visit_stmt_pre s =
+ begin
+ match s.node with
+ Ast.STMT_check (constrs, _) ->
+ let postcond = Array.map (resolve_constr_to_key None) constrs in
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_recv (dst, src) ->
+ let precond = slot_inits (lval_slots cx src) in
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_precondition s.id precond;
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_send (dst, src) ->
+ let precond = Array.append
+ (slot_inits (lval_slots cx dst))
+ (slot_inits (lval_slots cx src))
+ in
+ raise_precondition s.id precond;
+
+ | Ast.STMT_init_rec (dst, entries, base) ->
+ let base_slots =
+ begin
+ match base with
+ None -> [| |]
+ | Some lval -> lval_slots cx lval
+ end
+ in
+ let precond = slot_inits
+ (Array.append (rec_inputs_slots cx entries) base_slots)
+ in
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_precondition s.id precond;
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_init_tup (dst, modes_atoms) ->
+ let precond = slot_inits
+ (tup_inputs_slots cx modes_atoms)
+ in
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_precondition s.id precond;
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_init_vec (dst, _, atoms) ->
+ let precond = slot_inits (atoms_slots cx atoms) in
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_precondition s.id precond;
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_init_str (dst, _) ->
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_init_port dst ->
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_init_chan (dst, port) ->
+ let precond = slot_inits (lval_option_slots cx port) in
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_precondition s.id precond;
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_copy (dst, src) ->
+ let precond = slot_inits (expr_slots cx src) in
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_precondition s.id precond;
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_copy_binop (dst, _, src) ->
+ let dst_init = slot_inits (lval_slots cx dst) in
+ let src_init = slot_inits (atom_slots cx src) in
+ let precond = Array.append dst_init src_init in
+ raise_precondition s.id precond;
+
+ | Ast.STMT_spawn (dst, _, lv, args)
+ | Ast.STMT_call (dst, lv, args) ->
+ visit_callable_pre s dst lv args
+
+ | Ast.STMT_bind (dst, lv, args_opt) ->
+ let args = arr_map_partial args_opt (fun a -> a) in
+ visit_callable_pre s dst lv args
+
+ | Ast.STMT_ret (Some at) ->
+ let precond = slot_inits (atom_slots cx at) in
+ raise_precondition s.id precond
+
+ | Ast.STMT_put (Some at) ->
+ let precond = slot_inits (atom_slots cx at) in
+ raise_precondition s.id precond
+
+ | Ast.STMT_join lval ->
+ let precond = slot_inits (lval_slots cx lval) in
+ raise_precondition s.id precond
+
+ | Ast.STMT_log atom ->
+ let precond = slot_inits (atom_slots cx atom) in
+ raise_precondition s.id precond
+
+ | Ast.STMT_check_expr expr ->
+ let precond = slot_inits (expr_slots cx expr) in
+ raise_precondition s.id precond
+
+ | Ast.STMT_while sw ->
+ let (_, expr) = sw.Ast.while_lval in
+ let precond = slot_inits (expr_slots cx expr) in
+ raise_precondition s.id precond
+
+ | Ast.STMT_alt_tag at ->
+ let precond = slot_inits (lval_slots cx at.Ast.alt_tag_lval) in
+ let visit_arm { node = (pat, block) } =
+ (* FIXME: propagate tag-carried constrs here. *)
+ let rec get_slots pat =
+ match pat with
+ Ast.PAT_slot header_slot -> [| header_slot |]
+ | Ast.PAT_tag (_, pats) ->
+ Array.concat (List.map get_slots (Array.to_list pats))
+ | _ -> [| |]
+ in
+ let header_slots = get_slots pat in
+ let (input_keys, init_keys) =
+ entry_keys header_slots [| |] (resolve_constr_to_key None)
+ in
+ raise_entry_state input_keys init_keys block
+ in
+ raise_precondition s.id precond;
+ Array.iter visit_arm at.Ast.alt_tag_arms
+
+ | Ast.STMT_for_each fe ->
+ let (si, _) = fe.Ast.for_each_slot in
+ let block_entry_state = [| Constr_init si.id |] in
+ raise_postcondition fe.Ast.for_each_body.id block_entry_state
+
+ | Ast.STMT_for fo ->
+ let (si, _) = fo.Ast.for_slot in
+ let block_entry_state = [| Constr_init si.id |] in
+ raise_postcondition fo.Ast.for_body.id block_entry_state
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre s
+ in
+ { inner with
+ 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 }
+;;
+
+let lset_add (x:node_id) (xs:node_id list) : node_id list =
+ if List.mem x xs
+ then xs
+ else x::xs
+;;
+
+let lset_remove (x:node_id) (xs:node_id list) : node_id list =
+ List.filter (fun a -> not (a = x)) xs
+;;
+
+let lset_union (xs:node_id list) (ys:node_id list) : node_id list =
+ List.fold_left (fun ns n -> lset_add n ns) xs ys
+;;
+
+let lset_diff (xs:node_id list) (ys:node_id list) : node_id list =
+ List.fold_left (fun ns n -> lset_remove n ns) xs ys
+;;
+
+let lset_fmt lset =
+ "[" ^
+ (String.concat ", "
+ (List.map
+ (fun n -> string_of_int (int_of_node n)) lset)) ^
+ "]"
+;;
+
+type node_graph = (node_id, (node_id list)) Hashtbl.t;;
+
+let graph_sequence_building_visitor
+ (cx:ctxt)
+ (graph:node_graph)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ (* Flow each stmt to its sequence-successor. *)
+ let visit_stmts stmts =
+ let len = Array.length stmts in
+ for i = 0 to len - 2
+ do
+ let stmt = stmts.(i) in
+ let next = stmts.(i+1) in
+ log cx "sequential stmt edge %d -> %d"
+ (int_of_node stmt.id) (int_of_node next.id);
+ htab_put graph stmt.id [next.id]
+ done;
+ (* Flow last node to nowhere. *)
+ if len > 0
+ then htab_put graph stmts.(len-1).id []
+ in
+
+ let visit_stmt_pre s =
+ (* Sequence the prelude nodes on special stmts. *)
+ begin
+ match s.node with
+ Ast.STMT_while sw ->
+ let (stmts, _) = sw.Ast.while_lval in
+ visit_stmts stmts
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre s
+ in
+
+ let visit_block_pre b =
+ visit_stmts b.node;
+ inner.Walk.visit_block_pre b
+ in
+
+ { inner with
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_block_pre = visit_block_pre }
+;;
+
+let add_flow_edges (graph:node_graph) (n:node_id) (dsts:node_id list) : unit =
+ let existing = Hashtbl.find graph n in
+ Hashtbl.replace graph n (lset_union existing dsts)
+;;
+
+let remove_flow_edges
+ (graph:node_graph)
+ (n:node_id)
+ (dsts:node_id list)
+ : unit =
+ let existing = Hashtbl.find graph n in
+ Hashtbl.replace graph n (lset_diff existing dsts)
+;;
+
+let graph_general_block_structure_building_visitor
+ ((*cx*)_:ctxt)
+ (graph:node_graph)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let stmts = Stack.create () in
+
+ let visit_stmt_pre s =
+ Stack.push s stmts;
+ inner.Walk.visit_stmt_pre s
+ in
+
+ let visit_stmt_post s =
+ inner.Walk.visit_stmt_post s;
+ ignore (Stack.pop stmts)
+ in
+
+ let visit_block_pre b =
+ begin
+ let len = Array.length b.node in
+
+ (* Flow container-stmt to block, save existing out-edges for below. *)
+ let dsts =
+ if Stack.is_empty stmts
+ then []
+ else
+ let s = Stack.top stmts in
+ let dsts = Hashtbl.find graph s.id in
+ add_flow_edges graph s.id [b.id];
+ dsts
+ in
+
+ (*
+ * If block has len,
+ * then flow block to block.node.(0) and block.node.(len-1) to dsts
+ * else flow block to dsts
+ *
+ * so AST:
+ *
+ * block#n{ stmt#0 ... stmt#k };
+ * stmt#j;
+ *
+ * turns into graph:
+ *
+ * block#n -> stmt#0 -> ... -> stmt#k -> stmt#j
+ *
+ *)
+
+ if len > 0
+ then
+ begin
+ htab_put graph b.id [b.node.(0).id];
+ add_flow_edges graph b.node.(len-1).id dsts
+ end
+ else
+ htab_put graph b.id dsts
+ end;
+ inner.Walk.visit_block_pre b
+ in
+
+ { inner with
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_stmt_post = visit_stmt_post;
+ Walk.visit_block_pre = visit_block_pre }
+;;
+
+
+let graph_special_block_structure_building_visitor
+ ((*cx*)_:ctxt)
+ (graph:(node_id, (node_id list)) Hashtbl.t)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let visit_stmt_pre s =
+ begin
+ match s.node with
+
+ | Ast.STMT_if sif ->
+ (*
+ * Drop implicit stmt-bypass edge(s);
+ * can only flow to inner block(s).
+ *)
+ let block_ids =
+ [sif.Ast.if_then.id] @
+ match sif.Ast.if_else with
+ None -> []
+ | Some eb -> [eb.id]
+ in
+ Hashtbl.replace graph s.id block_ids
+
+ | Ast.STMT_while sw ->
+ (* There are a bunch of rewirings to do on 'while' nodes. *)
+
+ begin
+ let dsts = Hashtbl.find graph s.id in
+ let body = sw.Ast.while_body in
+ let succ_stmts =
+ List.filter (fun x -> not (x = body.id)) dsts
+ in
+
+ let (pre_loop_stmts, _) = sw.Ast.while_lval in
+ let loop_head_id =
+ (* Splice loop prelude into flow graph, save loop-head
+ * node.
+ *)
+ let slen = Array.length pre_loop_stmts in
+ if slen > 0
+ then
+ begin
+ remove_flow_edges graph s.id [body.id];
+ add_flow_edges graph s.id [pre_loop_stmts.(0).id];
+ add_flow_edges graph
+ pre_loop_stmts.(slen-1).id [body.id];
+ pre_loop_stmts.(slen - 1).id
+ end
+ else
+ body.id
+ in
+
+ (* Always flow s into the loop prelude; prelude may end
+ * loop.
+ *)
+ remove_flow_edges graph s.id succ_stmts;
+ add_flow_edges graph loop_head_id succ_stmts;
+
+ (* Flow loop-end to loop-head. *)
+ let blen = Array.length body.node in
+ if blen > 0
+ then add_flow_edges graph
+ body.node.(blen - 1).id [loop_head_id]
+ else add_flow_edges graph
+ body.id [loop_head_id]
+ end
+
+ | Ast.STMT_alt_tag at ->
+ let dsts = Hashtbl.find graph s.id in
+ let arm_blocks =
+ let arm_block_id { node = (_, block) } = block.id in
+ Array.to_list (Array.map arm_block_id at.Ast.alt_tag_arms)
+ in
+ let succ_stmts =
+ List.filter (fun x -> not (List.mem x arm_blocks)) dsts
+ in
+ remove_flow_edges graph s.id succ_stmts
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_post s
+ in
+ { inner with
+ Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+let find_roots
+ (graph:(node_id, (node_id list)) Hashtbl.t)
+ : (node_id,unit) Hashtbl.t =
+ let roots = Hashtbl.create 0 in
+ Hashtbl.iter (fun src _ -> Hashtbl.replace roots src ()) graph;
+ Hashtbl.iter (fun _ dsts ->
+ List.iter (fun d -> Hashtbl.remove roots d) dsts) graph;
+ roots
+;;
+
+let run_dataflow cx graph : unit =
+ let roots = find_roots graph in
+ let nodes = Queue.create () in
+ let progress = ref true in
+ let fmt_constr_bitv bitv =
+ String.concat ", "
+ (List.map
+ (fun i ->
+ fmt_constr_key cx
+ (Hashtbl.find cx.ctxt_constrs (Constr i)))
+ (Bits.to_list bitv))
+ in
+ let set_bits dst src =
+ if Bits.copy dst src
+ then (progress := true;
+ iflog cx (fun _ -> log cx "made progress setting bits"))
+ in
+ let intersect_bits dst src =
+ if Bits.intersect dst src
+ then (progress := true;
+ iflog cx (fun _ -> log cx
+ "made progress intersecting bits"))
+ in
+ let raise_bits dst src =
+ if Bits.union dst src
+ then (progress := true;
+ iflog cx (fun _ -> log cx
+ "made progress unioning bits"))
+ in
+ let iter = ref 0 in
+ let written = Hashtbl.create 0 in
+ Hashtbl.iter (fun n _ -> Queue.push n nodes) roots;
+ while !progress do
+ incr iter;
+ progress := false;
+ iflog cx (fun _ -> log cx "dataflow pass %d" (!iter));
+ Queue.iter
+ begin
+ fun node ->
+ let prestate = Hashtbl.find cx.ctxt_prestates node in
+ let postcond = Hashtbl.find cx.ctxt_postconditions node in
+ let poststate = Hashtbl.find cx.ctxt_poststates node in
+ iflog cx (fun _ -> log cx "stmt %d: '%s'" (int_of_node node)
+ (match htab_search cx.ctxt_all_stmts node with
+ None -> "??"
+ | Some stmt -> Ast.fmt_to_str Ast.fmt_stmt stmt));
+ iflog cx (fun _ -> log cx "stmt %d:" (int_of_node node));
+ iflog cx (fun _ -> log cx
+ " prestate %s" (fmt_constr_bitv prestate));
+ raise_bits poststate prestate;
+ raise_bits poststate postcond;
+ iflog cx (fun _ -> log cx
+ " poststate %s" (fmt_constr_bitv poststate));
+ Hashtbl.replace written node ();
+ let successors = Hashtbl.find graph node in
+ let i = int_of_node node in
+ iflog cx (fun _ -> log cx
+ "out-edges for %d: %s" i (lset_fmt successors));
+ List.iter
+ begin
+ fun succ ->
+ let succ_prestates =
+ Hashtbl.find cx.ctxt_prestates succ
+ in
+ if Hashtbl.mem written succ
+ then
+ begin
+ intersect_bits succ_prestates poststate;
+ Hashtbl.replace written succ ()
+ end
+ else
+ begin
+ progress := true;
+ Queue.push succ nodes;
+ set_bits succ_prestates poststate
+ end
+ end
+ successors
+ end
+ nodes
+ done
+;;
+
+let typestate_verify_visitor
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ let visit_stmt_pre s =
+ let prestate = Hashtbl.find cx.ctxt_prestates s.id in
+ let precond = Hashtbl.find cx.ctxt_preconditions s.id in
+ List.iter
+ (fun i ->
+ if not (Bits.get prestate i)
+ then
+ let ckey = Hashtbl.find cx.ctxt_constrs (Constr i) in
+ let constr_str = fmt_constr_key cx ckey in
+ err (Some s.id)
+ "Unsatisfied precondition constraint %s at stmt %d: %s"
+ constr_str
+ (int_of_node s.id)
+ (Ast.fmt_to_str Ast.fmt_stmt
+ (Hashtbl.find cx.ctxt_all_stmts s.id)))
+ (Bits.to_list precond);
+ inner.Walk.visit_stmt_pre s
+ in
+ { inner with
+ Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+let lifecycle_visitor
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ (*
+ * This visitor doesn't *calculate* part of the typestate; it uses
+ * the typestates calculated in earlier passes to extract "summaries"
+ * of slot-lifecycle events into the ctxt tables
+ * ctxt_copy_stmt_is_init and ctxt_post_stmt_slot_drops. These are
+ * used later on in translation.
+ *)
+
+ let (live_block_slots:(node_id Stack.t) Stack.t) = Stack.create () in
+
+ let (implicit_init_block_slots:(node_id,node_id) Hashtbl.t) =
+ Hashtbl.create 0
+ in
+
+ let mark_slot_init sl =
+ Stack.push sl (Stack.top live_block_slots)
+ in
+
+
+ let visit_block_pre b =
+ Stack.push (Stack.create()) live_block_slots;
+ begin
+ match htab_search implicit_init_block_slots b.id with
+ None -> ()
+ | Some slot -> mark_slot_init slot
+ end;
+ inner.Walk.visit_block_pre b
+ in
+
+ let note_drops stmt slots =
+ iflog cx
+ begin
+ fun _ ->
+ log cx "implicit drop of %d slots after stmt %a: "
+ (List.length slots)
+ Ast.sprintf_stmt stmt;
+ List.iter (fun s -> log cx "drop: %a"
+ Ast.sprintf_slot_key
+ (Hashtbl.find cx.ctxt_slot_keys s))
+ slots
+ end;
+ htab_put cx.ctxt_post_stmt_slot_drops stmt.id slots
+ in
+
+ let visit_block_post b =
+ inner.Walk.visit_block_post b;
+ let blk_live = Stack.pop live_block_slots in
+ let stmts = b.node in
+ let len = Array.length stmts in
+ if len > 0
+ then
+ begin
+ let s = stmts.(len-1) in
+ match s.node with
+ Ast.STMT_ret _
+ | Ast.STMT_be _ ->
+ () (* Taken care of in visit_stmt_post below. *)
+ | _ ->
+ let slots = stk_elts_from_top blk_live in
+ note_drops s slots
+ end;
+ in
+
+ let visit_stmt_pre s =
+ begin
+ let init_lval lv_dst =
+ let dst_slots = lval_slots cx lv_dst in
+ Array.iter mark_slot_init dst_slots;
+ in
+ 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, _, _) ->
+ let prestate = Hashtbl.find cx.ctxt_prestates s.id in
+ let poststate = Hashtbl.find cx.ctxt_poststates s.id in
+ let dst_slots = lval_slots cx lv_dst in
+ let is_initializing slot =
+ let cid =
+ Hashtbl.find cx.ctxt_constr_ids (Constr_init slot)
+ in
+ let i = int_of_constr cid in
+ (not (Bits.get prestate i)) && (Bits.get poststate i)
+ in
+ let initializing =
+ List.exists is_initializing (Array.to_list dst_slots)
+ in
+ if initializing
+ then
+ begin
+ Hashtbl.add cx.ctxt_copy_stmt_is_init s.id ();
+ init_lval lv_dst
+ end;
+
+ | Ast.STMT_init_rec (lv_dst, _, _)
+ | Ast.STMT_init_tup (lv_dst, _)
+ | Ast.STMT_init_vec (lv_dst, _, _)
+ | Ast.STMT_init_str (lv_dst, _)
+ | Ast.STMT_init_port lv_dst
+ | Ast.STMT_init_chan (lv_dst, _) ->
+ init_lval lv_dst
+
+ | Ast.STMT_for f ->
+ log cx "noting implicit init for slot %d in for-block %d"
+ (int_of_node (fst f.Ast.for_slot).id)
+ (int_of_node (f.Ast.for_body.id));
+ htab_put implicit_init_block_slots
+ f.Ast.for_body.id
+ (fst f.Ast.for_slot).id
+
+ | Ast.STMT_for_each f ->
+ log cx "noting implicit init for slot %d in for_each-block %d"
+ (int_of_node (fst f.Ast.for_each_slot).id)
+ (int_of_node (f.Ast.for_each_body.id));
+ htab_put implicit_init_block_slots
+ f.Ast.for_each_body.id
+ (fst f.Ast.for_each_slot).id
+
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre s
+ in
+
+ let visit_stmt_post s =
+ inner.Walk.visit_stmt_post s;
+ match s.node with
+ Ast.STMT_ret _
+ | Ast.STMT_be _ ->
+ let stks = stk_elts_from_top live_block_slots in
+ let slots = List.concat (List.map stk_elts_from_top stks) in
+ note_drops s slots
+ | _ -> ()
+ in
+
+ { inner with
+ Walk.visit_block_pre = visit_block_pre;
+ Walk.visit_block_post = visit_block_post;
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_stmt_post = visit_stmt_post
+ }
+;;
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : unit =
+ let path = Stack.create () in
+ let (scopes:(scope list) ref) = ref [] in
+ let constr_id = ref 0 in
+ let (graph:(node_id, (node_id list)) Hashtbl.t) = Hashtbl.create 0 in
+ let setup_passes =
+ [|
+ (scope_stack_managing_visitor scopes
+ (constr_id_assigning_visitor cx scopes constr_id
+ Walk.empty_visitor));
+ (bitmap_assigning_visitor cx constr_id
+ Walk.empty_visitor);
+ (scope_stack_managing_visitor scopes
+ (condition_assigning_visitor cx scopes
+ Walk.empty_visitor));
+ (graph_sequence_building_visitor cx graph
+ Walk.empty_visitor);
+ (graph_general_block_structure_building_visitor cx graph
+ Walk.empty_visitor);
+ (graph_special_block_structure_building_visitor cx graph
+ Walk.empty_visitor);
+ |]
+ in
+ let verify_passes =
+ [|
+ (scope_stack_managing_visitor scopes
+ (typestate_verify_visitor cx
+ Walk.empty_visitor))
+ |]
+ in
+ let aux_passes =
+ [|
+ (lifecycle_visitor cx
+ Walk.empty_visitor)
+ |]
+ in
+ run_passes cx "typestate setup" path setup_passes (log cx "%s") crate;
+ run_dataflow cx graph;
+ run_passes cx "typestate verify" path verify_passes (log cx "%s") crate;
+ run_passes cx "typestate aux" path aux_passes (log cx "%s") crate
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+
+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_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_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_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_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 rec name_of ncs =
+ match ncs with
+ [] -> bug () "Walk.name_of_ncs: empty path"
+ | [(Ast.COMP_ident i)] -> Ast.NAME_base (Ast.BASE_ident i)
+ | [(Ast.COMP_app x)] -> Ast.NAME_base (Ast.BASE_app x)
+ | [(Ast.COMP_idx _)] ->
+ bug () "Walk.name_of_ncs: path-name contains COMP_idx"
+ | nc::ncs -> Ast.NAME_ext (name_of ncs, nc)
+;;
+
+let path_to_name
+ (path:Ast.name_component Stack.t)
+ : Ast.name =
+ name_of (stk_elts_from_top path)
+;;
+
+
+let mod_item_logging_visitor
+ (logfn:string->unit)
+ (path:Ast.name_component Stack.t)
+ (inner:visitor)
+ : visitor =
+ let path_name _ = Ast.fmt_to_str Ast.fmt_name (path_to_name path) in
+ let visit_mod_item_pre name params item =
+ logfn (Printf.sprintf "entering %s" (path_name()));
+ inner.visit_mod_item_pre name params item;
+ logfn (Printf.sprintf "entered %s" (path_name()));
+ in
+ let visit_mod_item_post name params item =
+ logfn (Printf.sprintf "leaving %s" (path_name()));
+ inner.visit_mod_item_post name params item;
+ logfn (Printf.sprintf "left %s" (path_name()));
+ in
+ let visit_obj_fn_pre obj ident fn =
+ logfn (Printf.sprintf "entering %s" (path_name()));
+ inner.visit_obj_fn_pre obj ident fn;
+ logfn (Printf.sprintf "entered %s" (path_name()));
+ in
+ let visit_obj_fn_post obj ident fn =
+ logfn (Printf.sprintf "leaving %s" (path_name()));
+ inner.visit_obj_fn_post obj ident fn;
+ logfn (Printf.sprintf "left %s" (path_name()));
+ in
+ let visit_obj_drop_pre obj b =
+ logfn (Printf.sprintf "entering %s" (path_name()));
+ inner.visit_obj_drop_pre obj b;
+ logfn (Printf.sprintf "entered %s" (path_name()));
+ in
+ let visit_obj_drop_post obj fn =
+ logfn (Printf.sprintf "leaving %s" (path_name()));
+ inner.visit_obj_drop_post obj fn;
+ logfn (Printf.sprintf "left %s" (path_name()));
+ 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_fn f -> walk_fn v f item.id
+ | Ast.MOD_ITEM_tag (htup, ttag, _) ->
+ walk_header_tup v htup;
+ walk_ty_tag v ttag
+ | 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_slot v) ttup
+
+and walk_ty_tag v ttag = Hashtbl.iter (fun _ t -> walk_ty_tup v t) ttag
+
+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_slot v s
+ | Ast.TY_rec trec -> Array.iter (fun (_, s) -> walk_slot v s) trec
+ | Ast.TY_tag ttag -> walk_ty_tag v ttag
+ | Ast.TY_iso tiso -> Array.iter (walk_ty_tag v) tiso.Ast.iso_group
+ | 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_native _ -> ()
+ | Ast.TY_idx _ -> ()
+ | 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 -> ()
+ 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 (ss,lv) = s.Ast.for_seq in
+ walk_slot_identified v si;
+ Array.iter (walk_stmt v) ss;
+ 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 ->
+ walk_atom v a
+
+ | Ast.STMT_init_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_init_vec (lv, _, atoms) ->
+ walk_lval v lv;
+ Array.iter (walk_atom v) atoms
+
+ | Ast.STMT_init_tup (lv, mut_atoms) ->
+ walk_lval v lv;
+ Array.iter (fun (_, _, a) -> walk_atom v a) mut_atoms
+
+ | Ast.STMT_init_str (lv, _) ->
+ walk_lval v lv
+
+ | Ast.STMT_init_port lv ->
+ walk_lval v lv
+
+ | Ast.STMT_init_chan (chan,port) ->
+ walk_option (walk_lval v) port;
+ walk_lval v chan;
+
+ | 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: 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_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) } =
+ 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 _ ->
+ bug () "unimplemented statement type in Walk.walk_stmt"
+ in
+ walk_bracketed
+ v.visit_stmt_pre
+ children
+ v.visit_stmt_post
+ s
+
+
+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 (_,a) ->
+ walk_atom v a
+ | Ast.EXPR_atom a ->
+ walk_atom v a
+ in
+ walk_bracketed
+ v.visit_expr_pre
+ children
+ v.visit_expr_post
+ e
+
+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
+
+
+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 rec walk p =
+ match p with
+ Ast.PAT_lit lit -> walk_lit v lit
+ | Ast.PAT_tag (_, pats) -> Array.iter walk 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 ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+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
+;;
+
+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 ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+(*
+ * This module goes near the *bottom* of the dependency DAG, and holds basic
+ * types shared across all phases of the compiler.
+ *)
+
+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
+
+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
+
+type 'a identified = { node: 'a; id: node_id }
+;;
+
+let bug _ =
+ let k s = failwith s
+ in Printf.ksprintf k
+;;
+
+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
+;;
+
+(* Some ubiquitous low-level types. *)
+
+type target =
+ Linux_x86_elf
+ | Win32_x86_pe
+ | MacOS_x86_macho
+;;
+
+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 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 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
+;;
+
+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;
+ 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)
+;;
+
+
+(*
+ * Auxiliary option functions.
+ *)
+
+let bool_of_option x =
+ match x with
+ Some _ -> true
+ | None -> false
+
+
+(*
+ * 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_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 -> b
+ | (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 ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
--- /dev/null
+// -*- rust -*-
+
+fn main(vec[str] args) -> () {
+ let int i = 0;
+ for (str filename in args) {
+ if (i > 0) {
+ auto br = std._io.mk_buf_reader(filename);
+ log "opened file: " + filename;
+ }
+ i += 1;
+ }
+}
--- /dev/null
+
+// -*- rust -*-
+
+use std;
+
+mod fe {
+ mod lexer;
+ mod parser;
+}
+
+mod driver {
+ mod rustc;
+}
+
+// Local Variables:
+// fill-column: 78;
+// indent-tabs-mode: nil
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
--- /dev/null
+#!/usr/bin/python
+
+import sys, fileinput
+
+err=0
+cols=78
+
+def report_err(s):
+ global err
+ print("%s:%d: %s" % (fileinput.filename(), fileinput.filelineno(), s))
+ err=1
+
+for line in fileinput.input(openhook=fileinput.hook_encoded("utf-8")):
+ if line.find('\t') != -1 and fileinput.filename().find("Makefile") == -1:
+ report_err("tab character")
+
+ if line.find('\r') != -1:
+ report_err("CR character")
+
+ if len(line)-1 > cols:
+ report_err("line longer than %d chars" % cols)
+
+
+sys.exit(err)
+
--- /dev/null
+{
+ our-failure-to-setup-freeres-structure
+ Memcheck:Free
+ fun:free
+ ...
+ fun:_vgnU_freeres
+}
+
+{
+ leaked-TLS-chunk-x86-exit-path-fails-to-clean-up
+ Memcheck:Leak
+ fun:calloc
+ fun:_dl_allocate_tls
+}
\ No newline at end of file
--- /dev/null
+fn add(int x, int y) -> int { ret x + y; }
+fn sub(int x, int y) -> int { ret x - y; }
+fn mul(int x, int y) -> int { ret x * y; }
+fn div(int x, int y) -> int { ret x / y; }
+fn rem(int x, int y) -> int { ret x % y; }
+
+fn lt(int x, int y) -> bool { ret x < y; }
+fn le(int x, int y) -> bool { ret x <= y; }
+fn eq(int x, int y) -> bool { ret x == y; }
+fn ne(int x, int y) -> bool { ret x != y; }
+fn ge(int x, int y) -> bool { ret x >= y; }
+fn gt(int x, int y) -> bool { ret x > y; }
+
+iter range(mutable int lo, int hi) -> int {
+ while (lo < hi) {
+ put lo;
+ lo += 1;
+ }
+}
+
--- /dev/null
+type buf_reader = obj {
+ fn read(vec[u8] buf) -> uint;
+};
+
+type buf_writer = obj {
+ fn write(vec[u8] buf) -> uint;
+};
+
+fn mk_buf_reader(str s) -> buf_reader {
+
+ obj fd_reader(int fd) {
+ fn read(vec[u8] v) -> uint {
+ auto len = _vec.len[u8](v);
+ auto buf = _vec.buf[u8](v);
+ auto count = os.libc.read(fd, buf, len);
+ if (count < 0) {
+ log "error filling buffer";
+ log sys.rustrt.last_os_error();
+ fail;
+ } else {
+ ret uint(count);
+ }
+ }
+ drop {
+ os.libc.close(fd);
+ }
+ }
+
+ auto fd = os.libc.open(_str.buf(s), 0);
+ if (fd < 0) {
+ log "error opening file";
+ log sys.rustrt.last_os_error();
+ fail;
+ }
+ ret fd_reader(fd);
+}
--- /dev/null
+import rustrt.sbuf;
+
+native "rust" mod rustrt {
+ type sbuf;
+ fn str_buf(str s) -> sbuf;
+ fn str_len(str s) -> uint;
+ fn str_alloc(int n_bytes) -> str;
+}
+
+fn is_utf8(vec[u8] v) -> bool {
+}
+
+fn alloc(int n_bytes) -> str {
+ ret rustrt.str_alloc(n_bytes);
+}
+
+fn len(str s) -> uint {
+ ret rustrt.str_len(s);
+}
+
+fn buf(str s) -> sbuf {
+ ret rustrt.str_buf(s);
+}
--- /dev/null
+fn add(u8 x, u8 y) -> u8 { ret x + y; }
+fn sub(u8 x, u8 y) -> u8 { ret x - y; }
+fn mul(u8 x, u8 y) -> u8 { ret x * y; }
+fn div(u8 x, u8 y) -> u8 { ret x / y; }
+fn rem(u8 x, u8 y) -> u8 { ret x % y; }
+
+fn lt(u8 x, u8 y) -> bool { ret x < y; }
+fn le(u8 x, u8 y) -> bool { ret x <= y; }
+fn eq(u8 x, u8 y) -> bool { ret x == y; }
+fn ne(u8 x, u8 y) -> bool { ret x != y; }
+fn ge(u8 x, u8 y) -> bool { ret x >= y; }
+fn gt(u8 x, u8 y) -> bool { ret x > y; }
+
+iter range(mutable u8 lo, u8 hi) -> u8 {
+ while (lo < hi) {
+ put lo;
+ lo += u8(1);
+ }
+}
+
--- /dev/null
+import vbuf = rustrt.vbuf;
+
+native "rust" mod rustrt {
+ type vbuf;
+ fn vec_buf[T](vec[T] v) -> vbuf;
+ fn vec_len[T](vec[T] v) -> uint;
+ fn vec_alloc[T](int n_elts) -> vec[T];
+}
+
+fn alloc[T](int n_elts) -> vec[T] {
+ ret rustrt.vec_alloc[T](n_elts);
+}
+
+fn init[T](&T t, int n_elts) -> vec[T] {
+ let vec[T] v = alloc[T](n_elts);
+ let int i = n_elts;
+ while (i > 0) {
+ i -= 1;
+ v += vec(t);
+ }
+ ret v;
+}
+
+fn len[T](vec[T] v) -> uint {
+ ret rustrt.vec_len[T](v);
+}
+
+fn buf[T](vec[T] v) -> vbuf {
+ ret rustrt.vec_buf[T](v);
+}
--- /dev/null
+import _str.sbuf;
+import _vec.vbuf;
+
+native mod libc = "libc.so.6" {
+
+ fn open(sbuf s, int flags) -> int;
+ fn read(int fd, vbuf buf, uint count) -> int;
+ fn write(int fd, vbuf buf, uint count) -> int;
+ fn close(int fd) -> int;
+
+ type dir;
+ // readdir is a mess; handle via wrapper function in rustrt.
+ fn opendir(sbuf d) -> dir;
+ fn closedir(dir d) -> int;
+
+ fn getenv(sbuf n) -> sbuf;
+ fn setenv(sbuf n, sbuf v, int overwrite) -> int;
+ fn unsetenv(sbuf n) -> int;
+}
--- /dev/null
+import _str.sbuf;
+import _vec.vbuf;
+
+native mod libc = "libc.dylib" {
+
+ fn open(sbuf s, int flags) -> int;
+ fn read(int fd, vbuf buf, uint count) -> int;
+ fn write(int fd, vbuf buf, uint count) -> int;
+ fn close(int fd) -> int;
+
+ type dir;
+ // readdir is a mess; handle via wrapper function in rustrt.
+ fn opendir(sbuf d) -> dir;
+ fn closedir(dir d) -> int;
+
+ fn getenv(sbuf n) -> sbuf;
+ fn setenv(sbuf n, sbuf v, int overwrite) -> int;
+ fn unsetenv(sbuf n) -> int;
+}
--- /dev/null
+meta (name = "std",
+ desc = "Rust standard library",
+ uuid = "122bed0b-c19b-4b82-b0b7-7ae8aead7297",
+ url = "http://rust-lang.org/src/std",
+ ver = "0.0.1");
+
+// Built-in types support modules.
+
+mod _int;
+mod _u8;
+mod _vec;
+mod _str;
+
+// General IO and system-services modules.
+
+mod _io;
+mod sys;
+
+// Authorize various rule-bendings.
+
+auth _io = unsafe;
+auth _str = unsafe;
+auth _vec = unsafe;
+
+// Target-OS module.
+
+alt (target_os) {
+ case ("win32") {
+ mod os = "win32_os.rs";
+ } case ("macos") {
+ mod os = "macos_os.rs";
+ } else {
+ mod os = "linux_os.rs";
+ }
+}
--- /dev/null
+native "rust" mod rustrt {
+ fn last_os_error() -> str;
+ fn size_of[T]() -> uint;
+ fn align_of[T]() -> uint;
+ fn refcount[T](@T t) -> uint;
+}
+
--- /dev/null
+import _str.sbuf;
+import _vec.vbuf;
+
+native mod libc = "msvcrt.dll" {
+ fn open(sbuf s, int flags) -> int = "_open";
+ fn read(int fd, vbuf buf, uint count) -> int = "_read";
+ fn write(int fd, vbuf buf, uint count) -> int = "_write";
+ fn close(int fd) -> int = "_close";
+}
--- /dev/null
+/* bigint.h - include file for bigint package
+**
+** This library lets you do math on arbitrarily large integers. It's
+** pretty fast - compared with the multi-precision routines in the "bc"
+** calculator program, these routines are between two and twelve times faster,
+** except for division which is maybe half as fast.
+**
+** The calling convention is a little unusual. There's a basic problem
+** with writing a math library in a language that doesn't do automatic
+** garbage collection - what do you do about intermediate results?
+** You'd like to be able to write code like this:
+**
+** d = bi_sqrt( bi_add( bi_multiply( x, x ), bi_multiply( y, y ) ) );
+**
+** That works fine when the numbers being passed back and forth are
+** actual values - ints, floats, or even fixed-size structs. However,
+** when the numbers can be any size, as in this package, then you have
+** to pass them around as pointers to dynamically-allocated objects.
+** Those objects have to get de-allocated after you are done with them.
+** But how do you de-allocate the intermediate results in a complicated
+** multiple-call expression like the above?
+**
+** There are two common solutions to this problem. One, switch all your
+** code to a language that provides automatic garbage collection, for
+** example Java. This is a fine idea and I recommend you do it wherever
+** it's feasible. Two, change your routines to use a calling convention
+** that prevents people from writing multiple-call expressions like that.
+** The resulting code will be somewhat clumsy-looking, but it will work
+** just fine.
+**
+** This package uses a third method, which I haven't seen used anywhere
+** before. It's simple: each number can be used precisely once, after
+** which it is automatically de-allocated. This handles the anonymous
+** intermediate values perfectly. Named values still need to be copied
+** and freed explicitly. Here's the above example using this convention:
+**
+** d = bi_sqrt( bi_add(
+** bi_multiply( bi_copy( x ), bi_copy( x ) ),
+** bi_multiply( bi_copy( y ), bi_copy( y ) ) ) );
+** bi_free( x );
+** bi_free( y );
+**
+** Or, since the package contains a square routine, you could just write:
+**
+** d = bi_sqrt( bi_add( bi_square( x ), bi_square( y ) ) );
+**
+** This time the named values are only being used once, so you don't
+** have to copy and free them.
+**
+** This really works, however you do have to be very careful when writing
+** your code. If you leave out a bi_copy() and use a value more than once,
+** you'll get a runtime error about "zero refs" and a SIGFPE. Run your
+** code in a debugger, get a backtrace to see where the call was, and then
+** eyeball the code there to see where you need to add the bi_copy().
+**
+**
+** Copyright © 2000 by Jef Poskanzer <jef@mail.acme.com>.
+** All rights reserved.
+**
+** Redistribution and use in source and binary forms, with or without
+** modification, are permitted provided that the following conditions
+** are met:
+** 1. Redistributions of source code must retain the above copyright
+** notice, this list of conditions and the following disclaimer.
+** 2. Redistributions in binary form must reproduce the above copyright
+** notice, this list of conditions and the following disclaimer in the
+** documentation and/or other materials provided with the distribution.
+**
+** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+** SUCH DAMAGE.
+*/
+
+
+/* Type definition for bigints - it's an opaque type, the real definition
+** is in bigint.c.
+*/
+typedef void* bigint;
+
+
+/* Some convenient pre-initialized numbers. These are all permanent,
+** so you can use them as many times as you want without calling bi_copy().
+*/
+extern bigint bi_0, bi_1, bi_2, bi_10, bi_m1, bi_maxint, bi_minint;
+
+
+/* Initialize the bigint package. You must call this when your program
+** starts up.
+*/
+void bi_initialize( void );
+
+/* Shut down the bigint package. You should call this when your program
+** exits. It's not actually required, but it does do some consistency
+** checks which help keep your program bug-free, so you really ought
+** to call it.
+*/
+void bi_terminate( void );
+
+/* Run in unsafe mode, skipping most runtime checks. Slightly faster.
+** Once your code is debugged you can add this call after bi_initialize().
+*/
+void bi_no_check( void );
+
+/* Make a copy of a bigint. You must call this if you want to use a
+** bigint more than once. (Or you can make the bigint permanent.)
+** Note that this routine is very cheap - all it actually does is
+** increment a reference counter.
+*/
+bigint bi_copy( bigint bi );
+
+/* Make a bigint permanent, so it doesn't get automatically freed when
+** used as an operand.
+*/
+void bi_permanent( bigint bi );
+
+/* Undo bi_permanent(). The next use will free the bigint. */
+void bi_depermanent( bigint bi );
+
+/* Explicitly free a bigint. Normally bigints get freed automatically
+** when they are used as an operand. This routine lets you free one
+** without using it. If the bigint is permanent, this doesn't do
+** anything, you have to depermanent it first.
+*/
+void bi_free( bigint bi );
+
+/* Compare two bigints. Returns -1, 0, or 1. */
+int bi_compare( bigint bia, bigint bib );
+
+/* Convert an int to a bigint. */
+bigint int_to_bi( int i );
+
+/* Convert a string to a bigint. */
+bigint str_to_bi( char* str );
+
+/* Convert a bigint to an int. SIGFPE on overflow. */
+int bi_to_int( bigint bi );
+
+/* Write a bigint to a file. */
+void bi_print( FILE* f, bigint bi );
+
+/* Read a bigint from a file. */
+bigint bi_scan( FILE* f );
+
+
+/* Operations on a bigint and a regular int. */
+
+/* Add an int to a bigint. */
+bigint bi_int_add( bigint bi, int i );
+
+/* Subtract an int from a bigint. */
+bigint bi_int_subtract( bigint bi, int i );
+
+/* Multiply a bigint by an int. */
+bigint bi_int_multiply( bigint bi, int i );
+
+/* Divide a bigint by an int. SIGFPE on divide-by-zero. */
+bigint bi_int_divide( bigint binumer, int denom );
+
+/* Take the remainder of a bigint by an int, with an int result.
+** SIGFPE if m is zero.
+*/
+int bi_int_rem( bigint bi, int m );
+
+/* Take the modulus of a bigint by an int, with an int result.
+** Note that mod is not rem: mod is always within [0..m), while
+** rem can be negative. SIGFPE if m is zero or negative.
+*/
+int bi_int_mod( bigint bi, int m );
+
+
+/* Basic operations on two bigints. */
+
+/* Add two bigints. */
+bigint bi_add( bigint bia, bigint bib );
+
+/* Subtract bib from bia. */
+bigint bi_subtract( bigint bia, bigint bib );
+
+/* Multiply two bigints. */
+bigint bi_multiply( bigint bia, bigint bib );
+
+/* Divide one bigint by another. SIGFPE on divide-by-zero. */
+bigint bi_divide( bigint binumer, bigint bidenom );
+
+/* Binary division of one bigint by another. SIGFPE on divide-by-zero.
+** This is here just for testing. It's about five times slower than
+** regular division.
+*/
+bigint bi_binary_divide( bigint binumer, bigint bidenom );
+
+/* Take the remainder of one bigint by another. SIGFPE if bim is zero. */
+bigint bi_rem( bigint bia, bigint bim );
+
+/* Take the modulus of one bigint by another. Note that mod is not rem:
+** mod is always within [0..bim), while rem can be negative. SIGFPE if
+** bim is zero or negative.
+*/
+bigint bi_mod( bigint bia, bigint bim );
+
+
+/* Some less common operations. */
+
+/* Negate a bigint. */
+bigint bi_negate( bigint bi );
+
+/* Absolute value of a bigint. */
+bigint bi_abs( bigint bi );
+
+/* Divide a bigint in half. */
+bigint bi_half( bigint bi );
+
+/* Multiply a bigint by two. */
+bigint bi_double( bigint bi );
+
+/* Square a bigint. */
+bigint bi_square( bigint bi );
+
+/* Raise bi to the power of biexp. SIGFPE if biexp is negative. */
+bigint bi_power( bigint bi, bigint biexp );
+
+/* Integer square root. */
+bigint bi_sqrt( bigint bi );
+
+/* Factorial. */
+bigint bi_factorial( bigint bi );
+
+
+/* Some predicates. */
+
+/* 1 if the bigint is odd, 0 if it's even. */
+int bi_is_odd( bigint bi );
+
+/* 1 if the bigint is even, 0 if it's odd. */
+int bi_is_even( bigint bi );
+
+/* 1 if the bigint equals zero, 0 if it's nonzero. */
+int bi_is_zero( bigint bi );
+
+/* 1 if the bigint equals one, 0 otherwise. */
+int bi_is_one( bigint bi );
+
+/* 1 if the bigint is less than zero, 0 if it's zero or greater. */
+int bi_is_negative( bigint bi );
+
+
+/* Now we get into the esoteric number-theory stuff used for cryptography. */
+
+/* Modular exponentiation. Much faster than bi_mod(bi_power(bi,biexp),bim).
+** Also, biexp can be negative.
+*/
+bigint bi_mod_power( bigint bi, bigint biexp, bigint bim );
+
+/* Modular inverse. mod( bi * modinv(bi), bim ) == 1. SIGFPE if bi is not
+** relatively prime to bim.
+*/
+bigint bi_mod_inverse( bigint bi, bigint bim );
+
+/* Produce a random number in the half-open interval [0..bi). You need
+** to have called srandom() before using this.
+*/
+bigint bi_random( bigint bi );
+
+/* Greatest common divisor of two bigints. Euclid's algorithm. */
+bigint bi_gcd( bigint bim, bigint bin );
+
+/* Greatest common divisor of two bigints, plus the corresponding multipliers.
+** Extended Euclid's algorithm.
+*/
+bigint bi_egcd( bigint bim, bigint bin, bigint* bim_mul, bigint* bin_mul );
+
+/* Least common multiple of two bigints. */
+bigint bi_lcm( bigint bia, bigint bib );
+
+/* The Jacobi symbol. SIGFPE if bib is even. */
+bigint bi_jacobi( bigint bia, bigint bib );
+
+/* Probabalistic prime checking. A non-zero return means the probability
+** that bi is prime is at least 1 - 1/2 ^ certainty.
+*/
+int bi_is_probable_prime( bigint bi, int certainty );
+
+/* Random probabilistic prime with the specified number of bits. */
+bigint bi_generate_prime( int bits, int certainty );
+
+/* Number of bits in the number. The log base 2, approximately. */
+int bi_bits( bigint bi );
--- /dev/null
+/* bigint_ext - external portion of large integer package
+**
+** Copyright © 2000 by Jef Poskanzer <jef@mail.acme.com>.
+** All rights reserved.
+**
+** Redistribution and use in source and binary forms, with or without
+** modification, are permitted provided that the following conditions
+** are met:
+** 1. Redistributions of source code must retain the above copyright
+** notice, this list of conditions and the following disclaimer.
+** 2. Redistributions in binary form must reproduce the above copyright
+** notice, this list of conditions and the following disclaimer in the
+** documentation and/or other materials provided with the distribution.
+**
+** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+** SUCH DAMAGE.
+*/
+
+#include <sys/types.h>
+#include <signal.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <time.h>
+
+#include "bigint.h"
+#include "low_primes.h"
+
+
+bigint bi_0, bi_1, bi_2, bi_10, bi_m1, bi_maxint, bi_minint;
+
+
+/* Forwards. */
+static void print_pos( FILE* f, bigint bi );
+
+
+bigint
+str_to_bi( char* str )
+ {
+ int sign;
+ bigint biR;
+
+ sign = 1;
+ if ( *str == '-' )
+ {
+ sign = -1;
+ ++str;
+ }
+ for ( biR = bi_0; *str >= '0' && *str <= '9'; ++str )
+ biR = bi_int_add( bi_int_multiply( biR, 10 ), *str - '0' );
+ if ( sign == -1 )
+ biR = bi_negate( biR );
+ return biR;
+ }
+
+
+void
+bi_print( FILE* f, bigint bi )
+ {
+ if ( bi_is_negative( bi_copy( bi ) ) )
+ {
+ putc( '-', f );
+ bi = bi_negate( bi );
+ }
+ print_pos( f, bi );
+ }
+
+
+bigint
+bi_scan( FILE* f )
+ {
+ int sign;
+ int c;
+ bigint biR;
+
+ sign = 1;
+ c = getc( f );
+ if ( c == '-' )
+ sign = -1;
+ else
+ ungetc( c, f );
+
+ biR = bi_0;
+ for (;;)
+ {
+ c = getc( f );
+ if ( c < '0' || c > '9' )
+ break;
+ biR = bi_int_add( bi_int_multiply( biR, 10 ), c - '0' );
+ }
+
+ if ( sign == -1 )
+ biR = bi_negate( biR );
+ return biR;
+ }
+
+
+static void
+print_pos( FILE* f, bigint bi )
+ {
+ if ( bi_compare( bi_copy( bi ), bi_10 ) >= 0 )
+ print_pos( f, bi_int_divide( bi_copy( bi ), 10 ) );
+ putc( bi_int_mod( bi, 10 ) + '0', f );
+ }
+
+
+int
+bi_int_mod( bigint bi, int m )
+ {
+ int r;
+
+ if ( m <= 0 )
+ {
+ (void) fprintf( stderr, "bi_int_mod: zero or negative modulus\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ r = bi_int_rem( bi, m );
+ if ( r < 0 )
+ r += m;
+ return r;
+ }
+
+
+bigint
+bi_rem( bigint bia, bigint bim )
+ {
+ return bi_subtract(
+ bia, bi_multiply( bi_divide( bi_copy( bia ), bi_copy( bim ) ), bim ) );
+ }
+
+
+bigint
+bi_mod( bigint bia, bigint bim )
+ {
+ bigint biR;
+
+ if ( bi_compare( bi_copy( bim ), bi_0 ) <= 0 )
+ {
+ (void) fprintf( stderr, "bi_mod: zero or negative modulus\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ biR = bi_rem( bia, bi_copy( bim ) );
+ if ( bi_is_negative( bi_copy( biR ) ) )
+ biR = bi_add( biR, bim );
+ else
+ bi_free( bim );
+ return biR;
+ }
+
+
+bigint
+bi_square( bigint bi )
+ {
+ bigint biR;
+
+ biR = bi_multiply( bi_copy( bi ), bi_copy( bi ) );
+ bi_free( bi );
+ return biR;
+ }
+
+
+bigint
+bi_power( bigint bi, bigint biexp )
+ {
+ bigint biR;
+
+ if ( bi_is_negative( bi_copy( biexp ) ) )
+ {
+ (void) fprintf( stderr, "bi_power: negative exponent\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ biR = bi_1;
+ for (;;)
+ {
+ if ( bi_is_odd( bi_copy( biexp ) ) )
+ biR = bi_multiply( biR, bi_copy( bi ) );
+ biexp = bi_half( biexp );
+ if ( bi_compare( bi_copy( biexp ), bi_0 ) <= 0 )
+ break;
+ bi = bi_multiply( bi_copy( bi ), bi );
+ }
+ bi_free( bi );
+ bi_free( biexp );
+ return biR;
+ }
+
+
+bigint
+bi_factorial( bigint bi )
+ {
+ bigint biR;
+
+ biR = bi_1;
+ while ( bi_compare( bi_copy( bi ), bi_1 ) > 0 )
+ {
+ biR = bi_multiply( biR, bi_copy( bi ) );
+ bi = bi_int_subtract( bi, 1 );
+ }
+ bi_free( bi );
+ return biR;
+ }
+
+
+int
+bi_is_even( bigint bi )
+ {
+ return ! bi_is_odd( bi );
+ }
+
+
+bigint
+bi_mod_power( bigint bi, bigint biexp, bigint bim )
+ {
+ int invert;
+ bigint biR;
+
+ invert = 0;
+ if ( bi_is_negative( bi_copy( biexp ) ) )
+ {
+ biexp = bi_negate( biexp );
+ invert = 1;
+ }
+
+ biR = bi_1;
+ for (;;)
+ {
+ if ( bi_is_odd( bi_copy( biexp ) ) )
+ biR = bi_mod( bi_multiply( biR, bi_copy( bi ) ), bi_copy( bim ) );
+ biexp = bi_half( biexp );
+ if ( bi_compare( bi_copy( biexp ), bi_0 ) <= 0 )
+ break;
+ bi = bi_mod( bi_multiply( bi_copy( bi ), bi ), bi_copy( bim ) );
+ }
+ bi_free( bi );
+ bi_free( biexp );
+
+ if ( invert )
+ biR = bi_mod_inverse( biR, bim );
+ else
+ bi_free( bim );
+ return biR;
+ }
+
+
+bigint
+bi_mod_inverse( bigint bi, bigint bim )
+ {
+ bigint gcd, mul0, mul1;
+
+ gcd = bi_egcd( bi_copy( bim ), bi, &mul0, &mul1 );
+
+ /* Did we get gcd == 1? */
+ if ( ! bi_is_one( gcd ) )
+ {
+ (void) fprintf( stderr, "bi_mod_inverse: not relatively prime\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+
+ bi_free( mul0 );
+ return bi_mod( mul1, bim );
+ }
+
+
+/* Euclid's algorithm. */
+bigint
+bi_gcd( bigint bim, bigint bin )
+ {
+ bigint bit;
+
+ bim = bi_abs( bim );
+ bin = bi_abs( bin );
+ while ( ! bi_is_zero( bi_copy( bin ) ) )
+ {
+ bit = bi_mod( bim, bi_copy( bin ) );
+ bim = bin;
+ bin = bit;
+ }
+ bi_free( bin );
+ return bim;
+ }
+
+
+/* Extended Euclidean algorithm. */
+bigint
+bi_egcd( bigint bim, bigint bin, bigint* bim_mul, bigint* bin_mul )
+ {
+ bigint a0, b0, c0, a1, b1, c1, q, t;
+
+ if ( bi_is_negative( bi_copy( bim ) ) )
+ {
+ bigint biR;
+
+ biR = bi_egcd( bi_negate( bim ), bin, &t, bin_mul );
+ *bim_mul = bi_negate( t );
+ return biR;
+ }
+ if ( bi_is_negative( bi_copy( bin ) ) )
+ {
+ bigint biR;
+
+ biR = bi_egcd( bim, bi_negate( bin ), bim_mul, &t );
+ *bin_mul = bi_negate( t );
+ return biR;
+ }
+
+ a0 = bi_1; b0 = bi_0; c0 = bim;
+ a1 = bi_0; b1 = bi_1; c1 = bin;
+
+ while ( ! bi_is_zero( bi_copy( c1 ) ) )
+ {
+ q = bi_divide( bi_copy( c0 ), bi_copy( c1 ) );
+ t = a0;
+ a0 = bi_copy( a1 );
+ a1 = bi_subtract( t, bi_multiply( bi_copy( q ), a1 ) );
+ t = b0;
+ b0 = bi_copy( b1 );
+ b1 = bi_subtract( t, bi_multiply( bi_copy( q ), b1 ) );
+ t = c0;
+ c0 = bi_copy( c1 );
+ c1 = bi_subtract( t, bi_multiply( bi_copy( q ), c1 ) );
+ bi_free( q );
+ }
+
+ bi_free( a1 );
+ bi_free( b1 );
+ bi_free( c1 );
+ *bim_mul = a0;
+ *bin_mul = b0;
+ return c0;
+ }
+
+
+bigint
+bi_lcm( bigint bia, bigint bib )
+ {
+ bigint biR;
+
+ biR = bi_divide(
+ bi_multiply( bi_copy( bia ), bi_copy( bib ) ),
+ bi_gcd( bi_copy( bia ), bi_copy( bib ) ) );
+ bi_free( bia );
+ bi_free( bib );
+ return biR;
+ }
+
+
+/* The Jacobi symbol. */
+bigint
+bi_jacobi( bigint bia, bigint bib )
+ {
+ bigint biR;
+
+ if ( bi_is_even( bi_copy( bib ) ) )
+ {
+ (void) fprintf( stderr, "bi_jacobi: don't know how to compute Jacobi(n, even)\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+
+ if ( bi_compare( bi_copy( bia ), bi_copy( bib ) ) >= 0 )
+ return bi_jacobi( bi_mod( bia, bi_copy( bib ) ), bib );
+
+ if ( bi_is_zero( bi_copy( bia ) ) || bi_is_one( bi_copy( bia ) ) )
+ {
+ bi_free( bib );
+ return bia;
+ }
+
+ if ( bi_compare( bi_copy( bia ), bi_2 ) == 0 )
+ {
+ bi_free( bia );
+ switch ( bi_int_mod( bib, 8 ) )
+ {
+ case 1: case 7:
+ return bi_1;
+ case 3: case 5:
+ return bi_m1;
+ }
+ }
+
+ if ( bi_is_even( bi_copy( bia ) ) )
+ {
+ biR = bi_multiply(
+ bi_jacobi( bi_2, bi_copy( bib ) ),
+ bi_jacobi( bi_half( bia ), bi_copy( bib ) ) );
+ bi_free( bib );
+ return biR;
+ }
+
+ if ( bi_int_mod( bi_copy( bia ), 4 ) == 3 &&
+ bi_int_mod( bi_copy( bib ), 4 ) == 3 )
+ return bi_negate( bi_jacobi( bib, bia ) );
+ else
+ return bi_jacobi( bib, bia );
+ }
+
+
+/* Probabalistic prime checking. */
+int
+bi_is_probable_prime( bigint bi, int certainty )
+ {
+ int i, p;
+ bigint bim1;
+
+ /* First do trial division by a list of small primes. This eliminates
+ ** many candidates.
+ */
+ for ( i = 0; i < sizeof(low_primes)/sizeof(*low_primes); ++i )
+ {
+ p = low_primes[i];
+ switch ( bi_compare( int_to_bi( p ), bi_copy( bi ) ) )
+ {
+ case 0:
+ bi_free( bi );
+ return 1;
+ case 1:
+ bi_free( bi );
+ return 0;
+ }
+ if ( bi_int_mod( bi_copy( bi ), p ) == 0 )
+ {
+ bi_free( bi );
+ return 0;
+ }
+ }
+
+ /* Now do the probabilistic tests. */
+ bim1 = bi_int_subtract( bi_copy( bi ), 1 );
+ for ( i = 0; i < certainty; ++i )
+ {
+ bigint a, j, jac;
+
+ /* Pick random test number. */
+ a = bi_random( bi_copy( bi ) );
+
+ /* Decide whether to run the Fermat test or the Solovay-Strassen
+ ** test. The Fermat test is fast but lets some composite numbers
+ ** through. Solovay-Strassen runs slower but is more certain.
+ ** So the compromise here is we run the Fermat test a couple of
+ ** times to quickly reject most composite numbers, and then do
+ ** the rest of the iterations with Solovay-Strassen so nothing
+ ** slips through.
+ */
+ if ( i < 2 && certainty >= 5 )
+ {
+ /* Fermat test. Note that this is not state of the art. There's a
+ ** class of numbers called Carmichael numbers which are composite
+ ** but look prime to this test - it lets them slip through no
+ ** matter how many reps you run. However, it's nice and fast so
+ ** we run it anyway to help quickly reject most of the composites.
+ */
+ if ( ! bi_is_one( bi_mod_power( bi_copy( a ), bi_copy( bim1 ), bi_copy( bi ) ) ) )
+ {
+ bi_free( bi );
+ bi_free( bim1 );
+ bi_free( a );
+ return 0;
+ }
+ }
+ else
+ {
+ /* GCD test. This rarely hits, but we need it for Solovay-Strassen. */
+ if ( ! bi_is_one( bi_gcd( bi_copy( bi ), bi_copy( a ) ) ) )
+ {
+ bi_free( bi );
+ bi_free( bim1 );
+ bi_free( a );
+ return 0;
+ }
+
+ /* Solovay-Strassen test. First compute pseudo Jacobi. */
+ j = bi_mod_power(
+ bi_copy( a ), bi_half( bi_copy( bim1 ) ), bi_copy( bi ) );
+ if ( bi_compare( bi_copy( j ), bi_copy( bim1 ) ) == 0 )
+ {
+ bi_free( j );
+ j = bi_m1;
+ }
+
+ /* Now compute real Jacobi. */
+ jac = bi_jacobi( bi_copy( a ), bi_copy( bi ) );
+
+ /* If they're not equal, the number is definitely composite. */
+ if ( bi_compare( j, jac ) != 0 )
+ {
+ bi_free( bi );
+ bi_free( bim1 );
+ bi_free( a );
+ return 0;
+ }
+ }
+
+ bi_free( a );
+ }
+
+ bi_free( bim1 );
+
+ bi_free( bi );
+ return 1;
+ }
+
+
+bigint
+bi_generate_prime( int bits, int certainty )
+ {
+ bigint bimo2, bip;
+ int i, inc = 0;
+
+ bimo2 = bi_power( bi_2, int_to_bi( bits - 1 ) );
+ for (;;)
+ {
+ bip = bi_add( bi_random( bi_copy( bimo2 ) ), bi_copy( bimo2 ) );
+ /* By shoving the candidate numbers up to the next highest multiple
+ ** of six plus or minus one, we pre-eliminate all multiples of
+ ** two and/or three.
+ */
+ switch ( bi_int_mod( bi_copy( bip ), 6 ) )
+ {
+ case 0: inc = 4; bip = bi_int_add( bip, 1 ); break;
+ case 1: inc = 4; break;
+ case 2: inc = 2; bip = bi_int_add( bip, 3 ); break;
+ case 3: inc = 2; bip = bi_int_add( bip, 2 ); break;
+ case 4: inc = 2; bip = bi_int_add( bip, 1 ); break;
+ case 5: inc = 2; break;
+ }
+ /* Starting from the generated random number, check a bunch of
+ ** numbers in sequence. This is just to avoid calls to bi_random(),
+ ** which is more expensive than a simple add.
+ */
+ for ( i = 0; i < 1000; ++i ) /* arbitrary */
+ {
+ if ( bi_is_probable_prime( bi_copy( bip ), certainty ) )
+ {
+ bi_free( bimo2 );
+ return bip;
+ }
+ bip = bi_int_add( bip, inc );
+ inc = 6 - inc;
+ }
+ /* We ran through the whole sequence and didn't find a prime.
+ ** Shrug, just try a different random starting point.
+ */
+ bi_free( bip );
+ }
+ }
--- /dev/null
+/* bigint - internal portion of large integer package
+**
+** Copyright © 2000 by Jef Poskanzer <jef@mail.acme.com>.
+** All rights reserved.
+**
+** Redistribution and use in source and binary forms, with or without
+** modification, are permitted provided that the following conditions
+** are met:
+** 1. Redistributions of source code must retain the above copyright
+** notice, this list of conditions and the following disclaimer.
+** 2. Redistributions in binary form must reproduce the above copyright
+** notice, this list of conditions and the following disclaimer in the
+** documentation and/or other materials provided with the distribution.
+**
+** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+** SUCH DAMAGE.
+*/
+
+#include <sys/types.h>
+#include <signal.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <time.h>
+
+#include "bigint.h"
+
+#define max(a,b) ((a)>(b)?(a):(b))
+#define min(a,b) ((a)<(b)?(a):(b))
+
+/* MAXINT and MININT extracted from <values.h>, which gives a warning
+** message if included.
+*/
+#define BITSPERBYTE 8
+#define BITS(type) (BITSPERBYTE * (int)sizeof(type))
+#define INTBITS BITS(int)
+#define MININT (1 << (INTBITS - 1))
+#define MAXINT (~MININT)
+
+
+/* The package represents arbitrary-precision integers as a sign and a sum
+** of components multiplied by successive powers of the basic radix, i.e.:
+**
+** sign * ( comp0 + comp1 * radix + comp2 * radix^2 + comp3 * radix^3 )
+**
+** To make good use of the computer's word size, the radix is chosen
+** to be a power of two. It could be chosen to be the full word size,
+** however this would require a lot of finagling in the middle of the
+** algorithms to get the inter-word overflows right. That would slow things
+** down. Instead, the radix is chosen to be *half* the actual word size.
+** With just a little care, this means the words can hold all intermediate
+** values, and the overflows can be handled all at once at the end, in a
+** normalization step. This simplifies the coding enormously, and is probably
+** somewhat faster to run. The cost is that numbers use twice as much
+** storage as they would with the most efficient representation, but storage
+** is cheap.
+**
+** A few more notes on the representation:
+**
+** - The sign is always 1 or -1, never 0. The number 0 is represented
+** with a sign of 1.
+** - The components are signed numbers, to allow for negative intermediate
+** values. After normalization, all components are >= 0 and the sign is
+** updated.
+*/
+
+/* Type definition for bigints. */
+typedef int64_t comp; /* should be the largest signed int type you have */
+struct _real_bigint {
+ int refs;
+ struct _real_bigint* next;
+ int num_comps, max_comps;
+ int sign;
+ comp* comps;
+ };
+typedef struct _real_bigint* real_bigint;
+
+
+#undef DUMP
+
+
+#define PERMANENT 123456789
+
+static comp bi_radix, bi_radix_o2;
+static int bi_radix_sqrt, bi_comp_bits;
+
+static real_bigint active_list, free_list;
+static int active_count, free_count;
+static int check_level;
+
+
+/* Forwards. */
+static bigint regular_multiply( real_bigint bia, real_bigint bib );
+static bigint multi_divide( bigint binumer, real_bigint bidenom );
+static bigint multi_divide2( bigint binumer, real_bigint bidenom );
+static void more_comps( real_bigint bi, int n );
+static real_bigint alloc( int num_comps );
+static real_bigint clone( real_bigint bi );
+static void normalize( real_bigint bi );
+static void check( real_bigint bi );
+static void double_check( void );
+static void triple_check( void );
+#ifdef DUMP
+static void dump( char* str, bigint bi );
+#endif /* DUMP */
+static int csqrt( comp c );
+static int cbits( comp c );
+
+
+void
+bi_initialize( void )
+ {
+ /* Set the radix. This does not actually have to be a power of
+ ** two, that's just the most efficient value. It does have to
+ ** be even for bi_half() to work.
+ */
+ bi_radix = 1;
+ bi_radix <<= BITS(comp) / 2 - 1;
+
+ /* Halve the radix. Only used by bi_half(). */
+ bi_radix_o2 = bi_radix >> 1;
+
+ /* Take the square root of the radix. Only used by bi_divide(). */
+ bi_radix_sqrt = csqrt( bi_radix );
+
+ /* Figure out how many bits in a component. Only used by bi_bits(). */
+ bi_comp_bits = cbits( bi_radix - 1 );
+
+ /* Init various globals. */
+ active_list = (real_bigint) 0;
+ active_count = 0;
+ free_list = (real_bigint) 0;
+ free_count = 0;
+
+ /* This can be 0 through 3. */
+ check_level = 3;
+
+ /* Set up some convenient bigints. */
+ bi_0 = int_to_bi( 0 ); bi_permanent( bi_0 );
+ bi_1 = int_to_bi( 1 ); bi_permanent( bi_1 );
+ bi_2 = int_to_bi( 2 ); bi_permanent( bi_2 );
+ bi_10 = int_to_bi( 10 ); bi_permanent( bi_10 );
+ bi_m1 = int_to_bi( -1 ); bi_permanent( bi_m1 );
+ bi_maxint = int_to_bi( MAXINT ); bi_permanent( bi_maxint );
+ bi_minint = int_to_bi( MININT ); bi_permanent( bi_minint );
+ }
+
+
+void
+bi_terminate( void )
+ {
+ real_bigint p, pn;
+
+ bi_depermanent( bi_0 ); bi_free( bi_0 );
+ bi_depermanent( bi_1 ); bi_free( bi_1 );
+ bi_depermanent( bi_2 ); bi_free( bi_2 );
+ bi_depermanent( bi_10 ); bi_free( bi_10 );
+ bi_depermanent( bi_m1 ); bi_free( bi_m1 );
+ bi_depermanent( bi_maxint ); bi_free( bi_maxint );
+ bi_depermanent( bi_minint ); bi_free( bi_minint );
+
+ if ( active_count != 0 )
+ (void) fprintf(
+ stderr, "bi_terminate: there were %d un-freed bigints\n",
+ active_count );
+ if ( check_level >= 2 )
+ double_check();
+ if ( check_level >= 3 )
+ {
+ triple_check();
+ for ( p = active_list; p != (bigint) 0; p = pn )
+ {
+ pn = p->next;
+ free( p->comps );
+ free( p );
+ }
+ }
+ for ( p = free_list; p != (bigint) 0; p = pn )
+ {
+ pn = p->next;
+ free( p->comps );
+ free( p );
+ }
+ }
+
+
+void
+bi_no_check( void )
+ {
+ check_level = 0;
+ }
+
+
+bigint
+bi_copy( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+
+ check( bi );
+ if ( bi->refs != PERMANENT )
+ ++bi->refs;
+ return bi;
+ }
+
+
+void
+bi_permanent( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+
+ check( bi );
+ if ( check_level >= 1 && bi->refs != 1 )
+ {
+ (void) fprintf( stderr, "bi_permanent: refs was not 1\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ bi->refs = PERMANENT;
+ }
+
+
+void
+bi_depermanent( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+
+ check( bi );
+ if ( check_level >= 1 && bi->refs != PERMANENT )
+ {
+ (void) fprintf( stderr, "bi_depermanent: bigint was not permanent\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ bi->refs = 1;
+ }
+
+
+void
+bi_free( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+
+ check( bi );
+ if ( bi->refs == PERMANENT )
+ return;
+ --bi->refs;
+ if ( bi->refs > 0 )
+ return;
+ if ( check_level >= 3 )
+ {
+ /* The active list only gets maintained at check levels 3 or higher. */
+ real_bigint* nextP;
+ for ( nextP = &active_list; *nextP != (real_bigint) 0; nextP = &((*nextP)->next) )
+ if ( *nextP == bi )
+ {
+ *nextP = bi->next;
+ break;
+ }
+ }
+ --active_count;
+ bi->next = free_list;
+ free_list = bi;
+ ++free_count;
+ if ( check_level >= 1 && active_count < 0 )
+ {
+ (void) fprintf( stderr,
+ "bi_free: active_count went negative - double-freed bigint?\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ }
+
+
+int
+bi_compare( bigint obia, bigint obib )
+ {
+ real_bigint bia = (real_bigint) obia;
+ real_bigint bib = (real_bigint) obib;
+ int r, c;
+
+ check( bia );
+ check( bib );
+
+ /* First check for pointer equality. */
+ if ( bia == bib )
+ r = 0;
+ else
+ {
+ /* Compare signs. */
+ if ( bia->sign > bib->sign )
+ r = 1;
+ else if ( bia->sign < bib->sign )
+ r = -1;
+ /* Signs are the same. Check the number of components. */
+ else if ( bia->num_comps > bib->num_comps )
+ r = bia->sign;
+ else if ( bia->num_comps < bib->num_comps )
+ r = -bia->sign;
+ else
+ {
+ /* Same number of components. Compare starting from the high end
+ ** and working down.
+ */
+ r = 0; /* if we complete the loop, the numbers are equal */
+ for ( c = bia->num_comps - 1; c >= 0; --c )
+ {
+ if ( bia->comps[c] > bib->comps[c] )
+ { r = bia->sign; break; }
+ else if ( bia->comps[c] < bib->comps[c] )
+ { r = -bia->sign; break; }
+ }
+ }
+ }
+
+ bi_free( bia );
+ bi_free( bib );
+ return r;
+ }
+
+
+bigint
+int_to_bi( int i )
+ {
+ real_bigint biR;
+
+ biR = alloc( 1 );
+ biR->sign = 1;
+ biR->comps[0] = i;
+ normalize( biR );
+ check( biR );
+ return biR;
+ }
+
+
+int
+bi_to_int( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+ comp v, m;
+ int c, r;
+
+ check( bi );
+ if ( bi_compare( bi_copy( bi ), bi_maxint ) > 0 ||
+ bi_compare( bi_copy( bi ), bi_minint ) < 0 )
+ {
+ (void) fprintf( stderr, "bi_to_int: overflow\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ v = 0;
+ m = 1;
+ for ( c = 0; c < bi->num_comps; ++c )
+ {
+ v += bi->comps[c] * m;
+ m *= bi_radix;
+ }
+ r = (int) ( bi->sign * v );
+ bi_free( bi );
+ return r;
+ }
+
+
+bigint
+bi_int_add( bigint obi, int i )
+ {
+ real_bigint bi = (real_bigint) obi;
+ real_bigint biR;
+
+ check( bi );
+ biR = clone( bi );
+ if ( biR->sign == 1 )
+ biR->comps[0] += i;
+ else
+ biR->comps[0] -= i;
+ normalize( biR );
+ check( biR );
+ return biR;
+ }
+
+
+bigint
+bi_int_subtract( bigint obi, int i )
+ {
+ real_bigint bi = (real_bigint) obi;
+ real_bigint biR;
+
+ check( bi );
+ biR = clone( bi );
+ if ( biR->sign == 1 )
+ biR->comps[0] -= i;
+ else
+ biR->comps[0] += i;
+ normalize( biR );
+ check( biR );
+ return biR;
+ }
+
+
+bigint
+bi_int_multiply( bigint obi, int i )
+ {
+ real_bigint bi = (real_bigint) obi;
+ real_bigint biR;
+ int c;
+
+ check( bi );
+ biR = clone( bi );
+ if ( i < 0 )
+ {
+ i = -i;
+ biR->sign = -biR->sign;
+ }
+ for ( c = 0; c < biR->num_comps; ++c )
+ biR->comps[c] *= i;
+ normalize( biR );
+ check( biR );
+ return biR;
+ }
+
+
+bigint
+bi_int_divide( bigint obinumer, int denom )
+ {
+ real_bigint binumer = (real_bigint) obinumer;
+ real_bigint biR;
+ int c;
+ comp r;
+
+ check( binumer );
+ if ( denom == 0 )
+ {
+ (void) fprintf( stderr, "bi_int_divide: divide by zero\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ biR = clone( binumer );
+ if ( denom < 0 )
+ {
+ denom = -denom;
+ biR->sign = -biR->sign;
+ }
+ r = 0;
+ for ( c = biR->num_comps - 1; c >= 0; --c )
+ {
+ r = r * bi_radix + biR->comps[c];
+ biR->comps[c] = r / denom;
+ r = r % denom;
+ }
+ normalize( biR );
+ check( biR );
+ return biR;
+ }
+
+
+int
+bi_int_rem( bigint obi, int m )
+ {
+ real_bigint bi = (real_bigint) obi;
+ comp rad_r, r;
+ int c;
+
+ check( bi );
+ if ( m == 0 )
+ {
+ (void) fprintf( stderr, "bi_int_rem: divide by zero\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ if ( m < 0 )
+ m = -m;
+ rad_r = 1;
+ r = 0;
+ for ( c = 0; c < bi->num_comps; ++c )
+ {
+ r = ( r + bi->comps[c] * rad_r ) % m;
+ rad_r = ( rad_r * bi_radix ) % m;
+ }
+ if ( bi->sign < 1 )
+ r = -r;
+ bi_free( bi );
+ return (int) r;
+ }
+
+
+bigint
+bi_add( bigint obia, bigint obib )
+ {
+ real_bigint bia = (real_bigint) obia;
+ real_bigint bib = (real_bigint) obib;
+ real_bigint biR;
+ int c;
+
+ check( bia );
+ check( bib );
+ biR = clone( bia );
+ more_comps( biR, max( biR->num_comps, bib->num_comps ) );
+ for ( c = 0; c < bib->num_comps; ++c )
+ if ( biR->sign == bib->sign )
+ biR->comps[c] += bib->comps[c];
+ else
+ biR->comps[c] -= bib->comps[c];
+ bi_free( bib );
+ normalize( biR );
+ check( biR );
+ return biR;
+ }
+
+
+bigint
+bi_subtract( bigint obia, bigint obib )
+ {
+ real_bigint bia = (real_bigint) obia;
+ real_bigint bib = (real_bigint) obib;
+ real_bigint biR;
+ int c;
+
+ check( bia );
+ check( bib );
+ biR = clone( bia );
+ more_comps( biR, max( biR->num_comps, bib->num_comps ) );
+ for ( c = 0; c < bib->num_comps; ++c )
+ if ( biR->sign == bib->sign )
+ biR->comps[c] -= bib->comps[c];
+ else
+ biR->comps[c] += bib->comps[c];
+ bi_free( bib );
+ normalize( biR );
+ check( biR );
+ return biR;
+ }
+
+
+/* Karatsuba multiplication. This is supposedly O(n^1.59), better than
+** regular multiplication for large n. The define below sets the crossover
+** point - below that we use regular multiplication, above it we
+** use Karatsuba. Note that Karatsuba is a recursive algorithm, so
+** all Karatsuba calls involve regular multiplications as the base
+** steps.
+*/
+#define KARATSUBA_THRESH 12
+bigint
+bi_multiply( bigint obia, bigint obib )
+ {
+ real_bigint bia = (real_bigint) obia;
+ real_bigint bib = (real_bigint) obib;
+
+ check( bia );
+ check( bib );
+ if ( min( bia->num_comps, bib->num_comps ) < KARATSUBA_THRESH )
+ return regular_multiply( bia, bib );
+ else
+ {
+ /* The factors are large enough that Karatsuba multiplication
+ ** is a win. The basic idea here is you break each factor up
+ ** into two parts, like so:
+ ** i * r^n + j k * r^n + l
+ ** r is the radix we're representing numbers with, so this
+ ** breaking up just means shuffling components around, no
+ ** math required. With regular multiplication the product
+ ** would be:
+ ** ik * r^(n*2) + ( il + jk ) * r^n + jl
+ ** That's four sub-multiplies and one addition, not counting the
+ ** radix-shifting. With Karatsuba, you instead do:
+ ** ik * r^(n*2) + ( (i+j)(k+l) - ik - jl ) * r^n + jl
+ ** This is only three sub-multiplies. The number of adds
+ ** (and subtracts) increases to four, but those run in linear time
+ ** so they are cheap. The sub-multiplies are accomplished by
+ ** recursive calls, eventually reducing to regular multiplication.
+ */
+ int n, c;
+ real_bigint bi_i, bi_j, bi_k, bi_l;
+ real_bigint bi_ik, bi_mid, bi_jl;
+
+ n = ( max( bia->num_comps, bib->num_comps ) + 1 ) / 2;
+ bi_i = alloc( n );
+ bi_j = alloc( n );
+ bi_k = alloc( n );
+ bi_l = alloc( n );
+ for ( c = 0; c < n; ++c )
+ {
+ if ( c + n < bia->num_comps )
+ bi_i->comps[c] = bia->comps[c + n];
+ else
+ bi_i->comps[c] = 0;
+ if ( c < bia->num_comps )
+ bi_j->comps[c] = bia->comps[c];
+ else
+ bi_j->comps[c] = 0;
+ if ( c + n < bib->num_comps )
+ bi_k->comps[c] = bib->comps[c + n];
+ else
+ bi_k->comps[c] = 0;
+ if ( c < bib->num_comps )
+ bi_l->comps[c] = bib->comps[c];
+ else
+ bi_l->comps[c] = 0;
+ }
+ bi_i->sign = bi_j->sign = bi_k->sign = bi_l->sign = 1;
+ normalize( bi_i );
+ normalize( bi_j );
+ normalize( bi_k );
+ normalize( bi_l );
+ bi_ik = bi_multiply( bi_copy( bi_i ), bi_copy( bi_k ) );
+ bi_jl = bi_multiply( bi_copy( bi_j ), bi_copy( bi_l ) );
+ bi_mid = bi_subtract(
+ bi_subtract(
+ bi_multiply( bi_add( bi_i, bi_j ), bi_add( bi_k, bi_l ) ),
+ bi_copy( bi_ik ) ),
+ bi_copy( bi_jl ) );
+ more_comps(
+ bi_jl, max( bi_mid->num_comps + n, bi_ik->num_comps + n * 2 ) );
+ for ( c = 0; c < bi_mid->num_comps; ++c )
+ bi_jl->comps[c + n] += bi_mid->comps[c];
+ for ( c = 0; c < bi_ik->num_comps; ++c )
+ bi_jl->comps[c + n * 2] += bi_ik->comps[c];
+ bi_free( bi_ik );
+ bi_free( bi_mid );
+ bi_jl->sign = bia->sign * bib->sign;
+ bi_free( bia );
+ bi_free( bib );
+ normalize( bi_jl );
+ check( bi_jl );
+ return bi_jl;
+ }
+ }
+
+
+/* Regular O(n^2) multiplication. */
+static bigint
+regular_multiply( real_bigint bia, real_bigint bib )
+ {
+ real_bigint biR;
+ int new_comps, c1, c2;
+
+ check( bia );
+ check( bib );
+ biR = clone( bi_0 );
+ new_comps = bia->num_comps + bib->num_comps;
+ more_comps( biR, new_comps );
+ for ( c1 = 0; c1 < bia->num_comps; ++c1 )
+ {
+ for ( c2 = 0; c2 < bib->num_comps; ++c2 )
+ biR->comps[c1 + c2] += bia->comps[c1] * bib->comps[c2];
+ /* Normalize after each inner loop to avoid overflowing any
+ ** components. But be sure to reset biR's components count,
+ ** in case a previous normalization lowered it.
+ */
+ biR->num_comps = new_comps;
+ normalize( biR );
+ }
+ check( biR );
+ if ( ! bi_is_zero( bi_copy( biR ) ) )
+ biR->sign = bia->sign * bib->sign;
+ bi_free( bia );
+ bi_free( bib );
+ return biR;
+ }
+
+
+/* The following three routines implement a multi-precision divide method
+** that I haven't seen used anywhere else. It is not quite as fast as
+** the standard divide method, but it is a lot simpler. In fact it's
+** about as simple as the binary shift-and-subtract method, which goes
+** about five times slower than this.
+**
+** The method assumes you already have multi-precision multiply and subtract
+** routines, and also a multi-by-single precision divide routine. The latter
+** is used to generate approximations, which are then checked and corrected
+** using the former. The result converges to the correct value by about
+** 16 bits per loop.
+*/
+
+/* Public routine to divide two arbitrary numbers. */
+bigint
+bi_divide( bigint binumer, bigint obidenom )
+ {
+ real_bigint bidenom = (real_bigint) obidenom;
+ int sign;
+ bigint biquotient;
+
+ /* Check signs and trivial cases. */
+ sign = 1;
+ switch ( bi_compare( bi_copy( bidenom ), bi_0 ) )
+ {
+ case 0:
+ (void) fprintf( stderr, "bi_divide: divide by zero\n" );
+ (void) kill( getpid(), SIGFPE );
+ case -1:
+ sign *= -1;
+ bidenom = bi_negate( bidenom );
+ break;
+ }
+ switch ( bi_compare( bi_copy( binumer ), bi_0 ) )
+ {
+ case 0:
+ bi_free( binumer );
+ bi_free( bidenom );
+ return bi_0;
+ case -1:
+ sign *= -1;
+ binumer = bi_negate( binumer );
+ break;
+ }
+ switch ( bi_compare( bi_copy( binumer ), bi_copy( bidenom ) ) )
+ {
+ case -1:
+ bi_free( binumer );
+ bi_free( bidenom );
+ return bi_0;
+ case 0:
+ bi_free( binumer );
+ bi_free( bidenom );
+ if ( sign == 1 )
+ return bi_1;
+ else
+ return bi_m1;
+ }
+
+ /* Is the denominator small enough to do an int divide? */
+ if ( bidenom->num_comps == 1 )
+ {
+ /* Win! */
+ biquotient = bi_int_divide( binumer, bidenom->comps[0] );
+ bi_free( bidenom );
+ }
+ else
+ {
+ /* No, we have to do a full multi-by-multi divide. */
+ biquotient = multi_divide( binumer, bidenom );
+ }
+
+ if ( sign == -1 )
+ biquotient = bi_negate( biquotient );
+ return biquotient;
+ }
+
+
+/* Divide two multi-precision positive numbers. */
+static bigint
+multi_divide( bigint binumer, real_bigint bidenom )
+ {
+ /* We use a successive approximation method that is kind of like a
+ ** continued fraction. The basic approximation is to do an int divide
+ ** by the high-order component of the denominator. Then we correct
+ ** based on the remainder from that.
+ **
+ ** However, if the high-order component is too small, this doesn't
+ ** work well. In particular, if the high-order component is 1 it
+ ** doesn't work at all. Easily fixed, though - if the component
+ ** is too small, increase it!
+ */
+ if ( bidenom->comps[bidenom->num_comps-1] < bi_radix_sqrt )
+ {
+ /* We use the square root of the radix as the threshhold here
+ ** because that's the largest value guaranteed to not make the
+ ** high-order component overflow and become too small again.
+ **
+ ** We increase binumer along with bidenom to keep the end result
+ ** the same.
+ */
+ binumer = bi_int_multiply( binumer, bi_radix_sqrt );
+ bidenom = bi_int_multiply( bidenom, bi_radix_sqrt );
+ }
+
+ /* Now start the recursion. */
+ return multi_divide2( binumer, bidenom );
+ }
+
+
+/* Divide two multi-precision positive conditioned numbers. */
+static bigint
+multi_divide2( bigint binumer, real_bigint bidenom )
+ {
+ real_bigint biapprox;
+ bigint birem, biquotient;
+ int c, o;
+
+ /* Figure out the approximate quotient. Since we're dividing by only
+ ** the top component of the denominator, which is less than or equal to
+ ** the full denominator, the result is guaranteed to be greater than or
+ ** equal to the correct quotient.
+ */
+ o = bidenom->num_comps - 1;
+ biapprox = bi_int_divide( bi_copy( binumer ), bidenom->comps[o] );
+ /* And downshift the result to get the approximate quotient. */
+ for ( c = o; c < biapprox->num_comps; ++c )
+ biapprox->comps[c - o] = biapprox->comps[c];
+ biapprox->num_comps -= o;
+
+ /* Find the remainder from the approximate quotient. */
+ birem = bi_subtract(
+ bi_multiply( bi_copy( biapprox ), bi_copy( bidenom ) ), binumer );
+
+ /* If the remainder is negative, zero, or in fact any value less
+ ** than bidenom, then we have the correct quotient and we're done.
+ */
+ if ( bi_compare( bi_copy( birem ), bi_copy( bidenom ) ) < 0 )
+ {
+ biquotient = biapprox;
+ bi_free( birem );
+ bi_free( bidenom );
+ }
+ else
+ {
+ /* The real quotient is now biapprox - birem / bidenom. We still
+ ** have to do a divide. However, birem is smaller than binumer,
+ ** so the next divide will go faster. We do the divide by
+ ** recursion. Since this is tail-recursion or close to it, we
+ ** could probably re-arrange things and make it a non-recursive
+ ** loop, but the overhead of recursion is small and the bookkeeping
+ ** is simpler this way.
+ **
+ ** Note that since the sub-divide uses the same denominator, it
+ ** doesn't have to adjust the values again - the high-order component
+ ** will still be good.
+ */
+ biquotient = bi_subtract( biapprox, multi_divide2( birem, bidenom ) );
+ }
+
+ return biquotient;
+ }
+
+
+/* Binary division - about five times slower than the above. */
+bigint
+bi_binary_divide( bigint binumer, bigint obidenom )
+ {
+ real_bigint bidenom = (real_bigint) obidenom;
+ int sign;
+ bigint biquotient;
+
+ /* Check signs and trivial cases. */
+ sign = 1;
+ switch ( bi_compare( bi_copy( bidenom ), bi_0 ) )
+ {
+ case 0:
+ (void) fprintf( stderr, "bi_divide: divide by zero\n" );
+ (void) kill( getpid(), SIGFPE );
+ case -1:
+ sign *= -1;
+ bidenom = bi_negate( bidenom );
+ break;
+ }
+ switch ( bi_compare( bi_copy( binumer ), bi_0 ) )
+ {
+ case 0:
+ bi_free( binumer );
+ bi_free( bidenom );
+ return bi_0;
+ case -1:
+ sign *= -1;
+ binumer = bi_negate( binumer );
+ break;
+ }
+ switch ( bi_compare( bi_copy( binumer ), bi_copy( bidenom ) ) )
+ {
+ case -1:
+ bi_free( binumer );
+ bi_free( bidenom );
+ return bi_0;
+ case 0:
+ bi_free( binumer );
+ bi_free( bidenom );
+ if ( sign == 1 )
+ return bi_1;
+ else
+ return bi_m1;
+ }
+
+ /* Is the denominator small enough to do an int divide? */
+ if ( bidenom->num_comps == 1 )
+ {
+ /* Win! */
+ biquotient = bi_int_divide( binumer, bidenom->comps[0] );
+ bi_free( bidenom );
+ }
+ else
+ {
+ /* No, we have to do a full multi-by-multi divide. */
+ int num_bits, den_bits, i;
+
+ num_bits = bi_bits( bi_copy( binumer ) );
+ den_bits = bi_bits( bi_copy( bidenom ) );
+ bidenom = bi_multiply( bidenom, bi_power( bi_2, int_to_bi( num_bits - den_bits ) ) );
+ biquotient = bi_0;
+ for ( i = den_bits; i <= num_bits; ++i )
+ {
+ biquotient = bi_double( biquotient );
+ if ( bi_compare( bi_copy( binumer ), bi_copy( bidenom ) ) >= 0 )
+ {
+ biquotient = bi_int_add( biquotient, 1 );
+ binumer = bi_subtract( binumer, bi_copy( bidenom ) );
+ }
+ bidenom = bi_half( bidenom );
+ }
+ bi_free( binumer );
+ bi_free( bidenom );
+ }
+
+ if ( sign == -1 )
+ biquotient = bi_negate( biquotient );
+ return biquotient;
+ }
+
+
+bigint
+bi_negate( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+ real_bigint biR;
+
+ check( bi );
+ biR = clone( bi );
+ biR->sign = -biR->sign;
+ check( biR );
+ return biR;
+ }
+
+
+bigint
+bi_abs( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+ real_bigint biR;
+
+ check( bi );
+ biR = clone( bi );
+ biR->sign = 1;
+ check( biR );
+ return biR;
+ }
+
+
+bigint
+bi_half( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+ real_bigint biR;
+ int c;
+
+ check( bi );
+ /* This depends on the radix being even. */
+ biR = clone( bi );
+ for ( c = 0; c < biR->num_comps; ++c )
+ {
+ if ( biR->comps[c] & 1 )
+ if ( c > 0 )
+ biR->comps[c - 1] += bi_radix_o2;
+ biR->comps[c] = biR->comps[c] >> 1;
+ }
+ /* Avoid normalization. */
+ if ( biR->num_comps > 1 && biR->comps[biR->num_comps-1] == 0 )
+ --biR->num_comps;
+ check( biR );
+ return biR;
+ }
+
+
+bigint
+bi_double( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+ real_bigint biR;
+ int c;
+
+ check( bi );
+ biR = clone( bi );
+ for ( c = biR->num_comps - 1; c >= 0; --c )
+ {
+ biR->comps[c] = biR->comps[c] << 1;
+ if ( biR->comps[c] >= bi_radix )
+ {
+ if ( c + 1 >= biR->num_comps )
+ more_comps( biR, biR->num_comps + 1 );
+ biR->comps[c] -= bi_radix;
+ biR->comps[c + 1] += 1;
+ }
+ }
+ check( biR );
+ return biR;
+ }
+
+
+/* Find integer square root by Newton's method. */
+bigint
+bi_sqrt( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+ bigint biR, biR2, bidiff;
+
+ switch ( bi_compare( bi_copy( bi ), bi_0 ) )
+ {
+ case -1:
+ (void) fprintf( stderr, "bi_sqrt: imaginary result\n" );
+ (void) kill( getpid(), SIGFPE );
+ case 0:
+ return bi;
+ }
+ if ( bi_is_one( bi_copy( bi ) ) )
+ return bi;
+
+ /* Newton's method converges reasonably fast, but it helps to have
+ ** a good initial guess. We can make a *very* good initial guess
+ ** by taking the square root of the top component times the square
+ ** root of the radix part. Both of those are easy to compute.
+ */
+ biR = bi_int_multiply(
+ bi_power( int_to_bi( bi_radix_sqrt ), int_to_bi( bi->num_comps - 1 ) ),
+ csqrt( bi->comps[bi->num_comps - 1] ) );
+
+ /* Now do the Newton loop until we have the answer. */
+ for (;;)
+ {
+ biR2 = bi_divide( bi_copy( bi ), bi_copy( biR ) );
+ bidiff = bi_subtract( bi_copy( biR ), bi_copy( biR2 ) );
+ if ( bi_is_zero( bi_copy( bidiff ) ) ||
+ bi_compare( bi_copy( bidiff ), bi_m1 ) == 0 )
+ {
+ bi_free( bi );
+ bi_free( bidiff );
+ bi_free( biR2 );
+ return biR;
+ }
+ if ( bi_is_one( bi_copy( bidiff ) ) )
+ {
+ bi_free( bi );
+ bi_free( bidiff );
+ bi_free( biR );
+ return biR2;
+ }
+ bi_free( bidiff );
+ biR = bi_half( bi_add( biR, biR2 ) );
+ }
+ }
+
+
+int
+bi_is_odd( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+ int r;
+
+ check( bi );
+ r = bi->comps[0] & 1;
+ bi_free( bi );
+ return r;
+ }
+
+
+int
+bi_is_zero( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+ int r;
+
+ check( bi );
+ r = ( bi->sign == 1 && bi->num_comps == 1 && bi->comps[0] == 0 );
+ bi_free( bi );
+ return r;
+ }
+
+
+int
+bi_is_one( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+ int r;
+
+ check( bi );
+ r = ( bi->sign == 1 && bi->num_comps == 1 && bi->comps[0] == 1 );
+ bi_free( bi );
+ return r;
+ }
+
+
+int
+bi_is_negative( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+ int r;
+
+ check( bi );
+ r = ( bi->sign == -1 );
+ bi_free( bi );
+ return r;
+ }
+
+
+bigint
+bi_random( bigint bi )
+ {
+ real_bigint biR;
+ int c;
+
+ biR = bi_multiply( bi_copy( bi ), bi_copy( bi ) );
+ for ( c = 0; c < biR->num_comps; ++c )
+ biR->comps[c] = random();
+ normalize( biR );
+ biR = bi_mod( biR, bi );
+ return biR;
+ }
+
+
+int
+bi_bits( bigint obi )
+ {
+ real_bigint bi = (real_bigint) obi;
+ int bits;
+
+ bits =
+ bi_comp_bits * ( bi->num_comps - 1 ) +
+ cbits( bi->comps[bi->num_comps - 1] );
+ bi_free( bi );
+ return bits;
+ }
+
+
+/* Allocate and zero more components. Does not consume bi, of course. */
+static void
+more_comps( real_bigint bi, int n )
+ {
+ if ( n > bi->max_comps )
+ {
+ bi->max_comps = max( bi->max_comps * 2, n );
+ bi->comps = (comp*) realloc(
+ (void*) bi->comps, bi->max_comps * sizeof(comp) );
+ if ( bi->comps == (comp*) 0 )
+ {
+ (void) fprintf( stderr, "out of memory\n" );
+ exit( 1 );
+ }
+ }
+ for ( ; bi->num_comps < n; ++bi->num_comps )
+ bi->comps[bi->num_comps] = 0;
+ }
+
+
+/* Make a new empty bigint. Fills in everything except sign and the
+** components.
+*/
+static real_bigint
+alloc( int num_comps )
+ {
+ real_bigint biR;
+
+ /* Can we recycle an old bigint? */
+ if ( free_list != (real_bigint) 0 )
+ {
+ biR = free_list;
+ free_list = biR->next;
+ --free_count;
+ if ( check_level >= 1 && biR->refs != 0 )
+ {
+ (void) fprintf( stderr, "alloc: refs was not 0\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ more_comps( biR, num_comps );
+ }
+ else
+ {
+ /* No free bigints available - create a new one. */
+ biR = (real_bigint) malloc( sizeof(struct _real_bigint) );
+ if ( biR == (real_bigint) 0 )
+ {
+ (void) fprintf( stderr, "out of memory\n" );
+ exit( 1 );
+ }
+ biR->comps = (comp*) malloc( num_comps * sizeof(comp) );
+ if ( biR->comps == (comp*) 0 )
+ {
+ (void) fprintf( stderr, "out of memory\n" );
+ exit( 1 );
+ }
+ biR->max_comps = num_comps;
+ }
+ biR->num_comps = num_comps;
+ biR->refs = 1;
+ if ( check_level >= 3 )
+ {
+ /* The active list only gets maintained at check levels 3 or higher. */
+ biR->next = active_list;
+ active_list = biR;
+ }
+ else
+ biR->next = (real_bigint) 0;
+ ++active_count;
+ return biR;
+ }
+
+
+/* Make a modifiable copy of bi. DOES consume bi. */
+static real_bigint
+clone( real_bigint bi )
+ {
+ real_bigint biR;
+ int c;
+
+ /* Very clever optimization. */
+ if ( bi->refs != PERMANENT && bi->refs == 1 )
+ return bi;
+
+ biR = alloc( bi->num_comps );
+ biR->sign = bi->sign;
+ for ( c = 0; c < bi->num_comps; ++c )
+ biR->comps[c] = bi->comps[c];
+ bi_free( bi );
+ return biR;
+ }
+
+
+/* Put bi into normal form. Does not consume bi, of course.
+**
+** Normal form is:
+** - All components >= 0 and < bi_radix.
+** - Leading 0 components removed.
+** - Sign either 1 or -1.
+** - The number zero represented by a single 0 component and a sign of 1.
+*/
+static void
+normalize( real_bigint bi )
+ {
+ int c;
+
+ /* Borrow for negative components. Got to be careful with the math here:
+ ** -9 / 10 == 0 -9 % 10 == -9
+ ** -10 / 10 == -1 -10 % 10 == 0
+ ** -11 / 10 == -1 -11 % 10 == -1
+ */
+ for ( c = 0; c < bi->num_comps - 1; ++c )
+ if ( bi->comps[c] < 0 )
+ {
+ bi->comps[c+1] += bi->comps[c] / bi_radix - 1;
+ bi->comps[c] = bi->comps[c] % bi_radix;
+ if ( bi->comps[c] != 0 )
+ bi->comps[c] += bi_radix;
+ else
+ bi->comps[c+1] += 1;
+ }
+ /* Is the top component negative? */
+ if ( bi->comps[bi->num_comps - 1] < 0 )
+ {
+ /* Switch the sign of the number, and fix up the components. */
+ bi->sign = -bi->sign;
+ for ( c = 0; c < bi->num_comps - 1; ++c )
+ {
+ bi->comps[c] = bi_radix - bi->comps[c];
+ bi->comps[c + 1] += 1;
+ }
+ bi->comps[bi->num_comps - 1] = -bi->comps[bi->num_comps - 1];
+ }
+
+ /* Carry for components larger than the radix. */
+ for ( c = 0; c < bi->num_comps; ++c )
+ if ( bi->comps[c] >= bi_radix )
+ {
+ if ( c + 1 >= bi->num_comps )
+ more_comps( bi, bi->num_comps + 1 );
+ bi->comps[c+1] += bi->comps[c] / bi_radix;
+ bi->comps[c] = bi->comps[c] % bi_radix;
+ }
+
+ /* Trim off any leading zero components. */
+ for ( ; bi->num_comps > 1 && bi->comps[bi->num_comps-1] == 0; --bi->num_comps )
+ ;
+
+ /* Check for -0. */
+ if ( bi->num_comps == 1 && bi->comps[0] == 0 && bi->sign == -1 )
+ bi->sign = 1;
+ }
+
+
+static void
+check( real_bigint bi )
+ {
+ if ( check_level == 0 )
+ return;
+ if ( bi->refs == 0 )
+ {
+ (void) fprintf( stderr, "check: zero refs in bigint\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ if ( bi->refs < 0 )
+ {
+ (void) fprintf( stderr, "check: negative refs in bigint\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ if ( check_level < 3 )
+ {
+ /* At check levels less than 3, active bigints have a zero next. */
+ if ( bi->next != (real_bigint) 0 )
+ {
+ (void) fprintf(
+ stderr, "check: attempt to use a bigint from the free list\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ }
+ else
+ {
+ /* At check levels 3 or higher, active bigints must be on the active
+ ** list.
+ */
+ real_bigint p;
+
+ for ( p = active_list; p != (real_bigint) 0; p = p->next )
+ if ( p == bi )
+ break;
+ if ( p == (real_bigint) 0 )
+ {
+ (void) fprintf( stderr,
+ "check: attempt to use a bigint not on the active list\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ }
+ if ( check_level >= 2 )
+ double_check();
+ if ( check_level >= 3 )
+ triple_check();
+ }
+
+
+static void
+double_check( void )
+ {
+ real_bigint p;
+ int c;
+
+ for ( p = free_list, c = 0; p != (real_bigint) 0; p = p->next, ++c )
+ if ( p->refs != 0 )
+ {
+ (void) fprintf( stderr,
+ "double_check: found a non-zero ref on the free list\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ if ( c != free_count )
+ {
+ (void) fprintf( stderr,
+ "double_check: free_count is %d but the free list has %d items\n",
+ free_count, c );
+ (void) kill( getpid(), SIGFPE );
+ }
+ }
+
+
+static void
+triple_check( void )
+ {
+ real_bigint p;
+ int c;
+
+ for ( p = active_list, c = 0; p != (real_bigint) 0; p = p->next, ++c )
+ if ( p->refs == 0 )
+ {
+ (void) fprintf( stderr,
+ "triple_check: found a zero ref on the active list\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+ if ( c != active_count )
+ {
+ (void) fprintf( stderr,
+ "triple_check: active_count is %d but active_list has %d items\n",
+ free_count, c );
+ (void) kill( getpid(), SIGFPE );
+ }
+ }
+
+
+#ifdef DUMP
+/* Debug routine to dump out a complete bigint. Does not consume bi. */
+static void
+dump( char* str, bigint obi )
+ {
+ int c;
+ real_bigint bi = (real_bigint) obi;
+
+ (void) fprintf( stdout, "dump %s at 0x%08x:\n", str, (unsigned int) bi );
+ (void) fprintf( stdout, " refs: %d\n", bi->refs );
+ (void) fprintf( stdout, " next: 0x%08x\n", (unsigned int) bi->next );
+ (void) fprintf( stdout, " num_comps: %d\n", bi->num_comps );
+ (void) fprintf( stdout, " max_comps: %d\n", bi->max_comps );
+ (void) fprintf( stdout, " sign: %d\n", bi->sign );
+ for ( c = bi->num_comps - 1; c >= 0; --c )
+ (void) fprintf( stdout, " comps[%d]: %11lld (0x%016llx)\n", c, (long long) bi->comps[c], (long long) bi->comps[c] );
+ (void) fprintf( stdout, " print: " );
+ bi_print( stdout, bi_copy( bi ) );
+ (void) fprintf( stdout, "\n" );
+ }
+#endif /* DUMP */
+
+
+/* Trivial square-root routine so that we don't have to link in the math lib. */
+static int
+csqrt( comp c )
+ {
+ comp r, r2, diff;
+
+ if ( c < 0 )
+ {
+ (void) fprintf( stderr, "csqrt: imaginary result\n" );
+ (void) kill( getpid(), SIGFPE );
+ }
+
+ r = c / 2;
+ for (;;)
+ {
+ r2 = c / r;
+ diff = r - r2;
+ if ( diff == 0 || diff == -1 )
+ return (int) r;
+ if ( diff == 1 )
+ return (int) r2;
+ r = ( r + r2 ) / 2;
+ }
+ }
+
+
+/* Figure out how many bits are in a number. */
+static int
+cbits( comp c )
+ {
+ int b;
+
+ for ( b = 0; c != 0; ++b )
+ c >>= 1;
+ return b;
+ }
--- /dev/null
+/* Primes up to 100000. */
+static long low_primes[] = {
+ 2, 3, 5, 7, 11, 13, 17, 19, 23,
+ 29, 31, 37, 41, 43, 47, 53, 59, 61,
+ 67, 71, 73, 79, 83, 89, 97, 101, 103,
+ 107, 109, 113, 127, 131, 137, 139, 149, 151,
+ 157, 163, 167, 173, 179, 181, 191, 193, 197,
+ 199, 211, 223, 227, 229, 233, 239, 241, 251,
+ 257, 263, 269, 271, 277, 281, 283, 293, 307,
+ 311, 313, 317, 331, 337, 347, 349, 353, 359,
+ 367, 373, 379, 383, 389, 397, 401, 409, 419,
+ 421, 431, 433, 439, 443, 449, 457, 461, 463,
+ 467, 479, 487, 491, 499, 503, 509, 521, 523,
+ 541, 547, 557, 563, 569, 571, 577, 587, 593,
+ 599, 601, 607, 613, 617, 619, 631, 641, 643,
+ 647, 653, 659, 661, 673, 677, 683, 691, 701,
+ 709, 719, 727, 733, 739, 743, 751, 757, 761,
+ 769, 773, 787, 797, 809, 811, 821, 823, 827,
+ 829, 839, 853, 857, 859, 863, 877, 881, 883,
+ 887, 907, 911, 919, 929, 937, 941, 947, 953,
+ 967, 971, 977, 983, 991, 997, 1009, 1013, 1019,
+ 1021, 1031, 1033, 1039, 1049, 1051, 1061, 1063, 1069,
+ 1087, 1091, 1093, 1097, 1103, 1109, 1117, 1123, 1129,
+ 1151, 1153, 1163, 1171, 1181, 1187, 1193, 1201, 1213,
+ 1217, 1223, 1229, 1231, 1237, 1249, 1259, 1277, 1279,
+ 1283, 1289, 1291, 1297, 1301, 1303, 1307, 1319, 1321,
+ 1327, 1361, 1367, 1373, 1381, 1399, 1409, 1423, 1427,
+ 1429, 1433, 1439, 1447, 1451, 1453, 1459, 1471, 1481,
+ 1483, 1487, 1489, 1493, 1499, 1511, 1523, 1531, 1543,
+ 1549, 1553, 1559, 1567, 1571, 1579, 1583, 1597, 1601,
+ 1607, 1609, 1613, 1619, 1621, 1627, 1637, 1657, 1663,
+ 1667, 1669, 1693, 1697, 1699, 1709, 1721, 1723, 1733,
+ 1741, 1747, 1753, 1759, 1777, 1783, 1787, 1789, 1801,
+ 1811, 1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877,
+ 1879, 1889, 1901, 1907, 1913, 1931, 1933, 1949, 1951,
+ 1973, 1979, 1987, 1993, 1997, 1999, 2003, 2011, 2017,
+ 2027, 2029, 2039, 2053, 2063, 2069, 2081, 2083, 2087,
+ 2089, 2099, 2111, 2113, 2129, 2131, 2137, 2141, 2143,
+ 2153, 2161, 2179, 2203, 2207, 2213, 2221, 2237, 2239,
+ 2243, 2251, 2267, 2269, 2273, 2281, 2287, 2293, 2297,
+ 2309, 2311, 2333, 2339, 2341, 2347, 2351, 2357, 2371,
+ 2377, 2381, 2383, 2389, 2393, 2399, 2411, 2417, 2423,
+ 2437, 2441, 2447, 2459, 2467, 2473, 2477, 2503, 2521,
+ 2531, 2539, 2543, 2549, 2551, 2557, 2579, 2591, 2593,
+ 2609, 2617, 2621, 2633, 2647, 2657, 2659, 2663, 2671,
+ 2677, 2683, 2687, 2689, 2693, 2699, 2707, 2711, 2713,
+ 2719, 2729, 2731, 2741, 2749, 2753, 2767, 2777, 2789,
+ 2791, 2797, 2801, 2803, 2819, 2833, 2837, 2843, 2851,
+ 2857, 2861, 2879, 2887, 2897, 2903, 2909, 2917, 2927,
+ 2939, 2953, 2957, 2963, 2969, 2971, 2999, 3001, 3011,
+ 3019, 3023, 3037, 3041, 3049, 3061, 3067, 3079, 3083,
+ 3089, 3109, 3119, 3121, 3137, 3163, 3167, 3169, 3181,
+ 3187, 3191, 3203, 3209, 3217, 3221, 3229, 3251, 3253,
+ 3257, 3259, 3271, 3299, 3301, 3307, 3313, 3319, 3323,
+ 3329, 3331, 3343, 3347, 3359, 3361, 3371, 3373, 3389,
+ 3391, 3407, 3413, 3433, 3449, 3457, 3461, 3463, 3467,
+ 3469, 3491, 3499, 3511, 3517, 3527, 3529, 3533, 3539,
+ 3541, 3547, 3557, 3559, 3571, 3581, 3583, 3593, 3607,
+ 3613, 3617, 3623, 3631, 3637, 3643, 3659, 3671, 3673,
+ 3677, 3691, 3697, 3701, 3709, 3719, 3727, 3733, 3739,
+ 3761, 3767, 3769, 3779, 3793, 3797, 3803, 3821, 3823,
+ 3833, 3847, 3851, 3853, 3863, 3877, 3881, 3889, 3907,
+ 3911, 3917, 3919, 3923, 3929, 3931, 3943, 3947, 3967,
+ 3989, 4001, 4003, 4007, 4013, 4019, 4021, 4027, 4049,
+ 4051, 4057, 4073, 4079, 4091, 4093, 4099, 4111, 4127,
+ 4129, 4133, 4139, 4153, 4157, 4159, 4177, 4201, 4211,
+ 4217, 4219, 4229, 4231, 4241, 4243, 4253, 4259, 4261,
+ 4271, 4273, 4283, 4289, 4297, 4327, 4337, 4339, 4349,
+ 4357, 4363, 4373, 4391, 4397, 4409, 4421, 4423, 4441,
+ 4447, 4451, 4457, 4463, 4481, 4483, 4493, 4507, 4513,
+ 4517, 4519, 4523, 4547, 4549, 4561, 4567, 4583, 4591,
+ 4597, 4603, 4621, 4637, 4639, 4643, 4649, 4651, 4657,
+ 4663, 4673, 4679, 4691, 4703, 4721, 4723, 4729, 4733,
+ 4751, 4759, 4783, 4787, 4789, 4793, 4799, 4801, 4813,
+ 4817, 4831, 4861, 4871, 4877, 4889, 4903, 4909, 4919,
+ 4931, 4933, 4937, 4943, 4951, 4957, 4967, 4969, 4973,
+ 4987, 4993, 4999, 5003, 5009, 5011, 5021, 5023, 5039,
+ 5051, 5059, 5077, 5081, 5087, 5099, 5101, 5107, 5113,
+ 5119, 5147, 5153, 5167, 5171, 5179, 5189, 5197, 5209,
+ 5227, 5231, 5233, 5237, 5261, 5273, 5279, 5281, 5297,
+ 5303, 5309, 5323, 5333, 5347, 5351, 5381, 5387, 5393,
+ 5399, 5407, 5413, 5417, 5419, 5431, 5437, 5441, 5443,
+ 5449, 5471, 5477, 5479, 5483, 5501, 5503, 5507, 5519,
+ 5521, 5527, 5531, 5557, 5563, 5569, 5573, 5581, 5591,
+ 5623, 5639, 5641, 5647, 5651, 5653, 5657, 5659, 5669,
+ 5683, 5689, 5693, 5701, 5711, 5717, 5737, 5741, 5743,
+ 5749, 5779, 5783, 5791, 5801, 5807, 5813, 5821, 5827,
+ 5839, 5843, 5849, 5851, 5857, 5861, 5867, 5869, 5879,
+ 5881, 5897, 5903, 5923, 5927, 5939, 5953, 5981, 5987,
+ 6007, 6011, 6029, 6037, 6043, 6047, 6053, 6067, 6073,
+ 6079, 6089, 6091, 6101, 6113, 6121, 6131, 6133, 6143,
+ 6151, 6163, 6173, 6197, 6199, 6203, 6211, 6217, 6221,
+ 6229, 6247, 6257, 6263, 6269, 6271, 6277, 6287, 6299,
+ 6301, 6311, 6317, 6323, 6329, 6337, 6343, 6353, 6359,
+ 6361, 6367, 6373, 6379, 6389, 6397, 6421, 6427, 6449,
+ 6451, 6469, 6473, 6481, 6491, 6521, 6529, 6547, 6551,
+ 6553, 6563, 6569, 6571, 6577, 6581, 6599, 6607, 6619,
+ 6637, 6653, 6659, 6661, 6673, 6679, 6689, 6691, 6701,
+ 6703, 6709, 6719, 6733, 6737, 6761, 6763, 6779, 6781,
+ 6791, 6793, 6803, 6823, 6827, 6829, 6833, 6841, 6857,
+ 6863, 6869, 6871, 6883, 6899, 6907, 6911, 6917, 6947,
+ 6949, 6959, 6961, 6967, 6971, 6977, 6983, 6991, 6997,
+ 7001, 7013, 7019, 7027, 7039, 7043, 7057, 7069, 7079,
+ 7103, 7109, 7121, 7127, 7129, 7151, 7159, 7177, 7187,
+ 7193, 7207, 7211, 7213, 7219, 7229, 7237, 7243, 7247,
+ 7253, 7283, 7297, 7307, 7309, 7321, 7331, 7333, 7349,
+ 7351, 7369, 7393, 7411, 7417, 7433, 7451, 7457, 7459,
+ 7477, 7481, 7487, 7489, 7499, 7507, 7517, 7523, 7529,
+ 7537, 7541, 7547, 7549, 7559, 7561, 7573, 7577, 7583,
+ 7589, 7591, 7603, 7607, 7621, 7639, 7643, 7649, 7669,
+ 7673, 7681, 7687, 7691, 7699, 7703, 7717, 7723, 7727,
+ 7741, 7753, 7757, 7759, 7789, 7793, 7817, 7823, 7829,
+ 7841, 7853, 7867, 7873, 7877, 7879, 7883, 7901, 7907,
+ 7919, 7927, 7933, 7937, 7949, 7951, 7963, 7993, 8009,
+ 8011, 8017, 8039, 8053, 8059, 8069, 8081, 8087, 8089,
+ 8093, 8101, 8111, 8117, 8123, 8147, 8161, 8167, 8171,
+ 8179, 8191, 8209, 8219, 8221, 8231, 8233, 8237, 8243,
+ 8263, 8269, 8273, 8287, 8291, 8293, 8297, 8311, 8317,
+ 8329, 8353, 8363, 8369, 8377, 8387, 8389, 8419, 8423,
+ 8429, 8431, 8443, 8447, 8461, 8467, 8501, 8513, 8521,
+ 8527, 8537, 8539, 8543, 8563, 8573, 8581, 8597, 8599,
+ 8609, 8623, 8627, 8629, 8641, 8647, 8663, 8669, 8677,
+ 8681, 8689, 8693, 8699, 8707, 8713, 8719, 8731, 8737,
+ 8741, 8747, 8753, 8761, 8779, 8783, 8803, 8807, 8819,
+ 8821, 8831, 8837, 8839, 8849, 8861, 8863, 8867, 8887,
+ 8893, 8923, 8929, 8933, 8941, 8951, 8963, 8969, 8971,
+ 8999, 9001, 9007, 9011, 9013, 9029, 9041, 9043, 9049,
+ 9059, 9067, 9091, 9103, 9109, 9127, 9133, 9137, 9151,
+ 9157, 9161, 9173, 9181, 9187, 9199, 9203, 9209, 9221,
+ 9227, 9239, 9241, 9257, 9277, 9281, 9283, 9293, 9311,
+ 9319, 9323, 9337, 9341, 9343, 9349, 9371, 9377, 9391,
+ 9397, 9403, 9413, 9419, 9421, 9431, 9433, 9437, 9439,
+ 9461, 9463, 9467, 9473, 9479, 9491, 9497, 9511, 9521,
+ 9533, 9539, 9547, 9551, 9587, 9601, 9613, 9619, 9623,
+ 9629, 9631, 9643, 9649, 9661, 9677, 9679, 9689, 9697,
+ 9719, 9721, 9733, 9739, 9743, 9749, 9767, 9769, 9781,
+ 9787, 9791, 9803, 9811, 9817, 9829, 9833, 9839, 9851,
+ 9857, 9859, 9871, 9883, 9887, 9901, 9907, 9923, 9929,
+ 9931, 9941, 9949, 9967, 9973, 10007, 10009, 10037, 10039,
+ 10061, 10067, 10069, 10079, 10091, 10093, 10099, 10103, 10111,
+ 10133, 10139, 10141, 10151, 10159, 10163, 10169, 10177, 10181,
+ 10193, 10211, 10223, 10243, 10247, 10253, 10259, 10267, 10271,
+ 10273, 10289, 10301, 10303, 10313, 10321, 10331, 10333, 10337,
+ 10343, 10357, 10369, 10391, 10399, 10427, 10429, 10433, 10453,
+ 10457, 10459, 10463, 10477, 10487, 10499, 10501, 10513, 10529,
+ 10531, 10559, 10567, 10589, 10597, 10601, 10607, 10613, 10627,
+ 10631, 10639, 10651, 10657, 10663, 10667, 10687, 10691, 10709,
+ 10711, 10723, 10729, 10733, 10739, 10753, 10771, 10781, 10789,
+ 10799, 10831, 10837, 10847, 10853, 10859, 10861, 10867, 10883,
+ 10889, 10891, 10903, 10909, 10937, 10939, 10949, 10957, 10973,
+ 10979, 10987, 10993, 11003, 11027, 11047, 11057, 11059, 11069,
+ 11071, 11083, 11087, 11093, 11113, 11117, 11119, 11131, 11149,
+ 11159, 11161, 11171, 11173, 11177, 11197, 11213, 11239, 11243,
+ 11251, 11257, 11261, 11273, 11279, 11287, 11299, 11311, 11317,
+ 11321, 11329, 11351, 11353, 11369, 11383, 11393, 11399, 11411,
+ 11423, 11437, 11443, 11447, 11467, 11471, 11483, 11489, 11491,
+ 11497, 11503, 11519, 11527, 11549, 11551, 11579, 11587, 11593,
+ 11597, 11617, 11621, 11633, 11657, 11677, 11681, 11689, 11699,
+ 11701, 11717, 11719, 11731, 11743, 11777, 11779, 11783, 11789,
+ 11801, 11807, 11813, 11821, 11827, 11831, 11833, 11839, 11863,
+ 11867, 11887, 11897, 11903, 11909, 11923, 11927, 11933, 11939,
+ 11941, 11953, 11959, 11969, 11971, 11981, 11987, 12007, 12011,
+ 12037, 12041, 12043, 12049, 12071, 12073, 12097, 12101, 12107,
+ 12109, 12113, 12119, 12143, 12149, 12157, 12161, 12163, 12197,
+ 12203, 12211, 12227, 12239, 12241, 12251, 12253, 12263, 12269,
+ 12277, 12281, 12289, 12301, 12323, 12329, 12343, 12347, 12373,
+ 12377, 12379, 12391, 12401, 12409, 12413, 12421, 12433, 12437,
+ 12451, 12457, 12473, 12479, 12487, 12491, 12497, 12503, 12511,
+ 12517, 12527, 12539, 12541, 12547, 12553, 12569, 12577, 12583,
+ 12589, 12601, 12611, 12613, 12619, 12637, 12641, 12647, 12653,
+ 12659, 12671, 12689, 12697, 12703, 12713, 12721, 12739, 12743,
+ 12757, 12763, 12781, 12791, 12799, 12809, 12821, 12823, 12829,
+ 12841, 12853, 12889, 12893, 12899, 12907, 12911, 12917, 12919,
+ 12923, 12941, 12953, 12959, 12967, 12973, 12979, 12983, 13001,
+ 13003, 13007, 13009, 13033, 13037, 13043, 13049, 13063, 13093,
+ 13099, 13103, 13109, 13121, 13127, 13147, 13151, 13159, 13163,
+ 13171, 13177, 13183, 13187, 13217, 13219, 13229, 13241, 13249,
+ 13259, 13267, 13291, 13297, 13309, 13313, 13327, 13331, 13337,
+ 13339, 13367, 13381, 13397, 13399, 13411, 13417, 13421, 13441,
+ 13451, 13457, 13463, 13469, 13477, 13487, 13499, 13513, 13523,
+ 13537, 13553, 13567, 13577, 13591, 13597, 13613, 13619, 13627,
+ 13633, 13649, 13669, 13679, 13681, 13687, 13691, 13693, 13697,
+ 13709, 13711, 13721, 13723, 13729, 13751, 13757, 13759, 13763,
+ 13781, 13789, 13799, 13807, 13829, 13831, 13841, 13859, 13873,
+ 13877, 13879, 13883, 13901, 13903, 13907, 13913, 13921, 13931,
+ 13933, 13963, 13967, 13997, 13999, 14009, 14011, 14029, 14033,
+ 14051, 14057, 14071, 14081, 14083, 14087, 14107, 14143, 14149,
+ 14153, 14159, 14173, 14177, 14197, 14207, 14221, 14243, 14249,
+ 14251, 14281, 14293, 14303, 14321, 14323, 14327, 14341, 14347,
+ 14369, 14387, 14389, 14401, 14407, 14411, 14419, 14423, 14431,
+ 14437, 14447, 14449, 14461, 14479, 14489, 14503, 14519, 14533,
+ 14537, 14543, 14549, 14551, 14557, 14561, 14563, 14591, 14593,
+ 14621, 14627, 14629, 14633, 14639, 14653, 14657, 14669, 14683,
+ 14699, 14713, 14717, 14723, 14731, 14737, 14741, 14747, 14753,
+ 14759, 14767, 14771, 14779, 14783, 14797, 14813, 14821, 14827,
+ 14831, 14843, 14851, 14867, 14869, 14879, 14887, 14891, 14897,
+ 14923, 14929, 14939, 14947, 14951, 14957, 14969, 14983, 15013,
+ 15017, 15031, 15053, 15061, 15073, 15077, 15083, 15091, 15101,
+ 15107, 15121, 15131, 15137, 15139, 15149, 15161, 15173, 15187,
+ 15193, 15199, 15217, 15227, 15233, 15241, 15259, 15263, 15269,
+ 15271, 15277, 15287, 15289, 15299, 15307, 15313, 15319, 15329,
+ 15331, 15349, 15359, 15361, 15373, 15377, 15383, 15391, 15401,
+ 15413, 15427, 15439, 15443, 15451, 15461, 15467, 15473, 15493,
+ 15497, 15511, 15527, 15541, 15551, 15559, 15569, 15581, 15583,
+ 15601, 15607, 15619, 15629, 15641, 15643, 15647, 15649, 15661,
+ 15667, 15671, 15679, 15683, 15727, 15731, 15733, 15737, 15739,
+ 15749, 15761, 15767, 15773, 15787, 15791, 15797, 15803, 15809,
+ 15817, 15823, 15859, 15877, 15881, 15887, 15889, 15901, 15907,
+ 15913, 15919, 15923, 15937, 15959, 15971, 15973, 15991, 16001,
+ 16007, 16033, 16057, 16061, 16063, 16067, 16069, 16073, 16087,
+ 16091, 16097, 16103, 16111, 16127, 16139, 16141, 16183, 16187,
+ 16189, 16193, 16217, 16223, 16229, 16231, 16249, 16253, 16267,
+ 16273, 16301, 16319, 16333, 16339, 16349, 16361, 16363, 16369,
+ 16381, 16411, 16417, 16421, 16427, 16433, 16447, 16451, 16453,
+ 16477, 16481, 16487, 16493, 16519, 16529, 16547, 16553, 16561,
+ 16567, 16573, 16603, 16607, 16619, 16631, 16633, 16649, 16651,
+ 16657, 16661, 16673, 16691, 16693, 16699, 16703, 16729, 16741,
+ 16747, 16759, 16763, 16787, 16811, 16823, 16829, 16831, 16843,
+ 16871, 16879, 16883, 16889, 16901, 16903, 16921, 16927, 16931,
+ 16937, 16943, 16963, 16979, 16981, 16987, 16993, 17011, 17021,
+ 17027, 17029, 17033, 17041, 17047, 17053, 17077, 17093, 17099,
+ 17107, 17117, 17123, 17137, 17159, 17167, 17183, 17189, 17191,
+ 17203, 17207, 17209, 17231, 17239, 17257, 17291, 17293, 17299,
+ 17317, 17321, 17327, 17333, 17341, 17351, 17359, 17377, 17383,
+ 17387, 17389, 17393, 17401, 17417, 17419, 17431, 17443, 17449,
+ 17467, 17471, 17477, 17483, 17489, 17491, 17497, 17509, 17519,
+ 17539, 17551, 17569, 17573, 17579, 17581, 17597, 17599, 17609,
+ 17623, 17627, 17657, 17659, 17669, 17681, 17683, 17707, 17713,
+ 17729, 17737, 17747, 17749, 17761, 17783, 17789, 17791, 17807,
+ 17827, 17837, 17839, 17851, 17863, 17881, 17891, 17903, 17909,
+ 17911, 17921, 17923, 17929, 17939, 17957, 17959, 17971, 17977,
+ 17981, 17987, 17989, 18013, 18041, 18043, 18047, 18049, 18059,
+ 18061, 18077, 18089, 18097, 18119, 18121, 18127, 18131, 18133,
+ 18143, 18149, 18169, 18181, 18191, 18199, 18211, 18217, 18223,
+ 18229, 18233, 18251, 18253, 18257, 18269, 18287, 18289, 18301,
+ 18307, 18311, 18313, 18329, 18341, 18353, 18367, 18371, 18379,
+ 18397, 18401, 18413, 18427, 18433, 18439, 18443, 18451, 18457,
+ 18461, 18481, 18493, 18503, 18517, 18521, 18523, 18539, 18541,
+ 18553, 18583, 18587, 18593, 18617, 18637, 18661, 18671, 18679,
+ 18691, 18701, 18713, 18719, 18731, 18743, 18749, 18757, 18773,
+ 18787, 18793, 18797, 18803, 18839, 18859, 18869, 18899, 18911,
+ 18913, 18917, 18919, 18947, 18959, 18973, 18979, 19001, 19009,
+ 19013, 19031, 19037, 19051, 19069, 19073, 19079, 19081, 19087,
+ 19121, 19139, 19141, 19157, 19163, 19181, 19183, 19207, 19211,
+ 19213, 19219, 19231, 19237, 19249, 19259, 19267, 19273, 19289,
+ 19301, 19309, 19319, 19333, 19373, 19379, 19381, 19387, 19391,
+ 19403, 19417, 19421, 19423, 19427, 19429, 19433, 19441, 19447,
+ 19457, 19463, 19469, 19471, 19477, 19483, 19489, 19501, 19507,
+ 19531, 19541, 19543, 19553, 19559, 19571, 19577, 19583, 19597,
+ 19603, 19609, 19661, 19681, 19687, 19697, 19699, 19709, 19717,
+ 19727, 19739, 19751, 19753, 19759, 19763, 19777, 19793, 19801,
+ 19813, 19819, 19841, 19843, 19853, 19861, 19867, 19889, 19891,
+ 19913, 19919, 19927, 19937, 19949, 19961, 19963, 19973, 19979,
+ 19991, 19993, 19997, 20011, 20021, 20023, 20029, 20047, 20051,
+ 20063, 20071, 20089, 20101, 20107, 20113, 20117, 20123, 20129,
+ 20143, 20147, 20149, 20161, 20173, 20177, 20183, 20201, 20219,
+ 20231, 20233, 20249, 20261, 20269, 20287, 20297, 20323, 20327,
+ 20333, 20341, 20347, 20353, 20357, 20359, 20369, 20389, 20393,
+ 20399, 20407, 20411, 20431, 20441, 20443, 20477, 20479, 20483,
+ 20507, 20509, 20521, 20533, 20543, 20549, 20551, 20563, 20593,
+ 20599, 20611, 20627, 20639, 20641, 20663, 20681, 20693, 20707,
+ 20717, 20719, 20731, 20743, 20747, 20749, 20753, 20759, 20771,
+ 20773, 20789, 20807, 20809, 20849, 20857, 20873, 20879, 20887,
+ 20897, 20899, 20903, 20921, 20929, 20939, 20947, 20959, 20963,
+ 20981, 20983, 21001, 21011, 21013, 21017, 21019, 21023, 21031,
+ 21059, 21061, 21067, 21089, 21101, 21107, 21121, 21139, 21143,
+ 21149, 21157, 21163, 21169, 21179, 21187, 21191, 21193, 21211,
+ 21221, 21227, 21247, 21269, 21277, 21283, 21313, 21317, 21319,
+ 21323, 21341, 21347, 21377, 21379, 21383, 21391, 21397, 21401,
+ 21407, 21419, 21433, 21467, 21481, 21487, 21491, 21493, 21499,
+ 21503, 21517, 21521, 21523, 21529, 21557, 21559, 21563, 21569,
+ 21577, 21587, 21589, 21599, 21601, 21611, 21613, 21617, 21647,
+ 21649, 21661, 21673, 21683, 21701, 21713, 21727, 21737, 21739,
+ 21751, 21757, 21767, 21773, 21787, 21799, 21803, 21817, 21821,
+ 21839, 21841, 21851, 21859, 21863, 21871, 21881, 21893, 21911,
+ 21929, 21937, 21943, 21961, 21977, 21991, 21997, 22003, 22013,
+ 22027, 22031, 22037, 22039, 22051, 22063, 22067, 22073, 22079,
+ 22091, 22093, 22109, 22111, 22123, 22129, 22133, 22147, 22153,
+ 22157, 22159, 22171, 22189, 22193, 22229, 22247, 22259, 22271,
+ 22273, 22277, 22279, 22283, 22291, 22303, 22307, 22343, 22349,
+ 22367, 22369, 22381, 22391, 22397, 22409, 22433, 22441, 22447,
+ 22453, 22469, 22481, 22483, 22501, 22511, 22531, 22541, 22543,
+ 22549, 22567, 22571, 22573, 22613, 22619, 22621, 22637, 22639,
+ 22643, 22651, 22669, 22679, 22691, 22697, 22699, 22709, 22717,
+ 22721, 22727, 22739, 22741, 22751, 22769, 22777, 22783, 22787,
+ 22807, 22811, 22817, 22853, 22859, 22861, 22871, 22877, 22901,
+ 22907, 22921, 22937, 22943, 22961, 22963, 22973, 22993, 23003,
+ 23011, 23017, 23021, 23027, 23029, 23039, 23041, 23053, 23057,
+ 23059, 23063, 23071, 23081, 23087, 23099, 23117, 23131, 23143,
+ 23159, 23167, 23173, 23189, 23197, 23201, 23203, 23209, 23227,
+ 23251, 23269, 23279, 23291, 23293, 23297, 23311, 23321, 23327,
+ 23333, 23339, 23357, 23369, 23371, 23399, 23417, 23431, 23447,
+ 23459, 23473, 23497, 23509, 23531, 23537, 23539, 23549, 23557,
+ 23561, 23563, 23567, 23581, 23593, 23599, 23603, 23609, 23623,
+ 23627, 23629, 23633, 23663, 23669, 23671, 23677, 23687, 23689,
+ 23719, 23741, 23743, 23747, 23753, 23761, 23767, 23773, 23789,
+ 23801, 23813, 23819, 23827, 23831, 23833, 23857, 23869, 23873,
+ 23879, 23887, 23893, 23899, 23909, 23911, 23917, 23929, 23957,
+ 23971, 23977, 23981, 23993, 24001, 24007, 24019, 24023, 24029,
+ 24043, 24049, 24061, 24071, 24077, 24083, 24091, 24097, 24103,
+ 24107, 24109, 24113, 24121, 24133, 24137, 24151, 24169, 24179,
+ 24181, 24197, 24203, 24223, 24229, 24239, 24247, 24251, 24281,
+ 24317, 24329, 24337, 24359, 24371, 24373, 24379, 24391, 24407,
+ 24413, 24419, 24421, 24439, 24443, 24469, 24473, 24481, 24499,
+ 24509, 24517, 24527, 24533, 24547, 24551, 24571, 24593, 24611,
+ 24623, 24631, 24659, 24671, 24677, 24683, 24691, 24697, 24709,
+ 24733, 24749, 24763, 24767, 24781, 24793, 24799, 24809, 24821,
+ 24841, 24847, 24851, 24859, 24877, 24889, 24907, 24917, 24919,
+ 24923, 24943, 24953, 24967, 24971, 24977, 24979, 24989, 25013,
+ 25031, 25033, 25037, 25057, 25073, 25087, 25097, 25111, 25117,
+ 25121, 25127, 25147, 25153, 25163, 25169, 25171, 25183, 25189,
+ 25219, 25229, 25237, 25243, 25247, 25253, 25261, 25301, 25303,
+ 25307, 25309, 25321, 25339, 25343, 25349, 25357, 25367, 25373,
+ 25391, 25409, 25411, 25423, 25439, 25447, 25453, 25457, 25463,
+ 25469, 25471, 25523, 25537, 25541, 25561, 25577, 25579, 25583,
+ 25589, 25601, 25603, 25609, 25621, 25633, 25639, 25643, 25657,
+ 25667, 25673, 25679, 25693, 25703, 25717, 25733, 25741, 25747,
+ 25759, 25763, 25771, 25793, 25799, 25801, 25819, 25841, 25847,
+ 25849, 25867, 25873, 25889, 25903, 25913, 25919, 25931, 25933,
+ 25939, 25943, 25951, 25969, 25981, 25997, 25999, 26003, 26017,
+ 26021, 26029, 26041, 26053, 26083, 26099, 26107, 26111, 26113,
+ 26119, 26141, 26153, 26161, 26171, 26177, 26183, 26189, 26203,
+ 26209, 26227, 26237, 26249, 26251, 26261, 26263, 26267, 26293,
+ 26297, 26309, 26317, 26321, 26339, 26347, 26357, 26371, 26387,
+ 26393, 26399, 26407, 26417, 26423, 26431, 26437, 26449, 26459,
+ 26479, 26489, 26497, 26501, 26513, 26539, 26557, 26561, 26573,
+ 26591, 26597, 26627, 26633, 26641, 26647, 26669, 26681, 26683,
+ 26687, 26693, 26699, 26701, 26711, 26713, 26717, 26723, 26729,
+ 26731, 26737, 26759, 26777, 26783, 26801, 26813, 26821, 26833,
+ 26839, 26849, 26861, 26863, 26879, 26881, 26891, 26893, 26903,
+ 26921, 26927, 26947, 26951, 26953, 26959, 26981, 26987, 26993,
+ 27011, 27017, 27031, 27043, 27059, 27061, 27067, 27073, 27077,
+ 27091, 27103, 27107, 27109, 27127, 27143, 27179, 27191, 27197,
+ 27211, 27239, 27241, 27253, 27259, 27271, 27277, 27281, 27283,
+ 27299, 27329, 27337, 27361, 27367, 27397, 27407, 27409, 27427,
+ 27431, 27437, 27449, 27457, 27479, 27481, 27487, 27509, 27527,
+ 27529, 27539, 27541, 27551, 27581, 27583, 27611, 27617, 27631,
+ 27647, 27653, 27673, 27689, 27691, 27697, 27701, 27733, 27737,
+ 27739, 27743, 27749, 27751, 27763, 27767, 27773, 27779, 27791,
+ 27793, 27799, 27803, 27809, 27817, 27823, 27827, 27847, 27851,
+ 27883, 27893, 27901, 27917, 27919, 27941, 27943, 27947, 27953,
+ 27961, 27967, 27983, 27997, 28001, 28019, 28027, 28031, 28051,
+ 28057, 28069, 28081, 28087, 28097, 28099, 28109, 28111, 28123,
+ 28151, 28163, 28181, 28183, 28201, 28211, 28219, 28229, 28277,
+ 28279, 28283, 28289, 28297, 28307, 28309, 28319, 28349, 28351,
+ 28387, 28393, 28403, 28409, 28411, 28429, 28433, 28439, 28447,
+ 28463, 28477, 28493, 28499, 28513, 28517, 28537, 28541, 28547,
+ 28549, 28559, 28571, 28573, 28579, 28591, 28597, 28603, 28607,
+ 28619, 28621, 28627, 28631, 28643, 28649, 28657, 28661, 28663,
+ 28669, 28687, 28697, 28703, 28711, 28723, 28729, 28751, 28753,
+ 28759, 28771, 28789, 28793, 28807, 28813, 28817, 28837, 28843,
+ 28859, 28867, 28871, 28879, 28901, 28909, 28921, 28927, 28933,
+ 28949, 28961, 28979, 29009, 29017, 29021, 29023, 29027, 29033,
+ 29059, 29063, 29077, 29101, 29123, 29129, 29131, 29137, 29147,
+ 29153, 29167, 29173, 29179, 29191, 29201, 29207, 29209, 29221,
+ 29231, 29243, 29251, 29269, 29287, 29297, 29303, 29311, 29327,
+ 29333, 29339, 29347, 29363, 29383, 29387, 29389, 29399, 29401,
+ 29411, 29423, 29429, 29437, 29443, 29453, 29473, 29483, 29501,
+ 29527, 29531, 29537, 29567, 29569, 29573, 29581, 29587, 29599,
+ 29611, 29629, 29633, 29641, 29663, 29669, 29671, 29683, 29717,
+ 29723, 29741, 29753, 29759, 29761, 29789, 29803, 29819, 29833,
+ 29837, 29851, 29863, 29867, 29873, 29879, 29881, 29917, 29921,
+ 29927, 29947, 29959, 29983, 29989, 30011, 30013, 30029, 30047,
+ 30059, 30071, 30089, 30091, 30097, 30103, 30109, 30113, 30119,
+ 30133, 30137, 30139, 30161, 30169, 30181, 30187, 30197, 30203,
+ 30211, 30223, 30241, 30253, 30259, 30269, 30271, 30293, 30307,
+ 30313, 30319, 30323, 30341, 30347, 30367, 30389, 30391, 30403,
+ 30427, 30431, 30449, 30467, 30469, 30491, 30493, 30497, 30509,
+ 30517, 30529, 30539, 30553, 30557, 30559, 30577, 30593, 30631,
+ 30637, 30643, 30649, 30661, 30671, 30677, 30689, 30697, 30703,
+ 30707, 30713, 30727, 30757, 30763, 30773, 30781, 30803, 30809,
+ 30817, 30829, 30839, 30841, 30851, 30853, 30859, 30869, 30871,
+ 30881, 30893, 30911, 30931, 30937, 30941, 30949, 30971, 30977,
+ 30983, 31013, 31019, 31033, 31039, 31051, 31063, 31069, 31079,
+ 31081, 31091, 31121, 31123, 31139, 31147, 31151, 31153, 31159,
+ 31177, 31181, 31183, 31189, 31193, 31219, 31223, 31231, 31237,
+ 31247, 31249, 31253, 31259, 31267, 31271, 31277, 31307, 31319,
+ 31321, 31327, 31333, 31337, 31357, 31379, 31387, 31391, 31393,
+ 31397, 31469, 31477, 31481, 31489, 31511, 31513, 31517, 31531,
+ 31541, 31543, 31547, 31567, 31573, 31583, 31601, 31607, 31627,
+ 31643, 31649, 31657, 31663, 31667, 31687, 31699, 31721, 31723,
+ 31727, 31729, 31741, 31751, 31769, 31771, 31793, 31799, 31817,
+ 31847, 31849, 31859, 31873, 31883, 31891, 31907, 31957, 31963,
+ 31973, 31981, 31991, 32003, 32009, 32027, 32029, 32051, 32057,
+ 32059, 32063, 32069, 32077, 32083, 32089, 32099, 32117, 32119,
+ 32141, 32143, 32159, 32173, 32183, 32189, 32191, 32203, 32213,
+ 32233, 32237, 32251, 32257, 32261, 32297, 32299, 32303, 32309,
+ 32321, 32323, 32327, 32341, 32353, 32359, 32363, 32369, 32371,
+ 32377, 32381, 32401, 32411, 32413, 32423, 32429, 32441, 32443,
+ 32467, 32479, 32491, 32497, 32503, 32507, 32531, 32533, 32537,
+ 32561, 32563, 32569, 32573, 32579, 32587, 32603, 32609, 32611,
+ 32621, 32633, 32647, 32653, 32687, 32693, 32707, 32713, 32717,
+ 32719, 32749, 32771, 32779, 32783, 32789, 32797, 32801, 32803,
+ 32831, 32833, 32839, 32843, 32869, 32887, 32909, 32911, 32917,
+ 32933, 32939, 32941, 32957, 32969, 32971, 32983, 32987, 32993,
+ 32999, 33013, 33023, 33029, 33037, 33049, 33053, 33071, 33073,
+ 33083, 33091, 33107, 33113, 33119, 33149, 33151, 33161, 33179,
+ 33181, 33191, 33199, 33203, 33211, 33223, 33247, 33287, 33289,
+ 33301, 33311, 33317, 33329, 33331, 33343, 33347, 33349, 33353,
+ 33359, 33377, 33391, 33403, 33409, 33413, 33427, 33457, 33461,
+ 33469, 33479, 33487, 33493, 33503, 33521, 33529, 33533, 33547,
+ 33563, 33569, 33577, 33581, 33587, 33589, 33599, 33601, 33613,
+ 33617, 33619, 33623, 33629, 33637, 33641, 33647, 33679, 33703,
+ 33713, 33721, 33739, 33749, 33751, 33757, 33767, 33769, 33773,
+ 33791, 33797, 33809, 33811, 33827, 33829, 33851, 33857, 33863,
+ 33871, 33889, 33893, 33911, 33923, 33931, 33937, 33941, 33961,
+ 33967, 33997, 34019, 34031, 34033, 34039, 34057, 34061, 34123,
+ 34127, 34129, 34141, 34147, 34157, 34159, 34171, 34183, 34211,
+ 34213, 34217, 34231, 34253, 34259, 34261, 34267, 34273, 34283,
+ 34297, 34301, 34303, 34313, 34319, 34327, 34337, 34351, 34361,
+ 34367, 34369, 34381, 34403, 34421, 34429, 34439, 34457, 34469,
+ 34471, 34483, 34487, 34499, 34501, 34511, 34513, 34519, 34537,
+ 34543, 34549, 34583, 34589, 34591, 34603, 34607, 34613, 34631,
+ 34649, 34651, 34667, 34673, 34679, 34687, 34693, 34703, 34721,
+ 34729, 34739, 34747, 34757, 34759, 34763, 34781, 34807, 34819,
+ 34841, 34843, 34847, 34849, 34871, 34877, 34883, 34897, 34913,
+ 34919, 34939, 34949, 34961, 34963, 34981, 35023, 35027, 35051,
+ 35053, 35059, 35069, 35081, 35083, 35089, 35099, 35107, 35111,
+ 35117, 35129, 35141, 35149, 35153, 35159, 35171, 35201, 35221,
+ 35227, 35251, 35257, 35267, 35279, 35281, 35291, 35311, 35317,
+ 35323, 35327, 35339, 35353, 35363, 35381, 35393, 35401, 35407,
+ 35419, 35423, 35437, 35447, 35449, 35461, 35491, 35507, 35509,
+ 35521, 35527, 35531, 35533, 35537, 35543, 35569, 35573, 35591,
+ 35593, 35597, 35603, 35617, 35671, 35677, 35729, 35731, 35747,
+ 35753, 35759, 35771, 35797, 35801, 35803, 35809, 35831, 35837,
+ 35839, 35851, 35863, 35869, 35879, 35897, 35899, 35911, 35923,
+ 35933, 35951, 35963, 35969, 35977, 35983, 35993, 35999, 36007,
+ 36011, 36013, 36017, 36037, 36061, 36067, 36073, 36083, 36097,
+ 36107, 36109, 36131, 36137, 36151, 36161, 36187, 36191, 36209,
+ 36217, 36229, 36241, 36251, 36263, 36269, 36277, 36293, 36299,
+ 36307, 36313, 36319, 36341, 36343, 36353, 36373, 36383, 36389,
+ 36433, 36451, 36457, 36467, 36469, 36473, 36479, 36493, 36497,
+ 36523, 36527, 36529, 36541, 36551, 36559, 36563, 36571, 36583,
+ 36587, 36599, 36607, 36629, 36637, 36643, 36653, 36671, 36677,
+ 36683, 36691, 36697, 36709, 36713, 36721, 36739, 36749, 36761,
+ 36767, 36779, 36781, 36787, 36791, 36793, 36809, 36821, 36833,
+ 36847, 36857, 36871, 36877, 36887, 36899, 36901, 36913, 36919,
+ 36923, 36929, 36931, 36943, 36947, 36973, 36979, 36997, 37003,
+ 37013, 37019, 37021, 37039, 37049, 37057, 37061, 37087, 37097,
+ 37117, 37123, 37139, 37159, 37171, 37181, 37189, 37199, 37201,
+ 37217, 37223, 37243, 37253, 37273, 37277, 37307, 37309, 37313,
+ 37321, 37337, 37339, 37357, 37361, 37363, 37369, 37379, 37397,
+ 37409, 37423, 37441, 37447, 37463, 37483, 37489, 37493, 37501,
+ 37507, 37511, 37517, 37529, 37537, 37547, 37549, 37561, 37567,
+ 37571, 37573, 37579, 37589, 37591, 37607, 37619, 37633, 37643,
+ 37649, 37657, 37663, 37691, 37693, 37699, 37717, 37747, 37781,
+ 37783, 37799, 37811, 37813, 37831, 37847, 37853, 37861, 37871,
+ 37879, 37889, 37897, 37907, 37951, 37957, 37963, 37967, 37987,
+ 37991, 37993, 37997, 38011, 38039, 38047, 38053, 38069, 38083,
+ 38113, 38119, 38149, 38153, 38167, 38177, 38183, 38189, 38197,
+ 38201, 38219, 38231, 38237, 38239, 38261, 38273, 38281, 38287,
+ 38299, 38303, 38317, 38321, 38327, 38329, 38333, 38351, 38371,
+ 38377, 38393, 38431, 38447, 38449, 38453, 38459, 38461, 38501,
+ 38543, 38557, 38561, 38567, 38569, 38593, 38603, 38609, 38611,
+ 38629, 38639, 38651, 38653, 38669, 38671, 38677, 38693, 38699,
+ 38707, 38711, 38713, 38723, 38729, 38737, 38747, 38749, 38767,
+ 38783, 38791, 38803, 38821, 38833, 38839, 38851, 38861, 38867,
+ 38873, 38891, 38903, 38917, 38921, 38923, 38933, 38953, 38959,
+ 38971, 38977, 38993, 39019, 39023, 39041, 39043, 39047, 39079,
+ 39089, 39097, 39103, 39107, 39113, 39119, 39133, 39139, 39157,
+ 39161, 39163, 39181, 39191, 39199, 39209, 39217, 39227, 39229,
+ 39233, 39239, 39241, 39251, 39293, 39301, 39313, 39317, 39323,
+ 39341, 39343, 39359, 39367, 39371, 39373, 39383, 39397, 39409,
+ 39419, 39439, 39443, 39451, 39461, 39499, 39503, 39509, 39511,
+ 39521, 39541, 39551, 39563, 39569, 39581, 39607, 39619, 39623,
+ 39631, 39659, 39667, 39671, 39679, 39703, 39709, 39719, 39727,
+ 39733, 39749, 39761, 39769, 39779, 39791, 39799, 39821, 39827,
+ 39829, 39839, 39841, 39847, 39857, 39863, 39869, 39877, 39883,
+ 39887, 39901, 39929, 39937, 39953, 39971, 39979, 39983, 39989,
+ 40009, 40013, 40031, 40037, 40039, 40063, 40087, 40093, 40099,
+ 40111, 40123, 40127, 40129, 40151, 40153, 40163, 40169, 40177,
+ 40189, 40193, 40213, 40231, 40237, 40241, 40253, 40277, 40283,
+ 40289, 40343, 40351, 40357, 40361, 40387, 40423, 40427, 40429,
+ 40433, 40459, 40471, 40483, 40487, 40493, 40499, 40507, 40519,
+ 40529, 40531, 40543, 40559, 40577, 40583, 40591, 40597, 40609,
+ 40627, 40637, 40639, 40693, 40697, 40699, 40709, 40739, 40751,
+ 40759, 40763, 40771, 40787, 40801, 40813, 40819, 40823, 40829,
+ 40841, 40847, 40849, 40853, 40867, 40879, 40883, 40897, 40903,
+ 40927, 40933, 40939, 40949, 40961, 40973, 40993, 41011, 41017,
+ 41023, 41039, 41047, 41051, 41057, 41077, 41081, 41113, 41117,
+ 41131, 41141, 41143, 41149, 41161, 41177, 41179, 41183, 41189,
+ 41201, 41203, 41213, 41221, 41227, 41231, 41233, 41243, 41257,
+ 41263, 41269, 41281, 41299, 41333, 41341, 41351, 41357, 41381,
+ 41387, 41389, 41399, 41411, 41413, 41443, 41453, 41467, 41479,
+ 41491, 41507, 41513, 41519, 41521, 41539, 41543, 41549, 41579,
+ 41593, 41597, 41603, 41609, 41611, 41617, 41621, 41627, 41641,
+ 41647, 41651, 41659, 41669, 41681, 41687, 41719, 41729, 41737,
+ 41759, 41761, 41771, 41777, 41801, 41809, 41813, 41843, 41849,
+ 41851, 41863, 41879, 41887, 41893, 41897, 41903, 41911, 41927,
+ 41941, 41947, 41953, 41957, 41959, 41969, 41981, 41983, 41999,
+ 42013, 42017, 42019, 42023, 42043, 42061, 42071, 42073, 42083,
+ 42089, 42101, 42131, 42139, 42157, 42169, 42179, 42181, 42187,
+ 42193, 42197, 42209, 42221, 42223, 42227, 42239, 42257, 42281,
+ 42283, 42293, 42299, 42307, 42323, 42331, 42337, 42349, 42359,
+ 42373, 42379, 42391, 42397, 42403, 42407, 42409, 42433, 42437,
+ 42443, 42451, 42457, 42461, 42463, 42467, 42473, 42487, 42491,
+ 42499, 42509, 42533, 42557, 42569, 42571, 42577, 42589, 42611,
+ 42641, 42643, 42649, 42667, 42677, 42683, 42689, 42697, 42701,
+ 42703, 42709, 42719, 42727, 42737, 42743, 42751, 42767, 42773,
+ 42787, 42793, 42797, 42821, 42829, 42839, 42841, 42853, 42859,
+ 42863, 42899, 42901, 42923, 42929, 42937, 42943, 42953, 42961,
+ 42967, 42979, 42989, 43003, 43013, 43019, 43037, 43049, 43051,
+ 43063, 43067, 43093, 43103, 43117, 43133, 43151, 43159, 43177,
+ 43189, 43201, 43207, 43223, 43237, 43261, 43271, 43283, 43291,
+ 43313, 43319, 43321, 43331, 43391, 43397, 43399, 43403, 43411,
+ 43427, 43441, 43451, 43457, 43481, 43487, 43499, 43517, 43541,
+ 43543, 43573, 43577, 43579, 43591, 43597, 43607, 43609, 43613,
+ 43627, 43633, 43649, 43651, 43661, 43669, 43691, 43711, 43717,
+ 43721, 43753, 43759, 43777, 43781, 43783, 43787, 43789, 43793,
+ 43801, 43853, 43867, 43889, 43891, 43913, 43933, 43943, 43951,
+ 43961, 43963, 43969, 43973, 43987, 43991, 43997, 44017, 44021,
+ 44027, 44029, 44041, 44053, 44059, 44071, 44087, 44089, 44101,
+ 44111, 44119, 44123, 44129, 44131, 44159, 44171, 44179, 44189,
+ 44201, 44203, 44207, 44221, 44249, 44257, 44263, 44267, 44269,
+ 44273, 44279, 44281, 44293, 44351, 44357, 44371, 44381, 44383,
+ 44389, 44417, 44449, 44453, 44483, 44491, 44497, 44501, 44507,
+ 44519, 44531, 44533, 44537, 44543, 44549, 44563, 44579, 44587,
+ 44617, 44621, 44623, 44633, 44641, 44647, 44651, 44657, 44683,
+ 44687, 44699, 44701, 44711, 44729, 44741, 44753, 44771, 44773,
+ 44777, 44789, 44797, 44809, 44819, 44839, 44843, 44851, 44867,
+ 44879, 44887, 44893, 44909, 44917, 44927, 44939, 44953, 44959,
+ 44963, 44971, 44983, 44987, 45007, 45013, 45053, 45061, 45077,
+ 45083, 45119, 45121, 45127, 45131, 45137, 45139, 45161, 45179,
+ 45181, 45191, 45197, 45233, 45247, 45259, 45263, 45281, 45289,
+ 45293, 45307, 45317, 45319, 45329, 45337, 45341, 45343, 45361,
+ 45377, 45389, 45403, 45413, 45427, 45433, 45439, 45481, 45491,
+ 45497, 45503, 45523, 45533, 45541, 45553, 45557, 45569, 45587,
+ 45589, 45599, 45613, 45631, 45641, 45659, 45667, 45673, 45677,
+ 45691, 45697, 45707, 45737, 45751, 45757, 45763, 45767, 45779,
+ 45817, 45821, 45823, 45827, 45833, 45841, 45853, 45863, 45869,
+ 45887, 45893, 45943, 45949, 45953, 45959, 45971, 45979, 45989,
+ 46021, 46027, 46049, 46051, 46061, 46073, 46091, 46093, 46099,
+ 46103, 46133, 46141, 46147, 46153, 46171, 46181, 46183, 46187,
+ 46199, 46219, 46229, 46237, 46261, 46271, 46273, 46279, 46301,
+ 46307, 46309, 46327, 46337, 46349, 46351, 46381, 46399, 46411,
+ 46439, 46441, 46447, 46451, 46457, 46471, 46477, 46489, 46499,
+ 46507, 46511, 46523, 46549, 46559, 46567, 46573, 46589, 46591,
+ 46601, 46619, 46633, 46639, 46643, 46649, 46663, 46679, 46681,
+ 46687, 46691, 46703, 46723, 46727, 46747, 46751, 46757, 46769,
+ 46771, 46807, 46811, 46817, 46819, 46829, 46831, 46853, 46861,
+ 46867, 46877, 46889, 46901, 46919, 46933, 46957, 46993, 46997,
+ 47017, 47041, 47051, 47057, 47059, 47087, 47093, 47111, 47119,
+ 47123, 47129, 47137, 47143, 47147, 47149, 47161, 47189, 47207,
+ 47221, 47237, 47251, 47269, 47279, 47287, 47293, 47297, 47303,
+ 47309, 47317, 47339, 47351, 47353, 47363, 47381, 47387, 47389,
+ 47407, 47417, 47419, 47431, 47441, 47459, 47491, 47497, 47501,
+ 47507, 47513, 47521, 47527, 47533, 47543, 47563, 47569, 47581,
+ 47591, 47599, 47609, 47623, 47629, 47639, 47653, 47657, 47659,
+ 47681, 47699, 47701, 47711, 47713, 47717, 47737, 47741, 47743,
+ 47777, 47779, 47791, 47797, 47807, 47809, 47819, 47837, 47843,
+ 47857, 47869, 47881, 47903, 47911, 47917, 47933, 47939, 47947,
+ 47951, 47963, 47969, 47977, 47981, 48017, 48023, 48029, 48049,
+ 48073, 48079, 48091, 48109, 48119, 48121, 48131, 48157, 48163,
+ 48179, 48187, 48193, 48197, 48221, 48239, 48247, 48259, 48271,
+ 48281, 48299, 48311, 48313, 48337, 48341, 48353, 48371, 48383,
+ 48397, 48407, 48409, 48413, 48437, 48449, 48463, 48473, 48479,
+ 48481, 48487, 48491, 48497, 48523, 48527, 48533, 48539, 48541,
+ 48563, 48571, 48589, 48593, 48611, 48619, 48623, 48647, 48649,
+ 48661, 48673, 48677, 48679, 48731, 48733, 48751, 48757, 48761,
+ 48767, 48779, 48781, 48787, 48799, 48809, 48817, 48821, 48823,
+ 48847, 48857, 48859, 48869, 48871, 48883, 48889, 48907, 48947,
+ 48953, 48973, 48989, 48991, 49003, 49009, 49019, 49031, 49033,
+ 49037, 49043, 49057, 49069, 49081, 49103, 49109, 49117, 49121,
+ 49123, 49139, 49157, 49169, 49171, 49177, 49193, 49199, 49201,
+ 49207, 49211, 49223, 49253, 49261, 49277, 49279, 49297, 49307,
+ 49331, 49333, 49339, 49363, 49367, 49369, 49391, 49393, 49409,
+ 49411, 49417, 49429, 49433, 49451, 49459, 49463, 49477, 49481,
+ 49499, 49523, 49529, 49531, 49537, 49547, 49549, 49559, 49597,
+ 49603, 49613, 49627, 49633, 49639, 49663, 49667, 49669, 49681,
+ 49697, 49711, 49727, 49739, 49741, 49747, 49757, 49783, 49787,
+ 49789, 49801, 49807, 49811, 49823, 49831, 49843, 49853, 49871,
+ 49877, 49891, 49919, 49921, 49927, 49937, 49939, 49943, 49957,
+ 49991, 49993, 49999, 50021, 50023, 50033, 50047, 50051, 50053,
+ 50069, 50077, 50087, 50093, 50101, 50111, 50119, 50123, 50129,
+ 50131, 50147, 50153, 50159, 50177, 50207, 50221, 50227, 50231,
+ 50261, 50263, 50273, 50287, 50291, 50311, 50321, 50329, 50333,
+ 50341, 50359, 50363, 50377, 50383, 50387, 50411, 50417, 50423,
+ 50441, 50459, 50461, 50497, 50503, 50513, 50527, 50539, 50543,
+ 50549, 50551, 50581, 50587, 50591, 50593, 50599, 50627, 50647,
+ 50651, 50671, 50683, 50707, 50723, 50741, 50753, 50767, 50773,
+ 50777, 50789, 50821, 50833, 50839, 50849, 50857, 50867, 50873,
+ 50891, 50893, 50909, 50923, 50929, 50951, 50957, 50969, 50971,
+ 50989, 50993, 51001, 51031, 51043, 51047, 51059, 51061, 51071,
+ 51109, 51131, 51133, 51137, 51151, 51157, 51169, 51193, 51197,
+ 51199, 51203, 51217, 51229, 51239, 51241, 51257, 51263, 51283,
+ 51287, 51307, 51329, 51341, 51343, 51347, 51349, 51361, 51383,
+ 51407, 51413, 51419, 51421, 51427, 51431, 51437, 51439, 51449,
+ 51461, 51473, 51479, 51481, 51487, 51503, 51511, 51517, 51521,
+ 51539, 51551, 51563, 51577, 51581, 51593, 51599, 51607, 51613,
+ 51631, 51637, 51647, 51659, 51673, 51679, 51683, 51691, 51713,
+ 51719, 51721, 51749, 51767, 51769, 51787, 51797, 51803, 51817,
+ 51827, 51829, 51839, 51853, 51859, 51869, 51871, 51893, 51899,
+ 51907, 51913, 51929, 51941, 51949, 51971, 51973, 51977, 51991,
+ 52009, 52021, 52027, 52051, 52057, 52067, 52069, 52081, 52103,
+ 52121, 52127, 52147, 52153, 52163, 52177, 52181, 52183, 52189,
+ 52201, 52223, 52237, 52249, 52253, 52259, 52267, 52289, 52291,
+ 52301, 52313, 52321, 52361, 52363, 52369, 52379, 52387, 52391,
+ 52433, 52453, 52457, 52489, 52501, 52511, 52517, 52529, 52541,
+ 52543, 52553, 52561, 52567, 52571, 52579, 52583, 52609, 52627,
+ 52631, 52639, 52667, 52673, 52691, 52697, 52709, 52711, 52721,
+ 52727, 52733, 52747, 52757, 52769, 52783, 52807, 52813, 52817,
+ 52837, 52859, 52861, 52879, 52883, 52889, 52901, 52903, 52919,
+ 52937, 52951, 52957, 52963, 52967, 52973, 52981, 52999, 53003,
+ 53017, 53047, 53051, 53069, 53077, 53087, 53089, 53093, 53101,
+ 53113, 53117, 53129, 53147, 53149, 53161, 53171, 53173, 53189,
+ 53197, 53201, 53231, 53233, 53239, 53267, 53269, 53279, 53281,
+ 53299, 53309, 53323, 53327, 53353, 53359, 53377, 53381, 53401,
+ 53407, 53411, 53419, 53437, 53441, 53453, 53479, 53503, 53507,
+ 53527, 53549, 53551, 53569, 53591, 53593, 53597, 53609, 53611,
+ 53617, 53623, 53629, 53633, 53639, 53653, 53657, 53681, 53693,
+ 53699, 53717, 53719, 53731, 53759, 53773, 53777, 53783, 53791,
+ 53813, 53819, 53831, 53849, 53857, 53861, 53881, 53887, 53891,
+ 53897, 53899, 53917, 53923, 53927, 53939, 53951, 53959, 53987,
+ 53993, 54001, 54011, 54013, 54037, 54049, 54059, 54083, 54091,
+ 54101, 54121, 54133, 54139, 54151, 54163, 54167, 54181, 54193,
+ 54217, 54251, 54269, 54277, 54287, 54293, 54311, 54319, 54323,
+ 54331, 54347, 54361, 54367, 54371, 54377, 54401, 54403, 54409,
+ 54413, 54419, 54421, 54437, 54443, 54449, 54469, 54493, 54497,
+ 54499, 54503, 54517, 54521, 54539, 54541, 54547, 54559, 54563,
+ 54577, 54581, 54583, 54601, 54617, 54623, 54629, 54631, 54647,
+ 54667, 54673, 54679, 54709, 54713, 54721, 54727, 54751, 54767,
+ 54773, 54779, 54787, 54799, 54829, 54833, 54851, 54869, 54877,
+ 54881, 54907, 54917, 54919, 54941, 54949, 54959, 54973, 54979,
+ 54983, 55001, 55009, 55021, 55049, 55051, 55057, 55061, 55073,
+ 55079, 55103, 55109, 55117, 55127, 55147, 55163, 55171, 55201,
+ 55207, 55213, 55217, 55219, 55229, 55243, 55249, 55259, 55291,
+ 55313, 55331, 55333, 55337, 55339, 55343, 55351, 55373, 55381,
+ 55399, 55411, 55439, 55441, 55457, 55469, 55487, 55501, 55511,
+ 55529, 55541, 55547, 55579, 55589, 55603, 55609, 55619, 55621,
+ 55631, 55633, 55639, 55661, 55663, 55667, 55673, 55681, 55691,
+ 55697, 55711, 55717, 55721, 55733, 55763, 55787, 55793, 55799,
+ 55807, 55813, 55817, 55819, 55823, 55829, 55837, 55843, 55849,
+ 55871, 55889, 55897, 55901, 55903, 55921, 55927, 55931, 55933,
+ 55949, 55967, 55987, 55997, 56003, 56009, 56039, 56041, 56053,
+ 56081, 56087, 56093, 56099, 56101, 56113, 56123, 56131, 56149,
+ 56167, 56171, 56179, 56197, 56207, 56209, 56237, 56239, 56249,
+ 56263, 56267, 56269, 56299, 56311, 56333, 56359, 56369, 56377,
+ 56383, 56393, 56401, 56417, 56431, 56437, 56443, 56453, 56467,
+ 56473, 56477, 56479, 56489, 56501, 56503, 56509, 56519, 56527,
+ 56531, 56533, 56543, 56569, 56591, 56597, 56599, 56611, 56629,
+ 56633, 56659, 56663, 56671, 56681, 56687, 56701, 56711, 56713,
+ 56731, 56737, 56747, 56767, 56773, 56779, 56783, 56807, 56809,
+ 56813, 56821, 56827, 56843, 56857, 56873, 56891, 56893, 56897,
+ 56909, 56911, 56921, 56923, 56929, 56941, 56951, 56957, 56963,
+ 56983, 56989, 56993, 56999, 57037, 57041, 57047, 57059, 57073,
+ 57077, 57089, 57097, 57107, 57119, 57131, 57139, 57143, 57149,
+ 57163, 57173, 57179, 57191, 57193, 57203, 57221, 57223, 57241,
+ 57251, 57259, 57269, 57271, 57283, 57287, 57301, 57329, 57331,
+ 57347, 57349, 57367, 57373, 57383, 57389, 57397, 57413, 57427,
+ 57457, 57467, 57487, 57493, 57503, 57527, 57529, 57557, 57559,
+ 57571, 57587, 57593, 57601, 57637, 57641, 57649, 57653, 57667,
+ 57679, 57689, 57697, 57709, 57713, 57719, 57727, 57731, 57737,
+ 57751, 57773, 57781, 57787, 57791, 57793, 57803, 57809, 57829,
+ 57839, 57847, 57853, 57859, 57881, 57899, 57901, 57917, 57923,
+ 57943, 57947, 57973, 57977, 57991, 58013, 58027, 58031, 58043,
+ 58049, 58057, 58061, 58067, 58073, 58099, 58109, 58111, 58129,
+ 58147, 58151, 58153, 58169, 58171, 58189, 58193, 58199, 58207,
+ 58211, 58217, 58229, 58231, 58237, 58243, 58271, 58309, 58313,
+ 58321, 58337, 58363, 58367, 58369, 58379, 58391, 58393, 58403,
+ 58411, 58417, 58427, 58439, 58441, 58451, 58453, 58477, 58481,
+ 58511, 58537, 58543, 58549, 58567, 58573, 58579, 58601, 58603,
+ 58613, 58631, 58657, 58661, 58679, 58687, 58693, 58699, 58711,
+ 58727, 58733, 58741, 58757, 58763, 58771, 58787, 58789, 58831,
+ 58889, 58897, 58901, 58907, 58909, 58913, 58921, 58937, 58943,
+ 58963, 58967, 58979, 58991, 58997, 59009, 59011, 59021, 59023,
+ 59029, 59051, 59053, 59063, 59069, 59077, 59083, 59093, 59107,
+ 59113, 59119, 59123, 59141, 59149, 59159, 59167, 59183, 59197,
+ 59207, 59209, 59219, 59221, 59233, 59239, 59243, 59263, 59273,
+ 59281, 59333, 59341, 59351, 59357, 59359, 59369, 59377, 59387,
+ 59393, 59399, 59407, 59417, 59419, 59441, 59443, 59447, 59453,
+ 59467, 59471, 59473, 59497, 59509, 59513, 59539, 59557, 59561,
+ 59567, 59581, 59611, 59617, 59621, 59627, 59629, 59651, 59659,
+ 59663, 59669, 59671, 59693, 59699, 59707, 59723, 59729, 59743,
+ 59747, 59753, 59771, 59779, 59791, 59797, 59809, 59833, 59863,
+ 59879, 59887, 59921, 59929, 59951, 59957, 59971, 59981, 59999,
+ 60013, 60017, 60029, 60037, 60041, 60077, 60083, 60089, 60091,
+ 60101, 60103, 60107, 60127, 60133, 60139, 60149, 60161, 60167,
+ 60169, 60209, 60217, 60223, 60251, 60257, 60259, 60271, 60289,
+ 60293, 60317, 60331, 60337, 60343, 60353, 60373, 60383, 60397,
+ 60413, 60427, 60443, 60449, 60457, 60493, 60497, 60509, 60521,
+ 60527, 60539, 60589, 60601, 60607, 60611, 60617, 60623, 60631,
+ 60637, 60647, 60649, 60659, 60661, 60679, 60689, 60703, 60719,
+ 60727, 60733, 60737, 60757, 60761, 60763, 60773, 60779, 60793,
+ 60811, 60821, 60859, 60869, 60887, 60889, 60899, 60901, 60913,
+ 60917, 60919, 60923, 60937, 60943, 60953, 60961, 61001, 61007,
+ 61027, 61031, 61043, 61051, 61057, 61091, 61099, 61121, 61129,
+ 61141, 61151, 61153, 61169, 61211, 61223, 61231, 61253, 61261,
+ 61283, 61291, 61297, 61331, 61333, 61339, 61343, 61357, 61363,
+ 61379, 61381, 61403, 61409, 61417, 61441, 61463, 61469, 61471,
+ 61483, 61487, 61493, 61507, 61511, 61519, 61543, 61547, 61553,
+ 61559, 61561, 61583, 61603, 61609, 61613, 61627, 61631, 61637,
+ 61643, 61651, 61657, 61667, 61673, 61681, 61687, 61703, 61717,
+ 61723, 61729, 61751, 61757, 61781, 61813, 61819, 61837, 61843,
+ 61861, 61871, 61879, 61909, 61927, 61933, 61949, 61961, 61967,
+ 61979, 61981, 61987, 61991, 62003, 62011, 62017, 62039, 62047,
+ 62053, 62057, 62071, 62081, 62099, 62119, 62129, 62131, 62137,
+ 62141, 62143, 62171, 62189, 62191, 62201, 62207, 62213, 62219,
+ 62233, 62273, 62297, 62299, 62303, 62311, 62323, 62327, 62347,
+ 62351, 62383, 62401, 62417, 62423, 62459, 62467, 62473, 62477,
+ 62483, 62497, 62501, 62507, 62533, 62539, 62549, 62563, 62581,
+ 62591, 62597, 62603, 62617, 62627, 62633, 62639, 62653, 62659,
+ 62683, 62687, 62701, 62723, 62731, 62743, 62753, 62761, 62773,
+ 62791, 62801, 62819, 62827, 62851, 62861, 62869, 62873, 62897,
+ 62903, 62921, 62927, 62929, 62939, 62969, 62971, 62981, 62983,
+ 62987, 62989, 63029, 63031, 63059, 63067, 63073, 63079, 63097,
+ 63103, 63113, 63127, 63131, 63149, 63179, 63197, 63199, 63211,
+ 63241, 63247, 63277, 63281, 63299, 63311, 63313, 63317, 63331,
+ 63337, 63347, 63353, 63361, 63367, 63377, 63389, 63391, 63397,
+ 63409, 63419, 63421, 63439, 63443, 63463, 63467, 63473, 63487,
+ 63493, 63499, 63521, 63527, 63533, 63541, 63559, 63577, 63587,
+ 63589, 63599, 63601, 63607, 63611, 63617, 63629, 63647, 63649,
+ 63659, 63667, 63671, 63689, 63691, 63697, 63703, 63709, 63719,
+ 63727, 63737, 63743, 63761, 63773, 63781, 63793, 63799, 63803,
+ 63809, 63823, 63839, 63841, 63853, 63857, 63863, 63901, 63907,
+ 63913, 63929, 63949, 63977, 63997, 64007, 64013, 64019, 64033,
+ 64037, 64063, 64067, 64081, 64091, 64109, 64123, 64151, 64153,
+ 64157, 64171, 64187, 64189, 64217, 64223, 64231, 64237, 64271,
+ 64279, 64283, 64301, 64303, 64319, 64327, 64333, 64373, 64381,
+ 64399, 64403, 64433, 64439, 64451, 64453, 64483, 64489, 64499,
+ 64513, 64553, 64567, 64577, 64579, 64591, 64601, 64609, 64613,
+ 64621, 64627, 64633, 64661, 64663, 64667, 64679, 64693, 64709,
+ 64717, 64747, 64763, 64781, 64783, 64793, 64811, 64817, 64849,
+ 64853, 64871, 64877, 64879, 64891, 64901, 64919, 64921, 64927,
+ 64937, 64951, 64969, 64997, 65003, 65011, 65027, 65029, 65033,
+ 65053, 65063, 65071, 65089, 65099, 65101, 65111, 65119, 65123,
+ 65129, 65141, 65147, 65167, 65171, 65173, 65179, 65183, 65203,
+ 65213, 65239, 65257, 65267, 65269, 65287, 65293, 65309, 65323,
+ 65327, 65353, 65357, 65371, 65381, 65393, 65407, 65413, 65419,
+ 65423, 65437, 65447, 65449, 65479, 65497, 65519, 65521, 65537,
+ 65539, 65543, 65551, 65557, 65563, 65579, 65581, 65587, 65599,
+ 65609, 65617, 65629, 65633, 65647, 65651, 65657, 65677, 65687,
+ 65699, 65701, 65707, 65713, 65717, 65719, 65729, 65731, 65761,
+ 65777, 65789, 65809, 65827, 65831, 65837, 65839, 65843, 65851,
+ 65867, 65881, 65899, 65921, 65927, 65929, 65951, 65957, 65963,
+ 65981, 65983, 65993, 66029, 66037, 66041, 66047, 66067, 66071,
+ 66083, 66089, 66103, 66107, 66109, 66137, 66161, 66169, 66173,
+ 66179, 66191, 66221, 66239, 66271, 66293, 66301, 66337, 66343,
+ 66347, 66359, 66361, 66373, 66377, 66383, 66403, 66413, 66431,
+ 66449, 66457, 66463, 66467, 66491, 66499, 66509, 66523, 66529,
+ 66533, 66541, 66553, 66569, 66571, 66587, 66593, 66601, 66617,
+ 66629, 66643, 66653, 66683, 66697, 66701, 66713, 66721, 66733,
+ 66739, 66749, 66751, 66763, 66791, 66797, 66809, 66821, 66841,
+ 66851, 66853, 66863, 66877, 66883, 66889, 66919, 66923, 66931,
+ 66943, 66947, 66949, 66959, 66973, 66977, 67003, 67021, 67033,
+ 67043, 67049, 67057, 67061, 67073, 67079, 67103, 67121, 67129,
+ 67139, 67141, 67153, 67157, 67169, 67181, 67187, 67189, 67211,
+ 67213, 67217, 67219, 67231, 67247, 67261, 67271, 67273, 67289,
+ 67307, 67339, 67343, 67349, 67369, 67391, 67399, 67409, 67411,
+ 67421, 67427, 67429, 67433, 67447, 67453, 67477, 67481, 67489,
+ 67493, 67499, 67511, 67523, 67531, 67537, 67547, 67559, 67567,
+ 67577, 67579, 67589, 67601, 67607, 67619, 67631, 67651, 67679,
+ 67699, 67709, 67723, 67733, 67741, 67751, 67757, 67759, 67763,
+ 67777, 67783, 67789, 67801, 67807, 67819, 67829, 67843, 67853,
+ 67867, 67883, 67891, 67901, 67927, 67931, 67933, 67939, 67943,
+ 67957, 67961, 67967, 67979, 67987, 67993, 68023, 68041, 68053,
+ 68059, 68071, 68087, 68099, 68111, 68113, 68141, 68147, 68161,
+ 68171, 68207, 68209, 68213, 68219, 68227, 68239, 68261, 68279,
+ 68281, 68311, 68329, 68351, 68371, 68389, 68399, 68437, 68443,
+ 68447, 68449, 68473, 68477, 68483, 68489, 68491, 68501, 68507,
+ 68521, 68531, 68539, 68543, 68567, 68581, 68597, 68611, 68633,
+ 68639, 68659, 68669, 68683, 68687, 68699, 68711, 68713, 68729,
+ 68737, 68743, 68749, 68767, 68771, 68777, 68791, 68813, 68819,
+ 68821, 68863, 68879, 68881, 68891, 68897, 68899, 68903, 68909,
+ 68917, 68927, 68947, 68963, 68993, 69001, 69011, 69019, 69029,
+ 69031, 69061, 69067, 69073, 69109, 69119, 69127, 69143, 69149,
+ 69151, 69163, 69191, 69193, 69197, 69203, 69221, 69233, 69239,
+ 69247, 69257, 69259, 69263, 69313, 69317, 69337, 69341, 69371,
+ 69379, 69383, 69389, 69401, 69403, 69427, 69431, 69439, 69457,
+ 69463, 69467, 69473, 69481, 69491, 69493, 69497, 69499, 69539,
+ 69557, 69593, 69623, 69653, 69661, 69677, 69691, 69697, 69709,
+ 69737, 69739, 69761, 69763, 69767, 69779, 69809, 69821, 69827,
+ 69829, 69833, 69847, 69857, 69859, 69877, 69899, 69911, 69929,
+ 69931, 69941, 69959, 69991, 69997, 70001, 70003, 70009, 70019,
+ 70039, 70051, 70061, 70067, 70079, 70099, 70111, 70117, 70121,
+ 70123, 70139, 70141, 70157, 70163, 70177, 70181, 70183, 70199,
+ 70201, 70207, 70223, 70229, 70237, 70241, 70249, 70271, 70289,
+ 70297, 70309, 70313, 70321, 70327, 70351, 70373, 70379, 70381,
+ 70393, 70423, 70429, 70439, 70451, 70457, 70459, 70481, 70487,
+ 70489, 70501, 70507, 70529, 70537, 70549, 70571, 70573, 70583,
+ 70589, 70607, 70619, 70621, 70627, 70639, 70657, 70663, 70667,
+ 70687, 70709, 70717, 70729, 70753, 70769, 70783, 70793, 70823,
+ 70841, 70843, 70849, 70853, 70867, 70877, 70879, 70891, 70901,
+ 70913, 70919, 70921, 70937, 70949, 70951, 70957, 70969, 70979,
+ 70981, 70991, 70997, 70999, 71011, 71023, 71039, 71059, 71069,
+ 71081, 71089, 71119, 71129, 71143, 71147, 71153, 71161, 71167,
+ 71171, 71191, 71209, 71233, 71237, 71249, 71257, 71261, 71263,
+ 71287, 71293, 71317, 71327, 71329, 71333, 71339, 71341, 71347,
+ 71353, 71359, 71363, 71387, 71389, 71399, 71411, 71413, 71419,
+ 71429, 71437, 71443, 71453, 71471, 71473, 71479, 71483, 71503,
+ 71527, 71537, 71549, 71551, 71563, 71569, 71593, 71597, 71633,
+ 71647, 71663, 71671, 71693, 71699, 71707, 71711, 71713, 71719,
+ 71741, 71761, 71777, 71789, 71807, 71809, 71821, 71837, 71843,
+ 71849, 71861, 71867, 71879, 71881, 71887, 71899, 71909, 71917,
+ 71933, 71941, 71947, 71963, 71971, 71983, 71987, 71993, 71999,
+ 72019, 72031, 72043, 72047, 72053, 72073, 72077, 72089, 72091,
+ 72101, 72103, 72109, 72139, 72161, 72167, 72169, 72173, 72211,
+ 72221, 72223, 72227, 72229, 72251, 72253, 72269, 72271, 72277,
+ 72287, 72307, 72313, 72337, 72341, 72353, 72367, 72379, 72383,
+ 72421, 72431, 72461, 72467, 72469, 72481, 72493, 72497, 72503,
+ 72533, 72547, 72551, 72559, 72577, 72613, 72617, 72623, 72643,
+ 72647, 72649, 72661, 72671, 72673, 72679, 72689, 72701, 72707,
+ 72719, 72727, 72733, 72739, 72763, 72767, 72797, 72817, 72823,
+ 72859, 72869, 72871, 72883, 72889, 72893, 72901, 72907, 72911,
+ 72923, 72931, 72937, 72949, 72953, 72959, 72973, 72977, 72997,
+ 73009, 73013, 73019, 73037, 73039, 73043, 73061, 73063, 73079,
+ 73091, 73121, 73127, 73133, 73141, 73181, 73189, 73237, 73243,
+ 73259, 73277, 73291, 73303, 73309, 73327, 73331, 73351, 73361,
+ 73363, 73369, 73379, 73387, 73417, 73421, 73433, 73453, 73459,
+ 73471, 73477, 73483, 73517, 73523, 73529, 73547, 73553, 73561,
+ 73571, 73583, 73589, 73597, 73607, 73609, 73613, 73637, 73643,
+ 73651, 73673, 73679, 73681, 73693, 73699, 73709, 73721, 73727,
+ 73751, 73757, 73771, 73783, 73819, 73823, 73847, 73849, 73859,
+ 73867, 73877, 73883, 73897, 73907, 73939, 73943, 73951, 73961,
+ 73973, 73999, 74017, 74021, 74027, 74047, 74051, 74071, 74077,
+ 74093, 74099, 74101, 74131, 74143, 74149, 74159, 74161, 74167,
+ 74177, 74189, 74197, 74201, 74203, 74209, 74219, 74231, 74257,
+ 74279, 74287, 74293, 74297, 74311, 74317, 74323, 74353, 74357,
+ 74363, 74377, 74381, 74383, 74411, 74413, 74419, 74441, 74449,
+ 74453, 74471, 74489, 74507, 74509, 74521, 74527, 74531, 74551,
+ 74561, 74567, 74573, 74587, 74597, 74609, 74611, 74623, 74653,
+ 74687, 74699, 74707, 74713, 74717, 74719, 74729, 74731, 74747,
+ 74759, 74761, 74771, 74779, 74797, 74821, 74827, 74831, 74843,
+ 74857, 74861, 74869, 74873, 74887, 74891, 74897, 74903, 74923,
+ 74929, 74933, 74941, 74959, 75011, 75013, 75017, 75029, 75037,
+ 75041, 75079, 75083, 75109, 75133, 75149, 75161, 75167, 75169,
+ 75181, 75193, 75209, 75211, 75217, 75223, 75227, 75239, 75253,
+ 75269, 75277, 75289, 75307, 75323, 75329, 75337, 75347, 75353,
+ 75367, 75377, 75389, 75391, 75401, 75403, 75407, 75431, 75437,
+ 75479, 75503, 75511, 75521, 75527, 75533, 75539, 75541, 75553,
+ 75557, 75571, 75577, 75583, 75611, 75617, 75619, 75629, 75641,
+ 75653, 75659, 75679, 75683, 75689, 75703, 75707, 75709, 75721,
+ 75731, 75743, 75767, 75773, 75781, 75787, 75793, 75797, 75821,
+ 75833, 75853, 75869, 75883, 75913, 75931, 75937, 75941, 75967,
+ 75979, 75983, 75989, 75991, 75997, 76001, 76003, 76031, 76039,
+ 76079, 76081, 76091, 76099, 76103, 76123, 76129, 76147, 76157,
+ 76159, 76163, 76207, 76213, 76231, 76243, 76249, 76253, 76259,
+ 76261, 76283, 76289, 76303, 76333, 76343, 76367, 76369, 76379,
+ 76387, 76403, 76421, 76423, 76441, 76463, 76471, 76481, 76487,
+ 76493, 76507, 76511, 76519, 76537, 76541, 76543, 76561, 76579,
+ 76597, 76603, 76607, 76631, 76649, 76651, 76667, 76673, 76679,
+ 76697, 76717, 76733, 76753, 76757, 76771, 76777, 76781, 76801,
+ 76819, 76829, 76831, 76837, 76847, 76871, 76873, 76883, 76907,
+ 76913, 76919, 76943, 76949, 76961, 76963, 76991, 77003, 77017,
+ 77023, 77029, 77041, 77047, 77069, 77081, 77093, 77101, 77137,
+ 77141, 77153, 77167, 77171, 77191, 77201, 77213, 77237, 77239,
+ 77243, 77249, 77261, 77263, 77267, 77269, 77279, 77291, 77317,
+ 77323, 77339, 77347, 77351, 77359, 77369, 77377, 77383, 77417,
+ 77419, 77431, 77447, 77471, 77477, 77479, 77489, 77491, 77509,
+ 77513, 77521, 77527, 77543, 77549, 77551, 77557, 77563, 77569,
+ 77573, 77587, 77591, 77611, 77617, 77621, 77641, 77647, 77659,
+ 77681, 77687, 77689, 77699, 77711, 77713, 77719, 77723, 77731,
+ 77743, 77747, 77761, 77773, 77783, 77797, 77801, 77813, 77839,
+ 77849, 77863, 77867, 77893, 77899, 77929, 77933, 77951, 77969,
+ 77977, 77983, 77999, 78007, 78017, 78031, 78041, 78049, 78059,
+ 78079, 78101, 78121, 78137, 78139, 78157, 78163, 78167, 78173,
+ 78179, 78191, 78193, 78203, 78229, 78233, 78241, 78259, 78277,
+ 78283, 78301, 78307, 78311, 78317, 78341, 78347, 78367, 78401,
+ 78427, 78437, 78439, 78467, 78479, 78487, 78497, 78509, 78511,
+ 78517, 78539, 78541, 78553, 78569, 78571, 78577, 78583, 78593,
+ 78607, 78623, 78643, 78649, 78653, 78691, 78697, 78707, 78713,
+ 78721, 78737, 78779, 78781, 78787, 78791, 78797, 78803, 78809,
+ 78823, 78839, 78853, 78857, 78877, 78887, 78889, 78893, 78901,
+ 78919, 78929, 78941, 78977, 78979, 78989, 79031, 79039, 79043,
+ 79063, 79087, 79103, 79111, 79133, 79139, 79147, 79151, 79153,
+ 79159, 79181, 79187, 79193, 79201, 79229, 79231, 79241, 79259,
+ 79273, 79279, 79283, 79301, 79309, 79319, 79333, 79337, 79349,
+ 79357, 79367, 79379, 79393, 79397, 79399, 79411, 79423, 79427,
+ 79433, 79451, 79481, 79493, 79531, 79537, 79549, 79559, 79561,
+ 79579, 79589, 79601, 79609, 79613, 79621, 79627, 79631, 79633,
+ 79657, 79669, 79687, 79691, 79693, 79697, 79699, 79757, 79769,
+ 79777, 79801, 79811, 79813, 79817, 79823, 79829, 79841, 79843,
+ 79847, 79861, 79867, 79873, 79889, 79901, 79903, 79907, 79939,
+ 79943, 79967, 79973, 79979, 79987, 79997, 79999, 80021, 80039,
+ 80051, 80071, 80077, 80107, 80111, 80141, 80147, 80149, 80153,
+ 80167, 80173, 80177, 80191, 80207, 80209, 80221, 80231, 80233,
+ 80239, 80251, 80263, 80273, 80279, 80287, 80309, 80317, 80329,
+ 80341, 80347, 80363, 80369, 80387, 80407, 80429, 80447, 80449,
+ 80471, 80473, 80489, 80491, 80513, 80527, 80537, 80557, 80567,
+ 80599, 80603, 80611, 80621, 80627, 80629, 80651, 80657, 80669,
+ 80671, 80677, 80681, 80683, 80687, 80701, 80713, 80737, 80747,
+ 80749, 80761, 80777, 80779, 80783, 80789, 80803, 80809, 80819,
+ 80831, 80833, 80849, 80863, 80897, 80909, 80911, 80917, 80923,
+ 80929, 80933, 80953, 80963, 80989, 81001, 81013, 81017, 81019,
+ 81023, 81031, 81041, 81043, 81047, 81049, 81071, 81077, 81083,
+ 81097, 81101, 81119, 81131, 81157, 81163, 81173, 81181, 81197,
+ 81199, 81203, 81223, 81233, 81239, 81281, 81283, 81293, 81299,
+ 81307, 81331, 81343, 81349, 81353, 81359, 81371, 81373, 81401,
+ 81409, 81421, 81439, 81457, 81463, 81509, 81517, 81527, 81533,
+ 81547, 81551, 81553, 81559, 81563, 81569, 81611, 81619, 81629,
+ 81637, 81647, 81649, 81667, 81671, 81677, 81689, 81701, 81703,
+ 81707, 81727, 81737, 81749, 81761, 81769, 81773, 81799, 81817,
+ 81839, 81847, 81853, 81869, 81883, 81899, 81901, 81919, 81929,
+ 81931, 81937, 81943, 81953, 81967, 81971, 81973, 82003, 82007,
+ 82009, 82013, 82021, 82031, 82037, 82039, 82051, 82067, 82073,
+ 82129, 82139, 82141, 82153, 82163, 82171, 82183, 82189, 82193,
+ 82207, 82217, 82219, 82223, 82231, 82237, 82241, 82261, 82267,
+ 82279, 82301, 82307, 82339, 82349, 82351, 82361, 82373, 82387,
+ 82393, 82421, 82457, 82463, 82469, 82471, 82483, 82487, 82493,
+ 82499, 82507, 82529, 82531, 82549, 82559, 82561, 82567, 82571,
+ 82591, 82601, 82609, 82613, 82619, 82633, 82651, 82657, 82699,
+ 82721, 82723, 82727, 82729, 82757, 82759, 82763, 82781, 82787,
+ 82793, 82799, 82811, 82813, 82837, 82847, 82883, 82889, 82891,
+ 82903, 82913, 82939, 82963, 82981, 82997, 83003, 83009, 83023,
+ 83047, 83059, 83063, 83071, 83077, 83089, 83093, 83101, 83117,
+ 83137, 83177, 83203, 83207, 83219, 83221, 83227, 83231, 83233,
+ 83243, 83257, 83267, 83269, 83273, 83299, 83311, 83339, 83341,
+ 83357, 83383, 83389, 83399, 83401, 83407, 83417, 83423, 83431,
+ 83437, 83443, 83449, 83459, 83471, 83477, 83497, 83537, 83557,
+ 83561, 83563, 83579, 83591, 83597, 83609, 83617, 83621, 83639,
+ 83641, 83653, 83663, 83689, 83701, 83717, 83719, 83737, 83761,
+ 83773, 83777, 83791, 83813, 83833, 83843, 83857, 83869, 83873,
+ 83891, 83903, 83911, 83921, 83933, 83939, 83969, 83983, 83987,
+ 84011, 84017, 84047, 84053, 84059, 84061, 84067, 84089, 84121,
+ 84127, 84131, 84137, 84143, 84163, 84179, 84181, 84191, 84199,
+ 84211, 84221, 84223, 84229, 84239, 84247, 84263, 84299, 84307,
+ 84313, 84317, 84319, 84347, 84349, 84377, 84389, 84391, 84401,
+ 84407, 84421, 84431, 84437, 84443, 84449, 84457, 84463, 84467,
+ 84481, 84499, 84503, 84509, 84521, 84523, 84533, 84551, 84559,
+ 84589, 84629, 84631, 84649, 84653, 84659, 84673, 84691, 84697,
+ 84701, 84713, 84719, 84731, 84737, 84751, 84761, 84787, 84793,
+ 84809, 84811, 84827, 84857, 84859, 84869, 84871, 84913, 84919,
+ 84947, 84961, 84967, 84977, 84979, 84991, 85009, 85021, 85027,
+ 85037, 85049, 85061, 85081, 85087, 85091, 85093, 85103, 85109,
+ 85121, 85133, 85147, 85159, 85193, 85199, 85201, 85213, 85223,
+ 85229, 85237, 85243, 85247, 85259, 85297, 85303, 85313, 85331,
+ 85333, 85361, 85363, 85369, 85381, 85411, 85427, 85429, 85439,
+ 85447, 85451, 85453, 85469, 85487, 85513, 85517, 85523, 85531,
+ 85549, 85571, 85577, 85597, 85601, 85607, 85619, 85621, 85627,
+ 85639, 85643, 85661, 85667, 85669, 85691, 85703, 85711, 85717,
+ 85733, 85751, 85781, 85793, 85817, 85819, 85829, 85831, 85837,
+ 85843, 85847, 85853, 85889, 85903, 85909, 85931, 85933, 85991,
+ 85999, 86011, 86017, 86027, 86029, 86069, 86077, 86083, 86111,
+ 86113, 86117, 86131, 86137, 86143, 86161, 86171, 86179, 86183,
+ 86197, 86201, 86209, 86239, 86243, 86249, 86257, 86263, 86269,
+ 86287, 86291, 86293, 86297, 86311, 86323, 86341, 86351, 86353,
+ 86357, 86369, 86371, 86381, 86389, 86399, 86413, 86423, 86441,
+ 86453, 86461, 86467, 86477, 86491, 86501, 86509, 86531, 86533,
+ 86539, 86561, 86573, 86579, 86587, 86599, 86627, 86629, 86677,
+ 86689, 86693, 86711, 86719, 86729, 86743, 86753, 86767, 86771,
+ 86783, 86813, 86837, 86843, 86851, 86857, 86861, 86869, 86923,
+ 86927, 86929, 86939, 86951, 86959, 86969, 86981, 86993, 87011,
+ 87013, 87037, 87041, 87049, 87071, 87083, 87103, 87107, 87119,
+ 87121, 87133, 87149, 87151, 87179, 87181, 87187, 87211, 87221,
+ 87223, 87251, 87253, 87257, 87277, 87281, 87293, 87299, 87313,
+ 87317, 87323, 87337, 87359, 87383, 87403, 87407, 87421, 87427,
+ 87433, 87443, 87473, 87481, 87491, 87509, 87511, 87517, 87523,
+ 87539, 87541, 87547, 87553, 87557, 87559, 87583, 87587, 87589,
+ 87613, 87623, 87629, 87631, 87641, 87643, 87649, 87671, 87679,
+ 87683, 87691, 87697, 87701, 87719, 87721, 87739, 87743, 87751,
+ 87767, 87793, 87797, 87803, 87811, 87833, 87853, 87869, 87877,
+ 87881, 87887, 87911, 87917, 87931, 87943, 87959, 87961, 87973,
+ 87977, 87991, 88001, 88003, 88007, 88019, 88037, 88069, 88079,
+ 88093, 88117, 88129, 88169, 88177, 88211, 88223, 88237, 88241,
+ 88259, 88261, 88289, 88301, 88321, 88327, 88337, 88339, 88379,
+ 88397, 88411, 88423, 88427, 88463, 88469, 88471, 88493, 88499,
+ 88513, 88523, 88547, 88589, 88591, 88607, 88609, 88643, 88651,
+ 88657, 88661, 88663, 88667, 88681, 88721, 88729, 88741, 88747,
+ 88771, 88789, 88793, 88799, 88801, 88807, 88811, 88813, 88817,
+ 88819, 88843, 88853, 88861, 88867, 88873, 88883, 88897, 88903,
+ 88919, 88937, 88951, 88969, 88993, 88997, 89003, 89009, 89017,
+ 89021, 89041, 89051, 89057, 89069, 89071, 89083, 89087, 89101,
+ 89107, 89113, 89119, 89123, 89137, 89153, 89189, 89203, 89209,
+ 89213, 89227, 89231, 89237, 89261, 89269, 89273, 89293, 89303,
+ 89317, 89329, 89363, 89371, 89381, 89387, 89393, 89399, 89413,
+ 89417, 89431, 89443, 89449, 89459, 89477, 89491, 89501, 89513,
+ 89519, 89521, 89527, 89533, 89561, 89563, 89567, 89591, 89597,
+ 89599, 89603, 89611, 89627, 89633, 89653, 89657, 89659, 89669,
+ 89671, 89681, 89689, 89753, 89759, 89767, 89779, 89783, 89797,
+ 89809, 89819, 89821, 89833, 89839, 89849, 89867, 89891, 89897,
+ 89899, 89909, 89917, 89923, 89939, 89959, 89963, 89977, 89983,
+ 89989, 90001, 90007, 90011, 90017, 90019, 90023, 90031, 90053,
+ 90059, 90067, 90071, 90073, 90089, 90107, 90121, 90127, 90149,
+ 90163, 90173, 90187, 90191, 90197, 90199, 90203, 90217, 90227,
+ 90239, 90247, 90263, 90271, 90281, 90289, 90313, 90353, 90359,
+ 90371, 90373, 90379, 90397, 90401, 90403, 90407, 90437, 90439,
+ 90469, 90473, 90481, 90499, 90511, 90523, 90527, 90529, 90533,
+ 90547, 90583, 90599, 90617, 90619, 90631, 90641, 90647, 90659,
+ 90677, 90679, 90697, 90703, 90709, 90731, 90749, 90787, 90793,
+ 90803, 90821, 90823, 90833, 90841, 90847, 90863, 90887, 90901,
+ 90907, 90911, 90917, 90931, 90947, 90971, 90977, 90989, 90997,
+ 91009, 91019, 91033, 91079, 91081, 91097, 91099, 91121, 91127,
+ 91129, 91139, 91141, 91151, 91153, 91159, 91163, 91183, 91193,
+ 91199, 91229, 91237, 91243, 91249, 91253, 91283, 91291, 91297,
+ 91303, 91309, 91331, 91367, 91369, 91373, 91381, 91387, 91393,
+ 91397, 91411, 91423, 91433, 91453, 91457, 91459, 91463, 91493,
+ 91499, 91513, 91529, 91541, 91571, 91573, 91577, 91583, 91591,
+ 91621, 91631, 91639, 91673, 91691, 91703, 91711, 91733, 91753,
+ 91757, 91771, 91781, 91801, 91807, 91811, 91813, 91823, 91837,
+ 91841, 91867, 91873, 91909, 91921, 91939, 91943, 91951, 91957,
+ 91961, 91967, 91969, 91997, 92003, 92009, 92033, 92041, 92051,
+ 92077, 92083, 92107, 92111, 92119, 92143, 92153, 92173, 92177,
+ 92179, 92189, 92203, 92219, 92221, 92227, 92233, 92237, 92243,
+ 92251, 92269, 92297, 92311, 92317, 92333, 92347, 92353, 92357,
+ 92363, 92369, 92377, 92381, 92383, 92387, 92399, 92401, 92413,
+ 92419, 92431, 92459, 92461, 92467, 92479, 92489, 92503, 92507,
+ 92551, 92557, 92567, 92569, 92581, 92593, 92623, 92627, 92639,
+ 92641, 92647, 92657, 92669, 92671, 92681, 92683, 92693, 92699,
+ 92707, 92717, 92723, 92737, 92753, 92761, 92767, 92779, 92789,
+ 92791, 92801, 92809, 92821, 92831, 92849, 92857, 92861, 92863,
+ 92867, 92893, 92899, 92921, 92927, 92941, 92951, 92957, 92959,
+ 92987, 92993, 93001, 93047, 93053, 93059, 93077, 93083, 93089,
+ 93097, 93103, 93113, 93131, 93133, 93139, 93151, 93169, 93179,
+ 93187, 93199, 93229, 93239, 93241, 93251, 93253, 93257, 93263,
+ 93281, 93283, 93287, 93307, 93319, 93323, 93329, 93337, 93371,
+ 93377, 93383, 93407, 93419, 93427, 93463, 93479, 93481, 93487,
+ 93491, 93493, 93497, 93503, 93523, 93529, 93553, 93557, 93559,
+ 93563, 93581, 93601, 93607, 93629, 93637, 93683, 93701, 93703,
+ 93719, 93739, 93761, 93763, 93787, 93809, 93811, 93827, 93851,
+ 93871, 93887, 93889, 93893, 93901, 93911, 93913, 93923, 93937,
+ 93941, 93949, 93967, 93971, 93979, 93983, 93997, 94007, 94009,
+ 94033, 94049, 94057, 94063, 94079, 94099, 94109, 94111, 94117,
+ 94121, 94151, 94153, 94169, 94201, 94207, 94219, 94229, 94253,
+ 94261, 94273, 94291, 94307, 94309, 94321, 94327, 94331, 94343,
+ 94349, 94351, 94379, 94397, 94399, 94421, 94427, 94433, 94439,
+ 94441, 94447, 94463, 94477, 94483, 94513, 94529, 94531, 94541,
+ 94543, 94547, 94559, 94561, 94573, 94583, 94597, 94603, 94613,
+ 94621, 94649, 94651, 94687, 94693, 94709, 94723, 94727, 94747,
+ 94771, 94777, 94781, 94789, 94793, 94811, 94819, 94823, 94837,
+ 94841, 94847, 94849, 94873, 94889, 94903, 94907, 94933, 94949,
+ 94951, 94961, 94993, 94999, 95003, 95009, 95021, 95027, 95063,
+ 95071, 95083, 95087, 95089, 95093, 95101, 95107, 95111, 95131,
+ 95143, 95153, 95177, 95189, 95191, 95203, 95213, 95219, 95231,
+ 95233, 95239, 95257, 95261, 95267, 95273, 95279, 95287, 95311,
+ 95317, 95327, 95339, 95369, 95383, 95393, 95401, 95413, 95419,
+ 95429, 95441, 95443, 95461, 95467, 95471, 95479, 95483, 95507,
+ 95527, 95531, 95539, 95549, 95561, 95569, 95581, 95597, 95603,
+ 95617, 95621, 95629, 95633, 95651, 95701, 95707, 95713, 95717,
+ 95723, 95731, 95737, 95747, 95773, 95783, 95789, 95791, 95801,
+ 95803, 95813, 95819, 95857, 95869, 95873, 95881, 95891, 95911,
+ 95917, 95923, 95929, 95947, 95957, 95959, 95971, 95987, 95989,
+ 96001, 96013, 96017, 96043, 96053, 96059, 96079, 96097, 96137,
+ 96149, 96157, 96167, 96179, 96181, 96199, 96211, 96221, 96223,
+ 96233, 96259, 96263, 96269, 96281, 96289, 96293, 96323, 96329,
+ 96331, 96337, 96353, 96377, 96401, 96419, 96431, 96443, 96451,
+ 96457, 96461, 96469, 96479, 96487, 96493, 96497, 96517, 96527,
+ 96553, 96557, 96581, 96587, 96589, 96601, 96643, 96661, 96667,
+ 96671, 96697, 96703, 96731, 96737, 96739, 96749, 96757, 96763,
+ 96769, 96779, 96787, 96797, 96799, 96821, 96823, 96827, 96847,
+ 96851, 96857, 96893, 96907, 96911, 96931, 96953, 96959, 96973,
+ 96979, 96989, 96997, 97001, 97003, 97007, 97021, 97039, 97073,
+ 97081, 97103, 97117, 97127, 97151, 97157, 97159, 97169, 97171,
+ 97177, 97187, 97213, 97231, 97241, 97259, 97283, 97301, 97303,
+ 97327, 97367, 97369, 97373, 97379, 97381, 97387, 97397, 97423,
+ 97429, 97441, 97453, 97459, 97463, 97499, 97501, 97511, 97523,
+ 97547, 97549, 97553, 97561, 97571, 97577, 97579, 97583, 97607,
+ 97609, 97613, 97649, 97651, 97673, 97687, 97711, 97729, 97771,
+ 97777, 97787, 97789, 97813, 97829, 97841, 97843, 97847, 97849,
+ 97859, 97861, 97871, 97879, 97883, 97919, 97927, 97931, 97943,
+ 97961, 97967, 97973, 97987, 98009, 98011, 98017, 98041, 98047,
+ 98057, 98081, 98101, 98123, 98129, 98143, 98179, 98207, 98213,
+ 98221, 98227, 98251, 98257, 98269, 98297, 98299, 98317, 98321,
+ 98323, 98327, 98347, 98369, 98377, 98387, 98389, 98407, 98411,
+ 98419, 98429, 98443, 98453, 98459, 98467, 98473, 98479, 98491,
+ 98507, 98519, 98533, 98543, 98561, 98563, 98573, 98597, 98621,
+ 98627, 98639, 98641, 98663, 98669, 98689, 98711, 98713, 98717,
+ 98729, 98731, 98737, 98773, 98779, 98801, 98807, 98809, 98837,
+ 98849, 98867, 98869, 98873, 98887, 98893, 98897, 98899, 98909,
+ 98911, 98927, 98929, 98939, 98947, 98953, 98963, 98981, 98993,
+ 98999, 99013, 99017, 99023, 99041, 99053, 99079, 99083, 99089,
+ 99103, 99109, 99119, 99131, 99133, 99137, 99139, 99149, 99173,
+ 99181, 99191, 99223, 99233, 99241, 99251, 99257, 99259, 99277,
+ 99289, 99317, 99347, 99349, 99367, 99371, 99377, 99391, 99397,
+ 99401, 99409, 99431, 99439, 99469, 99487, 99497, 99523, 99527,
+ 99529, 99551, 99559, 99563, 99571, 99577, 99581, 99607, 99611,
+ 99623, 99643, 99661, 99667, 99679, 99689, 99707, 99709, 99713,
+ 99719, 99721, 99733, 99761, 99767, 99787, 99793, 99809, 99817,
+ 99823, 99829, 99833, 99839, 99859, 99871, 99877, 99881, 99901,
+ 99907, 99923, 99929, 99961, 99971, 99989, 99991,
+ };
--- /dev/null
+/*
+------------------------------------------------------------------------------
+rand.h: definitions for a random number generator
+By Bob Jenkins, 1996, Public Domain
+MODIFIED:
+ 960327: Creation (addition of randinit, really)
+ 970719: use context, not global variables, for internal state
+ 980324: renamed seed to flag
+ 980605: recommend RANDSIZL=4 for noncryptography.
+ 010626: note this is public domain
+------------------------------------------------------------------------------
+*/
+#ifndef STANDARD
+#include "standard.h"
+#endif
+
+#ifndef RAND
+#define RAND
+#define RANDSIZL (8) /* I recommend 8 for crypto, 4 for simulations */
+#define RANDSIZ (1<<RANDSIZL)
+
+/* context of random number generator */
+struct randctx
+{
+ ub4 randcnt;
+ ub4 randrsl[RANDSIZ];
+ ub4 randmem[RANDSIZ];
+ ub4 randa;
+ ub4 randb;
+ ub4 randc;
+};
+typedef struct randctx randctx;
+
+/*
+------------------------------------------------------------------------------
+ If (flag==TRUE), then use the contents of randrsl[0..RANDSIZ-1] as the seed.
+------------------------------------------------------------------------------
+*/
+void randinit(randctx *r, word flag);
+
+void isaac(randctx *r);
+
+
+/*
+------------------------------------------------------------------------------
+ Call rand(/o_ randctx *r _o/) to retrieve a single 32-bit random value
+------------------------------------------------------------------------------
+*/
+#define rand(r) \
+ (!(r)->randcnt-- ? \
+ (isaac(r), (r)->randcnt=RANDSIZ-1, (r)->randrsl[(r)->randcnt]) : \
+ (r)->randrsl[(r)->randcnt])
+
+#endif /* RAND */
+
+
--- /dev/null
+/*
+------------------------------------------------------------------------------
+rand.c: By Bob Jenkins. My random number generator, ISAAC. Public Domain
+MODIFIED:
+ 960327: Creation (addition of randinit, really)
+ 970719: use context, not global variables, for internal state
+ 980324: make a portable version
+ 010626: Note this is public domain
+------------------------------------------------------------------------------
+*/
+#ifndef STANDARD
+#include "standard.h"
+#endif
+#ifndef RAND
+#include "rand.h"
+#endif
+
+
+#define ind(mm,x) ((mm)[(x>>2)&(RANDSIZ-1)])
+#define rngstep(mix,a,b,mm,m,m2,r,x) \
+{ \
+ x = *m; \
+ a = ((a^(mix)) + *(m2++)) & 0xffffffff; \
+ *(m++) = y = (ind(mm,x) + a + b) & 0xffffffff; \
+ *(r++) = b = (ind(mm,y>>RANDSIZL) + x) & 0xffffffff; \
+}
+
+void isaac(randctx *ctx)
+{
+ register ub4 a,b,x,y,*m,*mm,*m2,*r,*mend;
+ mm=ctx->randmem; r=ctx->randrsl;
+ a = ctx->randa; b = (ctx->randb + (++ctx->randc)) & 0xffffffff;
+ for (m = mm, mend = m2 = m+(RANDSIZ/2); m<mend; )
+ {
+ rngstep( a<<13, a, b, mm, m, m2, r, x);
+ rngstep( a>>6 , a, b, mm, m, m2, r, x);
+ rngstep( a<<2 , a, b, mm, m, m2, r, x);
+ rngstep( a>>16, a, b, mm, m, m2, r, x);
+ }
+ for (m2 = mm; m2<mend; )
+ {
+ rngstep( a<<13, a, b, mm, m, m2, r, x);
+ rngstep( a>>6 , a, b, mm, m, m2, r, x);
+ rngstep( a<<2 , a, b, mm, m, m2, r, x);
+ rngstep( a>>16, a, b, mm, m, m2, r, x);
+ }
+ ctx->randb = b; ctx->randa = a;
+}
+
+
+#define mix(a,b,c,d,e,f,g,h) \
+{ \
+ a^=b<<11; d+=a; b+=c; \
+ b^=c>>2; e+=b; c+=d; \
+ c^=d<<8; f+=c; d+=e; \
+ d^=e>>16; g+=d; e+=f; \
+ e^=f<<10; h+=e; f+=g; \
+ f^=g>>4; a+=f; g+=h; \
+ g^=h<<8; b+=g; h+=a; \
+ h^=a>>9; c+=h; a+=b; \
+}
+
+/* if (flag==TRUE), then use the contents of randrsl[] to initialize mm[]. */
+void randinit(randctx *ctx, word flag)
+{
+ word i;
+ ub4 a,b,c,d,e,f,g,h;
+ ub4 *m,*r;
+ ctx->randa = ctx->randb = ctx->randc = 0;
+ m=ctx->randmem;
+ r=ctx->randrsl;
+ a=b=c=d=e=f=g=h=0x9e3779b9; /* the golden ratio */
+
+ for (i=0; i<4; ++i) /* scramble it */
+ {
+ mix(a,b,c,d,e,f,g,h);
+ }
+
+ if (flag)
+ {
+ /* initialize using the contents of r[] as the seed */
+ for (i=0; i<RANDSIZ; i+=8)
+ {
+ a+=r[i ]; b+=r[i+1]; c+=r[i+2]; d+=r[i+3];
+ e+=r[i+4]; f+=r[i+5]; g+=r[i+6]; h+=r[i+7];
+ mix(a,b,c,d,e,f,g,h);
+ m[i ]=a; m[i+1]=b; m[i+2]=c; m[i+3]=d;
+ m[i+4]=e; m[i+5]=f; m[i+6]=g; m[i+7]=h;
+ }
+ /* do a second pass to make all of the seed affect all of m */
+ for (i=0; i<RANDSIZ; i+=8)
+ {
+ a+=m[i ]; b+=m[i+1]; c+=m[i+2]; d+=m[i+3];
+ e+=m[i+4]; f+=m[i+5]; g+=m[i+6]; h+=m[i+7];
+ mix(a,b,c,d,e,f,g,h);
+ m[i ]=a; m[i+1]=b; m[i+2]=c; m[i+3]=d;
+ m[i+4]=e; m[i+5]=f; m[i+6]=g; m[i+7]=h;
+ }
+ }
+ else
+ {
+ for (i=0; i<RANDSIZ; i+=8)
+ {
+ /* fill in mm[] with messy stuff */
+ mix(a,b,c,d,e,f,g,h);
+ m[i ]=a; m[i+1]=b; m[i+2]=c; m[i+3]=d;
+ m[i+4]=e; m[i+5]=f; m[i+6]=g; m[i+7]=h;
+ }
+ }
+
+ isaac(ctx); /* fill in the first set of results */
+ ctx->randcnt=RANDSIZ; /* prepare to use the first set of results */
+}
+
+
+#ifdef NEVER
+int main()
+{
+ ub4 i,j;
+ randctx ctx;
+ ctx.randa=ctx.randb=ctx.randc=(ub4)0;
+ for (i=0; i<256; ++i) ctx.randrsl[i]=(ub4)0;
+ randinit(&ctx, TRUE);
+ for (i=0; i<2; ++i)
+ {
+ isaac(&ctx);
+ for (j=0; j<256; ++j)
+ {
+ printf("%.8lx",ctx.randrsl[j]);
+ if ((j&7)==7) printf("\n");
+ }
+ }
+}
+#endif
--- /dev/null
+/*
+------------------------------------------------------------------------------
+Standard definitions and types, Bob Jenkins
+------------------------------------------------------------------------------
+*/
+#ifndef STANDARD
+# define STANDARD
+# ifndef STDIO
+# include <stdio.h>
+# define STDIO
+# endif
+# ifndef STDDEF
+# include <stddef.h>
+# define STDDEF
+# endif
+typedef unsigned long long ub8;
+#define UB8MAXVAL 0xffffffffffffffffLL
+#define UB8BITS 64
+typedef signed long long sb8;
+#define SB8MAXVAL 0x7fffffffffffffffLL
+typedef unsigned long int ub4; /* unsigned 4-byte quantities */
+#define UB4MAXVAL 0xffffffff
+typedef signed long int sb4;
+#define UB4BITS 32
+#define SB4MAXVAL 0x7fffffff
+typedef unsigned short int ub2;
+#define UB2MAXVAL 0xffff
+#define UB2BITS 16
+typedef signed short int sb2;
+#define SB2MAXVAL 0x7fff
+typedef unsigned char ub1;
+#define UB1MAXVAL 0xff
+#define UB1BITS 8
+typedef signed char sb1; /* signed 1-byte quantities */
+#define SB1MAXVAL 0x7f
+typedef int word; /* fastest type available */
+
+#define bis(target,mask) ((target) |= (mask))
+#define bic(target,mask) ((target) &= ~(mask))
+#define bit(target,mask) ((target) & (mask))
+#ifndef min
+# define min(a,b) (((a)<(b)) ? (a) : (b))
+#endif /* min */
+#ifndef max
+# define max(a,b) (((a)<(b)) ? (b) : (a))
+#endif /* max */
+#ifndef align
+# define align(a) (((ub4)a+(sizeof(void *)-1))&(~(sizeof(void *)-1)))
+#endif /* align */
+#ifndef abs
+# define abs(a) (((a)>0) ? (a) : -(a))
+#endif
+#define TRUE 1
+#define FALSE 0
+#define SUCCESS 0 /* 1 on VAX */
+
+#endif /* STANDARD */
--- /dev/null
+
+/*
+ ----------------------------------------------------------------
+
+ Notice that the following BSD-style license applies to this one
+ file (memcheck.h) only. The rest of Valgrind is licensed under the
+ terms of the GNU General Public License, version 2, unless
+ otherwise indicated. See the COPYING file in the source
+ distribution for details.
+
+ ----------------------------------------------------------------
+
+ This file is part of MemCheck, a heavyweight Valgrind tool for
+ detecting memory errors.
+
+ Copyright (C) 2000-2009 Julian Seward. All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. The origin of this software must not be misrepresented; you must
+ not claim that you wrote the original software. If you use this
+ software in a product, an acknowledgment in the product
+ documentation would be appreciated but is not required.
+
+ 3. Altered source versions must be plainly marked as such, and must
+ not be misrepresented as being the original software.
+
+ 4. The name of the author may not be used to endorse or promote
+ products derived from this software without specific prior written
+ permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+ OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+ DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+ GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+ WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+ NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+ ----------------------------------------------------------------
+
+ Notice that the above BSD-style license applies to this one file
+ (memcheck.h) only. The entire rest of Valgrind is licensed under
+ the terms of the GNU General Public License, version 2. See the
+ COPYING file in the source distribution for details.
+
+ ----------------------------------------------------------------
+*/
+
+
+#ifndef __MEMCHECK_H
+#define __MEMCHECK_H
+
+
+/* This file is for inclusion into client (your!) code.
+
+ You can use these macros to manipulate and query memory permissions
+ inside your own programs.
+
+ See comment near the top of valgrind.h on how to use them.
+*/
+
+#include "valgrind.h"
+
+/* !! ABIWARNING !! ABIWARNING !! ABIWARNING !! ABIWARNING !!
+ This enum comprises an ABI exported by Valgrind to programs
+ which use client requests. DO NOT CHANGE THE ORDER OF THESE
+ ENTRIES, NOR DELETE ANY -- add new ones at the end. */
+typedef
+ enum {
+ VG_USERREQ__MAKE_MEM_NOACCESS = VG_USERREQ_TOOL_BASE('M','C'),
+ VG_USERREQ__MAKE_MEM_UNDEFINED,
+ VG_USERREQ__MAKE_MEM_DEFINED,
+ VG_USERREQ__DISCARD,
+ VG_USERREQ__CHECK_MEM_IS_ADDRESSABLE,
+ VG_USERREQ__CHECK_MEM_IS_DEFINED,
+ VG_USERREQ__DO_LEAK_CHECK,
+ VG_USERREQ__COUNT_LEAKS,
+
+ VG_USERREQ__GET_VBITS,
+ VG_USERREQ__SET_VBITS,
+
+ VG_USERREQ__CREATE_BLOCK,
+
+ VG_USERREQ__MAKE_MEM_DEFINED_IF_ADDRESSABLE,
+
+ /* Not next to VG_USERREQ__COUNT_LEAKS because it was added later. */
+ VG_USERREQ__COUNT_LEAK_BLOCKS,
+
+ /* This is just for memcheck's internal use - don't use it */
+ _VG_USERREQ__MEMCHECK_RECORD_OVERLAP_ERROR
+ = VG_USERREQ_TOOL_BASE('M','C') + 256
+ } Vg_MemCheckClientRequest;
+
+
+
+/* Client-code macros to manipulate the state of memory. */
+
+/* Mark memory at _qzz_addr as unaddressable for _qzz_len bytes. */
+#define VALGRIND_MAKE_MEM_NOACCESS(_qzz_addr,_qzz_len) \
+ (__extension__({unsigned long _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0 /* default return */, \
+ VG_USERREQ__MAKE_MEM_NOACCESS, \
+ _qzz_addr, _qzz_len, 0, 0, 0); \
+ _qzz_res; \
+ }))
+
+/* Similarly, mark memory at _qzz_addr as addressable but undefined
+ for _qzz_len bytes. */
+#define VALGRIND_MAKE_MEM_UNDEFINED(_qzz_addr,_qzz_len) \
+ (__extension__({unsigned long _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0 /* default return */, \
+ VG_USERREQ__MAKE_MEM_UNDEFINED, \
+ _qzz_addr, _qzz_len, 0, 0, 0); \
+ _qzz_res; \
+ }))
+
+/* Similarly, mark memory at _qzz_addr as addressable and defined
+ for _qzz_len bytes. */
+#define VALGRIND_MAKE_MEM_DEFINED(_qzz_addr,_qzz_len) \
+ (__extension__({unsigned long _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0 /* default return */, \
+ VG_USERREQ__MAKE_MEM_DEFINED, \
+ _qzz_addr, _qzz_len, 0, 0, 0); \
+ _qzz_res; \
+ }))
+
+/* Similar to VALGRIND_MAKE_MEM_DEFINED except that addressability is
+ not altered: bytes which are addressable are marked as defined,
+ but those which are not addressable are left unchanged. */
+#define VALGRIND_MAKE_MEM_DEFINED_IF_ADDRESSABLE(_qzz_addr,_qzz_len) \
+ (__extension__({unsigned long _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0 /* default return */, \
+ VG_USERREQ__MAKE_MEM_DEFINED_IF_ADDRESSABLE, \
+ _qzz_addr, _qzz_len, 0, 0, 0); \
+ _qzz_res; \
+ }))
+
+/* Create a block-description handle. The description is an ascii
+ string which is included in any messages pertaining to addresses
+ within the specified memory range. Has no other effect on the
+ properties of the memory range. */
+#define VALGRIND_CREATE_BLOCK(_qzz_addr,_qzz_len, _qzz_desc) \
+ (__extension__({unsigned long _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0 /* default return */, \
+ VG_USERREQ__CREATE_BLOCK, \
+ _qzz_addr, _qzz_len, _qzz_desc, \
+ 0, 0); \
+ _qzz_res; \
+ }))
+
+/* Discard a block-description-handle. Returns 1 for an
+ invalid handle, 0 for a valid handle. */
+#define VALGRIND_DISCARD(_qzz_blkindex) \
+ (__extension__ ({unsigned long _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0 /* default return */, \
+ VG_USERREQ__DISCARD, \
+ 0, _qzz_blkindex, 0, 0, 0); \
+ _qzz_res; \
+ }))
+
+
+/* Client-code macros to check the state of memory. */
+
+/* Check that memory at _qzz_addr is addressable for _qzz_len bytes.
+ If suitable addressibility is not established, Valgrind prints an
+ error message and returns the address of the first offending byte.
+ Otherwise it returns zero. */
+#define VALGRIND_CHECK_MEM_IS_ADDRESSABLE(_qzz_addr,_qzz_len) \
+ (__extension__({unsigned long _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__CHECK_MEM_IS_ADDRESSABLE,\
+ _qzz_addr, _qzz_len, 0, 0, 0); \
+ _qzz_res; \
+ }))
+
+/* Check that memory at _qzz_addr is addressable and defined for
+ _qzz_len bytes. If suitable addressibility and definedness are not
+ established, Valgrind prints an error message and returns the
+ address of the first offending byte. Otherwise it returns zero. */
+#define VALGRIND_CHECK_MEM_IS_DEFINED(_qzz_addr,_qzz_len) \
+ (__extension__({unsigned long _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__CHECK_MEM_IS_DEFINED, \
+ _qzz_addr, _qzz_len, 0, 0, 0); \
+ _qzz_res; \
+ }))
+
+/* Use this macro to force the definedness and addressibility of an
+ lvalue to be checked. If suitable addressibility and definedness
+ are not established, Valgrind prints an error message and returns
+ the address of the first offending byte. Otherwise it returns
+ zero. */
+#define VALGRIND_CHECK_VALUE_IS_DEFINED(__lvalue) \
+ VALGRIND_CHECK_MEM_IS_DEFINED( \
+ (volatile unsigned char *)&(__lvalue), \
+ (unsigned long)(sizeof (__lvalue)))
+
+
+/* Do a full memory leak check (like --leak-check=full) mid-execution. */
+#define VALGRIND_DO_LEAK_CHECK \
+ {unsigned long _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__DO_LEAK_CHECK, \
+ 0, 0, 0, 0, 0); \
+ }
+
+/* Do a summary memory leak check (like --leak-check=summary) mid-execution. */
+#define VALGRIND_DO_QUICK_LEAK_CHECK \
+ {unsigned long _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__DO_LEAK_CHECK, \
+ 1, 0, 0, 0, 0); \
+ }
+
+/* Return number of leaked, dubious, reachable and suppressed bytes found by
+ all previous leak checks. They must be lvalues. */
+#define VALGRIND_COUNT_LEAKS(leaked, dubious, reachable, suppressed) \
+ /* For safety on 64-bit platforms we assign the results to private
+ unsigned long variables, then assign these to the lvalues the user
+ specified, which works no matter what type 'leaked', 'dubious', etc
+ are. We also initialise '_qzz_leaked', etc because
+ VG_USERREQ__COUNT_LEAKS doesn't mark the values returned as
+ defined. */ \
+ {unsigned long _qzz_res; \
+ unsigned long _qzz_leaked = 0, _qzz_dubious = 0; \
+ unsigned long _qzz_reachable = 0, _qzz_suppressed = 0; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__COUNT_LEAKS, \
+ &_qzz_leaked, &_qzz_dubious, \
+ &_qzz_reachable, &_qzz_suppressed, 0); \
+ leaked = _qzz_leaked; \
+ dubious = _qzz_dubious; \
+ reachable = _qzz_reachable; \
+ suppressed = _qzz_suppressed; \
+ }
+
+/* Return number of leaked, dubious, reachable and suppressed bytes found by
+ all previous leak checks. They must be lvalues. */
+#define VALGRIND_COUNT_LEAK_BLOCKS(leaked, dubious, reachable, suppressed) \
+ /* For safety on 64-bit platforms we assign the results to private
+ unsigned long variables, then assign these to the lvalues the user
+ specified, which works no matter what type 'leaked', 'dubious', etc
+ are. We also initialise '_qzz_leaked', etc because
+ VG_USERREQ__COUNT_LEAKS doesn't mark the values returned as
+ defined. */ \
+ {unsigned long _qzz_res; \
+ unsigned long _qzz_leaked = 0, _qzz_dubious = 0; \
+ unsigned long _qzz_reachable = 0, _qzz_suppressed = 0; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__COUNT_LEAK_BLOCKS, \
+ &_qzz_leaked, &_qzz_dubious, \
+ &_qzz_reachable, &_qzz_suppressed, 0); \
+ leaked = _qzz_leaked; \
+ dubious = _qzz_dubious; \
+ reachable = _qzz_reachable; \
+ suppressed = _qzz_suppressed; \
+ }
+
+
+/* Get the validity data for addresses [zza..zza+zznbytes-1] and copy it
+ into the provided zzvbits array. Return values:
+ 0 if not running on valgrind
+ 1 success
+ 2 [previously indicated unaligned arrays; these are now allowed]
+ 3 if any parts of zzsrc/zzvbits are not addressable.
+ The metadata is not copied in cases 0, 2 or 3 so it should be
+ impossible to segfault your system by using this call.
+*/
+#define VALGRIND_GET_VBITS(zza,zzvbits,zznbytes) \
+ (__extension__({unsigned long _qzz_res; \
+ char* czza = (char*)zza; \
+ char* czzvbits = (char*)zzvbits; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__GET_VBITS, \
+ czza, czzvbits, zznbytes, 0, 0 ); \
+ _qzz_res; \
+ }))
+
+/* Set the validity data for addresses [zza..zza+zznbytes-1], copying it
+ from the provided zzvbits array. Return values:
+ 0 if not running on valgrind
+ 1 success
+ 2 [previously indicated unaligned arrays; these are now allowed]
+ 3 if any parts of zza/zzvbits are not addressable.
+ The metadata is not copied in cases 0, 2 or 3 so it should be
+ impossible to segfault your system by using this call.
+*/
+#define VALGRIND_SET_VBITS(zza,zzvbits,zznbytes) \
+ (__extension__({unsigned int _qzz_res; \
+ char* czza = (char*)zza; \
+ char* czzvbits = (char*)zzvbits; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__SET_VBITS, \
+ czza, czzvbits, zznbytes, 0, 0 ); \
+ _qzz_res; \
+ }))
+
+#endif
+
--- /dev/null
+#include "rust_internal.h"
+#include "util/array_list.h"
+
+
+// #define TRACK_ALLOCATIONS
+// For debugging, keeps track of live allocations, so you can find out
+// exactly what leaked.
+
+#ifdef TRACK_ALLOCATIONS
+array_list<void *> allocation_list;
+#endif
+
+rust_srv::rust_srv() :
+ live_allocs(0)
+{
+}
+
+rust_srv::~rust_srv()
+{
+ if (live_allocs != 0) {
+ char msg[128];
+ snprintf(msg, sizeof(msg),
+ "leaked memory in rust main loop (%" PRIuPTR " objects)",
+ live_allocs);
+#ifdef TRACK_ALLOCATIONS
+ for (size_t i = 0; i < allocation_list.size(); i++) {
+ if (allocation_list[i] != NULL) {
+ printf("allocation 0x%" PRIxPTR " was not freed\n",
+ (uintptr_t) allocation_list[i]);
+ }
+ }
+#endif
+ fatal(msg, __FILE__, __LINE__);
+ }
+}
+
+void
+rust_srv::log(char const *str)
+{
+ printf("rt: %s\n", str);
+}
+
+
+
+void *
+rust_srv::malloc(size_t bytes)
+{
+ ++live_allocs;
+ void * val = ::malloc(bytes);
+#ifdef TRACK_ALLOCATIONS
+ allocation_list.append(val);
+#endif
+ return val;
+}
+
+void *
+rust_srv::realloc(void *p, size_t bytes)
+{
+ if (!p) {
+ live_allocs++;
+ }
+ void * val = ::realloc(p, bytes);
+#ifdef TRACK_ALLOCATIONS
+ if (allocation_list.replace(p, val) == NULL) {
+ fatal("not in allocation_list", __FILE__, __LINE__);
+ }
+#endif
+ return val;
+}
+
+void
+rust_srv::free(void *p)
+{
+ if (live_allocs < 1) {
+ fatal("live_allocs < 1", __FILE__, __LINE__);
+ }
+ live_allocs--;
+ ::free(p);
+#ifdef TRACK_ALLOCATIONS
+ if (allocation_list.replace(p, NULL) == NULL) {
+ fatal("not in allocation_list", __FILE__, __LINE__);
+ }
+#endif
+}
+
+void
+rust_srv::fatal(char const *expr, char const *file, size_t line)
+{
+ char buf[1024];
+ snprintf(buf, sizeof(buf),
+ "fatal, '%s' failed, %s:%d",
+ expr, file, (int)line);
+ log(buf);
+ exit(1);
+}
+
+rust_srv *
+rust_srv::clone()
+{
+ return new rust_srv();
+}
+
+
+int
+rust_main_loop(rust_dom *dom)
+{
+ // Make sure someone is watching, to pull us out of infinite loops.
+ rust_timer timer(*dom);
+
+ int rval;
+ rust_task *task;
+
+ dom->log(rust_log::DOM,
+ "running main-loop on domain 0x%" PRIxPTR, dom);
+ dom->logptr("exit-task glue",
+ dom->root_crate->get_exit_task_glue());
+
+ while ((task = dom->sched()) != NULL) {
+ I(dom, task->running());
+
+ dom->log(rust_log::TASK,
+ "activating task 0x%" PRIxPTR ", sp=0x%" PRIxPTR,
+ (uintptr_t)task, task->rust_sp);
+
+ dom->interrupt_flag = 0;
+
+ dom->activate(task);
+
+ dom->log(rust_log::TASK,
+ "returned from task 0x%" PRIxPTR
+ " in state '%s', sp=0x%" PRIxPTR,
+ (uintptr_t)task,
+ dom->state_vec_name(task->state),
+ task->rust_sp);
+
+ I(dom, task->rust_sp >= (uintptr_t) &task->stk->data[0]);
+ I(dom, task->rust_sp < task->stk->limit);
+
+ dom->reap_dead_tasks();
+ }
+
+ dom->log(rust_log::DOM, "finished main-loop (dom.rval = %d)", dom->rval);
+ rval = dom->rval;
+
+ return rval;
+}
+
+
+struct
+command_line_args
+{
+ rust_dom &dom;
+ int argc;
+ char **argv;
+
+ // vec[str] passed to rust_task::start.
+ rust_vec *args;
+
+ command_line_args(rust_dom &dom,
+ int sys_argc,
+ char **sys_argv)
+ : dom(dom),
+ argc(sys_argc),
+ argv(sys_argv),
+ args(NULL)
+ {
+#if defined(__WIN32__)
+ LPCWSTR cmdline = GetCommandLineW();
+ LPWSTR *wargv = CommandLineToArgvW(cmdline, &argc);
+ dom.win32_require("CommandLineToArgvW", argv != NULL);
+ argv = (char **) dom.malloc(sizeof(char*) * argc);
+ for (int i = 0; i < argc; ++i) {
+ int n_chars = WideCharToMultiByte(CP_UTF8, 0, wargv[i], -1,
+ NULL, 0, NULL, NULL);
+ dom.win32_require("WideCharToMultiByte(0)", n_chars != 0);
+ argv[i] = (char *) dom.malloc(n_chars);
+ n_chars = WideCharToMultiByte(CP_UTF8, 0, wargv[i], -1,
+ argv[i], n_chars, NULL, NULL);
+ dom.win32_require("WideCharToMultiByte(1)", n_chars != 0);
+ }
+ LocalFree(wargv);
+#endif
+ size_t vec_fill = sizeof(rust_str *) * argc;
+ size_t vec_alloc = next_power_of_two(sizeof(rust_vec) + vec_fill);
+ void *mem = dom.malloc(vec_alloc);
+ args = new (mem) rust_vec(&dom, vec_alloc, 0, NULL);
+ rust_str **strs = (rust_str**) &args->data[0];
+ for (int i = 0; i < argc; ++i) {
+ size_t str_fill = strlen(argv[i]) + 1;
+ size_t str_alloc = next_power_of_two(sizeof(rust_str) + str_fill);
+ mem = dom.malloc(str_alloc);
+ strs[i] = new (mem) rust_str(&dom, str_alloc, str_fill,
+ (uint8_t const *)argv[i]);
+ }
+ args->fill = vec_fill;
+ // If the caller has a declared args array, they may drop; but
+ // we don't know if they have such an array. So we pin the args
+ // array here to ensure it survives to program-shutdown.
+ args->ref();
+ }
+
+ ~command_line_args() {
+ if (args) {
+ // Drop the args we've had pinned here.
+ rust_str **strs = (rust_str**) &args->data[0];
+ for (int i = 0; i < argc; ++i)
+ dom.free(strs[i]);
+ dom.free(args);
+ }
+
+#ifdef __WIN32__
+ for (int i = 0; i < argc; ++i) {
+ dom.free(argv[i]);
+ }
+ dom.free(argv);
+#endif
+ }
+};
+
+
+extern "C" CDECL int
+rust_start(uintptr_t main_fn, rust_crate const *crate, int argc, char **argv)
+{
+ int ret;
+ {
+ rust_srv srv;
+ rust_dom dom(&srv, crate);
+ command_line_args args(dom, argc, argv);
+
+ dom.log(rust_log::DOM, "startup: %d args", args.argc);
+ for (int i = 0; i < args.argc; ++i)
+ dom.log(rust_log::DOM,
+ "startup: arg[%d] = '%s'", i, args.argv[i]);
+
+ if (dom._log.is_tracing(rust_log::DWARF)) {
+ rust_crate_reader rdr(&dom, crate);
+ }
+
+ uintptr_t main_args[3] = { 0, 0, (uintptr_t)args.args };
+
+ dom.root_task->start(crate->get_exit_task_glue(),
+ main_fn,
+ (uintptr_t)&main_args,
+ sizeof(main_args));
+
+ ret = rust_main_loop(&dom);
+ }
+
+#if !defined(__WIN32__)
+ // Don't take down the process if the main thread exits without an
+ // error.
+ if (!ret)
+ pthread_exit(NULL);
+#endif
+ return ret;
+}
+
+//
+// Local Variables:
+// mode: C++
+// fill-column: 78;
+// indent-tabs-mode: nil
+// c-basic-offset: 4
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
+//
--- /dev/null
+#ifndef RUST_H
+#define RUST_H
+
+/*
+ * Include this file after you've defined the ISO C9x stdint
+ * types (size_t, uint8_t, uintptr_t, etc.)
+ */
+
+#ifdef __i386__
+// 'cdecl' ABI only means anything on i386
+#ifdef __WIN32__
+#define CDECL __cdecl
+#else
+#define CDECL __attribute__((cdecl))
+#endif
+#else
+#define CDECL
+#endif
+
+struct rust_srv {
+ size_t live_allocs;
+
+ virtual void log(char const *);
+ virtual void fatal(char const *, char const *, size_t);
+ virtual void *malloc(size_t);
+ virtual void *realloc(void *, size_t);
+ virtual void free(void *);
+ virtual rust_srv *clone();
+
+ rust_srv();
+ virtual ~rust_srv();
+};
+
+inline void *operator new(size_t size, rust_srv *srv)
+{
+ return srv->malloc(size);
+}
+
+/*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * c-basic-offset: 4
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ */
+
+#endif /* RUST_H */
--- /dev/null
+
+#include "rust_internal.h"
+
+/* Native builtins. */
+extern "C" CDECL rust_str*
+str_alloc(rust_task *task, size_t n_bytes)
+{
+ rust_dom *dom = task->dom;
+ size_t alloc = next_power_of_two(sizeof(rust_str) + n_bytes);
+ void *mem = dom->malloc(alloc);
+ if (!mem) {
+ task->fail(2);
+ return NULL;
+ }
+ rust_str *st = new (mem) rust_str(dom, alloc, 1, (uint8_t const *)"");
+ return st;
+}
+
+extern "C" CDECL rust_str*
+last_os_error(rust_task *task) {
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::TASK, "last_os_error()");
+
+#if defined(__WIN32__)
+ LPTSTR buf;
+ DWORD err = GetLastError();
+ DWORD res = FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER |
+ FORMAT_MESSAGE_FROM_SYSTEM |
+ FORMAT_MESSAGE_IGNORE_INSERTS,
+ NULL, err,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
+ (LPTSTR) &buf, 0, NULL);
+ if (!res) {
+ task->fail(1);
+ return NULL;
+ }
+#elif defined(_GNU_SOURCE)
+ char cbuf[1024];
+ char *buf = strerror_r(errno, cbuf, sizeof(cbuf));
+ if (!buf) {
+ task->fail(1);
+ return NULL;
+ }
+#else
+ char buf[1024];
+ int err = strerror_r(errno, buf, sizeof(buf));
+ if (err) {
+ task->fail(1);
+ return NULL;
+ }
+#endif
+ size_t fill = strlen(buf) + 1;
+ size_t alloc = next_power_of_two(sizeof(rust_str) + fill);
+ void *mem = dom->malloc(alloc);
+ if (!mem) {
+ task->fail(1);
+ return NULL;
+ }
+ rust_str *st = new (mem) rust_str(dom, alloc, fill, (const uint8_t *)buf);
+
+#ifdef __WIN32__
+ LocalFree((HLOCAL)buf);
+#endif
+ return st;
+}
+
+extern "C" CDECL size_t
+size_of(rust_task *task, type_desc *t) {
+ return t->size;
+}
+
+extern "C" CDECL size_t
+align_of(rust_task *task, type_desc *t) {
+ return t->align;
+}
+
+extern "C" CDECL size_t
+refcount(rust_task *task, type_desc *t, size_t *v) {
+ // Passed-in value has refcount 1 too high
+ // because it was ref'ed while making the call.
+ return (*v) - 1;
+}
+
+extern "C" CDECL rust_vec*
+vec_alloc(rust_task *task, type_desc *t, size_t n_elts)
+{
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::MEM,
+ "vec_alloc %" PRIdPTR " elements of size %" PRIdPTR,
+ n_elts, t->size);
+ size_t fill = n_elts * t->size;
+ size_t alloc = next_power_of_two(sizeof(rust_vec) + fill);
+ void *mem = dom->malloc(alloc);
+ if (!mem) {
+ task->fail(3);
+ return NULL;
+ }
+ rust_vec *vec = new (mem) rust_vec(dom, alloc, 0, NULL);
+ return vec;
+}
+
+extern "C" CDECL char const *
+str_buf(rust_task *task, rust_str *s)
+{
+ return (char const *)&s->data[0];
+}
+
+extern "C" CDECL void *
+vec_buf(rust_task *task, type_desc *ty, rust_vec *v)
+{
+ return (void *)&v->data[0];
+}
+
+extern "C" CDECL size_t
+vec_len(rust_task *task, type_desc *ty, rust_vec *v)
+{
+ return v->fill;
+}
+
+//
+// Local Variables:
+// mode: C++
+// fill-column: 78;
+// indent-tabs-mode: nil
+// c-basic-offset: 4
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
+//
--- /dev/null
+
+#include "rust_internal.h"
+#include "rust_chan.h"
+
+rust_chan::rust_chan(rust_task *task, rust_port *port) :
+ task(task),
+ port(port),
+ buffer(task->dom, port->unit_sz),
+ token(this)
+{
+ if (port)
+ port->chans.push(this);
+}
+
+rust_chan::~rust_chan()
+{
+ if (port) {
+ if (token.pending())
+ token.withdraw();
+ port->chans.swapdel(this);
+ }
+}
+
+void
+rust_chan::disassociate()
+{
+ I(task->dom, port);
+
+ if (token.pending())
+ token.withdraw();
+
+ // Delete reference to the port/
+ port = NULL;
+}
--- /dev/null
+
+#ifndef RUST_CHAN_H
+#define RUST_CHAN_H
+
+class rust_chan : public rc_base<rust_chan>, public task_owned<rust_chan> {
+public:
+ rust_chan(rust_task *task, rust_port *port);
+ ~rust_chan();
+
+ rust_task *task;
+ rust_port *port;
+ circ_buf buffer;
+ size_t idx; // Index into port->chans.
+
+ // Token belonging to this chan, it will be placed into a port's
+ // writers vector if we have something to send to the port.
+ rust_token token;
+
+ void disassociate();
+};
+
+#endif /* RUST_CHAN_H */
--- /dev/null
+
+#include "rust_internal.h"
+
+template class ptr_vec<rust_token>;
+template class ptr_vec<rust_alarm>;
+template class ptr_vec<rust_chan>;
+
+rust_alarm::rust_alarm(rust_task *receiver) :
+ receiver(receiver)
+{
+}
+
+
+// Circular buffers.
+
+circ_buf::circ_buf(rust_dom *dom, size_t unit_sz) :
+ dom(dom),
+ alloc(INIT_CIRC_BUF_UNITS * unit_sz),
+ unit_sz(unit_sz),
+ next(0),
+ unread(0),
+ data((uint8_t *)dom->calloc(alloc))
+{
+ I(dom, unit_sz);
+ dom->log(rust_log::MEM|rust_log::COMM,
+ "new circ_buf(alloc=%d, unread=%d) -> circ_buf=0x%" PRIxPTR,
+ alloc, unread, this);
+ I(dom, data);
+}
+
+circ_buf::~circ_buf()
+{
+ dom->log(rust_log::MEM|rust_log::COMM,
+ "~circ_buf 0x%" PRIxPTR,
+ this);
+ I(dom, data);
+ // I(dom, unread == 0);
+ dom->free(data);
+}
+
+void
+circ_buf::transfer(void *dst)
+{
+ size_t i;
+ uint8_t *d = (uint8_t *)dst;
+ I(dom, dst);
+ for (i = 0; i < unread; i += unit_sz)
+ memcpy(&d[i], &data[next + i % alloc], unit_sz);
+}
+
+void
+circ_buf::push(void *src)
+{
+ size_t i;
+ void *tmp;
+
+ I(dom, src);
+ I(dom, unread <= alloc);
+
+ /* Grow if necessary. */
+ if (unread == alloc) {
+ I(dom, alloc <= MAX_CIRC_BUF_SIZE);
+ tmp = dom->malloc(alloc << 1);
+ transfer(tmp);
+ alloc <<= 1;
+ dom->free(data);
+ data = (uint8_t *)tmp;
+ }
+
+ dom->log(rust_log::MEM|rust_log::COMM,
+ "circ buf push, unread=%d, alloc=%d, unit_sz=%d",
+ unread, alloc, unit_sz);
+
+ I(dom, unread < alloc);
+ I(dom, unread + unit_sz <= alloc);
+
+ i = (next + unread) % alloc;
+ memcpy(&data[i], src, unit_sz);
+
+ dom->log(rust_log::MEM|rust_log::COMM, "pushed data at index %d", i);
+ unread += unit_sz;
+}
+
+void
+circ_buf::shift(void *dst)
+{
+ size_t i;
+ void *tmp;
+
+ I(dom, dst);
+ I(dom, unit_sz > 0);
+ I(dom, unread >= unit_sz);
+ I(dom, unread <= alloc);
+ I(dom, data);
+ i = next;
+ memcpy(dst, &data[i], unit_sz);
+ dom->log(rust_log::MEM|rust_log::COMM, "shifted data from index %d", i);
+ unread -= unit_sz;
+ next += unit_sz;
+ I(dom, next <= alloc);
+ if (next == alloc)
+ next = 0;
+
+ /* Shrink if necessary. */
+ if (alloc >= INIT_CIRC_BUF_UNITS * unit_sz &&
+ unread <= alloc / 4) {
+ tmp = dom->malloc(alloc / 2);
+ transfer(tmp);
+ alloc >>= 1;
+ dom->free(data);
+ data = (uint8_t *)tmp;
+ }
+}
+
+
+// Ports.
+
+rust_port::rust_port(rust_task *task, size_t unit_sz) :
+ task(task),
+ unit_sz(unit_sz),
+ writers(task->dom),
+ chans(task->dom)
+{
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::MEM|rust_log::COMM,
+ "new rust_port(task=0x%" PRIxPTR ", unit_sz=%d) -> port=0x%"
+ PRIxPTR, (uintptr_t)task, unit_sz, (uintptr_t)this);
+}
+
+rust_port::~rust_port()
+{
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::COMM|rust_log::MEM,
+ "~rust_port 0x%" PRIxPTR,
+ (uintptr_t)this);
+ while (chans.length() > 0)
+ chans.pop()->disassociate();
+}
+
+
+// Tokens.
+
+rust_token::rust_token(rust_chan *chan) :
+ chan(chan),
+ idx(0),
+ submitted(false)
+{
+}
+
+rust_token::~rust_token()
+{
+}
+
+bool
+rust_token::pending() const
+{
+ return submitted;
+}
+
+void
+rust_token::submit()
+{
+ rust_port *port = chan->port;
+ rust_dom *dom = chan->task->dom;
+
+ I(dom, port);
+ I(dom, !submitted);
+
+ port->writers.push(this);
+ submitted = true;
+}
+
+void
+rust_token::withdraw()
+{
+ rust_task *task = chan->task;
+ rust_port *port = chan->port;
+ rust_dom *dom = task->dom;
+
+ I(dom, port);
+ I(dom, submitted);
+
+ if (task->blocked())
+ task->wakeup(this); // must be blocked on us (or dead)
+ port->writers.swapdel(this);
+ submitted = false;
+}
+
+
+//
+// Local Variables:
+// mode: C++
+// fill-column: 78;
+// indent-tabs-mode: nil
+// c-basic-offset: 4
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
+//
--- /dev/null
+
+#include "rust_internal.h"
+
+uintptr_t
+rust_crate::get_image_base() const {
+ return ((uintptr_t)this + image_base_off);
+}
+
+ptrdiff_t
+rust_crate::get_relocation_diff() const {
+ return ((uintptr_t)this - self_addr);
+}
+
+activate_glue_ty
+rust_crate::get_activate_glue() const {
+ return (activate_glue_ty) ((uintptr_t)this + activate_glue_off);
+}
+
+uintptr_t
+rust_crate::get_exit_task_glue() const {
+ return ((uintptr_t)this + exit_task_glue_off);
+}
+
+uintptr_t
+rust_crate::get_unwind_glue() const {
+ return ((uintptr_t)this + unwind_glue_off);
+}
+
+uintptr_t
+rust_crate::get_yield_glue() const {
+ return ((uintptr_t)this + yield_glue_off);
+}
+
+rust_crate::mem_area::mem_area(rust_dom *dom, uintptr_t pos, size_t sz)
+ : dom(dom),
+ base(pos),
+ lim(pos + sz)
+{
+ dom->log(rust_log::MEM, "new mem_area [0x%" PRIxPTR ",0x%" PRIxPTR "]",
+ base, lim);
+}
+
+rust_crate::mem_area
+rust_crate::get_debug_info(rust_dom *dom) const {
+ return mem_area(dom, ((uintptr_t)this + debug_info_off),
+ debug_info_sz);
+}
+
+rust_crate::mem_area
+rust_crate::get_debug_abbrev(rust_dom *dom) const {
+ return mem_area(dom, ((uintptr_t)this + debug_abbrev_off),
+ debug_abbrev_sz);
+}
+
+//
+// Local Variables:
+// mode: C++
+// fill-column: 78;
+// indent-tabs-mode: nil
+// c-basic-offset: 4
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
--- /dev/null
+
+#include "rust_internal.h"
+
+rust_crate_cache::lib::lib(rust_dom *dom, char const *name)
+ : handle(0),
+ dom(dom)
+{
+#if defined(__WIN32__)
+ handle = (uintptr_t)LoadLibrary(_T(name));
+#else
+ handle = (uintptr_t)dlopen(name, RTLD_LOCAL|RTLD_LAZY);
+#endif
+ dom->log(rust_log::CACHE, "loaded library '%s' as 0x%" PRIxPTR,
+ name, handle);
+}
+
+rust_crate_cache::lib::~lib() {
+ dom->log(rust_log::CACHE, "~rust_crate_cache::lib(0x%" PRIxPTR ")",
+ handle);
+ if (handle) {
+#if defined(__WIN32__)
+ FreeLibrary((HMODULE)handle);
+#else
+ dlclose((void*)handle);
+#endif
+ }
+}
+
+uintptr_t
+rust_crate_cache::lib::get_handle() {
+ return handle;
+}
+
+
+
+rust_crate_cache::c_sym::c_sym(rust_dom *dom, lib *library, char const *name)
+ : val(0),
+ library(library),
+ dom(dom)
+{
+ library->ref();
+ uintptr_t handle = library->get_handle();
+ if (handle) {
+#if defined(__WIN32__)
+ val = (uintptr_t)GetProcAddress((HMODULE)handle, _T(name));
+#else
+ val = (uintptr_t)dlsym((void*)handle, name);
+#endif
+ dom->log(rust_log::CACHE, "resolved symbol '%s' to 0x%" PRIxPTR,
+ name, val);
+ } else {
+ dom->log(rust_log::CACHE, "unresolved symbol '%s', null lib handle",
+ name);
+ }
+}
+
+rust_crate_cache::c_sym::~c_sym() {
+ dom->log(rust_log::CACHE,
+ "~rust_crate_cache::c_sym(0x%" PRIxPTR ")", val);
+ library->deref();
+}
+
+uintptr_t
+rust_crate_cache::c_sym::get_val() {
+ return val;
+}
+
+
+
+rust_crate_cache::rust_sym::rust_sym(rust_dom *dom,
+ rust_crate const *curr_crate,
+ c_sym *crate_sym,
+ char const **path)
+ : val(0),
+ crate_sym(crate_sym),
+ dom(dom)
+{
+ crate_sym->ref();
+ typedef rust_crate_reader::die die;
+ rust_crate const *crate = (rust_crate*)crate_sym->get_val();
+ if (!crate) {
+ dom->log(rust_log::CACHE,
+ "failed to resolve symbol, null crate symbol");
+ return;
+ }
+ rust_crate_reader rdr(dom, crate);
+ bool found_root = false;
+ bool found_leaf = false;
+ for (die d = rdr.dies.first_die();
+ !(found_root || d.is_null());
+ d = d.next_sibling()) {
+
+ die t1 = d;
+ die t2 = d;
+ for (char const **c = crate_rel(curr_crate, path);
+ (*c
+ && !t1.is_null()
+ && t1.find_child_by_name(crate_rel(curr_crate, *c), t2));
+ ++c, t1=t2) {
+ dom->log(rust_log::DWARF|rust_log::CACHE,
+ "matched die <0x%" PRIxPTR
+ ">, child '%s' = die<0x%" PRIxPTR ">",
+ t1.off, crate_rel(curr_crate, *c), t2.off);
+ found_root = found_root || true;
+ if (!*(c+1) && t2.find_num_attr(DW_AT_low_pc, val)) {
+ dom->log(rust_log::DWARF|rust_log::CACHE,
+ "found relative address: 0x%" PRIxPTR, val);
+ dom->log(rust_log::DWARF|rust_log::CACHE,
+ "plus image-base 0x%" PRIxPTR,
+ crate->get_image_base());
+ val += crate->get_image_base();
+ found_leaf = true;
+ break;
+ }
+ }
+ if (found_root || found_leaf)
+ break;
+ }
+ if (found_leaf) {
+ dom->log(rust_log::CACHE, "resolved symbol to 0x%" PRIxPTR, val);
+ } else {
+ dom->log(rust_log::CACHE, "failed to resolve symbol");
+ }
+}
+
+rust_crate_cache::rust_sym::~rust_sym() {
+ dom->log(rust_log::CACHE,
+ "~rust_crate_cache::rust_sym(0x%" PRIxPTR ")", val);
+ crate_sym->deref();
+}
+
+uintptr_t
+rust_crate_cache::rust_sym::get_val() {
+ return val;
+}
+
+
+
+rust_crate_cache::lib *
+rust_crate_cache::get_lib(size_t n, char const *name)
+{
+ I(dom, n < crate->n_libs);
+ lib *library = libs[n];
+ if (!library) {
+ library = new (dom) lib(dom, name);
+ libs[n] = library;
+ }
+ return library;
+}
+
+rust_crate_cache::c_sym *
+rust_crate_cache::get_c_sym(size_t n, lib *library, char const *name)
+{
+ I(dom, n < crate->n_c_syms);
+ c_sym *sym = c_syms[n];
+ dom->log(rust_log::CACHE, "cached C symbol %s = 0x%" PRIxPTR, name, sym);
+ if (!sym) {
+ sym = new (dom) c_sym(dom, library, name);
+ c_syms[n] = sym;
+ }
+ return sym;
+}
+
+rust_crate_cache::rust_sym *
+rust_crate_cache::get_rust_sym(size_t n,
+ rust_dom *dom,
+ rust_crate const *curr_crate,
+ c_sym *crate_sym,
+ char const **path)
+{
+ I(dom, n < crate->n_rust_syms);
+ rust_sym *sym = rust_syms[n];
+ if (!sym) {
+ sym = new (dom) rust_sym(dom, curr_crate, crate_sym, path);
+ rust_syms[n] = sym;
+ }
+ return sym;
+}
+
+static inline void
+adjust_disp(uintptr_t &disp, const void *oldp, const void *newp)
+{
+ if (disp) {
+ disp += (uintptr_t)oldp;
+ disp -= (uintptr_t)newp;
+ }
+}
+
+type_desc *
+rust_crate_cache::get_type_desc(size_t size,
+ size_t align,
+ size_t n_descs,
+ type_desc const **descs)
+{
+ I(dom, n_descs > 1);
+ type_desc *td = NULL;
+ size_t keysz = n_descs * sizeof(type_desc*);
+ HASH_FIND(hh, this->type_descs, descs, keysz, td);
+ if (td) {
+ dom->log(rust_log::CACHE, "rust_crate_cache::get_type_desc hit");
+ return td;
+ }
+ dom->log(rust_log::CACHE, "rust_crate_cache::get_type_desc miss");
+ td = (type_desc*) dom->malloc(sizeof(type_desc) + keysz);
+ if (!td)
+ return NULL;
+ // By convention, desc 0 is the root descriptor.
+ // but we ignore the size and alignment of it and use the
+ // passed-in, computed values.
+ memcpy(td, descs[0], sizeof(type_desc));
+ td->first_param = &td->descs[1];
+ td->size = size;
+ td->align = align;
+ for (size_t i = 0; i < n_descs; ++i) {
+ dom->log(rust_log::CACHE,
+ "rust_crate_cache::descs[%" PRIdPTR "] = 0x%" PRIxPTR,
+ i, descs[i]);
+ td->descs[i] = descs[i];
+ }
+ adjust_disp(td->copy_glue_off, descs[0], td);
+ adjust_disp(td->drop_glue_off, descs[0], td);
+ adjust_disp(td->free_glue_off, descs[0], td);
+ adjust_disp(td->mark_glue_off, descs[0], td);
+ adjust_disp(td->obj_drop_glue_off, descs[0], td);
+ HASH_ADD(hh, this->type_descs, descs, keysz, td);
+ return td;
+}
+
+rust_crate_cache::rust_crate_cache(rust_dom *dom,
+ rust_crate const *crate)
+ : rust_syms((rust_sym**)
+ dom->calloc(sizeof(rust_sym*) * crate->n_rust_syms)),
+ c_syms((c_sym**) dom->calloc(sizeof(c_sym*) * crate->n_c_syms)),
+ libs((lib**) dom->calloc(sizeof(lib*) * crate->n_libs)),
+ type_descs(NULL),
+ crate(crate),
+ dom(dom),
+ idx(0)
+{
+ I(dom, rust_syms);
+ I(dom, c_syms);
+ I(dom, libs);
+}
+
+void
+rust_crate_cache::flush() {
+ dom->log(rust_log::CACHE, "rust_crate_cache::flush()");
+ for (size_t i = 0; i < crate->n_rust_syms; ++i) {
+ rust_sym *s = rust_syms[i];
+ if (s) {
+ dom->log(rust_log::CACHE,
+ "rust_crate_cache::flush() deref rust_sym %"
+ PRIdPTR " (rc=%" PRIdPTR ")", i, s->refcnt);
+ s->deref();
+ }
+ rust_syms[i] = NULL;
+ }
+
+ for (size_t i = 0; i < crate->n_c_syms; ++i) {
+ c_sym *s = c_syms[i];
+ if (s) {
+ dom->log(rust_log::CACHE,
+ "rust_crate_cache::flush() deref c_sym %"
+ PRIdPTR " (rc=%" PRIdPTR ")", i, s->refcnt);
+ s->deref();
+ }
+ c_syms[i] = NULL;
+ }
+
+ for (size_t i = 0; i < crate->n_libs; ++i) {
+ lib *l = libs[i];
+ if (l) {
+ dom->log(rust_log::CACHE, "rust_crate_cache::flush() deref lib %"
+ PRIdPTR " (rc=%" PRIdPTR ")", i, l->refcnt);
+ l->deref();
+ }
+ libs[i] = NULL;
+ }
+
+ while (type_descs) {
+ type_desc *d = type_descs;
+ HASH_DEL(type_descs, d);
+ dom->log(rust_log::MEM,
+ "rust_crate_cache::flush() tydesc %" PRIxPTR, d);
+ dom->free(d);
+ }
+}
+
+rust_crate_cache::~rust_crate_cache()
+{
+ flush();
+ dom->free(rust_syms);
+ dom->free(c_syms);
+ dom->free(libs);
+}
+
+//
+// Local Variables:
+// mode: C++
+// fill-column: 78;
+// indent-tabs-mode: nil
+// c-basic-offset: 4
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
+//
--- /dev/null
+
+#include "rust_internal.h"
+
+bool
+rust_crate_reader::mem_reader::is_ok()
+{
+ return ok;
+}
+
+bool
+rust_crate_reader::mem_reader::at_end()
+{
+ return pos == mem.lim;
+}
+
+void
+rust_crate_reader::mem_reader::fail()
+{
+ ok = false;
+}
+
+void
+rust_crate_reader::mem_reader::reset()
+{
+ pos = mem.base;
+ ok = true;
+}
+
+rust_crate_reader::mem_reader::mem_reader(rust_crate::mem_area &m)
+ : mem(m),
+ ok(true),
+ pos(m.base)
+{}
+
+size_t
+rust_crate_reader::mem_reader::tell_abs()
+{
+ return pos;
+}
+
+size_t
+rust_crate_reader::mem_reader::tell_off()
+{
+ return pos - mem.base;
+}
+
+void
+rust_crate_reader::mem_reader::seek_abs(uintptr_t p)
+{
+ if (!ok || p < mem.base || p >= mem.lim)
+ ok = false;
+ else
+ pos = p;
+}
+
+void
+rust_crate_reader::mem_reader::seek_off(uintptr_t p)
+{
+ seek_abs(p + mem.base);
+}
+
+
+bool
+rust_crate_reader::mem_reader::adv_zstr(size_t sz)
+{
+ sz = 0;
+ while (ok) {
+ char c;
+ get(c);
+ ++sz;
+ if (c == '\0')
+ return true;
+ }
+ return false;
+}
+
+bool
+rust_crate_reader::mem_reader::get_zstr(char const *&c, size_t &sz)
+{
+ if (!ok)
+ return false;
+ c = (char const *)(pos);
+ return adv_zstr(sz);
+}
+
+void
+rust_crate_reader::mem_reader::adv(size_t amt)
+{
+ if (pos < mem.base
+ || pos >= mem.lim
+ || pos + amt > mem.lim)
+ ok = false;
+ if (!ok)
+ return;
+ // mem.dom->log(rust_log::MEM, "adv %d bytes", amt);
+ pos += amt;
+ ok &= !at_end();
+ I(mem.dom, at_end() || (mem.base <= pos && pos < mem.lim));
+}
+
+
+rust_crate_reader::abbrev::abbrev(rust_dom *dom,
+ uintptr_t body_off,
+ size_t body_sz,
+ uintptr_t tag,
+ uint8_t has_children) :
+ dom(dom),
+ body_off(body_off),
+ tag(tag),
+ has_children(has_children),
+ idx(0)
+{}
+
+
+rust_crate_reader::abbrev_reader::abbrev_reader
+ (rust_crate::mem_area &abbrev_mem)
+ : mem_reader(abbrev_mem),
+ abbrevs(abbrev_mem.dom)
+{
+ rust_dom *dom = mem.dom;
+ while (is_ok()) {
+
+ // dom->log(rust_log::DWARF, "reading new abbrev at 0x%" PRIxPTR,
+ // tell_off());
+
+ uintptr_t idx, tag;
+ uint8_t has_children;
+ get_uleb(idx);
+ get_uleb(tag);
+ get(has_children);
+
+ uintptr_t attr, form;
+ size_t body_off = tell_off();
+ while (is_ok() && step_attr_form_pair(attr, form));
+
+ // dom->log(rust_log::DWARF,
+ // "finished scanning attr/form pairs, pos=0x%"
+ // PRIxPTR ", lim=0x%" PRIxPTR ", is_ok=%d, at_end=%d",
+ // pos, mem.lim, is_ok(), at_end());
+
+ if (is_ok() || at_end()) {
+ dom->log(rust_log::DWARF, "read abbrev: %" PRIdPTR, idx);
+ I(dom, idx = abbrevs.length() + 1);
+ abbrevs.push(new (dom) abbrev(dom, body_off,
+ tell_off() - body_off,
+ tag, has_children));
+ }
+ }
+}
+
+rust_crate_reader::abbrev *
+rust_crate_reader::abbrev_reader::get_abbrev(size_t i) {
+ i -= 1;
+ if (i < abbrevs.length())
+ return abbrevs[i];
+ return NULL;
+}
+
+bool
+rust_crate_reader::abbrev_reader::step_attr_form_pair(uintptr_t &attr,
+ uintptr_t &form)
+{
+ attr = 0;
+ form = 0;
+ // mem.dom->log(rust_log::DWARF, "reading attr/form pair at 0x%" PRIxPTR,
+ // tell_off());
+ get_uleb(attr);
+ get_uleb(form);
+ // mem.dom->log(rust_log::DWARF, "attr 0x%" PRIxPTR ", form 0x%" PRIxPTR,
+ // attr, form);
+ return ! (attr == 0 && form == 0);
+}
+rust_crate_reader::abbrev_reader::~abbrev_reader() {
+ while (abbrevs.length()) {
+ delete abbrevs.pop();
+ }
+}
+
+
+bool
+rust_crate_reader::attr::is_numeric() const
+{
+ switch (form) {
+ case DW_FORM_ref_addr:
+ case DW_FORM_addr:
+ case DW_FORM_data4:
+ case DW_FORM_data1:
+ case DW_FORM_flag:
+ return true;
+ default:
+ break;
+ }
+ return false;
+}
+
+bool
+rust_crate_reader::attr::is_string() const
+{
+ return form == DW_FORM_string;
+}
+
+size_t
+rust_crate_reader::attr::get_ssz(rust_dom *dom) const
+{
+ I(dom, is_string());
+ return val.str.sz;
+}
+
+char const *
+rust_crate_reader::attr::get_str(rust_dom *dom) const
+{
+ I(dom, is_string());
+ return val.str.s;
+}
+
+uintptr_t
+rust_crate_reader::attr::get_num(rust_dom *dom) const
+{
+ I(dom, is_numeric());
+ return val.num;
+}
+
+bool
+rust_crate_reader::attr::is_unknown() const {
+ return !(is_numeric() || is_string());
+}
+
+rust_crate_reader::rdr_sess::rdr_sess(die_reader *rdr) : rdr(rdr)
+{
+ I(rdr->mem.dom, !rdr->in_use);
+ rdr->in_use = true;
+}
+
+rust_crate_reader::rdr_sess::~rdr_sess()
+{
+ rdr->in_use = false;
+}
+
+rust_crate_reader::die::die(die_reader *rdr, uintptr_t off)
+ : rdr(rdr),
+ off(off),
+ using_rdr(false)
+{
+ rust_dom *dom = rdr->mem.dom;
+ rdr_sess use(rdr);
+
+ rdr->reset();
+ rdr->seek_off(off);
+ if (!rdr->is_ok()) {
+ ab = NULL;
+ return;
+ }
+ size_t ab_idx;
+ rdr->get_uleb(ab_idx);
+ if (!ab_idx) {
+ ab = NULL;
+ dom->log(rust_log::DWARF, "DIE <0x%" PRIxPTR "> (null)", off);
+ } else {
+ ab = rdr->abbrevs.get_abbrev(ab_idx);
+ dom->log(rust_log::DWARF, "DIE <0x%" PRIxPTR "> abbrev 0x%"
+ PRIxPTR, off, ab_idx);
+ dom->log(rust_log::DWARF, " tag 0x%x, has children: %d",
+ ab->tag, ab->has_children);
+ }
+}
+
+bool
+rust_crate_reader::die::is_null() const
+{
+ return ab == NULL;
+}
+
+bool
+rust_crate_reader::die::has_children() const
+{
+ return (!is_null()) && ab->has_children;
+}
+
+dw_tag
+rust_crate_reader::die::tag() const
+{
+ if (is_null())
+ return (dw_tag) (-1);
+ return (dw_tag) ab->tag;
+}
+
+bool
+rust_crate_reader::die::start_attrs() const
+{
+ if (is_null())
+ return false;
+ rdr->reset();
+ rdr->seek_off(off + 1);
+ rdr->abbrevs.reset();
+ rdr->abbrevs.seek_off(ab->body_off);
+ return rdr->is_ok();
+}
+
+bool
+rust_crate_reader::die::step_attr(attr &a) const
+{
+ uintptr_t ai, fi;
+ if (rdr->abbrevs.step_attr_form_pair(ai, fi) && rdr->is_ok()) {
+ a.at = (dw_at)ai;
+ a.form = (dw_form)fi;
+
+ uint32_t u32;
+ uint8_t u8;
+
+ switch (a.form) {
+ case DW_FORM_string:
+ return rdr->get_zstr(a.val.str.s, a.val.str.sz);
+ break;
+
+ case DW_FORM_ref_addr:
+ I(rdr->mem.dom, sizeof(uintptr_t) == 4);
+ case DW_FORM_addr:
+ case DW_FORM_data4:
+ rdr->get(u32);
+ a.val.num = (uintptr_t)u32;
+ return rdr->is_ok() || rdr->at_end();
+ break;
+
+ case DW_FORM_data1:
+ case DW_FORM_flag:
+ rdr->get(u8);
+ a.val.num = u8;
+ return rdr->is_ok() || rdr->at_end();
+ break;
+
+ case DW_FORM_block1:
+ rdr->get(u8);
+ rdr->adv(u8);
+ return rdr->is_ok() || rdr->at_end();
+ break;
+
+ default:
+ rdr->mem.dom->log(rust_log::DWARF, " unknown dwarf form: 0x%"
+ PRIxPTR, a.form);
+ rdr->fail();
+ break;
+ }
+ }
+ return false;
+}
+
+bool
+rust_crate_reader::die::find_str_attr(dw_at at, char const *&c)
+{
+ rdr_sess use(rdr);
+ if (is_null())
+ return false;
+ if (start_attrs()) {
+ attr a;
+ while (step_attr(a)) {
+ if (a.at == at && a.is_string()) {
+ c = a.get_str(rdr->mem.dom);
+ return true;
+ }
+ }
+ }
+ return false;
+}
+
+bool
+rust_crate_reader::die::find_num_attr(dw_at at, uintptr_t &n)
+{
+ rdr_sess use(rdr);
+ if (is_null())
+ return false;
+ if (start_attrs()) {
+ attr a;
+ while (step_attr(a)) {
+ if (a.at == at && a.is_numeric()) {
+ n = a.get_num(rdr->mem.dom);
+ return true;
+ }
+ }
+ }
+ return false;
+}
+
+bool
+rust_crate_reader::die::is_transparent()
+{
+ // "semantically transparent" DIEs are those with
+ // children that serve to structure the tree but have
+ // tags that don't reflect anything in the rust-module
+ // name hierarchy.
+ switch (tag()) {
+ case DW_TAG_compile_unit:
+ case DW_TAG_lexical_block:
+ return (has_children());
+ default:
+ break;
+ }
+ return false;
+}
+
+bool
+rust_crate_reader::die::find_child_by_name(char const *c,
+ die &child,
+ bool exact)
+{
+ rust_dom *dom = rdr->mem.dom;
+ I(dom, has_children());
+ I(dom, !is_null());
+
+ for (die ch = next(); !ch.is_null(); ch = ch.next_sibling()) {
+ char const *ac;
+ if (!exact && ch.is_transparent()) {
+ if (ch.find_child_by_name(c, child, exact)) {
+ return true;
+ }
+ }
+ else if (ch.find_str_attr(DW_AT_name, ac)) {
+ if (strcmp(ac, c) == 0) {
+ child = ch;
+ return true;
+ }
+ }
+ }
+ return false;
+}
+
+bool
+rust_crate_reader::die::find_child_by_tag(dw_tag tag, die &child)
+{
+ rust_dom *dom = rdr->mem.dom;
+ I(dom, has_children());
+ I(dom, !is_null());
+
+ for (child = next(); !child.is_null();
+ child = child.next_sibling()) {
+ if (child.tag() == tag)
+ return true;
+ }
+ return false;
+}
+
+rust_crate_reader::die
+rust_crate_reader::die::next() const
+{
+ rust_dom *dom = rdr->mem.dom;
+
+ if (is_null()) {
+ rdr->seek_off(off + 1);
+ return die(rdr, rdr->tell_off());
+ }
+
+ {
+ rdr_sess use(rdr);
+ if (start_attrs()) {
+ attr a;
+ while (step_attr(a)) {
+ I(dom, !(a.is_numeric() && a.is_string()));
+ if (a.is_numeric())
+ dom->log(rust_log::DWARF, " attr num: 0x%"
+ PRIxPTR, a.get_num(dom));
+ else if (a.is_string())
+ dom->log(rust_log::DWARF, " attr str: %s",
+ a.get_str(dom));
+ else
+ dom->log(rust_log::DWARF, " attr ??:");
+ }
+ }
+ }
+ return die(rdr, rdr->tell_off());
+}
+
+rust_crate_reader::die
+rust_crate_reader::die::next_sibling() const
+{
+ // FIXME: use DW_AT_sibling, when present.
+ if (has_children()) {
+ // rdr->mem.dom->log(rust_log::DWARF, "+++ children of die 0x%"
+ // PRIxPTR, off);
+ die child = next();
+ while (!child.is_null())
+ child = child.next_sibling();
+ // rdr->mem.dom->log(rust_log::DWARF, "--- children of die 0x%"
+ // PRIxPTR, off);
+ return child.next();
+ } else {
+ return next();
+ }
+}
+
+
+rust_crate_reader::die
+rust_crate_reader::die_reader::first_die()
+{
+ reset();
+ seek_off(cu_base
+ + sizeof(dwarf_vers)
+ + sizeof(cu_abbrev_off)
+ + sizeof(sizeof_addr));
+ return die(this, tell_off());
+}
+
+void
+rust_crate_reader::die_reader::dump()
+{
+ rust_dom *dom = mem.dom;
+ die d = first_die();
+ while (!d.is_null())
+ d = d.next_sibling();
+ I(dom, d.is_null());
+ I(dom, d.off == mem.lim - mem.base);
+}
+
+
+rust_crate_reader::die_reader::die_reader(rust_crate::mem_area &die_mem,
+ abbrev_reader &abbrevs)
+ : mem_reader(die_mem),
+ abbrevs(abbrevs),
+ cu_unit_length(0),
+ cu_base(0),
+ dwarf_vers(0),
+ cu_abbrev_off(0),
+ sizeof_addr(0),
+ in_use(false)
+{
+ rust_dom *dom = mem.dom;
+
+ rdr_sess use(this);
+
+ get(cu_unit_length);
+ cu_base = tell_off();
+
+ get(dwarf_vers);
+ get(cu_abbrev_off);
+ get(sizeof_addr);
+
+ if (is_ok()) {
+ dom->log(rust_log::DWARF, "new root CU at 0x%" PRIxPTR, die_mem.base);
+ dom->log(rust_log::DWARF, "CU unit length: %" PRId32, cu_unit_length);
+ dom->log(rust_log::DWARF, "dwarf version: %" PRId16, dwarf_vers);
+ dom->log(rust_log::DWARF, "CU abbrev off: %" PRId32, cu_abbrev_off);
+ dom->log(rust_log::DWARF, "size of address: %" PRId8, sizeof_addr);
+ I(dom, sizeof_addr == sizeof(uintptr_t));
+ I(dom, dwarf_vers >= 2);
+ I(dom, cu_base + cu_unit_length == die_mem.lim - die_mem.base);
+ } else {
+ dom->log(rust_log::DWARF, "failed to read root CU header");
+ }
+}
+
+rust_crate_reader::die_reader::~die_reader() {
+}
+
+
+rust_crate_reader::rust_crate_reader(rust_dom *dom,
+ rust_crate const *crate)
+ : dom(dom),
+ crate(crate),
+ abbrev_mem(crate->get_debug_abbrev(dom)),
+ abbrevs(abbrev_mem),
+ die_mem(crate->get_debug_info(dom)),
+ dies(die_mem, abbrevs)
+{
+ dom->log(rust_log::MEM, "crate_reader on crate: 0x%" PRIxPTR, this);
+ dom->log(rust_log::MEM, "debug_abbrev: 0x%" PRIxPTR, abbrev_mem.base);
+ dom->log(rust_log::MEM, "debug_info: 0x%" PRIxPTR, die_mem.base);
+ // For now, perform diagnostics only.
+ dies.dump();
+}
+
+
+//
+// Local Variables:
+// mode: C++
+// fill-column: 78;
+// indent-tabs-mode: nil
+// c-basic-offset: 4
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
--- /dev/null
+
+#include <stdarg.h>
+#include "rust_internal.h"
+
+template class ptr_vec<rust_task>;
+
+rust_dom::rust_dom(rust_srv *srv, rust_crate const *root_crate) :
+ interrupt_flag(0),
+ root_crate(root_crate),
+ _log(srv, this),
+ srv(srv),
+ running_tasks(this),
+ blocked_tasks(this),
+ dead_tasks(this),
+ caches(this),
+ root_task(NULL),
+ curr_task(NULL),
+ rval(0)
+{
+ logptr("new dom", (uintptr_t)this);
+ memset(&rctx, 0, sizeof(rctx));
+
+#ifdef __WIN32__
+ {
+ HCRYPTPROV hProv;
+ win32_require
+ (_T("CryptAcquireContext"),
+ CryptAcquireContext(&hProv, NULL, NULL, PROV_RSA_FULL,
+ CRYPT_VERIFYCONTEXT|CRYPT_SILENT));
+ win32_require
+ (_T("CryptGenRandom"),
+ CryptGenRandom(hProv, sizeof(rctx.randrsl),
+ (BYTE*)(&rctx.randrsl)));
+ win32_require
+ (_T("CryptReleaseContext"),
+ CryptReleaseContext(hProv, 0));
+ }
+#else
+ int fd = open("/dev/urandom", O_RDONLY);
+ I(this, fd > 0);
+ I(this, read(fd, (void*) &rctx.randrsl, sizeof(rctx.randrsl))
+ == sizeof(rctx.randrsl));
+ I(this, close(fd) == 0);
+ pthread_attr_init(&attr);
+ pthread_attr_setstacksize(&attr, 1024 * 1024);
+ pthread_attr_setdetachstate(&attr, true);
+#endif
+ randinit(&rctx, 1);
+
+ root_task = new (this) rust_task(this, NULL);
+}
+
+static void
+del_all_tasks(rust_dom *dom, ptr_vec<rust_task> *v) {
+ I(dom, v);
+ while (v->length()) {
+ dom->log(rust_log::TASK, "deleting task %" PRIdPTR, v->length() - 1);
+ delete v->pop();
+ }
+}
+
+rust_dom::~rust_dom() {
+ log(rust_log::TASK, "deleting all running tasks");
+ del_all_tasks(this, &running_tasks);
+ log(rust_log::TASK, "deleting all blocked tasks");
+ del_all_tasks(this, &blocked_tasks);
+ log(rust_log::TASK, "deleting all dead tasks");
+ del_all_tasks(this, &dead_tasks);
+#ifndef __WIN32__
+ pthread_attr_destroy(&attr);
+#endif
+ while (caches.length())
+ delete caches.pop();
+}
+
+void
+rust_dom::activate(rust_task *task) {
+ curr_task = task;
+ root_crate->get_activate_glue()(task);
+ curr_task = NULL;
+}
+
+void
+rust_dom::log(uint32_t type_bits, char const *fmt, ...) {
+ char buf[256];
+ if (_log.is_tracing(type_bits)) {
+ va_list args;
+ va_start(args, fmt);
+ vsnprintf(buf, sizeof(buf), fmt, args);
+ _log.trace_ln(type_bits, buf);
+ va_end(args);
+ }
+}
+
+rust_log &
+rust_dom::get_log() {
+ return _log;
+}
+
+void
+rust_dom::logptr(char const *msg, uintptr_t ptrval) {
+ log(rust_log::MEM, "%s 0x%" PRIxPTR, msg, ptrval);
+}
+
+template<typename T> void
+rust_dom::logptr(char const *msg, T* ptrval) {
+ log(rust_log::MEM, "%s 0x%" PRIxPTR, msg, (uintptr_t)ptrval);
+}
+
+
+void
+rust_dom::fail() {
+ log(rust_log::DOM, "domain 0x%" PRIxPTR " root task failed", this);
+ I(this, rval == 0);
+ rval = 1;
+}
+
+void *
+rust_dom::malloc(size_t sz) {
+ void *p = srv->malloc(sz);
+ I(this, p);
+ log(rust_log::MEM, "rust_dom::malloc(%d) -> 0x%" PRIxPTR,
+ sz, p);
+ return p;
+}
+
+void *
+rust_dom::calloc(size_t sz) {
+ void *p = this->malloc(sz);
+ memset(p, 0, sz);
+ return p;
+}
+
+void *
+rust_dom::realloc(void *p, size_t sz) {
+ void *p1 = srv->realloc(p, sz);
+ I(this, p1);
+ log(rust_log::MEM, "rust_dom::realloc(0x%" PRIxPTR ", %d) -> 0x%" PRIxPTR,
+ p, sz, p1);
+ return p1;
+}
+
+void
+rust_dom::free(void *p) {
+ log(rust_log::MEM, "rust_dom::free(0x%" PRIxPTR ")", p);
+ I(this, p);
+ srv->free(p);
+}
+
+#ifdef __WIN32__
+void
+rust_dom::win32_require(LPCTSTR fn, BOOL ok) {
+ if (!ok) {
+ LPTSTR buf;
+ DWORD err = GetLastError();
+ FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER |
+ FORMAT_MESSAGE_FROM_SYSTEM |
+ FORMAT_MESSAGE_IGNORE_INSERTS,
+ NULL, err,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
+ (LPTSTR) &buf, 0, NULL );
+ log(rust_log::ERR, "%s failed with error %ld: %s", fn, err, buf);
+ LocalFree((HLOCAL)buf);
+ I(this, ok);
+ }
+}
+#endif
+
+size_t
+rust_dom::n_live_tasks()
+{
+ return running_tasks.length() + blocked_tasks.length();
+}
+
+void
+rust_dom::add_task_to_state_vec(ptr_vec<rust_task> *v, rust_task *task)
+{
+ log(rust_log::MEM|rust_log::TASK,
+ "adding task 0x%" PRIxPTR " in state '%s' to vec 0x%" PRIxPTR,
+ (uintptr_t)task, state_vec_name(v), (uintptr_t)v);
+ v->push(task);
+}
+
+
+void
+rust_dom::remove_task_from_state_vec(ptr_vec<rust_task> *v, rust_task *task)
+{
+ log(rust_log::MEM|rust_log::TASK,
+ "removing task 0x%" PRIxPTR " in state '%s' from vec 0x%" PRIxPTR,
+ (uintptr_t)task, state_vec_name(v), (uintptr_t)v);
+ I(this, (*v)[task->idx] == task);
+ v->swapdel(task);
+}
+
+const char *
+rust_dom::state_vec_name(ptr_vec<rust_task> *v)
+{
+ if (v == &running_tasks)
+ return "running";
+ if (v == &blocked_tasks)
+ return "blocked";
+ I(this, v == &dead_tasks);
+ return "dead";
+}
+
+void
+rust_dom::reap_dead_tasks()
+{
+ for (size_t i = 0; i < dead_tasks.length(); ) {
+ rust_task *t = dead_tasks[i];
+ if (t == root_task || t->refcnt == 0) {
+ I(this, !t->waiting_tasks.length());
+ dead_tasks.swapdel(t);
+ log(rust_log::TASK,
+ "deleting unreferenced dead task 0x%" PRIxPTR, t);
+ delete t;
+ continue;
+ }
+ ++i;
+ }
+}
+
+rust_task *
+rust_dom::sched()
+{
+ I(this, this);
+ // FIXME: in the face of failing tasks, this is not always right.
+ // I(this, n_live_tasks() > 0);
+ if (running_tasks.length() > 0) {
+ size_t i = rand(&rctx);
+ i %= running_tasks.length();
+ return (rust_task *)running_tasks[i];
+ }
+ log(rust_log::DOM|rust_log::TASK,
+ "no schedulable tasks");
+ return NULL;
+}
+
+rust_crate_cache *
+rust_dom::get_cache(rust_crate const *crate) {
+ log(rust_log::CACHE,
+ "looking for crate-cache for crate 0x%" PRIxPTR, crate);
+ rust_crate_cache *cache = NULL;
+ for (size_t i = 0; i < caches.length(); ++i) {
+ rust_crate_cache *c = caches[i];
+ if (c->crate == crate) {
+ cache = c;
+ break;
+ }
+ }
+ if (!cache) {
+ log(rust_log::CACHE,
+ "making new crate-cache for crate 0x%" PRIxPTR, crate);
+ cache = new (this) rust_crate_cache(this, crate);
+ caches.push(cache);
+ }
+ cache->ref();
+ return cache;
+}
+
+
+//
+// Local Variables:
+// mode: C++
+// fill-column: 70;
+// indent-tabs-mode: nil
+// c-basic-offset: 4
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
+//
--- /dev/null
+#ifndef RUST_DWARF_H
+#define RUST_DWARF_H
+
+enum
+dw_form
+ {
+ DW_FORM_addr = 0x01,
+ DW_FORM_block2 = 0x03,
+ DW_FORM_block4 = 0x04,
+ DW_FORM_data2 = 0x05,
+ DW_FORM_data4 = 0x06,
+ DW_FORM_data8 = 0x07,
+ DW_FORM_string = 0x08,
+ DW_FORM_block = 0x09,
+ DW_FORM_block1 = 0x0a,
+ DW_FORM_data1 = 0x0b,
+ DW_FORM_flag = 0x0c,
+ DW_FORM_sdata = 0x0d,
+ DW_FORM_strp = 0x0e,
+ DW_FORM_udata = 0x0f,
+ DW_FORM_ref_addr = 0x10,
+ DW_FORM_ref1 = 0x11,
+ DW_FORM_ref2 = 0x12,
+ DW_FORM_ref4 = 0x13,
+ DW_FORM_ref8 = 0x14,
+ DW_FORM_ref_udata = 0x15,
+ DW_FORM_indirect = 0x16
+ };
+
+enum
+dw_at
+ {
+ DW_AT_sibling = 0x01,
+ DW_AT_location = 0x02,
+ DW_AT_name = 0x03,
+ DW_AT_ordering = 0x09,
+ DW_AT_byte_size = 0x0b,
+ DW_AT_bit_offset = 0x0c,
+ DW_AT_bit_size = 0x0d,
+ DW_AT_stmt_list = 0x10,
+ DW_AT_low_pc = 0x11,
+ DW_AT_high_pc = 0x12,
+ DW_AT_language = 0x13,
+ DW_AT_discr = 0x15,
+ DW_AT_discr_value = 0x16,
+ DW_AT_visibility = 0x17,
+ DW_AT_import = 0x18,
+ DW_AT_string_length = 0x19,
+ DW_AT_common_reference = 0x1a,
+ DW_AT_comp_dir = 0x1b,
+ DW_AT_const_value = 0x1c,
+ DW_AT_containing_type = 0x1d,
+ DW_AT_default_value = 0x1e,
+ DW_AT_inline = 0x20,
+ DW_AT_is_optional = 0x21,
+ DW_AT_lower_bound = 0x22,
+ DW_AT_producer = 0x25,
+ DW_AT_prototyped = 0x27,
+ DW_AT_return_addr = 0x2a,
+ DW_AT_start_scope = 0x2c,
+ DW_AT_bit_stride = 0x2e,
+ DW_AT_upper_bound = 0x2f,
+ DW_AT_abstract_origin = 0x31,
+ DW_AT_accessibility = 0x32,
+ DW_AT_address_class = 0x33,
+ DW_AT_artificial = 0x34,
+ DW_AT_base_types = 0x35,
+ DW_AT_calling_convention = 0x36,
+ DW_AT_count = 0x37,
+ DW_AT_data_member_location = 0x38,
+ DW_AT_decl_column = 0x39,
+ DW_AT_decl_file = 0x3a,
+ DW_AT_decl_line = 0x3b,
+ DW_AT_declaration = 0x3c,
+ DW_AT_discr_list = 0x3d,
+ DW_AT_encoding = 0x3e,
+ DW_AT_external = 0x3f,
+ DW_AT_frame_base = 0x40,
+ DW_AT_friend = 0x41,
+ DW_AT_identifier_case = 0x42,
+ DW_AT_macro_info = 0x43,
+ DW_AT_namelist_item = 0x44,
+ DW_AT_priority = 0x45,
+ DW_AT_segment = 0x46,
+ DW_AT_specification = 0x47,
+ DW_AT_static_link = 0x48,
+ DW_AT_type = 0x49,
+ DW_AT_use_location = 0x4a,
+ DW_AT_variable_parameter = 0x4b,
+ DW_AT_virtuality = 0x4c,
+ DW_AT_vtable_elem_location = 0x4d,
+ DW_AT_allocated = 0x4e,
+ DW_AT_associated = 0x4f,
+ DW_AT_data_location = 0x50,
+ DW_AT_byte_stride = 0x51,
+ DW_AT_entry_pc = 0x52,
+ DW_AT_use_UTF8 = 0x53,
+ DW_AT_extension = 0x54,
+ DW_AT_ranges = 0x55,
+ DW_AT_trampoline = 0x56,
+ DW_AT_call_column = 0x57,
+ DW_AT_call_file = 0x58,
+ DW_AT_call_line = 0x59,
+ DW_AT_description = 0x5a,
+ DW_AT_binary_scale = 0x5b,
+ DW_AT_decimal_scale = 0x5c,
+ DW_AT_small = 0x5d,
+ DW_AT_decimal_sign = 0x5e,
+ DW_AT_digit_count = 0x5f,
+ DW_AT_picture_string = 0x60,
+ DW_AT_mutable = 0x61,
+ DW_AT_threads_scaled = 0x62,
+ DW_AT_explicit = 0x63,
+ DW_AT_object_pointer = 0x64,
+ DW_AT_endianity = 0x65,
+ DW_AT_elemental = 0x66,
+ DW_AT_pure = 0x67,
+ DW_AT_recursive = 0x68,
+ DW_AT_lo_user = 0x2000,
+ DW_AT_hi_user = 0x3fff
+};
+
+enum
+dw_tag
+ {
+ DW_TAG_array_type = 0x01,
+ DW_TAG_class_type = 0x02,
+ DW_TAG_entry_point = 0x03,
+ DW_TAG_enumeration_type = 0x04,
+ DW_TAG_formal_parameter = 0x05,
+ DW_TAG_imported_declaration = 0x08,
+ DW_TAG_label = 0x0a,
+ DW_TAG_lexical_block = 0x0b,
+ DW_TAG_member = 0x0d,
+ DW_TAG_pointer_type = 0x0f,
+ DW_TAG_reference_type = 0x10,
+ DW_TAG_compile_unit = 0x11,
+ DW_TAG_string_type = 0x12,
+ DW_TAG_structure_type = 0x13,
+ DW_TAG_subroutine_type = 0x15,
+ DW_TAG_typedef = 0x16,
+ DW_TAG_union_type = 0x17,
+ DW_TAG_unspecified_parameters = 0x18,
+ DW_TAG_variant = 0x19,
+ DW_TAG_common_block = 0x1a,
+ DW_TAG_common_inclusion = 0x1b,
+ DW_TAG_inheritance = 0x1c,
+ DW_TAG_inlined_subroutine = 0x1d,
+ DW_TAG_module = 0x1e,
+ DW_TAG_ptr_to_member_type = 0x1f,
+ DW_TAG_set_type = 0x20,
+ DW_TAG_subrange_type = 0x21,
+ DW_TAG_with_stmt = 0x22,
+ DW_TAG_access_declaration = 0x23,
+ DW_TAG_base_type = 0x24,
+ DW_TAG_catch_block = 0x25,
+ DW_TAG_const_type = 0x26,
+ DW_TAG_constant = 0x27,
+ DW_TAG_enumerator = 0x28,
+ DW_TAG_file_type = 0x29,
+ DW_TAG_friend = 0x2a,
+ DW_TAG_namelist = 0x2b,
+ DW_TAG_namelist_item = 0x2c,
+ DW_TAG_packed_type = 0x2d,
+ DW_TAG_subprogram = 0x2e,
+ DW_TAG_template_type_parameter = 0x2f,
+ DW_TAG_template_value_parameter = 0x30,
+ DW_TAG_thrown_type = 0x31,
+ DW_TAG_try_block = 0x32,
+ DW_TAG_variant_part = 0x33,
+ DW_TAG_variable = 0x34,
+ DW_TAG_volatile_type = 0x35,
+ DW_TAG_dwarf_procedure = 0x36,
+ DW_TAG_restrict_type = 0x37,
+ DW_TAG_interface_type = 0x38,
+ DW_TAG_namespace = 0x39,
+ DW_TAG_imported_module = 0x3a,
+ DW_TAG_unspecified_type = 0x3b,
+ DW_TAG_partial_unit = 0x3c,
+ DW_TAG_imported_unit = 0x3d,
+ DW_TAG_condition = 0x3f,
+ DW_TAG_shared_type = 0x40,
+ DW_TAG_lo_user = 0x4080,
+ DW_TAG_hi_user = 0xffff,
+ };
+
+//
+// Local Variables:
+// mode: C++
+// fill-column: 78;
+// indent-tabs-mode: nil
+// c-basic-offset: 4
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
+//
+
+#endif
--- /dev/null
+#ifndef RUST_INTERNAL_H
+#define RUST_INTERNAL_H
+
+#define __STDC_LIMIT_MACROS 1
+#define __STDC_CONSTANT_MACROS 1
+#define __STDC_FORMAT_MACROS 1
+
+#include <stdlib.h>
+#include <stdint.h>
+#include <inttypes.h>
+
+#include <stdio.h>
+#include <string.h>
+
+#include "rust.h"
+
+#include "rand.h"
+#include "rust_log.h"
+#include "uthash.h"
+
+#if defined(__WIN32__)
+extern "C" {
+#include <windows.h>
+#include <tchar.h>
+#include <wincrypt.h>
+}
+#elif defined(__GNUC__)
+#include <unistd.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <dlfcn.h>
+#include <pthread.h>
+#include <errno.h>
+#else
+#error "Platform not supported."
+#endif
+
+#ifndef __i386__
+#error "Target CPU not supported."
+#endif
+
+#define I(dom, e) ((e) ? (void)0 : \
+ (dom)->srv->fatal(#e, __FILE__, __LINE__))
+
+struct rust_task;
+struct rust_port;
+class rust_chan;
+struct rust_token;
+struct rust_dom;
+class rust_crate;
+class rust_crate_cache;
+class lockfree_queue;
+
+struct stk_seg;
+struct type_desc;
+struct frame_glue_fns;
+
+// This drives our preemption scheme.
+
+static size_t const TIME_SLICE_IN_MS = 10;
+
+// Every reference counted object should derive from this base class.
+
+template <typename T>
+struct
+rc_base
+{
+ size_t refcnt;
+
+ void ref() {
+ ++refcnt;
+ }
+
+ void deref() {
+ if (--refcnt == 0) {
+ delete (T*)this;
+ }
+ }
+
+ rc_base();
+ ~rc_base();
+};
+
+template <typename T>
+struct
+dom_owned
+{
+ void operator delete(void *ptr) {
+ ((T *)ptr)->dom->free(ptr);
+ }
+};
+
+template <typename T>
+struct
+task_owned
+{
+ void operator delete(void *ptr) {
+ ((T *)ptr)->task->dom->free(ptr);
+ }
+};
+
+
+// Helper class used regularly elsewhere.
+
+template <typename T>
+class
+ptr_vec : public dom_owned<ptr_vec<T> >
+{
+ static const size_t INIT_SIZE = 8;
+
+ rust_dom *dom;
+ size_t alloc;
+ size_t fill;
+ T **data;
+
+public:
+ ptr_vec(rust_dom *dom);
+ ~ptr_vec();
+
+ size_t length() {
+ return fill;
+ }
+
+ T *& operator[](size_t offset);
+ void push(T *p);
+ T *pop();
+ void trim(size_t fill);
+ void swapdel(T* p);
+};
+
+struct
+rust_dom
+{
+ // Fields known to the compiler:
+ uintptr_t interrupt_flag;
+
+ // Fields known only by the runtime:
+
+ // NB: the root crate must remain in memory until the root of the
+ // tree of domains exits. All domains within this tree have a
+ // copy of this root_crate value and use it for finding utility
+ // glue.
+ rust_crate const *root_crate;
+ rust_log _log;
+ rust_srv *srv;
+ // uint32_t logbits;
+ ptr_vec<rust_task> running_tasks;
+ ptr_vec<rust_task> blocked_tasks;
+ ptr_vec<rust_task> dead_tasks;
+ ptr_vec<rust_crate_cache> caches;
+ randctx rctx;
+ rust_task *root_task;
+ rust_task *curr_task;
+ int rval;
+ lockfree_queue *incoming; // incoming messages from other threads
+
+#ifndef __WIN32__
+ pthread_attr_t attr;
+#endif
+
+ rust_dom(rust_srv *srv, rust_crate const *root_crate);
+ ~rust_dom();
+
+ void activate(rust_task *task);
+ void log(uint32_t logbit, char const *fmt, ...);
+ rust_log & get_log();
+ void logptr(char const *msg, uintptr_t ptrval);
+ template<typename T>
+ void logptr(char const *msg, T* ptrval);
+ void fail();
+ void *malloc(size_t sz);
+ void *calloc(size_t sz);
+ void *realloc(void *data, size_t sz);
+ void free(void *p);
+
+#ifdef __WIN32__
+ void win32_require(LPCTSTR fn, BOOL ok);
+#endif
+
+ rust_crate_cache *get_cache(rust_crate const *crate);
+ size_t n_live_tasks();
+ void add_task_to_state_vec(ptr_vec<rust_task> *v, rust_task *task);
+ void remove_task_from_state_vec(ptr_vec<rust_task> *v, rust_task *task);
+ const char *state_vec_name(ptr_vec<rust_task> *v);
+
+ void reap_dead_tasks();
+ rust_task *sched();
+};
+
+inline void *operator new(size_t sz, void *mem) {
+ return mem;
+}
+
+inline void *operator new(size_t sz, rust_dom *dom) {
+ return dom->malloc(sz);
+}
+
+inline void *operator new[](size_t sz, rust_dom *dom) {
+ return dom->malloc(sz);
+}
+
+inline void *operator new(size_t sz, rust_dom &dom) {
+ return dom.malloc(sz);
+}
+
+inline void *operator new[](size_t sz, rust_dom &dom) {
+ return dom.malloc(sz);
+}
+
+struct
+rust_timer
+{
+ // FIXME: This will probably eventually need replacement
+ // with something more sophisticated and integrated with
+ // an IO event-handling library, when we have such a thing.
+ // For now it's just the most basic "thread that can interrupt
+ // its associated domain-thread" device, so that we have
+ // *some* form of task-preemption.
+ rust_dom &dom;
+ uintptr_t exit_flag;
+
+#if defined(__WIN32__)
+ HANDLE thread;
+#else
+ pthread_attr_t attr;
+ pthread_t thread;
+#endif
+
+ rust_timer(rust_dom &dom);
+ ~rust_timer();
+};
+
+#include "rust_util.h"
+
+// Crates.
+
+template<typename T> T*
+crate_rel(rust_crate const *crate, T *t) {
+ return (T*)(((uintptr_t)crate) + ((ptrdiff_t)t));
+}
+
+template<typename T> T const*
+crate_rel(rust_crate const *crate, T const *t) {
+ return (T const*)(((uintptr_t)crate) + ((ptrdiff_t)t));
+}
+
+typedef void CDECL (*activate_glue_ty)(rust_task *);
+
+class
+rust_crate
+{
+ // The following fields are emitted by the compiler for the static
+ // rust_crate object inside each compiled crate.
+
+ ptrdiff_t image_base_off; // (Loaded image base) - this.
+ uintptr_t self_addr; // Un-relocated addres of 'this'.
+
+ ptrdiff_t debug_abbrev_off; // Offset from this to .debug_abbrev.
+ size_t debug_abbrev_sz; // Size of .debug_abbrev.
+
+ ptrdiff_t debug_info_off; // Offset from this to .debug_info.
+ size_t debug_info_sz; // Size of .debug_info.
+
+ ptrdiff_t activate_glue_off;
+ ptrdiff_t exit_task_glue_off;
+ ptrdiff_t unwind_glue_off;
+ ptrdiff_t yield_glue_off;
+
+public:
+
+ size_t n_rust_syms;
+ size_t n_c_syms;
+ size_t n_libs;
+
+ // Crates are immutable, constructed by the compiler.
+
+ uintptr_t get_image_base() const;
+ ptrdiff_t get_relocation_diff() const;
+ activate_glue_ty get_activate_glue() const;
+ uintptr_t get_exit_task_glue() const;
+ uintptr_t get_unwind_glue() const;
+ uintptr_t get_yield_glue() const;
+ struct mem_area
+ {
+ rust_dom *dom;
+ uintptr_t base;
+ uintptr_t lim;
+ mem_area(rust_dom *dom, uintptr_t pos, size_t sz);
+ };
+
+ mem_area get_debug_info(rust_dom *dom) const;
+ mem_area get_debug_abbrev(rust_dom *dom) const;
+};
+
+
+struct type_desc {
+ // First part of type_desc is known to compiler.
+ // first_param = &descs[1] if dynamic, null if static.
+ const type_desc **first_param;
+ size_t size;
+ size_t align;
+ uintptr_t copy_glue_off;
+ uintptr_t drop_glue_off;
+ uintptr_t free_glue_off;
+ uintptr_t mark_glue_off; // For GC.
+ uintptr_t obj_drop_glue_off; // For custom destructors.
+
+ // Residual fields past here are known only to runtime.
+ UT_hash_handle hh;
+ size_t n_descs;
+ const type_desc *descs[];
+};
+
+class
+rust_crate_cache : public dom_owned<rust_crate_cache>,
+ public rc_base<rust_crate_cache>
+{
+public:
+ class lib :
+ public rc_base<lib>, public dom_owned<lib>
+ {
+ uintptr_t handle;
+ public:
+ rust_dom *dom;
+ lib(rust_dom *dom, char const *name);
+ uintptr_t get_handle();
+ ~lib();
+ };
+
+ class c_sym :
+ public rc_base<c_sym>, public dom_owned<c_sym>
+ {
+ uintptr_t val;
+ lib *library;
+ public:
+ rust_dom *dom;
+ c_sym(rust_dom *dom, lib *library, char const *name);
+ uintptr_t get_val();
+ ~c_sym();
+ };
+
+ class rust_sym :
+ public rc_base<rust_sym>, public dom_owned<rust_sym>
+ {
+ uintptr_t val;
+ c_sym *crate_sym;
+ public:
+ rust_dom *dom;
+ rust_sym(rust_dom *dom, rust_crate const *curr_crate,
+ c_sym *crate_sym, char const **path);
+ uintptr_t get_val();
+ ~rust_sym();
+ };
+
+ lib *get_lib(size_t n, char const *name);
+ c_sym *get_c_sym(size_t n, lib *library, char const *name);
+ rust_sym *get_rust_sym(size_t n,
+ rust_dom *dom,
+ rust_crate const *curr_crate,
+ c_sym *crate_sym,
+ char const **path);
+ type_desc *get_type_desc(size_t size,
+ size_t align,
+ size_t n_descs,
+ type_desc const **descs);
+
+private:
+
+ rust_sym **rust_syms;
+ c_sym **c_syms;
+ lib **libs;
+ type_desc *type_descs;
+
+public:
+
+ rust_crate const *crate;
+ rust_dom *dom;
+ size_t idx;
+
+ rust_crate_cache(rust_dom *dom,
+ rust_crate const *crate);
+ ~rust_crate_cache();
+ void flush();
+};
+
+#include "rust_dwarf.h"
+
+class
+rust_crate_reader
+{
+ struct mem_reader
+ {
+ rust_crate::mem_area &mem;
+ bool ok;
+ uintptr_t pos;
+
+ bool is_ok();
+ bool at_end();
+ void fail();
+ void reset();
+ mem_reader(rust_crate::mem_area &m);
+ size_t tell_abs();
+ size_t tell_off();
+ void seek_abs(uintptr_t p);
+ void seek_off(uintptr_t p);
+
+ template<typename T>
+ void get(T &out) {
+ if (pos < mem.base
+ || pos >= mem.lim
+ || pos + sizeof(T) > mem.lim)
+ ok = false;
+ if (!ok)
+ return;
+ out = *((T*)(pos));
+ pos += sizeof(T);
+ ok &= !at_end();
+ I(mem.dom, at_end() || (mem.base <= pos && pos < mem.lim));
+ }
+
+ template<typename T>
+ void get_uleb(T &out) {
+ out = T(0);
+ for (size_t i = 0; i < sizeof(T) && ok; ++i) {
+ uint8_t byte;
+ get(byte);
+ out <<= 7;
+ out |= byte & 0x7f;
+ if (!(byte & 0x80))
+ break;
+ }
+ I(mem.dom, at_end() || (mem.base <= pos && pos < mem.lim));
+ }
+
+ template<typename T>
+ void adv_sizeof(T &) {
+ adv(sizeof(T));
+ }
+
+ bool adv_zstr(size_t sz);
+ bool get_zstr(char const *&c, size_t &sz);
+ void adv(size_t amt);
+ };
+
+ struct
+ abbrev : dom_owned<abbrev>
+ {
+ rust_dom *dom;
+ uintptr_t body_off;
+ size_t body_sz;
+ uintptr_t tag;
+ uint8_t has_children;
+ size_t idx;
+ abbrev(rust_dom *dom, uintptr_t body_off, size_t body_sz,
+ uintptr_t tag, uint8_t has_children);
+ };
+
+ class
+ abbrev_reader : public mem_reader
+ {
+ ptr_vec<abbrev> abbrevs;
+ public:
+ abbrev_reader(rust_crate::mem_area &abbrev_mem);
+ abbrev *get_abbrev(size_t i);
+ bool step_attr_form_pair(uintptr_t &attr, uintptr_t &form);
+ ~abbrev_reader();
+ };
+
+ rust_dom *dom;
+ size_t idx;
+ rust_crate const *crate;
+
+ rust_crate::mem_area abbrev_mem;
+ abbrev_reader abbrevs;
+
+ rust_crate::mem_area die_mem;
+
+public:
+
+ struct
+ attr
+ {
+ dw_form form;
+ dw_at at;
+ union {
+ struct {
+ char const *s;
+ size_t sz;
+ } str;
+ uintptr_t num;
+ } val;
+
+ bool is_numeric() const;
+ bool is_string() const;
+ size_t get_ssz(rust_dom *dom) const;
+ char const *get_str(rust_dom *dom) const;
+ uintptr_t get_num(rust_dom *dom) const;
+ bool is_unknown() const;
+ };
+
+ struct die_reader;
+
+ struct
+ die
+ {
+ die_reader *rdr;
+ uintptr_t off;
+ abbrev *ab;
+ bool using_rdr;
+
+ die(die_reader *rdr, uintptr_t off);
+ bool is_null() const;
+ bool has_children() const;
+ dw_tag tag() const;
+ bool start_attrs() const;
+ bool step_attr(attr &a) const;
+ bool find_str_attr(dw_at at, char const *&c);
+ bool find_num_attr(dw_at at, uintptr_t &n);
+ bool is_transparent();
+ bool find_child_by_name(char const *c, die &child,
+ bool exact=false);
+ bool find_child_by_tag(dw_tag tag, die &child);
+ die next() const;
+ die next_sibling() const;
+ };
+
+ struct
+ rdr_sess
+ {
+ die_reader *rdr;
+ rdr_sess(die_reader *rdr);
+ ~rdr_sess();
+ };
+
+ struct
+ die_reader : public mem_reader
+ {
+ abbrev_reader &abbrevs;
+ uint32_t cu_unit_length;
+ uintptr_t cu_base;
+ uint16_t dwarf_vers;
+ uint32_t cu_abbrev_off;
+ uint8_t sizeof_addr;
+ bool in_use;
+
+ die first_die();
+ void dump();
+ die_reader(rust_crate::mem_area &die_mem,
+ abbrev_reader &abbrevs);
+ ~die_reader();
+ };
+ die_reader dies;
+ rust_crate_reader(rust_dom *dom, rust_crate const *crate);
+};
+
+
+// A cond(ition) is something we can block on. This can be a channel
+// (writing), a port (reading) or a task (waiting).
+
+struct
+rust_cond
+{
+};
+
+// An alarm can be put into a wait queue and the task will be notified
+// when the wait queue is flushed.
+
+struct
+rust_alarm
+{
+ rust_task *receiver;
+ size_t idx;
+
+ rust_alarm(rust_task *receiver);
+};
+
+
+typedef ptr_vec<rust_alarm> rust_wait_queue;
+
+
+struct stk_seg {
+ unsigned int valgrind_id;
+ uintptr_t limit;
+ uint8_t data[];
+};
+
+struct frame_glue_fns {
+ uintptr_t mark_glue_off;
+ uintptr_t drop_glue_off;
+ uintptr_t reloc_glue_off;
+};
+
+struct
+rust_task : public rc_base<rust_task>,
+ public dom_owned<rust_task>,
+ public rust_cond
+{
+ // Fields known to the compiler.
+ stk_seg *stk;
+ uintptr_t runtime_sp; // Runtime sp while task running.
+ uintptr_t rust_sp; // Saved sp when not running.
+ uintptr_t gc_alloc_chain; // Linked list of GC allocations.
+ rust_dom *dom;
+ rust_crate_cache *cache;
+
+ // Fields known only to the runtime.
+ ptr_vec<rust_task> *state;
+ rust_cond *cond;
+ uintptr_t* dptr; // Rendezvous pointer for send/recv.
+ rust_task *spawner; // Parent-link.
+ size_t idx;
+
+ // Wait queue for tasks waiting for this task.
+ rust_wait_queue waiting_tasks;
+ rust_alarm alarm;
+
+ rust_task(rust_dom *dom,
+ rust_task *spawner);
+ ~rust_task();
+
+ void start(uintptr_t exit_task_glue,
+ uintptr_t spawnee_fn,
+ uintptr_t args,
+ size_t callsz);
+ void grow(size_t n_frame_bytes);
+ bool running();
+ bool blocked();
+ bool blocked_on(rust_cond *cond);
+ bool dead();
+
+ const char *state_str();
+ void transition(ptr_vec<rust_task> *svec, ptr_vec<rust_task> *dvec);
+
+ void block(rust_cond *on);
+ void wakeup(rust_cond *from);
+ void die();
+ void unblock();
+
+ void check_active() { I(dom, dom->curr_task == this); }
+ void check_suspended() { I(dom, dom->curr_task != this); }
+
+ // Swap in some glue code to run when we have returned to the
+ // task's context (assuming we're the active task).
+ void run_after_return(size_t nargs, uintptr_t glue);
+
+ // Swap in some glue code to run when we're next activated
+ // (assuming we're the suspended task).
+ void run_on_resume(uintptr_t glue);
+
+ // Save callee-saved registers and return to the main loop.
+ void yield(size_t nargs);
+
+ // Fail this task (assuming caller-on-stack is different task).
+ void kill();
+
+ // Fail self, assuming caller-on-stack is this task.
+ void fail(size_t nargs);
+
+ // Notify tasks waiting for us that we are about to die.
+ void notify_waiting_tasks();
+
+ uintptr_t get_fp();
+ uintptr_t get_previous_fp(uintptr_t fp);
+ frame_glue_fns *get_frame_glue_fns(uintptr_t fp);
+ rust_crate_cache * get_crate_cache(rust_crate const *curr_crate);
+};
+
+struct rust_port : public rc_base<rust_port>,
+ public task_owned<rust_port>,
+ public rust_cond {
+ rust_task *task;
+ size_t unit_sz;
+ ptr_vec<rust_token> writers;
+ ptr_vec<rust_chan> chans;
+
+ rust_port(rust_task *task, size_t unit_sz);
+ ~rust_port();
+};
+
+struct rust_token : public rust_cond {
+ rust_chan *chan; // Link back to the channel this token belongs to
+ size_t idx; // Index into port->writers.
+ bool submitted; // Whether token is in a port->writers.
+
+ rust_token(rust_chan *chan);
+ ~rust_token();
+
+ bool pending() const;
+ void submit();
+ void withdraw();
+};
+
+
+struct circ_buf : public dom_owned<circ_buf> {
+ static const size_t INIT_CIRC_BUF_UNITS = 8;
+ static const size_t MAX_CIRC_BUF_SIZE = 1 << 24;
+
+ rust_dom *dom;
+ size_t alloc;
+ size_t unit_sz;
+ size_t next;
+ size_t unread;
+ uint8_t *data;
+
+ circ_buf(rust_dom *dom, size_t unit_sz);
+ ~circ_buf();
+
+ void transfer(void *dst);
+ void push(void *src);
+ void shift(void *dst);
+};
+
+#include "rust_chan.h"
+
+int
+rust_main_loop(rust_dom *dom);
+
+//
+// Local Variables:
+// mode: C++
+// fill-column: 78;
+// indent-tabs-mode: nil
+// c-basic-offset: 4
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
+//
+
+#endif
--- /dev/null
+/*
+ * Logging infrastructure that aims to support multi-threading, indentation
+ * and ansi colors.
+ */
+
+#include "rust_internal.h"
+
+static uint32_t read_type_bit_mask() {
+ uint32_t bits = rust_log::ULOG | rust_log::ERR;
+ char *env_str = getenv("RUST_LOG");
+ if (env_str) {
+ bits = 0;
+ bits |= strstr(env_str, "err") ? rust_log::ERR : 0;
+ bits |= strstr(env_str, "mem") ? rust_log::MEM : 0;
+ bits |= strstr(env_str, "comm") ? rust_log::COMM : 0;
+ bits |= strstr(env_str, "task") ? rust_log::TASK : 0;
+ bits |= strstr(env_str, "up") ? rust_log::UPCALL : 0;
+ bits |= strstr(env_str, "dom") ? rust_log::DOM : 0;
+ bits |= strstr(env_str, "ulog") ? rust_log::ULOG : 0;
+ bits |= strstr(env_str, "trace") ? rust_log::TRACE : 0;
+ bits |= strstr(env_str, "dwarf") ? rust_log::DWARF : 0;
+ bits |= strstr(env_str, "cache") ? rust_log::CACHE : 0;
+ bits |= strstr(env_str, "timer") ? rust_log::TIMER : 0;
+ bits |= strstr(env_str, "all") ? rust_log::ALL : 0;
+ }
+ return bits;
+}
+
+rust_log::ansi_color rust_log::get_type_color(log_type type) {
+ switch (type) {
+ case ERR:
+ return rust_log::RED;
+ case UPCALL:
+ return rust_log::GREEN;
+ case COMM:
+ return rust_log::MAGENTA;
+ case DOM:
+ case TASK:
+ return rust_log::LIGHTTEAL;
+ case MEM:
+ return rust_log::YELLOW;
+ default:
+ return rust_log::WHITE;
+ }
+}
+
+static const char * _foreground_colors[] = { "[30m", "[1;30m", "[37m",
+ "[31m", "[1;31m", "[32m",
+ "[1;32m", "[33m", "[33m",
+ "[34m", "[1;34m", "[35m",
+ "[1;35m", "[36m", "[1;36m" };
+rust_log::rust_log(rust_srv *srv, rust_dom *dom) :
+ _srv(srv), _dom(dom), _type_bit_mask(read_type_bit_mask()),
+ _use_colors(getenv("RUST_COLOR_LOG")), _indent(0) {
+}
+
+rust_log::~rust_log() {
+
+}
+
+void rust_log::trace_ln(char *message) {
+ char buffer[512];
+ if (_use_colors) {
+ snprintf(buffer, sizeof(buffer), "\x1b%s0x%08" PRIxPTR "\x1b[0m: ",
+ _foreground_colors[1 + ((uintptr_t) _dom % 2687 % (LIGHTTEAL
+ - 1))], (uintptr_t) _dom);
+ } else {
+ snprintf(buffer, sizeof(buffer), "0x%08" PRIxPTR ": ",
+ (uintptr_t) _dom);
+ }
+
+ for (uint32_t i = 0; i < _indent; i++) {
+ strncat(buffer, "\t", sizeof(buffer) - strlen(buffer) - 1);
+ }
+ strncat(buffer, message, sizeof(buffer) - strlen(buffer) - 1);
+ _srv->log(buffer);
+}
+
+/**
+ * Traces a log message if the specified logging type is not filtered.
+ */
+void rust_log::trace_ln(uint32_t type_bits, char *message) {
+ trace_ln(get_type_color((rust_log::log_type) type_bits), type_bits,
+ message);
+}
+
+/**
+ * Traces a log message using the specified ANSI color code.
+ */
+void rust_log::trace_ln(ansi_color color, uint32_t type_bits, char *message) {
+ if (is_tracing(type_bits)) {
+ if (_use_colors) {
+ char buffer[512];
+ snprintf(buffer, sizeof(buffer), "\x1b%s%s\x1b[0m",
+ _foreground_colors[color], message);
+ trace_ln(buffer);
+ } else {
+ trace_ln(message);
+ }
+ }
+}
+
+bool rust_log::is_tracing(uint32_t type_bits) {
+ return type_bits & _type_bit_mask;
+}
+
+void rust_log::indent() {
+ _indent++;
+}
+
+void rust_log::outdent() {
+ _indent--;
+}
+
+void rust_log::reset_indent(uint32_t indent) {
+ _indent = indent;
+}
--- /dev/null
+#ifndef RUST_LOG_H_
+#define RUST_LOG_H_
+
+class rust_dom;
+
+class rust_log {
+ rust_srv *_srv;
+ rust_dom *_dom;
+ uint32_t _type_bit_mask;
+ bool _use_colors;
+ uint32_t _indent;
+ void trace_ln(char *message);
+public:
+ rust_log(rust_srv *srv, rust_dom *dom);
+ virtual ~rust_log();
+
+ enum ansi_color {
+ BLACK,
+ GRAY,
+ WHITE,
+ RED,
+ LIGHTRED,
+ GREEN,
+ LIGHTGREEN,
+ YELLOW,
+ LIGHTYELLOW,
+ BLUE,
+ LIGHTBLUE,
+ MAGENTA,
+ LIGHTMAGENTA,
+ TEAL,
+ LIGHTTEAL
+ };
+
+ enum log_type {
+ ERR = 0x1,
+ MEM = 0x2,
+ COMM = 0x4,
+ TASK = 0x8,
+ DOM = 0x10,
+ ULOG = 0x20,
+ TRACE = 0x40,
+ DWARF = 0x80,
+ CACHE = 0x100,
+ UPCALL = 0x200,
+ TIMER = 0x400,
+ ALL = 0xffffffff
+ };
+
+ void indent();
+ void outdent();
+ void reset_indent(uint32_t indent);
+ void trace_ln(uint32_t type_bits, char *message);
+ void trace_ln(ansi_color color, uint32_t type_bits, char *message);
+ bool is_tracing(uint32_t type_bits);
+ static ansi_color get_type_color(log_type type);
+};
+
+#endif /* RUST_LOG_H_ */
--- /dev/null
+
+#include "rust_internal.h"
+
+#include "valgrind.h"
+#include "memcheck.h"
+
+// Stacks
+
+static size_t const min_stk_bytes = 0x300;
+
+// Task stack segments. Heap allocated and chained together.
+
+static stk_seg*
+new_stk(rust_dom *dom, size_t minsz)
+{
+ if (minsz < min_stk_bytes)
+ minsz = min_stk_bytes;
+ size_t sz = sizeof(stk_seg) + minsz;
+ stk_seg *stk = (stk_seg *)dom->malloc(sz);
+ dom->logptr("new stk", (uintptr_t)stk);
+ memset(stk, 0, sizeof(stk_seg));
+ stk->limit = (uintptr_t) &stk->data[minsz];
+ dom->logptr("stk limit", stk->limit);
+ stk->valgrind_id =
+ VALGRIND_STACK_REGISTER(&stk->data[0],
+ &stk->data[minsz]);
+ return stk;
+}
+
+static void
+del_stk(rust_dom *dom, stk_seg *stk)
+{
+ VALGRIND_STACK_DEREGISTER(stk->valgrind_id);
+ dom->logptr("freeing stk segment", (uintptr_t)stk);
+ dom->free(stk);
+}
+
+// Tasks
+
+// FIXME (issue #31): ifdef by platform. This is getting absurdly
+// x86-specific.
+
+size_t const n_callee_saves = 4;
+size_t const callee_save_fp = 0;
+
+static uintptr_t
+align_down(uintptr_t sp)
+{
+ // There is no platform we care about that needs more than a
+ // 16-byte alignment.
+ return sp & ~(16 - 1);
+}
+
+
+rust_task::rust_task(rust_dom *dom, rust_task *spawner) :
+ stk(new_stk(dom, 0)),
+ runtime_sp(0),
+ rust_sp(stk->limit),
+ gc_alloc_chain(0),
+ dom(dom),
+ cache(NULL),
+ state(&dom->running_tasks),
+ cond(NULL),
+ dptr(0),
+ spawner(spawner),
+ idx(0),
+ waiting_tasks(dom),
+ alarm(this)
+{
+ dom->logptr("new task", (uintptr_t)this);
+}
+
+rust_task::~rust_task()
+{
+ dom->log(rust_log::MEM|rust_log::TASK,
+ "~rust_task 0x%" PRIxPTR ", refcnt=%d",
+ (uintptr_t)this, refcnt);
+
+ /*
+ for (uintptr_t fp = get_fp(); fp; fp = get_previous_fp(fp)) {
+ frame_glue_fns *glue_fns = get_frame_glue_fns(fp);
+ dom->log(rust_log::MEM|rust_log::TASK,
+ "~rust_task, frame fp=0x%" PRIxPTR ", glue_fns=0x%" PRIxPTR,
+ fp, glue_fns);
+ if (glue_fns) {
+ dom->log(rust_log::MEM|rust_log::TASK,
+ "~rust_task, mark_glue=0x%" PRIxPTR,
+ glue_fns->mark_glue);
+ dom->log(rust_log::MEM|rust_log::TASK,
+ "~rust_task, drop_glue=0x%" PRIxPTR,
+ glue_fns->drop_glue);
+ dom->log(rust_log::MEM|rust_log::TASK,
+ "~rust_task, reloc_glue=0x%" PRIxPTR,
+ glue_fns->reloc_glue);
+ }
+ }
+ */
+
+ /* FIXME: tighten this up, there are some more
+ assertions that hold at task-lifecycle events. */
+ I(dom, refcnt == 0 ||
+ (refcnt == 1 && this == dom->root_task));
+
+ del_stk(dom, stk);
+ if (cache)
+ cache->deref();
+}
+
+void
+rust_task::start(uintptr_t exit_task_glue,
+ uintptr_t spawnee_fn,
+ uintptr_t args,
+ size_t callsz)
+{
+ dom->logptr("exit-task glue", exit_task_glue);
+ dom->logptr("from spawnee", spawnee_fn);
+
+ // Set sp to last uintptr_t-sized cell of segment and align down.
+ rust_sp -= sizeof(uintptr_t);
+ rust_sp = align_down(rust_sp);
+
+ // Begin synthesizing frames. There are two: a "fully formed"
+ // exit-task frame at the top of the stack -- that pretends to be
+ // mid-execution -- and a just-starting frame beneath it that
+ // starts executing the first instruction of the spawnee. The
+ // spawnee *thinks* it was called by the exit-task frame above
+ // it. It wasn't; we put that fake frame in place here, but the
+ // illusion is enough for the spawnee to return to the exit-task
+ // frame when it's done, and exit.
+ uintptr_t *spp = (uintptr_t *)rust_sp;
+
+ // The exit_task_glue frame we synthesize above the frame we activate:
+ *spp-- = (uintptr_t) this; // task
+ *spp-- = (uintptr_t) 0; // output
+ *spp-- = (uintptr_t) 0; // retpc
+ for (size_t j = 0; j < n_callee_saves; ++j) {
+ *spp-- = 0;
+ }
+
+ // We want 'frame_base' to point to the last callee-save in this
+ // (exit-task) frame, because we're going to inject this
+ // frame-pointer into the callee-save frame pointer value in the
+ // *next* (spawnee) frame. A cheap trick, but this means the
+ // spawnee frame will restore the proper frame pointer of the glue
+ // frame as it runs its epilogue.
+ uintptr_t frame_base = (uintptr_t) (spp+1);
+
+ *spp-- = (uintptr_t) dom->root_crate; // crate ptr
+ *spp-- = (uintptr_t) 0; // frame_glue_fns
+
+ // Copy args from spawner to spawnee.
+ if (args) {
+ uintptr_t *src = (uintptr_t *)args;
+ src += 1; // spawn-call output slot
+ src += 1; // spawn-call task slot
+ // Memcpy all but the task and output pointers
+ callsz -= (2 * sizeof(uintptr_t));
+ spp = (uintptr_t*) (((uintptr_t)spp) - callsz);
+ memcpy(spp, src, callsz);
+
+ // Move sp down to point to task cell.
+ spp--;
+ } else {
+ // We're at root, starting up.
+ I(dom, callsz==0);
+ }
+
+ // The *implicit* incoming args to the spawnee frame we're
+ // activating:
+
+ *spp-- = (uintptr_t) this; // task
+ *spp-- = (uintptr_t) 0; // output addr
+ *spp-- = (uintptr_t) exit_task_glue; // retpc
+
+ // The context the activate_glue needs to switch stack.
+ *spp-- = (uintptr_t) spawnee_fn; // instruction to start at
+ for (size_t j = 0; j < n_callee_saves; ++j) {
+ // callee-saves to carry in when we activate
+ if (j == callee_save_fp)
+ *spp-- = frame_base;
+ else
+ *spp-- = NULL;
+ }
+
+ // Back up one, we overshot where sp should be.
+ rust_sp = (uintptr_t) (spp+1);
+
+ dom->add_task_to_state_vec(&dom->running_tasks, this);
+}
+
+void
+rust_task::grow(size_t n_frame_bytes)
+{
+ stk_seg *old_stk = this->stk;
+ uintptr_t old_top = (uintptr_t) old_stk->limit;
+ uintptr_t old_bottom = (uintptr_t) &old_stk->data[0];
+ uintptr_t rust_sp_disp = old_top - this->rust_sp;
+ size_t ssz = old_top - old_bottom;
+ dom->log(rust_log::MEM|rust_log::TASK|rust_log::UPCALL,
+ "upcall_grow_task(%" PRIdPTR
+ "), old size %" PRIdPTR
+ " bytes (old lim: 0x%" PRIxPTR ")",
+ n_frame_bytes, ssz, old_top);
+ ssz *= 2;
+ if (ssz < n_frame_bytes)
+ ssz = n_frame_bytes;
+ ssz = next_power_of_two(ssz);
+
+ dom->log(rust_log::MEM|rust_log::TASK, "upcall_grow_task growing stk 0x%"
+ PRIxPTR " to %d bytes", old_stk, ssz);
+
+ stk_seg *nstk = new_stk(dom, ssz);
+ uintptr_t new_top = (uintptr_t) &nstk->data[ssz];
+ size_t n_copy = old_top - old_bottom;
+ dom->log(rust_log::MEM|rust_log::TASK,
+ "copying %d bytes of stack from [0x%" PRIxPTR ", 0x%" PRIxPTR "]"
+ " to [0x%" PRIxPTR ", 0x%" PRIxPTR "]",
+ n_copy,
+ old_bottom, old_bottom + n_copy,
+ new_top - n_copy, new_top);
+
+ VALGRIND_MAKE_MEM_DEFINED((void*)old_bottom, n_copy);
+ memcpy((void*)(new_top - n_copy), (void*)old_bottom, n_copy);
+
+ nstk->limit = new_top;
+ this->stk = nstk;
+ this->rust_sp = new_top - rust_sp_disp;
+
+ dom->log(rust_log::MEM|rust_log::TASK, "processing relocations");
+
+ // FIXME (issue #32): this is the most ridiculously crude
+ // relocation scheme ever. Try actually, you know, writing out
+ // reloc descriptors?
+ size_t n_relocs = 0;
+ for (uintptr_t* p = (uintptr_t*)(new_top - n_copy);
+ p < (uintptr_t*)new_top; ++p) {
+ if (old_bottom <= *p && *p < old_top) {
+ //dom->log(rust_log::MEM, "relocating pointer 0x%" PRIxPTR
+ // " by %d bytes", *p, (new_top - old_top));
+ n_relocs++;
+ *p += (new_top - old_top);
+ }
+ }
+ dom->log(rust_log::MEM|rust_log::TASK,
+ "processed %d relocations", n_relocs);
+ del_stk(dom, old_stk);
+ dom->logptr("grown stk limit", new_top);
+}
+
+void
+push_onto_thread_stack(uintptr_t &sp, uintptr_t value)
+{
+ asm("xchgl %0, %%esp\n"
+ "push %2\n"
+ "xchgl %0, %%esp\n"
+ : "=r" (sp)
+ : "0" (sp), "r" (value)
+ : "eax");
+}
+
+void
+rust_task::run_after_return(size_t nargs, uintptr_t glue)
+{
+ // This is only safe to call if we're the currently-running task.
+ check_active();
+
+ uintptr_t sp = runtime_sp;
+
+ // The compiler reserves nargs + 1 word for oldsp on the stack and
+ // then aligns it.
+ sp = align_down(sp - nargs * sizeof(uintptr_t));
+
+ uintptr_t *retpc = ((uintptr_t *) sp) - 1;
+ dom->log(rust_log::TASK|rust_log::MEM,
+ "run_after_return: overwriting retpc=0x%" PRIxPTR
+ " @ runtime_sp=0x%" PRIxPTR
+ " with glue=0x%" PRIxPTR,
+ *retpc, sp, glue);
+
+ // Move the current return address (which points into rust code)
+ // onto the rust stack and pretend we just called into the glue.
+ push_onto_thread_stack(rust_sp, *retpc);
+ *retpc = glue;
+}
+
+void
+rust_task::run_on_resume(uintptr_t glue)
+{
+ // This is only safe to call if we're suspended.
+ check_suspended();
+
+ // Inject glue as resume address in the suspended frame.
+ uintptr_t* rsp = (uintptr_t*) rust_sp;
+ rsp += n_callee_saves;
+ dom->log(rust_log::TASK|rust_log::MEM,
+ "run_on_resume: overwriting retpc=0x%" PRIxPTR
+ " @ rust_sp=0x%" PRIxPTR
+ " with glue=0x%" PRIxPTR,
+ *rsp, rsp, glue);
+ *rsp = glue;
+}
+
+void
+rust_task::yield(size_t nargs)
+{
+ dom->log(rust_log::TASK,
+ "task 0x%" PRIxPTR " yielding", this);
+ run_after_return(nargs, dom->root_crate->get_yield_glue());
+}
+
+static inline uintptr_t
+get_callee_save_fp(uintptr_t *top_of_callee_saves)
+{
+ return top_of_callee_saves[n_callee_saves - (callee_save_fp + 1)];
+}
+
+void
+rust_task::kill() {
+ // Note the distinction here: kill() is when you're in an upcall
+ // from task A and want to force-fail task B, you do B->kill().
+ // If you want to fail yourself you do self->fail(upcall_nargs).
+ dom->log(rust_log::TASK, "killing task 0x%" PRIxPTR, this);
+ // Unblock the task so it can unwind.
+ unblock();
+ if (this == dom->root_task)
+ dom->fail();
+ run_on_resume(dom->root_crate->get_unwind_glue());
+}
+
+void
+rust_task::fail(size_t nargs) {
+ // See note in ::kill() regarding who should call this.
+ dom->log(rust_log::TASK, "task 0x%" PRIxPTR " failing", this);
+ // Unblock the task so it can unwind.
+ unblock();
+ if (this == dom->root_task)
+ dom->fail();
+ run_after_return(nargs, dom->root_crate->get_unwind_glue());
+ if (spawner) {
+ dom->log(rust_log::TASK,
+ "task 0x%" PRIxPTR
+ " propagating failure to parent 0x%" PRIxPTR,
+ this, spawner);
+ spawner->kill();
+ }
+}
+
+void
+rust_task::notify_waiting_tasks()
+{
+ while (waiting_tasks.length() > 0) {
+ rust_task *t = waiting_tasks.pop()->receiver;
+ if (!t->dead())
+ t->wakeup(this);
+ }
+}
+
+uintptr_t
+rust_task::get_fp() {
+ // sp in any suspended task points to the last callee-saved reg on
+ // the task stack.
+ return get_callee_save_fp((uintptr_t*)rust_sp);
+}
+
+uintptr_t
+rust_task::get_previous_fp(uintptr_t fp) {
+ // fp happens to, coincidentally (!) also point to the last
+ // callee-save on the task stack.
+ return get_callee_save_fp((uintptr_t*)fp);
+}
+
+frame_glue_fns*
+rust_task::get_frame_glue_fns(uintptr_t fp) {
+ fp -= sizeof(uintptr_t);
+ return *((frame_glue_fns**) fp);
+}
+
+bool
+rust_task::running()
+{
+ return state == &dom->running_tasks;
+}
+
+bool
+rust_task::blocked()
+{
+ return state == &dom->blocked_tasks;
+}
+
+bool
+rust_task::blocked_on(rust_cond *on)
+{
+ return blocked() && cond == on;
+}
+
+bool
+rust_task::dead()
+{
+ return state == &dom->dead_tasks;
+}
+
+void
+rust_task::transition(ptr_vec<rust_task> *src, ptr_vec<rust_task> *dst)
+{
+ I(dom, state == src);
+ dom->log(rust_log::TASK,
+ "task 0x%" PRIxPTR " state change '%s' -> '%s'",
+ (uintptr_t)this,
+ dom->state_vec_name(src),
+ dom->state_vec_name(dst));
+ dom->remove_task_from_state_vec(src, this);
+ dom->add_task_to_state_vec(dst, this);
+ state = dst;
+}
+
+void
+rust_task::block(rust_cond *on)
+{
+ I(dom, on);
+ transition(&dom->running_tasks, &dom->blocked_tasks);
+ dom->log(rust_log::TASK,
+ "task 0x%" PRIxPTR " blocking on 0x%" PRIxPTR,
+ (uintptr_t)this,
+ (uintptr_t)on);
+ cond = on;
+}
+
+void
+rust_task::wakeup(rust_cond *from)
+{
+ transition(&dom->blocked_tasks, &dom->running_tasks);
+ I(dom, cond == from);
+}
+
+void
+rust_task::die()
+{
+ transition(&dom->running_tasks, &dom->dead_tasks);
+}
+
+void
+rust_task::unblock()
+{
+ if (blocked())
+ wakeup(cond);
+}
+
+rust_crate_cache *
+rust_task::get_crate_cache(rust_crate const *curr_crate)
+{
+ if (cache && cache->crate != curr_crate) {
+ dom->log(rust_log::TASK, "switching task crate-cache to crate 0x%"
+ PRIxPTR, curr_crate);
+ cache->deref();
+ cache = NULL;
+ }
+
+ if (!cache) {
+ dom->log(rust_log::TASK, "fetching cache for current crate");
+ cache = dom->get_cache(curr_crate);
+ }
+ return cache;
+}
+
+//
+// Local Variables:
+// mode: C++
+// fill-column: 78;
+// indent-tabs-mode: nil
+// c-basic-offset: 4
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
+//
--- /dev/null
+
+#include "rust_internal.h"
+
+// The mechanism in this file is very crude; every domain (thread) spawns its
+// own secondary timer thread, and that timer thread *never idles*. It
+// sleep-loops interrupting the domain.
+//
+// This will need replacement, particularly in order to achieve an actual
+// state of idling when we're waiting on the outside world. Though that might
+// be as simple as making a secondary waitable start/stop-timer signalling
+// system between the domain and its timer thread. We'll see.
+//
+// On the other hand, we don't presently have the ability to idle domains *at
+// all*, and without the timer thread we're unable to otherwise preempt rust
+// tasks. So ... one step at a time.
+//
+// The implementation here is "lockless" in the sense that it only involves
+// one-directional signaling of one-shot events, so the event initiator just
+// writes a nonzero word to a prederermined location and waits for the
+// receiver to see it show up in their memory.
+
+#if defined(__WIN32__)
+static DWORD WINAPI
+win32_timer_loop(void *ptr)
+{
+ // We were handed the rust_timer that owns us.
+ rust_timer *timer = (rust_timer *)ptr;
+ rust_dom &dom = timer->dom;
+ dom.log(LOG_TIMER, "in timer 0x%" PRIxPTR, (uintptr_t)timer);
+ while (!timer->exit_flag) {
+ Sleep(TIME_SLICE_IN_MS);
+ dom.log(LOG_TIMER,
+ "timer 0x%" PRIxPTR
+ " interrupting domain 0x%" PRIxPTR,
+ (uintptr_t)timer,
+ (uintptr_t)&dom);
+ dom.interrupt_flag = 1;
+ }
+ ExitThread(0);
+ return 0;
+}
+
+#elif defined(__GNUC__)
+static void *
+pthread_timer_loop(void *ptr)
+{
+ // We were handed the rust_timer that owns us.
+ rust_timer *timer = (rust_timer *)ptr;
+ rust_dom &dom(timer->dom);
+ while (!timer->exit_flag) {
+ usleep(TIME_SLICE_IN_MS * 1000);
+ dom.interrupt_flag = 1;
+ }
+ pthread_exit(NULL);
+ return 0;
+
+}
+#else
+#error "Platform not supported"
+#endif
+
+
+rust_timer::rust_timer(rust_dom &dom) : dom(dom), exit_flag(0)
+{
+ dom.log(rust_log::TIMER, "creating timer for domain 0x%" PRIxPTR, &dom);
+#if defined(__WIN32__)
+ thread = CreateThread(NULL, 0, win32_timer_loop, this, 0, NULL);
+ dom.win32_require("CreateThread", thread != NULL);
+#else
+ pthread_attr_init(&attr);
+ pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE);
+ pthread_create(&thread, &attr, pthread_timer_loop, (void *)this);
+#endif
+}
+
+rust_timer::~rust_timer()
+{
+ exit_flag = 1;
+#if defined(__WIN32__)
+ dom.win32_require("WaitForSingleObject",
+ WaitForSingleObject(thread, INFINITE)
+ == WAIT_OBJECT_0);
+#else
+ pthread_join(thread, NULL);
+#endif
+}
+
+//
+// Local Variables:
+// mode: C++
+// fill-column: 78;
+// indent-tabs-mode: nil
+// c-basic-offset: 4
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
+//
--- /dev/null
+
+#include "rust_internal.h"
+
+
+// Upcalls.
+
+#ifdef __GNUC__
+#define LOG_UPCALL_ENTRY(task) \
+ (task)->dom->get_log().reset_indent(0); \
+ (task)->dom->log(rust_log::UPCALL, \
+ "upcall task: 0x%" PRIxPTR \
+ " retpc: 0x%" PRIxPTR, \
+ (task), __builtin_return_address(0)); \
+ (task)->dom->get_log().indent();
+#else
+#define LOG_UPCALL_ENTRY(task) \
+ (task)->dom->get_log().reset_indent(0); \
+ (task)->dom->log(rust_log::UPCALL, \
+ "upcall task: 0x%" PRIxPTR (task)); \
+ (task)->dom->get_log().indent();
+#endif
+
+extern "C" CDECL char const *str_buf(rust_task *task, rust_str *s);
+
+extern "C" void
+upcall_grow_task(rust_task *task, size_t n_frame_bytes)
+{
+ LOG_UPCALL_ENTRY(task);
+ task->grow(n_frame_bytes);
+}
+
+extern "C" CDECL void
+upcall_log_int(rust_task *task, int32_t i)
+{
+ LOG_UPCALL_ENTRY(task);
+ task->dom->log(rust_log::UPCALL|rust_log::ULOG,
+ "upcall log_int(0x%" PRIx32 " = %" PRId32 " = '%c')",
+ i, i, (char)i);
+}
+
+extern "C" CDECL void
+upcall_log_str(rust_task *task, rust_str *str)
+{
+ LOG_UPCALL_ENTRY(task);
+ const char *c = str_buf(task, str);
+ task->dom->log(rust_log::UPCALL|rust_log::ULOG,
+ "upcall log_str(\"%s\")",
+ c);
+}
+
+extern "C" CDECL void
+upcall_trace_word(rust_task *task, uintptr_t i)
+{
+ LOG_UPCALL_ENTRY(task);
+ task->dom->log(rust_log::UPCALL|rust_log::TRACE,
+ "trace: 0x%" PRIxPTR "",
+ i, i, (char)i);
+}
+
+extern "C" CDECL void
+upcall_trace_str(rust_task *task, char const *c)
+{
+ LOG_UPCALL_ENTRY(task);
+ task->dom->log(rust_log::UPCALL|rust_log::TRACE,
+ "trace: %s",
+ c);
+}
+
+extern "C" CDECL rust_port*
+upcall_new_port(rust_task *task, size_t unit_sz)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::MEM|rust_log::COMM,
+ "upcall_new_port(task=0x%" PRIxPTR ", unit_sz=%d)",
+ (uintptr_t)task, unit_sz);
+ return new (dom) rust_port(task, unit_sz);
+}
+
+extern "C" CDECL void
+upcall_del_port(rust_task *task, rust_port *port)
+{
+ LOG_UPCALL_ENTRY(task);
+ task->dom->log(rust_log::UPCALL|rust_log::MEM|rust_log::COMM,
+ "upcall del_port(0x%" PRIxPTR ")", (uintptr_t)port);
+ I(task->dom, !port->refcnt);
+ delete port;
+}
+
+extern "C" CDECL rust_chan*
+upcall_new_chan(rust_task *task, rust_port *port)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::MEM|rust_log::COMM,
+ "upcall_new_chan(task=0x%" PRIxPTR ", port=0x%" PRIxPTR ")",
+ (uintptr_t)task, port);
+ I(dom, port);
+ return new (dom) rust_chan(task, port);
+}
+
+extern "C" CDECL void
+upcall_del_chan(rust_task *task, rust_chan *chan)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::MEM|rust_log::COMM,
+ "upcall del_chan(0x%" PRIxPTR ")", (uintptr_t)chan);
+ I(dom, !chan->refcnt);
+ delete chan;
+}
+
+extern "C" CDECL rust_chan *
+upcall_clone_chan(rust_task *task, rust_task *owner, rust_chan *chan)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::MEM|rust_log::COMM,
+ "upcall clone_chan(owner 0x%" PRIxPTR ", chan 0x%" PRIxPTR ")",
+ (uintptr_t)owner, (uintptr_t)chan);
+ return new (owner->dom) rust_chan(owner, chan->port);
+}
+
+
+/*
+ * Buffering protocol:
+ *
+ * - Reader attempts to read:
+ * - Set reader to blocked-reading state.
+ * - If buf with data exists:
+ * - Attempt transmission.
+ *
+ * - Writer attempts to write:
+ * - Set writer to blocked-writing state.
+ * - Copy data into chan.
+ * - Attempt transmission.
+ *
+ * - Transmission:
+ * - Copy data from buf to reader
+ * - Decr buf
+ * - Set reader to running
+ * - If buf now empty and blocked writer:
+ * - Set blocked writer to running
+ *
+ */
+
+static int
+attempt_transmission(rust_dom *dom,
+ rust_chan *src,
+ rust_task *dst)
+{
+ I(dom, src);
+ I(dom, dst);
+
+ rust_port *port = src->port;
+ if (!port) {
+ dom->log(rust_log::COMM,
+ "src died, transmission incomplete");
+ return 0;
+ }
+
+ circ_buf *buf = &src->buffer;
+ if (buf->unread == 0) {
+ dom->log(rust_log::COMM,
+ "buffer empty, transmission incomplete");
+ return 0;
+ }
+
+ if (!dst->blocked_on(port)) {
+ dom->log(rust_log::COMM,
+ "dst in non-reading state, transmission incomplete");
+ return 0;
+ }
+
+ uintptr_t *dptr = dst->dptr;
+ dom->log(rust_log::COMM,
+ "receiving %d bytes into dst_task=0x%" PRIxPTR
+ ", dptr=0x%" PRIxPTR,
+ port->unit_sz, dst, dptr);
+ buf->shift(dptr);
+
+ // Wake up the sender if its waiting for the send operation.
+ rust_task *sender = src->task;
+ rust_token *token = &src->token;
+ if (sender->blocked_on(token))
+ sender->wakeup(token);
+
+ // Wake up the receiver, there is new data.
+ dst->wakeup(port);
+
+ dom->log(rust_log::COMM, "transmission complete");
+ return 1;
+}
+
+extern "C" CDECL void
+upcall_yield(rust_task *task)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::COMM, "upcall yield()");
+ task->yield(1);
+}
+
+extern "C" CDECL void
+upcall_join(rust_task *task, rust_task *other)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::COMM,
+ "upcall join(other=0x%" PRIxPTR ")",
+ (uintptr_t)other);
+
+ // If the other task is already dying, we dont have to wait for it.
+ if (!other->dead()) {
+ other->waiting_tasks.push(&task->alarm);
+ task->block(other);
+ task->yield(2);
+ }
+}
+
+extern "C" CDECL void
+upcall_send(rust_task *task, rust_chan *chan, void *sptr)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::COMM,
+ "upcall send(chan=0x%" PRIxPTR ", sptr=0x%" PRIxPTR ")",
+ (uintptr_t)chan,
+ (uintptr_t)sptr);
+
+ I(dom, chan);
+ I(dom, sptr);
+
+ rust_port *port = chan->port;
+ dom->log(rust_log::MEM|rust_log::COMM,
+ "send to port", (uintptr_t)port);
+ I(dom, port);
+
+ rust_token *token = &chan->token;
+ dom->log(rust_log::MEM|rust_log::COMM,
+ "sending via token 0x%" PRIxPTR,
+ (uintptr_t)token);
+
+ if (port->task) {
+ chan->buffer.push(sptr);
+ task->block(token);
+ attempt_transmission(dom, chan, port->task);
+ if (chan->buffer.unread && !token->pending())
+ token->submit();
+ } else {
+ dom->log(rust_log::COMM|rust_log::ERR,
+ "port has no task (possibly throw?)");
+ }
+
+ if (!task->running())
+ task->yield(3);
+}
+
+extern "C" CDECL void
+upcall_recv(rust_task *task, uintptr_t *dptr, rust_port *port)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::COMM,
+ "upcall recv(dptr=0x" PRIxPTR ", port=0x%" PRIxPTR ")",
+ (uintptr_t)dptr,
+ (uintptr_t)port);
+
+ I(dom, port);
+ I(dom, port->task);
+ I(dom, task);
+ I(dom, port->task == task);
+
+ task->block(port);
+
+ if (port->writers.length() > 0) {
+ I(dom, task->dom);
+ size_t i = rand(&dom->rctx);
+ i %= port->writers.length();
+ rust_token *token = port->writers[i];
+ rust_chan *chan = token->chan;
+ if (attempt_transmission(dom, chan, task))
+ token->withdraw();
+ } else {
+ dom->log(rust_log::COMM,
+ "no writers sending to port", (uintptr_t)port);
+ }
+
+ if (!task->running()) {
+ task->dptr = dptr;
+ task->yield(3);
+ }
+}
+
+extern "C" CDECL void
+upcall_fail(rust_task *task, char const *expr, char const *file, size_t line)
+{
+ LOG_UPCALL_ENTRY(task);
+ task->dom->log(rust_log::UPCALL|rust_log::ERR,
+ "upcall fail '%s', %s:%" PRIdPTR,
+ expr, file, line);
+ task->fail(4);
+}
+
+extern "C" CDECL void
+upcall_kill(rust_task *task, rust_task *target)
+{
+ LOG_UPCALL_ENTRY(task);
+ task->dom->log(rust_log::UPCALL|rust_log::TASK,
+ "upcall kill target=0x%" PRIxPTR, target);
+ target->kill();
+}
+
+extern "C" CDECL void
+upcall_exit(rust_task *task)
+{
+ LOG_UPCALL_ENTRY(task);
+
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::TASK, "upcall exit");
+ task->die();
+ task->notify_waiting_tasks();
+ task->yield(1);
+}
+
+extern "C" CDECL uintptr_t
+upcall_malloc(rust_task *task, size_t nbytes)
+{
+ LOG_UPCALL_ENTRY(task);
+
+ void *p = task->dom->malloc(nbytes);
+ task->dom->log(rust_log::UPCALL|rust_log::MEM,
+ "upcall malloc(%u) = 0x%" PRIxPTR,
+ nbytes, (uintptr_t)p);
+ return (uintptr_t) p;
+}
+
+extern "C" CDECL void
+upcall_free(rust_task *task, void* ptr)
+{
+ LOG_UPCALL_ENTRY(task);
+
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::MEM,
+ "upcall free(0x%" PRIxPTR ")",
+ (uintptr_t)ptr);
+ dom->free(ptr);
+}
+
+extern "C" CDECL rust_str *
+upcall_new_str(rust_task *task, char const *s, size_t fill)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::MEM,
+ "upcall new_str('%s', %" PRIdPTR ")", s, fill);
+ size_t alloc = next_power_of_two(sizeof(rust_str) + fill);
+ void *mem = dom->malloc(alloc);
+ if (!mem) {
+ task->fail(3);
+ return NULL;
+ }
+ rust_str *st = new (mem) rust_str(dom, alloc, fill, (uint8_t const *)s);
+ dom->log(rust_log::UPCALL|rust_log::MEM,
+ "upcall new_str('%s', %" PRIdPTR ") = 0x%" PRIxPTR,
+ s, fill, st);
+ return st;
+}
+
+extern "C" CDECL rust_vec *
+upcall_new_vec(rust_task *task, size_t fill)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::MEM,
+ "upcall new_vec(%" PRIdPTR ")", fill);
+ size_t alloc = next_power_of_two(sizeof(rust_vec) + fill);
+ void *mem = dom->malloc(alloc);
+ if (!mem) {
+ task->fail(3);
+ return NULL;
+ }
+ rust_vec *v = new (mem) rust_vec(dom, alloc, 0, NULL);
+ dom->log(rust_log::UPCALL|rust_log::MEM,
+ "upcall new_vec(%" PRIdPTR ") = 0x%" PRIxPTR,
+ fill, v);
+ return v;
+}
+
+
+extern "C" CDECL rust_str *
+upcall_vec_grow(rust_task *task, rust_vec *v, size_t n_bytes)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::MEM,
+ "upcall vec_grow(%" PRIxPTR ", %" PRIdPTR ")", v, n_bytes);
+ size_t alloc = next_power_of_two(sizeof(rust_vec) + v->fill + n_bytes);
+ if (v->refcnt == 1) {
+
+ // Fastest path: already large enough.
+ if (v->alloc >= alloc) {
+ dom->log(rust_log::UPCALL|rust_log::MEM, "no-growth path");
+ return v;
+ }
+
+ // Second-fastest path: can at least realloc.
+ dom->log(rust_log::UPCALL|rust_log::MEM, "realloc path");
+ v = (rust_vec*)dom->realloc(v, alloc);
+ if (!v) {
+ task->fail(3);
+ return NULL;
+ }
+ v->alloc = alloc;
+
+ } else {
+ // Slowest path: make a new vec.
+ dom->log(rust_log::UPCALL|rust_log::MEM, "new vec path");
+ void *mem = dom->malloc(alloc);
+ if (!mem) {
+ task->fail(3);
+ return NULL;
+ }
+ v->deref();
+ v = new (mem) rust_vec(dom, alloc, v->fill, &v->data[0]);
+ }
+ I(dom, sizeof(rust_vec) + v->fill <= v->alloc);
+ return v;
+}
+
+
+static rust_crate_cache::c_sym *
+fetch_c_sym(rust_task *task,
+ rust_crate const *curr_crate,
+ size_t lib_num,
+ size_t c_sym_num,
+ char const *library,
+ char const *symbol)
+{
+ rust_crate_cache *cache = task->get_crate_cache(curr_crate);
+ rust_crate_cache::lib *l = cache->get_lib(lib_num, library);
+ return cache->get_c_sym(c_sym_num, l, symbol);
+}
+
+extern "C" CDECL uintptr_t
+upcall_require_rust_sym(rust_task *task,
+ rust_crate const *curr_crate,
+ size_t lib_num, // # of lib
+ size_t c_sym_num, // # of C sym "rust_crate" in lib
+ size_t rust_sym_num, // # of rust sym
+ char const *library,
+ char const **path)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+
+ dom->log(rust_log::UPCALL|rust_log::CACHE,
+ "upcall require rust sym: lib #%" PRIdPTR
+ " = %s, c_sym #%" PRIdPTR
+ ", rust_sym #%" PRIdPTR
+ ", curr_crate = 0x%" PRIxPTR,
+ lib_num, library, c_sym_num, rust_sym_num,
+ curr_crate);
+ for (char const **c = crate_rel(curr_crate, path); *c; ++c) {
+ dom->log(rust_log::UPCALL, " + %s", crate_rel(curr_crate, *c));
+ }
+
+ dom->log(rust_log::UPCALL|rust_log::CACHE,
+ "require C symbol 'rust_crate' from lib #%" PRIdPTR,lib_num);
+ rust_crate_cache::c_sym *c =
+ fetch_c_sym(task, curr_crate, lib_num, c_sym_num,
+ library, "rust_crate");
+
+ dom->log(rust_log::UPCALL|rust_log::CACHE,
+ "require rust symbol inside crate");
+ rust_crate_cache::rust_sym *s =
+ task->cache->get_rust_sym(rust_sym_num, dom, curr_crate, c, path);
+
+ uintptr_t addr = s->get_val();
+ if (addr) {
+ dom->log(rust_log::UPCALL|rust_log::CACHE,
+ "found-or-cached addr: 0x%" PRIxPTR, addr);
+ } else {
+ dom->log(rust_log::UPCALL|rust_log::CACHE,
+ "failed to resolve symbol");
+ task->fail(7);
+ }
+ return addr;
+}
+
+extern "C" CDECL uintptr_t
+upcall_require_c_sym(rust_task *task,
+ rust_crate const *curr_crate,
+ size_t lib_num, // # of lib
+ size_t c_sym_num, // # of C sym
+ char const *library,
+ char const *symbol)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+
+ dom->log(rust_log::UPCALL|rust_log::CACHE,
+ "upcall require c sym: lib #%" PRIdPTR
+ " = %s, c_sym #%" PRIdPTR
+ " = %s"
+ ", curr_crate = 0x%" PRIxPTR,
+ lib_num, library, c_sym_num, symbol, curr_crate);
+
+ rust_crate_cache::c_sym *c =
+ fetch_c_sym(task, curr_crate, lib_num, c_sym_num, library, symbol);
+
+ uintptr_t addr = c->get_val();
+ if (addr) {
+ dom->log(rust_log::UPCALL|rust_log::CACHE,
+ "found-or-cached addr: 0x%" PRIxPTR, addr);
+ } else {
+ dom->log(rust_log::UPCALL|rust_log::CACHE,
+ "failed to resolve symbol");
+ task->fail(6);
+ }
+ return addr;
+}
+
+extern "C" CDECL type_desc *
+upcall_get_type_desc(rust_task *task,
+ rust_crate const *curr_crate,
+ size_t size,
+ size_t align,
+ size_t n_descs,
+ type_desc const **descs)
+{
+ LOG_UPCALL_ENTRY(task);
+ rust_dom *dom = task->dom;
+ dom->log(rust_log::UPCALL|rust_log::CACHE,
+ "upcall get_type_desc with size=%" PRIdPTR
+ ", align=%" PRIdPTR ", %" PRIdPTR " descs",
+ size, align, n_descs);
+ rust_crate_cache *cache = task->get_crate_cache(curr_crate);
+ type_desc *td = cache->get_type_desc(size, align, n_descs, descs);
+ dom->log(rust_log::UPCALL|rust_log::CACHE,
+ "returning tydesc 0x%" PRIxPTR, td);
+ return td;
+}
+
+
+#if defined(__WIN32__)
+static DWORD WINAPI rust_thread_start(void *ptr)
+#elif defined(__GNUC__)
+static void *rust_thread_start(void *ptr)
+#else
+#error "Platform not supported"
+#endif
+{
+ // We were handed the domain we are supposed to run.
+ rust_dom *dom = (rust_dom *)ptr;
+
+ // Start a new rust main loop for this thread.
+ rust_main_loop(dom);
+
+ rust_srv *srv = dom->srv;
+ delete dom;
+ delete srv;
+
+ return 0;
+}
+
+extern "C" CDECL rust_task *
+upcall_new_task(rust_task *spawner)
+{
+ LOG_UPCALL_ENTRY(spawner);
+
+ rust_dom *dom = spawner->dom;
+ rust_task *task = new (dom) rust_task(dom, spawner);
+ dom->log(rust_log::UPCALL|rust_log::MEM|rust_log::TASK,
+ "upcall new_task(spawner 0x%" PRIxPTR ") = 0x%" PRIxPTR,
+ spawner, task);
+ return task;
+}
+
+extern "C" CDECL rust_task *
+upcall_start_task(rust_task *spawner,
+ rust_task *task,
+ uintptr_t exit_task_glue,
+ uintptr_t spawnee_fn,
+ size_t callsz)
+{
+ LOG_UPCALL_ENTRY(spawner);
+
+ rust_dom *dom = spawner->dom;
+ dom->log(rust_log::UPCALL|rust_log::MEM|rust_log::TASK,
+ "upcall start_task(task 0x%" PRIxPTR
+ " exit_task_glue 0x%" PRIxPTR
+ ", spawnee 0x%" PRIxPTR
+ ", callsz %" PRIdPTR ")",
+ task, exit_task_glue, spawnee_fn, callsz);
+ task->start(exit_task_glue, spawnee_fn, spawner->rust_sp, callsz);
+ return task;
+}
+
+extern "C" CDECL rust_task *
+upcall_new_thread(rust_task *task)
+{
+ LOG_UPCALL_ENTRY(task);
+
+ rust_dom *old_dom = task->dom;
+ rust_dom *new_dom = new rust_dom(old_dom->srv->clone(),
+ old_dom->root_crate);
+ new_dom->log(rust_log::UPCALL|rust_log::MEM,
+ "upcall new_thread() = 0x%" PRIxPTR,
+ new_dom->root_task);
+ return new_dom->root_task;
+}
+
+extern "C" CDECL rust_task *
+upcall_start_thread(rust_task *spawner,
+ rust_task *root_task,
+ uintptr_t exit_task_glue,
+ uintptr_t spawnee_fn,
+ size_t callsz)
+{
+ LOG_UPCALL_ENTRY(spawner);
+
+ rust_dom *dom = spawner->dom;
+ dom->log(rust_log::UPCALL|rust_log::MEM|rust_log::TASK,
+ "upcall start_thread(exit_task_glue 0x%" PRIxPTR
+ ", spawnee 0x%" PRIxPTR
+ ", callsz %" PRIdPTR ")",
+ exit_task_glue, spawnee_fn, callsz);
+ root_task->start(exit_task_glue, spawnee_fn, spawner->rust_sp, callsz);
+
+#if defined(__WIN32__)
+ HANDLE thread;
+ thread = CreateThread(NULL, 0, rust_thread_start, root_task->dom,
+ 0, NULL);
+ dom->win32_require("CreateThread", thread != NULL);
+#else
+ pthread_t thread;
+ pthread_create(&thread, &dom->attr, rust_thread_start,
+ (void *)root_task->dom);
+#endif
+
+ return 0;
+}
+
+//
+// Local Variables:
+// mode: C++
+// fill-column: 78;
+// indent-tabs-mode: nil
+// c-basic-offset: 4
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
+//
--- /dev/null
+#ifndef RUST_UTIL_H
+#define RUST_UTIL_H
+
+// Reference counted objects
+
+template <typename T>
+rc_base<T>::rc_base() :
+ refcnt(1)
+{
+}
+
+template <typename T>
+rc_base<T>::~rc_base()
+{
+}
+
+// Utility type: pointer-vector.
+
+template <typename T>
+ptr_vec<T>::ptr_vec(rust_dom *dom) :
+ dom(dom),
+ alloc(INIT_SIZE),
+ fill(0),
+ data(new (dom) T*[alloc])
+{
+ I(dom, data);
+ dom->log(rust_log::MEM,
+ "new ptr_vec(data=0x%" PRIxPTR ") -> 0x%" PRIxPTR,
+ (uintptr_t)data, (uintptr_t)this);
+}
+
+template <typename T>
+ptr_vec<T>::~ptr_vec()
+{
+ I(dom, data);
+ dom->log(rust_log::MEM,
+ "~ptr_vec 0x%" PRIxPTR ", data=0x%" PRIxPTR,
+ (uintptr_t)this, (uintptr_t)data);
+ I(dom, fill == 0);
+ dom->free(data);
+}
+
+template <typename T> T *&
+ptr_vec<T>::operator[](size_t offset) {
+ I(dom, data[offset]->idx == offset);
+ return data[offset];
+}
+
+template <typename T>
+void
+ptr_vec<T>::push(T *p)
+{
+ I(dom, data);
+ I(dom, fill <= alloc);
+ if (fill == alloc) {
+ alloc *= 2;
+ data = (T **)dom->realloc(data, alloc * sizeof(T*));
+ I(dom, data);
+ }
+ I(dom, fill < alloc);
+ p->idx = fill;
+ data[fill++] = p;
+}
+
+template <typename T>
+T *
+ptr_vec<T>::pop()
+{
+ return data[--fill];
+}
+
+template <typename T>
+void
+ptr_vec<T>::trim(size_t sz)
+{
+ I(dom, data);
+ if (sz <= (alloc / 4) &&
+ (alloc / 2) >= INIT_SIZE) {
+ alloc /= 2;
+ I(dom, alloc >= fill);
+ data = (T **)dom->realloc(data, alloc * sizeof(T*));
+ I(dom, data);
+ }
+}
+
+template <typename T>
+void
+ptr_vec<T>::swapdel(T *item)
+{
+ /* Swap the endpoint into i and decr fill. */
+ I(dom, data);
+ I(dom, fill > 0);
+ I(dom, item->idx < fill);
+ fill--;
+ if (fill > 0) {
+ T *subst = data[fill];
+ size_t idx = item->idx;
+ data[idx] = subst;
+ subst->idx = idx;
+ }
+}
+
+// Inline fn used regularly elsewhere.
+
+static inline size_t
+next_power_of_two(size_t s)
+{
+ size_t tmp = s - 1;
+ tmp |= tmp >> 1;
+ tmp |= tmp >> 2;
+ tmp |= tmp >> 4;
+ tmp |= tmp >> 8;
+ tmp |= tmp >> 16;
+#if SIZE_MAX == UINT64_MAX
+ tmp |= tmp >> 32;
+#endif
+ return tmp + 1;
+}
+
+// Vectors (rust-user-code level).
+
+struct
+rust_vec : public rc_base<rust_vec>
+{
+ size_t alloc;
+ size_t fill;
+ uint8_t data[];
+ rust_vec(rust_dom *dom, size_t alloc, size_t fill, uint8_t const *d) :
+ alloc(alloc),
+ fill(fill)
+ {
+ if (d || fill) {
+ I(dom, d);
+ I(dom, fill);
+ memcpy(&data[0], d, fill);
+ }
+ }
+ ~rust_vec() {}
+};
+
+// Rust types vec and str look identical from our perspective.
+typedef rust_vec rust_str;
+
+//
+// Local Variables:
+// mode: C++
+// fill-column: 78;
+// indent-tabs-mode: nil
+// c-basic-offset: 4
+// buffer-file-coding-system: utf-8-unix
+// compile-command: "make -k -C .. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+// End:
+//
+
+#endif
--- /dev/null
+/*
+ * This works well as long as the number of contending threads
+ * is less than the number of processors. This is because of
+ * the fair locking scheme. If the thread that is next in line
+ * for acquiring the lock is not currently running, no other
+ * thread can acquire the lock. This is terrible for performance,
+ * and it seems that all fair locking schemes suffer from this
+ * behavior.
+ */
+
+// #define TRACE
+
+fair_ticket_lock::fair_ticket_lock() {
+ next_ticket = now_serving = 0;
+}
+
+fair_ticket_lock::~fair_ticket_lock() {
+
+}
+
+void fair_ticket_lock::lock() {
+ unsigned ticket = __sync_fetch_and_add(&next_ticket, 1);
+ while (now_serving != ticket) {
+ pause();
+ }
+#ifdef TRACE
+ printf("locked nextTicket: %d nowServing: %d",
+ next_ticket, now_serving);
+#endif
+}
+
+void fair_ticket_lock::unlock() {
+ now_serving++;
+#ifdef TRACE
+ printf("unlocked nextTicket: %d nowServing: %d",
+ next_ticket, now_serving);
+#endif
+}
+
+void fair_ticket_lock::pause() {
+ asm volatile("pause\n" : : : "memory");
+}
+
--- /dev/null
+#ifndef FAIR_TICKET_LOCK_H
+#define FAIR_TICKET_LOCK_H
+
+class fair_ticket_lock {
+ unsigned next_ticket;
+ unsigned now_serving;
+ void pause();
+public:
+ fair_ticket_lock();
+ virtual ~fair_ticket_lock();
+ void lock();
+ void unlock();
+};
+
+#endif /* FAIR_TICKET_LOCK_H */
--- /dev/null
+/*
+ * Interrupt transparent queue, Schoen et. al, "On Interrupt-Transparent
+ * Synchronization in an Embedded Object-Oriented Operating System", 2000.
+ * enqueue() is allowed to interrupt enqueue() and dequeue(), however,
+ * dequeue() is not allowed to interrupt itself.
+ */
+
+#include "lock_free_queue.h"
+
+lock_free_queue::lock_free_queue() :
+ tail(this) {
+}
+
+void lock_free_queue::enqueue(lock_free_queue_node *item) {
+ item->next = (lock_free_queue_node *) 0;
+ lock_free_queue_node *last = tail;
+ tail = item;
+ while (last->next)
+ last = last->next;
+ last->next = item;
+}
+
+lock_free_queue_node *lockfree_queue::dequeue() {
+ lock_free_queue_node *item = next;
+ if (item && !(next = item->next)) {
+ tail = (lock_free_queue_node *) this;
+ if (item->next) {
+ lock_free_queue_node *lost = item->next;
+ lock_free_queue_node *help;
+ do {
+ help = lost->next;
+ enqueue(lost);
+ } while ((lost = help) != (lock_free_queue_node *) 0);
+ }
+ }
+ return item;
+}
--- /dev/null
+#ifndef LOCK_FREE_QUEUE_H
+#define LOCK_FREE_QUEUE_H
+
+class lock_free_queue_node {
+ lock_free_queue_node *next;
+};
+
+class lock_free_queue {
+public:
+ lock_free_queue();
+ void enqueue(lock_free_queue_node *item);
+ lock_free_queue_node *dequeue();
+};
+
+#endif /* LOCK_FREE_QUEUE_H */
--- /dev/null
+/*
+ * Your average spin lock.
+ */
+
+#include "globals.h"
+
+// #define TRACE
+
+spin_lock::spin_lock() {
+ unlock();
+}
+
+spin_lock::~spin_lock() {
+}
+
+static inline unsigned xchg32(void *ptr, unsigned x) {
+ __asm__ __volatile__("xchgl %0,%1"
+ :"=r" ((unsigned) x)
+ :"m" (*(volatile unsigned *)ptr), "0" (x)
+ :"memory");
+ return x;
+}
+
+void spin_lock::lock() {
+ while (true) {
+ if (!xchg32(&ticket, 1)) {
+ return;
+ }
+ while (ticket) {
+ pause();
+ }
+ }
+#ifdef TRACE
+ printf(" lock: %d", ticket);
+#endif
+}
+
+void spin_lock::unlock() {
+ ticket = 0;
+#ifdef TRACE
+ printf("unlock:");
+#endif
+}
+
+void spin_lock::pause() {
+ asm volatile("pause\n" : : : "memory");
+}
--- /dev/null
+#ifndef UNFAIR_TICKET_LOCK_H
+#define UNFAIR_TICKET_LOCK_H
+
+class spin_lock {
+ unsigned ticket;
+ void pause();
+public:
+ spin_lock();
+ virtual ~spin_lock();
+ void lock();
+ void unlock();
+};
+
+#endif /* UNFAIR_TICKET_LOCK_H */
--- /dev/null
+/*
+Copyright (c) 2003-2009, Troy D. Hanson http://uthash.sourceforge.net
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+#ifndef UTHASH_H
+#define UTHASH_H
+
+#include <string.h> /* memcmp,strlen */
+#include <stddef.h> /* ptrdiff_t */
+#include <inttypes.h> /* uint32_t etc */
+
+#define UTHASH_VERSION 1.6
+
+/* C++ requires extra stringent casting */
+#if defined __cplusplus
+#define TYPEOF(x) (typeof(x))
+#else
+#define TYPEOF(x)
+#endif
+
+
+#define uthash_fatal(msg) exit(-1) /* fatal error (out of memory,etc) */
+#define uthash_bkt_malloc(sz) malloc(sz) /* malloc fcn for UT_hash_bucket's */
+#define uthash_bkt_free(ptr) free(ptr) /* free fcn for UT_hash_bucket's */
+#define uthash_tbl_malloc(sz) malloc(sz) /* malloc fcn for UT_hash_table */
+#define uthash_tbl_free(ptr) free(ptr) /* free fcn for UT_hash_table */
+
+#define uthash_noexpand_fyi(tbl) /* can be defined to log noexpand */
+#define uthash_expand_fyi(tbl) /* can be defined to log expands */
+
+/* initial number of buckets */
+#define HASH_INITIAL_NUM_BUCKETS 32 /* initial number of buckets */
+#define HASH_INITIAL_NUM_BUCKETS_LOG2 5 /* lg2 of initial number of buckets */
+#define HASH_BKT_CAPACITY_THRESH 10 /* expand when bucket count reaches */
+
+/* calculate the element whose hash handle address is hhe */
+#define ELMT_FROM_HH(tbl,hhp) ((void*)(((char*)hhp) - (tbl)->hho))
+
+#define HASH_FIND(hh,head,keyptr,keylen,out) \
+do { \
+ unsigned _hf_bkt,_hf_hashv; \
+ out=TYPEOF(out)head; \
+ if (head) { \
+ HASH_FCN(keyptr,keylen, (head)->hh.tbl->num_buckets, _hf_hashv, _hf_bkt); \
+ HASH_FIND_IN_BKT((head)->hh.tbl, hh, (head)->hh.tbl->buckets[ _hf_bkt ], \
+ keyptr,keylen,out); \
+ } \
+} while (0)
+
+#define HASH_MAKE_TABLE(hh,head) \
+do { \
+ (head)->hh.tbl = (UT_hash_table*)uthash_tbl_malloc( \
+ sizeof(UT_hash_table)); \
+ if (!((head)->hh.tbl)) { uthash_fatal( "out of memory"); } \
+ memset((head)->hh.tbl, 0, sizeof(UT_hash_table)); \
+ (head)->hh.tbl->tail = &((head)->hh); \
+ (head)->hh.tbl->num_buckets = HASH_INITIAL_NUM_BUCKETS; \
+ (head)->hh.tbl->log2_num_buckets = HASH_INITIAL_NUM_BUCKETS_LOG2; \
+ (head)->hh.tbl->hho = (char*)(&(head)->hh) - (char*)(head); \
+ (head)->hh.tbl->buckets = (UT_hash_bucket*)uthash_bkt_malloc( \
+ HASH_INITIAL_NUM_BUCKETS*sizeof(struct UT_hash_bucket)); \
+ if (! (head)->hh.tbl->buckets) { uthash_fatal( "out of memory"); } \
+ memset((head)->hh.tbl->buckets, 0, \
+ HASH_INITIAL_NUM_BUCKETS*sizeof(struct UT_hash_bucket)); \
+} while(0)
+
+#define HASH_ADD(hh,head,fieldname,keylen_in,add) \
+ HASH_ADD_KEYPTR(hh,head,&add->fieldname,keylen_in,add)
+
+#define HASH_ADD_KEYPTR(hh,head,keyptr,keylen_in,add) \
+do { \
+ unsigned _ha_bkt; \
+ (add)->hh.next = NULL; \
+ (add)->hh.key = (char*)keyptr; \
+ (add)->hh.keylen = keylen_in; \
+ if (!(head)) { \
+ head = (add); \
+ (head)->hh.prev = NULL; \
+ HASH_MAKE_TABLE(hh,head); \
+ } else { \
+ (head)->hh.tbl->tail->next = (add); \
+ (add)->hh.prev = ELMT_FROM_HH((head)->hh.tbl, (head)->hh.tbl->tail); \
+ (head)->hh.tbl->tail = &((add)->hh); \
+ } \
+ (head)->hh.tbl->num_items++; \
+ (add)->hh.tbl = (head)->hh.tbl; \
+ HASH_FCN(keyptr,keylen_in, (head)->hh.tbl->num_buckets, \
+ (add)->hh.hashv, _ha_bkt); \
+ HASH_ADD_TO_BKT((head)->hh.tbl->buckets[_ha_bkt],&(add)->hh); \
+ HASH_EMIT_KEY(hh,head,keyptr,keylen_in); \
+ HASH_FSCK(hh,head); \
+} while(0)
+
+#define HASH_TO_BKT( hashv, num_bkts, bkt ) \
+do { \
+ bkt = ((hashv) & ((num_bkts) - 1)); \
+} while(0)
+
+/* delete "delptr" from the hash table.
+ * "the usual" patch-up process for the app-order doubly-linked-list.
+ * The use of _hd_hh_del below deserves special explanation.
+ * These used to be expressed using (delptr) but that led to a bug
+ * if someone used the same symbol for the head and deletee, like
+ * HASH_DELETE(hh,users,users);
+ * We want that to work, but by changing the head (users) below
+ * we were forfeiting our ability to further refer to the deletee (users)
+ * in the patch-up process. Solution: use scratch space in the table to
+ * copy the deletee pointer, then the latter references are via that
+ * scratch pointer rather than through the repointed (users) symbol.
+ */
+#define HASH_DELETE(hh,head,delptr) \
+do { \
+ unsigned _hd_bkt; \
+ struct UT_hash_handle *_hd_hh_del; \
+ if ( ((delptr)->hh.prev == NULL) && ((delptr)->hh.next == NULL) ) { \
+ uthash_bkt_free((head)->hh.tbl->buckets ); \
+ uthash_tbl_free((head)->hh.tbl); \
+ head = NULL; \
+ } else { \
+ _hd_hh_del = &((delptr)->hh); \
+ if ((delptr) == ELMT_FROM_HH((head)->hh.tbl,(head)->hh.tbl->tail)) { \
+ (head)->hh.tbl->tail = \
+ (UT_hash_handle*)((char*)((delptr)->hh.prev) + \
+ (head)->hh.tbl->hho); \
+ } \
+ if ((delptr)->hh.prev) { \
+ ((UT_hash_handle*)((char*)((delptr)->hh.prev) + \
+ (head)->hh.tbl->hho))->next = (delptr)->hh.next; \
+ } else { \
+ head = TYPEOF(head)((delptr)->hh.next); \
+ } \
+ if (_hd_hh_del->next) { \
+ ((UT_hash_handle*)((char*)_hd_hh_del->next + \
+ (head)->hh.tbl->hho))->prev = \
+ _hd_hh_del->prev; \
+ } \
+ HASH_TO_BKT( _hd_hh_del->hashv, (head)->hh.tbl->num_buckets, _hd_bkt); \
+ HASH_DEL_IN_BKT(hh,(head)->hh.tbl->buckets[_hd_bkt], _hd_hh_del); \
+ (head)->hh.tbl->num_items--; \
+ } \
+ HASH_FSCK(hh,head); \
+} while (0)
+
+
+/* convenience forms of HASH_FIND/HASH_ADD/HASH_DEL */
+#define HASH_FIND_STR(head,findstr,out) \
+ HASH_FIND(hh,head,findstr,strlen(findstr),out)
+#define HASH_ADD_STR(head,strfield,add) \
+ HASH_ADD(hh,head,strfield,strlen(add->strfield),add)
+#define HASH_FIND_INT(head,findint,out) \
+ HASH_FIND(hh,head,findint,sizeof(int),out)
+#define HASH_ADD_INT(head,intfield,add) \
+ HASH_ADD(hh,head,intfield,sizeof(int),add)
+#define HASH_DEL(head,delptr) \
+ HASH_DELETE(hh,head,delptr)
+
+/* HASH_FSCK checks hash integrity on every add/delete when HASH_DEBUG is defined.
+ * This is for uthash developer only; it compiles away if HASH_DEBUG isn't defined.
+ */
+#ifdef HASH_DEBUG
+#define HASH_OOPS(...) do { fprintf(stderr,__VA_ARGS__); exit(-1); } while (0)
+#define HASH_FSCK(hh,head) \
+do { \
+ unsigned _bkt_i; \
+ unsigned _count, _bkt_count; \
+ char *_prev; \
+ struct UT_hash_handle *_thh; \
+ if (head) { \
+ _count = 0; \
+ for( _bkt_i = 0; _bkt_i < (head)->hh.tbl->num_buckets; _bkt_i++) { \
+ _bkt_count = 0; \
+ _thh = (head)->hh.tbl->buckets[_bkt_i].hh_head; \
+ _prev = NULL; \
+ while (_thh) { \
+ if (_prev != (char*)(_thh->hh_prev)) { \
+ HASH_OOPS("invalid hh_prev %p, actual %p\n", \
+ _thh->hh_prev, _prev ); \
+ } \
+ _bkt_count++; \
+ _prev = (char*)(_thh); \
+ _thh = _thh->hh_next; \
+ } \
+ _count += _bkt_count; \
+ if ((head)->hh.tbl->buckets[_bkt_i].count != _bkt_count) { \
+ HASH_OOPS("invalid bucket count %d, actual %d\n", \
+ (head)->hh.tbl->buckets[_bkt_i].count, _bkt_count); \
+ } \
+ } \
+ if (_count != (head)->hh.tbl->num_items) { \
+ HASH_OOPS("invalid hh item count %d, actual %d\n", \
+ (head)->hh.tbl->num_items, _count ); \
+ } \
+ /* traverse hh in app order; check next/prev integrity, count */ \
+ _count = 0; \
+ _prev = NULL; \
+ _thh = &(head)->hh; \
+ while (_thh) { \
+ _count++; \
+ if (_prev !=(char*)(_thh->prev)) { \
+ HASH_OOPS("invalid prev %p, actual %p\n", \
+ _thh->prev, _prev ); \
+ } \
+ _prev = (char*)ELMT_FROM_HH((head)->hh.tbl, _thh); \
+ _thh = ( _thh->next ? (UT_hash_handle*)((char*)(_thh->next) + \
+ (head)->hh.tbl->hho) : NULL ); \
+ } \
+ if (_count != (head)->hh.tbl->num_items) { \
+ HASH_OOPS("invalid app item count %d, actual %d\n", \
+ (head)->hh.tbl->num_items, _count ); \
+ } \
+ } \
+} while (0)
+#else
+#define HASH_FSCK(hh,head)
+#endif
+
+/* When compiled with -DHASH_EMIT_KEYS, length-prefixed keys are emitted to
+ * the descriptor to which this macro is defined for tuning the hash function.
+ * The app can #include <unistd.h> to get the prototype for write(2). */
+#ifdef HASH_EMIT_KEYS
+#define HASH_EMIT_KEY(hh,head,keyptr,fieldlen) \
+do { \
+ unsigned _klen = fieldlen; \
+ write(HASH_EMIT_KEYS, &_klen, sizeof(_klen)); \
+ write(HASH_EMIT_KEYS, keyptr, fieldlen); \
+} while (0)
+#else
+#define HASH_EMIT_KEY(hh,head,keyptr,fieldlen)
+#endif
+
+/* default to MurmurHash unless overridden e.g. DHASH_FUNCTION=HASH_SAX */
+#ifdef HASH_FUNCTION
+#define HASH_FCN HASH_FUNCTION
+#else
+#define HASH_FCN HASH_MUR
+#endif
+
+/* The Bernstein hash function, used in Perl prior to v5.6 */
+#define HASH_BER(key,keylen,num_bkts,hashv,bkt) \
+do { \
+ unsigned _hb_keylen=keylen; \
+ char *_hb_key=(char*)key; \
+ (hashv) = 0; \
+ while (_hb_keylen--) { (hashv) = ((hashv) * 33) + *_hb_key++; } \
+ bkt = (hashv) & (num_bkts-1); \
+} while (0)
+
+
+/* SAX/FNV/OAT/JEN hash functions are macro variants of those listed at
+ * http://eternallyconfuzzled.com/tuts/algorithms/jsw_tut_hashing.aspx */
+#define HASH_SAX(key,keylen,num_bkts,hashv,bkt) \
+do { \
+ unsigned _sx_i; \
+ char *_hs_key=(char*)key; \
+ hashv = 0; \
+ for(_sx_i=0; _sx_i < keylen; _sx_i++) \
+ hashv ^= (hashv << 5) + (hashv >> 2) + _hs_key[_sx_i]; \
+ bkt = hashv & (num_bkts-1); \
+} while (0)
+
+#define HASH_FNV(key,keylen,num_bkts,hashv,bkt) \
+do { \
+ unsigned _fn_i; \
+ char *_hf_key=(char*)key; \
+ hashv = 2166136261UL; \
+ for(_fn_i=0; _fn_i < keylen; _fn_i++) \
+ hashv = (hashv * 16777619) ^ _hf_key[_fn_i]; \
+ bkt = hashv & (num_bkts-1); \
+} while(0);
+
+#define HASH_OAT(key,keylen,num_bkts,hashv,bkt) \
+do { \
+ unsigned _ho_i; \
+ char *_ho_key=(char*)key; \
+ hashv = 0; \
+ for(_ho_i=0; _ho_i < keylen; _ho_i++) { \
+ hashv += _ho_key[_ho_i]; \
+ hashv += (hashv << 10); \
+ hashv ^= (hashv >> 6); \
+ } \
+ hashv += (hashv << 3); \
+ hashv ^= (hashv >> 11); \
+ hashv += (hashv << 15); \
+ bkt = hashv & (num_bkts-1); \
+} while(0)
+
+#define HASH_JEN_MIX(a,b,c) \
+do { \
+ a -= b; a -= c; a ^= ( c >> 13 ); \
+ b -= c; b -= a; b ^= ( a << 8 ); \
+ c -= a; c -= b; c ^= ( b >> 13 ); \
+ a -= b; a -= c; a ^= ( c >> 12 ); \
+ b -= c; b -= a; b ^= ( a << 16 ); \
+ c -= a; c -= b; c ^= ( b >> 5 ); \
+ a -= b; a -= c; a ^= ( c >> 3 ); \
+ b -= c; b -= a; b ^= ( a << 10 ); \
+ c -= a; c -= b; c ^= ( b >> 15 ); \
+} while (0)
+
+#define HASH_JEN(key,keylen,num_bkts,hashv,bkt) \
+do { \
+ unsigned _hj_i,_hj_j,_hj_k; \
+ char *_hj_key=(char*)key; \
+ hashv = 0xfeedbeef; \
+ _hj_i = _hj_j = 0x9e3779b9; \
+ _hj_k = keylen; \
+ while (_hj_k >= 12) { \
+ _hj_i += (_hj_key[0] + ( (unsigned)_hj_key[1] << 8 ) \
+ + ( (unsigned)_hj_key[2] << 16 ) \
+ + ( (unsigned)_hj_key[3] << 24 ) ); \
+ _hj_j += (_hj_key[4] + ( (unsigned)_hj_key[5] << 8 ) \
+ + ( (unsigned)_hj_key[6] << 16 ) \
+ + ( (unsigned)_hj_key[7] << 24 ) ); \
+ hashv += (_hj_key[8] + ( (unsigned)_hj_key[9] << 8 ) \
+ + ( (unsigned)_hj_key[10] << 16 ) \
+ + ( (unsigned)_hj_key[11] << 24 ) ); \
+ \
+ HASH_JEN_MIX(_hj_i, _hj_j, hashv); \
+ \
+ _hj_key += 12; \
+ _hj_k -= 12; \
+ } \
+ hashv += keylen; \
+ switch ( _hj_k ) { \
+ case 11: hashv += ( (unsigned)_hj_key[10] << 24 ); \
+ case 10: hashv += ( (unsigned)_hj_key[9] << 16 ); \
+ case 9: hashv += ( (unsigned)_hj_key[8] << 8 ); \
+ case 8: _hj_j += ( (unsigned)_hj_key[7] << 24 ); \
+ case 7: _hj_j += ( (unsigned)_hj_key[6] << 16 ); \
+ case 6: _hj_j += ( (unsigned)_hj_key[5] << 8 ); \
+ case 5: _hj_j += _hj_key[4]; \
+ case 4: _hj_i += ( (unsigned)_hj_key[3] << 24 ); \
+ case 3: _hj_i += ( (unsigned)_hj_key[2] << 16 ); \
+ case 2: _hj_i += ( (unsigned)_hj_key[1] << 8 ); \
+ case 1: _hj_i += _hj_key[0]; \
+ } \
+ HASH_JEN_MIX(_hj_i, _hj_j, hashv); \
+ bkt = hashv & (num_bkts-1); \
+} while(0)
+
+/* The Paul Hsieh hash function */
+#undef get16bits
+#if (defined(__GNUC__) && defined(__i386__)) || defined(__WATCOMC__) \
+ || defined(_MSC_VER) || defined (__BORLANDC__) || defined (__TURBOC__)
+#define get16bits(d) (*((const uint16_t *) (d)))
+#endif
+
+#if !defined (get16bits)
+#define get16bits(d) ((((uint32_t)(((const uint8_t *)(d))[1])) << 8)\
+ +(uint32_t)(((const uint8_t *)(d))[0]) )
+#endif
+#define HASH_SFH(key,keylen,num_bkts,hashv,bkt) \
+do { \
+ char *_sfh_key=(char*)key; \
+ hashv = 0xcafebabe; \
+ uint32_t _sfh_tmp, _sfh_len = keylen; \
+ \
+ int _sfh_rem = _sfh_len & 3; \
+ _sfh_len >>= 2; \
+ \
+ /* Main loop */ \
+ for (;_sfh_len > 0; _sfh_len--) { \
+ hashv += get16bits (_sfh_key); \
+ _sfh_tmp = (get16bits (_sfh_key+2) << 11) ^ hashv; \
+ hashv = (hashv << 16) ^ _sfh_tmp; \
+ _sfh_key += 2*sizeof (uint16_t); \
+ hashv += hashv >> 11; \
+ } \
+ \
+ /* Handle end cases */ \
+ switch (_sfh_rem) { \
+ case 3: hashv += get16bits (_sfh_key); \
+ hashv ^= hashv << 16; \
+ hashv ^= _sfh_key[sizeof (uint16_t)] << 18; \
+ hashv += hashv >> 11; \
+ break; \
+ case 2: hashv += get16bits (_sfh_key); \
+ hashv ^= hashv << 11; \
+ hashv += hashv >> 17; \
+ break; \
+ case 1: hashv += *_sfh_key; \
+ hashv ^= hashv << 10; \
+ hashv += hashv >> 1; \
+ } \
+ \
+ /* Force "avalanching" of final 127 bits */ \
+ hashv ^= hashv << 3; \
+ hashv += hashv >> 5; \
+ hashv ^= hashv << 4; \
+ hashv += hashv >> 17; \
+ hashv ^= hashv << 25; \
+ hashv += hashv >> 6; \
+ bkt = hashv & (num_bkts-1); \
+} while(0);
+
+/* Austin Appleby's MurmurHash */
+#define HASH_MUR(key,keylen,num_bkts,hashv,bkt) \
+do { \
+ const unsigned int _mur_m = 0x5bd1e995; \
+ const int _mur_r = 24; \
+ hashv = 0xcafebabe ^ keylen; \
+ char *_mur_key = (char *)key; \
+ uint32_t _mur_tmp, _mur_len = keylen; \
+ \
+ for (;_mur_len >= 4; _mur_len-=4) { \
+ _mur_tmp = *(uint32_t *)_mur_key; \
+ _mur_tmp *= _mur_m; \
+ _mur_tmp ^= _mur_tmp >> _mur_r; \
+ _mur_tmp *= _mur_m; \
+ hashv *= _mur_m; \
+ hashv ^= _mur_tmp; \
+ _mur_key += 4; \
+ } \
+ \
+ switch(_mur_len) \
+ { \
+ case 3: hashv ^= _mur_key[2] << 16; \
+ case 2: hashv ^= _mur_key[1] << 8; \
+ case 1: hashv ^= _mur_key[0]; \
+ hashv *= _mur_m; \
+ }; \
+ \
+ hashv ^= hashv >> 13; \
+ hashv *= _mur_m; \
+ hashv ^= hashv >> 15; \
+ \
+ bkt = hashv & (num_bkts-1); \
+} while(0)
+
+/* key comparison function; return 0 if keys equal */
+#define HASH_KEYCMP(a,b,len) memcmp(a,b,len)
+
+/* iterate over items in a known bucket to find desired item */
+#define HASH_FIND_IN_BKT(tbl,hh,head,keyptr,keylen_in,out) \
+out = TYPEOF(out)((head.hh_head) ? ELMT_FROM_HH(tbl,head.hh_head) : NULL); \
+while (out) { \
+ if (out->hh.keylen == keylen_in) { \
+ if ((HASH_KEYCMP(out->hh.key,keyptr,keylen_in)) == 0) break; \
+ } \
+ out= TYPEOF(out)((out->hh.hh_next) ? \
+ ELMT_FROM_HH(tbl,out->hh.hh_next) : NULL); \
+}
+
+/* add an item to a bucket */
+#define HASH_ADD_TO_BKT(head,addhh) \
+do { \
+ head.count++; \
+ (addhh)->hh_next = head.hh_head; \
+ (addhh)->hh_prev = NULL; \
+ if (head.hh_head) { (head).hh_head->hh_prev = (addhh); } \
+ (head).hh_head=addhh; \
+ if (head.count >= ((head.expand_mult+1) * HASH_BKT_CAPACITY_THRESH) \
+ && (addhh)->tbl->noexpand != 1) { \
+ HASH_EXPAND_BUCKETS((addhh)->tbl); \
+ } \
+} while(0)
+
+/* remove an item from a given bucket */
+#define HASH_DEL_IN_BKT(hh,head,hh_del) \
+ (head).count--; \
+ if ((head).hh_head == hh_del) { \
+ (head).hh_head = hh_del->hh_next; \
+ } \
+ if (hh_del->hh_prev) { \
+ hh_del->hh_prev->hh_next = hh_del->hh_next; \
+ } \
+ if (hh_del->hh_next) { \
+ hh_del->hh_next->hh_prev = hh_del->hh_prev; \
+ }
+
+/* Bucket expansion has the effect of doubling the number of buckets
+ * and redistributing the items into the new buckets. Ideally the
+ * items will distribute more or less evenly into the new buckets
+ * (the extent to which this is true is a measure of the quality of
+ * the hash function as it applies to the key domain).
+ *
+ * With the items distributed into more buckets, the chain length
+ * (item count) in each bucket is reduced. Thus by expanding buckets
+ * the hash keeps a bound on the chain length. This bounded chain
+ * length is the essence of how a hash provides constant time lookup.
+ *
+ * The calculation of tbl->ideal_chain_maxlen below deserves some
+ * explanation. First, keep in mind that we're calculating the ideal
+ * maximum chain length based on the *new* (doubled) bucket count.
+ * In fractions this is just n/b (n=number of items,b=new num buckets).
+ * Since the ideal chain length is an integer, we want to calculate
+ * ceil(n/b). We don't depend on floating point arithmetic in this
+ * hash, so to calculate ceil(n/b) with integers we could write
+ *
+ * ceil(n/b) = (n/b) + ((n%b)?1:0)
+ *
+ * and in fact a previous version of this hash did just that.
+ * But now we have improved things a bit by recognizing that b is
+ * always a power of two. We keep its base 2 log handy (call it lb),
+ * so now we can write this with a bit shift and logical AND:
+ *
+ * ceil(n/b) = (n>>lb) + ( (n & (b-1)) ? 1:0)
+ *
+ */
+#define HASH_EXPAND_BUCKETS(tbl) \
+do { \
+ unsigned _he_bkt; \
+ unsigned _he_bkt_i; \
+ struct UT_hash_handle *_he_thh, *_he_hh_nxt; \
+ UT_hash_bucket *_he_new_buckets, *_he_newbkt; \
+ _he_new_buckets = (UT_hash_bucket*)uthash_bkt_malloc( \
+ 2 * tbl->num_buckets * sizeof(struct UT_hash_bucket)); \
+ if (!_he_new_buckets) { uthash_fatal( "out of memory"); } \
+ memset(_he_new_buckets, 0, \
+ 2 * tbl->num_buckets * sizeof(struct UT_hash_bucket)); \
+ tbl->ideal_chain_maxlen = \
+ (tbl->num_items >> (tbl->log2_num_buckets+1)) + \
+ ((tbl->num_items & ((tbl->num_buckets*2)-1)) ? 1 : 0); \
+ tbl->nonideal_items = 0; \
+ for(_he_bkt_i = 0; _he_bkt_i < tbl->num_buckets; _he_bkt_i++) \
+ { \
+ _he_thh = tbl->buckets[ _he_bkt_i ].hh_head; \
+ while (_he_thh) { \
+ _he_hh_nxt = _he_thh->hh_next; \
+ HASH_TO_BKT( _he_thh->hashv, tbl->num_buckets*2, _he_bkt); \
+ _he_newbkt = &(_he_new_buckets[ _he_bkt ]); \
+ if (++(_he_newbkt->count) > tbl->ideal_chain_maxlen) { \
+ tbl->nonideal_items++; \
+ _he_newbkt->expand_mult = _he_newbkt->count / \
+ tbl->ideal_chain_maxlen; \
+ } \
+ _he_thh->hh_prev = NULL; \
+ _he_thh->hh_next = _he_newbkt->hh_head; \
+ if (_he_newbkt->hh_head) _he_newbkt->hh_head->hh_prev = \
+ _he_thh; \
+ _he_newbkt->hh_head = _he_thh; \
+ _he_thh = _he_hh_nxt; \
+ } \
+ } \
+ tbl->num_buckets *= 2; \
+ tbl->log2_num_buckets++; \
+ uthash_bkt_free( tbl->buckets ); \
+ tbl->buckets = _he_new_buckets; \
+ tbl->ineff_expands = (tbl->nonideal_items > (tbl->num_items >> 1)) ? \
+ (tbl->ineff_expands+1) : 0; \
+ if (tbl->ineff_expands > 1) { \
+ tbl->noexpand=1; \
+ uthash_noexpand_fyi(tbl); \
+ } \
+ uthash_expand_fyi(tbl); \
+} while(0)
+
+
+/* This is an adaptation of Simon Tatham's O(n log(n)) mergesort */
+/* Note that HASH_SORT assumes the hash handle name to be hh.
+ * HASH_SRT was added to allow the hash handle name to be passed in. */
+#define HASH_SORT(head,cmpfcn) HASH_SRT(hh,head,cmpfcn)
+#define HASH_SRT(hh,head,cmpfcn) \
+do { \
+ unsigned _hs_i; \
+ unsigned _hs_looping,_hs_nmerges,_hs_insize,_hs_psize,_hs_qsize; \
+ struct UT_hash_handle *_hs_p, *_hs_q, *_hs_e, *_hs_list, *_hs_tail; \
+ if (head) { \
+ _hs_insize = 1; \
+ _hs_looping = 1; \
+ _hs_list = &((head)->hh); \
+ while (_hs_looping) { \
+ _hs_p = _hs_list; \
+ _hs_list = NULL; \
+ _hs_tail = NULL; \
+ _hs_nmerges = 0; \
+ while (_hs_p) { \
+ _hs_nmerges++; \
+ _hs_q = _hs_p; \
+ _hs_psize = 0; \
+ for ( _hs_i = 0; _hs_i < _hs_insize; _hs_i++ ) { \
+ _hs_psize++; \
+ _hs_q = (UT_hash_handle*)((_hs_q->next) ? \
+ ((void*)((char*)(_hs_q->next) + \
+ (head)->hh.tbl->hho)) : NULL); \
+ if (! (_hs_q) ) break; \
+ } \
+ _hs_qsize = _hs_insize; \
+ while ((_hs_psize > 0) || ((_hs_qsize > 0) && _hs_q )) { \
+ if (_hs_psize == 0) { \
+ _hs_e = _hs_q; \
+ _hs_q = (UT_hash_handle*)((_hs_q->next) ? \
+ ((void*)((char*)(_hs_q->next) + \
+ (head)->hh.tbl->hho)) : NULL); \
+ _hs_qsize--; \
+ } else if ( (_hs_qsize == 0) || !(_hs_q) ) { \
+ _hs_e = _hs_p; \
+ _hs_p = (UT_hash_handle*)((_hs_p->next) ? \
+ ((void*)((char*)(_hs_p->next) + \
+ (head)->hh.tbl->hho)) : NULL); \
+ _hs_psize--; \
+ } else if (( \
+ cmpfcn(TYPEOF(head)(ELMT_FROM_HH((head)->hh.tbl,_hs_p)), \
+ TYPEOF(head)(ELMT_FROM_HH((head)->hh.tbl,_hs_q))) \
+ ) <= 0) { \
+ _hs_e = _hs_p; \
+ _hs_p = (UT_hash_handle*)((_hs_p->next) ? \
+ ((void*)((char*)(_hs_p->next) + \
+ (head)->hh.tbl->hho)) : NULL); \
+ _hs_psize--; \
+ } else { \
+ _hs_e = _hs_q; \
+ _hs_q = (UT_hash_handle*)((_hs_q->next) ? \
+ ((void*)((char*)(_hs_q->next) + \
+ (head)->hh.tbl->hho)) : NULL); \
+ _hs_qsize--; \
+ } \
+ if ( _hs_tail ) { \
+ _hs_tail->next = ((_hs_e) ? \
+ ELMT_FROM_HH((head)->hh.tbl,_hs_e) : NULL); \
+ } else { \
+ _hs_list = _hs_e; \
+ } \
+ _hs_e->prev = ((_hs_tail) ? \
+ ELMT_FROM_HH((head)->hh.tbl,_hs_tail) : NULL); \
+ _hs_tail = _hs_e; \
+ } \
+ _hs_p = _hs_q; \
+ } \
+ _hs_tail->next = NULL; \
+ if ( _hs_nmerges <= 1 ) { \
+ _hs_looping=0; \
+ (head)->hh.tbl->tail = _hs_tail; \
+ (head) = TYPEOF(head)ELMT_FROM_HH((head)->hh.tbl, _hs_list); \
+ } \
+ _hs_insize *= 2; \
+ } \
+ HASH_FSCK(hh,head); \
+ } \
+} while (0)
+
+/* This function selects items from one hash into another hash.
+ * The end result is that the selected items have dual presence
+ * in both hashes. There is no copy of the items made; rather
+ * they are added into the new hash through a secondary hash
+ * hash handle that must be present in the structure. */
+#define HASH_SELECT(hh_dst, dst, hh_src, src, cond) \
+do { \
+ unsigned _src_bkt, _dst_bkt; \
+ void *_last_elt=NULL, *_elt; \
+ UT_hash_handle *_src_hh, *_dst_hh, *_last_elt_hh=NULL; \
+ ptrdiff_t _dst_hho = ((char*)(&(dst)->hh_dst) - (char*)(dst)); \
+ if (src) { \
+ for(_src_bkt=0; _src_bkt < (src)->hh_src.tbl->num_buckets; _src_bkt++) { \
+ for(_src_hh = (src)->hh_src.tbl->buckets[_src_bkt].hh_head; \
+ _src_hh; \
+ _src_hh = _src_hh->hh_next) { \
+ _elt = ELMT_FROM_HH((src)->hh_src.tbl, _src_hh); \
+ if (cond(_elt)) { \
+ _dst_hh = (UT_hash_handle*)(((char*)_elt) + _dst_hho); \
+ _dst_hh->key = _src_hh->key; \
+ _dst_hh->keylen = _src_hh->keylen; \
+ _dst_hh->hashv = _src_hh->hashv; \
+ _dst_hh->prev = _last_elt; \
+ _dst_hh->next = NULL; \
+ if (_last_elt_hh) { _last_elt_hh->next = _elt; } \
+ if (!dst) { \
+ dst = TYPEOF(dst)_elt; \
+ HASH_MAKE_TABLE(hh_dst,dst); \
+ } else { \
+ _dst_hh->tbl = (dst)->hh_dst.tbl; \
+ } \
+ HASH_TO_BKT(_dst_hh->hashv, _dst_hh->tbl->num_buckets, _dst_bkt); \
+ HASH_ADD_TO_BKT(_dst_hh->tbl->buckets[_dst_bkt],_dst_hh); \
+ (dst)->hh_dst.tbl->num_items++; \
+ _last_elt = _elt; \
+ _last_elt_hh = _dst_hh; \
+ } \
+ } \
+ } \
+ } \
+ HASH_FSCK(hh_dst,dst); \
+} while (0)
+
+#define HASH_CLEAR(hh,head) \
+do { \
+ if (head) { \
+ uthash_bkt_free((head)->hh.tbl->buckets ); \
+ uthash_tbl_free((head)->hh.tbl); \
+ (head)=NULL; \
+ } \
+} while(0)
+
+/* obtain a count of items in the hash */
+#define HASH_COUNT(head) HASH_CNT(hh,head)
+#define HASH_CNT(hh,head) (head?(head->hh.tbl->num_items):0)
+
+typedef struct UT_hash_bucket {
+ struct UT_hash_handle *hh_head;
+ unsigned count;
+
+ /* expand_mult is normally set to 0. In this situation, the max chain length
+ * threshold is enforced at its default value, HASH_BKT_CAPACITY_THRESH. (If
+ * the bucket's chain exceeds this length, bucket expansion is triggered).
+ * However, setting expand_mult to a non-zero value delays bucket expansion
+ * (that would be triggered by additions to this particular bucket)
+ * until its chain length reaches a *multiple* of HASH_BKT_CAPACITY_THRESH.
+ * (The multiplier is simply expand_mult+1). The whole idea of this
+ * multiplier is to reduce bucket expansions, since they are expensive, in
+ * situations where we know that a particular bucket tends to be overused.
+ * It is better to let its chain length grow to a longer yet-still-bounded
+ * value, than to do an O(n) bucket expansion too often.
+ */
+ unsigned expand_mult;
+
+} UT_hash_bucket;
+
+typedef struct UT_hash_table {
+ UT_hash_bucket *buckets;
+ unsigned num_buckets, log2_num_buckets;
+ unsigned num_items;
+ struct UT_hash_handle *tail; /* tail hh in app order, for fast append */
+ ptrdiff_t hho; /* hash handle offset (byte pos of hash handle in element */
+
+ /* in an ideal situation (all buckets used equally), no bucket would have
+ * more than ceil(#items/#buckets) items. that's the ideal chain length. */
+ unsigned ideal_chain_maxlen;
+
+ /* nonideal_items is the number of items in the hash whose chain position
+ * exceeds the ideal chain maxlen. these items pay the penalty for an uneven
+ * hash distribution; reaching them in a chain traversal takes >ideal steps */
+ unsigned nonideal_items;
+
+ /* ineffective expands occur when a bucket doubling was performed, but
+ * afterward, more than half the items in the hash had nonideal chain
+ * positions. If this happens on two consecutive expansions we inhibit any
+ * further expansion, as it's not helping; this happens when the hash
+ * function isn't a good fit for the key domain. When expansion is inhibited
+ * the hash will still work, albeit no longer in constant time. */
+ unsigned ineff_expands, noexpand;
+
+
+} UT_hash_table;
+
+
+typedef struct UT_hash_handle {
+ struct UT_hash_table *tbl;
+ void *prev; /* prev element in app order */
+ void *next; /* next element in app order */
+ struct UT_hash_handle *hh_prev; /* previous hh in bucket order */
+ struct UT_hash_handle *hh_next; /* next hh in bucket order */
+ void *key; /* ptr to enclosing struct's key */
+ unsigned keylen; /* enclosing struct's key len */
+ unsigned hashv; /* result of hash-fcn(key) */
+} UT_hash_handle;
+
+#endif /* UTHASH_H */
--- /dev/null
+/*
+Copyright (c) 2007-2009, Troy D. Hanson
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+#ifndef UTLIST_H
+#define UTLIST_H
+
+#define UTLIST_VERSION 1.0
+
+/* C++ requires extra stringent casting */
+#if defined __cplusplus
+#define LTYPEOF(x) (typeof(x))
+#else
+#define LTYPEOF(x)
+#endif
+/*
+ * This file contains macros to manipulate singly and doubly-linked lists.
+ *
+ * 1. LL_ macros: singly-linked lists.
+ * 2. DL_ macros: doubly-linked lists.
+ * 3. CDL_ macros: circular doubly-linked lists.
+ *
+ * To use singly-linked lists, your structure must have a "next" pointer.
+ * To use doubly-linked lists, your structure must "prev" and "next" pointers.
+ * Either way, the pointer to the head of the list must be initialized to NULL.
+ *
+ * ----------------.EXAMPLE -------------------------
+ * struct item {
+ * int id;
+ * struct item *prev, *next;
+ * }
+ *
+ * struct item *list = NULL:
+ *
+ * int main() {
+ * struct item *item;
+ * ... allocate and populate item ...
+ * DL_APPEND(list, item);
+ * }
+ * --------------------------------------------------
+ *
+ * For doubly-linked lists, the append and delete macros are O(1)
+ * For singly-linked lists, append and delete are O(n) but prepend is O(1)
+ * The sort macro is O(n log(n)) for all types of single/double/circular lists.
+ */
+
+/******************************************************************************
+ * The SORT macros *
+ *****************************************************************************/
+#define LL_SORT(l,cmp) \
+ LISTSORT(l,0,0,FIELD_OFFSET(l,next),cmp)
+#define DL_SORT(l,cmp) \
+ LISTSORT(l,0,FIELD_OFFSET(l,prev),FIELD_OFFSET(l,next),cmp)
+#define CDL_SORT(l,cmp) \
+ LISTSORT(l,1,FIELD_OFFSET(l,prev),FIELD_OFFSET(l,next),cmp)
+
+/* The macros can't assume or cast to the caller's list element type. So we use
+ * a couple tricks when we need to deal with those element's prev/next pointers.
+ * Basically we use char pointer arithmetic to get those field offsets. */
+#define FIELD_OFFSET(ptr,field) ((char*)&((ptr)->field) - (char*)(ptr))
+#define LNEXT(e,no) (*(char**)(((char*)e) + no))
+#define LPREV(e,po) (*(char**)(((char*)e) + po))
+/******************************************************************************
+ * The LISTSORT macro is an adaptation of Simon Tatham's O(n log(n)) mergesort*
+ * Unwieldy variable names used here to avoid shadowing passed-in variables. *
+ *****************************************************************************/
+#define LISTSORT(list, is_circular, po, no, cmp) \
+do { \
+ void *_ls_p, *_ls_q, *_ls_e, *_ls_tail, *_ls_oldhead; \
+ int _ls_insize, _ls_nmerges, _ls_psize, _ls_qsize, _ls_i, _ls_looping; \
+ int _ls_is_double = (po==0) ? 0 : 1; \
+ if (list) { \
+ _ls_insize = 1; \
+ _ls_looping = 1; \
+ while (_ls_looping) { \
+ _ls_p = list; \
+ _ls_oldhead = list; \
+ list = NULL; \
+ _ls_tail = NULL; \
+ _ls_nmerges = 0; \
+ while (_ls_p) { \
+ _ls_nmerges++; \
+ _ls_q = _ls_p; \
+ _ls_psize = 0; \
+ for (_ls_i = 0; _ls_i < _ls_insize; _ls_i++) { \
+ _ls_psize++; \
+ if (is_circular) { \
+ _ls_q = ((LNEXT(_ls_q,no) == _ls_oldhead) ? NULL : LNEXT(_ls_q,no)); \
+ } else { \
+ _ls_q = LNEXT(_ls_q,no); \
+ } \
+ if (!_ls_q) break; \
+ } \
+ _ls_qsize = _ls_insize; \
+ while (_ls_psize > 0 || (_ls_qsize > 0 && _ls_q)) { \
+ if (_ls_psize == 0) { \
+ _ls_e = _ls_q; _ls_q = LNEXT(_ls_q,no); _ls_qsize--; \
+ if (is_circular && _ls_q == _ls_oldhead) { _ls_q = NULL; } \
+ } else if (_ls_qsize == 0 || !_ls_q) { \
+ _ls_e = _ls_p; _ls_p = LNEXT(_ls_p,no); _ls_psize--; \
+ if (is_circular && (_ls_p == _ls_oldhead)) { _ls_p = NULL; } \
+ } else if (cmp(LTYPEOF(list)_ls_p,LTYPEOF(list)_ls_q) <= 0) { \
+ _ls_e = _ls_p; _ls_p = LNEXT(_ls_p,no); _ls_psize--; \
+ if (is_circular && (_ls_p == _ls_oldhead)) { _ls_p = NULL; } \
+ } else { \
+ _ls_e = _ls_q; _ls_q = LNEXT(_ls_q,no); _ls_qsize--; \
+ if (is_circular && (_ls_q == _ls_oldhead)) { _ls_q = NULL; } \
+ } \
+ if (_ls_tail) { \
+ LNEXT(_ls_tail,no) = (char*)_ls_e; \
+ } else { \
+ list = LTYPEOF(list)_ls_e; \
+ } \
+ if (_ls_is_double) { \
+ LPREV(_ls_e,po) = (char*)_ls_tail; \
+ } \
+ _ls_tail = _ls_e; \
+ } \
+ _ls_p = _ls_q; \
+ } \
+ if (is_circular) { \
+ LNEXT(_ls_tail,no) = (char*)list; \
+ if (_ls_is_double) { \
+ LPREV(list,po) = (char*)_ls_tail; \
+ } \
+ } else { \
+ LNEXT(_ls_tail,no) = NULL; \
+ } \
+ if (_ls_nmerges <= 1) { \
+ _ls_looping=0; \
+ } \
+ _ls_insize *= 2; \
+ } \
+ } \
+} while (0)
+
+/******************************************************************************
+ * singly linked list macros (non-circular) *
+ *****************************************************************************/
+#define LL_PREPEND(head,add) \
+do { \
+ (add)->next = head; \
+ head = add; \
+} while (0)
+
+#define LL_APPEND(head,add) \
+do { \
+ (add)->next=NULL; \
+ if (head) { \
+ char *_lla_el = (char*)(head); \
+ unsigned _lla_no = FIELD_OFFSET(head,next); \
+ while (LNEXT(_lla_el,_lla_no)) { _lla_el = LNEXT(_lla_el,_lla_no); } \
+ LNEXT(_lla_el,_lla_no)=(char*)(add); \
+ } else { \
+ (head)=(add); \
+ } \
+} while (0)
+
+#define LL_DELETE(head,del) \
+do { \
+ if ((head) == (del)) { \
+ (head)=(head)->next; \
+ } else { \
+ char *_lld_el = (char*)(head); \
+ unsigned _lld_no = FIELD_OFFSET(head,next); \
+ while (LNEXT(_lld_el,_lld_no) && (LNEXT(_lld_el,_lld_no) != (char*)(del))) { \
+ _lld_el = LNEXT(_lld_el,_lld_no); \
+ } \
+ if (LNEXT(_lld_el,_lld_no)) { \
+ LNEXT(_lld_el,_lld_no) = (char*)((del)->next); \
+ } \
+ } \
+} while (0)
+
+#define LL_FOREACH(head,el) \
+ for(el=head;el;el=el->next)
+
+/******************************************************************************
+ * doubly linked list macros (non-circular) *
+ *****************************************************************************/
+#define DL_PREPEND(head,add) \
+do { \
+ (add)->next = head; \
+ if (head) { \
+ (add)->prev = (head)->prev; \
+ (head)->prev = (add); \
+ } else { \
+ (add)->prev = (add); \
+ } \
+ (head) = (add); \
+} while (0)
+
+#define DL_APPEND(head,add) \
+do { \
+ if (head) { \
+ (add)->prev = (head)->prev; \
+ (head)->prev->next = (add); \
+ (head)->prev = (add); \
+ (add)->next = NULL; \
+ } else { \
+ (head)=(add); \
+ (head)->prev = (head); \
+ (head)->next = NULL; \
+ } \
+} while (0);
+
+#define DL_DELETE(head,del) \
+do { \
+ if ((del)->prev == (del)) { \
+ (head)=NULL; \
+ } else if ((del)==(head)) { \
+ (del)->next->prev = (del)->prev; \
+ (head) = (del)->next; \
+ } else { \
+ (del)->prev->next = (del)->next; \
+ if ((del)->next) { \
+ (del)->next->prev = (del)->prev; \
+ } else { \
+ (head)->prev = (del)->prev; \
+ } \
+ } \
+} while (0);
+
+
+#define DL_FOREACH(head,el) \
+ for(el=head;el;el=el->next)
+
+/******************************************************************************
+ * circular doubly linked list macros *
+ *****************************************************************************/
+#define CDL_PREPEND(head,add) \
+do { \
+ if (head) { \
+ (add)->prev = (head)->prev; \
+ (add)->next = (head); \
+ (head)->prev = (add); \
+ (add)->prev->next = (add); \
+ } else { \
+ (add)->prev = (add); \
+ (add)->next = (add); \
+ } \
+(head)=(add); \
+} while (0)
+
+#define CDL_DELETE(head,del) \
+do { \
+ if ( ((head)==(del)) && ((head)->next == (head))) { \
+ (head) = 0L; \
+ } else { \
+ (del)->next->prev = (del)->prev; \
+ (del)->prev->next = (del)->next; \
+ if ((del) == (head)) (head)=(del)->next; \
+ } \
+} while (0);
+
+#define CDL_FOREACH(head,el) \
+ for(el=head;el;el= (el->next==head ? 0L : el->next))
+
+
+#endif /* UTLIST_H */
+
--- /dev/null
+#ifndef ARRAY_LIST_H
+#define ARRAY_LIST_H
+
+/**
+ * A simple, resizable array list.
+ */
+template<typename T> class array_list {
+ static const size_t INITIAL_CAPACITY = 8;
+ size_t _size;
+ T * _data;
+ size_t _capacity;
+public:
+ array_list();
+ ~array_list();
+ size_t size();
+ void append(T value);
+ T replace(T old_value, T new_value);
+ size_t index_of(T value);
+ T & operator[](size_t index);
+};
+
+template<typename T> array_list<T>::array_list() {
+ _capacity = INITIAL_CAPACITY;
+ _data = (T *) malloc(sizeof(T) * _capacity);
+}
+
+template<typename T> array_list<T>::~array_list() {
+ delete _data;
+}
+
+template<typename T> size_t array_list<T>::size() {
+ return _size;
+}
+
+template<typename T> void array_list<T>::append(T value) {
+ if (_size == _capacity) {
+ _capacity = _capacity * 2;
+ _data = (T *) realloc(_data, _capacity * sizeof(T));
+ }
+ _data[_size++] = value;
+}
+
+/**
+ * Replaces the old_value in the list with the new_value.
+ * Returns the old_value if the replacement succeeded, or NULL otherwise.
+ */
+template<typename T> T array_list<T>::replace(T old_value, T new_value) {
+ int index = index_of(old_value);
+ if (index < 0) {
+ return NULL;
+ }
+ _data[index] = new_value;
+ return old_value;
+}
+
+template<typename T> size_t array_list<T>::index_of(T value) {
+ for (size_t i = 0; i < _size; i++) {
+ if (_data[i] == value) {
+ return i;
+ }
+ }
+ return -1;
+}
+
+template<typename T> T & array_list<T>::operator[](size_t index) {
+ return _data[index];
+}
+
+#endif /* ARRAY_LIST_H */
--- /dev/null
+/* -*- c -*-
+ ----------------------------------------------------------------
+
+ Notice that the following BSD-style license applies to this one
+ file (valgrind.h) only. The rest of Valgrind is licensed under the
+ terms of the GNU General Public License, version 2, unless
+ otherwise indicated. See the COPYING file in the source
+ distribution for details.
+
+ ----------------------------------------------------------------
+
+ This file is part of Valgrind, a dynamic binary instrumentation
+ framework.
+
+ Copyright (C) 2000-2008 Julian Seward. All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. The origin of this software must not be misrepresented; you must
+ not claim that you wrote the original software. If you use this
+ software in a product, an acknowledgment in the product
+ documentation would be appreciated but is not required.
+
+ 3. Altered source versions must be plainly marked as such, and must
+ not be misrepresented as being the original software.
+
+ 4. The name of the author may not be used to endorse or promote
+ products derived from this software without specific prior written
+ permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+ OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+ DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+ GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+ WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+ NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+ ----------------------------------------------------------------
+
+ Notice that the above BSD-style license applies to this one file
+ (valgrind.h) only. The entire rest of Valgrind is licensed under
+ the terms of the GNU General Public License, version 2. See the
+ COPYING file in the source distribution for details.
+
+ ----------------------------------------------------------------
+*/
+
+
+/* This file is for inclusion into client (your!) code.
+
+ You can use these macros to manipulate and query Valgrind's
+ execution inside your own programs.
+
+ The resulting executables will still run without Valgrind, just a
+ little bit more slowly than they otherwise would, but otherwise
+ unchanged. When not running on valgrind, each client request
+ consumes very few (eg. 7) instructions, so the resulting performance
+ loss is negligible unless you plan to execute client requests
+ millions of times per second. Nevertheless, if that is still a
+ problem, you can compile with the NVALGRIND symbol defined (gcc
+ -DNVALGRIND) so that client requests are not even compiled in. */
+
+#ifndef __VALGRIND_H
+#define __VALGRIND_H
+
+#include <stdarg.h>
+
+/* Nb: this file might be included in a file compiled with -ansi. So
+ we can't use C++ style "//" comments nor the "asm" keyword (instead
+ use "__asm__"). */
+
+/* Derive some tags indicating what the target platform is. Note
+ that in this file we're using the compiler's CPP symbols for
+ identifying architectures, which are different to the ones we use
+ within the rest of Valgrind. Note, __powerpc__ is active for both
+ 32 and 64-bit PPC, whereas __powerpc64__ is only active for the
+ latter (on Linux, that is). */
+#undef PLAT_x86_linux
+#undef PLAT_amd64_linux
+#undef PLAT_ppc32_linux
+#undef PLAT_ppc64_linux
+#undef PLAT_ppc32_aix5
+#undef PLAT_ppc64_aix5
+
+#if !defined(_AIX) && defined(__i386__)
+# define PLAT_x86_linux 1
+#elif !defined(_AIX) && defined(__x86_64__)
+# define PLAT_amd64_linux 1
+#elif !defined(_AIX) && defined(__powerpc__) && !defined(__powerpc64__)
+# define PLAT_ppc32_linux 1
+#elif !defined(_AIX) && defined(__powerpc__) && defined(__powerpc64__)
+# define PLAT_ppc64_linux 1
+#elif defined(_AIX) && defined(__64BIT__)
+# define PLAT_ppc64_aix5 1
+#elif defined(_AIX) && !defined(__64BIT__)
+# define PLAT_ppc32_aix5 1
+#endif
+
+
+/* If we're not compiling for our target platform, don't generate
+ any inline asms. */
+#if !defined(PLAT_x86_linux) && !defined(PLAT_amd64_linux) \
+ && !defined(PLAT_ppc32_linux) && !defined(PLAT_ppc64_linux) \
+ && !defined(PLAT_ppc32_aix5) && !defined(PLAT_ppc64_aix5)
+# if !defined(NVALGRIND)
+# define NVALGRIND 1
+# endif
+#endif
+
+
+/* ------------------------------------------------------------------ */
+/* ARCHITECTURE SPECIFICS for SPECIAL INSTRUCTIONS. There is nothing */
+/* in here of use to end-users -- skip to the next section. */
+/* ------------------------------------------------------------------ */
+
+#if defined(NVALGRIND)
+
+/* Define NVALGRIND to completely remove the Valgrind magic sequence
+ from the compiled code (analogous to NDEBUG's effects on
+ assert()) */
+#define VALGRIND_DO_CLIENT_REQUEST( \
+ _zzq_rlval, _zzq_default, _zzq_request, \
+ _zzq_arg1, _zzq_arg2, _zzq_arg3, _zzq_arg4, _zzq_arg5) \
+ { \
+ (_zzq_rlval) = (_zzq_default); \
+ }
+
+#else /* ! NVALGRIND */
+
+/* The following defines the magic code sequences which the JITter
+ spots and handles magically. Don't look too closely at them as
+ they will rot your brain.
+
+ The assembly code sequences for all architectures is in this one
+ file. This is because this file must be stand-alone, and we don't
+ want to have multiple files.
+
+ For VALGRIND_DO_CLIENT_REQUEST, we must ensure that the default
+ value gets put in the return slot, so that everything works when
+ this is executed not under Valgrind. Args are passed in a memory
+ block, and so there's no intrinsic limit to the number that could
+ be passed, but it's currently five.
+
+ The macro args are:
+ _zzq_rlval result lvalue
+ _zzq_default default value (result returned when running on real CPU)
+ _zzq_request request code
+ _zzq_arg1..5 request params
+
+ The other two macros are used to support function wrapping, and are
+ a lot simpler. VALGRIND_GET_NR_CONTEXT returns the value of the
+ guest's NRADDR pseudo-register and whatever other information is
+ needed to safely run the call original from the wrapper: on
+ ppc64-linux, the R2 value at the divert point is also needed. This
+ information is abstracted into a user-visible type, OrigFn.
+
+ VALGRIND_CALL_NOREDIR_* behaves the same as the following on the
+ guest, but guarantees that the branch instruction will not be
+ redirected: x86: call *%eax, amd64: call *%rax, ppc32/ppc64:
+ branch-and-link-to-r11. VALGRIND_CALL_NOREDIR is just text, not a
+ complete inline asm, since it needs to be combined with more magic
+ inline asm stuff to be useful.
+*/
+
+/* ------------------------- x86-linux ------------------------- */
+
+#if defined(PLAT_x86_linux)
+
+typedef
+ struct {
+ unsigned int nraddr; /* where's the code? */
+ }
+ OrigFn;
+
+#define __SPECIAL_INSTRUCTION_PREAMBLE \
+ "roll $3, %%edi ; roll $13, %%edi\n\t" \
+ "roll $29, %%edi ; roll $19, %%edi\n\t"
+
+#define VALGRIND_DO_CLIENT_REQUEST( \
+ _zzq_rlval, _zzq_default, _zzq_request, \
+ _zzq_arg1, _zzq_arg2, _zzq_arg3, _zzq_arg4, _zzq_arg5) \
+ { volatile unsigned int _zzq_args[6]; \
+ volatile unsigned int _zzq_result; \
+ _zzq_args[0] = (unsigned int)(_zzq_request); \
+ _zzq_args[1] = (unsigned int)(_zzq_arg1); \
+ _zzq_args[2] = (unsigned int)(_zzq_arg2); \
+ _zzq_args[3] = (unsigned int)(_zzq_arg3); \
+ _zzq_args[4] = (unsigned int)(_zzq_arg4); \
+ _zzq_args[5] = (unsigned int)(_zzq_arg5); \
+ __asm__ volatile(__SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %EDX = client_request ( %EAX ) */ \
+ "xchgl %%ebx,%%ebx" \
+ : "=d" (_zzq_result) \
+ : "a" (&_zzq_args[0]), "0" (_zzq_default) \
+ : "cc", "memory" \
+ ); \
+ _zzq_rlval = _zzq_result; \
+ }
+
+#define VALGRIND_GET_NR_CONTEXT(_zzq_rlval) \
+ { volatile OrigFn* _zzq_orig = &(_zzq_rlval); \
+ volatile unsigned int __addr; \
+ __asm__ volatile(__SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %EAX = guest_NRADDR */ \
+ "xchgl %%ecx,%%ecx" \
+ : "=a" (__addr) \
+ : \
+ : "cc", "memory" \
+ ); \
+ _zzq_orig->nraddr = __addr; \
+ }
+
+#define VALGRIND_CALL_NOREDIR_EAX \
+ __SPECIAL_INSTRUCTION_PREAMBLE \
+ /* call-noredir *%EAX */ \
+ "xchgl %%edx,%%edx\n\t"
+#endif /* PLAT_x86_linux */
+
+/* ------------------------ amd64-linux ------------------------ */
+
+#if defined(PLAT_amd64_linux)
+
+typedef
+ struct {
+ unsigned long long int nraddr; /* where's the code? */
+ }
+ OrigFn;
+
+#define __SPECIAL_INSTRUCTION_PREAMBLE \
+ "rolq $3, %%rdi ; rolq $13, %%rdi\n\t" \
+ "rolq $61, %%rdi ; rolq $51, %%rdi\n\t"
+
+#define VALGRIND_DO_CLIENT_REQUEST( \
+ _zzq_rlval, _zzq_default, _zzq_request, \
+ _zzq_arg1, _zzq_arg2, _zzq_arg3, _zzq_arg4, _zzq_arg5) \
+ { volatile unsigned long long int _zzq_args[6]; \
+ volatile unsigned long long int _zzq_result; \
+ _zzq_args[0] = (unsigned long long int)(_zzq_request); \
+ _zzq_args[1] = (unsigned long long int)(_zzq_arg1); \
+ _zzq_args[2] = (unsigned long long int)(_zzq_arg2); \
+ _zzq_args[3] = (unsigned long long int)(_zzq_arg3); \
+ _zzq_args[4] = (unsigned long long int)(_zzq_arg4); \
+ _zzq_args[5] = (unsigned long long int)(_zzq_arg5); \
+ __asm__ volatile(__SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %RDX = client_request ( %RAX ) */ \
+ "xchgq %%rbx,%%rbx" \
+ : "=d" (_zzq_result) \
+ : "a" (&_zzq_args[0]), "0" (_zzq_default) \
+ : "cc", "memory" \
+ ); \
+ _zzq_rlval = _zzq_result; \
+ }
+
+#define VALGRIND_GET_NR_CONTEXT(_zzq_rlval) \
+ { volatile OrigFn* _zzq_orig = &(_zzq_rlval); \
+ volatile unsigned long long int __addr; \
+ __asm__ volatile(__SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %RAX = guest_NRADDR */ \
+ "xchgq %%rcx,%%rcx" \
+ : "=a" (__addr) \
+ : \
+ : "cc", "memory" \
+ ); \
+ _zzq_orig->nraddr = __addr; \
+ }
+
+#define VALGRIND_CALL_NOREDIR_RAX \
+ __SPECIAL_INSTRUCTION_PREAMBLE \
+ /* call-noredir *%RAX */ \
+ "xchgq %%rdx,%%rdx\n\t"
+#endif /* PLAT_amd64_linux */
+
+/* ------------------------ ppc32-linux ------------------------ */
+
+#if defined(PLAT_ppc32_linux)
+
+typedef
+ struct {
+ unsigned int nraddr; /* where's the code? */
+ }
+ OrigFn;
+
+#define __SPECIAL_INSTRUCTION_PREAMBLE \
+ "rlwinm 0,0,3,0,0 ; rlwinm 0,0,13,0,0\n\t" \
+ "rlwinm 0,0,29,0,0 ; rlwinm 0,0,19,0,0\n\t"
+
+#define VALGRIND_DO_CLIENT_REQUEST( \
+ _zzq_rlval, _zzq_default, _zzq_request, \
+ _zzq_arg1, _zzq_arg2, _zzq_arg3, _zzq_arg4, _zzq_arg5) \
+ \
+ { unsigned int _zzq_args[6]; \
+ unsigned int _zzq_result; \
+ unsigned int* _zzq_ptr; \
+ _zzq_args[0] = (unsigned int)(_zzq_request); \
+ _zzq_args[1] = (unsigned int)(_zzq_arg1); \
+ _zzq_args[2] = (unsigned int)(_zzq_arg2); \
+ _zzq_args[3] = (unsigned int)(_zzq_arg3); \
+ _zzq_args[4] = (unsigned int)(_zzq_arg4); \
+ _zzq_args[5] = (unsigned int)(_zzq_arg5); \
+ _zzq_ptr = _zzq_args; \
+ __asm__ volatile("mr 3,%1\n\t" /*default*/ \
+ "mr 4,%2\n\t" /*ptr*/ \
+ __SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %R3 = client_request ( %R4 ) */ \
+ "or 1,1,1\n\t" \
+ "mr %0,3" /*result*/ \
+ : "=b" (_zzq_result) \
+ : "b" (_zzq_default), "b" (_zzq_ptr) \
+ : "cc", "memory", "r3", "r4"); \
+ _zzq_rlval = _zzq_result; \
+ }
+
+#define VALGRIND_GET_NR_CONTEXT(_zzq_rlval) \
+ { volatile OrigFn* _zzq_orig = &(_zzq_rlval); \
+ unsigned int __addr; \
+ __asm__ volatile(__SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %R3 = guest_NRADDR */ \
+ "or 2,2,2\n\t" \
+ "mr %0,3" \
+ : "=b" (__addr) \
+ : \
+ : "cc", "memory", "r3" \
+ ); \
+ _zzq_orig->nraddr = __addr; \
+ }
+
+#define VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ __SPECIAL_INSTRUCTION_PREAMBLE \
+ /* branch-and-link-to-noredir *%R11 */ \
+ "or 3,3,3\n\t"
+#endif /* PLAT_ppc32_linux */
+
+/* ------------------------ ppc64-linux ------------------------ */
+
+#if defined(PLAT_ppc64_linux)
+
+typedef
+ struct {
+ unsigned long long int nraddr; /* where's the code? */
+ unsigned long long int r2; /* what tocptr do we need? */
+ }
+ OrigFn;
+
+#define __SPECIAL_INSTRUCTION_PREAMBLE \
+ "rotldi 0,0,3 ; rotldi 0,0,13\n\t" \
+ "rotldi 0,0,61 ; rotldi 0,0,51\n\t"
+
+#define VALGRIND_DO_CLIENT_REQUEST( \
+ _zzq_rlval, _zzq_default, _zzq_request, \
+ _zzq_arg1, _zzq_arg2, _zzq_arg3, _zzq_arg4, _zzq_arg5) \
+ \
+ { unsigned long long int _zzq_args[6]; \
+ register unsigned long long int _zzq_result __asm__("r3"); \
+ register unsigned long long int* _zzq_ptr __asm__("r4"); \
+ _zzq_args[0] = (unsigned long long int)(_zzq_request); \
+ _zzq_args[1] = (unsigned long long int)(_zzq_arg1); \
+ _zzq_args[2] = (unsigned long long int)(_zzq_arg2); \
+ _zzq_args[3] = (unsigned long long int)(_zzq_arg3); \
+ _zzq_args[4] = (unsigned long long int)(_zzq_arg4); \
+ _zzq_args[5] = (unsigned long long int)(_zzq_arg5); \
+ _zzq_ptr = _zzq_args; \
+ __asm__ volatile(__SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %R3 = client_request ( %R4 ) */ \
+ "or 1,1,1" \
+ : "=r" (_zzq_result) \
+ : "0" (_zzq_default), "r" (_zzq_ptr) \
+ : "cc", "memory"); \
+ _zzq_rlval = _zzq_result; \
+ }
+
+#define VALGRIND_GET_NR_CONTEXT(_zzq_rlval) \
+ { volatile OrigFn* _zzq_orig = &(_zzq_rlval); \
+ register unsigned long long int __addr __asm__("r3"); \
+ __asm__ volatile(__SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %R3 = guest_NRADDR */ \
+ "or 2,2,2" \
+ : "=r" (__addr) \
+ : \
+ : "cc", "memory" \
+ ); \
+ _zzq_orig->nraddr = __addr; \
+ __asm__ volatile(__SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %R3 = guest_NRADDR_GPR2 */ \
+ "or 4,4,4" \
+ : "=r" (__addr) \
+ : \
+ : "cc", "memory" \
+ ); \
+ _zzq_orig->r2 = __addr; \
+ }
+
+#define VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ __SPECIAL_INSTRUCTION_PREAMBLE \
+ /* branch-and-link-to-noredir *%R11 */ \
+ "or 3,3,3\n\t"
+
+#endif /* PLAT_ppc64_linux */
+
+/* ------------------------ ppc32-aix5 ------------------------- */
+
+#if defined(PLAT_ppc32_aix5)
+
+typedef
+ struct {
+ unsigned int nraddr; /* where's the code? */
+ unsigned int r2; /* what tocptr do we need? */
+ }
+ OrigFn;
+
+#define __SPECIAL_INSTRUCTION_PREAMBLE \
+ "rlwinm 0,0,3,0,0 ; rlwinm 0,0,13,0,0\n\t" \
+ "rlwinm 0,0,29,0,0 ; rlwinm 0,0,19,0,0\n\t"
+
+#define VALGRIND_DO_CLIENT_REQUEST( \
+ _zzq_rlval, _zzq_default, _zzq_request, \
+ _zzq_arg1, _zzq_arg2, _zzq_arg3, _zzq_arg4, _zzq_arg5) \
+ \
+ { unsigned int _zzq_args[7]; \
+ register unsigned int _zzq_result; \
+ register unsigned int* _zzq_ptr; \
+ _zzq_args[0] = (unsigned int)(_zzq_request); \
+ _zzq_args[1] = (unsigned int)(_zzq_arg1); \
+ _zzq_args[2] = (unsigned int)(_zzq_arg2); \
+ _zzq_args[3] = (unsigned int)(_zzq_arg3); \
+ _zzq_args[4] = (unsigned int)(_zzq_arg4); \
+ _zzq_args[5] = (unsigned int)(_zzq_arg5); \
+ _zzq_args[6] = (unsigned int)(_zzq_default); \
+ _zzq_ptr = _zzq_args; \
+ __asm__ volatile("mr 4,%1\n\t" \
+ "lwz 3, 24(4)\n\t" \
+ __SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %R3 = client_request ( %R4 ) */ \
+ "or 1,1,1\n\t" \
+ "mr %0,3" \
+ : "=b" (_zzq_result) \
+ : "b" (_zzq_ptr) \
+ : "r3", "r4", "cc", "memory"); \
+ _zzq_rlval = _zzq_result; \
+ }
+
+#define VALGRIND_GET_NR_CONTEXT(_zzq_rlval) \
+ { volatile OrigFn* _zzq_orig = &(_zzq_rlval); \
+ register unsigned int __addr; \
+ __asm__ volatile(__SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %R3 = guest_NRADDR */ \
+ "or 2,2,2\n\t" \
+ "mr %0,3" \
+ : "=b" (__addr) \
+ : \
+ : "r3", "cc", "memory" \
+ ); \
+ _zzq_orig->nraddr = __addr; \
+ __asm__ volatile(__SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %R3 = guest_NRADDR_GPR2 */ \
+ "or 4,4,4\n\t" \
+ "mr %0,3" \
+ : "=b" (__addr) \
+ : \
+ : "r3", "cc", "memory" \
+ ); \
+ _zzq_orig->r2 = __addr; \
+ }
+
+#define VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ __SPECIAL_INSTRUCTION_PREAMBLE \
+ /* branch-and-link-to-noredir *%R11 */ \
+ "or 3,3,3\n\t"
+
+#endif /* PLAT_ppc32_aix5 */
+
+/* ------------------------ ppc64-aix5 ------------------------- */
+
+#if defined(PLAT_ppc64_aix5)
+
+typedef
+ struct {
+ unsigned long long int nraddr; /* where's the code? */
+ unsigned long long int r2; /* what tocptr do we need? */
+ }
+ OrigFn;
+
+#define __SPECIAL_INSTRUCTION_PREAMBLE \
+ "rotldi 0,0,3 ; rotldi 0,0,13\n\t" \
+ "rotldi 0,0,61 ; rotldi 0,0,51\n\t"
+
+#define VALGRIND_DO_CLIENT_REQUEST( \
+ _zzq_rlval, _zzq_default, _zzq_request, \
+ _zzq_arg1, _zzq_arg2, _zzq_arg3, _zzq_arg4, _zzq_arg5) \
+ \
+ { unsigned long long int _zzq_args[7]; \
+ register unsigned long long int _zzq_result; \
+ register unsigned long long int* _zzq_ptr; \
+ _zzq_args[0] = (unsigned int long long)(_zzq_request); \
+ _zzq_args[1] = (unsigned int long long)(_zzq_arg1); \
+ _zzq_args[2] = (unsigned int long long)(_zzq_arg2); \
+ _zzq_args[3] = (unsigned int long long)(_zzq_arg3); \
+ _zzq_args[4] = (unsigned int long long)(_zzq_arg4); \
+ _zzq_args[5] = (unsigned int long long)(_zzq_arg5); \
+ _zzq_args[6] = (unsigned int long long)(_zzq_default); \
+ _zzq_ptr = _zzq_args; \
+ __asm__ volatile("mr 4,%1\n\t" \
+ "ld 3, 48(4)\n\t" \
+ __SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %R3 = client_request ( %R4 ) */ \
+ "or 1,1,1\n\t" \
+ "mr %0,3" \
+ : "=b" (_zzq_result) \
+ : "b" (_zzq_ptr) \
+ : "r3", "r4", "cc", "memory"); \
+ _zzq_rlval = _zzq_result; \
+ }
+
+#define VALGRIND_GET_NR_CONTEXT(_zzq_rlval) \
+ { volatile OrigFn* _zzq_orig = &(_zzq_rlval); \
+ register unsigned long long int __addr; \
+ __asm__ volatile(__SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %R3 = guest_NRADDR */ \
+ "or 2,2,2\n\t" \
+ "mr %0,3" \
+ : "=b" (__addr) \
+ : \
+ : "r3", "cc", "memory" \
+ ); \
+ _zzq_orig->nraddr = __addr; \
+ __asm__ volatile(__SPECIAL_INSTRUCTION_PREAMBLE \
+ /* %R3 = guest_NRADDR_GPR2 */ \
+ "or 4,4,4\n\t" \
+ "mr %0,3" \
+ : "=b" (__addr) \
+ : \
+ : "r3", "cc", "memory" \
+ ); \
+ _zzq_orig->r2 = __addr; \
+ }
+
+#define VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ __SPECIAL_INSTRUCTION_PREAMBLE \
+ /* branch-and-link-to-noredir *%R11 */ \
+ "or 3,3,3\n\t"
+
+#endif /* PLAT_ppc64_aix5 */
+
+/* Insert assembly code for other platforms here... */
+
+#endif /* NVALGRIND */
+
+
+/* ------------------------------------------------------------------ */
+/* PLATFORM SPECIFICS for FUNCTION WRAPPING. This is all very */
+/* ugly. It's the least-worst tradeoff I can think of. */
+/* ------------------------------------------------------------------ */
+
+/* This section defines magic (a.k.a appalling-hack) macros for doing
+ guaranteed-no-redirection macros, so as to get from function
+ wrappers to the functions they are wrapping. The whole point is to
+ construct standard call sequences, but to do the call itself with a
+ special no-redirect call pseudo-instruction that the JIT
+ understands and handles specially. This section is long and
+ repetitious, and I can't see a way to make it shorter.
+
+ The naming scheme is as follows:
+
+ CALL_FN_{W,v}_{v,W,WW,WWW,WWWW,5W,6W,7W,etc}
+
+ 'W' stands for "word" and 'v' for "void". Hence there are
+ different macros for calling arity 0, 1, 2, 3, 4, etc, functions,
+ and for each, the possibility of returning a word-typed result, or
+ no result.
+*/
+
+/* Use these to write the name of your wrapper. NOTE: duplicates
+ VG_WRAP_FUNCTION_Z{U,Z} in pub_tool_redir.h. */
+
+#define I_WRAP_SONAME_FNNAME_ZU(soname,fnname) \
+ _vgwZU_##soname##_##fnname
+
+#define I_WRAP_SONAME_FNNAME_ZZ(soname,fnname) \
+ _vgwZZ_##soname##_##fnname
+
+/* Use this macro from within a wrapper function to collect the
+ context (address and possibly other info) of the original function.
+ Once you have that you can then use it in one of the CALL_FN_
+ macros. The type of the argument _lval is OrigFn. */
+#define VALGRIND_GET_ORIG_FN(_lval) VALGRIND_GET_NR_CONTEXT(_lval)
+
+/* Derivatives of the main macros below, for calling functions
+ returning void. */
+
+#define CALL_FN_v_v(fnptr) \
+ do { volatile unsigned long _junk; \
+ CALL_FN_W_v(_junk,fnptr); } while (0)
+
+#define CALL_FN_v_W(fnptr, arg1) \
+ do { volatile unsigned long _junk; \
+ CALL_FN_W_W(_junk,fnptr,arg1); } while (0)
+
+#define CALL_FN_v_WW(fnptr, arg1,arg2) \
+ do { volatile unsigned long _junk; \
+ CALL_FN_W_WW(_junk,fnptr,arg1,arg2); } while (0)
+
+#define CALL_FN_v_WWW(fnptr, arg1,arg2,arg3) \
+ do { volatile unsigned long _junk; \
+ CALL_FN_W_WWW(_junk,fnptr,arg1,arg2,arg3); } while (0)
+
+/* ------------------------- x86-linux ------------------------- */
+
+#if defined(PLAT_x86_linux)
+
+/* These regs are trashed by the hidden call. No need to mention eax
+ as gcc can already see that, plus causes gcc to bomb. */
+#define __CALLER_SAVED_REGS /*"eax"*/ "ecx", "edx"
+
+/* These CALL_FN_ macros assume that on x86-linux, sizeof(unsigned
+ long) == 4. */
+
+#define CALL_FN_W_v(lval, orig) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[1]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ __asm__ volatile( \
+ "movl (%%eax), %%eax\n\t" /* target->%eax */ \
+ VALGRIND_CALL_NOREDIR_EAX \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_W(lval, orig, arg1) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[2]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ __asm__ volatile( \
+ "pushl 4(%%eax)\n\t" \
+ "movl (%%eax), %%eax\n\t" /* target->%eax */ \
+ VALGRIND_CALL_NOREDIR_EAX \
+ "addl $4, %%esp\n" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WW(lval, orig, arg1,arg2) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ __asm__ volatile( \
+ "pushl 8(%%eax)\n\t" \
+ "pushl 4(%%eax)\n\t" \
+ "movl (%%eax), %%eax\n\t" /* target->%eax */ \
+ VALGRIND_CALL_NOREDIR_EAX \
+ "addl $8, %%esp\n" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WWW(lval, orig, arg1,arg2,arg3) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[4]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ __asm__ volatile( \
+ "pushl 12(%%eax)\n\t" \
+ "pushl 8(%%eax)\n\t" \
+ "pushl 4(%%eax)\n\t" \
+ "movl (%%eax), %%eax\n\t" /* target->%eax */ \
+ VALGRIND_CALL_NOREDIR_EAX \
+ "addl $12, %%esp\n" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WWWW(lval, orig, arg1,arg2,arg3,arg4) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[5]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ __asm__ volatile( \
+ "pushl 16(%%eax)\n\t" \
+ "pushl 12(%%eax)\n\t" \
+ "pushl 8(%%eax)\n\t" \
+ "pushl 4(%%eax)\n\t" \
+ "movl (%%eax), %%eax\n\t" /* target->%eax */ \
+ VALGRIND_CALL_NOREDIR_EAX \
+ "addl $16, %%esp\n" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_5W(lval, orig, arg1,arg2,arg3,arg4,arg5) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[6]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ __asm__ volatile( \
+ "pushl 20(%%eax)\n\t" \
+ "pushl 16(%%eax)\n\t" \
+ "pushl 12(%%eax)\n\t" \
+ "pushl 8(%%eax)\n\t" \
+ "pushl 4(%%eax)\n\t" \
+ "movl (%%eax), %%eax\n\t" /* target->%eax */ \
+ VALGRIND_CALL_NOREDIR_EAX \
+ "addl $20, %%esp\n" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_6W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[7]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ __asm__ volatile( \
+ "pushl 24(%%eax)\n\t" \
+ "pushl 20(%%eax)\n\t" \
+ "pushl 16(%%eax)\n\t" \
+ "pushl 12(%%eax)\n\t" \
+ "pushl 8(%%eax)\n\t" \
+ "pushl 4(%%eax)\n\t" \
+ "movl (%%eax), %%eax\n\t" /* target->%eax */ \
+ VALGRIND_CALL_NOREDIR_EAX \
+ "addl $24, %%esp\n" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_7W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[8]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ _argvec[7] = (unsigned long)(arg7); \
+ __asm__ volatile( \
+ "pushl 28(%%eax)\n\t" \
+ "pushl 24(%%eax)\n\t" \
+ "pushl 20(%%eax)\n\t" \
+ "pushl 16(%%eax)\n\t" \
+ "pushl 12(%%eax)\n\t" \
+ "pushl 8(%%eax)\n\t" \
+ "pushl 4(%%eax)\n\t" \
+ "movl (%%eax), %%eax\n\t" /* target->%eax */ \
+ VALGRIND_CALL_NOREDIR_EAX \
+ "addl $28, %%esp\n" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_8W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[9]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ _argvec[7] = (unsigned long)(arg7); \
+ _argvec[8] = (unsigned long)(arg8); \
+ __asm__ volatile( \
+ "pushl 32(%%eax)\n\t" \
+ "pushl 28(%%eax)\n\t" \
+ "pushl 24(%%eax)\n\t" \
+ "pushl 20(%%eax)\n\t" \
+ "pushl 16(%%eax)\n\t" \
+ "pushl 12(%%eax)\n\t" \
+ "pushl 8(%%eax)\n\t" \
+ "pushl 4(%%eax)\n\t" \
+ "movl (%%eax), %%eax\n\t" /* target->%eax */ \
+ VALGRIND_CALL_NOREDIR_EAX \
+ "addl $32, %%esp\n" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_9W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[10]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ _argvec[7] = (unsigned long)(arg7); \
+ _argvec[8] = (unsigned long)(arg8); \
+ _argvec[9] = (unsigned long)(arg9); \
+ __asm__ volatile( \
+ "pushl 36(%%eax)\n\t" \
+ "pushl 32(%%eax)\n\t" \
+ "pushl 28(%%eax)\n\t" \
+ "pushl 24(%%eax)\n\t" \
+ "pushl 20(%%eax)\n\t" \
+ "pushl 16(%%eax)\n\t" \
+ "pushl 12(%%eax)\n\t" \
+ "pushl 8(%%eax)\n\t" \
+ "pushl 4(%%eax)\n\t" \
+ "movl (%%eax), %%eax\n\t" /* target->%eax */ \
+ VALGRIND_CALL_NOREDIR_EAX \
+ "addl $36, %%esp\n" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_10W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[11]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ _argvec[7] = (unsigned long)(arg7); \
+ _argvec[8] = (unsigned long)(arg8); \
+ _argvec[9] = (unsigned long)(arg9); \
+ _argvec[10] = (unsigned long)(arg10); \
+ __asm__ volatile( \
+ "pushl 40(%%eax)\n\t" \
+ "pushl 36(%%eax)\n\t" \
+ "pushl 32(%%eax)\n\t" \
+ "pushl 28(%%eax)\n\t" \
+ "pushl 24(%%eax)\n\t" \
+ "pushl 20(%%eax)\n\t" \
+ "pushl 16(%%eax)\n\t" \
+ "pushl 12(%%eax)\n\t" \
+ "pushl 8(%%eax)\n\t" \
+ "pushl 4(%%eax)\n\t" \
+ "movl (%%eax), %%eax\n\t" /* target->%eax */ \
+ VALGRIND_CALL_NOREDIR_EAX \
+ "addl $40, %%esp\n" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_11W(lval, orig, arg1,arg2,arg3,arg4,arg5, \
+ arg6,arg7,arg8,arg9,arg10, \
+ arg11) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[12]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ _argvec[7] = (unsigned long)(arg7); \
+ _argvec[8] = (unsigned long)(arg8); \
+ _argvec[9] = (unsigned long)(arg9); \
+ _argvec[10] = (unsigned long)(arg10); \
+ _argvec[11] = (unsigned long)(arg11); \
+ __asm__ volatile( \
+ "pushl 44(%%eax)\n\t" \
+ "pushl 40(%%eax)\n\t" \
+ "pushl 36(%%eax)\n\t" \
+ "pushl 32(%%eax)\n\t" \
+ "pushl 28(%%eax)\n\t" \
+ "pushl 24(%%eax)\n\t" \
+ "pushl 20(%%eax)\n\t" \
+ "pushl 16(%%eax)\n\t" \
+ "pushl 12(%%eax)\n\t" \
+ "pushl 8(%%eax)\n\t" \
+ "pushl 4(%%eax)\n\t" \
+ "movl (%%eax), %%eax\n\t" /* target->%eax */ \
+ VALGRIND_CALL_NOREDIR_EAX \
+ "addl $44, %%esp\n" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_12W(lval, orig, arg1,arg2,arg3,arg4,arg5, \
+ arg6,arg7,arg8,arg9,arg10, \
+ arg11,arg12) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[13]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ _argvec[7] = (unsigned long)(arg7); \
+ _argvec[8] = (unsigned long)(arg8); \
+ _argvec[9] = (unsigned long)(arg9); \
+ _argvec[10] = (unsigned long)(arg10); \
+ _argvec[11] = (unsigned long)(arg11); \
+ _argvec[12] = (unsigned long)(arg12); \
+ __asm__ volatile( \
+ "pushl 48(%%eax)\n\t" \
+ "pushl 44(%%eax)\n\t" \
+ "pushl 40(%%eax)\n\t" \
+ "pushl 36(%%eax)\n\t" \
+ "pushl 32(%%eax)\n\t" \
+ "pushl 28(%%eax)\n\t" \
+ "pushl 24(%%eax)\n\t" \
+ "pushl 20(%%eax)\n\t" \
+ "pushl 16(%%eax)\n\t" \
+ "pushl 12(%%eax)\n\t" \
+ "pushl 8(%%eax)\n\t" \
+ "pushl 4(%%eax)\n\t" \
+ "movl (%%eax), %%eax\n\t" /* target->%eax */ \
+ VALGRIND_CALL_NOREDIR_EAX \
+ "addl $48, %%esp\n" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#endif /* PLAT_x86_linux */
+
+/* ------------------------ amd64-linux ------------------------ */
+
+#if defined(PLAT_amd64_linux)
+
+/* ARGREGS: rdi rsi rdx rcx r8 r9 (the rest on stack in R-to-L order) */
+
+/* These regs are trashed by the hidden call. */
+#define __CALLER_SAVED_REGS /*"rax",*/ "rcx", "rdx", "rsi", \
+ "rdi", "r8", "r9", "r10", "r11"
+
+/* These CALL_FN_ macros assume that on amd64-linux, sizeof(unsigned
+ long) == 8. */
+
+/* NB 9 Sept 07. There is a nasty kludge here in all these CALL_FN_
+ macros. In order not to trash the stack redzone, we need to drop
+ %rsp by 128 before the hidden call, and restore afterwards. The
+ nastyness is that it is only by luck that the stack still appears
+ to be unwindable during the hidden call - since then the behaviour
+ of any routine using this macro does not match what the CFI data
+ says. Sigh.
+
+ Why is this important? Imagine that a wrapper has a stack
+ allocated local, and passes to the hidden call, a pointer to it.
+ Because gcc does not know about the hidden call, it may allocate
+ that local in the redzone. Unfortunately the hidden call may then
+ trash it before it comes to use it. So we must step clear of the
+ redzone, for the duration of the hidden call, to make it safe.
+
+ Probably the same problem afflicts the other redzone-style ABIs too
+ (ppc64-linux, ppc32-aix5, ppc64-aix5); but for those, the stack is
+ self describing (none of this CFI nonsense) so at least messing
+ with the stack pointer doesn't give a danger of non-unwindable
+ stack. */
+
+#define CALL_FN_W_v(lval, orig) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[1]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ __asm__ volatile( \
+ "subq $128,%%rsp\n\t" \
+ "movq (%%rax), %%rax\n\t" /* target->%rax */ \
+ VALGRIND_CALL_NOREDIR_RAX \
+ "addq $128,%%rsp\n\t" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_W(lval, orig, arg1) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[2]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ __asm__ volatile( \
+ "subq $128,%%rsp\n\t" \
+ "movq 8(%%rax), %%rdi\n\t" \
+ "movq (%%rax), %%rax\n\t" /* target->%rax */ \
+ VALGRIND_CALL_NOREDIR_RAX \
+ "addq $128,%%rsp\n\t" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WW(lval, orig, arg1,arg2) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ __asm__ volatile( \
+ "subq $128,%%rsp\n\t" \
+ "movq 16(%%rax), %%rsi\n\t" \
+ "movq 8(%%rax), %%rdi\n\t" \
+ "movq (%%rax), %%rax\n\t" /* target->%rax */ \
+ VALGRIND_CALL_NOREDIR_RAX \
+ "addq $128,%%rsp\n\t" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WWW(lval, orig, arg1,arg2,arg3) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[4]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ __asm__ volatile( \
+ "subq $128,%%rsp\n\t" \
+ "movq 24(%%rax), %%rdx\n\t" \
+ "movq 16(%%rax), %%rsi\n\t" \
+ "movq 8(%%rax), %%rdi\n\t" \
+ "movq (%%rax), %%rax\n\t" /* target->%rax */ \
+ VALGRIND_CALL_NOREDIR_RAX \
+ "addq $128,%%rsp\n\t" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WWWW(lval, orig, arg1,arg2,arg3,arg4) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[5]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ __asm__ volatile( \
+ "subq $128,%%rsp\n\t" \
+ "movq 32(%%rax), %%rcx\n\t" \
+ "movq 24(%%rax), %%rdx\n\t" \
+ "movq 16(%%rax), %%rsi\n\t" \
+ "movq 8(%%rax), %%rdi\n\t" \
+ "movq (%%rax), %%rax\n\t" /* target->%rax */ \
+ VALGRIND_CALL_NOREDIR_RAX \
+ "addq $128,%%rsp\n\t" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_5W(lval, orig, arg1,arg2,arg3,arg4,arg5) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[6]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ __asm__ volatile( \
+ "subq $128,%%rsp\n\t" \
+ "movq 40(%%rax), %%r8\n\t" \
+ "movq 32(%%rax), %%rcx\n\t" \
+ "movq 24(%%rax), %%rdx\n\t" \
+ "movq 16(%%rax), %%rsi\n\t" \
+ "movq 8(%%rax), %%rdi\n\t" \
+ "movq (%%rax), %%rax\n\t" /* target->%rax */ \
+ VALGRIND_CALL_NOREDIR_RAX \
+ "addq $128,%%rsp\n\t" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_6W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[7]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ __asm__ volatile( \
+ "subq $128,%%rsp\n\t" \
+ "movq 48(%%rax), %%r9\n\t" \
+ "movq 40(%%rax), %%r8\n\t" \
+ "movq 32(%%rax), %%rcx\n\t" \
+ "movq 24(%%rax), %%rdx\n\t" \
+ "movq 16(%%rax), %%rsi\n\t" \
+ "movq 8(%%rax), %%rdi\n\t" \
+ "movq (%%rax), %%rax\n\t" /* target->%rax */ \
+ "addq $128,%%rsp\n\t" \
+ VALGRIND_CALL_NOREDIR_RAX \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_7W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[8]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ _argvec[7] = (unsigned long)(arg7); \
+ __asm__ volatile( \
+ "subq $128,%%rsp\n\t" \
+ "pushq 56(%%rax)\n\t" \
+ "movq 48(%%rax), %%r9\n\t" \
+ "movq 40(%%rax), %%r8\n\t" \
+ "movq 32(%%rax), %%rcx\n\t" \
+ "movq 24(%%rax), %%rdx\n\t" \
+ "movq 16(%%rax), %%rsi\n\t" \
+ "movq 8(%%rax), %%rdi\n\t" \
+ "movq (%%rax), %%rax\n\t" /* target->%rax */ \
+ VALGRIND_CALL_NOREDIR_RAX \
+ "addq $8, %%rsp\n" \
+ "addq $128,%%rsp\n\t" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_8W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[9]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ _argvec[7] = (unsigned long)(arg7); \
+ _argvec[8] = (unsigned long)(arg8); \
+ __asm__ volatile( \
+ "subq $128,%%rsp\n\t" \
+ "pushq 64(%%rax)\n\t" \
+ "pushq 56(%%rax)\n\t" \
+ "movq 48(%%rax), %%r9\n\t" \
+ "movq 40(%%rax), %%r8\n\t" \
+ "movq 32(%%rax), %%rcx\n\t" \
+ "movq 24(%%rax), %%rdx\n\t" \
+ "movq 16(%%rax), %%rsi\n\t" \
+ "movq 8(%%rax), %%rdi\n\t" \
+ "movq (%%rax), %%rax\n\t" /* target->%rax */ \
+ VALGRIND_CALL_NOREDIR_RAX \
+ "addq $16, %%rsp\n" \
+ "addq $128,%%rsp\n\t" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_9W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[10]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ _argvec[7] = (unsigned long)(arg7); \
+ _argvec[8] = (unsigned long)(arg8); \
+ _argvec[9] = (unsigned long)(arg9); \
+ __asm__ volatile( \
+ "subq $128,%%rsp\n\t" \
+ "pushq 72(%%rax)\n\t" \
+ "pushq 64(%%rax)\n\t" \
+ "pushq 56(%%rax)\n\t" \
+ "movq 48(%%rax), %%r9\n\t" \
+ "movq 40(%%rax), %%r8\n\t" \
+ "movq 32(%%rax), %%rcx\n\t" \
+ "movq 24(%%rax), %%rdx\n\t" \
+ "movq 16(%%rax), %%rsi\n\t" \
+ "movq 8(%%rax), %%rdi\n\t" \
+ "movq (%%rax), %%rax\n\t" /* target->%rax */ \
+ VALGRIND_CALL_NOREDIR_RAX \
+ "addq $24, %%rsp\n" \
+ "addq $128,%%rsp\n\t" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_10W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[11]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ _argvec[7] = (unsigned long)(arg7); \
+ _argvec[8] = (unsigned long)(arg8); \
+ _argvec[9] = (unsigned long)(arg9); \
+ _argvec[10] = (unsigned long)(arg10); \
+ __asm__ volatile( \
+ "subq $128,%%rsp\n\t" \
+ "pushq 80(%%rax)\n\t" \
+ "pushq 72(%%rax)\n\t" \
+ "pushq 64(%%rax)\n\t" \
+ "pushq 56(%%rax)\n\t" \
+ "movq 48(%%rax), %%r9\n\t" \
+ "movq 40(%%rax), %%r8\n\t" \
+ "movq 32(%%rax), %%rcx\n\t" \
+ "movq 24(%%rax), %%rdx\n\t" \
+ "movq 16(%%rax), %%rsi\n\t" \
+ "movq 8(%%rax), %%rdi\n\t" \
+ "movq (%%rax), %%rax\n\t" /* target->%rax */ \
+ VALGRIND_CALL_NOREDIR_RAX \
+ "addq $32, %%rsp\n" \
+ "addq $128,%%rsp\n\t" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_11W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10,arg11) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[12]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ _argvec[7] = (unsigned long)(arg7); \
+ _argvec[8] = (unsigned long)(arg8); \
+ _argvec[9] = (unsigned long)(arg9); \
+ _argvec[10] = (unsigned long)(arg10); \
+ _argvec[11] = (unsigned long)(arg11); \
+ __asm__ volatile( \
+ "subq $128,%%rsp\n\t" \
+ "pushq 88(%%rax)\n\t" \
+ "pushq 80(%%rax)\n\t" \
+ "pushq 72(%%rax)\n\t" \
+ "pushq 64(%%rax)\n\t" \
+ "pushq 56(%%rax)\n\t" \
+ "movq 48(%%rax), %%r9\n\t" \
+ "movq 40(%%rax), %%r8\n\t" \
+ "movq 32(%%rax), %%rcx\n\t" \
+ "movq 24(%%rax), %%rdx\n\t" \
+ "movq 16(%%rax), %%rsi\n\t" \
+ "movq 8(%%rax), %%rdi\n\t" \
+ "movq (%%rax), %%rax\n\t" /* target->%rax */ \
+ VALGRIND_CALL_NOREDIR_RAX \
+ "addq $40, %%rsp\n" \
+ "addq $128,%%rsp\n\t" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_12W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10,arg11,arg12) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[13]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)(arg1); \
+ _argvec[2] = (unsigned long)(arg2); \
+ _argvec[3] = (unsigned long)(arg3); \
+ _argvec[4] = (unsigned long)(arg4); \
+ _argvec[5] = (unsigned long)(arg5); \
+ _argvec[6] = (unsigned long)(arg6); \
+ _argvec[7] = (unsigned long)(arg7); \
+ _argvec[8] = (unsigned long)(arg8); \
+ _argvec[9] = (unsigned long)(arg9); \
+ _argvec[10] = (unsigned long)(arg10); \
+ _argvec[11] = (unsigned long)(arg11); \
+ _argvec[12] = (unsigned long)(arg12); \
+ __asm__ volatile( \
+ "subq $128,%%rsp\n\t" \
+ "pushq 96(%%rax)\n\t" \
+ "pushq 88(%%rax)\n\t" \
+ "pushq 80(%%rax)\n\t" \
+ "pushq 72(%%rax)\n\t" \
+ "pushq 64(%%rax)\n\t" \
+ "pushq 56(%%rax)\n\t" \
+ "movq 48(%%rax), %%r9\n\t" \
+ "movq 40(%%rax), %%r8\n\t" \
+ "movq 32(%%rax), %%rcx\n\t" \
+ "movq 24(%%rax), %%rdx\n\t" \
+ "movq 16(%%rax), %%rsi\n\t" \
+ "movq 8(%%rax), %%rdi\n\t" \
+ "movq (%%rax), %%rax\n\t" /* target->%rax */ \
+ VALGRIND_CALL_NOREDIR_RAX \
+ "addq $48, %%rsp\n" \
+ "addq $128,%%rsp\n\t" \
+ : /*out*/ "=a" (_res) \
+ : /*in*/ "a" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#endif /* PLAT_amd64_linux */
+
+/* ------------------------ ppc32-linux ------------------------ */
+
+#if defined(PLAT_ppc32_linux)
+
+/* This is useful for finding out about the on-stack stuff:
+
+ extern int f9 ( int,int,int,int,int,int,int,int,int );
+ extern int f10 ( int,int,int,int,int,int,int,int,int,int );
+ extern int f11 ( int,int,int,int,int,int,int,int,int,int,int );
+ extern int f12 ( int,int,int,int,int,int,int,int,int,int,int,int );
+
+ int g9 ( void ) {
+ return f9(11,22,33,44,55,66,77,88,99);
+ }
+ int g10 ( void ) {
+ return f10(11,22,33,44,55,66,77,88,99,110);
+ }
+ int g11 ( void ) {
+ return f11(11,22,33,44,55,66,77,88,99,110,121);
+ }
+ int g12 ( void ) {
+ return f12(11,22,33,44,55,66,77,88,99,110,121,132);
+ }
+*/
+
+/* ARGREGS: r3 r4 r5 r6 r7 r8 r9 r10 (the rest on stack somewhere) */
+
+/* These regs are trashed by the hidden call. */
+#define __CALLER_SAVED_REGS \
+ "lr", "ctr", "xer", \
+ "cr0", "cr1", "cr2", "cr3", "cr4", "cr5", "cr6", "cr7", \
+ "r0", "r2", "r3", "r4", "r5", "r6", "r7", "r8", "r9", "r10", \
+ "r11", "r12", "r13"
+
+/* These CALL_FN_ macros assume that on ppc32-linux,
+ sizeof(unsigned long) == 4. */
+
+#define CALL_FN_W_v(lval, orig) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[1]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "lwz 11,0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr %0,3" \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_W(lval, orig, arg1) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[2]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)arg1; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "lwz 3,4(11)\n\t" /* arg1->r3 */ \
+ "lwz 11,0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr %0,3" \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WW(lval, orig, arg1,arg2) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)arg1; \
+ _argvec[2] = (unsigned long)arg2; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "lwz 3,4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4,8(11)\n\t" \
+ "lwz 11,0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr %0,3" \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WWW(lval, orig, arg1,arg2,arg3) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[4]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)arg1; \
+ _argvec[2] = (unsigned long)arg2; \
+ _argvec[3] = (unsigned long)arg3; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "lwz 3,4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4,8(11)\n\t" \
+ "lwz 5,12(11)\n\t" \
+ "lwz 11,0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr %0,3" \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WWWW(lval, orig, arg1,arg2,arg3,arg4) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[5]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)arg1; \
+ _argvec[2] = (unsigned long)arg2; \
+ _argvec[3] = (unsigned long)arg3; \
+ _argvec[4] = (unsigned long)arg4; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "lwz 3,4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4,8(11)\n\t" \
+ "lwz 5,12(11)\n\t" \
+ "lwz 6,16(11)\n\t" /* arg4->r6 */ \
+ "lwz 11,0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr %0,3" \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_5W(lval, orig, arg1,arg2,arg3,arg4,arg5) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[6]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)arg1; \
+ _argvec[2] = (unsigned long)arg2; \
+ _argvec[3] = (unsigned long)arg3; \
+ _argvec[4] = (unsigned long)arg4; \
+ _argvec[5] = (unsigned long)arg5; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "lwz 3,4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4,8(11)\n\t" \
+ "lwz 5,12(11)\n\t" \
+ "lwz 6,16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7,20(11)\n\t" \
+ "lwz 11,0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr %0,3" \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_6W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[7]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)arg1; \
+ _argvec[2] = (unsigned long)arg2; \
+ _argvec[3] = (unsigned long)arg3; \
+ _argvec[4] = (unsigned long)arg4; \
+ _argvec[5] = (unsigned long)arg5; \
+ _argvec[6] = (unsigned long)arg6; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "lwz 3,4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4,8(11)\n\t" \
+ "lwz 5,12(11)\n\t" \
+ "lwz 6,16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7,20(11)\n\t" \
+ "lwz 8,24(11)\n\t" \
+ "lwz 11,0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr %0,3" \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_7W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[8]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)arg1; \
+ _argvec[2] = (unsigned long)arg2; \
+ _argvec[3] = (unsigned long)arg3; \
+ _argvec[4] = (unsigned long)arg4; \
+ _argvec[5] = (unsigned long)arg5; \
+ _argvec[6] = (unsigned long)arg6; \
+ _argvec[7] = (unsigned long)arg7; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "lwz 3,4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4,8(11)\n\t" \
+ "lwz 5,12(11)\n\t" \
+ "lwz 6,16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7,20(11)\n\t" \
+ "lwz 8,24(11)\n\t" \
+ "lwz 9,28(11)\n\t" \
+ "lwz 11,0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr %0,3" \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_8W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[9]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)arg1; \
+ _argvec[2] = (unsigned long)arg2; \
+ _argvec[3] = (unsigned long)arg3; \
+ _argvec[4] = (unsigned long)arg4; \
+ _argvec[5] = (unsigned long)arg5; \
+ _argvec[6] = (unsigned long)arg6; \
+ _argvec[7] = (unsigned long)arg7; \
+ _argvec[8] = (unsigned long)arg8; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "lwz 3,4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4,8(11)\n\t" \
+ "lwz 5,12(11)\n\t" \
+ "lwz 6,16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7,20(11)\n\t" \
+ "lwz 8,24(11)\n\t" \
+ "lwz 9,28(11)\n\t" \
+ "lwz 10,32(11)\n\t" /* arg8->r10 */ \
+ "lwz 11,0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr %0,3" \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_9W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[10]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)arg1; \
+ _argvec[2] = (unsigned long)arg2; \
+ _argvec[3] = (unsigned long)arg3; \
+ _argvec[4] = (unsigned long)arg4; \
+ _argvec[5] = (unsigned long)arg5; \
+ _argvec[6] = (unsigned long)arg6; \
+ _argvec[7] = (unsigned long)arg7; \
+ _argvec[8] = (unsigned long)arg8; \
+ _argvec[9] = (unsigned long)arg9; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "addi 1,1,-16\n\t" \
+ /* arg9 */ \
+ "lwz 3,36(11)\n\t" \
+ "stw 3,8(1)\n\t" \
+ /* args1-8 */ \
+ "lwz 3,4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4,8(11)\n\t" \
+ "lwz 5,12(11)\n\t" \
+ "lwz 6,16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7,20(11)\n\t" \
+ "lwz 8,24(11)\n\t" \
+ "lwz 9,28(11)\n\t" \
+ "lwz 10,32(11)\n\t" /* arg8->r10 */ \
+ "lwz 11,0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "addi 1,1,16\n\t" \
+ "mr %0,3" \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_10W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[11]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)arg1; \
+ _argvec[2] = (unsigned long)arg2; \
+ _argvec[3] = (unsigned long)arg3; \
+ _argvec[4] = (unsigned long)arg4; \
+ _argvec[5] = (unsigned long)arg5; \
+ _argvec[6] = (unsigned long)arg6; \
+ _argvec[7] = (unsigned long)arg7; \
+ _argvec[8] = (unsigned long)arg8; \
+ _argvec[9] = (unsigned long)arg9; \
+ _argvec[10] = (unsigned long)arg10; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "addi 1,1,-16\n\t" \
+ /* arg10 */ \
+ "lwz 3,40(11)\n\t" \
+ "stw 3,12(1)\n\t" \
+ /* arg9 */ \
+ "lwz 3,36(11)\n\t" \
+ "stw 3,8(1)\n\t" \
+ /* args1-8 */ \
+ "lwz 3,4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4,8(11)\n\t" \
+ "lwz 5,12(11)\n\t" \
+ "lwz 6,16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7,20(11)\n\t" \
+ "lwz 8,24(11)\n\t" \
+ "lwz 9,28(11)\n\t" \
+ "lwz 10,32(11)\n\t" /* arg8->r10 */ \
+ "lwz 11,0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "addi 1,1,16\n\t" \
+ "mr %0,3" \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_11W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10,arg11) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[12]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)arg1; \
+ _argvec[2] = (unsigned long)arg2; \
+ _argvec[3] = (unsigned long)arg3; \
+ _argvec[4] = (unsigned long)arg4; \
+ _argvec[5] = (unsigned long)arg5; \
+ _argvec[6] = (unsigned long)arg6; \
+ _argvec[7] = (unsigned long)arg7; \
+ _argvec[8] = (unsigned long)arg8; \
+ _argvec[9] = (unsigned long)arg9; \
+ _argvec[10] = (unsigned long)arg10; \
+ _argvec[11] = (unsigned long)arg11; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "addi 1,1,-32\n\t" \
+ /* arg11 */ \
+ "lwz 3,44(11)\n\t" \
+ "stw 3,16(1)\n\t" \
+ /* arg10 */ \
+ "lwz 3,40(11)\n\t" \
+ "stw 3,12(1)\n\t" \
+ /* arg9 */ \
+ "lwz 3,36(11)\n\t" \
+ "stw 3,8(1)\n\t" \
+ /* args1-8 */ \
+ "lwz 3,4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4,8(11)\n\t" \
+ "lwz 5,12(11)\n\t" \
+ "lwz 6,16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7,20(11)\n\t" \
+ "lwz 8,24(11)\n\t" \
+ "lwz 9,28(11)\n\t" \
+ "lwz 10,32(11)\n\t" /* arg8->r10 */ \
+ "lwz 11,0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "addi 1,1,32\n\t" \
+ "mr %0,3" \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_12W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10,arg11,arg12) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[13]; \
+ volatile unsigned long _res; \
+ _argvec[0] = (unsigned long)_orig.nraddr; \
+ _argvec[1] = (unsigned long)arg1; \
+ _argvec[2] = (unsigned long)arg2; \
+ _argvec[3] = (unsigned long)arg3; \
+ _argvec[4] = (unsigned long)arg4; \
+ _argvec[5] = (unsigned long)arg5; \
+ _argvec[6] = (unsigned long)arg6; \
+ _argvec[7] = (unsigned long)arg7; \
+ _argvec[8] = (unsigned long)arg8; \
+ _argvec[9] = (unsigned long)arg9; \
+ _argvec[10] = (unsigned long)arg10; \
+ _argvec[11] = (unsigned long)arg11; \
+ _argvec[12] = (unsigned long)arg12; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "addi 1,1,-32\n\t" \
+ /* arg12 */ \
+ "lwz 3,48(11)\n\t" \
+ "stw 3,20(1)\n\t" \
+ /* arg11 */ \
+ "lwz 3,44(11)\n\t" \
+ "stw 3,16(1)\n\t" \
+ /* arg10 */ \
+ "lwz 3,40(11)\n\t" \
+ "stw 3,12(1)\n\t" \
+ /* arg9 */ \
+ "lwz 3,36(11)\n\t" \
+ "stw 3,8(1)\n\t" \
+ /* args1-8 */ \
+ "lwz 3,4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4,8(11)\n\t" \
+ "lwz 5,12(11)\n\t" \
+ "lwz 6,16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7,20(11)\n\t" \
+ "lwz 8,24(11)\n\t" \
+ "lwz 9,28(11)\n\t" \
+ "lwz 10,32(11)\n\t" /* arg8->r10 */ \
+ "lwz 11,0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "addi 1,1,32\n\t" \
+ "mr %0,3" \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[0]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#endif /* PLAT_ppc32_linux */
+
+/* ------------------------ ppc64-linux ------------------------ */
+
+#if defined(PLAT_ppc64_linux)
+
+/* ARGREGS: r3 r4 r5 r6 r7 r8 r9 r10 (the rest on stack somewhere) */
+
+/* These regs are trashed by the hidden call. */
+#define __CALLER_SAVED_REGS \
+ "lr", "ctr", "xer", \
+ "cr0", "cr1", "cr2", "cr3", "cr4", "cr5", "cr6", "cr7", \
+ "r0", "r2", "r3", "r4", "r5", "r6", "r7", "r8", "r9", "r10", \
+ "r11", "r12", "r13"
+
+/* These CALL_FN_ macros assume that on ppc64-linux, sizeof(unsigned
+ long) == 8. */
+
+#define CALL_FN_W_v(lval, orig) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+0]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)" /* restore tocptr */ \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_W(lval, orig, arg1) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+1]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)" /* restore tocptr */ \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WW(lval, orig, arg1,arg2) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+2]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)" /* restore tocptr */ \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WWW(lval, orig, arg1,arg2,arg3) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+3]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)" /* restore tocptr */ \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WWWW(lval, orig, arg1,arg2,arg3,arg4) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+4]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)" /* restore tocptr */ \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_5W(lval, orig, arg1,arg2,arg3,arg4,arg5) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+5]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)" /* restore tocptr */ \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_6W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+6]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)" /* restore tocptr */ \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_7W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+7]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 9, 56(11)\n\t" /* arg7->r9 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)" /* restore tocptr */ \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_8W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+8]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 9, 56(11)\n\t" /* arg7->r9 */ \
+ "ld 10, 64(11)\n\t" /* arg8->r10 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)" /* restore tocptr */ \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_9W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+9]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ _argvec[2+9] = (unsigned long)arg9; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "addi 1,1,-128\n\t" /* expand stack frame */ \
+ /* arg9 */ \
+ "ld 3,72(11)\n\t" \
+ "std 3,112(1)\n\t" \
+ /* args1-8 */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 9, 56(11)\n\t" /* arg7->r9 */ \
+ "ld 10, 64(11)\n\t" /* arg8->r10 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ "addi 1,1,128" /* restore frame */ \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_10W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+10]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ _argvec[2+9] = (unsigned long)arg9; \
+ _argvec[2+10] = (unsigned long)arg10; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "addi 1,1,-128\n\t" /* expand stack frame */ \
+ /* arg10 */ \
+ "ld 3,80(11)\n\t" \
+ "std 3,120(1)\n\t" \
+ /* arg9 */ \
+ "ld 3,72(11)\n\t" \
+ "std 3,112(1)\n\t" \
+ /* args1-8 */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 9, 56(11)\n\t" /* arg7->r9 */ \
+ "ld 10, 64(11)\n\t" /* arg8->r10 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ "addi 1,1,128" /* restore frame */ \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_11W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10,arg11) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+11]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ _argvec[2+9] = (unsigned long)arg9; \
+ _argvec[2+10] = (unsigned long)arg10; \
+ _argvec[2+11] = (unsigned long)arg11; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "addi 1,1,-144\n\t" /* expand stack frame */ \
+ /* arg11 */ \
+ "ld 3,88(11)\n\t" \
+ "std 3,128(1)\n\t" \
+ /* arg10 */ \
+ "ld 3,80(11)\n\t" \
+ "std 3,120(1)\n\t" \
+ /* arg9 */ \
+ "ld 3,72(11)\n\t" \
+ "std 3,112(1)\n\t" \
+ /* args1-8 */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 9, 56(11)\n\t" /* arg7->r9 */ \
+ "ld 10, 64(11)\n\t" /* arg8->r10 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ "addi 1,1,144" /* restore frame */ \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_12W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10,arg11,arg12) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+12]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ _argvec[2+9] = (unsigned long)arg9; \
+ _argvec[2+10] = (unsigned long)arg10; \
+ _argvec[2+11] = (unsigned long)arg11; \
+ _argvec[2+12] = (unsigned long)arg12; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "addi 1,1,-144\n\t" /* expand stack frame */ \
+ /* arg12 */ \
+ "ld 3,96(11)\n\t" \
+ "std 3,136(1)\n\t" \
+ /* arg11 */ \
+ "ld 3,88(11)\n\t" \
+ "std 3,128(1)\n\t" \
+ /* arg10 */ \
+ "ld 3,80(11)\n\t" \
+ "std 3,120(1)\n\t" \
+ /* arg9 */ \
+ "ld 3,72(11)\n\t" \
+ "std 3,112(1)\n\t" \
+ /* args1-8 */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 9, 56(11)\n\t" /* arg7->r9 */ \
+ "ld 10, 64(11)\n\t" /* arg8->r10 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ "addi 1,1,144" /* restore frame */ \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#endif /* PLAT_ppc64_linux */
+
+/* ------------------------ ppc32-aix5 ------------------------- */
+
+#if defined(PLAT_ppc32_aix5)
+
+/* ARGREGS: r3 r4 r5 r6 r7 r8 r9 r10 (the rest on stack somewhere) */
+
+/* These regs are trashed by the hidden call. */
+#define __CALLER_SAVED_REGS \
+ "lr", "ctr", "xer", \
+ "cr0", "cr1", "cr2", "cr3", "cr4", "cr5", "cr6", "cr7", \
+ "r0", "r2", "r3", "r4", "r5", "r6", "r7", "r8", "r9", "r10", \
+ "r11", "r12", "r13"
+
+/* Expand the stack frame, copying enough info that unwinding
+ still works. Trashes r3. */
+
+#define VG_EXPAND_FRAME_BY_trashes_r3(_n_fr) \
+ "addi 1,1,-" #_n_fr "\n\t" \
+ "lwz 3," #_n_fr "(1)\n\t" \
+ "stw 3,0(1)\n\t"
+
+#define VG_CONTRACT_FRAME_BY(_n_fr) \
+ "addi 1,1," #_n_fr "\n\t"
+
+/* These CALL_FN_ macros assume that on ppc32-aix5, sizeof(unsigned
+ long) == 4. */
+
+#define CALL_FN_W_v(lval, orig) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+0]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "stw 2,-8(11)\n\t" /* save tocptr */ \
+ "lwz 2,-4(11)\n\t" /* use nraddr's tocptr */ \
+ "lwz 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "lwz 2,-8(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_W(lval, orig, arg1) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+1]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "stw 2,-8(11)\n\t" /* save tocptr */ \
+ "lwz 2,-4(11)\n\t" /* use nraddr's tocptr */ \
+ "lwz 3, 4(11)\n\t" /* arg1->r3 */ \
+ "lwz 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "lwz 2,-8(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WW(lval, orig, arg1,arg2) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+2]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "stw 2,-8(11)\n\t" /* save tocptr */ \
+ "lwz 2,-4(11)\n\t" /* use nraddr's tocptr */ \
+ "lwz 3, 4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4, 8(11)\n\t" /* arg2->r4 */ \
+ "lwz 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "lwz 2,-8(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WWW(lval, orig, arg1,arg2,arg3) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+3]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "stw 2,-8(11)\n\t" /* save tocptr */ \
+ "lwz 2,-4(11)\n\t" /* use nraddr's tocptr */ \
+ "lwz 3, 4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4, 8(11)\n\t" /* arg2->r4 */ \
+ "lwz 5, 12(11)\n\t" /* arg3->r5 */ \
+ "lwz 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "lwz 2,-8(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WWWW(lval, orig, arg1,arg2,arg3,arg4) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+4]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "stw 2,-8(11)\n\t" /* save tocptr */ \
+ "lwz 2,-4(11)\n\t" /* use nraddr's tocptr */ \
+ "lwz 3, 4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4, 8(11)\n\t" /* arg2->r4 */ \
+ "lwz 5, 12(11)\n\t" /* arg3->r5 */ \
+ "lwz 6, 16(11)\n\t" /* arg4->r6 */ \
+ "lwz 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "lwz 2,-8(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_5W(lval, orig, arg1,arg2,arg3,arg4,arg5) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+5]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "stw 2,-8(11)\n\t" /* save tocptr */ \
+ "lwz 2,-4(11)\n\t" /* use nraddr's tocptr */ \
+ "lwz 3, 4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4, 8(11)\n\t" /* arg2->r4 */ \
+ "lwz 5, 12(11)\n\t" /* arg3->r5 */ \
+ "lwz 6, 16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7, 20(11)\n\t" /* arg5->r7 */ \
+ "lwz 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "lwz 2,-8(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_6W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+6]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "stw 2,-8(11)\n\t" /* save tocptr */ \
+ "lwz 2,-4(11)\n\t" /* use nraddr's tocptr */ \
+ "lwz 3, 4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4, 8(11)\n\t" /* arg2->r4 */ \
+ "lwz 5, 12(11)\n\t" /* arg3->r5 */ \
+ "lwz 6, 16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7, 20(11)\n\t" /* arg5->r7 */ \
+ "lwz 8, 24(11)\n\t" /* arg6->r8 */ \
+ "lwz 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "lwz 2,-8(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_7W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+7]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "stw 2,-8(11)\n\t" /* save tocptr */ \
+ "lwz 2,-4(11)\n\t" /* use nraddr's tocptr */ \
+ "lwz 3, 4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4, 8(11)\n\t" /* arg2->r4 */ \
+ "lwz 5, 12(11)\n\t" /* arg3->r5 */ \
+ "lwz 6, 16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7, 20(11)\n\t" /* arg5->r7 */ \
+ "lwz 8, 24(11)\n\t" /* arg6->r8 */ \
+ "lwz 9, 28(11)\n\t" /* arg7->r9 */ \
+ "lwz 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "lwz 2,-8(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_8W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+8]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "stw 2,-8(11)\n\t" /* save tocptr */ \
+ "lwz 2,-4(11)\n\t" /* use nraddr's tocptr */ \
+ "lwz 3, 4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4, 8(11)\n\t" /* arg2->r4 */ \
+ "lwz 5, 12(11)\n\t" /* arg3->r5 */ \
+ "lwz 6, 16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7, 20(11)\n\t" /* arg5->r7 */ \
+ "lwz 8, 24(11)\n\t" /* arg6->r8 */ \
+ "lwz 9, 28(11)\n\t" /* arg7->r9 */ \
+ "lwz 10, 32(11)\n\t" /* arg8->r10 */ \
+ "lwz 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "lwz 2,-8(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_9W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+9]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ _argvec[2+9] = (unsigned long)arg9; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "stw 2,-8(11)\n\t" /* save tocptr */ \
+ "lwz 2,-4(11)\n\t" /* use nraddr's tocptr */ \
+ VG_EXPAND_FRAME_BY_trashes_r3(64) \
+ /* arg9 */ \
+ "lwz 3,36(11)\n\t" \
+ "stw 3,56(1)\n\t" \
+ /* args1-8 */ \
+ "lwz 3, 4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4, 8(11)\n\t" /* arg2->r4 */ \
+ "lwz 5, 12(11)\n\t" /* arg3->r5 */ \
+ "lwz 6, 16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7, 20(11)\n\t" /* arg5->r7 */ \
+ "lwz 8, 24(11)\n\t" /* arg6->r8 */ \
+ "lwz 9, 28(11)\n\t" /* arg7->r9 */ \
+ "lwz 10, 32(11)\n\t" /* arg8->r10 */ \
+ "lwz 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "lwz 2,-8(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(64) \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_10W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+10]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ _argvec[2+9] = (unsigned long)arg9; \
+ _argvec[2+10] = (unsigned long)arg10; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "stw 2,-8(11)\n\t" /* save tocptr */ \
+ "lwz 2,-4(11)\n\t" /* use nraddr's tocptr */ \
+ VG_EXPAND_FRAME_BY_trashes_r3(64) \
+ /* arg10 */ \
+ "lwz 3,40(11)\n\t" \
+ "stw 3,60(1)\n\t" \
+ /* arg9 */ \
+ "lwz 3,36(11)\n\t" \
+ "stw 3,56(1)\n\t" \
+ /* args1-8 */ \
+ "lwz 3, 4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4, 8(11)\n\t" /* arg2->r4 */ \
+ "lwz 5, 12(11)\n\t" /* arg3->r5 */ \
+ "lwz 6, 16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7, 20(11)\n\t" /* arg5->r7 */ \
+ "lwz 8, 24(11)\n\t" /* arg6->r8 */ \
+ "lwz 9, 28(11)\n\t" /* arg7->r9 */ \
+ "lwz 10, 32(11)\n\t" /* arg8->r10 */ \
+ "lwz 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "lwz 2,-8(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(64) \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_11W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10,arg11) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+11]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ _argvec[2+9] = (unsigned long)arg9; \
+ _argvec[2+10] = (unsigned long)arg10; \
+ _argvec[2+11] = (unsigned long)arg11; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "stw 2,-8(11)\n\t" /* save tocptr */ \
+ "lwz 2,-4(11)\n\t" /* use nraddr's tocptr */ \
+ VG_EXPAND_FRAME_BY_trashes_r3(72) \
+ /* arg11 */ \
+ "lwz 3,44(11)\n\t" \
+ "stw 3,64(1)\n\t" \
+ /* arg10 */ \
+ "lwz 3,40(11)\n\t" \
+ "stw 3,60(1)\n\t" \
+ /* arg9 */ \
+ "lwz 3,36(11)\n\t" \
+ "stw 3,56(1)\n\t" \
+ /* args1-8 */ \
+ "lwz 3, 4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4, 8(11)\n\t" /* arg2->r4 */ \
+ "lwz 5, 12(11)\n\t" /* arg3->r5 */ \
+ "lwz 6, 16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7, 20(11)\n\t" /* arg5->r7 */ \
+ "lwz 8, 24(11)\n\t" /* arg6->r8 */ \
+ "lwz 9, 28(11)\n\t" /* arg7->r9 */ \
+ "lwz 10, 32(11)\n\t" /* arg8->r10 */ \
+ "lwz 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "lwz 2,-8(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(72) \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_12W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10,arg11,arg12) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+12]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ _argvec[2+9] = (unsigned long)arg9; \
+ _argvec[2+10] = (unsigned long)arg10; \
+ _argvec[2+11] = (unsigned long)arg11; \
+ _argvec[2+12] = (unsigned long)arg12; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "stw 2,-8(11)\n\t" /* save tocptr */ \
+ "lwz 2,-4(11)\n\t" /* use nraddr's tocptr */ \
+ VG_EXPAND_FRAME_BY_trashes_r3(72) \
+ /* arg12 */ \
+ "lwz 3,48(11)\n\t" \
+ "stw 3,68(1)\n\t" \
+ /* arg11 */ \
+ "lwz 3,44(11)\n\t" \
+ "stw 3,64(1)\n\t" \
+ /* arg10 */ \
+ "lwz 3,40(11)\n\t" \
+ "stw 3,60(1)\n\t" \
+ /* arg9 */ \
+ "lwz 3,36(11)\n\t" \
+ "stw 3,56(1)\n\t" \
+ /* args1-8 */ \
+ "lwz 3, 4(11)\n\t" /* arg1->r3 */ \
+ "lwz 4, 8(11)\n\t" /* arg2->r4 */ \
+ "lwz 5, 12(11)\n\t" /* arg3->r5 */ \
+ "lwz 6, 16(11)\n\t" /* arg4->r6 */ \
+ "lwz 7, 20(11)\n\t" /* arg5->r7 */ \
+ "lwz 8, 24(11)\n\t" /* arg6->r8 */ \
+ "lwz 9, 28(11)\n\t" /* arg7->r9 */ \
+ "lwz 10, 32(11)\n\t" /* arg8->r10 */ \
+ "lwz 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "lwz 2,-8(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(72) \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#endif /* PLAT_ppc32_aix5 */
+
+/* ------------------------ ppc64-aix5 ------------------------- */
+
+#if defined(PLAT_ppc64_aix5)
+
+/* ARGREGS: r3 r4 r5 r6 r7 r8 r9 r10 (the rest on stack somewhere) */
+
+/* These regs are trashed by the hidden call. */
+#define __CALLER_SAVED_REGS \
+ "lr", "ctr", "xer", \
+ "cr0", "cr1", "cr2", "cr3", "cr4", "cr5", "cr6", "cr7", \
+ "r0", "r2", "r3", "r4", "r5", "r6", "r7", "r8", "r9", "r10", \
+ "r11", "r12", "r13"
+
+/* Expand the stack frame, copying enough info that unwinding
+ still works. Trashes r3. */
+
+#define VG_EXPAND_FRAME_BY_trashes_r3(_n_fr) \
+ "addi 1,1,-" #_n_fr "\n\t" \
+ "ld 3," #_n_fr "(1)\n\t" \
+ "std 3,0(1)\n\t"
+
+#define VG_CONTRACT_FRAME_BY(_n_fr) \
+ "addi 1,1," #_n_fr "\n\t"
+
+/* These CALL_FN_ macros assume that on ppc64-aix5, sizeof(unsigned
+ long) == 8. */
+
+#define CALL_FN_W_v(lval, orig) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+0]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_W(lval, orig, arg1) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+1]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WW(lval, orig, arg1,arg2) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+2]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WWW(lval, orig, arg1,arg2,arg3) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+3]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_WWWW(lval, orig, arg1,arg2,arg3,arg4) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+4]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_5W(lval, orig, arg1,arg2,arg3,arg4,arg5) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+5]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_6W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+6]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_7W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+7]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 9, 56(11)\n\t" /* arg7->r9 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_8W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+8]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 9, 56(11)\n\t" /* arg7->r9 */ \
+ "ld 10, 64(11)\n\t" /* arg8->r10 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_9W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+9]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ _argvec[2+9] = (unsigned long)arg9; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ VG_EXPAND_FRAME_BY_trashes_r3(128) \
+ /* arg9 */ \
+ "ld 3,72(11)\n\t" \
+ "std 3,112(1)\n\t" \
+ /* args1-8 */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 9, 56(11)\n\t" /* arg7->r9 */ \
+ "ld 10, 64(11)\n\t" /* arg8->r10 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(128) \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_10W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+10]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ _argvec[2+9] = (unsigned long)arg9; \
+ _argvec[2+10] = (unsigned long)arg10; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ VG_EXPAND_FRAME_BY_trashes_r3(128) \
+ /* arg10 */ \
+ "ld 3,80(11)\n\t" \
+ "std 3,120(1)\n\t" \
+ /* arg9 */ \
+ "ld 3,72(11)\n\t" \
+ "std 3,112(1)\n\t" \
+ /* args1-8 */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 9, 56(11)\n\t" /* arg7->r9 */ \
+ "ld 10, 64(11)\n\t" /* arg8->r10 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(128) \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_11W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10,arg11) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+11]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ _argvec[2+9] = (unsigned long)arg9; \
+ _argvec[2+10] = (unsigned long)arg10; \
+ _argvec[2+11] = (unsigned long)arg11; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ VG_EXPAND_FRAME_BY_trashes_r3(144) \
+ /* arg11 */ \
+ "ld 3,88(11)\n\t" \
+ "std 3,128(1)\n\t" \
+ /* arg10 */ \
+ "ld 3,80(11)\n\t" \
+ "std 3,120(1)\n\t" \
+ /* arg9 */ \
+ "ld 3,72(11)\n\t" \
+ "std 3,112(1)\n\t" \
+ /* args1-8 */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 9, 56(11)\n\t" /* arg7->r9 */ \
+ "ld 10, 64(11)\n\t" /* arg8->r10 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(144) \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#define CALL_FN_W_12W(lval, orig, arg1,arg2,arg3,arg4,arg5,arg6, \
+ arg7,arg8,arg9,arg10,arg11,arg12) \
+ do { \
+ volatile OrigFn _orig = (orig); \
+ volatile unsigned long _argvec[3+12]; \
+ volatile unsigned long _res; \
+ /* _argvec[0] holds current r2 across the call */ \
+ _argvec[1] = (unsigned long)_orig.r2; \
+ _argvec[2] = (unsigned long)_orig.nraddr; \
+ _argvec[2+1] = (unsigned long)arg1; \
+ _argvec[2+2] = (unsigned long)arg2; \
+ _argvec[2+3] = (unsigned long)arg3; \
+ _argvec[2+4] = (unsigned long)arg4; \
+ _argvec[2+5] = (unsigned long)arg5; \
+ _argvec[2+6] = (unsigned long)arg6; \
+ _argvec[2+7] = (unsigned long)arg7; \
+ _argvec[2+8] = (unsigned long)arg8; \
+ _argvec[2+9] = (unsigned long)arg9; \
+ _argvec[2+10] = (unsigned long)arg10; \
+ _argvec[2+11] = (unsigned long)arg11; \
+ _argvec[2+12] = (unsigned long)arg12; \
+ __asm__ volatile( \
+ "mr 11,%1\n\t" \
+ VG_EXPAND_FRAME_BY_trashes_r3(512) \
+ "std 2,-16(11)\n\t" /* save tocptr */ \
+ "ld 2,-8(11)\n\t" /* use nraddr's tocptr */ \
+ VG_EXPAND_FRAME_BY_trashes_r3(144) \
+ /* arg12 */ \
+ "ld 3,96(11)\n\t" \
+ "std 3,136(1)\n\t" \
+ /* arg11 */ \
+ "ld 3,88(11)\n\t" \
+ "std 3,128(1)\n\t" \
+ /* arg10 */ \
+ "ld 3,80(11)\n\t" \
+ "std 3,120(1)\n\t" \
+ /* arg9 */ \
+ "ld 3,72(11)\n\t" \
+ "std 3,112(1)\n\t" \
+ /* args1-8 */ \
+ "ld 3, 8(11)\n\t" /* arg1->r3 */ \
+ "ld 4, 16(11)\n\t" /* arg2->r4 */ \
+ "ld 5, 24(11)\n\t" /* arg3->r5 */ \
+ "ld 6, 32(11)\n\t" /* arg4->r6 */ \
+ "ld 7, 40(11)\n\t" /* arg5->r7 */ \
+ "ld 8, 48(11)\n\t" /* arg6->r8 */ \
+ "ld 9, 56(11)\n\t" /* arg7->r9 */ \
+ "ld 10, 64(11)\n\t" /* arg8->r10 */ \
+ "ld 11, 0(11)\n\t" /* target->r11 */ \
+ VALGRIND_BRANCH_AND_LINK_TO_NOREDIR_R11 \
+ "mr 11,%1\n\t" \
+ "mr %0,3\n\t" \
+ "ld 2,-16(11)\n\t" /* restore tocptr */ \
+ VG_CONTRACT_FRAME_BY(144) \
+ VG_CONTRACT_FRAME_BY(512) \
+ : /*out*/ "=r" (_res) \
+ : /*in*/ "r" (&_argvec[2]) \
+ : /*trash*/ "cc", "memory", __CALLER_SAVED_REGS \
+ ); \
+ lval = (__typeof__(lval)) _res; \
+ } while (0)
+
+#endif /* PLAT_ppc64_aix5 */
+
+
+/* ------------------------------------------------------------------ */
+/* ARCHITECTURE INDEPENDENT MACROS for CLIENT REQUESTS. */
+/* */
+/* ------------------------------------------------------------------ */
+
+/* Some request codes. There are many more of these, but most are not
+ exposed to end-user view. These are the public ones, all of the
+ form 0x1000 + small_number.
+
+ Core ones are in the range 0x00000000--0x0000ffff. The non-public
+ ones start at 0x2000.
+*/
+
+/* These macros are used by tools -- they must be public, but don't
+ embed them into other programs. */
+#define VG_USERREQ_TOOL_BASE(a,b) \
+ ((unsigned int)(((a)&0xff) << 24 | ((b)&0xff) << 16))
+#define VG_IS_TOOL_USERREQ(a, b, v) \
+ (VG_USERREQ_TOOL_BASE(a,b) == ((v) & 0xffff0000))
+
+/* !! ABIWARNING !! ABIWARNING !! ABIWARNING !! ABIWARNING !!
+ This enum comprises an ABI exported by Valgrind to programs
+ which use client requests. DO NOT CHANGE THE ORDER OF THESE
+ ENTRIES, NOR DELETE ANY -- add new ones at the end. */
+typedef
+ enum { VG_USERREQ__RUNNING_ON_VALGRIND = 0x1001,
+ VG_USERREQ__DISCARD_TRANSLATIONS = 0x1002,
+
+ /* These allow any function to be called from the simulated
+ CPU but run on the real CPU. Nb: the first arg passed to
+ the function is always the ThreadId of the running
+ thread! So CLIENT_CALL0 actually requires a 1 arg
+ function, etc. */
+ VG_USERREQ__CLIENT_CALL0 = 0x1101,
+ VG_USERREQ__CLIENT_CALL1 = 0x1102,
+ VG_USERREQ__CLIENT_CALL2 = 0x1103,
+ VG_USERREQ__CLIENT_CALL3 = 0x1104,
+
+ /* Can be useful in regression testing suites -- eg. can
+ send Valgrind's output to /dev/null and still count
+ errors. */
+ VG_USERREQ__COUNT_ERRORS = 0x1201,
+
+ /* These are useful and can be interpreted by any tool that
+ tracks malloc() et al, by using vg_replace_malloc.c. */
+ VG_USERREQ__MALLOCLIKE_BLOCK = 0x1301,
+ VG_USERREQ__FREELIKE_BLOCK = 0x1302,
+ /* Memory pool support. */
+ VG_USERREQ__CREATE_MEMPOOL = 0x1303,
+ VG_USERREQ__DESTROY_MEMPOOL = 0x1304,
+ VG_USERREQ__MEMPOOL_ALLOC = 0x1305,
+ VG_USERREQ__MEMPOOL_FREE = 0x1306,
+ VG_USERREQ__MEMPOOL_TRIM = 0x1307,
+ VG_USERREQ__MOVE_MEMPOOL = 0x1308,
+ VG_USERREQ__MEMPOOL_CHANGE = 0x1309,
+ VG_USERREQ__MEMPOOL_EXISTS = 0x130a,
+
+ /* Allow printfs to valgrind log. */
+ VG_USERREQ__PRINTF = 0x1401,
+ VG_USERREQ__PRINTF_BACKTRACE = 0x1402,
+
+ /* Stack support. */
+ VG_USERREQ__STACK_REGISTER = 0x1501,
+ VG_USERREQ__STACK_DEREGISTER = 0x1502,
+ VG_USERREQ__STACK_CHANGE = 0x1503
+ } Vg_ClientRequest;
+
+#if !defined(__GNUC__)
+# define __extension__ /* */
+#endif
+
+/* Returns the number of Valgrinds this code is running under. That
+ is, 0 if running natively, 1 if running under Valgrind, 2 if
+ running under Valgrind which is running under another Valgrind,
+ etc. */
+#define RUNNING_ON_VALGRIND __extension__ \
+ ({unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0 /* if not */, \
+ VG_USERREQ__RUNNING_ON_VALGRIND, \
+ 0, 0, 0, 0, 0); \
+ _qzz_res; \
+ })
+
+
+/* Discard translation of code in the range [_qzz_addr .. _qzz_addr +
+ _qzz_len - 1]. Useful if you are debugging a JITter or some such,
+ since it provides a way to make sure valgrind will retranslate the
+ invalidated area. Returns no value. */
+#define VALGRIND_DISCARD_TRANSLATIONS(_qzz_addr,_qzz_len) \
+ {unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__DISCARD_TRANSLATIONS, \
+ _qzz_addr, _qzz_len, 0, 0, 0); \
+ }
+
+
+/* These requests are for getting Valgrind itself to print something.
+ Possibly with a backtrace. This is a really ugly hack. */
+
+#if defined(NVALGRIND)
+
+# define VALGRIND_PRINTF(...)
+# define VALGRIND_PRINTF_BACKTRACE(...)
+
+#else /* NVALGRIND */
+
+/* Modern GCC will optimize the static routine out if unused,
+ and unused attribute will shut down warnings about it. */
+static int VALGRIND_PRINTF(const char *format, ...)
+ __attribute__((format(__printf__, 1, 2), __unused__));
+static int
+VALGRIND_PRINTF(const char *format, ...)
+{
+ unsigned long _qzz_res;
+ va_list vargs;
+ va_start(vargs, format);
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, VG_USERREQ__PRINTF,
+ (unsigned long)format, (unsigned long)vargs,
+ 0, 0, 0);
+ va_end(vargs);
+ return (int)_qzz_res;
+}
+
+static int VALGRIND_PRINTF_BACKTRACE(const char *format, ...)
+ __attribute__((format(__printf__, 1, 2), __unused__));
+static int
+VALGRIND_PRINTF_BACKTRACE(const char *format, ...)
+{
+ unsigned long _qzz_res;
+ va_list vargs;
+ va_start(vargs, format);
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, VG_USERREQ__PRINTF_BACKTRACE,
+ (unsigned long)format, (unsigned long)vargs,
+ 0, 0, 0);
+ va_end(vargs);
+ return (int)_qzz_res;
+}
+
+#endif /* NVALGRIND */
+
+
+/* These requests allow control to move from the simulated CPU to the
+ real CPU, calling an arbitary function.
+
+ Note that the current ThreadId is inserted as the first argument.
+ So this call:
+
+ VALGRIND_NON_SIMD_CALL2(f, arg1, arg2)
+
+ requires f to have this signature:
+
+ Word f(Word tid, Word arg1, Word arg2)
+
+ where "Word" is a word-sized type.
+
+ Note that these client requests are not entirely reliable. For example,
+ if you call a function with them that subsequently calls printf(),
+ there's a high chance Valgrind will crash. Generally, your prospects of
+ these working are made higher if the called function does not refer to
+ any global variables, and does not refer to any libc or other functions
+ (printf et al). Any kind of entanglement with libc or dynamic linking is
+ likely to have a bad outcome, for tricky reasons which we've grappled
+ with a lot in the past.
+*/
+#define VALGRIND_NON_SIMD_CALL0(_qyy_fn) \
+ __extension__ \
+ ({unsigned long _qyy_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qyy_res, 0 /* default return */, \
+ VG_USERREQ__CLIENT_CALL0, \
+ _qyy_fn, \
+ 0, 0, 0, 0); \
+ _qyy_res; \
+ })
+
+#define VALGRIND_NON_SIMD_CALL1(_qyy_fn, _qyy_arg1) \
+ __extension__ \
+ ({unsigned long _qyy_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qyy_res, 0 /* default return */, \
+ VG_USERREQ__CLIENT_CALL1, \
+ _qyy_fn, \
+ _qyy_arg1, 0, 0, 0); \
+ _qyy_res; \
+ })
+
+#define VALGRIND_NON_SIMD_CALL2(_qyy_fn, _qyy_arg1, _qyy_arg2) \
+ __extension__ \
+ ({unsigned long _qyy_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qyy_res, 0 /* default return */, \
+ VG_USERREQ__CLIENT_CALL2, \
+ _qyy_fn, \
+ _qyy_arg1, _qyy_arg2, 0, 0); \
+ _qyy_res; \
+ })
+
+#define VALGRIND_NON_SIMD_CALL3(_qyy_fn, _qyy_arg1, _qyy_arg2, _qyy_arg3) \
+ __extension__ \
+ ({unsigned long _qyy_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qyy_res, 0 /* default return */, \
+ VG_USERREQ__CLIENT_CALL3, \
+ _qyy_fn, \
+ _qyy_arg1, _qyy_arg2, \
+ _qyy_arg3, 0); \
+ _qyy_res; \
+ })
+
+
+/* Counts the number of errors that have been recorded by a tool. Nb:
+ the tool must record the errors with VG_(maybe_record_error)() or
+ VG_(unique_error)() for them to be counted. */
+#define VALGRIND_COUNT_ERRORS \
+ __extension__ \
+ ({unsigned int _qyy_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qyy_res, 0 /* default return */, \
+ VG_USERREQ__COUNT_ERRORS, \
+ 0, 0, 0, 0, 0); \
+ _qyy_res; \
+ })
+
+/* Mark a block of memory as having been allocated by a malloc()-like
+ function. `addr' is the start of the usable block (ie. after any
+ redzone) `rzB' is redzone size if the allocator can apply redzones;
+ use '0' if not. Adding redzones makes it more likely Valgrind will spot
+ block overruns. `is_zeroed' indicates if the memory is zeroed, as it is
+ for calloc(). Put it immediately after the point where a block is
+ allocated.
+
+ If you're using Memcheck: If you're allocating memory via superblocks,
+ and then handing out small chunks of each superblock, if you don't have
+ redzones on your small blocks, it's worth marking the superblock with
+ VALGRIND_MAKE_MEM_NOACCESS when it's created, so that block overruns are
+ detected. But if you can put redzones on, it's probably better to not do
+ this, so that messages for small overruns are described in terms of the
+ small block rather than the superblock (but if you have a big overrun
+ that skips over a redzone, you could miss an error this way). See
+ memcheck/tests/custom_alloc.c for an example.
+
+ WARNING: if your allocator uses malloc() or 'new' to allocate
+ superblocks, rather than mmap() or brk(), this will not work properly --
+ you'll likely get assertion failures during leak detection. This is
+ because Valgrind doesn't like seeing overlapping heap blocks. Sorry.
+
+ Nb: block must be freed via a free()-like function specified
+ with VALGRIND_FREELIKE_BLOCK or mismatch errors will occur. */
+#define VALGRIND_MALLOCLIKE_BLOCK(addr, sizeB, rzB, is_zeroed) \
+ {unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__MALLOCLIKE_BLOCK, \
+ addr, sizeB, rzB, is_zeroed, 0); \
+ }
+
+/* Mark a block of memory as having been freed by a free()-like function.
+ `rzB' is redzone size; it must match that given to
+ VALGRIND_MALLOCLIKE_BLOCK. Memory not freed will be detected by the leak
+ checker. Put it immediately after the point where the block is freed. */
+#define VALGRIND_FREELIKE_BLOCK(addr, rzB) \
+ {unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__FREELIKE_BLOCK, \
+ addr, rzB, 0, 0, 0); \
+ }
+
+/* Create a memory pool. */
+#define VALGRIND_CREATE_MEMPOOL(pool, rzB, is_zeroed) \
+ {unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__CREATE_MEMPOOL, \
+ pool, rzB, is_zeroed, 0, 0); \
+ }
+
+/* Destroy a memory pool. */
+#define VALGRIND_DESTROY_MEMPOOL(pool) \
+ {unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__DESTROY_MEMPOOL, \
+ pool, 0, 0, 0, 0); \
+ }
+
+/* Associate a piece of memory with a memory pool. */
+#define VALGRIND_MEMPOOL_ALLOC(pool, addr, size) \
+ {unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__MEMPOOL_ALLOC, \
+ pool, addr, size, 0, 0); \
+ }
+
+/* Disassociate a piece of memory from a memory pool. */
+#define VALGRIND_MEMPOOL_FREE(pool, addr) \
+ {unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__MEMPOOL_FREE, \
+ pool, addr, 0, 0, 0); \
+ }
+
+/* Disassociate any pieces outside a particular range. */
+#define VALGRIND_MEMPOOL_TRIM(pool, addr, size) \
+ {unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__MEMPOOL_TRIM, \
+ pool, addr, size, 0, 0); \
+ }
+
+/* Resize and/or move a piece associated with a memory pool. */
+#define VALGRIND_MOVE_MEMPOOL(poolA, poolB) \
+ {unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__MOVE_MEMPOOL, \
+ poolA, poolB, 0, 0, 0); \
+ }
+
+/* Resize and/or move a piece associated with a memory pool. */
+#define VALGRIND_MEMPOOL_CHANGE(pool, addrA, addrB, size) \
+ {unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__MEMPOOL_CHANGE, \
+ pool, addrA, addrB, size, 0); \
+ }
+
+/* Return 1 if a mempool exists, else 0. */
+#define VALGRIND_MEMPOOL_EXISTS(pool) \
+ __extension__ \
+ ({unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__MEMPOOL_EXISTS, \
+ pool, 0, 0, 0, 0); \
+ _qzz_res; \
+ })
+
+/* Mark a piece of memory as being a stack. Returns a stack id. */
+#define VALGRIND_STACK_REGISTER(start, end) \
+ __extension__ \
+ ({unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__STACK_REGISTER, \
+ start, end, 0, 0, 0); \
+ _qzz_res; \
+ })
+
+/* Unmark the piece of memory associated with a stack id as being a
+ stack. */
+#define VALGRIND_STACK_DEREGISTER(id) \
+ {unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__STACK_DEREGISTER, \
+ id, 0, 0, 0, 0); \
+ }
+
+/* Change the start and end address of the stack id. */
+#define VALGRIND_STACK_CHANGE(id, start, end) \
+ {unsigned int _qzz_res; \
+ VALGRIND_DO_CLIENT_REQUEST(_qzz_res, 0, \
+ VG_USERREQ__STACK_CHANGE, \
+ id, start, end, 0, 0); \
+ }
+
+
+#undef PLAT_x86_linux
+#undef PLAT_amd64_linux
+#undef PLAT_ppc32_linux
+#undef PLAT_ppc64_linux
+#undef PLAT_ppc32_aix5
+#undef PLAT_ppc64_aix5
+
+#endif /* __VALGRIND_H */
--- /dev/null
+// -*- rust -*-
+
+fn ack(int m, int n) -> int {
+ if (m == 0) {
+ ret n+1;
+ } else {
+ if (n == 0) {
+ ret ack(m-1, 1);
+ } else {
+ ret ack(m-1, ack(m, n-1));
+ }
+ }
+}
+
+fn main() {
+ check (ack(0,0) == 1);
+ check (ack(3,2) == 29);
+ check (ack(3,4) == 125);
+
+ // This takes a while; but a comparison may amuse: on win32 at least, the
+ // posted C version of the 'benchmark' running ack(4,1) overruns its stack
+ // segment and crashes. We just grow our stack (to 4mb) as we go.
+
+ // check (ack(4,1) == 65533);
+}
\ No newline at end of file
--- /dev/null
+type tree = tag(nil(), node(@tree, @tree, int));
+
+fn item_check(&tree t) -> int {
+ alt (t) {
+ case (nil()) {
+ ret 0;
+ }
+ case (node(@tree left, @tree right, int item)) {
+ ret item + item_check(left) - item_check(right);
+ }
+ }
+}
+
+fn main() {
+}
\ No newline at end of file
--- /dev/null
+// -*- rust -*-
+
+fn fib(int n) -> int {
+ // Several of the posted 'benchmark' versions of this compute the
+ // wrong Fibonacci numbers, of course.
+ if (n == 0) {
+ ret 0;
+ } else {
+ if (n <= 2) {
+ ret 1;
+ } else {
+ ret fib(n-1) + fib(n-2);
+ }
+ }
+}
+
+fn main() {
+ check (fib(8) == 21);
+ check (fib(15) == 610);
+ log fib(8);
+ log fib(15);
+}
--- /dev/null
+// error-pattern: mismatched types
+
+fn f(int x) {
+}
+
+fn main() {
+ let () i;
+ i = f();
+}
--- /dev/null
+
+// error-pattern: mismatched types
+
+fn f(int x) {
+}
+
+fn main() {
+ let () i;
+ i = f(());
+}
\ No newline at end of file
--- /dev/null
+// error-pattern: attempted dynamic environment-capture
+fn foo() {
+ let int x;
+ fn bar() {
+ log x;
+ }
+}
+fn main() {
+ foo();
+}
\ No newline at end of file
--- /dev/null
+// error-pattern: bad type signature
+
+fn main(int x) {
+}
--- /dev/null
+
+// error-pattern: malformed name
+
+fn main() {
+ let x.y[int].z foo;
+}
--- /dev/null
+// error-pattern: attempted dynamic environment-capture
+fn foo[T]() { obj bar(T b) {} }
+fn main() {}
\ No newline at end of file
--- /dev/null
+// -*- rust -*-
+
+type color = tag(
+ rgb(int, int, int),
+ rgba(int, int, int, int)
+);
+
+fn main() -> () {
+ let color red = rgb(255, 0, 0);
+ alt (red) {
+ case (rgb(int r, int g, int b)) {
+ log "rgb";
+ }
+ case (hsl(int h, int s, int l)) {
+ log "hsl";
+ }
+ }
+}
+
--- /dev/null
+// error-pattern: calculated effect is 'io'
+
+fn main() {
+ let chan[int] c = chan();
+ c <| 10;
+}
\ No newline at end of file
--- /dev/null
+// -*- rust -*-
+
+fn f(str caller) {
+ log caller;
+}
+
+fn main() {
+ be f("main");
+ log "Paul is dead";
+}
+
--- /dev/null
+// -*- rust -*-
+
+fn f(str caller) {
+ log caller;
+}
+
+fn main() {
+ ret f("main");
+ log "Paul is dead";
+}
+
--- /dev/null
+
+// error-pattern: mismatched types
+
+obj x() {
+ fn hello() {
+ log "hello";
+ }
+}
+
+fn main() {
+ x.hello();
+}
\ No newline at end of file
--- /dev/null
+// error-pattern: unknown module item
+mod foo {
+ export x;
+ fn x(int y) {
+ log y;
+ }
+ fn z(int y) {
+ log y;
+ }
+}
+
+fn main() {
+ foo.z(10);
+}
--- /dev/null
+// -*- rust -*-
+
+type point = rec(int x, int y);
+
+fn main() {
+ let point origin = rec(x=0, y=0);
+
+ let point origin3d = rec(z=0 with origin);
+}
--- /dev/null
+// -*- rust -*-
+
+type point = rec(int x, int y);
+
+fn main() {
+ let point origin;
+
+ let point right = rec(x=10 with origin);
+ origin = rec(x=0, y=0);
+}
--- /dev/null
+// -*- rust -*-
+
+// error-pattern: impure function used in constraint
+
+fn f(int a, int b) : lt(a,b) {
+}
+
+io fn lt(int a, int b) -> bool {
+ let port[int] p = port();
+ let chan[int] c = chan(p);
+ c <| 10;
+}
+
+fn main() {
+ let int a = 10;
+ let int b = 23;
+ check lt(a,b);
+ f(a,b);
+}
--- /dev/null
+// -*- rust -*-
+
+// error-pattern: Infinite type recursion
+
+type mlist = tag(cons(int,mlist), nil());
+
+fn main() {
+ auto a = cons(10, cons(11, nil()));
+}
--- /dev/null
+// -*- rust -*-
+
+// error-pattern: Infinite type recursion
+
+type x = vec[x];
+
+fn main() {
+ let x b = vec();
+}
--- /dev/null
+// error-pattern: calculated effect is 'io'
+
+io fn foo() {
+ let chan[int] c = chan();
+ c <| 10;
+}
+
+fn main() {
+ foo();
+}
\ No newline at end of file
--- /dev/null
+// error-pattern: mismatched types
+
+fn main() {
+ log main;
+}
+
--- /dev/null
+// error-pattern: calculated effect is 'unsafe'
+
+native mod foo {
+ fn naughty();
+}
+
+fn main() {
+ foo.naughty();
+}
\ No newline at end of file
--- /dev/null
+// -*- rust -*-
+
+// error-pattern: mismatched types
+
+fn f(int a, int b) : lt(a,b) {
+}
+
+obj lt(int a, int b) {
+}
+
+fn main() {
+ let int a = 10;
+ let int b = 23;
+ check lt(a,b);
+ f(a,b);
+}
--- /dev/null
+// error-pattern: mismatched types
+
+fn f() {
+}
+
+fn main() {
+ let int i;
+ i = f();
+}
--- /dev/null
+// -*- rust -*-
+
+// error-pattern: Unsatisfied .* lt(a, c)
+
+fn f(int a, int b) : lt(a,b) {
+}
+
+fn lt(int a, int b) -> bool {
+ ret a < b;
+}
+
+fn main() {
+ let int a = 10;
+ let int b = 23;
+ let int c = 77;
+ check lt(a,b);
+ check lt(b,c);
+ f(a,b);
+ f(a,c);
+}
--- /dev/null
+// -*- rust -*-
+
+// Issue #51.
+
+type point = rec(int x, int y);
+
+fn main() {
+ let point p = rec(x=10);
+ log p.y;
+}
--- /dev/null
+// error-pattern: precondition constraint
+
+fn f() -> int {
+ let int x;
+ ret x;
+}
+
+fn main() {
+ f();
+}
\ No newline at end of file
--- /dev/null
+// -*- rust -*-
+
+// error-pattern: mismatched types
+
+fn f(int a, int b) : lt(a,b) {
+}
+
+fn main() {
+ let int lt;
+ let int a = 10;
+ let int b = 23;
+ check lt(a,b);
+ f(a,b);
+}
--- /dev/null
+// error-pattern: mismatched types
+
+fn f(int x) -> int {
+ ret x;
+}
+
+fn main() {
+ spawn f(10);
+}
--- /dev/null
+// -*- rust -*-
+
+// error-pattern: mismatched types
+
+fn main() {
+ type X = int;
+ type Y = X;
+ if (true) {
+ type X = str;
+ let Y y = "hello";
+ }
+}
--- /dev/null
+// error-pattern: calculated effect is ''
+io fn main() {
+ log "hi";
+}
\ No newline at end of file
--- /dev/null
+// error-pattern: calculated effect is ''
+unsafe fn main() {
+ log "hi";
+}
\ No newline at end of file
--- /dev/null
+// error-pattern: calculated effect is 'unsafe'
+
+native mod foo {
+ fn naughty();
+}
+
+unsafe fn bar() {
+ foo.naughty();
+}
+
+fn main() {
+ bar();
+}
\ No newline at end of file
--- /dev/null
+// error-pattern: precondition constraint
+
+fn f() -> int {
+ let int x;
+ while(true) {
+ x = 10;
+ }
+ ret x;
+}
+
+fn main() {
+ f();
+}
--- /dev/null
+// error-pattern: precondition constraint
+
+fn main() {
+ let bool x;
+ while(x) {
+ }
+}
--- /dev/null
+// error-pattern: mismatched types
+
+fn main() {
+ while (main) {
+ }
+}
+
--- /dev/null
+// -*- rust -*-
+
+// error-pattern: writing to non-mutable slot
+
+type point = rec(int x, int y, int z);
+
+fn f(&point p) {
+ p.x = 13;
+}
+
+fn main() {
+ let point x = rec(x=10, y=11, z=12);
+ f(x);
+}
--- /dev/null
+// error-pattern:explicit
+
+fn main() {
+ fail;
+}
--- /dev/null
+// error-pattern:1 == 2
+
+fn main() {
+ check (1 == 2);
+}
--- /dev/null
+// -*- rust -*-
+
+// error-pattern:1 == 2
+
+fn child() {
+ check (1 == 2);
+}
+
+io fn main() {
+ let port[int] p = port();
+ spawn child();
+ let int x;
+ x <- p;
+}
--- /dev/null
+// -*- rust -*-
+
+// error-pattern:predicate check
+
+fn f(int a, int b) : lt(a,b) {
+}
+
+fn lt(int a, int b) -> bool {
+ ret a < b;
+}
+
+fn main() {
+ let int a = 10;
+ let int b = 23;
+ check lt(b,a);
+ f(b,a);
+}
--- /dev/null
+// -*- rust -*-
+
+// error-pattern:bounds check
+
+fn main() {
+ let str s = "hello";
+ let int x = 0;
+ check (s.(x) == u8(0x68));
+
+ // NB: at the moment a string always has a trailing NULL,
+ // so the largest index value on the string above is 5, not
+ // 4. Possibly change this.
+
+ // Bounds-check failure.
+ check (s.(x + 6) == u8(0x0));
+}
--- /dev/null
+// -*- rust -*-
+
+// error-pattern:bounds check
+
+fn main() {
+ let vec[int] v = vec(10);
+ let int x = 0;
+ check (v.(x) == 10);
+ // Bounds-check failure.
+ check (v.(x + 2) == 20);
+}
--- /dev/null
+// -*- rust -*-
+
+// error-pattern:bounds check
+
+fn main() {
+ let vec[int] v = vec(10, 20);
+ let int x = 0;
+ check (v.(x) == 10);
+ // Bounds-check failure.
+ check (v.(x-1) == 20);
+}
--- /dev/null
+// -*- rust -*-
+
+io fn f(chan[int] c)
+{
+ type t = tup(int,int,int);
+
+ // Allocate an exterior.
+ let @t x = tup(1,2,3);
+
+ // Signal parent that we've allocated an exterior.
+ c <| 1;
+
+ while (true) {
+ // spin waiting for the parent to kill us.
+ log "child waiting to die...";
+ c <| 1;
+ }
+}
+
+
+io fn main() {
+ let port[int] p = port();
+ spawn f(chan(p));
+ let int i;
+
+ // synchronize on event from child.
+ i <- p;
+
+ log "parent exiting, killing child";
+}
--- /dev/null
+// -*- rust -*-
+
+type color = tag(
+ rgb(int, int, int),
+ rgba(int, int, int, int),
+ hsl(int, int, int)
+);
+
+fn process(color c) -> int {
+ let int x;
+ alt (c) {
+ case (rgb(r, _, _)) {
+ log "rgb";
+ log r;
+ x = r;
+ }
+ case (rgba(_, _, _, a)) {
+ log "rgba";
+ log a;
+ x = a;
+ }
+ case (hsl(_, s, _)) {
+ log "hsl";
+ log s;
+ x = s;
+ }
+ }
+ ret x;
+}
+
+fn main() {
+ let color gray = rgb(127, 127, 127);
+ let color clear = rgba(50, 150, 250, 0);
+ let color red = hsl(0, 255, 255);
+ check (process(gray) == 127);
+ check (process(clear) == 0);
+ check (process(red) == 255);
+}
+
--- /dev/null
+fn main(vec[str] args) {
+ let vec[str] vs = vec("hi", "there", "this", "is", "a", "vec");
+ let vec[vec[str]] vvs = vec(args, vs);
+ for (vec[str] vs in vvs) {
+ for (str s in vs) {
+ log s;
+ }
+ }
+}
--- /dev/null
+// -*- rust -*-
+
+io fn a(chan[int] c) {
+ if (true) {
+ log "task a";
+ log "task a";
+ log "task a";
+ log "task a";
+ log "task a";
+ }
+ c <| 10;
+}
+
+fn k(int x) -> int {
+ ret 15;
+}
+
+fn g(int x, str y) -> int {
+ log x;
+ log y;
+ let int z = k(1);
+ ret z;
+}
+
+io fn main() {
+ let int n = 2 + 3 * 7;
+ let str s = "hello there";
+ let port[int] p = port();
+ spawn a(chan(p));
+ spawn b(chan(p));
+ let int x = 10;
+ x = g(n,s);
+ log x;
+ n <- p;
+ n <- p;
+ // FIXME: use signal-channel for this.
+ log "children finished, root finishing";
+}
+
+io fn b(chan[int] c) {
+ if (true) {
+ log "task b";
+ log "task b";
+ log "task b";
+ log "task b";
+ log "task b";
+ log "task b";
+ }
+ c <| 10;
+}
--- /dev/null
+fn main() {
+ // Testcase for issue #59.
+ obj simple(int x, int y) {
+ fn sum() -> int {
+ ret x + y;
+ }
+ }
+
+ auto obj0 = simple(1,2);
+ auto ctor0 = bind simple(1, _);
+ auto ctor1 = bind simple(_, 2);
+ auto obj1 = ctor0(2);
+ auto obj2 = ctor1(1);
+ check (obj0.sum() == 3);
+ check (obj1.sum() == 3);
+ check (obj2.sum() == 3);
+}
--- /dev/null
+// -*- rust -*-
+
+fn f() -> int {
+ ret 42;
+}
+
+fn main() {
+ let fn() -> int g = bind f();
+ let int i = g();
+ check(i == 42);
+}
--- /dev/null
+// -*- rust -*-
+
+fn f(int n) -> int {
+ ret n;
+}
+
+fn main() {
+ let fn(int) -> int g = bind f(_);
+ let int i = g(42);
+ check(i == 42);
+}
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let int a = 1;
+ let int b = 2;
+ a ^= b;
+ b ^= a;
+ a = a ^ b;
+ log a;
+ log b;
+ check (b == 1);
+ check (a == 2);
+
+ check (~(0xf0) & 0xff == 0xf);
+ check (0xf0 | 0xf == 0xff);
+ check (0xf << 4 == 0xf0);
+ check (0xf0 >> 4 == 0xf);
+ check (-16 >>> 2 == -4);
+ check (0b1010_1010 | 0b0101_0101 == 0xff);
+}
+
--- /dev/null
+type box[T] = tup(@T);
+
+fn unbox[T](box[T] b) -> T { ret b._0; }
+
+fn main() {
+ let int foo = 17;
+ let box[int] bfoo = tup(foo);
+ log "see what's in our box";
+ check (unbox[int](bfoo) == foo);
+}
--- /dev/null
+// -*- rust -*-
+
+
+fn main() {
+ let int i = int('Q');
+ check (i == 0x51);
+ let u32 u = u32(i);
+ check (u == u32(0x51));
+ check (u == u32('Q'));
+ check (i8(i) == i8('Q'));
+ check (i8(u8(i)) == i8(u8('Q')));
+ check (char(0x51) == 'Q');
+
+ check (true == bool(1));
+ check (u32(0) == u32(false));
+}
--- /dev/null
+fn main() {
+ let char c = 'x';
+ let char d = 'x';
+ check(c == 'x');
+ check('x' == c);
+ check(c == c);
+ check(c == d);
+ check(d == c);
+ check (d == 'x');
+ check('x' == d);
+}
+
--- /dev/null
+fn f(@rec(int a, int b) x) {
+ check (x.a == 10);
+ check (x.b == 12);
+}
+
+fn main() {
+ let @rec(int a, int b) z = rec(a=10, b=12);
+ let task p = spawn thread f(z);
+ join p;
+}
\ No newline at end of file
--- /dev/null
+// -*- rust -*-
+
+io fn main() {
+ let port[int] p = port();
+ spawn child(chan(p));
+ let int y;
+ y <- p;
+ log "received";
+ log y;
+ check (y == 10);
+}
+
+io fn child(chan[int] c) {
+ c <| 10;
+}
+
--- /dev/null
+fn main(vec[str] args) {
+ log args.(0);
+}
--- /dev/null
+// -*- rust -*-
+
+type t = int;
+fn putstr(str s) {}
+fn putint(int i) {
+ let int i = 33;
+ while (i < 36) {
+ putstr("hi"); i = i + 1;
+ }
+}
+fn zerg(int i) -> int { ret i; }
+fn foo(int x) -> int {
+ let t y = x + 2;
+ putstr("hello");
+ while (y < 10) {
+ putint(y);
+ if (y * 3 == 4) {
+ y = y + 2;
+ }
+ }
+ let t z;
+ z = 0x55;
+ foo(z);
+}
+
+fn main() {
+ let int x = 2 + 2;
+ log x;
+ log "hello, world";
+ log 10;
+}
+
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ if (1 == 1) {
+ ret;
+ }
+ log "Paul is dead";
+}
--- /dev/null
+// -*- rust -*-
+
+fn f(int x) -> int {
+ if (x == 1) {
+ ret 1;
+ } else {
+ let int y = 1 + f(x-1);
+ ret y;
+ }
+}
+
+fn main() {
+ check (f(5000) == 5000);
+}
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let int x = 15;
+ let int y = 5;
+ check(x / 5 == 3);
+ check(x / 4 == 3);
+ check(x / 3 == 5);
+ check(x / y == 3);
+ check(15 / y == 3);
+
+ check(x % 5 == 0);
+ check(x % 4 == 3);
+ check(x % 3 == 0);
+ check(x % y == 0);
+ check(15 % y == 0);
+}
--- /dev/null
+// -*- rust -*-
+
+fn f() -> int {
+ if (true) {
+ let str s = "should not leak";
+ ret 1;
+ }
+ ret 0;
+}
+fn main() {
+ f();
+}
--- /dev/null
+fn main() {
+ if (1 == 2) {
+ check(false);
+ } else if (2 == 3) {
+ check(false);
+ } else if (3 == 4) {
+ check(false);
+ } else {
+ check(true);
+ }
+
+
+ if (1 == 2) {
+ check(false);
+ } else if (2 == 2) {
+ check(true);
+ }
+
+}
\ No newline at end of file
--- /dev/null
+export foo;
+
+type list_cell[T] = tag(cons(@list_cell[T]));
+
+fn main() {
+}
--- /dev/null
+// -*- rust -*-
+
+type point = rec(int x, int y, mutable int z);
+
+fn f(@point p) {
+ check (p.z == 12);
+ p.z = 13;
+ check (p.z == 13);
+}
+
+fn main() {
+ let point a = rec(x=10, y=11, z=mutable 12);
+ let @point b = a;
+ check (b.z == 12);
+ f(b);
+ check (a.z == 12);
+ check (b.z == 13);
+}
--- /dev/null
+// -*- rust -*-
+
+fn f(int x) -> int {
+ // log "in f:";
+ log x;
+ if (x == 1) {
+ // log "bottoming out";
+ ret 1;
+ } else {
+ // log "recurring";
+ let int y = x * f(x-1);
+ // log "returned";
+ log y;
+ ret y;
+ }
+}
+fn main () {
+ check (f(5) == 120);
+ // log "all done";
+}
+
--- /dev/null
+iter pairs() -> tup(int,int) {
+ let int i = 0;
+ let int j = 0;
+ while (i < 10) {
+ put tup(i, j);
+ i += 1;
+ j += i;
+ }
+}
+
+fn main() {
+ let int i = 10;
+ let int j = 0;
+ for each (tup(int,int) p in pairs()) {
+ log p._0;
+ log p._1;
+ check (p._0 + 10 == i);
+ i += 1;
+ j = p._1;
+ }
+ check(j == 45);
+}
\ No newline at end of file
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let int sum = 0;
+ for each (int i in first_ten()) {
+ log "main";
+ log i;
+ sum = sum + i;
+ }
+ log "sum";
+ log sum;
+ check (sum == 45);
+}
+
+iter first_ten() -> int {
+ let int i = 0;
+ while (i < 10) {
+ log "first_ten";
+ put i;
+ i = i + 1;
+ }
+}
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ for each (int i in first_ten()) {
+ log "main";
+ }
+}
+
+iter first_ten() -> int {
+ let int i = 90;
+ while (i < 100) {
+ log "first_ten";
+ log i;
+ put i;
+ i = i + 1;
+ }
+}
--- /dev/null
+// -*- rust -*-
+
+fn ho(fn(int) -> int f) -> int {
+ let int n = f(3);
+ ret n;
+}
+
+fn direct(int x) -> int {
+ ret x + 1;
+}
+
+fn main() {
+ let int a = direct(3); // direct
+ //let int b = ho(direct); // indirect unbound
+ let int c = ho(bind direct(_)); // indirect bound
+ //check(a == b);
+ //check(b == c);
+}
+
--- /dev/null
+// -*- rust -*-
+
+fn f() -> int {
+ ret 42;
+}
+
+fn main() {
+ let fn() -> int g = f;
+ let int i = g();
+ check(i == 42);
+}
--- /dev/null
+fn g[X](X x) -> X {
+ ret x;
+}
+
+fn f[T](T t) -> tup(T,T) {
+ type pair = tup(T,T);
+ let pair x = tup(t,t);
+ ret g[pair](x);
+}
+
+fn main() {
+ auto b = f[int](10);
+ log b._0;
+ log b._1;
+ check (b._0 == 10);
+ check (b._1 == 10);
+}
--- /dev/null
+fn f[T](T t) {
+ log "dropping";
+}
+
+fn main() {
+ type r = rec(@int x, @int y);
+ auto x = rec(x=@10, y=@12);
+ f[r](x);
+}
\ No newline at end of file
--- /dev/null
+type tupbox[T] = tup(@T);
+type recbox[T] = rec(@T x);
+
+fn tuplift[T](T t) -> tupbox[T] { ret tup(@t); }
+fn reclift[T](T t) -> recbox[T] { ret rec(x=@t); }
+
+fn main() {
+ let int foo = 17;
+ let tupbox[int] tbfoo = tuplift[int](foo);
+ let recbox[int] rbfoo = reclift[int](foo);
+ check (tbfoo._0 == foo);
+ check (rbfoo.x == foo);
+}
--- /dev/null
+// -*- rust -*-
+
+// Issue #45: infer type parameters in function applications
+
+fn id[T](T x) -> T {
+ ret x;
+}
+
+fn main() {
+ let int x = 42;
+ let int y = id(x);
+ check (x == y);
+}
--- /dev/null
+// -*- rust -*-
+
+fn id[T](T x) -> T {
+ ret x;
+}
+
+type triple = tup(int,int,int);
+
+fn main() {
+ auto x = 62;
+ auto y = 63;
+ auto a = 'a';
+ auto b = 'b';
+
+ let triple p = tup(65, 66, 67);
+ let triple q = tup(68, 69, 70);
+
+ y = id[int](x);
+ log y;
+ check (x == y);
+
+ b = id[char](a);
+ log b;
+ check (a == b);
+
+ q = id[triple](p);
+ x = p._2;
+ y = q._2;
+ log y;
+ check (x == y);
+
+}
--- /dev/null
+obj handle[T](T data) {
+ fn get() -> T {
+ ret data;
+ }
+}
+
+fn main() {
+ type rgb = tup(u8,u8,u8);
+ let handle[rgb] h = handle[rgb](tup(u8(1), u8(2), u8(3)));
+ log "constructed object";
+ log h.get()._0;
+ log h.get()._1;
+ log h.get()._2;
+ check (h.get()._0 == u8(1));
+ check (h.get()._1 == u8(2));
+ check (h.get()._2 == u8(3));
+}
--- /dev/null
+obj buf[T](tup(T,T,T) data) {
+ fn get(int i) -> T {
+ if (i == 0) {
+ ret data._0;
+ } else {
+ if (i == 1) {
+ ret data._1;
+ } else {
+ ret data._2;
+ }
+ }
+ }
+}
+
+fn main() {
+ let buf[int] b = buf[int](tup(1,2,3));
+ log "constructed object";
+ log b.get(0);
+ log b.get(1);
+ log b.get(2);
+ check (b.get(0) == 1);
+ check (b.get(1) == 2);
+ check (b.get(2) == 3);
+}
--- /dev/null
+type list[T] = tag(cons(@T, @list[T]), nil());
+
+fn main() {
+ let list[int] a = cons[int](10, cons[int](12, cons[int](13, nil[int]())));
+}
\ No newline at end of file
--- /dev/null
+type foo[T] = tag(arm(T));
+
+fn altfoo[T](foo[T] f) {
+ alt (f) {
+ case (arm(x)) {}
+ }
+}
+
+fn main() {}
--- /dev/null
+type option[T] = tag(some(@T), none());
+
+fn main() {
+ let option[int] a = some[int](10);
+ a = none[int]();
+}
\ No newline at end of file
--- /dev/null
+type foo[T] = tup(T);
+type bar[T] = foo[T];
+fn takebar[T](bar[T] b) {}
+fn main() {}
\ No newline at end of file
--- /dev/null
+type pair[T] = tup(T,T);
+fn main() {
+ let pair[int] x = tup(10,12);
+ check (x._0 == 10);
+ check (x._1 == 12);
+}
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ log "hello, world.";
+}
+
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let i32 x = i32(-400);
+ x = i32(0) - x;
+ check(x == i32(400));
+}
+
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let i8 x = i8(-12);
+ let i8 y = i8(-12);
+ x = x + i8(1);
+ x = x - i8(1);
+ check(x == y);
+}
--- /dev/null
+mod foo {
+ fn x(int y) {
+ log y;
+ }
+}
+
+mod bar {
+ import foo.x;
+ import z = foo.x;
+ fn main() {
+ x(10);
+ z(10);
+ }
+}
--- /dev/null
+// -*- rust -*-
+
+mod inner {
+ mod inner2 {
+ fn hello() {
+ log "hello, modular world";
+ }
+ }
+ fn hello() {
+ inner2.hello();
+ }
+}
+
+fn main() {
+ inner.hello();
+ inner.inner2.hello();
+}
--- /dev/null
+// -*- rust -*-
+
+
+fn main() {
+ let int x = 10;
+}
--- /dev/null
+// -*- rust -*-
+
+fn f() {
+ let rec(int a, int b, int c, int d,
+ int e, int f, int g, int h,
+ int i, int j, int k, int l) foo =
+ rec(a=0, b=0, c=0, d=0,
+ e=0, f=0, g=0, h=0,
+ i=0, j=0, k=0, l=0);
+}
+
+fn main() {
+ f();
+}
--- /dev/null
+fn incr(mutable &int x) -> bool {
+ x += 1;
+ check (false);
+ ret false;
+}
+
+fn main() {
+
+ auto x = (1 == 2) || (3 == 3);
+ check (x);
+
+ let int y = 10;
+ log x || incr(y);
+ check (y == 10);
+
+ if (true && x) {
+ check (true);
+ } else {
+ check (false);
+ }
+
+}
\ No newline at end of file
--- /dev/null
+// -*- rust -*-
+
+io fn main() {
+ let port[int] p = port();
+ auto c = chan(p);
+ let int y;
+
+ spawn child(c);
+ y <- p;
+ log "received 1";
+ log y;
+ check (y == 10);
+
+ spawn child(c);
+ y <- p;
+ log "received 2";
+ log y;
+ check (y == 10);
+}
+
+io fn child(chan[int] c) {
+ c <| 10;
+}
--- /dev/null
+fn main() {
+ auto x = vec(1,2,3);
+ auto y = 0;
+ for (int i in x) {
+ log i;
+ y += i;
+ }
+ log y;
+ check (y == 6);
+
+ auto s = "hello there";
+ let int i = 0;
+ for (u8 c in s) {
+ if (i == 0) {
+ check (c == u8('h'));
+ }
+ if (i == 1) {
+ check (c == u8('e'));
+ }
+ if (i == 2) {
+ check (c == u8('l'));
+ }
+ if (i == 3) {
+ check (c == u8('l'));
+ }
+ if (i == 4) {
+ check (c == u8('o'));
+ }
+ // ...
+ if (i == 12) {
+ check (c == u8(0));
+ }
+ i += 1;
+ log i;
+ log c;
+ }
+ check(i == 12);
+}
--- /dev/null
+// -*- rust -*-
+
+type list = tag(cons(int,@list), nil());
+
+fn main() {
+ cons(10, cons(11, cons(12, nil())));
+}
--- /dev/null
+// -*- rust -*-
+
+io fn sub(chan[int] parent, int id) {
+ if (id == 0) {
+ parent <| 0;
+ } else {
+ let port[int] p = port();
+ auto child = spawn sub(chan(p), id-1);
+ let int y <- p;
+ parent <| y + 1;
+ }
+}
+
+io fn main() {
+ let port[int] p = port();
+ auto child = spawn sub(chan(p), 500);
+ let int y <- p;
+ check (y == 500);
+}
--- /dev/null
+// -*- rust -*-
+
+type pair = rec(int head, mutable @mlist tail);
+type mlist = tag(cons(@pair), nil());
+
+fn main() {
+ let @pair p = rec(head=10, tail=mutable nil());
+ let @mlist cycle = cons(p);
+ //p.tail = cycle;
+}
--- /dev/null
+// -*- rust -*-
+
+type mlist = tag(cons(int,mutable @mlist), nil());
+
+fn main() {
+ cons(10, cons(11, cons(12, nil())));
+}
--- /dev/null
+fn main() {
+ // This just tests whether the vec leaks its members.
+ let vec[mutable @tup(int,int)] pvec = vec(tup(1,2),tup(3,4),tup(5,6));
+}
--- /dev/null
+// -*- rust -*-
+
+type colour = tag(red(), green(), blue());
+type tree = tag(children(@list), leaf(colour));
+type list = tag(cons(@tree, @list), nil());
+
+type small_list = tag(kons(int,@small_list), neel());
+
+fn main() {
+}
+
--- /dev/null
+// -*- rust -*-
+
+unsafe fn main() {
+ auto f = "Makefile";
+ auto s = rustrt.str_buf(f);
+ auto buf = libc.malloc(1024);
+ auto fd = libc.open(s, 0, 0);
+ libc.read(fd, buf, 1024);
+ libc.write(1, buf, 1024);
+ libc.close(fd);
+ libc.free(buf);
+}
--- /dev/null
+// -*- rust -*-
+
+native mod libc = target_libc {
+ fn open(int name, int flags, int mode) -> int;
+ fn close(int fd) -> int;
+ fn read(int fd, int buf, int count) -> int;
+ fn write(int fd, int buf, int count) -> int;
+ fn malloc(int sz) -> int;
+ fn free(int p) -> ();
+}
+
+native "rust" mod rustrt {
+ fn str_buf(str s) -> int;
+}
+
+mod inner = "native-mod-src/inner.rs";
--- /dev/null
+native mod libc {
+ type file_handle;
+}
+
+fn main() {
+ check (true);
+}
--- /dev/null
+// -*- rust -*-
+
+unsafe fn main() {
+ libc.puts(rustrt.str_buf("hello, native world 1"));
+ libc.puts(rustrt.str_buf("hello, native world 2"));
+ libc.puts(rustrt.str_buf("hello, native world 3"));
+}
--- /dev/null
+// -*- rust -*-
+
+native "rust" mod rustrt {
+ fn str_buf(str s) -> int;
+}
+
+
+native mod libc = target_libc {
+ fn puts(int s) -> ();
+}
+
+mod user = "native-src/native.rs";
--- /dev/null
+
+obj big() {
+ fn one() -> int { ret 1; }
+ fn two() -> int { ret 2; }
+ fn three() -> int { ret 3; }
+}
+
+type small = obj {
+ fn one() -> int;
+ };
+
+fn main() {
+
+ let big b = big();
+ check (b.one() == 1);
+ check (b.two() == 2);
+ check (b.three() == 3);
+
+ let small s = b as small;
+ check (s.one() == 1);
+}
\ No newline at end of file
--- /dev/null
+fn main() {
+ obj handle(@int i) {
+ }
+ // This just tests whether the obj leaks its exterior state members.
+ auto ob = handle(0xf00f00);
+}
\ No newline at end of file
--- /dev/null
+obj worker(chan[int] c) {
+ drop {
+ log "in dtor";
+ c <| 10;
+ }
+}
+
+io fn do_work(chan[int] c) {
+ log "in child task";
+ {
+ let worker w = worker(c);
+ log "constructed worker";
+ }
+ log "destructed worker";
+ while(true) {
+ // Deadlock-condition not handled properly yet, need to avoid
+ // exiting the child early.
+ c <| 11;
+ yield;
+ }
+}
+
+io fn main() {
+ let port[int] p = port();
+ log "spawning worker";
+ auto w = spawn do_work(chan(p));
+ let int i;
+ log "parent waiting for shutdown";
+ i <- p;
+ log "received int";
+ check (i == 10);
+ log "int is OK, child-dtor ran as expected";
+}
\ No newline at end of file
--- /dev/null
+fn main() {
+
+ obj buf(vec[u8] data) {
+ fn get(int i) -> u8 {
+ ret data.(i);
+ }
+ }
+ auto b = buf(vec(u8(1), u8(2), u8(3)));
+ log b.get(1);
+ check (b.get(1) == u8(2));
+}
\ No newline at end of file
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let int x = 1;
+
+ x *= 2;
+ log x;
+ check (x == 2);
+
+ x += 3;
+ log x;
+ check (x == 5);
+
+ x *= x;
+ log x;
+ check (x == 25);
+
+ x /= 5;
+ log x;
+ check (x == 5);
+}
+
--- /dev/null
+// -*- rust -*-
+
+fn f(int a, int b) : lt(a,b) {
+}
+
+fn lt(int a, int b) -> bool {
+ ret a < b;
+}
+
+fn main() {
+ let int a = 10;
+ let int b = 23;
+ let int c = 77;
+ check lt(a,b);
+ check lt(a,c);
+ f(a,b);
+ f(a,c);
+}
--- /dev/null
+// This checks that preemption works.
+
+io fn starve_main(chan[int] alive) {
+ log "signalling main";
+ alive <| 1;
+ log "starving main";
+ let int i = 0;
+ while (true) {
+ i += 1;
+ }
+}
+
+io fn main() {
+ let port[int] alive = port();
+ log "main started";
+ let task s = spawn starve_main(chan(alive));
+ let int i;
+ log "main waiting for alive signal";
+ i <- alive;
+ log "main got alive signal";
+ while (i < 1000) {
+ log "main iterated";
+ i += 1;
+ }
+ log "main completed";
+}
\ No newline at end of file
--- /dev/null
+// -*- rust -*-
+
+type point = rec(int x, int y, int z);
+
+fn f(&point p) {
+ check (p.z == 12);
+}
+
+fn main() {
+ let point x = rec(x=10, y=11, z=12);
+ f(x);
+}
--- /dev/null
+// -*- rust -*-
+
+// Issue #50.
+
+fn main() {
+ auto x = rec(foo = "hello", bar = "world");
+ log x.foo;
+ log x.bar;
+}
--- /dev/null
+// -*- rust -*-
+
+type point = rec(int x, int y);
+
+fn main() {
+ let point origin = rec(x=0, y=0);
+
+ let point right = rec(x=origin.x + 10 with origin);
+ let point up = rec(y=origin.y + 10 with origin);
+
+ check(origin.x == 0);
+ check(origin.y == 0);
+
+ check(right.x == 10);
+ check(right.y == 0);
+
+ check(up.x == 0);
+ check(up.y == 10);
+}
--- /dev/null
+// -*- rust -*-
+
+type point = rec(int x, int y);
+type rect = tup(point, point);
+
+fn f(rect r, int x1, int y1, int x2, int y2) {
+ check (r._0.x == x1);
+ check (r._0.y == y1);
+ check (r._1.x == x2);
+ check (r._1.y == y2);
+}
+
+fn main() {
+ let rect r = tup( rec(x=10, y=20),
+ rec(x=11, y=22) );
+ check (r._0.x == 10);
+ check (r._0.y == 20);
+ check (r._1.x == 11);
+ check (r._1.y == 22);
+ let rect r2 = r;
+ let int x = r2._0.x;
+ check (x == 10);
+ f(r, 10, 20, 11, 22);
+ f(r2, 10, 20, 11, 22);
+}
--- /dev/null
+// -*- rust -*-
+
+type rect = rec(int x, int y, int w, int h);
+
+fn f(rect r, int x, int y, int w, int h) {
+ check (r.x == x);
+ check (r.y == y);
+ check (r.w == w);
+ check (r.h == h);
+}
+
+fn main() {
+ let rect r = rec(x=10, y=20, w=100, h=200);
+ check (r.x == 10);
+ check (r.y == 20);
+ check (r.w == 100);
+ check (r.h == 200);
+ let rect r2 = r;
+ let int x = r2.x;
+ check (x == 10);
+ f(r, 10, 20, 100, 200);
+ f(r2, 10, 20, 100, 200);
+}
--- /dev/null
+fn f() {
+ let () x = ();
+ ret x;
+}
+
+fn main() {
+ auto x = f();
+}
\ No newline at end of file
--- /dev/null
+// -*- rust -*-
+
+obj x() {
+ fn hello() {
+ log "hello, object world";
+ }
+}
+
+fn main() {
+ auto mx = x();
+ mx.hello();
+}
--- /dev/null
+// -*- rust -*-
+
+fn x(str s, int n) {
+ log s;
+ log n;
+}
+
+fn main() {
+ spawn x("hello from first spawned fn", 65);
+ spawn x("hello from second spawned fn", 66);
+ spawn x("hello from third spawned fn", 67);
+ let int i = 30;
+ while (i > 0) {
+ i = i - 1;
+ log "parent sleeping";
+ yield;
+ }
+}
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ spawn child(10);
+}
+
+fn child(int i) {
+ log i;
+}
+
--- /dev/null
+// -*- rust -*-
+
+obj counter(mutable int x) {
+ fn hello() -> int {
+ ret 12345;
+ }
+ fn incr() {
+ x = x + 1;
+ }
+ fn get() -> int {
+ ret x;
+ }
+}
+
+fn main() {
+ auto y = counter(0);
+ check (y.hello() == 12345);
+ log y.get();
+ y.incr();
+ y.incr();
+ log y.get();
+ check (y.get() == 2);
+}
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let str s = "hello";
+ s += "world";
+ log s;
+ check(s.(9) == u8('d'));
+}
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let str a = "hello";
+ let str b = "world";
+ let str s = a + b;
+ log s;
+ check(s.(9) == u8('d'));
+}
--- /dev/null
+
+fn main() {
+ auto s = "hello";
+ let u8 c = s.(4);
+ log c;
+ check (c == u8(0x6f));
+}
--- /dev/null
+fn main() {
+ auto s = #shell { uname -a && hg identify };
+ log s;
+}
--- /dev/null
+// -*- rust -*-
+
+type colour = tag(red(int,int), green());
+
+fn f() {
+ auto x = red(1,2);
+ auto y = green();
+ // FIXME: needs structural equality test working.
+ // check (x != y);
+}
+
+fn main() {
+ f();
+}
--- /dev/null
+// -*- rust -*-
+
+fn checktrue(bool res) -> bool {
+ check(res);
+ ret true;
+}
+
+fn main() {
+ auto k = checktrue;
+ evenk(42, k);
+ oddk(45, k);
+}
+
+fn evenk(int n, fn(bool) -> bool k) -> bool {
+ log "evenk";
+ log n;
+ if (n == 0) {
+ be k(true);
+ }
+ else {
+ be oddk(n - 1, k);
+ }
+}
+
+fn oddk(int n, fn(bool) -> bool k) -> bool {
+ log "oddk";
+ log n;
+ if (n == 0) {
+ be k(false);
+ }
+ else {
+ be evenk(n - 1, k);
+ }
+}
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ check(even(42));
+ check(odd(45));
+}
+
+fn even(int n) -> bool {
+ if (n == 0) {
+ ret true;
+ }
+ else {
+ be odd(n - 1);
+ }
+}
+
+fn odd(int n) -> bool {
+ if (n == 0) {
+ ret false;
+ }
+ else {
+ be even(n - 1);
+ }
+}
--- /dev/null
+
+
+io fn main() -> () {
+ test00(true);
+ // test01();
+ // test02();
+ // test03();
+ // test04();
+}
+
+io fn test00_start(chan[int] ch, int message, int count) {
+ log "Starting test00_start";
+ let int i = 0;
+ while (i < count) {
+ ch <| message;
+ i = i + 1;
+ }
+ log "Ending test00_start";
+}
+
+io fn test00(bool is_multithreaded) {
+ let int number_of_tasks = 4;
+ let int number_of_messages = 64;
+ log "Creating tasks";
+
+ let port[int] po = port();
+ let chan[int] ch = chan(po);
+
+ let int i = 0;
+
+ let vec[task] tasks = vec();
+ while (i < number_of_tasks) {
+ i = i + 1;
+ if (is_multithreaded) {
+ tasks += vec(
+ spawn thread test00_start(ch, i, number_of_messages));
+ } else {
+ tasks += vec(spawn test00_start(ch, i, number_of_messages));
+ }
+ }
+
+ let int sum = 0;
+ for (task t in tasks) {
+ i = 0;
+ while (i < number_of_messages) {
+ let int value <- po;
+ sum += value;
+ i = i + 1;
+ }
+ }
+
+ for (task t in tasks) {
+ join t;
+ }
+
+ log "Completed: Final number is: ";
+ check (sum == number_of_messages *
+ (number_of_tasks * number_of_tasks + number_of_tasks) / 2);
+}
+
+io fn test01() {
+ let port[int] p = port();
+ log "Reading from a port that is never written to.";
+ let int value <- p;
+ log value;
+}
+
+io fn test02() {
+ let port[int] p = port();
+ let chan[int] c = chan(p);
+ log "Writing to a local task channel.";
+ c <| 42;
+ log "Reading from a local task port.";
+ let int value <- p;
+ log value;
+}
+
+obj vector(mutable int x, int y) {
+ fn length() -> int {
+ x = x + 2;
+ ret x + y;
+ }
+}
+
+fn test03() {
+ log "Creating object ...";
+ let mutable vector v = vector(1, 2);
+ log "created object ...";
+ let mutable vector t = v;
+ log v.length();
+}
+
+fn test04_start() {
+ log "Started Task";
+ let int i = 1024 * 1024 * 64;
+ while (i > 0) {
+ i = i - 1;
+ }
+ log "Finished Task";
+}
+
+fn test04() {
+ log "Spawning lots of tasks.";
+ let int i = 64;
+ while (i > 0) {
+ i = i - 1;
+ spawn thread test04_start();
+ }
+ log "Finishing up.";
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let port[int] p = port();
+ let int i = 10;
+ while (i > 0) {
+ spawn thread child(i);
+ i = i - 1;
+ }
+ log "main thread exiting";
+}
+
+fn child(int x) {
+ log x;
+}
+
--- /dev/null
+// -*- rust -*-
+
+type point = tup(int, int);
+
+fn f(point p, int x, int y) {
+ check (p._0 == x);
+ check (p._1 == y);
+}
+
+fn main() {
+ let point p = tup(10, 20);
+ check (p._0 == 10);
+ check (p._1 == 20);
+ let point p2 = p;
+ let int x = p2._0;
+ check (x == 10);
+ f(p, 10, 20);
+ f(p2, 10, 20);
+}
--- /dev/null
+
+import size_of = std.sys.rustrt.size_of;
+
+use std;
+
+fn main() {
+ check (size_of[u8]() == uint(1));
+ check (size_of[u32]() == uint(4));
+ check (size_of[char]() == uint(4));
+ check (size_of[i8]() == uint(1));
+ check (size_of[i32]() == uint(4));
+ check (size_of[tup(u8,i8)]() == uint(2));
+ check (size_of[tup(u8,i8,u8)]() == uint(3));
+ // Alignment causes padding before the char and the u32.
+ check (size_of[tup(u8,i8,tup(char,u8),u32)]() == uint(16));
+ check (size_of[int]() == size_of[uint]());
+ check (size_of[tup(int,())]() == size_of[int]());
+ check (size_of[tup(int,(),())]() == size_of[int]());
+ check (size_of[int]() == size_of[rec(int x)]());
+}
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let u32 word = u32(200000);
+ word = word - u32(1);
+ check(word == u32(199999));
+}
+
--- /dev/null
+// -*- rust -*-
+
+// These constants were chosen because they aren't used anywhere
+// in the rest of the generated code so they're easily grep-able.
+
+fn main() {
+ let u8 x = u8(19); // 0x13
+ let u8 y = u8(35); // 0x23
+ x = x + u8(7); // 0x7
+ y = y - u8(9); // 0x9
+ check(x == y);
+}
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let u8 x = u8(12);
+ let u8 y = u8(12);
+ x = x + u8(1);
+ x = x - u8(1);
+ check(x == y);
+ //x = u8(14);
+ //x = x + u8(1);
+}
+
--- /dev/null
+// -*- rust -*-
+
+
+fn main() {
+ let uint x = uint(10);
+}
--- /dev/null
+// -*- rust -*-
+
+fn f(() u) -> () {
+ ret u;
+}
+
+fn main() -> () {
+ let () u1 = ();
+ let () u2 = f(u1);
+ u2 = ();
+ ret ();
+}
+
--- /dev/null
+// -*- rust -*-
+
+use std (name = "std",
+ url = "http://rust-lang.org/src/std",
+ uuid = _, ver = _);
+
+fn main() {
+ auto s = std._str.alloc(10);
+ s += "hello ";
+ log s;
+ s += "there";
+ log s;
+ auto z = std._vec.alloc[int](10);
+}
--- /dev/null
+fn main() {
+ let char yen = '¥'; // 0xa5
+ let char c_cedilla = 'ç'; // 0xe7
+ let char thorn = 'þ'; // 0xfe
+ let char y_diaeresis = 'ÿ'; // 0xff
+ let char pi = 'Π'; // 0x3a0
+
+ check (int(yen) == 0xa5);
+ check (int(c_cedilla) == 0xe7);
+ check (int(thorn) == 0xfe);
+ check (int(y_diaeresis) == 0xff);
+ check (int(pi) == 0x3a0);
+
+ check (int(pi) == int('\u03a0'));
+ check (int('\x0a') == int('\n'));
+
+ let str bhutan = "འབྲུག་ཡུལ།";
+ let str japan = "日本";
+ let str uzbekistan = "Ўзбекистон";
+ let str austria = "Österreich";
+
+ let str bhutan_e =
+ "\u0f60\u0f56\u0fb2\u0f74\u0f42\u0f0b\u0f61\u0f74\u0f63\u0f0d";
+ let str japan_e = "\u65e5\u672c";
+ let str uzbekistan_e =
+ "\u040e\u0437\u0431\u0435\u043a\u0438\u0441\u0442\u043e\u043d";
+ let str austria_e = "\u00d6sterreich";
+
+ let char oo = 'Ö';
+ check (int(oo) == 0xd6);
+
+ fn check_str_eq(str a, str b) {
+ let int i = 0;
+ for (u8 ab in a) {
+ log i;
+ log ab;
+ let u8 bb = b.(i);
+ log bb;
+ check(ab == bb);
+ i += 1;
+ }
+ }
+
+ check_str_eq(bhutan, bhutan_e);
+ check_str_eq(japan, japan_e);
+ check_str_eq(uzbekistan, uzbekistan_e);
+ check_str_eq(austria, austria_e);
+}
\ No newline at end of file
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let vec[int] v = vec(1,2,3,4,5);
+ v += vec(6,7,8,9,0);
+ log v.(9);
+ check(v.(0) == 1);
+ check(v.(7) == 8);
+ check(v.(9) == 0);
+}
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let vec[int] a = vec(1,2,3,4,5);
+ let vec[int] b = vec(6,7,8,9,0);
+ let vec[int] v = a + b;
+ log v.(9);
+ check(v.(0) == 1);
+ check(v.(7) == 8);
+ check(v.(9) == 0);
+}
--- /dev/null
+fn main() {
+ // This just tests whether the vec leaks its members.
+ let vec[@tup(int,int)] pvec = vec(tup(1,2),tup(3,4),tup(5,6));
+}
--- /dev/null
+fn main() {
+ let vec[int] v = vec(1,2,3,4,5);
+ auto v2 = v.(1,2);
+ check (v2.(0) == 2);
+ check (v2.(1) == 3);
+}
\ No newline at end of file
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let vec[int] v = vec(10, 20);
+ check (v.(0) == 10);
+ check (v.(1) == 20);
+ let int x = 0;
+ check (v.(x) == 10);
+ check (v.(x + 1) == 20);
+ x = x + 1;
+ check (v.(x) == 20);
+ check (v.(x-1) == 10);
+}
--- /dev/null
+// -*- rust -*-
+
+type point = rec(int x, int y, mutable int z);
+
+fn f(mutable &point p) {
+ p.z = 13;
+}
+
+fn main() {
+ let point x = rec(x=10, y=11, z=mutable 12);
+ f(x);
+ check (x.z == 13);
+}
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ auto other = spawn child();
+ log "1";
+ yield;
+ log "2";
+ yield;
+ log "3";
+ join other;
+}
+
+fn child() {
+ log "4";
+ yield;
+ log "5";
+ yield;
+ log "6";
+}
+
--- /dev/null
+// -*- rust -*-
+
+fn main() {
+ let int i = 0;
+ while (i < 100) {
+ i = i + 1;
+ log i;
+ yield;
+ }
+}
projects / rust.git / commitdiff