Commit 950f2e48 authored by pazsan's avatar pazsan

Added direct threading for R3/4000. Still needs cache flush.

Added direct threading for R3/4000. Needs still cache flush.
parent fe5f8ba0
\ CROSS.FS The Cross-Compiler 06oct92py
\ $Id: cross.fs,v 1.2 1994-05-03 15:24:11 pazsan Exp $
\ $Id: cross.fs,v 1.3 1994-05-05 15:46:38 pazsan Exp $
\ Idea and implementation: Bernd Paysan (py)
\ Copyright 1992 by the ANSI figForth Development Group
......@@ -117,13 +117,6 @@ Variable bit$
Variable tdp
: there tdp @ ;
\ Constants 06apr93py
-2 Constant :docol
-3 Constant :docon
-4 Constant :dovar
-5 Constant :dodoes
\ Parameter for target systems 06oct92py
include machine.fs
......@@ -144,7 +137,9 @@ include machine.fs
-2 Constant :docol
-3 Constant :docon
-4 Constant :dovar
-5 Constant :dodoes
-5 Constant :douser
-6 Constant :dodoes
-7 Constant :doesjump
>CROSS
......@@ -228,7 +223,7 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
: >body ( cfa -- pfa ) T cell+ cell+ H ;
>CROSS
: dodoes, ( -- ) T 0 , 0 , H ;
: dodoes, ( -- ) T :doesjump A, 0 , H ;
\ Ghost Builder 06oct92py
......@@ -562,16 +557,30 @@ Build: T 0 A, H ;
by Create
Builder AVariable
Build: T 0 , H ;
by Create
\ User variables 04may94py
>CROSS
Variable tup 0 tup !
Variable tudp 0 tudp !
: u, ( n -- udp )
tup @ tudp @ + T ! H
tudp @ dup cell+ tudp ! ;
: au, ( n -- udp )
tup @ tudp @ + T A! H
tudp @ dup cell+ tudp ! ;
>TARGET
Build: T 0 u, , H ;
DO: ( ghost -- up-addr ) T @ H tup @ + ;DO
Builder User
by User :douser resolve
Build: T 0 , 0 , H ;
by Create
Build: T 0 u, , 0 u, drop H ;
by User
Builder 2User
Build: T 0 A, H ;
by Create
Build: T 0 au, , H ;
by User
Builder AUser
Build: ( n -- ) T , H ;
......@@ -771,6 +780,8 @@ only forth also minimal definitions
: decimal decimal ;
: hex hex ;
: tudp T tudp H ;
: tup T tup H ; minimal
\ for debugging...
: order order ;
......
/*
$Id: decstation.h,v 1.1 1994-02-11 16:30:46 anton Exp $
$Id: decstation.h,v 1.2 1994-05-05 15:46:41 pazsan Exp $
Copyright 1992 by the ANSI figForth Development Group
This is the machine-specific part for a Decstation running Ultrix
......@@ -51,9 +51,9 @@ typedef float SFloat;
/* CODE_ADDRESS is the address of the code jumped to through the code field */
# define CODE_ADDRESS(cfa) ((Label)(((*(unsigned *)(cfa))^JAL_PATTERN^(SEGMENT_NUM<<26))<<2))
# define MAKE_CF(cfa,ca) ({long *_cfa = (long *)(cfa); \
long _ca = (long)(ca);
_cfa[0] = JAL_PATTERN|(((((long)_ca)>>2)+4)&JUMP_MASK), /* JAL ca+4 */ \
_cfa[1] = *(long *)_ca; /* delay slot */})
long _ca = (long)(ca); \
_cfa[0] = JAL_PATTERN|(((((long)_ca)>>2))&JUMP_MASK); /* JAL ca+4 */ \
_cfa[1] = 0; /* *(long *)_ca; delay slot */})
# endif /* undefined */
/* this is the point where the does code starts if label points to the
......@@ -64,13 +64,19 @@ typedef float SFloat;
# define DOES_CODE1(cfa) DOES_CODE(cfa)
# define DOES_HANDLER_SIZE 8
# define MAKE_DOES_CF(cfa,does_code) \
({long does_handlerp=((long)(does_code))-DOES_HANDLER_SIZE; \
long *_cfa = (long*)(cfa); \
_cfa[0] = J_PATTERN|((does_handlerp&JUMP_MASK)>>2); /* J ca */ \
_cfa[1] = 0; /* nop */})
/*
# define MAKE_DOES_CF(cfa, does_code) ({char *does_handlerp=((char *)does_code)-DOES_HANDLER_SIZE; \
MAKE_CF(cfa,does_handlerp); \
MAKE_DOES_HANDLER(does_handlerp);})
MAKE_DOES_HANDLER(does_handlerp) ;})
*/
/* this stores a jump dodoes at addr */
# define MAKE_DOES_HANDLER(addr) ({long * _addr = (long *)addr; \
_addr[0] = J_PATTERN|((((long)DODOES)>>2)&JUMP_MASK); /* J dodoes */ \
_addr[1] = 0; /* nop */})
# define MAKE_DOES_HANDLER(addr) MAKE_CF(addr,symbols[DODOES])
#endif
#ifdef undefined
/* and here are some more efficient versions that can be tried later */
......@@ -80,17 +86,19 @@ typedef float SFloat;
*/
#define MAKE_DOESJUMP(addr) ({long * _addr = (long *)addr; \
_addr[0] = J_PATTERN|(((((long)symbols[3])>>2)+4)&JUMP_MASK), /* J dodoes+4 */ \
_addr[1] = *(long *)symbols[3]; /* delay */})
_addr[0] = J_PATTERN|(((((long)symbols[DODOES])>>2)+4)&JUMP_MASK), /* J dodoes+4 */ \
_addr[1] = *(long *)symbols[DODOES]; /* delay */})
/* the following version uses JAL to make DOES_CODE1 faster */
/* !! does the declaration clear the register ? */
/* it's ok to use the same reg as in PFA1:
dodoes is the only potential problem and I have taken care of it */
#define DOES_CODE1(cfa) ({register Code *_does_code asm("$31"); \
_does_code; })
#define MAKE_DOESJUMP(addr) ({long * _addr = (long *)addr; \
_addr[0] = JAL_PATTERN|(((((long)symbols[3])>>2)+4)&JUMP_MASK), /* JAL dodoes+4 */ \
_addr[1] = *(long *)symbols[3]; /* delay */})
_addr[0] = JAL_PATTERN|(((((long)symbols[DODOES])>>2)+4)&JUMP_MASK), /* JAL dodoes+4 */ \
_addr[1] = *(long *)symbols[DODOES]; /* delay */})
#endif
/*
$Id: engine.c,v 1.3 1994-05-03 19:10:34 pazsan Exp $
$Id: engine.c,v 1.4 1994-05-05 15:46:42 pazsan Exp $
Copyright 1992 by the ANSI figForth Development Group
*/
......@@ -45,16 +45,18 @@ typedef struct F83Name {
/* NEXT and NEXT1 are split into several parts to help scheduling */
#ifdef DIRECT_THREADED
#define NEXT1_P1
#define NEXT1_P2 ({goto *cfa;})
# define NEXT1_P1
# define NEXT1_P2 ({goto *cfa;})
# define DEF_CA
#else
#define NEXT1_P1 ({ca = *cfa;})
#define NEXT1_P2 ({goto *ca;})
# define NEXT1_P1 ({ca = *cfa;})
# define NEXT1_P2 ({goto *ca;})
# define DEF_CA Label ca;
#endif
#define NEXT_P1 ({cfa = *ip++; NEXT1_P1;})
#define NEXT1 ({Label ca; NEXT1_P1; NEXT1_P2;})
#define NEXT ({Label ca; NEXT_P1; NEXT1_P2;})
#define NEXT1 ({DEF_CA NEXT1_P1; NEXT1_P2;})
#define NEXT ({DEF_CA NEXT_P1; NEXT1_P2;})
#ifdef USE_TOS
#define IF_TOS(x) x
......@@ -70,7 +72,9 @@ typedef struct F83Name {
#define FTOS (fp[0])
#endif
#define DODOES (symbols[3])
/*
#define CA_DODOES (symbols[DODOES])
*/
int emitcounter;
#define NULLC '\0'
......@@ -90,16 +94,16 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp)
{
Xt cfa;
Address lp=NULL;
Address up=NULL;
static Label symbols[]= {
&&docol,
&&docon,
&&dovar,
&&douser,
&&dodoes,
&&docol, /* dummy for does handler address */
#include "prim_labels.i"
};
#ifndef DIRECT_THREADED
/* Label ca; */
#endif
IF_TOS(register Cell TOS;)
IF_FTOS(Float FTOS;)
#ifdef CPU_DEP
......@@ -129,7 +133,7 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp)
problems with code fields employing calls and delay slots
*/
{
Label ca;
DEF_CA
Xt *current_ip = (Xt *)PFA1(cfa);
cfa = *current_ip;
NEXT1_P1;
......@@ -164,6 +168,18 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp)
/* !! user? */
douser:
#ifdef DEBUG
printf("user: %x\n",(Cell)PFA1(cfa));
#endif
#ifdef USE_TOS
*sp-- = TOS;
TOS = up+*(Cell*)PFA1(cfa);
#else
*--sp = up+*(Cell*)PFA1(cfa);
#endif
NEXT;
dodoes:
/* this assumes the following structure:
defining-word:
......@@ -183,7 +199,7 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp)
*/
#ifdef DEBUG
printf("does: %x\n",(Cell)PFA(cfa));
printf("does: %x\n",(Cell)PFA(cfa)); fflush(stdout);
#endif
*--rp = (Cell)ip;
/* PFA1 might collide with DOES_CODE1 here, so we use PFA */
......
/*
$Id: forth.h,v 1.1 1994-02-11 16:30:46 anton Exp $
$Id: forth.h,v 1.2 1994-05-05 15:46:44 pazsan Exp $
Copyright 1992 by the ANSI figForth Development Group
*/
......@@ -7,6 +7,15 @@
typedef void *Label;
/* symbol indexed constants */
#define DOCOL 0
#define DOCON 1
#define DOVAR 2
#define DOUSER 3
#define DODOES 4
#define DOESJUMP 5
#include "machine.h"
/* Forth data types */
......@@ -45,7 +54,7 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp);
ca is the code address */
#define MAKE_CF(cfa,ca) ((*(Label *)(cfa)) = ((Label)ca))
/* make a code field for a defining-word-defined word */
#define MAKE_DOES_CF(cfa,does_code) ({MAKE_CF(cfa,DODOES); \
#define MAKE_DOES_CF(cfa,does_code) ({MAKE_CF(cfa,symbols[DODOES]); \
((Cell *)cfa)[1] = (Cell)does_code;})
/* the does handler resides between DOES> and the following Forth code */
#define DOES_HANDLER_SIZE 8
......@@ -53,7 +62,11 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp);
#endif
#ifdef DEBUG
# define NAME(string) puts(string);
# define NAME(string) printf("%08x: %s\n",(int)ip,string);
#else
# define NAME(string)
#endif
#define CF(const) (-const-2)
#define CF_NIL -1
......@@ -466,7 +466,7 @@ Create ??? ," ???"
\ direct threading is implementation dependent
: Create Header reveal [ :dovar ] ALiteral cfa, ;
: Create Header reveal [ :dovar ] Literal cfa, ;
\ DOES> 17mar93py
......@@ -483,7 +483,7 @@ Create ??? ," ???"
: User Variable ;
: AUser AVariable ;
: (Constant) Header reveal [ :docon ] ALiteral cfa, ;
: (Constant) Header reveal [ :docon ] Literal cfa, ;
: Constant (Constant) , ;
: AConstant (Constant) A, ;
: 2Constant ( w1 w2 "name" -- ) \ double
......@@ -511,10 +511,10 @@ Create ??? ," ???"
: EXIT ( -- ) postpone ;s ; immediate
: : ( -- colon-sys ) Header [ :docol ] ALiteral cfa, 0 ] ;
: : ( -- colon-sys ) Header [ :docol ] Literal cfa, 0 ] ;
: ; ( colon-sys -- ) ?struc postpone exit reveal postpone [ ;
immediate restrict
: :noname ( -- xt colon-sys ) here [ ' : @ ] ALiteral cfa, 0 ] ;
: :noname ( -- xt colon-sys ) here [ :docol ] Literal cfa, 0 ] ;
\ Search list handling 23feb93py
......@@ -794,7 +794,7 @@ Variable argc
." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ;
: boot ( **env **argv argc -- )
argc ! argv ! env !
argc ! argv ! env ! main-task up!
sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ;
: bye cr 0 (bye) ;
......
/*
$Id: main.c,v 1.1 1994-02-11 16:30:46 anton Exp $
$Id: main.c,v 1.2 1994-05-05 15:46:48 pazsan Exp $
Copyright 1993 by the ANSI figForth Development Group
*/
......@@ -14,10 +14,14 @@
#include <stdlib.h>
#include "forth.h"
#ifndef DEFAULTBIN
# define DEFAULTBIN ""
#endif
#ifdef DIRECT_THREADED
#define CA(n) (symbols[(n)])
# define CA(n) (symbols[(n)])
#else
#define CA(n) ((int)(symbols+(n)))
# define CA(n) ((int)(symbols+(n)))
#endif
/* image file format:
......@@ -32,31 +36,42 @@
* If the word is >=0, the address is within the image;
* addresses within the image are given relative to the start of the image.
* If the word is =-1, the address is NIL,
* If the word is between -2 and -4, it's a CFA (:, Create, Constant)
* If the word is -5, it's a DOES> CFA
* If the word is <-5, it's a primitive
* If the word is between -2 and -5, it's a CFA (:, Create, Constant, User)
* If the word is -6, it's a DOES> CFA
* If the word is -7, it's a DOES JUMP
* If the word is <-7, it's a primitive
*/
void relocate(int *image, char *bitstring, int size, Label symbols[])
{
int i;
static char bits[8]={0x80,0x40,0x20,0x10,0x08,0x04,0x02,0x01};
Label DODOES=symbols[3];
#ifdef DEBUG
printf("Dodoes-Adresse: %08x\n",(int)symbols[DODOES]);
#endif
for(i=0;i<size/sizeof(Cell);i++)
if(bitstring[i >> 3] & bits[i & 7])
if(image[i]<0)
if(image[i]==-1)
image[i]=0;
else if(image[i]>-5)
MAKE_CF(image+i,symbols[-image[i]-2]);
else if(image[i]==-5)
switch(image[i])
{
MAKE_DOES_CF(image+i,image[i+1]+((int)image));
i++; /* is this necessary? */
case CF_NIL :
image[i]=0; break;
case CF(DOCOL) :
case CF(DOVAR) :
case CF(DOCON) :
case CF(DOUSER) :
MAKE_CF(image+i,symbols[CF(image[i])]); break;
case CF(DODOES) :
MAKE_DOES_CF(image+i,image[i+1]+((int)image));
i++; break; /* is this necessary? */
case CF(DOESJUMP):
MAKE_DOES_HANDLER(image+i);
break;
default:
image[i]=(Cell)CA(CF(image[i]));
}
else
image[i]=(Cell)CA(-image[i]-2);
else
image[i]+=(Cell)image;
}
......@@ -120,7 +135,12 @@ int main(int argc, char **argv, char **env)
imagefile[strlen(imagefile)]='/';
}
else
imagefile[0]='\0';
{
strcpy(imagefile,DEFAULTBIN);
if(imagefile[0]!=0 && imagefile[strlen(imagefile)-1]!='/')
imagefile[strlen(imagefile)]='/';
}
if(argc>1 && argv[1][0]=='@')
{
......
......@@ -40,6 +40,7 @@ include toolsext.fs
\ Setup 13feb93py
here dp !
tudp H @ minimal udp !
decimal
\ 64 KB 0 cells ! \ total Space... defined above!
......
/*
$Id: primitives,v 1.3 1994-05-03 15:24:14 pazsan Exp $
$Id: primitives,v 1.4 1994-05-05 15:46:50 pazsan Exp $
Copyright 1992 by the ANSI figForth Development Group
WARNING: This file is processed by m4. Make sure your identifiers
......@@ -931,9 +931,9 @@ behaviour is uundefined""
defining-word-defined */
a_addr = DOES_CODE(xt);
code-address! c_addr xt -- new code_address_store
code-address! n xt -- new code_address_store
""Creates a code field with code address c_addr at xt""
MAKE_CF(xt, c_addr);
MAKE_CF(xt, symbols[CF(n)]);
does-code! a_addr xt -- new does_code_store
""creates a code field at xt for a defining-word-defined word; a_addr
......@@ -980,3 +980,6 @@ lp -= sizeof(Cell);
f>l r -- new f_to_l
lp -= sizeof(Float);
*(Float *)lp = r;
up! a_addr -- new up_store
up=a_addr;
;;$Id: primitives2c.el,v 1.2 1994-05-03 19:10:35 pazsan Exp $
;;$Id: primitives2c.el,v 1.3 1994-05-05 15:46:52 pazsan Exp $
;;Copyright 1992 by the ANSI figForth Development Group
;; To Do:
......@@ -60,12 +60,12 @@
(defun alias-filter (forth-name stack-effect standards c-name doku code forth-code)
(setq primitive-number (+ 1 primitive-number))
(format "%s Alias %s" (- -5 primitive-number) forth-name))
(format "%s Alias %s" (- -7 primitive-number) forth-name))
(defun c-filter (forth-name stack-effect standards c-name doku code forth-code)
"c code for the primitive"
(let ((effects (parse-stack-effect stack-effect)))
(format "I_%s: /* %s ( %s ) */\n/* %s */\n{\nLabel ca;\n%s\nNAME(\"%s\")\n{\n%s}\nNEXT_P1;\n%sNEXT1_P2;\n}\n"
(format "I_%s: /* %s ( %s ) */\n/* %s */\n{\nDEF_CA\n%s\nNAME(\"%s\")\n{\n%s}\nNEXT_P1;\n%sNEXT1_P2;\n}\n"
c-name forth-name stack-effect doku
(prefix effects) forth-name code (suffix effects))))
......
......@@ -23,6 +23,11 @@ FF Constant /line
\ doesn't produce real user variables now, but normal variables
Create main-task 100 cells allot
main-task tup H ! minimal
Variable udp
AUser s0
AUser r0
AUser f0
......@@ -48,7 +53,7 @@ AUser "error 0 "error !
2User linestart \ starting file postition of
\ the current interpreted line (in TIB)
User base $A base !
User base A base !
User dpl -1 dpl !
User state 0 state !
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment