ghc/interpreter/translate.c

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