Commit ca6e1e45 authored by sewardj's avatar sewardj
Browse files

[project @ 1999-07-06 15:24:36 by sewardj]

Mods to enable interworking with simple compiled code.  Supports fns and
data decls.  Classes, instances, primops, don't work yet.
Unregisterised, mininterpreted x86-ELF is the supported object format.
GC appears to work correctly.
parent 17622819
......@@ -7,8 +7,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: codegen.c,v $
* $Revision: 1.7 $
* $Date: 1999/06/07 17:22:53 $
* $Revision: 1.8 $
* $Date: 1999/07/06 15:24:36 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -54,6 +54,22 @@ static StgVar currentTop;
*
* ------------------------------------------------------------------------*/
static Cell cptrFromName ( Name n )
{
char buf[1000];
void* p;
Module m = name(n).mod;
Text mt = module(m).text;
sprintf(buf,"%s_%s_closure",
textToStr(mt), textToStr(name(n).text) );
p = lookupOTabName ( m, buf );
if (!p) {
ERRMSG(0) "Can't find object symbol %s", buf
EEND;
}
return mkCPtr(p);
}
static Bool varHasClosure( StgVar v )
{
return asmObjectHasClosure((AsmClosure*)ptrOf(stgVarInfo(v)));
......@@ -107,10 +123,13 @@ static void cgBind( AsmBCO bco, StgVar v )
static Void pushVar( AsmBCO bco, StgVar v )
{
Cell info;
assert(isStgVar(v));
if (!(isStgVar(v) || isCPtr(v))) {
assert(isStgVar(v) || isCPtr(v));
}
if (isCPtr(v)) {
fprintf ( stderr, "push cptr %p\n", (void*)cptrOf(v) );
asmGHCClosure(bco, cptrOf(v));
} else {
info = stgVarInfo(v);
if (isPtr(info)) {
......@@ -130,7 +149,9 @@ static Void pushAtom( AsmBCO bco, StgAtom e )
pushVar(bco,e);
break;
case NAME:
pushVar(bco,name(e).stgVar);
if (nonNull(name(e).stgVar))
pushVar(bco,name(e).stgVar); else
pushVar(bco,cptrFromName(e));
break;
case CHARCELL:
asmConstChar(bco,charOf(e));
......@@ -161,7 +182,7 @@ static Void pushAtom( AsmBCO bco, StgAtom e )
#endif
break;
case CPTRCELL:
asmConstWord(bco,cptrOf(e));
asmGHCClosure(bco,cptrOf(e));
break;
case PTRCELL:
asmConstAddr(bco,ptrOf(e));
......@@ -487,18 +508,31 @@ static Void build( AsmBCO bco, StgVar v )
}
case STGAPP:
{
Bool itsaPAP;
StgVar fun = stgAppFun(rhs);
StgVar fun0 = fun;
List args = stgAppArgs(rhs);
if (isName(fun)) {
fun = name(fun).stgVar;
if (nonNull(name(fun).stgVar))
fun = name(fun).stgVar; else
fun = cptrFromName(fun);
}
if (isCPtr(fun)
||
(nonNull(stgVarBody(fun))
&& whatIs(stgVarBody(fun)) == LAMBDA
&& length(stgLambdaArgs(stgVarBody(fun))) > length(args)
)
) {
if (isCPtr(fun)) {
assert(isName(fun0));
itsaPAP = name(fun0).arity > length(args);
fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n",
nameFromOPtr(cptrOf(fun)), name(fun0).arity, length(args) );
} else {
itsaPAP = FALSE;
if (nonNull(stgVarBody(fun))
&& whatIs(stgVarBody(fun)) == LAMBDA
&& length(stgLambdaArgs(stgVarBody(fun))) > length(args)
)
itsaPAP = TRUE;
}
if (itsaPAP) {
AsmSp start = asmBeginMkPAP(bco);
map1Proc(pushAtom,bco,reverse(args));
pushAtom(bco,fun);
......
......@@ -10,8 +10,8 @@
* in the distribution for details.
*
* $RCSfile: compiler.c,v $
* $Revision: 1.7 $
* $Date: 1999/06/07 17:22:46 $
* $Revision: 1.8 $
* $Date: 1999/07/06 15:24:36 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -1503,6 +1503,9 @@ Void evalExp() { /* compile and run input expression */
RevertCAFs();
break;
case Success:
//fflush(stderr);fflush(stdout);
//fprintf(stderr, "\n\nFinal top-of-stack is\n" );
//printObj ( *(MainRegTable.rSp) );
RevertCAFs();
break;
default:
......
......@@ -8,8 +8,8 @@
* in the distribution for details.
*
* $RCSfile: hugs.c,v $
* $Revision: 1.7 $
* $Date: 1999/06/07 17:22:43 $
* $Revision: 1.8 $
* $Date: 1999/07/06 15:24:37 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
......@@ -103,6 +103,7 @@ static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
static Bool addType = FALSE; /* TRUE => print type with value */
static Bool useDots = RISCOS; /* TRUE => use dots in progress */
static Bool quiet = FALSE; /* TRUE => don't show progress */
static Bool lastWasObject = FALSE;
Bool preludeLoaded = FALSE;
Bool optimise = FALSE;
......@@ -158,6 +159,7 @@ String bool2str ( Bool b )
void ppSmStack ( String who )
{
int i, j;
return;
fflush(stdout);fflush(stderr);
printf ( "\n" );
printf ( "ppSmStack %s: numScripts = %d namesUpto = %d needsImports = %s\n",
......@@ -892,6 +894,8 @@ Int stacknum; {
scriptFile = name;
if (scriptInfo[stacknum].fromSource) {
if (lastWasObject) finishInterfaces();
lastWasObject = FALSE;
Printf("Reading script \"%s\":\n",name);
needsImports = FALSE;
parseScript(name,len);
......@@ -912,6 +916,7 @@ Int stacknum; {
loadInterface(name,len);
scriptFile = 0;
lastWasObject = TRUE;
if (needsImports) return FALSE;
}
......@@ -1038,6 +1043,7 @@ Int n; { /* loading everything after and */
Long fileSize; /* has been either changed or added*/
static char name[FILENAME_MAX+1];
lastWasObject = FALSE;
ppSmStack("readscripts-begin");
#if HUGS_FOR_WINDOWS
SetCursor(LoadCursor(NULL, IDC_WAIT));
......@@ -1105,6 +1111,7 @@ assert(nextNumScripts==NUM_SCRIPTS);
}
else
dropScriptsFrom(numScripts-1);
} else {
if (scriptInfo[numScripts].objLoaded) {
......@@ -1300,14 +1307,15 @@ static Void local evaluator() { /* evaluate expr and print value */
Putchar('\n');
}
}
#endif
#if 0
#else
printf ( "result type is " );
printType ( stdout, type );
printf ( "\n" );
evalExp();
printf ( "\n" );
#endif
}
......
This diff is collapsed.
......@@ -7,8 +7,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: optimise.c,v $
* $Revision: 1.5 $
* $Date: 1999/04/27 10:06:57 $
* $Revision: 1.6 $
* $Date: 1999/07/06 15:24:39 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -21,6 +21,8 @@
/* #define DEBUG_OPTIMISE */
extern void print ( Cell, Int );
/* --------------------------------------------------------------------------
* Local functions
* ------------------------------------------------------------------------*/
......@@ -1583,7 +1585,7 @@ StgExpr simplify ( List caseEnv, StgExpr e )
case LAMBDA:
stgLambdaBody(e) = simplify(caseEnv,stgLambdaBody(e));
lambda_local:
/* lambda_local: */
while (whatIsStg(stgLambdaBody(e))==LAMBDA) {
nLambdasMerged++;
stgLambdaArgs(e) = appendOnto(stgLambdaArgs(e),
......@@ -2201,7 +2203,7 @@ static Bool noisy;
static void local optimiseTopBind( StgVar v )
{
Bool ppPrel = FALSE;
/* Bool ppPrel = FALSE; */
Int n, m;
Name naam;
Int oldSize, newSize;
......
......@@ -11,8 +11,8 @@
* in the distribution for details.
*
* $RCSfile: parser.y,v $
* $Revision: 1.6 $
* $Date: 1999/06/07 17:22:41 $
* $Revision: 1.7 $
* $Date: 1999/07/06 15:24:40 $
* ------------------------------------------------------------------------*/
%{
......@@ -347,9 +347,7 @@ ifEntities
;
ifEntity
: ifEntityOcc {$$=gc1($1);}
| ifEntityOcc ifStuffInside {$$=gc2($1);}
| ifEntityOcc '|' ifStuffInside {$$=gc3($1);}
/* exporting datacons but not tycon */
| ifEntityOcc ifStuffInside {$$=gc2(pair($1,$2));}
;
ifEntityOcc
: ifVar { $$ = gc1($1); }
......@@ -362,12 +360,9 @@ ifStuffInside
: '{' ifValOccs '}' { $$ = gc3($2); }
;
ifValOccs
: ifValOcc { $$ = gc1(singleton($1)); }
| ifValOcc ifValOccs { $$ = gc2(cons($1,$2)); }
;
ifValOcc
: ifVar {$$ = gc1($1); }
| ifCon {$$ = gc1($1); }
: { $$ = gc0(NIL); }
| ifVar ifValOccs { $$ = gc2(cons($1,$2)); }
| ifCon ifValOccs { $$ = gc2(cons($1,$2)); }
;
version_list_junk
: {$$=gc0(NIL);}
......
#define B_BASE 256
#define B_BASE_FLT (256.0)
/* this really ought to be abstract */
typedef
struct {
int sign;
int size;
int used;
unsigned char stuff[0];
}
B;
/* the ops themselves */
int do_getsign ( B* x );
int do_cmp ( B* x, B* y );
void do_add ( B* x, B* y, int sizeRes, B* res );
void do_sub ( B* x, B* y, int sizeRes, B* res );
void do_mul ( B* x, B* y, int sizeRes, B* res );
void do_qrm ( B* x, B* y, int sizeRes, B* qres, B* rres );
void do_neg ( B* x, int sizeRes, B* res );
void do_renormalise ( B* x );
int is_sane ( B* x );
void do_fromInt ( int n, int sizeRes, B* res );
void do_fromWord ( unsigned int n, int sizeRes, B* res );
void do_fromStr ( char* str, int sizeRes, B* res );
int do_toInt ( B* x );
unsigned int do_toWord ( B* x );
float do_toFloat ( B* x );
double do_toDouble ( B* x );
/* the number of bytes needed to hold result of an op */
int size_add ( B* x, B* y );
int size_sub ( B* x, B* y );
int size_mul ( B* x, B* y );
int size_qrm ( B* x, B* y );
int size_neg ( B* x );
int size_fromInt ( void );
int size_fromWord ( void );
int size_fromStr ( char* str );
int size_dblmantissa ( void );
int size_fltmantissa ( void );
......@@ -8,8 +8,8 @@
* in the distribution for details.
*
* $RCSfile: static.c,v $
* $Revision: 1.7 $
* $Date: 1999/06/07 17:22:35 $
* $Revision: 1.8 $
* $Date: 1999/07/06 15:24:41 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -412,9 +412,9 @@ Cell impList; {
List es = module(m).exports;
for(; nonNull(es); es=tl(es)) {
Cell e = hd(es);
if (isName(e))
if (isName(e)) {
imports = cons(e,imports);
else {
} else {
Cell c = fst(e);
List subentities = NIL;
imports = cons(c,imports);
......@@ -4183,7 +4183,7 @@ Cell e; {
EEND;
#endif
default : fprintf(stderr,"whatIs(e) == %d\n",whatIs(e));internal("depExpr");
default : internal("depExpr");
}
return e;
}
......
......@@ -8,8 +8,8 @@
* in the distribution for details.
*
* $RCSfile: storage.c,v $
* $Revision: 1.7 $
* $Date: 1999/06/07 17:22:49 $
* $Revision: 1.8 $
* $Date: 1999/07/06 15:24:43 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -415,7 +415,6 @@ Cell parent; {
name(nameHw).type = NIL;
name(nameHw).primop = 0;
name(nameHw).mod = currentModule;
name(nameHw).ghc_names = NIL;
module(currentModule).names=cons(nameHw,module(currentModule).names);
name(nameHw).nextNameHash = nameHash[h];
nameHash[h] = nameHw;
......@@ -881,6 +880,12 @@ Text t; {
module(moduleHw).names = NIL;
module(moduleHw).classes = NIL;
module(moduleHw).oImage = NULL;
module(moduleHw).oTab = NULL;
module(moduleHw).sizeoTab = 0;
module(moduleHw).usedoTab = 0;
module(moduleHw).dlTab = NULL;
module(moduleHw).sizedlTab = 0;
module(moduleHw).useddlTab = 0;
return moduleHw++;
}
......@@ -965,6 +970,95 @@ Name jrsFindQualName ( Text mn, Text sn )
return NIL;
}
/* A bit tricky. Assumes that if tab==NULL, then
currUsed and *currSize must be zero.
*/
static
void* genericExpand ( void* tab,
int* currSize, int currUsed,
int initSize, int elemSize )
{
int size2;
void* tab2;
if (currUsed < *currSize)
return tab;
size2 = (*currSize == 0) ? initSize : (2 * *currSize);
tab2 = malloc ( size2 * elemSize );
if (!tab2) {
ERRMSG(0) "Can't allocate enough memory to resize a table"
EEND;
}
if (*currSize > 0)
memcpy ( tab2, tab, elemSize * *currSize );
*currSize = size2;
if (tab) free ( tab );
return tab2;
}
void addOTabName ( Module m, char* nm, void* ad )
{
module(m).oTab
= genericExpand ( module(m).oTab,
&module(m).sizeoTab,
module(m).usedoTab,
8, sizeof(OSym) );
module(m).oTab[ module(m).usedoTab ].nm = nm;
module(m).oTab[ module(m).usedoTab ].ad = ad;
module(m).usedoTab++;
}
void addDLSect ( Module m, void* start, void* end, DLSect sect )
{
module(m).dlTab
= genericExpand ( module(m).dlTab,
&module(m).sizedlTab,
module(m).useddlTab,
4, sizeof(DLTabEnt) );
module(m).dlTab[ module(m).useddlTab ].start = start;
module(m).dlTab[ module(m).useddlTab ].end = end;
module(m).dlTab[ module(m).useddlTab ].sect = sect;
module(m).useddlTab++;
}
void* lookupOTabName ( Module m, char* nm )
{
int i;
for (i = 0; i < module(m).usedoTab; i++)
if (0==strcmp(nm,module(m).oTab[i].nm))
return module(m).oTab[i].ad;
return NULL;
}
char* nameFromOPtr ( void* p )
{
int i;
Module m;
for (m=MODMIN; m<moduleHw; m++)
for (i = 0; i < module(m).usedoTab; i++)
if (p == module(m).oTab[i].ad)
return module(m).oTab[i].nm;
return NULL;
}
DLSect lookupDLSect ( void* ad )
{
int i;
Module m;
for (m=MODMIN; m<moduleHw; m++)
for (i = 0; i < module(m).useddlTab; i++)
if (module(m).dlTab[i].start <= ad &&
ad <= module(m).dlTab[i].end)
return module(m).dlTab[i].sect;
return HUGS_DL_SECTION_OTHER;
}
/* --------------------------------------------------------------------------
* Script file storage:
*
......@@ -2273,8 +2367,7 @@ Int what; {
mark(name(i).defn);
mark(name(i).stgVar);
mark(name(i).type);
mark(name(i).ghc_names);
}
}
end("Names", nameHw-NAMEMIN);
start();
......
......@@ -9,8 +9,8 @@
* in the distribution for details.
*
* $RCSfile: storage.h,v $
* $Revision: 1.7 $
* $Date: 1999/06/07 17:22:47 $
* $Revision: 1.8 $
* $Date: 1999/07/06 15:24:45 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
......@@ -388,6 +388,26 @@ extern Ext mkExt Args((Text));
#define offsetOf(c) ((c)-OFFMIN)
#define mkOffset(o) (OFFMIN+(o))
/* --------------------------------------------------------------------------
* Object symbols:
* ------------------------------------------------------------------------*/
/* An entry in a very crude object symbol table */
typedef struct { char* nm; void* ad; }
OSym;
/* Indication of section kinds for loaded objects. Needed by
the GC for deciding whether or not a pointer on the stack
is a code pointer.
*/
typedef enum { HUGS_DL_SECTION_CODE_OR_RODATA,
HUGS_DL_SECTION_RWDATA,
HUGS_DL_SECTION_OTHER }
DLSect;
typedef struct { void* start; void* end; DLSect sect; }
DLTabEnt;
/* --------------------------------------------------------------------------
* Modules:
* ------------------------------------------------------------------------*/
......@@ -419,10 +439,20 @@ struct Module {
* evaluating an expression in the context of the current module.
*/
List qualImports;
/* ptr to malloc'd lump of memory holding the obj file */
void* oImage;
/* ptr to object symbol table; lives in mallocville.
Dynamically expands. */
OSym* oTab;
Int sizeoTab;
Int usedoTab;
/* The section-kind entries for this object module. Dynamically expands. */
DLTabEnt* dlTab;
Int sizedlTab;
Int useddlTab;
};
extern Module currentModule; /* Module currently being processed */
......@@ -434,6 +464,14 @@ extern Module findModule Args((Text));
extern Module findModid Args((Cell));
extern Void setCurrModule Args((Module));
extern void addOTabName Args((Module,char*,void*));
extern void* lookupOTabName Args((Module,char*));
extern char* nameFromOPtr Args((void*));
extern void addDLSect Args((Module,void*,void*,DLSect));
extern DLSect lookupDLSect Args((void*));
#define isPrelude(m) (m==modulePrelude)
/* --------------------------------------------------------------------------
......@@ -497,7 +535,6 @@ struct strName {
Bool simplified; /* TRUE => already simplified */
Bool isDBuilder; /* TRUE => is a dictionary builder */
const void* primop; /* really StgPrim* */
List ghc_names; /* [(Text,Ptr)] */
Name nextNameHash;
};
......
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