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