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.24 $
  14  * $Date: 1999/12/10 15:59:56 $
  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             char   str[30];
 215
 216 #if NPLUSK
 217             if (whatIs(h) == ADDPAT && argCount == 1) {
 218                 /*   ADDPAT num dictIntegral
 219                  * ==>
 220                  *   let n = fromInteger num in
 221                  *   if pmLe dictIntegral n scrut
 222                  *   then let v = pmSubtract dictIntegral scrut v
 223                  *   else fail
 224                  */
 225                 Cell   n            = snd(h);
 226                 Cell   dictIntegral = arg(discr);  /* Integral dictionary */
 227                 StgVar v            = NIL;
 228                 List   binds        = NIL;
 229                 StgVar dIntegral    = NIL;
 230
 231                 /* bind dictionary */
 232                 dIntegral = stgRhs(dictIntegral,co,sc,namePMFail);
 233                 if (!isAtomic(dIntegral)) { /* wasn't atomic */
 234                     dIntegral = mkStgVar(dIntegral,NIL);
 235                     binds = cons(dIntegral,binds);
 236                 }
 237
 238                 /* box number */
 239                 sprintf(str, "%d", n);
 240                 n = mkStgVar(mkStgCon(nameMkInteger,singleton(stringToBignum(str))),NIL);
 241                 binds = cons(n,binds);
 242
 243                 /* coerce number to right type (using Integral dict) */
 244                 n = mkStgVar(mkStgApp(
 245                        namePmFromInteger,doubleton(dIntegral,n)),NIL);
 246                 binds = cons(n,binds);
 247
 248                 ++co;
 249                 v = mkStgVar(mkStgApp(
 250                        namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
 251                 return
 252                    mkStgLet(
 253                       binds,
 254                       makeStgIf(
 255                          mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
 256                          mkStgLet(singleton(v),
 257                                   stgExpr(r,
 258                                           co,
 259                                           cons(pair(mkOffset(co),v),sc),
 260                                           failExpr)),
 261                          failExpr));
 262             }
 263 #endif /* NPLUSK */
 264
 265             assert(isName(h) && argCount == 2);
 266             {
 267                 /* This code is rather ugly.
 268                  * We ought to desugar it using one of the following:
 269                  *   if (==) dEq (fromInt     dNum        pat) scrut
 270                  *   if (==) dEq (fromInteger dNum        pat) scrut
 271                  *   if (==) dEq (fromFloat   dFractional pat) scrut
 272                  * But it would be very hard to obtain the Eq dictionary
 273                  * from the Num or Fractional dictionary we have.
 274                  * Instead, we rely on the Prelude to supply 3 helper
 275                  * functions which do the test for us.
 276                  *   primPmInt     :: Num a => Int -> a -> Bool
 277                  *   primPmInteger :: Num a => Integer -> a -> Bool
 278                  *   primPmDouble  :: Fractional a => Double -> a -> Bool
 279                  */
 280                 Cell   n      = arg(discr);
 281                 Cell   dict   = arg(fun(discr));
 282                 StgExpr d     = NIL;
 283                 List    binds = NIL;
 284                 //StgExpr m     = NIL;
 285                 Name   box
 286                     = h == nameFromInt     ? nameMkI
 287                     : h == nameFromInteger ? nameMkInteger
 288                     :                        nameMkD;
 289                 Name   testFun
 290                     = h == nameFromInt     ? namePmInt
 291                     : h == nameFromInteger ? namePmInteger
 292                     :                        namePmDouble;
 293                 Cell   altsc  = sc;
 294                 Cell   vs     = NIL;
 295                 Int    i;
 296
 297                 for(i=1; i<=da; ++i) {
 298                     Cell nv = mkStgVar(NIL,NIL);
 299                     vs    = cons(nv,vs);
 300                     altsc = cons(pair(mkOffset(co+i),nv),altsc);
 301                 }
 302                 /* bind dictionary */
 303                 d = stgRhs(dict,co,sc,namePMFail);
 304                 if (!isAtomic(d)) { /* wasn't atomic */
 305                     d = mkStgVar(d,NIL);
 306                     binds = cons(d,binds);
 307                 }
 308                 /* bind number */
 309                 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
 310                 binds = cons(n,binds);
 311
 312                 return
 313                    makeStgIf(
 314                       mkStgLet(binds,
 315                                mkStgApp(testFun,tripleton(d,n,scrut))),
 316                       stgExpr(r,co+da,altsc,failExpr),
 317                       failExpr
 318                    );
 319             }
 320         }
 321
 322     case LETREC:
 323         {
 324             List binds = NIL;
 325             List vs = NIL;
 326             List bs;
 327             /* allocate variables, extend scope */
 328             for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
 329                 Cell nv  = mkStgVar(NIL,NIL);
 330                 sc = cons(pair(fst3(hd(bs)),nv),sc);
 331                 binds = cons(nv,binds);
 332                 vs = cons(nv,vs);
 333             }
 334             for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
 335                 Cell nv  = mkStgVar(NIL,NIL);
 336                 sc = cons(pair(mkOffset(++co),nv),sc);
 337                 binds = cons(nv,binds);
 338                 vs = cons(nv,vs);
 339             }
 340             vs = rev(vs);
 341             /* transform functions */
 342             for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
 343                 Cell fun = hd(bs);
 344                 Cell nv  = hd(vs);
 345                 List as = NIL;
 346                 List funsc = sc;
 347                 Int  arity = intOf(snd3(fun));
 348                 Int  i;
 349                 for(i=1; i<=arity; ++i) {
 350                     Cell v = mkStgVar(NIL,NIL);
 351                     as = cons(v,as);
 352                     funsc = cons(pair(mkOffset(co+i),v),funsc);
 353                 }
 354                 stgVarBody(nv)
 355                    = mkStgLambda(
 356                         as,
 357                         stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
 358             }
 359             /* transform expressions */
 360             for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
 361                 Cell rhs = hd(bs);
 362                 Cell nv  = hd(vs);
 363                 stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
 364             }
 365             return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
 366         }
 367
 368     default: /* convert to an StgApp or StgVar plus some bindings */
 369         {
 370             List args  = NIL;
 371             List binds = NIL;
 372             List as    = NIL;
 373             Int  length_args;
 374
 375             /* Unwind args */
 376             while (isAp(e)) {
 377                 Cell arg = arg(e);
 378                 e        = fun(e);
 379                 args = cons(arg,args);
 380             }
 381
 382             /* Special cases */
 383             if (e == nameSel && length(args) == 3) {
 384                 Cell   con   = hd(args);
 385                 StgExpr v    = stgExpr(hd(tl(args)),co,sc,namePMFail);
 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 (whatIs(a) == LETREC) {
 404                     binds = appendOnto(stgLetBinds(a),binds);
 405                     a = stgLetBody(a);
 406                 }
 407                 if (!isAtomic(a)) {
 408                     a     = mkStgVar(a,NIL);
 409                     binds = cons(a,binds);
 410                 }
 411                 hd(as) = a;
 412             }
 413
 414             /* Special case: saturated constructor application */
 415             length_args = length(args);
 416             if ( (isName(e) && isCfun(e)
 417                   && name(e).arity > 0
 418                   && name(e).arity == length_args)
 419                  ||
 420                  (isTuple(e) && tycon(e).tuple == length_args)
 421                ) {
 422                StgVar v;
 423                /* fprintf ( stderr, "saturated application of %s\n",
 424                             textToStr(isTuple(e) ? tycon(e).text : name(e).text)); */
 425                v = mkStgVar(mkStgCon(e,args),NIL);
 426                binds = cons(v,binds);
 427                return mkStgLet(binds,v);
 428
 429
 430             }
 431
 432             /* Function must be StgVar or Name */
 433             e = stgRhs(e,co,sc,namePMFail);
 434             if (!isStgVar(e) && !isName(e)) {
 435                 e = mkStgVar(e,NIL);
 436                 binds = cons(e,binds);
 437             }
 438
 439             return makeStgLet(binds,makeStgApp(e,args));
 440         }
 441     }
 442 }
 443
 444 #if 0 /* apparently not used */
 445 static Void ppExp( Name n, Int arity, Cell e )
 446 {
 447     if (1 || debugCode) {
 448         Int i;
 449         printf("%s", textToStr(name(n).text));
 450         for (i = arity; i > 0; i--) {
 451             printf(" o%d", i);
 452         }
 453         printf(" = ");
 454         printExp(stdout,e);
 455         printf("\n");
 456     }
 457 }
 458 #endif
 459
 460
 461 Void stgDefn( Name n, Int arity, Cell e )
 462 {
 463     List vs = NIL;
 464     List sc = NIL;
 465     Int i, s;
 466     for (i = 1; i <= arity; ++i) {
 467         Cell nv = mkStgVar(NIL,NIL);
 468         vs = cons(nv,vs);
 469         sc = cons(pair(mkOffset(i),nv),sc);
 470     }
 471     stgVarBody(name(n).stgVar)
 472        = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
 473 }
 474
 475 Void implementCfun(c,scs)               /* Build implementation for constr */
 476 Name c;                                 /* fun c.  scs lists integers (1..)*/
 477 List scs; {                             /* in incr order of strict fields. */
 478     Int a = name(c).arity;
 479
 480     if (a > 0) {
 481         StgVar  vcurr, e1, v, vsi;
 482         List    args  = makeArgs(a);
 483         StgVar  v0    = mkStgVar(mkStgCon(c,args),NIL);
 484         List    binds = singleton(v0);
 485
 486         vcurr = v0;
 487         for (; nonNull(scs); scs=tl(scs)) {
 488            vsi   = nth(intOf(hd(scs))-1,args);
 489            vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
 490            binds = cons(vcurr,binds);
 491         }
 492         binds = rev(binds);
 493         e1    = mkStgLet(binds,vcurr);
 494         v     = mkStgVar(mkStgLambda(args,e1),NIL);
 495         name(c).stgVar = v;
 496     } else {
 497         StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
 498         name(c).stgVar = v;
 499     }
 500     stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
 501     /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */
 502 }
 503
 504 /* --------------------------------------------------------------------------
 505  * Foreign function calls and primops
 506  * ------------------------------------------------------------------------*/
 507
 508 /* Outbound denotes data moving from Haskell world to elsewhere.
 509    Inbound denotes data moving from elsewhere to Haskell world.
 510 */
 511 static String  charListToString   ( List cs );
 512 static Cell    foreignTy          ( Bool outBound, Type t );
 513 static Cell    foreignOutboundTy  ( Type t );
 514 static Cell    foreignInboundTy   ( Type t );
 515 static Name    repToBox           ( char c );
 516 static StgRhs  makeStgPrim        ( Name,Bool,List,String,String );
 517
 518 static String charListToString( List cs )
 519 {
 520     static char s[100];
 521
 522     Int i = 0;
 523     assert( length(cs) < 100 );
 524     for(; nonNull(cs); ++i, cs=tl(cs)) {
 525         s[i] = charOf(hd(cs));
 526     }
 527     s[i] = '\0';
 528     return textToStr(findText(s));
 529 }
 530
 531 static Cell foreignTy ( Bool outBound, Type t )
 532 {
 533     if      (t == typeChar)   return mkChar(CHAR_REP);
 534     else if (t == typeInt)    return mkChar(INT_REP);
 535 #if 0
 536     else if (t == typeInteger)return mkChar(INTEGER_REP);
 537 #endif
 538     else if (t == typeWord)   return mkChar(WORD_REP);
 539     else if (t == typeAddr)   return mkChar(ADDR_REP);
 540     else if (t == typeFloat)  return mkChar(FLOAT_REP);
 541     else if (t == typeDouble) return mkChar(DOUBLE_REP);
 542     else if (t == typeStable) return mkChar(STABLE_REP);
 543 #ifdef PROVIDE_FOREIGN
 544     else if (t == typeForeign)return mkChar(FOREIGN_REP);
 545          /* ToDo: argty only! */
 546 #endif
 547 #if 0
 548     else if (t == typePrimByteArray) return mkChar(BARR_REP);
 549          /* ToDo: argty only! */
 550     else if (whatIs(t) == AP) {
 551         Type h = getHead(t);
 552         if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
 553          /* ToDo: argty only! */
 554     }
 555 #endif
 556    /* ToDo: decent line numbers! */
 557    if (outBound) {
 558       ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
 559       ERRTEXT " \"" ETHEN ERRTYPE(t);
 560       ERRTEXT "\""
 561       EEND;
 562    } else {
 563       ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
 564       ERRTEXT " \"" ETHEN ERRTYPE(t);
 565       ERRTEXT "\""
 566       EEND;
 567    }
 568 }
 569
 570 static Cell foreignOutboundTy ( Type t )
 571 {
 572     return foreignTy ( TRUE, t );
 573 }
 574
 575 static Cell foreignInboundTy ( Type t )
 576 {
 577     return foreignTy ( FALSE, t );
 578 }
 579
 580 static Name repToBox( char c )
 581 {
 582     switch (c) {
 583     case CHAR_REP:     return nameMkC;
 584     case INT_REP:      return nameMkI;
 585     case INTEGER_REP:  return nameMkInteger;
 586     case WORD_REP:     return nameMkW;
 587     case ADDR_REP:     return nameMkA;
 588     case FLOAT_REP:    return nameMkF;
 589     case DOUBLE_REP:   return nameMkD;
 590     case ARR_REP:      return nameMkPrimArray;
 591     case BARR_REP:     return nameMkPrimByteArray;
 592     case REF_REP:      return nameMkRef;
 593     case MUTARR_REP:   return nameMkPrimMutableArray;
 594     case MUTBARR_REP:  return nameMkPrimMutableByteArray;
 595     case STABLE_REP:   return nameMkStable;
 596     case THREADID_REP: return nameMkThreadId;
 597     case MVAR_REP:     return nameMkPrimMVar;
 598 #ifdef PROVIDE_WEAK
 599     case WEAK_REP:  return nameMkWeak;
 600 #endif
 601 #ifdef PROVIDE_FOREIGN
 602     case FOREIGN_REP: return nameMkForeign;
 603 #endif
 604     default: return NIL;
 605     }
 606 }
 607
 608 static StgPrimAlt boxResults( String reps, StgVar state )
 609 {
 610     List rs = NIL;     /* possibly unboxed results     */
 611     List bs = NIL;     /* boxed results of wrapper     */
 612     List rbinds = NIL; /* bindings used to box results */
 613     StgExpr e   = NIL;
 614     Int i;
 615     for(i=0; reps[i] != '\0'; ++i) {
 616         StgRep k = mkStgRep(reps[i]);
 617         Cell v   = mkStgPrimVar(NIL,k,NIL);
 618         Name box = repToBox(reps[i]);
 619         if (isNull(box)) {
 620             bs = cons(v,bs);
 621         } else {
 622             StgRhs rhs = mkStgCon(box,singleton(v));
 623             StgVar bv = mkStgVar(rhs,NIL); /* boxed */
 624             bs     = cons(bv,bs);
 625             rbinds = cons(bv,rbinds);
 626         }
 627         rs = cons(v,rs);
 628     }
 629
 630     /* Construct tuple of results */
 631     if (i == 0) {
 632         e = nameUnit;
 633     } else
 634     if (i == 1) {
 635         e = hd(bs);
 636     } else {
 637         StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
 638         rbinds = cons(r,rbinds);
 639         e = r;
 640     }
 641     /* construct result pair if needed */
 642     if (nonNull(state)) {
 643         /* Note that this builds a tuple directly - we know it's
 644          * saturated.
 645          */
 646         StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
 647         rbinds   = cons(r,rbinds);
 648         rs       = cons(state,rs);      /* last result is a state */
 649         e = r;
 650     }
 651     return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
 652 }
 653
 654 static List mkUnboxedVars( String reps )
 655 {
 656     List as = NIL;
 657     Int i;
 658     for(i=0; reps[i] != '\0'; ++i) {
 659         Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
 660         as = cons(v,as);
 661     }
 662     return rev(as);
 663 }
 664
 665 static List mkBoxedVars( String reps )
 666 {
 667     List as = NIL;
 668     Int i;
 669     for(i=0; reps[i] != '\0'; ++i) {
 670         as = cons(mkStgVar(NIL,NIL),as);
 671     }
 672     return rev(as);
 673 }
 674
 675 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
 676 {
 677     if (nonNull(b_args)) {
 678         StgVar b_arg = hd(b_args); /* boxed arg   */
 679         StgVar u_arg = hd(u_args); /* unboxed arg */
 680         Name   box   = repToBox(*reps);
 681         e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
 682         if (isNull(box)) {
 683             /* Use a trivial let-binding */
 684             stgVarBody(u_arg) = b_arg;
 685             return mkStgLet(singleton(u_arg),e);
 686         } else {
 687             StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
 688             return mkStgCase(b_arg,singleton(alt));
 689         }
 690     } else {
 691         return e;
 692     }
 693 }
 694
 695 /* Generate wrapper for primop based on list of arg types and result types:
 696  *
 697  * makeStgPrim op# False "II" "II" =
 698  *   \ x y -> "case x of { I# x# ->
 699  *             case y of { I# y# ->
 700  *             case op#{x#,y#} of { r1# r2# ->
 701  *             let r1 = I# r1#; r2 = I# r2# in
 702  *             (r1, r2)
 703  *             }}}"
 704  */
 705 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
 706 Name   op;
 707 Bool   addState;
 708 List   extra_args;
 709 String a_reps;
 710 String r_reps; {
 711     List b_args = NIL; /* boxed args to primop            */
 712     List u_args = NIL; /* possibly unboxed args to primop */
 713     List alts   = NIL;
 714     StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
 715     StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
 716
 717     /* box results */
 718     if (strcmp(r_reps,"B") == 0) {
 719         StgPrimAlt altF
 720            = mkStgPrimAlt(singleton(
 721                             mkStgPrimVar(mkInt(0),
 722                                          mkStgRep(INT_REP),NIL)
 723                           ),
 724                           nameFalse);
 725         StgPrimAlt altT
 726            = mkStgPrimAlt(
 727                 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
 728                 nameTrue);
 729         alts = doubleton(altF,altT);
 730         assert(nonNull(nameTrue));
 731         assert(!addState);
 732     } else {
 733         alts = singleton(boxResults(r_reps,s1));
 734     }
 735     b_args = mkBoxedVars(a_reps);
 736     u_args = mkUnboxedVars(a_reps);
 737     if (addState) {
 738         List actual_args
 739            = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
 740         StgRhs rhs
 741            = makeStgLambda(singleton(s0),
 742                            unboxVars(a_reps,b_args,u_args,
 743                                      mkStgPrimCase(mkStgPrim(op,actual_args),
 744                                                    alts)));
 745         StgVar m = mkStgVar(rhs,NIL);
 746         return makeStgLambda(b_args,
 747                              mkStgLet(singleton(m),
 748                                       mkStgApp(nameMkIO,singleton(m))));
 749     } else {
 750         List actual_args = appendOnto(extra_args,u_args);
 751         return makeStgLambda(
 752                   b_args,
 753                   unboxVars(a_reps,b_args,u_args,
 754                             mkStgPrimCase(mkStgPrim(op,actual_args),alts))
 755                );
 756     }
 757 }
 758
 759 Void implementPrim ( n )
 760 Name n; {
 761     const AsmPrim* p = name(n).primop;
 762     StgRhs   rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
 763     StgVar   v   = mkStgVar(rhs,NIL);
 764     name(n).stgVar   = v;
 765     stgGlobals=cons(pair(n,v),stgGlobals);  /* so it will get codegened */
 766 }
 767
 768 /* Generate wrapper code from (in,out) type lists.
 769  *
 770  * For example:
 771  *
 772  *     inTypes  = [Int,Float]
 773  *     outTypes = [Char,Addr]
 774  * ==>
 775  *     \ fun a1 a2 ->
 776  *       let m = (\ s0 ->
 777  *           case a1 of { I# a1# ->
 778  *           case s2 of { F# a2# ->
 779  *           case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
 780  *           let r1 = C# r1# in
 781  *           let r2 = A# r2# in
 782  *           let r  = (r1,r2) in
 783  *           (r,s1)
 784  *           }}})
 785  *       in primMkIO m
 786  *       ::
 787  *       Addr -> (Int -> Float -> IO (Char,Addr))
 788  */
 789 Void implementForeignImport ( Name n )
 790 {
 791     Type t         = name(n).type;
 792     List argTys    = NIL;
 793     List resultTys = NIL;
 794     CFunDescriptor* descriptor = 0;
 795     Bool addState  = TRUE;
 796     Bool dynamic   = isNull(name(n).defn);
 797     while (getHead(t)==typeArrow && argCount==2) {
 798         Type ta = fullExpand(arg(fun(t)));
 799         Type tr = arg(t);
 800         argTys = cons(ta,argTys);
 801         t = tr;
 802     }
 803     argTys = rev(argTys);
 804
 805     /* argTys now holds the argument tys.  If this is a dynamic call,
 806        the first one had better be an Addr.
 807     */
 808     if (dynamic) {
 809        if (isNull(argTys) || hd(argTys) != typeAddr) {
 810           ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
 811           EEND;
 812        }
 813     }
 814
 815     if (getHead(t) == typeIO) {
 816         resultTys = getArgs(t);
 817         assert(length(resultTys) == 1);
 818         resultTys = hd(resultTys);
 819         addState = TRUE;
 820     } else {
 821         resultTys = t;
 822         addState = FALSE;
 823     }
 824     resultTys = fullExpand(resultTys);
 825     if (isTuple(getHead(resultTys))) {
 826         resultTys = getArgs(resultTys);
 827     } else if (getHead(resultTys) == typeUnit) {
 828         resultTys = NIL;
 829     } else {
 830         resultTys = singleton(resultTys);
 831     }
 832     mapOver(foreignOutboundTy,argTys);  /* allows foreignObj, byteArrays, etc */
 833     mapOver(foreignInboundTy,resultTys); /* doesn't */
 834     descriptor
 835        = mkDescriptor(charListToString(argTys),
 836                       charListToString(resultTys));
 837     if (!descriptor) {
 838        ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
 839        EEND;
 840     }
 841
 842     /* ccall is the default convention, if it wasn't specified */
 843     if (isNull(name(n).callconv)
 844         || name(n).callconv == textCcall) {
 845        name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
 846     }
 847     else if (name(n).callconv == textStdcall) {
 848        if (!stdcallAllowed()) {
 849           ERRMSG(name(n).line) "stdcall is not supported on this platform"
 850           EEND;
 851        }
 852        name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
 853     }
 854     else
 855        internal ( "implementForeignImport: unknown calling convention");
 856
 857     {
 858         Pair   extName;
 859         void*  funPtr;
 860         List   extra_args;
 861         StgRhs rhs;
 862         StgVar v;
 863
 864         if (dynamic) {
 865            funPtr     = NULL;
 866            extra_args = singleton(mkPtr(descriptor));
 867            /* and we know that the first arg will be the function pointer */
 868         } else {
 869            extName = name(n).defn;
 870            funPtr  = getDLLSymbol(name(n).line,
 871                                   textToStr(textOf(fst(extName))),
 872                                   textToStr(textOf(snd(extName))));
 873            if (funPtr == 0) {
 874                ERRMSG(name(n).line)
 875                    "Could not find foreign function \"%s\" in \"%s\"",
 876                    textToStr(textOf(snd(extName))),
 877                    textToStr(textOf(fst(extName)))
 878                EEND;
 879            }
 880            extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
 881         }
 882
 883         rhs              = makeStgPrim(n,addState,extra_args,
 884                                        descriptor->arg_tys,
 885                                        descriptor->result_tys);
 886         v                = mkStgVar(rhs,NIL);
 887         name(n).defn     = NIL;
 888         name(n).stgVar   = v;
 889         stgGlobals       = cons(pair(n,v),stgGlobals);
 890     }
 891
 892     /* At this point the descriptor contains a tags for all args,
 893        because that makes makeStgPrim generate the correct unwrap
 894        code.  From now on, the descriptor is only used at the time
 895        the actual ccall is made.  So we need to zap the leading
 896        addr arg IF this is a f-i-dynamic call.
 897     */
 898     if (dynamic) {
 899        descriptor->arg_tys++;
 900        descriptor->num_args--;
 901     }
 902
 903
 904 }
 905
 906
 907 /* Generate code:
 908  *
 909  * \ fun s0 ->
 910      let e1 = A# "...."
 911          e3 = C# 'c' -- (ccall), or 's' (stdcall)
 912      in  primMkAdjThunk fun e1 e3 s0
 913
 914    we require, and check that,
 915      fun :: prim_arg* -> IO prim_result
 916  */
 917 Void implementForeignExport ( Name n )
 918 {
 919     Type t         = name(n).type;
 920     List argTys    = NIL;
 921     List resultTys = NIL;
 922     Char cc_char;
 923
 924     if (getHead(t)==typeArrow && argCount==2) {
 925        t = arg(fun(t));
 926     } else {
 927         ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
 928         ERRTEXT " \"" ETHEN ERRTYPE(t);
 929         ERRTEXT "\""
 930         EEND;
 931     }
 932
 933     while (getHead(t)==typeArrow && argCount==2) {
 934         Type ta = fullExpand(arg(fun(t)));
 935         Type tr = arg(t);
 936         argTys = cons(ta,argTys);
 937         t = tr;
 938     }
 939     argTys = rev(argTys);
 940     if (getHead(t) == typeIO) {
 941         resultTys = getArgs(t);
 942         assert(length(resultTys) == 1);
 943         resultTys = hd(resultTys);
 944     } else {
 945         ERRMSG(name(n).line) "foreign export doesn't return an IO type" ETHEN
 946         ERRTEXT " \"" ETHEN ERRTYPE(t);
 947         ERRTEXT "\""
 948         EEND;
 949     }
 950     resultTys = fullExpand(resultTys);
 951
 952     mapOver(foreignInboundTy,argTys);
 953
 954     /* ccall is the default convention, if it wasn't specified */
 955     if (isNull(name(n).callconv)
 956         || name(n).callconv == textCcall) {
 957         cc_char = 'c';
 958     }
 959     else if (name(n).callconv == textStdcall) {
 960        if (!stdcallAllowed()) {
 961           ERRMSG(name(n).line) "stdcall is not supported on this platform"
 962           EEND;
 963        }
 964        cc_char = 's';
 965     }
 966     else
 967        internal ( "implementForeignExport: unknown calling convention");
 968
 969
 970     {
 971     List     tdList;
 972     Text     tdText;
 973     List     args;
 974     StgVar   e1, e2, e3, v;
 975     StgExpr  fun;
 976
 977     tdList = cons(mkChar(':'),argTys);
 978     if (resultTys != typeUnit)
 979        tdList = cons(foreignOutboundTy(resultTys),tdList);
 980
 981     tdText = findText(charListToString ( tdList ));
 982     args   = makeArgs(2);
 983     e1     = mkStgVar(
 984                 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
 985                 NIL
 986              );
 987     e2     = mkStgVar(
 988                 mkStgApp(nameUnpackString,singleton(e1)),
 989                 NIL
 990              );
 991     e3     = mkStgVar(
 992                 mkStgCon(nameMkC,singleton(mkChar(cc_char))),
 993                 NIL
 994              );
 995     fun    = mkStgLambda(
 996                 args,
 997                 mkStgLet(
 998                    tripleton(e1,e2,e3),
 999                    mkStgApp(
1000                       nameCreateAdjThunk,
1001                       cons(hd(args),cons(e2,cons(e3,cons(hd(tl(args)),NIL))))
1002                    )
1003                 )
1004              );
1005
1006     v = mkStgVar(fun,NIL);
1007
1008     name(n).defn     = NIL;
1009     name(n).stgVar   = v;
1010     stgGlobals       = cons(pair(n,v),stgGlobals);
1011     }
1012 }
1013
1014 Void implementTuple(size)
1015 Int size; {
1016     if (size > 0) {
1017         Cell    t    = mkTuple(size);
1018         List    args = makeArgs(size);
1019         StgVar  tv   = mkStgVar(mkStgCon(t,args),NIL);
1020         StgExpr e    = mkStgLet(singleton(tv),tv);
1021         StgVar  v    = mkStgVar(mkStgLambda(args,e),NIL);
1022         stgGlobals   = cons(pair(t,v),stgGlobals);   /* so we can see it */
1023     } else {
1024         StgVar  tv   = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
1025         stgGlobals   = cons(pair(nameUnit,tv),stgGlobals);      /* ditto */
1026     }
1027 }
1028
1029 /* --------------------------------------------------------------------------
1030  * Compiler control:
1031  * ------------------------------------------------------------------------*/
1032
1033 Void translateControl(what)
1034 Int what; {
1035     switch (what) {
1036        case POSTPREL: break;
1037        case PREPREL:
1038        case RESET:
1039           stgGlobals=NIL;
1040           break;
1041        case MARK:
1042           mark(stgGlobals);
1043           break;
1044     }
1045 }
1046
1047 /*-------------------------------------------------------------------------*/