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