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.31 $
  14  * $Date: 2000/04/05 10:25:09 $
  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                  ||
 415                  (isTuple(e) && tycon(e).tuple == length_args)
 416                ) {
 417                StgVar v;
 418                /* fprintf ( stderr, "saturated application of %s\n",
 419                             textToStr(isTuple(e) ? tycon(e).text : name(e).text)); */
 420                v = mkStgVar(mkStgCon(e,args),NIL);
 421                binds = cons(v,binds);
 422                return mkStgLet(binds,v);
 423
 424
 425             }
 426
 427             /* Function must be StgVar or Name */
 428             e = stgRhs(e,co,sc,namePMFail);
 429             if (!isStgVar(e) && !isName(e)) {
 430                 e = mkStgVar(e,NIL);
 431                 binds = cons(e,binds);
 432             }
 433
 434             return makeStgLet(binds,makeStgApp(e,args));
 435         }
 436     }
 437 }
 438
 439
 440 Void stgDefn( Name n, Int arity, Cell e )
 441 {
 442     List vs = NIL;
 443     List sc = NIL;
 444     Int i, s;
 445     for (i = 1; i <= arity; ++i) {
 446         Cell nv = mkStgVar(NIL,NIL);
 447         vs = cons(nv,vs);
 448         sc = cons(pair(mkOffset(i),nv),sc);
 449     }
 450     stgVarBody(name(n).stgVar)
 451        = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
 452 }
 453
 454 Void implementCfun(c,scs)               /* Build implementation for constr */
 455 Name c;                                 /* fun c.  scs lists integers (1..)*/
 456 List scs; {                             /* in incr order of strict fields. */
 457     Int a = name(c).arity;
 458
 459     if (a > 0) {
 460         StgVar  vcurr, e1, v, vsi;
 461         List    args  = makeArgs(a);
 462         StgVar  v0    = mkStgVar(mkStgCon(c,args),NIL);
 463         List    binds = singleton(v0);
 464
 465         vcurr = v0;
 466         for (; nonNull(scs); scs=tl(scs)) {
 467            vsi   = nth(intOf(hd(scs))-1,args);
 468            vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
 469            binds = cons(vcurr,binds);
 470         }
 471         binds = rev(binds);
 472         e1    = mkStgLet(binds,vcurr);
 473         v     = mkStgVar(mkStgLambda(args,e1),NIL);
 474         name(c).stgVar = v;
 475     } else {
 476         StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
 477         name(c).stgVar = v;
 478     }
 479     stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
 480     /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */
 481 }
 482
 483 /* --------------------------------------------------------------------------
 484  * Foreign function calls and primops
 485  * ------------------------------------------------------------------------*/
 486
 487 /* Outbound denotes data moving from Haskell world to elsewhere.
 488    Inbound denotes data moving from elsewhere to Haskell world.
 489 */
 490 static String  charListToString   ( List cs );
 491 static Cell    foreignTy          ( Bool outBound, Type t );
 492 static Cell    foreignOutboundTy  ( Type t );
 493 static Cell    foreignInboundTy   ( Type t );
 494 static Name    repToBox           ( char c );
 495 static StgRhs  makeStgPrim        ( Name,Bool,List,String,String );
 496
 497 static String charListToString( List cs )
 498 {
 499     static char s[100];
 500
 501     Int i = 0;
 502     assert( length(cs) < 100 );
 503     for(; nonNull(cs); ++i, cs=tl(cs)) {
 504         s[i] = charOf(hd(cs));
 505     }
 506     s[i] = '\0';
 507     return textToStr(findText(s));
 508 }
 509
 510 static Cell foreignTy ( Bool outBound, Type t )
 511 {
 512     if      (t == typeChar)   return mkChar(CHAR_REP);
 513     else if (t == typeInt)    return mkChar(INT_REP);
 514 #if 0
 515     else if (t == typeInteger)return mkChar(INTEGER_REP);
 516 #endif
 517     else if (t == typeWord)   return mkChar(WORD_REP);
 518     else if (t == typeAddr)   return mkChar(ADDR_REP);
 519     else if (t == typeFloat)  return mkChar(FLOAT_REP);
 520     else if (t == typeDouble) return mkChar(DOUBLE_REP);
 521     else if (t == typeStable) return mkChar(STABLE_REP);
 522 #ifdef PROVIDE_FOREIGN
 523     else if (t == typeForeign)return mkChar(FOREIGN_REP);
 524          /* ToDo: argty only! */
 525 #endif
 526 #if 0
 527     else if (t == typePrimByteArray) return mkChar(BARR_REP);
 528          /* ToDo: argty only! */
 529     else if (whatIs(t) == AP) {
 530         Type h = getHead(t);
 531         if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
 532          /* ToDo: argty only! */
 533     }
 534 #endif
 535    /* ToDo: decent line numbers! */
 536    if (outBound) {
 537       ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
 538       ERRTEXT " \"" ETHEN ERRTYPE(t);
 539       ERRTEXT "\""
 540       EEND;
 541    } else {
 542       ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
 543       ERRTEXT " \"" ETHEN ERRTYPE(t);
 544       ERRTEXT "\""
 545       EEND;
 546    }
 547 }
 548
 549 static Cell foreignOutboundTy ( Type t )
 550 {
 551     return foreignTy ( TRUE, t );
 552 }
 553
 554 static Cell foreignInboundTy ( Type t )
 555 {
 556     return foreignTy ( FALSE, t );
 557 }
 558
 559 static Name repToBox( char c )
 560 {
 561     switch (c) {
 562     case CHAR_REP:     return nameMkC;
 563     case INT_REP:      return nameMkI;
 564     case INTEGER_REP:  return nameMkInteger;
 565     case WORD_REP:     return nameMkW;
 566     case ADDR_REP:     return nameMkA;
 567     case FLOAT_REP:    return nameMkF;
 568     case DOUBLE_REP:   return nameMkD;
 569     case ARR_REP:      return nameMkPrimArray;
 570     case BARR_REP:     return nameMkPrimByteArray;
 571     case REF_REP:      return nameMkRef;
 572     case MUTARR_REP:   return nameMkPrimMutableArray;
 573     case MUTBARR_REP:  return nameMkPrimMutableByteArray;
 574     case STABLE_REP:   return nameMkStable;
 575     case THREADID_REP: return nameMkThreadId;
 576     case MVAR_REP:     return nameMkPrimMVar;
 577 #ifdef PROVIDE_WEAK
 578     case WEAK_REP:  return nameMkWeak;
 579 #endif
 580 #ifdef PROVIDE_FOREIGN
 581     case FOREIGN_REP: return nameMkForeign;
 582 #endif
 583     default: return NIL;
 584     }
 585 }
 586
 587 static StgPrimAlt boxResults( String reps, StgVar state )
 588 {
 589     List rs = NIL;     /* possibly unboxed results     */
 590     List bs = NIL;     /* boxed results of wrapper     */
 591     List rbinds = NIL; /* bindings used to box results */
 592     StgExpr e   = NIL;
 593     Int i;
 594     for(i=0; reps[i] != '\0'; ++i) {
 595         StgRep k = mkStgRep(reps[i]);
 596         Cell v   = mkStgPrimVar(NIL,k,NIL);
 597         Name box = repToBox(reps[i]);
 598         if (isNull(box)) {
 599             bs = cons(v,bs);
 600         } else {
 601             StgRhs rhs = mkStgCon(box,singleton(v));
 602             StgVar bv = mkStgVar(rhs,NIL); /* boxed */
 603             bs     = cons(bv,bs);
 604             rbinds = cons(bv,rbinds);
 605         }
 606         rs = cons(v,rs);
 607     }
 608
 609     /* Construct tuple of results */
 610     if (i == 0) {
 611         e = nameUnit;
 612     } else
 613     if (i == 1) {
 614         e = hd(bs);
 615     } else {
 616         StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
 617         rbinds = cons(r,rbinds);
 618         e = r;
 619     }
 620     /* construct result pair if needed */
 621     if (nonNull(state)) {
 622         /* Note that this builds a tuple directly - we know it's
 623          * saturated.
 624          */
 625         StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
 626         rbinds   = cons(r,rbinds);
 627         rs       = cons(state,rs);      /* last result is a state */
 628         e = r;
 629     }
 630     return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
 631 }
 632
 633 static List mkUnboxedVars( String reps )
 634 {
 635     List as = NIL;
 636     Int i;
 637     for(i=0; reps[i] != '\0'; ++i) {
 638         Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
 639         as = cons(v,as);
 640     }
 641     return rev(as);
 642 }
 643
 644 static List mkBoxedVars( String reps )
 645 {
 646     List as = NIL;
 647     Int i;
 648     for(i=0; reps[i] != '\0'; ++i) {
 649         as = cons(mkStgVar(NIL,NIL),as);
 650     }
 651     return rev(as);
 652 }
 653
 654 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
 655 {
 656     if (nonNull(b_args)) {
 657         StgVar b_arg = hd(b_args); /* boxed arg   */
 658         StgVar u_arg = hd(u_args); /* unboxed arg */
 659         Name   box   = repToBox(*reps);
 660         e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
 661         if (isNull(box)) {
 662             /* Use a trivial let-binding */
 663             stgVarBody(u_arg) = b_arg;
 664             return mkStgLet(singleton(u_arg),e);
 665         } else {
 666             StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
 667             return mkStgCase(b_arg,singleton(alt));
 668         }
 669     } else {
 670         return e;
 671     }
 672 }
 673
 674 /* Generate wrapper for primop based on list of arg types and result types:
 675  *
 676  * makeStgPrim op# False "II" "II" =
 677  *   \ x y -> "case x of { I# x# ->
 678  *             case y of { I# y# ->
 679  *             case op#{x#,y#} of { r1# r2# ->
 680  *             let r1 = I# r1#; r2 = I# r2# in
 681  *             (r1, r2)
 682  *             }}}"
 683  */
 684 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
 685 Name   op;
 686 Bool   addState;
 687 List   extra_args;
 688 String a_reps;
 689 String r_reps; {
 690     List b_args = NIL; /* boxed args to primop            */
 691     List u_args = NIL; /* possibly unboxed args to primop */
 692     List alts   = NIL;
 693     StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
 694     StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
 695
 696     /* box results */
 697     if (strcmp(r_reps,"B") == 0) {
 698         StgPrimAlt altF
 699            = mkStgPrimAlt(singleton(
 700                             mkStgPrimVar(mkInt(0),
 701                                          mkStgRep(INT_REP),NIL)
 702                           ),
 703                           nameFalse);
 704         StgPrimAlt altT
 705            = mkStgPrimAlt(
 706                 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
 707                 nameTrue);
 708         alts = doubleton(altF,altT);
 709         assert(nonNull(nameTrue));
 710         assert(!addState);
 711     } else {
 712         alts = singleton(boxResults(r_reps,s1));
 713     }
 714     b_args = mkBoxedVars(a_reps);
 715     u_args = mkUnboxedVars(a_reps);
 716     if (addState) {
 717         List actual_args
 718            = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
 719         StgRhs rhs
 720            = makeStgLambda(singleton(s0),
 721                            unboxVars(a_reps,b_args,u_args,
 722                                      mkStgPrimCase(mkStgPrim(op,actual_args),
 723                                                    alts)));
 724         StgVar m = mkStgVar(rhs,NIL);
 725         return makeStgLambda(b_args,
 726                              mkStgLet(singleton(m),
 727                                       mkStgApp(nameMkIO,singleton(m))));
 728     } else {
 729         List actual_args = appendOnto(extra_args,u_args);
 730         return makeStgLambda(
 731                   b_args,
 732                   unboxVars(a_reps,b_args,u_args,
 733                             mkStgPrimCase(mkStgPrim(op,actual_args),alts))
 734                );
 735     }
 736 }
 737
 738 Void implementPrim ( n )
 739 Name n; {
 740     const AsmPrim* p = name(n).primop;
 741     StgRhs   rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
 742     StgVar   v   = mkStgVar(rhs,NIL);
 743     name(n).stgVar   = v;
 744     stgGlobals=cons(pair(n,v),stgGlobals);  /* so it will get codegened */
 745 }
 746
 747 /* Generate wrapper code from (in,out) type lists.
 748  *
 749  * For example:
 750  *
 751  *     inTypes  = [Int,Float]
 752  *     outTypes = [Char,Addr]
 753  * ==>
 754  *     \ fun a1 a2 ->
 755  *       let m = (\ s0 ->
 756  *           case a1 of { I# a1# ->
 757  *           case s2 of { F# a2# ->
 758  *           case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
 759  *           let r1 = C# r1# in
 760  *           let r2 = A# r2# in
 761  *           let r  = (r1,r2) in
 762  *           (r,s1)
 763  *           }}})
 764  *       in primMkIO m
 765  *       ::
 766  *       Addr -> (Int -> Float -> IO (Char,Addr))
 767  */
 768 Void implementForeignImport ( Name n )
 769 {
 770     Type t         = name(n).type;
 771     List argTys    = NIL;
 772     List resultTys = NIL;
 773     CFunDescriptor* descriptor = 0;
 774     Bool addState  = TRUE;
 775     Bool dynamic   = isNull(name(n).defn);
 776     while (getHead(t)==typeArrow && argCount==2) {
 777         Type ta = fullExpand(arg(fun(t)));
 778         Type tr = arg(t);
 779         argTys = cons(ta,argTys);
 780         t = tr;
 781     }
 782     argTys = rev(argTys);
 783
 784     /* argTys now holds the argument tys.  If this is a dynamic call,
 785        the first one had better be an Addr.
 786     */
 787     if (dynamic) {
 788        if (isNull(argTys) || hd(argTys) != typeAddr) {
 789           ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
 790           EEND;
 791        }
 792     }
 793
 794     if (getHead(t) == typeIO) {
 795         resultTys = getArgs(t);
 796         assert(length(resultTys) == 1);
 797         resultTys = hd(resultTys);
 798         addState = TRUE;
 799     } else {
 800         resultTys = t;
 801         addState = FALSE;
 802     }
 803     resultTys = fullExpand(resultTys);
 804     if (isTuple(getHead(resultTys))) {
 805         resultTys = getArgs(resultTys);
 806     } else if (getHead(resultTys) == typeUnit) {
 807         resultTys = NIL;
 808     } else {
 809         resultTys = singleton(resultTys);
 810     }
 811     mapOver(foreignOutboundTy,argTys);  /* allows foreignObj, byteArrays, etc */
 812     mapOver(foreignInboundTy,resultTys); /* doesn't */
 813     descriptor
 814        = 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;
 838         void*  funPtr;
 839         List   extra_args;
 840         StgRhs rhs;
 841         StgVar v;
 842
 843         if (dynamic) {
 844            funPtr     = NULL;
 845            extra_args = singleton(mkPtr(descriptor));
 846            /* and we know that the first arg will be the function pointer */
 847         } else {
 848            extName = name(n).defn;
 849            funPtr  = getDLLSymbol(name(n).line,
 850                                   textToStr(textOf(fst(extName))),
 851                                   textToStr(textOf(snd(extName))));
 852            if (funPtr == 0) {
 853                ERRMSG(name(n).line)
 854                    "Could not find foreign function \"%s\" in \"%s\"",
 855                    textToStr(textOf(snd(extName))),
 856                    textToStr(textOf(fst(extName)))
 857                EEND;
 858            }
 859            extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
 860         }
 861
 862         rhs              = makeStgPrim(n,addState,extra_args,
 863                                        descriptor->arg_tys,
 864                                        descriptor->result_tys);
 865         v                = mkStgVar(rhs,NIL);
 866         name(n).defn     = NIL;
 867         name(n).stgVar   = v;
 868         stgGlobals       = cons(pair(n,v),stgGlobals);
 869     }
 870
 871     /* At this point the descriptor contains a tags for all args,
 872        because that makes makeStgPrim generate the correct unwrap
 873        code.  From now on, the descriptor is only used at the time
 874        the actual ccall is made.  So we need to zap the leading
 875        addr arg IF this is a f-i-dynamic call.
 876     */
 877     if (dynamic) {
 878        descriptor->arg_tys++;
 879        descriptor->num_args--;
 880     }
 881 }
 882
 883
 884 /* Generate code:
 885  *
 886  * \ fun ->
 887      let e1 = A# "...."
 888          e3 = C# 'c' -- (ccall), or 's' (stdcall)
 889      in  primMkAdjThunk fun e1 e3
 890
 891    we require, and check that,
 892      fun :: prim_arg* -> IO prim_result
 893  */
 894 Void implementForeignExport ( Name n )
 895 {
 896     Type t         = name(n).type;
 897     List argTys    = NIL;
 898     List resultTys = NIL;
 899     Char cc_char;
 900
 901     if (getHead(t)==typeArrow && argCount==2) {
 902        t = arg(fun(t));
 903     } else {
 904         ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
 905         ERRTEXT " \"" ETHEN ERRTYPE(t);
 906         ERRTEXT "\""
 907         EEND;
 908     }
 909
 910     while (getHead(t)==typeArrow && argCount==2) {
 911         Type ta = fullExpand(arg(fun(t)));
 912         Type tr = arg(t);
 913         argTys = cons(ta,argTys);
 914         t = tr;
 915     }
 916     argTys = rev(argTys);
 917     if (getHead(t) == typeIO) {
 918         resultTys = getArgs(t);
 919         assert(length(resultTys) == 1);
 920         resultTys = hd(resultTys);
 921     } else {
 922         ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN
 923         ERRTEXT " \"" ETHEN ERRTYPE(t);
 924         ERRTEXT "\""
 925         EEND;
 926     }
 927     resultTys = fullExpand(resultTys);
 928
 929     mapOver(foreignInboundTy,argTys);
 930
 931     /* ccall is the default convention, if it wasn't specified */
 932     if (isNull(name(n).callconv)
 933         || name(n).callconv == textCcall) {
 934         cc_char = 'c';
 935     }
 936     else if (name(n).callconv == textStdcall) {
 937        if (!stdcallAllowed()) {
 938           ERRMSG(name(n).line) "stdcall is not supported on this platform"
 939           EEND;
 940        }
 941        cc_char = 's';
 942     }
 943     else
 944        internal ( "implementForeignExport: unknown calling convention");
 945
 946     {
 947     List     tdList;
 948     Text     tdText;
 949     List     args;
 950     StgVar   e1, e2, e3, v;
 951     StgExpr  fun;
 952
 953     tdList = cons(mkChar(':'),argTys);
 954     if (resultTys != typeUnit)
 955        tdList = cons(foreignOutboundTy(resultTys),tdList);
 956
 957     tdText = findText(charListToString ( tdList ));
 958     args   = makeArgs(1);
 959     e1     = mkStgVar(
 960                 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
 961                 NIL
 962              );
 963     e2     = mkStgVar(
 964                 mkStgApp(nameUnpackString,singleton(e1)),
 965                 NIL
 966              );
 967     e3     = mkStgVar(
 968                 mkStgCon(nameMkC,singleton(mkChar(cc_char))),
 969                 NIL
 970              );
 971     fun    = mkStgLambda(
 972                 args,
 973                 mkStgLet(
 974                    tripleton(e1,e2,e3),
 975                    mkStgApp(
 976                       nameCreateAdjThunk,
 977                       cons(hd(args),cons(e2,cons(e3,NIL)))
 978                    )
 979                 )
 980              );
 981
 982     v = mkStgVar(fun,NIL);
 983
 984     name(n).defn     = NIL;
 985     name(n).stgVar   = v;
 986     stgGlobals       = cons(pair(n,v),stgGlobals);
 987     }
 988 }
 989
 990 Void implementTuple(size)
 991 Int size; {
 992     if (size > 0) {
 993         Cell    t    = mkTuple(size);
 994         List    args = makeArgs(size);
 995         StgVar  tv   = mkStgVar(mkStgCon(t,args),NIL);
 996         StgExpr e    = mkStgLet(singleton(tv),tv);
 997         StgVar  v    = mkStgVar(mkStgLambda(args,e),NIL);
 998         stgGlobals   = cons(pair(t,v),stgGlobals);   /* so we can see it */
 999     } else {
1000         StgVar  tv   = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
1001         stgGlobals   = cons(pair(nameUnit,tv),stgGlobals);      /* ditto */
1002     }
1003 }
1004
1005 /* --------------------------------------------------------------------------
1006  * Compiler control:
1007  * ------------------------------------------------------------------------*/
1008
1009 Void translateControl(what)
1010 Int what; {
1011     switch (what) {
1012        case POSTPREL: break;
1013        case PREPREL:
1014        case RESET:
1015           stgGlobals=NIL;
1016           break;
1017        case MARK:
1018           mark(stgGlobals);
1019           break;
1020     }
1021 }
1022
1023 /*-------------------------------------------------------------------------*/