Commit ef37dc2d authored by sewardj's avatar sewardj
Browse files

[project @ 2000-02-08 15:32:29 by sewardj]

Many bug fixes for object loading:
-- create class symbol table entries more correctly
-- find GHC-created info tables for names which are constructors
-- add debugging machinery:   :d <entity>  and symbol-table printers
parent 4d12e452
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: codegen.c,v $
* $Revision: 1.15 $
* $Date: 2000/01/12 16:32:41 $
* $Revision: 1.16 $
* $Date: 2000/02/08 15:32:29 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -161,7 +161,8 @@ print(e,10);printf("\n");
pushVar(bco,name(e).stgVar);
} else {
Cell /*CPtr*/ addr = cptrFromName(e);
fprintf ( stderr, "nativeAtom: name %s\n", nameFromOPtr(cptrOf(addr)) );
fprintf ( stderr, "nativeAtom: name %s\n",
nameFromOPtr(cptrOf(addr)) );
pushVar(bco,addr);
}
break;
......@@ -191,7 +192,7 @@ print(e,10);printf("\n");
asmConstAddr(bco,ptrOf(e));
break;
default:
fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
fprintf(stderr,"\nYoiks1: "); printExp(stderr,e);
internal("pushAtom");
}
}
......@@ -453,7 +454,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
break;
}
default:
fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
fprintf(stderr,"\nYoiks2: "); printExp(stderr,e);
internal("cgExpr");
}
}
......@@ -470,6 +471,9 @@ static Void alloc( AsmBCO bco, StgVar v )
{
StgRhs rhs = stgVarBody(v);
assert(isStgVar(v));
#if 0
printf("alloc: ");ppStgExpr(v);
#endif
switch (whatIs(rhs)) {
case STGCON:
{
......@@ -591,7 +595,10 @@ static Void build( AsmBCO bco, StgVar v )
* of this except "let x = x in ..."
*/
case NAME:
rhs = name(rhs).stgVar;
if (nonNull(name(rhs).stgVar))
rhs = name(rhs).stgVar; else
rhs = cptrFromName(rhs);
/* fall thru */
case STGVAR:
{
AsmSp start = asmBeginMkAP(bco);
......
......@@ -11,8 +11,8 @@
* included in the distribution.
*
* $RCSfile: compiler.c,v $
* $Revision: 1.17 $
* $Date: 2000/01/13 10:47:05 $
* $Revision: 1.18 $
* $Date: 2000/02/08 15:32:29 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -208,6 +208,9 @@ Triple tr; { /* triple of expressions. */
static Void local transAlt(e) /* Translate alt: */
Cell e; { /* ([Pat], Rhs) ==> ([Pat], Rhs') */
#if 0
printf ( "transAlt: " );print(snd(e),100);printf("\n");
#endif
snd(e) = transRhs(snd(e));
}
......@@ -1620,6 +1623,9 @@ static Void local compileGenFunction(n) /* Produce code for internally */
Name n; { /* generated function */
List defs = name(n).defn;
Int arity = length(fst(hd(defs)));
#if 0
printf ( "compGenFn: " );print(defs,100);printf("\n");
#endif
compiler(RESET);
currentName = n;
mapProc(transAlt,defs);
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: hugs.c,v $
* $Revision: 1.37 $
* $Date: 2000/02/03 13:55:21 $
* $Revision: 1.38 $
* $Date: 2000/02/08 15:32:29 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
......@@ -40,6 +40,8 @@ Bool showInstRes = FALSE;
Bool multiInstRes = FALSE;
#endif
#define N_PRELUDE_SCRIPTS (combined ? 30 : 1)
/* --------------------------------------------------------------------------
* Local function prototypes:
* ------------------------------------------------------------------------*/
......@@ -847,7 +849,7 @@ String s; {
currProject = s;
projInput(currProject);
scriptFile = currProject;
forgetScriptsFrom(1);
forgetScriptsFrom(N_PRELUDE_SCRIPTS);
while ((s=readFilename())!=0)
addStackEntry(s);
if (namesUpto<=1) {
......@@ -1124,7 +1126,7 @@ static Void local load() { /* read filenames from command line */
/* to be read */
while ((s=readFilename())!=0)
addStackEntry(s);
readScripts(1);
readScripts(N_PRELUDE_SCRIPTS);
}
static Void local project() { /* read list of script names from */
......@@ -1145,7 +1147,7 @@ static Void local project() { /* read list of script names from */
EEND;
}
loadProject(s);
readScripts(1);
readScripts(N_PRELUDE_SCRIPTS);
}
static Void local readScripts(n) /* Reread current list of scripts, */
......@@ -1330,11 +1332,11 @@ ToDo: Fix!
startNewScript(0);
if (nonNull(c=findTycon(t=findText(nm)))) {
if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
readScripts(1);
readScripts(N_PRELUDE_SCRIPTS);
}
} else if (nonNull(c=findName(t))) {
if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
readScripts(1);
readScripts(N_PRELUDE_SCRIPTS);
}
} else {
ERRMSG(0) "No current definition for name \"%s\"", nm
......@@ -1346,7 +1348,7 @@ ToDo: Fix!
static Void local runEditor() { /* run editor on script lastEdit */
if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
readScripts(1);
readScripts(N_PRELUDE_SCRIPTS);
}
static Void local setLastEdit(fname,line)/* keep name of last file to edit */
......@@ -1624,6 +1626,48 @@ Cell c; {
extern Name nameHw;
static Void dumpStg ( void )
{
String s;
Int i;
setCurrModule(findEvalModule());
startNewScript(0);
s = readFilename();
/* request to locate a symbol by name */
if (s && (*s == '?')) {
Text t = findText(s+1);
locateSymbolByName(t);
return;
}
/* request to dump a bit of the heap */
if (s && (*s == '-' || isdigit(*s))) {
int i = atoi(s);
print(i,100);
printf("\n");
return;
}
/* request to dump a symbol table entry */
if (!s
|| !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
|| !isdigit(s[1])) {
fprintf(stderr, ":d -- bad request `%s'\n", s );
return;
}
i = atoi(s+1);
switch (*s) {
case 't': dumpTycon(i); break;
case 'n': dumpName(i); break;
case 'c': dumpClass(i); break;
case 'i': dumpInst(i); break;
default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
}
}
#if 0
static Void local dumpStg( void ) { /* print STG stuff */
String s;
Text t;
......@@ -1671,6 +1715,7 @@ static Void local dumpStg( void ) { /* print STG stuff */
}
}
}
#endif
static Void local info() { /* describe objects */
Int count = 0; /* or give menu of commands */
......@@ -1992,14 +2037,14 @@ String argv[]; {
case FIND : find();
break;
case LOAD : clearProject();
forgetScriptsFrom(1);
forgetScriptsFrom(N_PRELUDE_SCRIPTS);
load();
break;
case ALSO : clearProject();
forgetScriptsFrom(numScripts);
load();
break;
case RELOAD : readScripts(1);
case RELOAD : readScripts(N_PRELUDE_SCRIPTS);
break;
case PROJECT: project();
break;
......
This diff is collapsed.
......@@ -112,7 +112,7 @@ module Prelude (
-- This lot really shouldn't be exported, but are needed to
-- implement various libs.
,primCompAux,PrimArray,primRunST,primNewArray,primWriteArray
,hugsprimCompAux,PrimArray,primRunST,primNewArray,primWriteArray
,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv
,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open
,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar
......@@ -632,7 +632,7 @@ instance Ord a => Ord [a] where
compare [] (_:_) = LT
compare [] [] = EQ
compare (_:_) [] = GT
compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys)
instance Functor [] where
fmap = map
......@@ -1545,8 +1545,8 @@ readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
-- Hooks for primitives: -----------------------------------------------------
-- Do not mess with these!
primCompAux :: Ord a => a -> a -> Ordering -> Ordering
primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering
hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
hugsprimEqChar :: Char -> Char -> Bool
hugsprimEqChar c1 c2 = primEqChar c1 c2
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: link.c,v $
* $Revision: 1.39 $
* $Date: 2000/02/03 13:55:21 $
* $Revision: 1.40 $
* $Date: 2000/02/08 15:32:30 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -525,16 +525,13 @@ Int what; {
nameUnpackString = linkName("hugsprimUnpackString");
namePMFail = linkName("hugsprimPmFail");
assert(nonNull(namePMFail));
#define xyzzy(aaa,bbb) aaa = linkName(bbb)
/* pmc */
xyzzy(nameSel, "_SEL");
/* newtype and USE_NEWTYPE_FOR_DICTS */
xyzzy(nameId, "id");
/* strict constructors */
xyzzy(nameFlip, "flip" );
......@@ -553,20 +550,26 @@ Int what; {
xyzzy(nameLex, "lex");
xyzzy(nameComp, ".");
xyzzy(nameAnd, "&&");
xyzzy(nameCompAux, "primCompAux");
xyzzy(nameCompAux, "hugsprimCompAux");
xyzzy(nameMap, "map");
/* implementTagToCon */
xyzzy(nameError, "error");
xyzzy(nameError, "hugsprimError");
typeStable = linkTycon("Stable");
typeRef = linkTycon("IORef");
// {Prim,PrimByte,PrimMutable,PrimMutableByte}Array ?
ifLinkConstrItbl ( nameFalse );
ifLinkConstrItbl ( nameTrue );
ifLinkConstrItbl ( nameNil );
ifLinkConstrItbl ( nameCons );
break;
}
case PREPREL :
if (combined) {
Module modulePrelBase;
modulePrelude = findFakeModule(textPrelude);
module(modulePrelude).objectExtraNames
......@@ -603,6 +606,16 @@ Int what; {
pFun(nameInd, "_indirect");
name(nameInd).number = DFUNNAME;
/* newtype and USE_NEWTYPE_FOR_DICTS */
/* make a name entry for PrelBase.id _before_ loading Prelude
since ifSetClassDefaultsAndDCon() may need to refer to
nameId.
*/
modulePrelBase = findModule(findText("PrelBase"));
setCurrModule(modulePrelBase);
pFun(nameId, "id");
setCurrModule(modulePrelude);
} else {
modulePrelude = newModule(textPrelude);
......@@ -645,7 +658,7 @@ Int what; {
pFun(nameLex, "lex");
pFun(nameComp, ".");
pFun(nameAnd, "&&");
pFun(nameCompAux, "primCompAux");
pFun(nameCompAux, "hugsprimCompAux");
pFun(nameMap, "map");
/* implementTagToCon */
......
......@@ -12,8 +12,8 @@
* included in the distribution.
*
* $RCSfile: parser.y,v $
* $Revision: 1.21 $
* $Date: 2000/01/05 18:05:34 $
* $Revision: 1.22 $
* $Date: 2000/02/08 15:32:30 $
* ------------------------------------------------------------------------*/
%{
......@@ -380,7 +380,7 @@ ifKindedTyvar /* ((VarId,Kind)) */
| ifTyvar COCO ifAKind { $$ = gc3(zpair($1,$3)); }
;
ifKind : ifAKind { $$ = gc1($1); }
| ifAKind ARROW ifKind { $$ = gc3(fn($1,$3)); }
| ifAKind ARROW ifKind { $$ = gc3(ap($1,$3)); }
;
ifAKind : VAROP { $$ = gc1(STAR); }
/* should be '*' */
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: storage.c,v $
* $Revision: 1.40 $
* $Date: 2000/01/12 14:52:53 $
* $Revision: 1.41 $
* $Date: 2000/02/08 15:32:30 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -871,6 +871,7 @@ Tycon addWiredInEnumTycon ( String modNm, String typeNm,
Name con = newName(conT,t);
name(con).number = cfunNo(i);
name(con).type = t;
name(con).parent = t;
tycon(t).defn = cons(con, tycon(t).defn);
}
return t;
......@@ -1300,6 +1301,21 @@ List getAllKnownTyconsAndClasses ( void )
return xs;
}
/* Purely for debugging. */
void locateSymbolByName ( Text t )
{
Int i;
for (i = NAMEMIN; i < nameHw; i++)
if (name(i).text == t)
fprintf ( stderr, "name(%d)\n", i-NAMEMIN);
for (i = TYCMIN; i < tyconHw; i++)
if (tycon(i).text == t)
fprintf ( stderr, "tycon(%d)\n", i-TYCMIN);
for (i = CLASSMIN; i < classHw; i++)
if (cclass(i).text == t)
fprintf ( stderr, "class(%d)\n", i-CLASSMIN);
}
/* --------------------------------------------------------------------------
* Control stack:
*
......@@ -1496,7 +1512,9 @@ char* nameFromOPtr ( void* p )
void* lookupOTabName ( Module m, char* sym )
{
return ocLookupSym ( module(m).object, sym );
if (module(m).object)
return ocLookupSym ( module(m).object, sym );
return NULL;
}
......@@ -2411,8 +2429,7 @@ Cell c; {
Int intOf(c) /* find integer value of cell? */
Cell c; {
if (!isInt(c)) {
assert(isInt(c)); }
assert(isInt(c));
return isPair(c) ? (Int)(snd(c)) : (Int)(c-INTZERO);
}
......@@ -2906,6 +2923,132 @@ List args; {
return f;
}
/* --------------------------------------------------------------------------
* debugging support
* ------------------------------------------------------------------------*/
static String maybeModuleStr ( Module m )
{
if (isModule(m)) return textToStr(module(m).text); else return "??";
}
static String maybeNameStr ( Name n )
{
if (isName(n)) return textToStr(name(n).text); else return "??";
}
static String maybeTyconStr ( Tycon t )
{
if (isTycon(t)) return textToStr(tycon(t).text); else return "??";
}
static String maybeText ( Text t )
{
if (isNull(t)) return "(nil)";
return textToStr(t);
}
static void print100 ( Int x )
{
print ( x, 100); printf("\n");
}
void dumpTycon ( Int t )
{
if (isTycon(TYCMIN+t) && !isTycon(t)) t += TYCMIN;
if (!isTycon(t)) {
printf ( "dumpTycon %d: not a tycon\n", t);
return;
}
printf ( "{\n" );
printf ( " text: %s\n", textToStr(tycon(t).text) );
printf ( " line: %d\n", tycon(t).line );
printf ( " mod: %d %s\n", tycon(t).mod,
maybeModuleStr(tycon(t).mod));
printf ( " tuple: %d\n", tycon(t).tuple);
printf ( " arity: %d\n", tycon(t).arity);
printf ( " kind: "); print100(tycon(t).kind);
printf ( " what: %d\n", tycon(t).what);
printf ( " defn: "); print100(tycon(t).defn);
printf ( " cToT: %d %s\n", tycon(t).conToTag,
maybeNameStr(tycon(t).conToTag));
printf ( " tToC: %d %s\n", tycon(t).tagToCon,
maybeNameStr(tycon(t).tagToCon));
printf ( " itbl: %p\n", tycon(t).itbl);
printf ( " nextTH: %d %s\n", tycon(t).nextTyconHash,
maybeTyconStr(tycon(t).nextTyconHash));
printf ( "}\n" );
}
void dumpName ( Int n )
{
if (isName(NAMEMIN+n) && !isName(n)) n += NAMEMIN;
if (!isName(n)) {
printf ( "dumpName %d: not a name\n", n);
return;
}
printf ( "{\n" );
printf ( " text: %s\n", textToStr(name(n).text) );
printf ( " line: %d\n", name(n).line );
printf ( " mod: %d %s\n", name(n).mod,
maybeModuleStr(name(n).mod));
printf ( " syntax: %d\n", name(n).syntax );
printf ( " parent: %d\n", name(n).parent );
printf ( " arity: %d\n", name(n).arity );
printf ( " number: %d\n", name(n).number );
printf ( " type: "); print100(name(n).type);
printf ( " defn: %d\n", name(n).defn );
printf ( " stgVar: "); print100(name(n).stgVar);
printf ( " cconv: %d\n", name(n).callconv );
printf ( " primop: %p\n", name(n).primop );
printf ( " itbl: %p\n", name(n).itbl );
printf ( " nextNH: %d\n", name(n).nextNameHash );
printf ( "}\n" );
}
void dumpClass ( Int c )
{
if (isClass(CLASSMIN+c) && !isClass(c)) c += CLASSMIN;
if (!isClass(c)) {
printf ( "dumpClass %d: not a class\n", c);
return;
}
printf ( "{\n" );
printf ( " text: %s\n", textToStr(cclass(c).text) );
printf ( " line: %d\n", cclass(c).line );
printf ( " mod: %d %s\n", cclass(c).mod,
maybeModuleStr(cclass(c).mod));
printf ( " arity: %d\n", cclass(c).arity );
printf ( " level: %d\n", cclass(c).level );
printf ( " kinds: "); print100( cclass(c).kinds );
printf ( " fds: %d\n", cclass(c).fds );
printf ( " xfds: %d\n", cclass(c).xfds );
printf ( " head: "); print100( cclass(c).head );
printf ( " dcon: "); print100( cclass(c).dcon );
printf ( " supers: "); print100( cclass(c).supers );
printf ( " #supers: %d\n", cclass(c).numSupers );
printf ( " dsels: "); print100( cclass(c).dsels );
printf ( " members: "); print100( cclass(c).members );
printf ( "#members: %d\n", cclass(c).numMembers );
printf ( "defaults: "); print100( cclass(c).defaults );
printf ( " insts: "); print100( cclass(c).instances );
printf ( "}\n" );
}
void dumpInst ( Int i )
{
if (isInst(INSTMIN+i) && !isInst(i)) i += INSTMIN;
if (!isInst(i)) {
printf ( "dumpInst %d: not an instance\n", i);
return;
}
printf ( "{\n" );
// printf ( " text: %s\n", textToStr(cclass(c)).text) );
printf ( "}\n" );
}
/* --------------------------------------------------------------------------
* plugin support
......
......@@ -112,7 +112,7 @@ module Prelude (
-- This lot really shouldn't be exported, but are needed to
-- implement various libs.
,primCompAux,PrimArray,primRunST,primNewArray,primWriteArray
,hugsprimCompAux,PrimArray,primRunST,primNewArray,primWriteArray
,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv
,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open
,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar
......@@ -632,7 +632,7 @@ instance Ord a => Ord [a] where
compare [] (_:_) = LT
compare [] [] = EQ
compare (_:_) [] = GT
compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys)
instance Functor [] where
fmap = map
......@@ -1545,8 +1545,8 @@ readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
-- Hooks for primitives: -----------------------------------------------------
-- Do not mess with these!
primCompAux :: Ord a => a -> a -> Ordering -> Ordering
primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering
hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
hugsprimEqChar :: Char -> Char -> Bool
hugsprimEqChar c1 c2 = primEqChar c1 c2
......
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