#include <sys/types.h>
#include <assert.h>
#include <alignof.h>
+#include <byteswap.h>
#include <full-read.h>
The length of the header must be a multiple of 8 bytes. */
verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
+/* Endianness and word size of the compilation target. */
+static SCM target_endianness_var = SCM_BOOL_F;
+static SCM target_word_size_var = SCM_BOOL_F;
+
\f
/*
* Objcode type
*/
+/* Endianness of the build machine. */
+#ifdef WORDS_BIGENDIAN
+# define NATIVE_ENDIANNESS 'B'
+#else
+# define NATIVE_ENDIANNESS 'L'
+#endif
+
+/* Return the endianness of the compilation target. */
+static char
+target_endianness (void)
+{
+ if (scm_is_true (target_endianness_var))
+ return scm_is_eq (scm_call_0 (scm_variable_ref (target_endianness_var)),
+ scm_endianness_big) ? 'B' : 'L';
+ else
+ return NATIVE_ENDIANNESS;
+}
+
+/* Return the word size in bytes of the compilation target. */
+static size_t
+target_word_size (void)
+{
+ if (scm_is_true (target_word_size_var))
+ return scm_to_size_t (scm_call_0
+ (scm_variable_ref (target_word_size_var)));
+ else
+ return sizeof (void *);
+}
+
+/* Convert X, which is in byte order ENDIANNESS, to its native
+ representation. */
+static inline uint32_t
+to_native_order (uint32_t x, char endianness)
+{
+ if (endianness == NATIVE_ENDIANNESS)
+ return x;
+ else
+ return bswap_32 (x);
+}
+
static void
verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
#define FUNC_NAME "make_objcode_from_file"
verify_cookie (cookie, &st, -1, NULL);
- return scm_bytecode_to_objcode (bv);
+ return scm_bytecode_to_native_objcode (bv);
}
#endif
}
}
#undef FUNC_NAME
-SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
- (SCM bytecode),
- "")
-#define FUNC_NAME s_scm_bytecode_to_objcode
+/* Turn BYTECODE into objcode encoded for ENDIANNESS and WORD_SIZE. */
+static SCM
+bytecode_to_objcode (SCM bytecode, char endianness, size_t word_size)
+#define FUNC_NAME "bytecode->objcode"
{
- size_t size;
+ size_t size, len, metalen;
const scm_t_uint8 *c_bytecode;
struct scm_objcode *data;
size = SCM_BYTEVECTOR_LENGTH (bytecode);
c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);
-
+
SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
data = (struct scm_objcode*)c_bytecode;
- if (data->len + data->metalen != (size - sizeof (*data)))
+ len = to_native_order (data->len, endianness);
+ metalen = to_native_order (data->metalen, endianness);
+
+ if (len + metalen != (size - sizeof (*data)))
scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)",
scm_list_2 (scm_from_size_t (size),
- scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
+ scm_from_uint32 (sizeof (*data) + len + metalen)));
/* foolishly, we assume that as long as bytecode is around, that c_bytecode
will be of the same length; perhaps a bad assumption? */
}
#undef FUNC_NAME
+SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
+ (SCM bytecode),
+ "")
+#define FUNC_NAME s_scm_bytecode_to_objcode
+{
+ /* Assume we're called from Scheme, which known that to do with
+ `target-type'. */
+ return bytecode_to_objcode (bytecode, target_endianness (),
+ target_word_size ());
+}
+#undef FUNC_NAME
+
+/* Like `bytecode->objcode', but ignore the `target-type' fluid. This
+ is useful for native compilation that happens lazily---e.g., direct
+ calls to this function from libguile itself. */
+SCM
+scm_bytecode_to_native_objcode (SCM bytecode)
+{
+ return bytecode_to_objcode (bytecode, NATIVE_ENDIANNESS, sizeof (void *));
+}
+
SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
(SCM file),
"")
"")
#define FUNC_NAME s_scm_write_objcode
{
- static SCM target_endianness_var = SCM_BOOL_F;
- static SCM target_word_size_var = SCM_BOOL_F;
-
char cookie[sizeof (SCM_OBJCODE_COOKIE) - 1];
- char endianness;
- char word_size;
+ char endianness, word_size;
+ size_t total_size;
SCM_VALIDATE_OBJCODE (1, objcode);
SCM_VALIDATE_OUTPUT_PORT (2, port);
-
- if (scm_is_false (target_endianness_var))
- target_endianness_var =
- scm_c_public_variable ("system base target", "target-endianness");
- if (scm_is_false (target_word_size_var))
- target_word_size_var =
- scm_c_public_variable ("system base target", "target-word-size");
-
- endianness =
- scm_is_eq (scm_call_0 (scm_variable_ref (target_endianness_var)),
- scm_endianness_big) ? 'B' : 'L';
- switch (scm_to_int (scm_call_0 (scm_variable_ref (target_word_size_var))))
+ endianness = target_endianness ();
+ switch (target_word_size ())
{
- case 4: word_size = '4'; break;
- case 8: word_size = '8'; break;
- default: abort ();
+ case 4:
+ word_size = '4';
+ break;
+ case 8:
+ word_size = '8';
+ break;
+ default:
+ abort ();
}
memcpy (cookie, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE));
cookie[SCM_OBJCODE_ENDIANNESS_OFFSET] = endianness;
cookie[SCM_OBJCODE_WORD_SIZE_OFFSET] = word_size;
+ total_size =
+ to_native_order (SCM_OBJCODE_LEN (objcode), target_endianness ())
+ + to_native_order (SCM_OBJCODE_META_LEN (objcode), target_endianness ());
+
scm_c_write (port, cookie, strlen (SCM_OBJCODE_COOKIE));
scm_c_write (port, SCM_OBJCODE_DATA (objcode),
- sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));
+ sizeof (struct scm_objcode) + total_size);
return SCM_UNSPECIFIED;
}
scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
+
+ target_endianness_var = scm_c_public_variable ("system base target",
+ "target-endianness");
+ target_word_size_var = scm_c_public_variable ("system base target",
+ "target-word-size");
}
/*
SCM_API SCM scm_objcode_p (SCM obj);
SCM_API SCM scm_objcode_meta (SCM objcode);
SCM_API SCM scm_bytecode_to_objcode (SCM bytecode);
+SCM_INTERNAL SCM scm_bytecode_to_native_objcode (SCM bytecode);
SCM_API SCM scm_objcode_to_bytecode (SCM objcode);
SCM_API SCM scm_write_objcode (SCM objcode, SCM port);
u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
sizeof (struct scm_objcode) + sizeof (text));
- ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
+ ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
SCM_BOOL_F, SCM_BOOL_F);
SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
(define-module (system base target)
#:use-module (rnrs bytevectors)
+ #:use-module (ice-9 regex)
#:export (target-type with-target
target-cpu target-vendor target-os
;;;
(define %target-type (make-fluid))
+(define %target-endianness (make-fluid))
+(define %target-word-size (make-fluid))
-(define (target-type)
- (or (fluid-ref %target-type)
- %host-type))
+(define %native-word-size
+ ;; The native word size. Note: don't use `word-size' from
+ ;; (system vm objcode) to avoid a circular dependency.
+ ((@ (system foreign) sizeof) '*))
(define (validate-target target)
(if (or (not (string? target))
(define (with-target target thunk)
(validate-target target)
- (with-fluids ((%target-type target))
- (thunk)))
+ (let ((cpu (triplet-cpu target)))
+ (with-fluids ((%target-type target)
+ (%target-endianness (cpu-endianness cpu))
+ (%target-word-size (cpu-word-size cpu)))
+ (thunk))))
+
+(define (cpu-endianness cpu)
+ "Return the endianness for CPU."
+ (if (string=? cpu (triplet-cpu %host-type))
+ (native-endianness)
+ (cond ((string-match "^i[0-9]86$" cpu)
+ (endianness little))
+ ((member cpu '("x86_64" "ia64"
+ "powerpcle" "powerpc64le" "mipsel" "mips64el"))
+ (endianness little))
+ ((member cpu '("sparc" "sparc64" "powerpc" "powerpc64" "spu"
+ "mips" "mips64"))
+ (endianness big))
+ ((string-match "^arm.*el" cpu)
+ (endianness little))
+ (else
+ (error "unknown CPU endianness" cpu)))))
+
+(define (cpu-word-size cpu)
+ "Return the word size for CPU."
+ (if (string=? cpu (triplet-cpu %host-type))
+ %native-word-size
+ (cond ((string-match "^i[0-9]86$" cpu) 4)
+ ((string-match "64$" cpu) 8)
+ ((string-match "64[lbe][lbe]$" cpu) 8)
+ ((member cpu '("sparc" "powerpc" "mips")) 4)
+ ((string-match "^arm.*" cpu) 4)
+ (else "unknown CPU word size" cpu))))
+
+(define (triplet-cpu t)
+ (substring t 0 (string-index t #\-)))
+
+(define (triplet-vendor t)
+ (let ((start (1+ (string-index t #\-))))
+ (substring t start (string-index t #\- start))))
+
+(define (triplet-os t)
+ (let ((start (1+ (string-index t #\- (1+ (string-index t #\-))))))
+ (substring t start)))
+
+\f
+(define (target-type)
+ "Return the GNU configuration triplet of the target platform."
+ (or (fluid-ref %target-type)
+ %host-type))
(define (target-cpu)
- (let ((t (target-type)))
- (substring t 0 (string-index t #\-))))
+ "Return the CPU name of the target platform."
+ (triplet-cpu (target-type)))
(define (target-vendor)
- (let* ((t (target-type))
- (start (1+ (string-index t #\-))))
- (substring t start (string-index t #\- start))))
+ "Return the vendor name of the target platform."
+ (triplet-vendor (target-type)))
(define (target-os)
- (let* ((t (target-type))
- (start (1+ (string-index t #\- (1+ (string-index t #\-))))))
- (substring t start)))
+ "Return the operating system name of the target platform."
+ (triplet-os (target-type)))
(define (target-endianness)
- (if (equal? (target-type) %host-type)
- (native-endianness)
- (error "cross-compilation not yet handled" %host-type (target-type))))
+ "Return the endianness object of the target platform."
+ (or (fluid-ref %target-endianness) (native-endianness)))
(define (target-word-size)
- (if (equal? (target-type) %host-type)
- ((@ (system foreign) sizeof) '*)
- (error "cross-compilation not yet handled" %host-type (target-type))))
+ "Return the word size, in bytes, of the target platform."
+ (or (fluid-ref %target-word-size) %native-word-size))
#:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
#:use-module (test-suite lib)
#:use-module (system vm instruction)
+ #:use-module (system vm objcode)
#:use-module (system base target)
#:use-module (language assembly)
#:use-module (language assembly compile-bytecode))
(string=? (target-vendor) vendor)
(string=? (target-os) os)))))))
+(define %objcode-cookie-size
+ (string-length "GOOF----LE-8-2.0"))
+
+(define (test-target triplet endian word-size)
+ (pass-if (format #f "target `~a' honored" triplet)
+ (call-with-values (lambda ()
+ (open-bytevector-output-port))
+ (lambda (p get-objcode)
+ (with-target triplet
+ (lambda ()
+ (let ((b (compile-bytecode
+ '(load-program () 16 #f
+ (assert-nargs-ee/locals 1)
+ (make-int8 77)
+ (toplevel-ref 1)
+ (local-ref 0)
+ (mul)
+ (add)
+ (return)
+ (nop) (nop) (nop)
+ (nop) (nop))
+ #f)))
+ (write-objcode (bytecode->objcode b) p)
+ (let ((cookie (make-bytevector %objcode-cookie-size))
+ (expected (format #f "GOOF----~a-~a-~a"
+ (cond ((eq? endian (endianness little))
+ "LE")
+ ((eq? endian (endianness big))
+ "BE")
+ (else
+ (error "unknown endianness"
+ endian)))
+ word-size
+ (effective-version))))
+ (bytevector-copy! (get-objcode) 0 cookie 0
+ %objcode-cookie-size)
+ (string=? (utf8->string cookie) expected)))))))))
+
(with-test-prefix "cross-compilation"
(test-triplet "i586" "pc" "gnu0.3")
(test-triplet "x86_64" "unknown" "linux-gnu")
- (test-triplet "x86_64" "unknown" "kfreebsd-gnu"))
+ (test-triplet "x86_64" "unknown" "kfreebsd-gnu")
+
+ (test-target "i586-pc-gnu0.3" (endianness little) 4)
+ (test-target "x86_64-pc-linux-gnu" (endianness little) 8)
+ (test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
+ (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
+
+ (pass-if-exception "unknown target"
+ exception:miscellaneous-error
+ (call-with-values (lambda ()
+ (open-bytevector-output-port))
+ (lambda (p get-objcode)
+ (let* ((b (compile-bytecode '(load-program () 3 #f
+ (make-int8 77)
+ (return))
+ #f))
+ (o (bytecode->objcode b)))
+ (with-target "fcpu-unknown-gnu1.0"
+ (lambda ()
+ (write-objcode o p))))))))
;; Local Variables:
;; eval: (put 'with-target 'scheme-indent-function 1)
HCoop / bpt / guile.git / commitdiff