ghc/interpreter/translate.c

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