fix powerpc relocation bug
Slava Pestov
parent
863617b600
commit
29104bb40e
|
|
@ -27,6 +27,7 @@
|
|||
<li>Added expandable outliners. Used by the inspector, <code>.s</code>, <code>usage.</code>, <code>uses.</code>, <code>vocabs.</code>, and various other words.</li>
|
||||
<li>Added word completion to the listener pane; press <code>TAB</code>.</li>
|
||||
<li>Added word navigation shortcuts to the listener pane; press <code>C+LEFT</code> and <code>C+RIGHT</code> to move a word at a time, and <code>C+BACKSPACE</code> and <code>C+DELETE</code> to delete the previous and next word, respectively.</li>
|
||||
<lI>Added mouse-over help for presentations</lI>
|
||||
</ul>
|
||||
|
||||
</li>
|
||||
|
|
@ -103,7 +104,7 @@ However, most uses of <code>catch</code> can be replaced by <code>cleanup</code>
|
|||
|
||||
<li>Intel 8080 CPU and Space Invaders emulator in <code>contrib/space-invaders</code> (Chris Double)</li>
|
||||
<li>AOL Instant Messenger chat client library in <code>contrib/aim</code> (Doug Coleman)</li>
|
||||
|
||||
<li>Cairo graphics library binding in <code>contrib/cairo</code> (Sampo Vuori)</li>
|
||||
</ul>
|
||||
|
||||
</li>
|
||||
|
|
|
|||
17
Makefile
17
Makefile
|
|
@ -7,16 +7,7 @@ else
|
|||
STRIP = strip
|
||||
endif
|
||||
|
||||
ifdef STATIC
|
||||
DEFAULT_LIBS = -lm -Wl,-static -Wl,-whole-archive \
|
||||
-Wl,-export-dynamic \
|
||||
-lSDL -lSDL_gfx -lSDL_ttf \
|
||||
-Wl,-no-whole-archive \
|
||||
-lfreetype -lz -L/usr/X11R6/lib -lX11 -lXext \
|
||||
-Wl,-Bdynamic
|
||||
else
|
||||
DEFAULT_LIBS = -lm
|
||||
endif
|
||||
DEFAULT_LIBS = -lm
|
||||
|
||||
UNIX_OBJS = native/unix/file.o \
|
||||
native/unix/signal.o \
|
||||
|
|
@ -64,6 +55,7 @@ default:
|
|||
@echo "linux"
|
||||
@echo "linux-ppc"
|
||||
@echo "macosx"
|
||||
@echo "macosx-sdl -- if you wish to use the Factor GUI on Mac OS X"
|
||||
@echo "windows"
|
||||
@echo ""
|
||||
@echo "Also, you might want to set the SITE_CFLAGS environment"
|
||||
|
|
@ -83,6 +75,11 @@ macosx:
|
|||
CFLAGS="$(DEFAULT_CFLAGS)" \
|
||||
LIBS="$(DEFAULT_LIBS)"
|
||||
|
||||
macosx-sdl:
|
||||
$(MAKE) f \
|
||||
CFLAGS="$(DEFAULT_CFLAGS) -DFACTOR_SDL" \
|
||||
LIBS="$(DEFAULT_LIBS) -lSDL -lSDLmain -framework Cocoa -framework OpenGL -lSDL_ttf -lSDL_gfx"
|
||||
|
||||
linux:
|
||||
$(MAKE) f \
|
||||
CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic" \
|
||||
|
|
|
|||
|
|
@ -1,66 +0,0 @@
|
|||
! Copyright (C) 2005 Doug Coleman.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
|
||||
! mersenne twister based on
|
||||
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
|
||||
! usage: 1000 [ drop genrand . ] each
|
||||
! initializes to seed 5489 automatically
|
||||
|
||||
IN: crypto
|
||||
USING: kernel math namespaces sequences arrays ;
|
||||
|
||||
: mt-n 624 ; inline
|
||||
: mt-m 397 ; inline
|
||||
: mt-a HEX: 9908b0df ; inline
|
||||
: mt-hi HEX: 80000000 ; inline
|
||||
: mt-lo HEX: 7fffffff ; inline
|
||||
|
||||
SYMBOL: mt
|
||||
SYMBOL: mti
|
||||
|
||||
: mt-nth ( n -- nth )
|
||||
mt get nth ; inline
|
||||
|
||||
: mt-formula ( mt mti -- mt[mti] )
|
||||
dup rot nth dup -30 shift bitxor 1812433253 * + HEX: ffffffff bitand ; inline
|
||||
|
||||
: mt-y ( i0 i1 -- y )
|
||||
mt-nth mt-lo bitand >r mt-nth mt-hi bitand r> bitor ; inline
|
||||
|
||||
: set-mt-ith ( yi0 yi1 mt-set mt-get -- )
|
||||
>r >r mt-y r> r> mt-nth rot dup odd? mt-a 0 ? swap -1 shift bitxor bitxor swap mt get set-nth ; inline
|
||||
|
||||
: mt-temper ( y -- yt )
|
||||
dup -11 shift bitxor
|
||||
dup 7 shift HEX: 9d2c5680 bitand bitxor
|
||||
dup 15 shift HEX: efc60000 bitand bitxor
|
||||
dup -18 shift bitxor ; inline
|
||||
|
||||
: generate-new-mt
|
||||
mt-n mt-m - [ dup 2dup >r 1+ r> dup mt-m + set-mt-ith ] repeat
|
||||
mt-m 1- [ dup 227 + dup 2dup >r 1+ r> dup mt-m mt-n - + set-mt-ith drop ] repeat
|
||||
mt-n 1- 0 mt-n 1- mt-m 1- set-mt-ith
|
||||
0 mti set ;
|
||||
|
||||
: init-random ( seed -- )
|
||||
mt-n zero-array swap
|
||||
HEX: ffffffff bitand 0 pick set-nth
|
||||
mt-n 1- [ 2dup mt-formula 1+ pick pick 1+ swap set-nth ] repeat
|
||||
mt set 0 mti set
|
||||
generate-new-mt ;
|
||||
|
||||
: genrand ( -- rand )
|
||||
mti get dup mt-n < [ drop generate-new-mt 0 ] unless
|
||||
mt get nth mt-temper mti inc ;
|
||||
|
||||
USE: compiler
|
||||
USE: test
|
||||
|
||||
: million-genrand 1000000 [ drop genrand drop ] each ;
|
||||
: test-genrand \ million-genrand compile [ million-genrand ] time ;
|
||||
|
||||
[ 4123659995 ] [ 5489 init-random 9999 [ drop genrand drop ] each genrand millis init-random ] unit-test
|
||||
|
||||
! test-genrand
|
||||
! 5987 ms run / 56 ms GC time
|
||||
|
||||
|
|
@ -35,14 +35,10 @@ cpu "ppc" = [
|
|||
"statically-linked" get [
|
||||
unix? [
|
||||
os "macosx" = [
|
||||
"sdl" "libSDL.dylib" "cdecl" add-library
|
||||
"sdl-gfx" "libSDL_gfx.dylib" "cdecl" add-library
|
||||
"sdl-ttf" "libSDL_ttf.dylib" "cdecl" add-library
|
||||
] [
|
||||
"sdl" "libSDL.so" "cdecl" add-library
|
||||
"sdl-gfx" "libSDL_gfx.so" "cdecl" add-library
|
||||
"sdl-ttf" "libSDL_ttf.so" "cdecl" add-library
|
||||
] if
|
||||
] unless
|
||||
] when
|
||||
|
||||
win32? [
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ M: %call-label generate-node ( vop -- )
|
|||
#! Near calling convention for inlined recursive combinators
|
||||
#! Note: length of instruction sequence is hard-coded.
|
||||
vop-label
|
||||
0 1 rel-address compiled-offset 20 + 18 LOAD32
|
||||
compiled-offset 20 + 18 LOAD32 0 1 rel-address
|
||||
1 1 -16 STWU
|
||||
18 1 20 STW
|
||||
B ;
|
||||
|
|
@ -75,7 +75,7 @@ M: %dispatch generate-node ( vop -- )
|
|||
3 3 1 SRAWI
|
||||
! The value 24 is a magic number. It is the length of the
|
||||
! instruction sequence that follows to be generated.
|
||||
0 1 rel-address compiled-offset 24 + 4 LOAD32
|
||||
compiled-offset 24 + 4 LOAD32 0 1 rel-address
|
||||
3 3 4 ADD
|
||||
3 3 0 LWZ
|
||||
3 MTLR
|
||||
|
|
|
|||
|
|
@ -26,11 +26,7 @@ SYMBOL: relocation-table
|
|||
over 1 = [ 2drop ] [ 2 rel-type, relocating 0 rel, ] if ;
|
||||
|
||||
: rel-word ( word rel/abs 16/16 -- )
|
||||
pick primitive? [
|
||||
rel-primitive
|
||||
] [
|
||||
rot drop rel-address
|
||||
] if ;
|
||||
pick primitive? [ rel-primitive ] [ rel-address drop ] if ;
|
||||
|
||||
: rel-userenv ( n 16/16 -- )
|
||||
0 swap 3 rel-type, relocating rel, ;
|
||||
|
|
|
|||
|
|
@ -74,10 +74,11 @@ SYMBOL: open-fonts
|
|||
: make-color ( r g b -- color )
|
||||
#! Make an SDL_Color struct. This will go away soon in favor
|
||||
#! of pass-by-value support in the FFI.
|
||||
255 24 shift
|
||||
swap 16 shift bitor
|
||||
swap 8 shift bitor
|
||||
swap bitor ;
|
||||
<sdl-color>
|
||||
[ set-sdl-color-b ] keep
|
||||
[ set-sdl-color-g ] keep
|
||||
[ set-sdl-color-r ] keep
|
||||
0 alien-unsigned-4 ;
|
||||
|
||||
: make-rect ( x y w h -- rect )
|
||||
<sdl-rect>
|
||||
|
|
@ -105,7 +106,7 @@ SYMBOL: open-fonts
|
|||
] if ;
|
||||
|
||||
: lock-surface ( -- )
|
||||
surface get SDL_LockSurface sdl-error ;
|
||||
surface get SDL_LockSurface drop ;
|
||||
|
||||
: unlock-surface ( -- )
|
||||
surface get SDL_UnlockSurface ;
|
||||
|
|
|
|||
|
|
@ -45,6 +45,7 @@ void print_string(F_STRING* str)
|
|||
void print_obj(CELL obj)
|
||||
{
|
||||
F_ARRAY *array;
|
||||
CELL class;
|
||||
|
||||
switch(type_of(obj))
|
||||
{
|
||||
|
|
@ -66,7 +67,11 @@ void print_obj(CELL obj)
|
|||
case TUPLE_TYPE:
|
||||
array = (F_ARRAY*)UNTAG(obj);
|
||||
fprintf(stderr,"<< ");
|
||||
print_word(untag_word(get(AREF(array,0))));
|
||||
class = get(AREF(array,0));
|
||||
if(type_of(class) == WORD_TYPE)
|
||||
print_word(untag_word(class));
|
||||
else
|
||||
fprintf(stderr," corrupt tuple: %lx ",class);
|
||||
fprintf(stderr," %lx >>",obj);
|
||||
break;
|
||||
default:
|
||||
|
|
@ -209,13 +214,13 @@ void factorbug(void)
|
|||
fprintf(stderr,"\n");
|
||||
}
|
||||
else if(strcmp(cmd,"s") == 0)
|
||||
dump_memory(ds_bot,(ds + CELLS));
|
||||
dump_memory(ds_bot,ds);
|
||||
else if(strcmp(cmd,"r") == 0)
|
||||
dump_memory(cs_bot,(cs + CELLS));
|
||||
dump_memory(cs_bot,cs);
|
||||
else if(strcmp(cmd,".s") == 0)
|
||||
print_objects(ds_bot,(ds + CELLS));
|
||||
print_objects(ds_bot,ds);
|
||||
else if(strcmp(cmd,".r") == 0)
|
||||
print_objects(cs_bot,(cs + CELLS));
|
||||
print_objects(cs_bot,cs);
|
||||
else if(strcmp(cmd,"i") == 0)
|
||||
{
|
||||
fprintf(stderr,"Call frame:\n");
|
||||
|
|
@ -229,7 +234,7 @@ void factorbug(void)
|
|||
{
|
||||
int i;
|
||||
for(i = 0; i < USER_ENV; i++)
|
||||
dump_cell(userenv[i]);
|
||||
dump_cell((CELL)&userenv[i]);
|
||||
}
|
||||
else if(strcmp(cmd,"g") == 0)
|
||||
dump_generations();
|
||||
|
|
|
|||
|
|
@ -42,11 +42,7 @@ void throw_error(CELL error, bool keep_stacks)
|
|||
thrown_executing = executing;
|
||||
|
||||
/* Return to run() method */
|
||||
#ifdef WIN32
|
||||
longjmp(toplevel,1);
|
||||
#else
|
||||
siglongjmp(toplevel,1);
|
||||
#endif
|
||||
LONGJMP(toplevel,1);
|
||||
}
|
||||
|
||||
void primitive_throw(void)
|
||||
|
|
|
|||
|
|
@ -5,8 +5,6 @@ void init_factor(char* image, CELL ds_size, CELL cs_size,
|
|||
CELL young_size, CELL aging_size,
|
||||
CELL code_size, CELL literal_size)
|
||||
{
|
||||
/* initialize random number generator */
|
||||
srand((unsigned)time(NULL));
|
||||
init_ffi();
|
||||
init_arena(gen_count,young_size,aging_size);
|
||||
init_compiler(code_size);
|
||||
|
|
@ -104,5 +102,7 @@ int main(int argc, char** argv)
|
|||
|
||||
platform_run();
|
||||
|
||||
critical_error("run() returned due to empty callstack",0);
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -3,15 +3,33 @@
|
|||
|
||||
#include "platform.h"
|
||||
|
||||
#if defined(WIN32)
|
||||
#define DLLEXPORT __declspec(dllexport)
|
||||
#else
|
||||
#define DLLEXPORT
|
||||
#endif
|
||||
#define FIXNUM_MAX (LONG_MAX >> TAG_BITS)
|
||||
#define FIXNUM_MIN (LONG_MIN >> TAG_BITS)
|
||||
|
||||
#define F_FIXNUM long int /* unboxed */
|
||||
|
||||
#define WORD_SIZE (CELLS*8)
|
||||
#define HALF_WORD_SIZE (CELLS*4)
|
||||
#define HALF_WORD_MASK (((unsigned long)1<<HALF_WORD_SIZE)-1)
|
||||
|
||||
/* must always be 16 bits */
|
||||
#define CHARS ((signed)sizeof(u16))
|
||||
|
||||
typedef unsigned long int CELL;
|
||||
#define CELLS ((signed)sizeof(CELL))
|
||||
|
||||
typedef unsigned char u8;
|
||||
typedef unsigned short u16;
|
||||
typedef unsigned int u32;
|
||||
typedef unsigned long long u64;
|
||||
typedef signed char s8;
|
||||
typedef signed short s16;
|
||||
typedef signed int s32;
|
||||
typedef signed long long s64;
|
||||
|
||||
/* must always be 8 bits */
|
||||
typedef unsigned char BYTE;
|
||||
|
||||
/* raw pointer to datastack bottom */
|
||||
CELL ds_bot;
|
||||
|
||||
|
|
@ -54,14 +72,9 @@ CELL executing;
|
|||
#include <string.h>
|
||||
#include <time.h>
|
||||
|
||||
typedef unsigned char u8;
|
||||
typedef unsigned short u16;
|
||||
typedef unsigned int u32;
|
||||
typedef unsigned long long u64;
|
||||
typedef signed char s8;
|
||||
typedef signed short s16;
|
||||
typedef signed int s32;
|
||||
typedef signed long long s64;
|
||||
#ifdef FACTOR_SDL
|
||||
#include "SDL/SDL.h"
|
||||
#endif
|
||||
|
||||
#include <sys/param.h>
|
||||
|
||||
|
|
@ -78,29 +91,9 @@ typedef signed long long s64;
|
|||
#include <sys/stat.h>
|
||||
#include <unistd.h>
|
||||
#include <sys/time.h>
|
||||
#include <dlfcn.h>
|
||||
#endif
|
||||
|
||||
#if !defined(WIN32)
|
||||
#include <dlfcn.h>
|
||||
#endif
|
||||
|
||||
#define INLINE inline static
|
||||
|
||||
#define FIXNUM_MAX (LONG_MAX >> TAG_BITS)
|
||||
#define FIXNUM_MIN (LONG_MIN >> TAG_BITS)
|
||||
|
||||
#define F_FIXNUM long int /* unboxed */
|
||||
|
||||
#define WORD_SIZE (CELLS*8)
|
||||
#define HALF_WORD_SIZE (CELLS*4)
|
||||
#define HALF_WORD_MASK (((unsigned long)1<<HALF_WORD_SIZE)-1)
|
||||
|
||||
/* must always be 16 bits */
|
||||
#define CHARS ((signed)sizeof(u16))
|
||||
|
||||
/* must always be 8 bits */
|
||||
typedef unsigned char BYTE;
|
||||
|
||||
#include "error.h"
|
||||
#include "cards.h"
|
||||
#include "memory.h"
|
||||
|
|
|
|||
|
|
@ -30,3 +30,17 @@
|
|||
#else
|
||||
#define FACTOR_OS_STRING "unix"
|
||||
#endif
|
||||
|
||||
#if defined(WIN32)
|
||||
#define DLLEXPORT __declspec(dllexport)
|
||||
#define SETJMP setjmp
|
||||
#define LONGJMP longjmp
|
||||
#define JMP_BUF jmp_buf
|
||||
#else
|
||||
#define DLLEXPORT
|
||||
#define SETJMP(jmpbuf) sigsetjmp(jmpbuf,1)
|
||||
#define LONGJMP siglongjmp
|
||||
#define JMP_BUF sigjmp_buf
|
||||
#endif
|
||||
|
||||
#define INLINE inline static
|
||||
|
|
|
|||
12
native/run.c
12
native/run.c
|
|
@ -9,12 +9,11 @@ void run(void)
|
|||
{
|
||||
CELL next;
|
||||
|
||||
CELL height = cs - cs_bot;
|
||||
|
||||
/* Error handling. */
|
||||
#ifdef WIN32
|
||||
setjmp(toplevel);
|
||||
#else
|
||||
sigsetjmp(toplevel, 1);
|
||||
#endif
|
||||
SETJMP(toplevel);
|
||||
|
||||
if(throwing)
|
||||
{
|
||||
interrupt = false;
|
||||
|
|
@ -49,6 +48,9 @@ void run(void)
|
|||
interrupt = false;
|
||||
}
|
||||
|
||||
if(cs - cs_bot < height)
|
||||
return;
|
||||
|
||||
callframe = cpop();
|
||||
executing = cpop();
|
||||
continue;
|
||||
|
|
|
|||
11
native/run.h
11
native/run.h
|
|
@ -24,15 +24,7 @@ DLLEXPORT CELL userenv[USER_ENV];
|
|||
DLLEXPORT bool interrupt;
|
||||
|
||||
/* Error handlers restore this */
|
||||
#ifdef WIN32
|
||||
jmp_buf toplevel;
|
||||
#else
|
||||
sigjmp_buf toplevel;
|
||||
#endif
|
||||
|
||||
/* Call stack depth to start profile counter from */
|
||||
/* This ensures that words in the user's interpreter do not count */
|
||||
CELL profile_depth;
|
||||
JMP_BUF toplevel;
|
||||
|
||||
INLINE CELL dpop(void)
|
||||
{
|
||||
|
|
@ -89,7 +81,6 @@ INLINE void call(CELL quot)
|
|||
callframe = quot;
|
||||
}
|
||||
|
||||
void call_into_factor(F_WORD *word, XT xt);
|
||||
void run(void);
|
||||
void platform_run(void);
|
||||
void undefined(F_WORD *word);
|
||||
|
|
|
|||
Loading…
Reference in New Issue