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