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