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/04/12 09:37:19 $
14 * ------------------------------------------------------------------------*/
16 #include "hugsbasictypes.h"
21 #include "Assembler.h"
22 #include "Rts.h" /* IF_DEBUG */
25 /*#define DEBUG_CODEGEN*/
27 /* --------------------------------------------------------------------------
28 * Local function prototypes:
29 * ------------------------------------------------------------------------*/
31 #define getPos(v) intOf(stgVarInfo(v))
32 #define setPos(v,sp) stgVarInfo(v) = mkInt(sp)
33 #define getObj(v) ptrOf(stgVarInfo(v))
34 #define setObj(v,obj) stgVarInfo(v) = mkPtr(obj)
36 #define repOf(x) charOf(stgVarRep(x))
38 static void cgBind ( AsmBCO bco, StgVar v );
39 static Void pushVar ( AsmBCO bco, StgVar v );
40 static Void pushAtom ( AsmBCO bco, StgAtom atom );
41 static Void alloc ( AsmBCO bco, StgRhs rhs );
42 static Void build ( AsmBCO bco, StgRhs rhs );
43 static Void cgExpr ( AsmBCO bco, AsmSp root, StgExpr e );
45 static AsmBCO cgAlts ( AsmSp root, AsmSp sp, List alts );
46 static void testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
47 static AsmBCO cgLambda ( StgExpr e );
48 static AsmBCO cgRhs ( StgRhs rhs );
49 static void beginTop ( StgVar v );
50 static void endTop ( StgVar v );
52 static StgVar currentTop;
54 /* --------------------------------------------------------------------------
56 * ------------------------------------------------------------------------*/
58 static Cell cptrFromName ( Name n )
62 Module m = name(n).mod;
63 Text mt = module(m).text;
64 sprintf(buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_closure"),
66 textToStr( enZcodeThenFindText (
67 textToStr (name(n).text) ) ) );
68 p = lookupOTabName ( m, buf );
70 ERRMSG(0) "Can't find object symbol %s", buf
76 static Bool varHasClosure( StgVar v )
78 return asmObjectHasClosure((AsmClosure*)ptrOf(stgVarInfo(v)));
81 /* should be AsmClosure* */
82 void* closureOfVar( StgVar v )
84 return asmClosureOfObject((AsmClosure*)ptrOf(stgVarInfo(v)));
87 char* lookupHugsName( void* closure )
91 for( nm = NAME_BASE_ADDR;
92 nm < NAME_BASE_ADDR+tabNameSz; ++nm )
93 if (tabName[nm-NAME_BASE_ADDR].inUse) {
94 StgVar v = name(nm).stgVar;
96 && isPtr(stgVarInfo(v))
98 && closureOfVar(v) == closure) {
99 return textToStr(name(nm).text);
105 static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
107 setPos(v,asmBind(bco,rep));
110 static void cgBind( AsmBCO bco, StgVar v )
112 cgBindRep(bco,v,repOf(v));
115 static Void pushVar( AsmBCO bco, StgVar v )
119 printf ( "pushVar: %d ", v ); fflush(stdout);
120 print(v,10);printf("\n");
122 assert(isStgVar(v) || isCPtr(v));
125 asmGHCClosure(bco, cptrOf(v));
127 info = stgVarInfo(v);
129 asmClosure(bco,ptrOf(info));
130 } else if (isInt(info)) {
131 asmVar(bco,intOf(info),repOf(v));
138 static Void pushAtom( AsmBCO bco, StgAtom e )
141 printf ( "pushAtom: %d ", e ); fflush(stdout);
142 print(e,10);printf("\n");
149 if (nonNull(name(e).stgVar)) {
150 pushVar(bco,name(e).stgVar);
152 Cell /*CPtr*/ addr = cptrFromName(e);
154 fprintf ( stderr, "nativeAtom: name %s\n",
155 nameFromOPtr(cptrOf(addr)) );
161 asmConstChar(bco,charOf(e));
164 asmConstInt(bco,intOf(e));
167 asmConstInteger(bco,bignumToString(e));
170 asmConstDouble(bco,floatOf(e));
173 #if USE_ADDR_FOR_STRINGS
174 asmConstAddr(bco,textToStr(textOf(e)));
176 asmClosure(bco,asmStringObj(textToStr(textOf(e))));
180 asmGHCClosure(bco,cptrOf(e));
183 asmConstAddr(bco,ptrOf(e));
186 fprintf(stderr,"\nYoiks1: "); printExp(stderr,e);
187 internal("pushAtom");
191 static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
193 #ifdef CRUDE_PROFILING
194 AsmBCO bco = asmBeginContinuation(sp, currentTop + 1000000000);
196 AsmBCO bco = asmBeginContinuation(sp, alts);
199 = length(alts) == 2 &&
200 isDefaultAlt(hd(tl(alts))) &&
201 !isDefaultAlt(hd(alts));
203 /* refine the condition */
207 con = stgCaseAltCon(hd(alts));
209 /* special case: dictionary constructors */
210 if (isName(con) && strncmp(":D",textToStr(name(con).text),2)==0) {
214 /* special case: Tuples */
215 if (isTuple(con) || (isName(con) && con==nameUnit)) {
220 t = name(con).parent;
221 if (tycon(t).what == DATATYPE) {
222 if (length(tycon(t).defn) == 1) omit_test = TRUE;
228 for(; nonNull(alts); alts=tl(alts)) {
229 StgCaseAlt alt = hd(alts);
230 if (isDefaultAlt(alt)) {
231 cgBind(bco,stgDefaultVar(alt));
232 cgExpr(bco,root,stgDefaultBody(alt));
233 asmEndContinuation(bco);
234 return bco; /* ignore any further alternatives */
236 StgDiscr con = stgCaseAltCon(alt);
237 List vs = stgCaseAltVars(alt);
238 AsmSp begin = asmBeginAlt(bco);
240 if (omit_test) fix=-1; else fix = asmTest(bco,stgDiscrTag(con));
242 asmBind(bco,PTR_REP); /* Adjust simulated sp to acct for return value */
243 if (isBoxingCon(con)) {
244 setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
247 map1Proc(cgBind,bco,reverse(vs));
250 cgExpr(bco,root,stgCaseAltBody(alt));
251 asmEndAlt(bco,begin);
252 if (fix != -1) asmFixBranch(bco,fix);
255 /* if we got this far and didn't match, panic! */
257 asmEndContinuation(bco);
261 static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
266 StgVar pat = hd(pats);
267 if (isInt(stgVarBody(pat))) {
268 /* asmTestInt leaves stack unchanged - so no need to adjust it */
269 AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
270 assert(repOf(pat) == INT_REP);
271 testPrimPats(bco,root,tl(pats),e);
272 asmFixBranch(bco,tst);
274 testPrimPats(bco,root,tl(pats),e);
280 static AsmBCO cgLambda( StgExpr e )
282 AsmBCO bco = asmBeginBCO(e);
284 AsmSp root = asmBeginArgCheck(bco);
285 map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
286 asmEndArgCheck(bco,root);
289 cgExpr(bco,root,stgLambdaBody(e));
295 static AsmBCO cgRhs( StgRhs rhs )
297 AsmBCO bco = asmBeginBCO(rhs );
299 AsmSp root = asmBeginArgCheck(bco);
300 asmEndArgCheck(bco,root);
302 /* ppStgExpr(rhs); */
303 cgExpr(bco,root,rhs);
310 static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
313 printf("cgExpr:");ppStgExpr(e);printf("\n");
318 List binds = stgLetBinds(e);
319 map1Proc(alloc,bco,binds);
320 map1Proc(build,bco,binds);
321 cgExpr(bco,root,stgLetBody(e));
326 AsmSp begin = asmBeginEnter(bco);
327 asmClosure(bco,cgLambda(e));
328 asmEndEnter(bco,begin,root);
333 List alts = stgCaseAlts(e);
334 AsmSp sp = asmBeginCase(bco);
335 AsmSp caseroot = asmContinuation(bco,cgAlts(root,sp,alts));
336 cgExpr(bco,caseroot,stgCaseScrut(e));
342 StgExpr scrut = stgPrimCaseScrut(e);
343 List alts = stgPrimCaseAlts(e);
344 if (whatIs(scrut) == STGPRIM) { /* this is an optimisation */
346 /* No need to use return address or to Slide */
347 AsmSp beginPrim = asmBeginPrim(bco);
348 map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
349 asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
351 for(; nonNull(alts); alts=tl(alts)) {
352 StgPrimAlt alt = hd(alts);
353 List pats = stgPrimAltVars(alt);
354 StgExpr body = stgPrimAltBody(alt);
355 AsmSp altBegin = asmBeginAlt(bco);
356 map1Proc(cgBind,bco,reverse(pats));
357 testPrimPats(bco,root,pats,body);
358 asmEndAlt(bco,altBegin);
360 /* if we got this far and didn't match, panic! */
363 } else if (whatIs(scrut) == STGVAR) { /* another optimisation */
365 /* No need to use return address or to Slide */
367 /* only part different from primop code... todo */
368 AsmSp beginCase = asmBeginCase(bco);
370 asmEndAlt(bco,beginCase); /* hack, hack - */
372 for(; nonNull(alts); alts=tl(alts)) {
373 StgPrimAlt alt = hd(alts);
374 List pats = stgPrimAltVars(alt);
375 StgExpr body = stgPrimAltBody(alt);
376 AsmSp altBegin = asmBeginAlt(bco);
377 map1Proc(cgBind,bco,pats);
378 testPrimPats(bco,root,pats,body);
379 asmEndAlt(bco,altBegin);
381 /* if we got this far and didn't match, panic! */
385 /* ToDo: implement this code... */
387 /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e),
388 stgPrimCaseBody(e))); */
389 /* cgExpr( bco,root,scrut ); */
393 case STGAPP: /* Tail call */
395 AsmSp env = asmBeginEnter(bco);
396 map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
397 pushAtom(bco,stgAppFun(e));
398 asmEndEnter(bco,env,root);
401 case NAME: /* Tail call (with no args) */
403 AsmSp env = asmBeginEnter(bco);
404 /* JRS 000112: next line used to be: pushVar(bco,name(e).stgVar); */
406 asmEndEnter(bco,env,root);
409 case STGVAR: /* Tail call (with no args), plus unboxed return */
415 AsmSp env = asmBeginEnter(bco);
417 asmEndEnter(bco,env,root);
422 /* cgTailCall(bco,singleton(e)); */
423 /* asmReturnInt(bco); */
426 internal("cgExpr StgVar");
429 case STGPRIM: /* Tail call again */
431 AsmSp beginPrim = asmBeginPrim(bco);
432 map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
433 asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
434 /* map1Proc(cgBind,bco,rs_vars); */
435 assert(0); /* asmReturn_retty(); */
439 fprintf(stderr,"\nYoiks2: "); printExp(stderr,e);
444 /* allocate space for top level variable
445 * any change requires a corresponding change in 'build'.
447 static Void alloc( AsmBCO bco, StgVar v )
449 StgRhs rhs = stgVarBody(v);
452 printf("alloc: ");ppStgExpr(v);
454 switch (whatIs(rhs)) {
457 StgDiscr con = stgConCon(rhs);
458 List args = stgConArgs(rhs);
459 if (isBoxingCon(con)) {
460 pushAtom(bco,hd(args));
461 setPos(v,asmBox(bco,boxingConRep(con)));
463 setPos(v,asmAllocCONSTR(bco,stgConInfo(con)));
469 List bs = stgAppArgs(rhs);
470 for (; nonNull(bs); bs=tl(bs)) {
471 if (isName(hd(bs))) {
474 ASSERT(whatIs(hd(bs))==STGVAR);
475 totSizeW += asmRepSizeW( charOf(stgVarRep(hd(bs))) );
478 setPos(v,asmAllocAP(bco,totSizeW));
481 case LAMBDA: /* optimisation */
482 setObj(v,cgLambda(rhs));
485 setPos(v,asmAllocAP(bco,0));
490 static Void build( AsmBCO bco, StgVar v )
492 StgRhs rhs = stgVarBody(v);
495 switch (whatIs(rhs)) {
498 StgDiscr con = stgConCon(rhs);
499 List args = stgConArgs(rhs);
500 if (isBoxingCon(con)) {
501 doNothing(); /* already done in alloc */
503 AsmSp start = asmBeginPack(bco);
504 map1Proc(pushAtom,bco,reverse(args));
505 asmEndPack(bco,getPos(v),start,stgConInfo(con));
512 StgVar fun = stgAppFun(rhs);
514 List args = stgAppArgs(rhs);
516 if (nonNull(name(fun).stgVar))
517 fun = name(fun).stgVar; else
518 fun = cptrFromName(fun);
522 assert(isName(fun0));
523 itsaPAP = name(fun0).arity > length(args);
525 fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n",
526 nameFromOPtr(cptrOf(fun)), name(fun0).arity,
531 if (nonNull(stgVarBody(fun))
532 && whatIs(stgVarBody(fun)) == LAMBDA
533 && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
539 AsmSp start = asmBeginMkPAP(bco);
540 map1Proc(pushAtom,bco,reverse(args));
542 asmEndMkPAP(bco,getPos(v),start); /* optimisation */
544 AsmSp start = asmBeginMkAP(bco);
545 map1Proc(pushAtom,bco,reverse(args));
547 asmEndMkAP(bco,getPos(v),start);
551 case LAMBDA: /* optimisation */
552 doNothing(); /* already pushed in alloc */
555 /* These two cases look almost identical to the default but they're really
556 * special cases of STGAPP. The essential thing here is that we can't call
557 * cgRhs(rhs) because that expects the rhs to have no free variables when,
558 * in fact, the rhs is _always_ a free variable.
560 * ToDo: a simple optimiser would eliminate all examples
561 * of this except "let x = x in ..."
564 if (nonNull(name(rhs).stgVar))
565 rhs = name(rhs).stgVar; else
566 rhs = cptrFromName(rhs);
570 AsmSp start = asmBeginMkAP(bco);
572 asmEndMkAP(bco,getPos(v),start);
577 AsmSp start = asmBeginMkAP(bco); /* make it updateable! */
578 asmClosure(bco,cgRhs(rhs));
579 asmEndMkAP(bco,getPos(v),start);
585 /* --------------------------------------------------------------------------
586 * Top level variables
588 * ToDo: these should be handled by allocating a dynamic unentered CAF
589 * for each top level variable - this should be simpler!
590 * ------------------------------------------------------------------------*/
592 #if 0 /* appears to be unused */
593 static void cgAddVar( AsmObject obj, StgAtom v )
599 asmAddPtr(obj,getObj(v));
604 /* allocate AsmObject for top level variables
605 * any change requires a corresponding change in endTop
607 static void beginTop( StgVar v )
613 switch (whatIs(rhs)) {
616 //List as = stgConArgs(rhs);
617 setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
621 #ifdef CRUDE_PROFILING
622 setObj(v,asmBeginBCO(currentTop));
624 setObj(v,asmBeginBCO(rhs));
628 setObj(v,asmBeginCAF());
633 static void endTop( StgVar v )
635 StgRhs rhs = stgVarBody(v);
637 switch (whatIs(rhs)) {
640 List as = stgConArgs(rhs);
641 AsmCon con = (AsmCon)getObj(v);
642 for( ; nonNull(as); as=tl(as)) {
646 /* should be a delayed combinator! */
647 asmAddPtr(con,(AsmObject)getObj(a));
651 StgVar var = name(a).stgVar;
653 asmAddPtr(con,(AsmObject)getObj(a));
656 #if !USE_ADDR_FOR_STRINGS
658 asmAddPtr(con,asmStringObj(textToStr(textOf(a))));
662 /* asmAddPtr(con,??); */
670 case LAMBDA: /* optimisation */
672 /* ToDo: merge this code with cgLambda */
673 AsmBCO bco = (AsmBCO)getObj(v);
674 AsmSp root = asmBeginArgCheck(bco);
675 map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
676 asmEndArgCheck(bco,root);
678 cgExpr(bco,root,stgLambdaBody(rhs));
683 default: /* updateable caf */
685 AsmCAF caf = (AsmCAF)getObj(v);
686 asmEndCAF(caf,cgRhs(rhs));
692 static void zap( StgVar v )
695 // stgVarBody(v) = NIL;
698 /* external entry point */
699 Void cgBinds( List binds )
705 if (lastModule() != modulePrelude) {
706 printf("\n\ncgBinds: before ll\n\n" );
707 for (b=binds; nonNull(b); b=tl(b)) {
708 printStg ( stdout, hd(b) ); printf("\n\n");
713 binds = liftBinds(binds);
716 if (lastModule() != modulePrelude) {
717 printf("\n\ncgBinds: after ll\n\n" );
718 for (b=binds; nonNull(b); b=tl(b)) {
719 printStg ( stdout, hd(b) ); printf("\n\n");
724 for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
725 /* printStg( stdout, hd(b) ); printf( "\n\n"); */
729 for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
730 /* printStg( stdout, hd(b) ); printf( "\n\n"); */
734 /* mapProc(zap,binds); */
737 /* Called by the evaluator's GC to tell Hugs to mark stuff in the
740 void markHugsObjects( void )
744 for ( nm = NAME_BASE_ADDR;
745 nm < NAME_BASE_ADDR+tabNameSz; ++nm )
746 if (tabName[nm-NAME_BASE_ADDR].inUse) {
747 StgVar v = name(nm).stgVar;
748 if (isStgVar(v) && isPtr(stgVarInfo(v))) {
749 asmMarkObject(ptrOf(stgVarInfo(v)));
754 /* --------------------------------------------------------------------------
755 * Code Generator control:
756 * ------------------------------------------------------------------------*/
770 /*-------------------------------------------------------------------------*/