ghc/interpreter/compiler.c

   1 /* -*- mode: hugs-c; -*- */
   2 /* --------------------------------------------------------------------------
   3  * This is the Hugs compiler, handling translation of typechecked code to
   4  * `kernel' language, elimination of pattern matching and translation to
   5  * super combinators (lambda lifting).
   6  *
   7  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
   8  * All rights reserved. See NOTICE for details and conditions of use etc...
   9  * Hugs version 1.4, December 1997
  10  *
  11  * $RCSfile: compiler.c,v $
  12  * $Revision: 1.2 $
  13  * $Date: 1998/12/02 13:22:01 $
  14  * ------------------------------------------------------------------------*/
  15
  16 #include "prelude.h"
  17 #include "storage.h"
  18 #include "connect.h"
  19 #include "input.h"
  20 #include "compiler.h"
  21 #include "hugs.h"  /* for target */
  22 #include "errors.h"
  23
  24 #include "desugar.h"
  25 #include "pmc.h"
  26
  27 #include "optimise.h"
  28
  29 #include "Rts.h"    /* for rts_eval and related stuff */
  30 #include "RtsAPI.h" /* for rts_eval and related stuff */
  31
  32 Name currentName;                      /* Top level name being processed   */
  33 #if DEBUG_CODE
  34 Bool   debugCode     = FALSE;           /* TRUE => print G-code to screen  */
  35 #endif
  36
  37 /* --------------------------------------------------------------------------
  38  * Local function prototypes:
  39  * ------------------------------------------------------------------------*/
  40
  41 static List local addGlobals( List binds );
  42 static Void local compileGlobalFunction Args((Pair));
  43 static Void local compileGenFunction    Args((Name));
  44 static Name local compileSelFunction    Args((Pair));
  45
  46 /* --------------------------------------------------------------------------
  47  * STG stuff
  48  * ------------------------------------------------------------------------*/
  49
  50 #include "stg.h"
  51 #include "translate.h"
  52 #include "codegen.h"
  53
  54 static Void local stgCGBinds( List );
  55
  56 static Void local stgCGBinds(binds)
  57 List binds; {
  58     cgBinds(binds);
  59 }
  60
  61 /* --------------------------------------------------------------------------
  62  * Main entry points to compiler:
  63  * ------------------------------------------------------------------------*/
  64
  65 static List addGlobals( List binds )
  66 {
  67     /* stgGlobals = pieces of code generated for selectors, tuples, etc */
  68     for(;nonNull(stgGlobals);stgGlobals=tl(stgGlobals)) {
  69         StgVar bind = snd(hd(stgGlobals));
  70         if (nonNull(stgVarBody(bind))) {
  71             binds = cons(bind,binds);
  72         }
  73     }
  74     return binds;
  75 }
  76
  77 #if 0
  78 /* This is a hack to see if "show [1..1000]" will go any faster if I
  79  * code primShowInt in C
  80  */
  81 char* prim_showInt(int x)
  82 {
  83     char buffer[50];
  84     sprintf(buffer,"%d",x);
  85     return buffer;
  86 }
  87
  88 void prim_flush_stdout(void)
  89 {
  90     fflush(stdout);
  91 }
  92 #endif
  93
  94 Void evalExp() {                    /* compile and run input expression    */
  95     /* ToDo: this name (and other names generated during pattern match?)
  96      * get inserted in the symbol table but never get removed.
  97      */
  98     Name n = newName(inventText());
  99     StgVar v = mkStgVar(NIL,NIL);
 100     name(n).stgVar = v;
 101     compiler(RESET);
 102     stgDefn(n,0,pmcTerm(0,NIL,translate(inputExpr)));
 103     inputExpr = NIL;
 104     stgCGBinds(addGlobals(singleton(v)));
 105
 106
 107     /* Run thread (and any other runnable threads) */
 108
 109     /* Re-initialise the scheduler - ToDo: do I need this? */
 110     initScheduler();
 111     {
 112         HaskellObj result; /* ignored */
 113         SchedulerStatus status = rts_eval_(closureOfVar(v),10000,&result);
 114         switch (status) {
 115         case Deadlock:
 116         case AllBlocked: /* I don't understand the distinction - ADR */
 117                 printf("{Deadlock}");
 118                 RevertCAFs();
 119                 break;
 120         case Interrupted:
 121                 printf("{Interrupted}");
 122                 RevertCAFs();
 123                 break;
 124         case Killed:
 125                 printf("{Killed}");
 126                 RevertCAFs();
 127                 break;
 128         case Success:
 129                 /* Nothing to do */
 130                 break;
 131         default:
 132                 internal("evalExp: Unrecognised SchedulerStatus");
 133         }
 134         fflush(stdout);
 135         fflush(stderr);
 136     }
 137 }
 138
 139 static List local addStgVar( List binds, Pair bind ); /* todo */
 140
 141 static List local addStgVar( List binds, Pair bind )
 142 {
 143     StgVar nv = mkStgVar(NIL,NIL);
 144     Text   t  = textOf(fst(bind));
 145     Name   n  = findName(t);
 146
 147     if (isNull(n)) {                   /* Lookup global name - the only way*/
 148         n = newName(t);                /* this (should be able to happen)  */
 149     }                                  /* is with new global var introduced*/
 150                                        /* after type check; e.g. remPat1   */
 151     name(n).stgVar = nv;
 152     return cons(nv,binds);
 153 }
 154
 155
 156 Void compileDefns() {                  /* compile script definitions       */
 157     Target t = length(valDefns) + length(genDefns) + length(selDefns);
 158     Target i = 0;
 159
 160     List binds = NIL;
 161     {
 162         List vss;
 163         List vs;
 164         for(vs=genDefns; nonNull(vs); vs=tl(vs)) {
 165             Name   n  = hd(vs);
 166             StgVar nv = mkStgVar(NIL,NIL);
 167             assert(isName(n));
 168             name(n).stgVar = nv;
 169             binds = cons(nv,binds);
 170         }
 171         for(vss=selDefns; nonNull(vss); vss=tl(vss)) {
 172             for(vs=hd(vss); nonNull(vs); vs=tl(vs)) {
 173                 Pair p = hd(vs);
 174                 Name n = fst(p);
 175                 StgVar nv = mkStgVar(NIL,NIL);
 176                 assert(isName(n));
 177                 name(n).stgVar = nv;
 178                 binds = cons(nv,binds);
 179             }
 180         }
 181     }
 182
 183     setGoal("Compiling",t);
 184     /* do valDefns before everything else so that all stgVar's get added. */
 185     for (; nonNull(valDefns); valDefns=tl(valDefns)) {
 186         hd(valDefns) = transBinds(hd(valDefns));
 187         mapAccum(addStgVar,binds,hd(valDefns));
 188         mapProc(compileGlobalFunction,hd(valDefns));
 189         soFar(i++);
 190     }
 191     for (; nonNull(genDefns); genDefns=tl(genDefns)) {
 192         compileGenFunction(hd(genDefns));
 193         soFar(i++);
 194     }
 195     for (; nonNull(selDefns); selDefns=tl(selDefns)) {
 196         mapOver(compileSelFunction,hd(selDefns));
 197         soFar(i++);
 198     }
 199
 200     /* binds=revOnto(binds,NIL); *//* ToDo: maintain compilation order?? */
 201     binds = addGlobals(binds);
 202 #if USE_HUGS_OPTIMIZER
 203     mapProc(optimiseBind,binds);
 204 #endif
 205     stgCGBinds(binds);
 206
 207     done();
 208 }
 209
 210 static Void local compileGlobalFunction(bind)
 211 Pair bind; {
 212     Name n     = findName(textOf(fst(bind)));
 213     List defs  = snd(bind);
 214     Int  arity = length(fst(hd(defs)));
 215     assert(isName(n));
 216     compiler(RESET);
 217     stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
 218 }
 219
 220 static Void local compileGenFunction(n) /* Produce code for internally     */
 221 Name n; {                               /* generated function              */
 222     List defs  = name(n).defn;
 223     Int  arity = length(fst(hd(defs)));
 224
 225     compiler(RESET);
 226     mapProc(transAlt,defs);
 227     stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
 228     name(n).defn = NIL;
 229 }
 230
 231 static Name local compileSelFunction(p) /* Produce code for selector func  */
 232 Pair p; {                               /* Should be merged with genDefns, */
 233     Name s     = fst(p);                /* but the name(_).defn field is   */
 234     List defs  = snd(p);                /* already used for other purposes */
 235     Int  arity = length(fst(hd(defs))); /* in selector functions.          */
 236
 237     compiler(RESET);
 238     mapProc(transAlt,defs);
 239     stgDefn(s,arity,match(arity,altsMatch(1,arity,NIL,defs)));
 240     return s;
 241 }
 242
 243 /* --------------------------------------------------------------------------
 244  * Compiler control:
 245  * ------------------------------------------------------------------------*/
 246
 247 Void compiler(what)
 248 Int what; {
 249     switch (what) {
 250         case INSTALL :
 251         case RESET   : break;
 252         case MARK    : break;
 253     }
 254 }
 255
 256 /*-------------------------------------------------------------------------*/