2 /* --------------------------------------------------------------------------
5 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
6 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
7 * Technology, 1994-1999, All rights reserved. It is distributed as
8 * free software under the license in the file "License", which is
9 * included in the distribution.
11 * $RCSfile: codegen.c,v $
13 * $Date: 2000/03/07 16:18:25 $
14 * ------------------------------------------------------------------------*/
21 #include "Assembler.h"
24 #include "Rts.h" /* IF_DEBUG */
27 /*#define DEBUG_CODEGEN*/
29 /* --------------------------------------------------------------------------
30 * Local function prototypes:
31 * ------------------------------------------------------------------------*/
33 #define getPos(v) intOf(stgVarInfo(v))
34 #define setPos(v,sp) stgVarInfo(v) = mkInt(sp)
35 #define getObj(v) ptrOf(stgVarInfo(v))
36 #define setObj(v,obj) stgVarInfo(v) = mkPtr(obj)
38 #define repOf(x) charOf(stgVarRep(x))
40 static void cgBind ( AsmBCO bco, StgVar v );
41 static Void pushVar ( AsmBCO bco, StgVar v );
42 static Void pushAtom ( AsmBCO bco, StgAtom atom );
43 static Void alloc ( AsmBCO bco, StgRhs rhs );
44 static Void build ( AsmBCO bco, StgRhs rhs );
45 static Void cgExpr ( AsmBCO bco, AsmSp root, StgExpr e );
47 static AsmBCO cgAlts ( AsmSp root, AsmSp sp, List alts );
48 static void testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
49 static AsmBCO cgLambda ( StgExpr e );
50 static AsmBCO cgRhs ( StgRhs rhs );
51 static void beginTop ( StgVar v );
52 static void endTop ( StgVar v );
54 static StgVar currentTop;
56 /* --------------------------------------------------------------------------
58 * ------------------------------------------------------------------------*/
60 static Cell cptrFromName ( Name n )
64 Module m = name(n).mod;
65 Text mt = module(m).text;
66 sprintf(buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_closure"),
68 textToStr( enZcodeThenFindText (
69 textToStr (name(n).text) ) ) );
70 p = lookupOTabName ( m, buf );
72 ERRMSG(0) "Can't find object symbol %s", buf
78 static Bool varHasClosure( StgVar v )
80 return asmObjectHasClosure((AsmClosure*)ptrOf(stgVarInfo(v)));
83 /* should be AsmClosure* */
84 void* closureOfVar( StgVar v )
86 return asmClosureOfObject((AsmClosure*)ptrOf(stgVarInfo(v)));
89 char* lookupHugsName( void* closure )
93 for( nm=NAMEMIN; nm<nameHw; ++nm ) {
94 StgVar v = name(nm).stgVar;
96 && isPtr(stgVarInfo(v))
98 && closureOfVar(v) == closure) {
99 return textToStr(name(nm).text);
105 /* called at the start of GC */
106 void markHugsObjects( void )
110 for( nm=NAMEMIN; nm<nameHw; ++nm ) {
111 StgVar v = name(nm).stgVar;
112 if (isStgVar(v) && isPtr(stgVarInfo(v))) {
113 asmMarkObject((AsmClosure*)ptrOf(stgVarInfo(v)));
118 static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
120 setPos(v,asmBind(bco,rep));
123 static void cgBind( AsmBCO bco, StgVar v )
125 cgBindRep(bco,v,repOf(v));
128 static Void pushVar( AsmBCO bco, StgVar v )
132 printf ( "pushVar: %d ", v ); fflush(stdout);
133 print(v,10);printf("\n");
135 assert(isStgVar(v) || isCPtr(v));
138 asmGHCClosure(bco, cptrOf(v));
140 info = stgVarInfo(v);
142 asmClosure(bco,ptrOf(info));
143 } else if (isInt(info)) {
144 asmVar(bco,intOf(info),repOf(v));
151 static Void pushAtom( AsmBCO bco, StgAtom e )
154 printf ( "pushAtom: %d ", e ); fflush(stdout);
155 print(e,10);printf("\n");
162 if (nonNull(name(e).stgVar)) {
163 pushVar(bco,name(e).stgVar);
165 Cell /*CPtr*/ addr = cptrFromName(e);
166 # ifdef DEBUG_CODEGEN
167 fprintf ( stderr, "nativeAtom: name %s\n",
168 nameFromOPtr(cptrOf(addr)) );
174 asmConstChar(bco,charOf(e));
177 asmConstInt(bco,intOf(e));
180 asmConstInteger(bco,bignumToString(e));
183 asmConstDouble(bco,floatOf(e));
186 #if USE_ADDR_FOR_STRINGS
187 asmConstAddr(bco,textToStr(textOf(e)));
189 asmClosure(bco,asmStringObj(textToStr(textOf(e))));
193 asmGHCClosure(bco,cptrOf(e));
196 asmConstAddr(bco,ptrOf(e));
199 fprintf(stderr,"\nYoiks1: "); printExp(stderr,e);
200 internal("pushAtom");
204 static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
206 #ifdef CRUDE_PROFILING
207 AsmBCO bco = asmBeginContinuation(sp, currentTop + 1000000000);
209 AsmBCO bco = asmBeginContinuation(sp, alts);
212 = length(alts) == 2 &&
213 isDefaultAlt(hd(tl(alts))) &&
214 !isDefaultAlt(hd(alts));
216 /* refine the condition */
220 con = stgCaseAltCon(hd(alts));
222 /* special case: dictionary constructors */
223 if (strncmp(":D",textToStr(name(con).text),2)==0) {
227 /* special case: Tuples */
228 if (isTuple(con) || (isName(con) && con==nameUnit)) {
233 t = name(con).parent;
234 if (tycon(t).what == DATATYPE) {
235 if (length(tycon(t).defn) == 1) omit_test = TRUE;
241 for(; nonNull(alts); alts=tl(alts)) {
242 StgCaseAlt alt = hd(alts);
243 if (isDefaultAlt(alt)) {
244 cgBind(bco,stgDefaultVar(alt));
245 cgExpr(bco,root,stgDefaultBody(alt));
246 asmEndContinuation(bco);
247 return bco; /* ignore any further alternatives */
249 StgDiscr con = stgCaseAltCon(alt);
250 List vs = stgCaseAltVars(alt);
251 AsmSp begin = asmBeginAlt(bco);
253 if (omit_test) fix=-1; else fix = asmTest(bco,stgDiscrTag(con));
255 asmBind(bco,PTR_REP); /* Adjust simulated sp to acct for return value */
256 if (isBoxingCon(con)) {
257 setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
260 map1Proc(cgBind,bco,reverse(vs));
263 cgExpr(bco,root,stgCaseAltBody(alt));
264 asmEndAlt(bco,begin);
265 if (fix != -1) asmFixBranch(bco,fix);
268 /* if we got this far and didn't match, panic! */
270 asmEndContinuation(bco);
274 static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
279 StgVar pat = hd(pats);
280 if (isInt(stgVarBody(pat))) {
281 /* asmTestInt leaves stack unchanged - so no need to adjust it */
282 AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
283 assert(repOf(pat) == INT_REP);
284 testPrimPats(bco,root,tl(pats),e);
285 asmFixBranch(bco,tst);
287 testPrimPats(bco,root,tl(pats),e);
293 static AsmBCO cgLambda( StgExpr e )
295 AsmBCO bco = asmBeginBCO(e);
297 AsmSp root = asmBeginArgCheck(bco);
298 map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
299 asmEndArgCheck(bco,root);
302 cgExpr(bco,root,stgLambdaBody(e));
308 static AsmBCO cgRhs( StgRhs rhs )
310 AsmBCO bco = asmBeginBCO(rhs );
312 AsmSp root = asmBeginArgCheck(bco);
313 asmEndArgCheck(bco,root);
315 /* ppStgExpr(rhs); */
316 cgExpr(bco,root,rhs);
323 static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
326 printf("cgExpr:");ppStgExpr(e);printf("\n");
331 List binds = stgLetBinds(e);
332 map1Proc(alloc,bco,binds);
333 map1Proc(build,bco,binds);
334 cgExpr(bco,root,stgLetBody(e));
339 AsmSp begin = asmBeginEnter(bco);
340 asmClosure(bco,cgLambda(e));
341 asmEndEnter(bco,begin,root);
346 List alts = stgCaseAlts(e);
347 AsmSp sp = asmBeginCase(bco);
348 AsmSp caseroot = asmContinuation(bco,cgAlts(root,sp,alts));
349 cgExpr(bco,caseroot,stgCaseScrut(e));
355 StgExpr scrut = stgPrimCaseScrut(e);
356 List alts = stgPrimCaseAlts(e);
357 if (whatIs(scrut) == STGPRIM) { /* this is an optimisation */
359 /* No need to use return address or to Slide */
360 AsmSp beginPrim = asmBeginPrim(bco);
361 map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
362 asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
364 for(; nonNull(alts); alts=tl(alts)) {
365 StgPrimAlt alt = hd(alts);
366 List pats = stgPrimAltVars(alt);
367 StgExpr body = stgPrimAltBody(alt);
368 AsmSp altBegin = asmBeginAlt(bco);
369 map1Proc(cgBind,bco,reverse(pats));
370 testPrimPats(bco,root,pats,body);
371 asmEndAlt(bco,altBegin);
373 /* if we got this far and didn't match, panic! */
376 } else if (whatIs(scrut) == STGVAR) { /* another optimisation */
378 /* No need to use return address or to Slide */
380 /* only part different from primop code... todo */
381 AsmSp beginCase = asmBeginCase(bco);
383 asmEndAlt(bco,beginCase); /* hack, hack - */
385 for(; nonNull(alts); alts=tl(alts)) {
386 StgPrimAlt alt = hd(alts);
387 List pats = stgPrimAltVars(alt);
388 StgExpr body = stgPrimAltBody(alt);
389 AsmSp altBegin = asmBeginAlt(bco);
390 map1Proc(cgBind,bco,pats);
391 testPrimPats(bco,root,pats,body);
392 asmEndAlt(bco,altBegin);
394 /* if we got this far and didn't match, panic! */
398 /* ToDo: implement this code... */
400 /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e),
401 stgPrimCaseBody(e))); */
402 /* cgExpr( bco,root,scrut ); */
406 case STGAPP: /* Tail call */
408 AsmSp env = asmBeginEnter(bco);
409 map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
410 pushAtom(bco,stgAppFun(e));
411 asmEndEnter(bco,env,root);
414 case NAME: /* Tail call (with no args) */
416 AsmSp env = asmBeginEnter(bco);
417 /* JRS 000112: next line used to be: pushVar(bco,name(e).stgVar); */
419 asmEndEnter(bco,env,root);
422 case STGVAR: /* Tail call (with no args), plus unboxed return */
428 AsmSp env = asmBeginEnter(bco);
430 asmEndEnter(bco,env,root);
435 /* cgTailCall(bco,singleton(e)); */
436 /* asmReturnInt(bco); */
439 internal("cgExpr StgVar");
442 case STGPRIM: /* Tail call again */
444 AsmSp beginPrim = asmBeginPrim(bco);
445 map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
446 asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
447 /* map1Proc(cgBind,bco,rs_vars); */
448 assert(0); /* asmReturn_retty(); */
452 fprintf(stderr,"\nYoiks2: "); printExp(stderr,e);
457 #define M_ITBLNAMES 35000
459 void* itblNames[M_ITBLNAMES];
462 /* allocate space for top level variable
463 * any change requires a corresponding change in 'build'.
465 static Void alloc( AsmBCO bco, StgVar v )
467 StgRhs rhs = stgVarBody(v);
470 printf("alloc: ");ppStgExpr(v);
472 switch (whatIs(rhs)) {
475 StgDiscr con = stgConCon(rhs);
476 List args = stgConArgs(rhs);
477 if (isBoxingCon(con)) {
478 pushAtom(bco,hd(args));
479 setPos(v,asmBox(bco,boxingConRep(con)));
482 void* vv = stgConInfo(con);
483 if (!(nItblNames < (M_ITBLNAMES-2)))
484 internal("alloc -- M_ITBLNAMES too small");
486 itblNames[nItblNames++] = vv;
487 itblNames[nItblNames++] = textToStr(name(con).text);
490 itblNames[nItblNames++] = vv;
491 itblNames[nItblNames++] = textToStr(ghcTupleText(con));
493 assert ( /* cant identify constructor name */ 0 );
494 setPos(v,asmAllocCONSTR(bco, vv));
500 List bs = stgAppArgs(rhs);
501 for (; nonNull(bs); bs=tl(bs)) {
502 if (isName(hd(bs))) {
505 ASSERT(whatIs(hd(bs))==STGVAR);
506 totSizeW += asmRepSizeW( charOf(stgVarRep(hd(bs))) );
509 setPos(v,asmAllocAP(bco,totSizeW));
510 //ORIGINALLY:setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs))));
513 case LAMBDA: /* optimisation */
514 setObj(v,cgLambda(rhs));
517 setPos(v,asmAllocAP(bco,0));
522 static Void build( AsmBCO bco, StgVar v )
524 StgRhs rhs = stgVarBody(v);
527 switch (whatIs(rhs)) {
530 StgDiscr con = stgConCon(rhs);
531 List args = stgConArgs(rhs);
532 if (isBoxingCon(con)) {
533 doNothing(); /* already done in alloc */
535 AsmSp start = asmBeginPack(bco);
536 map1Proc(pushAtom,bco,reverse(args));
537 asmEndPack(bco,getPos(v),start,stgConInfo(con));
544 StgVar fun = stgAppFun(rhs);
546 List args = stgAppArgs(rhs);
548 if (nonNull(name(fun).stgVar))
549 fun = name(fun).stgVar; else
550 fun = cptrFromName(fun);
554 assert(isName(fun0));
555 itsaPAP = name(fun0).arity > length(args);
556 # ifdef DEBUG_CODEGEN
557 fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n",
558 nameFromOPtr(cptrOf(fun)), name(fun0).arity,
563 if (nonNull(stgVarBody(fun))
564 && whatIs(stgVarBody(fun)) == LAMBDA
565 && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
571 AsmSp start = asmBeginMkPAP(bco);
572 map1Proc(pushAtom,bco,reverse(args));
574 asmEndMkPAP(bco,getPos(v),start); /* optimisation */
576 AsmSp start = asmBeginMkAP(bco);
577 map1Proc(pushAtom,bco,reverse(args));
579 asmEndMkAP(bco,getPos(v),start);
583 case LAMBDA: /* optimisation */
584 doNothing(); /* already pushed in alloc */
587 /* These two cases look almost identical to the default but they're really
588 * special cases of STGAPP. The essential thing here is that we can't call
589 * cgRhs(rhs) because that expects the rhs to have no free variables when,
590 * in fact, the rhs is _always_ a free variable.
592 * ToDo: a simple optimiser would eliminate all examples
593 * of this except "let x = x in ..."
596 if (nonNull(name(rhs).stgVar))
597 rhs = name(rhs).stgVar; else
598 rhs = cptrFromName(rhs);
602 AsmSp start = asmBeginMkAP(bco);
604 asmEndMkAP(bco,getPos(v),start);
609 AsmSp start = asmBeginMkAP(bco); /* make it updateable! */
610 asmClosure(bco,cgRhs(rhs));
611 asmEndMkAP(bco,getPos(v),start);
617 /* --------------------------------------------------------------------------
618 * Top level variables
620 * ToDo: these should be handled by allocating a dynamic unentered CAF
621 * for each top level variable - this should be simpler!
622 * ------------------------------------------------------------------------*/
624 #if 0 /* appears to be unused */
625 static void cgAddVar( AsmObject obj, StgAtom v )
631 asmAddPtr(obj,getObj(v));
636 /* allocate AsmObject for top level variables
637 * any change requires a corresponding change in endTop
639 static void beginTop( StgVar v )
645 switch (whatIs(rhs)) {
648 //List as = stgConArgs(rhs);
649 setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
653 #ifdef CRUDE_PROFILING
654 setObj(v,asmBeginBCO(currentTop));
656 setObj(v,asmBeginBCO(rhs));
660 setObj(v,asmBeginCAF());
665 static void endTop( StgVar v )
667 StgRhs rhs = stgVarBody(v);
669 switch (whatIs(rhs)) {
672 List as = stgConArgs(rhs);
673 AsmCon con = (AsmCon)getObj(v);
674 for( ; nonNull(as); as=tl(as)) {
678 /* should be a delayed combinator! */
679 asmAddPtr(con,(AsmObject)getObj(a));
683 StgVar var = name(a).stgVar;
685 asmAddPtr(con,(AsmObject)getObj(a));
688 #if !USE_ADDR_FOR_STRINGS
690 asmAddPtr(con,asmStringObj(textToStr(textOf(a))));
694 /* asmAddPtr(con,??); */
702 case LAMBDA: /* optimisation */
704 /* ToDo: merge this code with cgLambda */
705 AsmBCO bco = (AsmBCO)getObj(v);
706 AsmSp root = asmBeginArgCheck(bco);
707 map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
708 asmEndArgCheck(bco,root);
710 cgExpr(bco,root,stgLambdaBody(rhs));
715 default: /* updateable caf */
717 AsmCAF caf = (AsmCAF)getObj(v);
718 asmEndCAF(caf,cgRhs(rhs));
724 static void zap( StgVar v )
727 // stgVarBody(v) = NIL;
730 /* external entry point */
731 Void cgBinds( List binds )
737 if (lastModule() != modulePrelude) {
738 printf("\n\ncgBinds: before ll\n\n" );
739 for (b=binds; nonNull(b); b=tl(b)) {
740 printStg ( stdout, hd(b) ); printf("\n\n");
745 binds = liftBinds(binds);
748 if (lastModule() != modulePrelude) {
749 printf("\n\ncgBinds: after ll\n\n" );
750 for (b=binds; nonNull(b); b=tl(b)) {
751 printStg ( stdout, hd(b) ); printf("\n\n");
756 for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
760 for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
761 //printStg( stdout, hd(b) ); printf( "\n\n");
765 //mapProc(zap,binds);
768 /* --------------------------------------------------------------------------
769 * Code Generator control:
770 * ------------------------------------------------------------------------*/
784 /*-------------------------------------------------------------------------*/