ghc/interpreter/translate.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Translator: generates stg code from output of pattern matching
   4  * compiler.
   5  *
   6  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
   7  * All rights reserved. See NOTICE for details and conditions of use etc...
   8  * Hugs version 1.4, December 1997
   9  *
  10  * $RCSfile: translate.c,v $
  11  * $Revision: 1.4 $
  12  * $Date: 1999/02/03 17:08:44 $
  13  * ------------------------------------------------------------------------*/
  14
  15 #include "prelude.h"
  16 #include "storage.h"
  17 #include "backend.h"
  18 #include "connect.h"
  19 #include "errors.h"
  20 #include "link.h"
  21 #include "dynamic.h"
  22 #include "Assembler.h"
  23
  24 /* ---------------------------------------------------------------- */
  25
  26 static StgVar  local stgOffset       Args((Offset,List));
  27 static StgVar  local stgText         Args((Text,List));
  28 static StgRhs  local stgRhs          Args((Cell,Int,List));
  29 static StgCaseAlt local stgCaseAlt   Args((Cell,Int,List,StgExpr));
  30 static StgExpr local stgExpr         Args((Cell,Int,List,StgExpr));
  31
  32 /* ---------------------------------------------------------------- */
  33
  34 /* Association list storing globals assigned to dictionaries, tuples, etc */
  35 List stgGlobals = NIL;
  36
  37 static StgVar local getSTGTupleVar  Args((Cell));
  38
  39 static StgVar local getSTGTupleVar( Cell d )
  40 {
  41     Pair p = cellAssoc(d,stgGlobals);
  42     /* Yoiks - only the Prelude sees Tuple decls! */
  43     if (isNull(p)) {
  44         implementTuple(tupleOf(d));
  45         p = cellAssoc(d,stgGlobals);
  46     }
  47     assert(nonNull(p));
  48     return snd(p);
  49 }
  50
  51 /* ---------------------------------------------------------------- */
  52
  53 static Cell local stgOffset(Offset o, List sc)
  54 {
  55     Cell r = cellAssoc(o,sc);
  56     assert(nonNull(r));
  57     return snd(r);
  58 }
  59
  60 static Cell local stgText(Text t,List sc)
  61 {
  62     List xs = sc;
  63     for (; nonNull(xs); xs=tl(xs)) {
  64         Cell x = hd(xs);
  65         Cell v = fst(x);
  66         if (!isOffset(v) && t == textOf(v)) {
  67             return snd(x);
  68         }
  69     }
  70     internal("stgText");
  71 }
  72
  73 /* ---------------------------------------------------------------- */
  74
  75 static StgRhs local stgRhs(e,co,sc)
  76 Cell e;
  77 Int  co;
  78 List sc; {
  79     switch (whatIs(e)) {
  80
  81     /* Identifiers */
  82     case OFFSET:
  83             return stgOffset(e,sc);
  84     case VARIDCELL:
  85     case VAROPCELL:
  86             return stgText(textOf(e),sc);
  87     case TUPLE:
  88             return getSTGTupleVar(e);
  89     case NAME:
  90             return e;
  91     /* Literals */
  92     case CHARCELL:
  93             return mkStgCon(nameMkC,singleton(e));
  94     case INTCELL:
  95             return mkStgCon(nameMkI,singleton(e));
  96     case BIGCELL:
  97             return mkStgCon(nameMkBignum,singleton(e));
  98     case FLOATCELL:
  99             return mkStgCon(nameMkD,singleton(e));
 100     case STRCELL:
 101 #if USE_ADDR_FOR_STRINGS
 102         {
 103             StgVar v = mkStgVar(mkStgCon(nameMkA,singleton(e)),NIL);
 104             return mkStgLet(singleton(v),
 105                             makeStgApp(nameUnpackString,singleton(v)));
 106         }
 107 #else
 108             return mkStgApp(nameUnpackString,singleton(e));
 109 #endif
 110     case AP:
 111             return stgExpr(e,co,sc,namePMFail);
 112     case NIL:
 113             internal("stgRhs2");
 114     default:
 115             return stgExpr(e,co,sc,namePMFail);
 116     }
 117 }
 118
 119 static StgCaseAlt local stgCaseAlt(alt,co,sc,failExpr)
 120 Cell alt;
 121 Int co;
 122 List sc;
 123 StgExpr failExpr;
 124 {
 125     StgDiscr d     = fst(alt);
 126     Int      da    = discrArity(d);
 127     Cell     vs    = NIL;
 128     Int  i;
 129     for(i=1; i<=da; ++i) {
 130         StgVar nv = mkStgVar(NIL,NIL);
 131         vs    = cons(nv,vs);
 132         sc    = cons(pair(mkOffset(co+i),nv),sc);
 133     }
 134     return mkStgCaseAlt(d,vs,stgExpr(snd(alt),co+da,sc,failExpr));
 135 }
 136
 137 static StgExpr local stgExpr(e,co,sc,failExpr)
 138 Cell e;
 139 Int  co;
 140 List sc;
 141 StgExpr failExpr;
 142 {
 143     switch (whatIs(e)) {
 144     case COND:
 145         {
 146             return makeStgIf(stgExpr(fst3(snd(e)),co,sc,namePMFail),
 147                              stgExpr(snd3(snd(e)),co,sc,failExpr),
 148                              stgExpr(thd3(snd(e)),co,sc,failExpr));
 149         }
 150     case GUARDED:
 151         {
 152             List guards = rev(snd(e));
 153             e = failExpr;
 154             for(; nonNull(guards); guards=tl(guards)) {
 155                 Cell g   = hd(guards);
 156                 Cell c   = stgExpr(fst(g),co,sc,namePMFail);
 157                 Cell rhs = stgExpr(snd(g),co,sc,failExpr);
 158                 e = makeStgIf(c,rhs,e);
 159             }
 160             return e;
 161         }
 162     case FATBAR:
 163         {
 164             StgExpr e2 = stgExpr(snd(snd(e)),co,sc,failExpr);
 165             StgVar alt = mkStgVar(e2,NIL);
 166             return mkStgLet(singleton(alt),stgExpr(fst(snd(e)),co,sc,alt));
 167         }
 168     case CASE:
 169         {
 170             List alts  = snd(snd(e));
 171             Cell scrut = stgExpr(fst(snd(e)),co,sc,namePMFail);
 172             if (isNull(alts)) {
 173                 return failExpr;
 174             } else if (isChar(fst(hd(alts)))) {
 175                 Cell     alt  = hd(alts);
 176                 StgDiscr d    = fst(alt);
 177                 StgVar   c    = mkStgVar(mkStgCon(nameMkC,singleton(d)),NIL);
 178                 StgExpr  test = nameEqChar;
 179                 /* duplicates scrut but it should be atomic */
 180                 return makeStgIf(makeStgLet(singleton(c),makeStgApp(test,doubleton(scrut,c))),
 181                                  stgExpr(snd(alt),co,sc,failExpr),
 182                                  stgExpr(ap(CASE,pair(fst(snd(e)),tl(alts))),co,sc,failExpr));
 183             } else {
 184                 List as    = NIL;
 185                 for(; nonNull(alts); alts=tl(alts)) {
 186                     as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
 187                 }
 188                 return mkStgCase(scrut, revOnto(as, singleton(mkStgDefault(mkStgVar(NIL,NIL),failExpr))));
 189             }
 190         }
 191     case NUMCASE:
 192 #if OVERLOADED_CONSTANTS
 193         {
 194             Triple nc    = snd(e);
 195             Offset o     = fst3(nc);
 196             Cell   discr = snd3(nc);
 197             Cell   r     = thd3(nc);
 198             Cell   scrut = stgOffset(o,sc);
 199             Cell   h     = getHead(discr);
 200             Int    da    = discrArity(discr);
 201
 202 #if NPLUSK
 203             if (whatIs(h) == ADDPAT && argCount == 1) {
 204                 /*   ADDPAT num dictIntegral
 205                  * ==>
 206                  *   let n = fromInteger num in
 207                  *   if pmLe dictIntegral n scrut
 208                  *   then let v = pmSubtract dictIntegral scrut v
 209                  *   else fail
 210                  */
 211                 Cell   n            = snd(h);
 212                 Cell   dictIntegral = arg(discr);  /* Integral dictionary */
 213                 StgVar v            = NIL;
 214                 List   binds        = NIL;
 215                 StgVar dIntegral    = NIL;
 216
 217                 /* bind dictionary */
 218                 dIntegral = stgRhs(dictIntegral,co,sc);
 219                 if (!isAtomic(dIntegral)) { /* wasn't atomic */
 220                     dIntegral = mkStgVar(dIntegral,NIL);
 221                     binds = cons(dIntegral,binds);
 222                 }
 223                 /* box number */
 224                 n = mkStgVar(mkStgCon(nameMkBignum,singleton(n)),NIL);
 225                 binds = cons(n,binds);
 226
 227                 /* coerce number to right type (using Integral dict) */
 228                 n = mkStgVar(mkStgApp(namePmFromInteger,doubleton(dIntegral,n)),NIL);
 229                 binds = cons(n,binds);
 230
 231                 ++co;
 232                 v = mkStgVar(mkStgApp(namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
 233                 return mkStgLet(binds,
 234                                 makeStgIf(mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
 235                                           mkStgLet(singleton(v),
 236                                                    stgExpr(r,
 237                                                            co,
 238                                                            cons(pair(mkOffset(co),v),sc),
 239                                                            failExpr)),
 240                                           failExpr));
 241             }
 242 #endif /* NPLUSK */
 243
 244             assert(isName(h) && argCount == 2);
 245             {
 246                 /* This code is rather ugly.
 247                  * We ought to desugar it using one of the following:
 248                  *   if (==) dEq (fromInt     dNum        pat) scrut
 249                  *   if (==) dEq (fromInteger dNum        pat) scrut
 250                  *   if (==) dEq (fromFloat   dFractional pat) scrut
 251                  * But it would be very hard to obtain the Eq dictionary
 252                  * from the Num or Fractional dictionary we have.
 253                  * Instead, we rely on the Prelude to supply 3 helper
 254                  * functions which do the test for us.
 255                  *   primPmInt     :: Num a => Int -> a -> Bool
 256                  *   primPmInteger :: Num a => Integer -> a -> Bool
 257                  *   primPmDouble  :: Fractional a => Double -> a -> Bool
 258                  */
 259                 Cell   n      = arg(discr);
 260                 Cell   dict   = arg(fun(discr));
 261                 StgExpr d     = NIL;
 262                 List    binds = NIL;
 263                 StgExpr m     = NIL;
 264                 Name   box
 265                     = h == nameFromInt     ? nameMkI
 266                     : h == nameFromInteger ? nameMkBignum
 267                     :                        nameMkD;
 268                 Name   testFun
 269                     = h == nameFromInt     ? namePmInt
 270                     : h == nameFromInteger ? namePmInteger
 271                     :                        namePmDouble;
 272                 Cell   altsc  = sc;
 273                 Cell   vs     = NIL;
 274                 Int    i;
 275
 276                 for(i=1; i<=da; ++i) {
 277                     Cell nv = mkStgVar(NIL,NIL);
 278                     vs    = cons(nv,vs);
 279                     altsc = cons(pair(mkOffset(co+i),nv),altsc);
 280                 }
 281                 /* bind dictionary */
 282                 d = stgRhs(dict,co,sc);
 283                 if (!isAtomic(d)) { /* wasn't atomic */
 284                     d = mkStgVar(d,NIL);
 285                     binds = cons(d,binds);
 286                 }
 287                 /* bind number */
 288                 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
 289                 binds = cons(n,binds);
 290
 291                 return makeStgIf(mkStgLet(binds,
 292                                           mkStgApp(testFun,tripleton(d,n,scrut))),
 293                                  stgExpr(r,co+da,altsc,failExpr),
 294                                  failExpr);
 295             }
 296         }
 297 #else /* ! OVERLOADED_CONSTANTS */
 298         {
 299             Triple nc    = snd(e);
 300             Offset o     = fst3(nc);
 301             Cell   discr = snd3(nc);
 302             Cell   r     = thd3(nc);
 303             Cell   scrut = stgOffset(o,sc);
 304             Cell   h     = getHead(discr);
 305             Int    da    = discrArity(discr);
 306             Cell   n     = discr;
 307             List   binds = NIL;
 308             Name   eq
 309                 = isInt(discr)    ? nameEqInt
 310                 : isBignum(discr) ? nameEqInteger
 311                 :                   nameEqDouble;
 312             Name   box
 313                 = isInt(discr)    ? nameMkI
 314                 : isBignum(discr) ? nameMkBignum
 315                 :                   nameMkD;
 316             StgExpr test = NIL;
 317             Cell   altsc = sc;
 318             Cell   vs    = NIL;
 319             Int    i;
 320
 321             for(i=1; i<=da; ++i) {
 322                 Cell nv = mkStgVar(NIL,NIL);
 323                 vs    = cons(nv,vs);
 324                 altsc = cons(pair(mkOffset(co+i),nv),altsc);
 325             }
 326
 327             /* bind number */
 328             n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
 329             binds = cons(n,binds);
 330
 331             test = mkStgLet(binds, mkStgApp(eq, doubleton(n,scrut)));
 332             return makeStgIf(test,
 333                              stgExpr(r,co+da,altsc,failExpr),
 334                              failExpr);
 335         }
 336 #endif /* ! OVERLOADED_CONSTANTS */
 337     case LETREC:
 338         {
 339             List binds = NIL;
 340             List vs = NIL;
 341             List bs;
 342             /* allocate variables, extend scope */
 343             for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
 344                 Cell nv  = mkStgVar(NIL,NIL);
 345                 sc = cons(pair(fst3(hd(bs)),nv),sc);
 346                 binds = cons(nv,binds);
 347                 vs = cons(nv,vs);
 348             }
 349             for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
 350                 Cell nv  = mkStgVar(NIL,NIL);
 351                 sc = cons(pair(mkOffset(++co),nv),sc);
 352                 binds = cons(nv,binds);
 353                 vs = cons(nv,vs);
 354             }
 355             vs = rev(vs);
 356             /* transform functions */
 357             for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
 358                 Cell fun = hd(bs);
 359                 Cell nv  = hd(vs);
 360                 List as = NIL;
 361                 List funsc = sc;
 362                 Int  arity = intOf(snd3(fun));
 363                 Int  i;
 364                 for(i=1; i<=arity; ++i) {
 365                     Cell v = mkStgVar(NIL,NIL);
 366                     as = cons(v,as);
 367                     funsc = cons(pair(mkOffset(co+i),v),funsc);
 368                 }
 369                 stgVarBody(nv) = mkStgLambda(as,stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
 370             }
 371             /* transform expressions */
 372             for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
 373                 Cell rhs = hd(bs);
 374                 Cell nv  = hd(vs);
 375                 stgVarBody(nv) = stgRhs(rhs,co,sc);
 376             }
 377             return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc));
 378         }
 379     default: /* convert to an StgApp or StgVar plus some bindings */
 380         {
 381             List args  = NIL;
 382             List binds = NIL;
 383             List as    = NIL;
 384
 385             /* Unwind args */
 386             while (isAp(e)) {
 387                 Cell arg = arg(e);
 388                 e        = fun(e);
 389                 args = cons(arg,args);
 390             }
 391
 392             /* Special cases */
 393             if (e == nameSel && length(args) == 3) {
 394                 Cell   con   = hd(args);
 395 #if 0
 396                 StgVar v     = stgOffset(hd(tl(args)),sc);
 397 #else
 398                 StgExpr v    = stgExpr(hd(tl(args)),co,sc,namePMFail);
 399 #endif
 400                 Int    ix    = intOf(hd(tl(tl(args))));
 401                 Int    da    = discrArity(con);
 402                 List   vs    = NIL;
 403                 Int    i;
 404                 for(i=1; i<=da; ++i) {
 405                     Cell nv = mkStgVar(NIL,NIL);
 406                     vs=cons(nv,vs);
 407                 }
 408                 return mkStgCase(v,
 409                                  doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
 410                                  mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
 411             }
 412
 413             /* Arguments must be StgAtoms */
 414             for(as=args; nonNull(as); as=tl(as)) {
 415                 StgRhs a = stgRhs(hd(as),co,sc);
 416 #if 1 /* optional flattening of let bindings */
 417                 if (whatIs(a) == LETREC) {
 418                     binds = appendOnto(stgLetBinds(a),binds);
 419                     a = stgLetBody(a);
 420                 }
 421 #endif
 422
 423                 if (!isAtomic(a)) {
 424                     a     = mkStgVar(a,NIL);
 425                     binds = cons(a,binds);
 426                 }
 427                 hd(as) = a;
 428             }
 429
 430             /* Function must be StgVar or Name */
 431             e = stgRhs(e,co,sc);
 432             if (!isStgVar(e) && !isName(e)) {
 433                 e = mkStgVar(e,NIL);
 434                 binds = cons(e,binds);
 435             }
 436
 437             return makeStgLet(binds,makeStgApp(e,args));
 438         }
 439     }
 440 }
 441
 442 static Void ppExp( Name n, Int arity, Cell e );
 443 static Void ppExp( Name n, Int arity, Cell e )
 444 {
 445 #if DEBUG_CODE
 446     if (debugCode) {
 447         Int i;
 448         printf("%s", textToStr(name(n).text));
 449         for (i = arity; i > 0; i--) {
 450             printf(" o%d", i);
 451         }
 452         printf(" = ");
 453         printExp(stdout,e);
 454         printf("\n");
 455     }
 456 #endif
 457 }
 458
 459 Void stgDefn( Name n, Int arity, Cell e )
 460 {
 461     List vs = NIL;
 462     List sc = NIL;
 463     Int i;
 464 //printf("\nBEGIN --------------- stgDefn-ppExp ----------------\n" );
 465 //    ppExp(n,arity,e);
 466 //printf("\nEND ----------------- stgDefn-ppExp ----------------\n" );
 467     for (i = 1; i <= arity; ++i) {
 468         Cell nv = mkStgVar(NIL,NIL);
 469         vs = cons(nv,vs);
 470         sc = cons(pair(mkOffset(i),nv),sc);
 471     }
 472     stgVarBody(name(n).stgVar) = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
 473 //printf("\nBEGIN --------------- stgDefn-ppStg ----------------\n" );
 474 //    ppStg(name(n).stgVar);
 475 //printf("\nEND ----------------- stgDefn-ppStg ----------------\n" );
 476 }
 477
 478 static StgExpr forceArgs( List is, List args, StgExpr e );
 479
 480 /* force the args numbered in is */
 481 static StgExpr forceArgs( List is, List args, StgExpr e )
 482 {
 483     for(; nonNull(is); is=tl(is)) {
 484         e = mkSeq(nth(intOf(hd(is))-1,args),e);
 485     }
 486     return e;
 487 }
 488
 489 #if 0
 490 ToDo: reinstate eventually
 491 /* \ v -> case v of { ...; Ci _ _ -> i; ... } */
 492 Void implementConToTag(t)
 493 Tycon t; {
 494     if (isNull(tycon(t).conToTag)) {
 495         List   cs  = tycon(t).defn;
 496         Name   nm  = newName(inventText());
 497         StgVar v   = mkStgVar(NIL,NIL);
 498         List alts  = NIL; /* can't fail */
 499
 500         assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE));
 501         for (; hasCfun(cs); cs=tl(cs)) {
 502             Name    c   = hd(cs);
 503             Int     num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
 504             StgVar  r   = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),NIL);
 505             StgExpr tag = mkStgLet(singleton(r),r);
 506             List    vs  = NIL;
 507             Int i;
 508             for(i=0; i < name(c).arity; ++i) {
 509                 vs = cons(mkStgVar(NIL,NIL),vs);
 510             }
 511             alts = cons(mkStgCaseAlt(c,vs,tag),alts);
 512         }
 513
 514         name(nm).line   = tycon(t).line;
 515         name(nm).type   = conToTagType(t);
 516         name(nm).arity  = 1;
 517         name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),NIL);
 518         tycon(t).conToTag = nm;
 519         /* hack to make it print out */
 520         stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
 521     }
 522 }
 523
 524 /* \ v -> case v of { ...; i -> Ci; ... } */
 525 Void implementTagToCon(t)
 526 Tycon t; {
 527     if (isNull(tycon(t).tagToCon)) {
 528         String etxt;
 529         String tyconname;
 530         List   cs;
 531         Name   nm;
 532         StgVar v1;
 533         StgVar v2;
 534         Cell   txt0;
 535         StgVar bind1;
 536         StgVar bind2;
 537         StgVar bind3;
 538         List   alts;
 539
 540         assert(nameMkA);
 541         assert(nameUnpackString);
 542         assert(nameError);
 543         assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE));
 544
 545         tyconname  = textToStr(tycon(t).text);
 546         etxt       = malloc(100+strlen(tyconname));
 547         assert(etxt);
 548         sprintf(etxt,
 549                 "out-of-range arg for `toEnum' in (derived) `instance Enum %s'",
 550                 tyconname);
 551
 552         cs  = tycon(t).defn;
 553         nm  = newName(inventText());
 554         v1  = mkStgVar(NIL,NIL);
 555         v2  = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
 556
 557         txt0  = mkStr(findText(etxt));
 558         bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL);
 559         bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)), NIL);
 560         bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)), NIL);
 561
 562         alts  = singleton(
 563                    mkStgPrimAlt(
 564                       singleton(
 565                          mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)
 566                       ),
 567                       makeStgLet ( tripleton(bind1,bind2,bind3), bind3 )
 568                    )
 569                 );
 570
 571         for (; hasCfun(cs); cs=tl(cs)) {
 572             Name   c   = hd(cs);
 573             Int    num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
 574             StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
 575             assert(name(c).arity==0);
 576             alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
 577         }
 578
 579         name(nm).line   = tycon(t).line;
 580         name(nm).type   = tagToConType(t);
 581         name(nm).arity  = 1;
 582         name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v1),
 583                                                mkStgCase(v1,singleton(mkStgCaseAlt(nameMkI,singleton(v2),
 584                                                                                    mkStgPrimCase(v2,alts))))),NIL);
 585         tycon(t).tagToCon = nm;
 586         /* hack to make it print out */
 587         stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
 588         if (etxt) free(etxt);
 589     }
 590 }
 591 #endif
 592
 593 Void implementCfun(c,scs)               /* Build implementation for constr */
 594 Name c;                                 /* fun c.  scs lists integers (1..)*/
 595 List scs; {                             /* in incr order of strict comps.  */
 596     Int a = name(c).arity;
 597     if (name(c).arity > 0) {
 598         List    args = makeArgs(a);
 599         StgVar  tv   = mkStgVar(mkStgCon(c,args),NIL);
 600         StgExpr e1   = mkStgLet(singleton(tv),tv);
 601         StgExpr e2   = forceArgs(scs,args,e1);
 602         StgVar  v    = mkStgVar(mkStgLambda(args,e2),NIL);
 603         name(c).stgVar = v;
 604     } else {
 605         StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
 606         name(c).stgVar = v;
 607     }
 608     /* hack to make it print out */
 609     stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
 610 }
 611
 612 /* --------------------------------------------------------------------------
 613  * Foreign function calls and primops
 614  * ------------------------------------------------------------------------*/
 615
 616 static String  charListToString( List cs );
 617 static Cell    foreignResultTy( Type t );
 618 static Cell    foreignArgTy( Type t );
 619 static Name    repToBox        Args(( char c ));
 620 static StgRhs  makeStgPrim     Args(( Name,Bool,List,String,String ));
 621
 622 static String charListToString( List cs )
 623 {
 624     static char s[100];
 625
 626     Int i = 0;
 627     assert( length(cs) < 100 );
 628     for(; nonNull(cs); ++i, cs=tl(cs)) {
 629         s[i] = charOf(hd(cs));
 630     }
 631     s[i] = '\0';
 632     return textToStr(findText(s));
 633 }
 634
 635 static Cell foreignResultTy( Type t )
 636 {
 637     if      (t == typeChar)   return mkChar(CHAR_REP);
 638     else if (t == typeInt)    return mkChar(INT_REP);
 639 #ifdef PROVIDE_INT64
 640     else if (t == typeInt64)  return mkChar(INT64_REP);
 641 #endif
 642 #ifdef PROVIDE_INTEGER
 643     else if (t == typeInteger)return mkChar(INTEGER_REP);
 644 #endif
 645 #ifdef PROVIDE_WORD
 646     else if (t == typeWord)   return mkChar(WORD_REP);
 647 #endif
 648 #ifdef PROVIDE_ADDR
 649     else if (t == typeAddr)   return mkChar(ADDR_REP);
 650 #endif
 651     else if (t == typeFloat)  return mkChar(FLOAT_REP);
 652     else if (t == typeDouble) return mkChar(DOUBLE_REP);
 653 #ifdef PROVIDE_FOREIGN
 654     else if (t == typeForeign)return mkChar(FOREIGN_REP); /* ToDo: argty only! */
 655 #endif
 656 #ifdef PROVIDE_ARRAY
 657     else if (t == typePrimByteArray) return mkChar(BARR_REP); /* ToDo: argty only! */
 658     else if (whatIs(t) == AP) {
 659         Type h = getHead(t);
 660         if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP); /* ToDo: argty only! */
 661     }
 662 #endif
 663    /* ToDo: decent line numbers! */
 664    ERRMSG(0) "Illegal foreign type" ETHEN
 665    ERRTEXT " \"" ETHEN ERRTYPE(t);
 666    ERRTEXT "\""
 667    EEND;
 668 }
 669
 670 static Cell foreignArgTy( Type t )
 671 {
 672     return foreignResultTy( t );
 673 }
 674
 675 static Name repToBox( char c )
 676 {
 677     switch (c) {
 678     case CHAR_REP:    return nameMkC;
 679     case INT_REP:     return nameMkI;
 680 #ifdef PROVIDE_INT64
 681     case INT64_REP:   return nameMkInt64;
 682 #endif
 683 #ifdef PROVIDE_INTEGER
 684     case INTEGER_REP: return nameMkInteger;
 685 #endif
 686 #ifdef PROVIDE_WORD
 687     case WORD_REP:    return nameMkW;
 688 #endif
 689 #ifdef PROVIDE_ADDR
 690     case ADDR_REP:    return nameMkA;
 691 #endif
 692     case FLOAT_REP:   return nameMkF;
 693     case DOUBLE_REP:  return nameMkD;
 694 #ifdef PROVIDE_ARRAY
 695     case ARR_REP:     return nameMkPrimArray;
 696     case BARR_REP:    return nameMkPrimByteArray;
 697     case REF_REP:     return nameMkRef;
 698     case MUTARR_REP:  return nameMkPrimMutableArray;
 699     case MUTBARR_REP: return nameMkPrimMutableByteArray;
 700 #endif
 701 #ifdef PROVIDE_STABLE
 702     case STABLE_REP:  return nameMkStable;
 703 #endif
 704 #ifdef PROVIDE_WEAK
 705     case WEAK_REP:  return nameMkWeak;
 706 #endif
 707 #ifdef PROVIDE_FOREIGN
 708     case FOREIGN_REP: return nameMkForeign;
 709 #endif
 710 #ifdef PROVIDE_CONCURRENT
 711     case THREADID_REP: return nameMkThreadId;
 712     case MVAR_REP:     return nameMkMVar;
 713 #endif
 714     default: return NIL;
 715     }
 716 }
 717
 718 static StgPrimAlt boxResults( String reps, StgVar state )
 719 {
 720     List rs = NIL;     /* possibly unboxed results     */
 721     List bs = NIL;     /* boxed results of wrapper     */
 722     List rbinds = NIL; /* bindings used to box results */
 723     StgExpr e   = NIL;
 724     Int i;
 725     for(i=0; reps[i] != '\0'; ++i) {
 726         StgRep k = mkStgRep(reps[i]);
 727         Cell v   = mkStgPrimVar(NIL,k,NIL);
 728         Name box = repToBox(reps[i]);
 729         if (isNull(box)) {
 730             bs = cons(v,bs);
 731         } else {
 732             StgRhs rhs = mkStgCon(box,singleton(v));
 733             StgVar bv = mkStgVar(rhs,NIL); /* boxed */
 734             bs     = cons(bv,bs);
 735             rbinds = cons(bv,rbinds);
 736         }
 737         rs = cons(v,rs);
 738     }
 739     /* Construct tuple of results */
 740     if (i == 1) {
 741         e = hd(bs);
 742     } else { /* includes i==0 case */
 743         StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
 744         rbinds = cons(r,rbinds);
 745         e = r;
 746     }
 747     /* construct result pair if needed */
 748     if (nonNull(state)) {
 749         /* Note that this builds a tuple directly - we know it's
 750          * saturated.
 751          */
 752         StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
 753         rbinds   = cons(r,rbinds);
 754         rs       = cons(state,rs);      /* last result is a state */
 755         e = r;
 756     }
 757     return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
 758 }
 759
 760 static List mkUnboxedVars( String reps )
 761 {
 762     List as = NIL;
 763     Int i;
 764     for(i=0; reps[i] != '\0'; ++i) {
 765         Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
 766         as = cons(v,as);
 767     }
 768     return rev(as);
 769 }
 770
 771 static List mkBoxedVars( String reps )
 772 {
 773     List as = NIL;
 774     Int i;
 775     for(i=0; reps[i] != '\0'; ++i) {
 776         as = cons(mkStgVar(NIL,NIL),as);
 777     }
 778     return rev(as);
 779 }
 780
 781 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
 782 {
 783     if (nonNull(b_args)) {
 784         StgVar b_arg = hd(b_args); /* boxed arg   */
 785         StgVar u_arg = hd(u_args); /* unboxed arg */
 786         StgRep k     = mkStgRep(*reps);
 787         Name   box   = repToBox(*reps);
 788         e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
 789         if (isNull(box)) {
 790             /* Use a trivial let-binding */
 791             stgVarBody(u_arg) = b_arg;
 792             return mkStgLet(singleton(u_arg),e);
 793         } else {
 794             StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
 795             return mkStgCase(b_arg,singleton(alt));
 796         }
 797     } else {
 798         return e;
 799     }
 800 }
 801
 802 /* Generate wrapper for primop based on list of arg types and result types:
 803  *
 804  * makeStgPrim op# False "II" "II" =
 805  *   \ x y -> "case x of { I# x# ->
 806  *             case y of { I# y# ->
 807  *             case op#{x#,y#} of { r1# r2# ->
 808  *             let r1 = I# r1#; r2 = I# r2# in
 809  *             (r1, r2)
 810  *             }}}"
 811  */
 812 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
 813 Name   op;
 814 Bool   addState;
 815 List   extra_args;
 816 String a_reps;
 817 String r_reps; {
 818     List b_args = NIL; /* boxed args to primop            */
 819     List u_args = NIL; /* possibly unboxed args to primop */
 820     List alts   = NIL;
 821     StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
 822     StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
 823
 824     /* box results */
 825     if (strcmp(r_reps,"B") == 0) {
 826         StgPrimAlt altF = mkStgPrimAlt(singleton(
 827                                          mkStgPrimVar(mkInt(0),
 828                                                       mkStgRep(INT_REP),NIL)
 829                                        ),
 830                                        nameFalse);
 831         StgPrimAlt altT = mkStgPrimAlt(singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
 832                                        nameTrue);
 833         alts = doubleton(altF,altT);
 834         assert(nonNull(nameTrue));
 835         assert(!addState);
 836     } else {
 837         alts = singleton(boxResults(r_reps,s1));
 838     }
 839     b_args = mkBoxedVars(a_reps);
 840     u_args = mkUnboxedVars(a_reps);
 841     if (addState) {
 842         List actual_args = appendOnto(extra_args,dupOnto(u_args,singleton(s0)));
 843         StgRhs rhs = makeStgLambda(singleton(s0),
 844                                    unboxVars(a_reps,b_args,u_args,
 845                                              mkStgPrimCase(mkStgPrim(op,actual_args),
 846                                                            alts)));
 847         StgVar m = mkStgVar(rhs,NIL);
 848         return makeStgLambda(b_args,
 849                              mkStgLet(singleton(m),
 850                                       mkStgApp(nameMkIO,singleton(m))));
 851     } else {
 852         List actual_args = appendOnto(extra_args,u_args);
 853         return makeStgLambda(b_args,
 854                              unboxVars(a_reps,b_args,u_args,mkStgPrimCase(mkStgPrim(op,actual_args),alts)));
 855     }
 856 }
 857
 858 Void implementPrim( n )
 859 Name n; {
 860     const AsmPrim* p = name(n).primop;
 861     StgRhs   rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
 862     StgVar   v   = mkStgVar(rhs,NIL);
 863     name(n).stgVar = v;
 864     stgGlobals=cons(pair(n,v),stgGlobals);  /* so it will get codegened */
 865 }
 866
 867 /* Generate wrapper code from (in,out) type lists.
 868  *
 869  * For example:
 870  *
 871  *     inTypes  = [Int,Float]
 872  *     outTypes = [Char,Addr]
 873  * ==>
 874  *     \ fun a1 a2 ->
 875  *       let m = (\ s0 ->
 876  *           case a1 of { I# a1# ->
 877  *           case s2 of { F# a2# ->
 878  *           case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
 879  *           let r1 = C# r1# in
 880  *           let r2 = A# r2# in
 881  *           let r  = (r1,r2) in
 882  *           (r,s1)
 883  *           }}})
 884  *       in primMkIO m
 885  *       ::
 886  *       Addr -> (Int -> Float -> IO (Char,Addr)
 887  */
 888 Void implementForeignImport( Name n )
 889 {
 890     Type t       = name(n).type;
 891     List argTys    = NIL;
 892     List resultTys = NIL;
 893     CFunDescriptor* descriptor = 0;
 894     Bool addState = TRUE;
 895     while (getHead(t)==typeArrow && argCount==2) {
 896         Type ta = fullExpand(arg(fun(t)));
 897         Type tr = arg(t);
 898         argTys = cons(ta,argTys);
 899         t = tr;
 900     }
 901     argTys = rev(argTys);
 902     if (getHead(t) == typeIO) {
 903         resultTys = getArgs(t);
 904         assert(length(resultTys) == 1);
 905         resultTys = hd(resultTys);
 906         addState = TRUE;
 907     } else {
 908         resultTys = t;
 909         addState = FALSE;
 910     }
 911     resultTys = fullExpand(resultTys);
 912     if (isTuple(getHead(resultTys))) {
 913         resultTys = getArgs(resultTys);
 914     } else if (getHead(resultTys) == typeUnit) {
 915         resultTys = NIL;
 916     } else {
 917         resultTys = singleton(resultTys);
 918     }
 919     mapOver(foreignArgTy,argTys);      /* allows foreignObj, byteArrays, etc */
 920     mapOver(foreignResultTy,resultTys);/* doesn't */
 921     descriptor = mkDescriptor(charListToString(argTys),
 922                               charListToString(resultTys));
 923     name(n).primop = addState ? &ccall_IO : &ccall_Id;
 924     {
 925         Pair    extName = name(n).defn;
 926         void*   funPtr  = getDLLSymbol(textToStr(textOf(fst(extName))),
 927                                        textToStr(textOf(snd(extName))));
 928         List extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
 929         StgRhs rhs = makeStgPrim(n,addState,extra_args,descriptor->arg_tys,descriptor->result_tys);
 930         StgVar v   = mkStgVar(rhs,NIL);
 931         if (funPtr == 0) {
 932             ERRMSG(0) "Could not find foreign function \"%s\" in \"%s\"",
 933                 textToStr(textOf(snd(extName))),
 934                 textToStr(textOf(fst(extName)))
 935             EEND;
 936         }
 937         ppStg(v);
 938         name(n).defn = NIL;
 939         name(n).stgVar = v;
 940         stgGlobals=cons(pair(n,v),stgGlobals);  /* so it will get codegened */
 941     }
 942 }
 943
 944 Void implementForeignExport( Name n )
 945 {
 946     internal("implementForeignExport: not implemented");
 947 }
 948
 949 Void implementTuple(size)
 950 Int size; {
 951     if (size > 0) {
 952         Cell    t    = mkTuple(size);
 953         List    args = makeArgs(size);
 954         StgVar  tv   = mkStgVar(mkStgCon(t,args),NIL);
 955         StgExpr e    = mkStgLet(singleton(tv),tv);
 956         StgVar  v    = mkStgVar(mkStgLambda(args,e),NIL);
 957         stgGlobals   = cons(pair(t,v),stgGlobals);   /* so we can see it */
 958     } else {
 959         StgVar  tv   = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
 960         stgGlobals   = cons(pair(nameUnit,tv),stgGlobals);   /* so we can see it */
 961     }
 962 }
 963
 964 /* --------------------------------------------------------------------------
 965  * Compiler control:
 966  * ------------------------------------------------------------------------*/
 967
 968 Void translateControl(what)
 969 Int what; {
 970     switch (what) {
 971     case INSTALL:
 972         {
 973             /* deliberate fall through */
 974         }
 975     case RESET:
 976             stgGlobals=NIL;
 977             break;
 978     case MARK:
 979             mark(stgGlobals);
 980             break;
 981     }
 982 }
 983
 984 /*-------------------------------------------------------------------------*/