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/05/10 16:53:35 $
14 * ------------------------------------------------------------------------*/
16 #include "hugsbasictypes.h"
21 #include "Rts.h" /* to make StgPtr visible in Assembler.h */
22 #include "Assembler.h"
25 /*#define DEBUG_CODEGEN*/
27 /* (JRS, 27 Apr 2000):
29 A total rewrite of the BCO assembler/linker, and rationalisation of
30 the code management and code generation phases of Hugs.
32 Problems with the old linker:
34 * Didn't have a clean way to insert a pointer to GHC code into a BCO.
35 This meant CAF GC didn't work properly in combined mode.
37 * Leaked memory. Each BCO, caf and constructor generated by Hugs had
38 a corresponding malloc'd record used in its construction. These
39 records existed forever. Pointers from the Hugs symbol tables into
40 the runtime heap always went via these intermediates, for no apparent
43 * A global variable holding a list of top-level stg trees was used
44 during code generation. It was hard to associate trees in this
45 list with entries in the name/tycon tables. Just too many
48 The New World Order is as follows:
50 * The global code list (stgGlobals) is gone.
52 * Each name in the name table has a .closure field. This points
53 to the top-level code for that name. Before bytecode generation
54 this points to a STG tree. During bytecode generation but before
55 bytecode linking it is a MPtr pointing to a malloc'd intermediate
56 structure (an AsmObject). After linking, it is a real live pointer
57 into the execution heap (CPtr) which is treated as a root during GC.
59 Because tuples do not have name table entries, tycons which are
60 tuples also have a .closure field, which is treated identically
61 to those of name table entries.
63 * Each module has a code list -- a list of names and tuples. If you
64 are a name or tuple and you have something (code, CAF or Con) which
65 needs to wind up in the execution heap, you MUST be on your module's
66 code list. Otherwise you won't get code generated.
68 * Lambda lifting generates new name table entries, which of course
69 also wind up on the code list.
71 * The initial phase of code generation for a module m traverses m's
72 code list. The stg trees referenced in the .closure fields are
73 code generated, creating AsmObject (AsmBCO, AsmCAF, AsmCon) in
74 mallocville. The .closure fields then point to these AsmObjects.
75 Since AsmObjects can be mutually recursive, they can contain
77 * Other AsmObjects Asm_RefObject
78 * Existing closures Asm_RefNoOp
79 * name/tycon table entries Asm_RefHugs
80 AsmObjects can also contain BCO insns and non-ptr words.
82 * A second copy-and-link phase copies the AsmObjects into the
83 execution heap, resolves the Asm_Ref* items, and frees up
84 the malloc'd entities.
86 * Minor cleanups in compile-time storage. There are now 3 kinds of
87 address-y things available:
88 CPtr/mkCPtr/cptrOf -- ptrs to Closures, probably in exec heap
89 ie anything which the exec GC knows about
90 MPtr/mkMPtr/mptrOf -- ptrs to mallocville, which the exec GC
92 Addr/mkAddr/addrOf -- literal addresses (like literal ints)
94 * Many hacky cases removed from codegen.c. Referencing code or
95 data during code generation is a lot simpler, since an entity
97 a CPtr, in which case use it as is
98 a MPtr -- stuff it into the AsmObject and the linker will fix it
102 * I've checked, using Purify that, at least in standalone mode,
103 no longer leaks mallocd memory. Prior to this it would leak at
104 the rate of about 300k per Prelude.
108 * Reinstate peephole optimisation for BCOs.
110 * Nuke magic number headers in AsmObjects, used for debugging.
112 * Profile and accelerate. Code generation is slower because linking
113 is slower. Evaluation GC is slower because markHugsObjects has
116 * Make setCurrentModule ignore name table entries created by the
121 /* --------------------------------------------------------------------------
122 * Local function prototypes:
123 * ------------------------------------------------------------------------*/
125 #define getPos(v) intOf(stgVarInfo(v))
126 #define setPos(v,sp) stgVarInfo(v) = mkInt(sp)
127 #define getObj(v) mptrOf(stgVarInfo(v))
128 #define setObj(v,obj) stgVarInfo(v) = mkMPtr(obj)
130 #define repOf(x) charOf(stgVarRep(x))
132 static void cgBind ( AsmBCO bco, StgVar v );
133 static Void pushAtom ( AsmBCO bco, StgAtom atom );
134 static Void alloc ( AsmBCO bco, StgRhs rhs );
135 static Void build ( AsmBCO bco, StgRhs rhs );
136 static Void cgExpr ( AsmBCO bco, AsmSp root, StgExpr e );
138 static AsmBCO cgAlts ( AsmSp root, AsmSp sp, List alts );
139 static void testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
140 static AsmBCO cgLambda ( StgExpr e );
141 static AsmBCO cgRhs ( StgRhs rhs );
142 static void beginTop ( StgVar v );
143 static AsmObject endTop ( StgVar v );
145 static StgVar currentTop;
147 /* --------------------------------------------------------------------------
149 * ------------------------------------------------------------------------*/
151 static void* /* StgClosure*/ cptrFromName ( Name n )
155 Module m = name(n).mod;
156 Text mt = module(m).text;
157 sprintf(buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_closure"),
159 textToStr( enZcodeThenFindText (
160 textToStr (name(n).text) ) ) );
161 p = lookupOTabName ( m, buf );
163 ERRMSG(0) "Can't find object symbol %s", buf
169 char* lookupHugsName( void* closure )
173 for( nm = NAME_BASE_ADDR;
174 nm < NAME_BASE_ADDR+tabNameSz; ++nm )
175 if (tabName[nm-NAME_BASE_ADDR].inUse) {
176 Cell cl = name(nm).closure;
177 if (isCPtr(cl) && cptrOf(cl) == closure)
178 return textToStr(name(nm).text);
183 static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
185 setPos(v,asmBind(bco,rep));
188 static void cgBind( AsmBCO bco, StgVar v )
190 cgBindRep(bco,v,repOf(v));
193 static void cgAddPtrToObject ( AsmObject obj, Cell ptrish )
195 switch (whatIs(ptrish)) {
197 asmAddRefNoOp ( obj, (StgPtr)cptrOf(ptrish) ); break;
199 asmAddRefObject ( obj, mptrOf(ptrish) ); break;
201 internal("cgAddPtrToObject");
205 /* Get a pointer to atom e onto the stack. */
206 static Void pushAtom ( AsmBCO bco, StgAtom e )
211 printf ( "pushAtom: %d ", e ); fflush(stdout);
212 print(e,10);printf("\n");
216 info = stgVarInfo(e);
218 asmVar(bco,intOf(info),repOf(e));
222 asmPushRefNoOp(bco,cptrOf(info));
226 asmPushRefObject(bco,mptrOf(info));
229 internal("pushAtom: STGVAR");
234 cl = getNameOrTupleClosure(e);
236 /* a stg tree which hasn't yet been translated */
237 asmPushRefHugs(bco,e);
241 /* a pointer to something in the heap */
242 asmPushRefNoOp(bco,(StgPtr)cptrOf(cl));
246 /* a pointer to an AsmBCO/AsmCAF/AsmCon object */
247 asmPushRefObject(bco,mptrOf(cl));
252 addr = cptrFromName(e);
254 fprintf ( stderr, "nativeAtom: name %s\n",
255 nameFromOPtr(addr) );
257 asmPushRefNoOp(bco,(StgPtr)addr);
261 asmConstChar(bco,charOf(e));
264 asmConstInt(bco,intOf(e));
267 asmConstAddr(bco,addrOf(e));
270 asmConstInteger(bco,bignumToString(e));
273 asmConstDouble(bco,floatOf(e));
276 # if USE_ADDR_FOR_STRINGS
277 asmConstAddr(bco,textToStr(textOf(e)));
279 asmClosure(bco,asmStringObj(textToStr(textOf(e))));
283 asmPushRefNoOp(bco,cptrOf(e));
286 asmPushRefObject(bco,mptrOf(e));
289 fprintf(stderr,"\nYoiks1: "); printExp(stderr,e);
290 internal("pushAtom");
294 static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
296 AsmBCO bco = asmBeginContinuation(sp, alts);
298 = length(alts) == 2 &&
299 isDefaultAlt(hd(tl(alts))) &&
300 !isDefaultAlt(hd(alts));
302 /* refine the condition */
306 con = stgCaseAltCon(hd(alts));
308 /* special case: dictionary constructors */
309 if (isName(con) && strncmp(":D",textToStr(name(con).text),2)==0) {
313 /* special case: Tuples */
314 if (isTuple(con) || (isName(con) && con==nameUnit)) {
319 t = name(con).parent;
320 if (tycon(t).what == DATATYPE) {
321 if (length(tycon(t).defn) == 1) omit_test = TRUE;
327 for(; nonNull(alts); alts=tl(alts)) {
328 StgCaseAlt alt = hd(alts);
329 if (isDefaultAlt(alt)) {
330 cgBind(bco,stgDefaultVar(alt));
331 cgExpr(bco,root,stgDefaultBody(alt));
332 asmEndContinuation(bco);
333 return bco; /* ignore any further alternatives */
335 StgDiscr con = stgCaseAltCon(alt);
336 List vs = stgCaseAltVars(alt);
337 AsmSp begin = asmBeginAlt(bco);
339 if (omit_test) fix=-1; else fix = asmTest(bco,stgDiscrTag(con));
341 asmBind(bco,PTR_REP); /* Adjust simulated sp to acct for return value */
342 if (isBoxingCon(con)) {
343 setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
346 map1Proc(cgBind,bco,reverse(vs));
349 cgExpr(bco,root,stgCaseAltBody(alt));
350 asmEndAlt(bco,begin);
351 if (fix != -1) asmFixBranch(bco,fix);
354 /* if we got this far and didn't match, panic! */
356 asmEndContinuation(bco);
360 static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
365 StgVar pat = hd(pats);
366 if (isInt(stgVarBody(pat))) {
367 /* asmTestInt leaves stack unchanged - so no need to adjust it */
368 AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
369 assert(repOf(pat) == INT_REP);
370 testPrimPats(bco,root,tl(pats),e);
371 asmFixBranch(bco,tst);
373 testPrimPats(bco,root,tl(pats),e);
379 static AsmBCO cgLambda( StgExpr e )
381 AsmBCO bco = asmBeginBCO(e);
383 AsmSp root = asmBeginArgCheck(bco);
384 map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
385 asmEndArgCheck(bco,root);
388 cgExpr(bco,root,stgLambdaBody(e));
394 static AsmBCO cgRhs( StgRhs rhs )
396 AsmBCO bco = asmBeginBCO(rhs );
398 AsmSp root = asmBeginArgCheck(bco);
399 asmEndArgCheck(bco,root);
401 /* ppStgExpr(rhs); */
402 cgExpr(bco,root,rhs);
409 static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
412 printf("cgExpr:");ppStgExpr(e);printf("\n");
417 List binds = stgLetBinds(e);
418 map1Proc(alloc,bco,binds);
419 map1Proc(build,bco,binds);
420 cgExpr(bco,root,stgLetBody(e));
425 AsmSp begin = asmBeginEnter(bco);
426 asmPushRefObject(bco,cgLambda(e));
427 asmEndEnter(bco,begin,root);
432 List alts = stgCaseAlts(e);
433 AsmSp sp = asmBeginCase(bco);
434 AsmSp caseroot = asmContinuation(bco,cgAlts(root,sp,alts));
435 cgExpr(bco,caseroot,stgCaseScrut(e));
441 StgExpr scrut = stgPrimCaseScrut(e);
442 List alts = stgPrimCaseAlts(e);
443 if (whatIs(scrut) == STGPRIM) { /* this is an optimisation */
445 /* No need to use return address or to Slide */
446 AsmSp beginPrim = asmBeginPrim(bco);
447 map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
448 asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
450 for(; nonNull(alts); alts=tl(alts)) {
451 StgPrimAlt alt = hd(alts);
452 List pats = stgPrimAltVars(alt);
453 StgExpr body = stgPrimAltBody(alt);
454 AsmSp altBegin = asmBeginAlt(bco);
455 map1Proc(cgBind,bco,reverse(pats));
456 testPrimPats(bco,root,pats,body);
457 asmEndAlt(bco,altBegin);
459 /* if we got this far and didn't match, panic! */
462 } else if (whatIs(scrut) == STGVAR) { /* another optimisation */
464 /* No need to use return address or to Slide */
466 /* only part different from primop code... todo */
467 AsmSp beginCase = asmBeginCase(bco);
468 pushAtom /*pushVar*/ (bco,scrut);
469 asmEndAlt(bco,beginCase); /* hack, hack - */
471 for(; nonNull(alts); alts=tl(alts)) {
472 StgPrimAlt alt = hd(alts);
473 List pats = stgPrimAltVars(alt);
474 StgExpr body = stgPrimAltBody(alt);
475 AsmSp altBegin = asmBeginAlt(bco);
476 map1Proc(cgBind,bco,pats);
477 testPrimPats(bco,root,pats,body);
478 asmEndAlt(bco,altBegin);
480 /* if we got this far and didn't match, panic! */
484 /* ToDo: implement this code... */
486 /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e),
487 stgPrimCaseBody(e))); */
488 /* cgExpr( bco,root,scrut ); */
492 case STGAPP: /* Tail call */
494 AsmSp env = asmBeginEnter(bco);
495 map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
496 pushAtom(bco,stgAppFun(e));
497 asmEndEnter(bco,env,root);
501 case NAME: /* Tail call (with no args) */
503 AsmSp env = asmBeginEnter(bco);
504 /* JRS 000112: next line used to be: pushVar(bco,name(e).stgVar); */
506 asmEndEnter(bco,env,root);
509 case STGVAR: /* Tail call (with no args), plus unboxed return */
515 AsmSp env = asmBeginEnter(bco);
516 pushAtom /*pushVar*/ (bco,e);
517 asmEndEnter(bco,env,root);
522 /* cgTailCall(bco,singleton(e)); */
523 /* asmReturnInt(bco); */
526 internal("cgExpr StgVar");
529 case STGPRIM: /* Tail call again */
531 AsmSp beginPrim = asmBeginPrim(bco);
532 map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
533 asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
534 /* map1Proc(cgBind,bco,rs_vars); */
535 assert(0); /* asmReturn_retty(); */
539 fprintf(stderr,"\nYoiks2: "); printExp(stderr,e);
544 /* allocate space for top level variable
545 * any change requires a corresponding change in 'build'.
547 static Void alloc( AsmBCO bco, StgVar v )
549 StgRhs rhs = stgVarBody(v);
552 printf("alloc: ");ppStgExpr(v);
554 switch (whatIs(rhs)) {
557 StgDiscr con = stgConCon(rhs);
558 List args = stgConArgs(rhs);
559 if (isBoxingCon(con)) {
560 pushAtom(bco,hd(args));
561 setPos(v,asmBox(bco,boxingConRep(con)));
563 setPos(v,asmAllocCONSTR(bco,stgConInfo(con)));
569 List bs = stgAppArgs(rhs);
570 for (; nonNull(bs); bs=tl(bs)) {
571 if (isName(hd(bs))) {
574 ASSERT(whatIs(hd(bs))==STGVAR);
575 totSizeW += asmRepSizeW( charOf(stgVarRep(hd(bs))) );
578 setPos(v,asmAllocAP(bco,totSizeW));
581 case LAMBDA: /* optimisation */
582 setObj(v,cgLambda(rhs));
585 setPos(v,asmAllocAP(bco,0));
590 static Void build( AsmBCO bco, StgVar v )
592 StgRhs rhs = stgVarBody(v);
595 switch (whatIs(rhs)) {
598 StgDiscr con = stgConCon(rhs);
599 List args = stgConArgs(rhs);
600 if (isBoxingCon(con)) {
601 doNothing(); /* already done in alloc */
603 AsmSp start = asmBeginPack(bco);
604 map1Proc(pushAtom,bco,reverse(args));
605 asmEndPack(bco,getPos(v),start,stgConInfo(con));
612 StgVar fun = stgAppFun(rhs);
613 List args = stgAppArgs(rhs);
616 itsaPAP = name(fun).arity > length(args);
620 if (nonNull(stgVarBody(fun))
621 && whatIs(stgVarBody(fun)) == LAMBDA
622 && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
627 internal("build: STGAPP");
630 AsmSp start = asmBeginMkPAP(bco);
631 map1Proc(pushAtom,bco,reverse(args));
633 asmEndMkPAP(bco,getPos(v),start); /* optimisation */
635 AsmSp start = asmBeginMkAP(bco);
636 map1Proc(pushAtom,bco,reverse(args));
638 asmEndMkAP(bco,getPos(v),start);
642 case LAMBDA: /* optimisation */
643 doNothing(); /* already pushed in alloc */
646 /* These two cases look almost identical to the default but they're really
647 * special cases of STGAPP. The essential thing here is that we can't call
648 * cgRhs(rhs) because that expects the rhs to have no free variables when,
649 * in fact, the rhs is _always_ a free variable.
651 * ToDo: a simple optimiser would eliminate all examples
652 * of this except "let x = x in ..."
657 AsmSp start = asmBeginMkAP(bco);
659 asmEndMkAP(bco,getPos(v),start);
664 AsmSp start = asmBeginMkAP(bco); /* make it updateable! */
665 asmPushRefObject(bco,cgRhs(rhs));
666 asmEndMkAP(bco,getPos(v),start);
672 /* --------------------------------------------------------------------------
673 * Top level variables
675 * ToDo: these should be handled by allocating a dynamic unentered CAF
676 * for each top level variable - this should be simpler!
677 * ------------------------------------------------------------------------*/
679 /* allocate AsmObject for top level variables
680 * any change requires a corresponding change in endTop
682 static void beginTop( StgVar v )
688 switch (whatIs(rhs)) {
690 setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
693 setObj(v,asmBeginBCO(rhs));
696 setObj(v,asmBeginCAF());
701 static AsmObject endTop( StgVar v )
703 StgRhs rhs = stgVarBody(v);
705 switch (whatIs(rhs)) {
707 List as = stgConArgs(rhs);
708 AsmCon con = (AsmCon)getObj(v);
709 for ( ; nonNull(as); as=tl(as)) {
713 /* should be a delayed combinator! */
714 asmAddRefObject(con,(AsmObject)getObj(a));
717 StgVar var = name(a).closure;
718 cgAddPtrToObject(con,var);
721 # if !USE_ADDR_FOR_STRINGS
723 asmAddPtr(con,asmStringObj(textToStr(textOf(a))));
727 /* asmAddPtr(con,??); */
735 case LAMBDA: { /* optimisation */
736 /* ToDo: merge this code with cgLambda */
737 AsmBCO bco = (AsmBCO)getObj(v);
738 AsmSp root = asmBeginArgCheck(bco);
739 map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
740 asmEndArgCheck(bco,root);
742 cgExpr(bco,root,stgLambdaBody(rhs));
747 default: { /* updateable caf */
748 AsmCAF caf = (AsmCAF)getObj(v);
749 asmAddRefObject ( caf, cgRhs(rhs) );
757 /* --------------------------------------------------------------------------
758 * The external entry points for the code generator.
759 * ------------------------------------------------------------------------*/
761 Void cgModule ( Module mod )
767 /* Lambda-lift, by traversing the code list of this module.
768 This creates more name-table entries, which are duly added
769 to the module's code list.
773 /* Initialise the BCO linker subsystem. */
776 /* Generate BCOs, CAFs and Constructors into mallocville.
777 At this point, the .closure values of the names/tycons on
778 the codelist contain StgVars, ie trees. The call to beginTop
779 converts them to MPtrs to AsmObjects.
781 for (cl=module(mod).codeList; nonNull(cl); cl=tl(cl)) {
782 c = getNameOrTupleClosure(hd(cl));
783 if (isCPtr(c)) continue;
785 if (isName(hd(cl))) {
786 printStg( stdout, name(hd(cl)).closure ); printf( "\n\n");
792 for (cl=module(mod).codeList; nonNull(cl); cl=tl(cl)) {
793 c = getNameOrTupleClosure(hd(cl));
794 if (isCPtr(c)) continue;
796 if (isName(hd(cl))) {
797 printStg( stdout, name(hd(cl)).closure ); printf( "\n\n");
800 setNameOrTupleClosure ( hd(cl), mkMPtr(endTop(c)) );
803 //fprintf ( stderr, "\nstarting sanity check\n" );
804 for (cl = module(mod).codeList; nonNull(cl); cl=tl(cl)) {
806 ASSERT(isName(c) || isTuple(c));
807 c = getNameOrTupleClosure(c);
808 ASSERT(isMPtr(c) || isCPtr(c));
810 //fprintf ( stderr, "completed sanity check\n" );
813 /* Figure out how big each object will be in the evaluator's heap,
814 and allocate space to put each in, but don't copy yet. Record
815 the heap address in the object. Assumes that GC doesn't happen;
816 reasonable since we use allocate().
818 asmAllocateHeapSpace();
820 /* Update name/tycon table closure entries with these new heap addrs. */
821 for (cl = module(mod).codeList; nonNull(cl); cl=tl(cl)) {
822 c = getNameOrTupleClosure(hd(cl));
824 setNameOrTupleClosureCPtr (
825 hd(cl), asmGetClosureOfObject(mptrOf(c)) );
828 /* Copy out of mallocville into the heap, resolving references on
833 /* Free up the malloc'd memory. */
838 /* --------------------------------------------------------------------------
839 * Code Generator control:
840 * ------------------------------------------------------------------------*/
848 case POSTPREL: break;
853 /*-------------------------------------------------------------------------*/