prop-src/instgen.pcc.old

   1 ///////////////////////////////////////////////////////////////////////////////
   2 //
   3 //  This file handles datatype instantiation processing.
   4 //
   5 ///////////////////////////////////////////////////////////////////////////////
   6 #include "ir.ph"
   7 #include "ast.ph"
   8 #include "datagen.h"
   9 #include "type.h"
  10 #include "hashtab.h"
  11 #include "options.h"
  12 #include <AD/strings/quark.h>
  13
  14 ///////////////////////////////////////////////////////////////////////////////
  15 //
  16 //  Equality and hashing on cons/tys pairs
  17 //
  18 ///////////////////////////////////////////////////////////////////////////////
  19 unsigned int id_tys_hash(HashTable::Key a)
  20 {  Pair<Id,Tys> key = (Pair<Id,Tys>)a;
  21    return (unsigned int)key->fst + tys_hash(key->snd);
  22 }
  23 Bool id_tys_equal(HashTable::Key a, HashTable::Key b)
  24 {  Pair<Id,Tys> x = (Pair<Id,Tys>)a;
  25    Pair<Id,Tys> y = (Pair<Id,Tys>)b;
  26    return x->fst == y->fst && tys_equal(x->snd,y->snd);
  27 }
  28
  29 unsigned int pid_hash(Pid pid)
  30 {  match (pid)
  31    {  PERSISTid id:  { return string_hash(id); }
  32    |  PERSISTnone:   { return 1235; }
  33    }
  34 }
  35
  36 Bool pid_equal(Pid a, Pid b)
  37 {  match (a) and (b)
  38    {  PERSISTid  a, PERSISTid  b: { return string_equal(a,b); }
  39    |  _,            _:            { return false; }
  40    }
  41 }
  42
  43 ///////////////////////////////////////////////////////////////////////////////
  44 //
  45 //  Global hashtables to store mapping from types to persistent Id's
  46 //  and vice versa.
  47 //
  48 ///////////////////////////////////////////////////////////////////////////////
  49 HashTable type_pid_map(id_tys_hash, id_tys_equal);
  50 HashTable pid_type_map(pid_hash, pid_equal);
  51
  52 ///////////////////////////////////////////////////////////////////////////////
  53 //
  54 //  Enter a new persistent id entry
  55 //
  56 ///////////////////////////////////////////////////////////////////////////////
  57 void update_persistent(Id id, Tys tys, Pid pid)
  58 {  Pair<Id,Tys> key = pair(id,tys);
  59    HashTable::Entry * e1 = type_pid_map.lookup((HashTable::Key)key);
  60    HashTable::Entry * e2 = pid_type_map.lookup((HashTable::Key)pid);
  61    if (e1)
  62    {  error ("%Lpersistence redefined for type %s%P\n",id,tys);
  63    }
  64    if (e2)
  65    {  Pair<Id,Tys> previous = (Pair<Id,Tys>)(e2->v);
  66       error ("%Lpersistence pid %Q already allocated for type %s%P\n",
  67              pid, previous->fst, previous->snd);
  68    }
  69    if (e1 == 0 && e2 == 0)
  70    {  type_pid_map.insert(key,(HashTable::Value)pid);
  71       pid_type_map.insert((HashTable::Key)pid,key);
  72    }
  73
  74    // add persistent qualifier to the constructor's type
  75    match (lookup_ty(id))
  76    {  DATATYPEty ({ qualifiers ... },_): { qualifiers |= QUALpersistent; }
  77    |  _: { error("%Ltype %s%P is not a datatype\n",id,tys); }
  78    }
  79 }
  80
  81 ///////////////////////////////////////////////////////////////////////////////
  82 //
  83 //  Lookup a new persistent id entry
  84 //
  85 ///////////////////////////////////////////////////////////////////////////////
  86 Pid lookup_persistent(Id id, Tys tys)
  87 {  Pair<Id,Tys> key = pair(id,tys);
  88    HashTable::Entry * e1 = type_pid_map.lookup((HashTable::Key)key);
  89    if (e1)
  90    {  return value_of(Pid, type_pid_map, e1); }
  91    else
  92    {  error ("%Lpersist object id is undefined for %s%P\n",id,tys);
  93       return PERSISTnone;
  94    }
  95 }
  96
  97 ///////////////////////////////////////////////////////////////////////////////
  98 //
  99 //  Method to generate datatype instantiate code.
 100 //
 101 ///////////////////////////////////////////////////////////////////////////////
 102 void DatatypeCompiler::instantiate_datatypes(Bool extern_def, Tys tys)
 103 {
 104    for_each(Ty, ty, tys)
 105    {  match (ty)
 106       {  TYCONty (IDtycon id, args):
 107          {  match (lookup_ty(id))
 108             {  TYCONty(tycon as DATATYPEtycon
 109                        { id, tyvars, polyty, qualifiers, opt, unit, arg,
 110                          inherit, terms ... },_):
 111                {  if ((qualifiers & QUALview) == 0)
 112                      instantiate_datatype
 113                        (extern_def, id, tyvars, args, unit, arg,
 114                         qualifiers, opt, polyty,inherit, terms);
 115                }
 116             |  NOty: { error ("%Ltype %T is undefined\n", ty); }
 117             |  _: { error("%Ltype %T is not a datatype\n", ty); }
 118             }
 119          }
 120       |  _: { error ("%Ltype %T is undefined\n", ty); }
 121       }
 122    }
 123 }
 124
 125 ///////////////////////////////////////////////////////////////////////////////
 126 //
 127 //  Instantiate one datatype
 128 //
 129 ///////////////////////////////////////////////////////////////////////////////
 130 void DatatypeCompiler::instantiate_datatype
 131    (Bool extern_def, Id id, TyVars tyvars, Tys tys, int unit,
 132     int arg, int qual, int opt, Ty polyty, Inherits inherits, Cons terms[])
 133 {  int arity = unit + arg;
 134
 135    // Generate inference interface.
 136    if (qual & QUALprintable)
 137       gen_pretty_printer(extern_def, deref_all(TYCONty(IDtycon(id),tys)), tys);
 138
 139    // Generate inference interface.
 140    if ((qual & QUALrelation) && ! extern_def) {
 141       pr ("%^%/%^// Relation class %s interface%^%/"
 142           "%^Fact::RelTag a_%s::relation_tag = 0;"
 143           "%^static InitialiseFact %s_dummy__(a_%s::relation_tag);"
 144           "%^Fact::RelTag a_%s::get_tag() const { return a_%s::relation_tag; }\n\n",
 145           id, id, id, id, id, id);
 146    }
 147
 148    // Generate garbage collection tracing methods.
 149    // Generate persistence read/write methods.
 150    Bool has_gc = false;
 151    Bool has_persistence = false;
 152
 153    if (!(opt & OPTsubclassless) && arg > 0) {
 154       if (qual & QUALcollectable)
 155       {  has_gc = gen_gc_trace(extern_def,
 156                     id, tyvars, tys, #[], NOty, polyty, opt, inherits, has_gc);
 157       }
 158       if (qual & QUALpersistent)
 159       {  has_persistence =
 160                gen_persistence(extern_def, id, tyvars, tys, 0, NOty,
 161                                polyty, opt, inherits, has_persistence);
 162       }
 163    }
 164
 165    if (!extern_def && options.save_space
 166        && ! (opt & OPTsubclassless) && tys == #[])
 167       gen_class_destructor(id,#[],0,NOty,qual,opt,false);
 168
 169    for (int i = 0; i < arity; i++)
 170    {  match (terms[i])
 171       {  ONEcons { name, cons_ty, ty = ty as ! NOty, opt = my_opt,
 172                    qual = cons_qual,
 173                    alg_ty = TYCONty(DATATYPEtycon { tyvars ... }, _) ... }:
 174          {  Ty arg_ty = apply_ty(cons_ty, tys);
 175             if (qual & QUALcollectable)
 176                gen_gc_trace(extern_def, id, tyvars, tys, name, arg_ty,
 177                             polyty, opt, inherits, has_gc);
 178             if (qual & QUALpersistent)
 179                gen_persistence(extern_def, id, tyvars, tys, name, arg_ty,
 180                                polyty, opt, inherits, has_persistence);
 181             if (! extern_def && options.save_space && tyvars == #[]) {
 182                Bool save = print_default_value;
 183                print_default_value = false;
 184                gen_class_constructor(id,#[],name,unit,arg,opt,arg_ty,false,cons_qual);
 185                gen_datatype_constructor(id,#[],name,unit,arg,opt|my_opt,arg_ty,false,cons_qual);
 186                gen_class_destructor(id,#[],name,ty,qual,opt|my_opt,false);
 187                print_default_value = save;
 188             }
 189          }
 190       |  _: /* skip */
 191       }
 192    }
 193 }
 194
 195 ///////////////////////////////////////////////////////////////////////////////
 196 //
 197 //  Method to generate the GC tracing method for one subclass
 198 //
 199 ///////////////////////////////////////////////////////////////////////////////
 200 Bool DatatypeCompiler::gen_gc_trace
 201    (Bool extern_def, Id id, TyVars tyvars, Tys tys, Id name,
 202     Ty ty, Ty alg_ty, int opt, Inherits inherits, Bool has_gc)
 203 {
 204    if (extern_def && tys == #[]) return false;
 205
 206    Bool is_base = (name == 0) || (opt & OPTsubclassless);
 207    if (is_base)
 208       pr ("%^%/%^// GC tracing method for base class of %s%P%^%/", id, tys);
 209    else
 210       pr ("%^%/%^// GC tracing method for %s%P::%S %T%^%/", id, tys, name, ty);
 211    pr ("%^void %s_%S%P::trace(GC * _gc_)%s\n",
 212        (is_base ? "a" : id), (is_base ? id : name), tys,(extern_def ? ";" : ""));
 213
 214    if (extern_def) return false;
 215
 216    pr ("%^{%+");
 217    // Generate code for to call trace methods of superclasses.
 218    if (is_base)
 219    {  for_each (Inherit, i, inherits)
 220       {  match (i)
 221          { { super_class, qualifiers ... }:
 222            {  if ((qualifiers & QUALcollectable) || is_gc_ty(super_class))
 223               {  Ty super_ty = apply_ty(mkpolyty(super_class,tyvars), tys);
 224                  pr ("%^%t::trace(_gc_);", super_ty, "");
 225                  has_gc = true;
 226               }
 227            }
 228          }
 229       }
 230    }
 231
 232    // Generate code for to invoke trace on each collectable component
 233    if (name != 0)
 234    {  Bool is_array_con = is_array_constructor(name);
 235       if (has_gc) pr("%^a_%s%P::trace(_gc_);",id,tys);
 236       if (is_array_con) ty = TYCONty(ARRAYtycon(IDexp("len_")),#[ty]);
 237       match (ty)
 238       {  TYCONty(TUPLEtycon, tys):
 239          {  int i = 1;
 240             for_each(Ty, t, tys) { gen_trace(t, index_of(i)); i++; }
 241          }
 242       |  TYCONty(RECORDtycon (labs,_), tys):
 243          {  Ids l; Tys t;
 244             for(l = labs, t = tys; l; l = l->#2, t = t->#2)
 245                gen_trace(t->#1,l->#1);
 246          }
 247       |  ty: {  gen_trace(ty,name); }
 248       }
 249    }
 250    pr ("%-%^}\n\n");
 251
 252    return has_gc;
 253 }
 254
 255 ///////////////////////////////////////////////////////////////////////////////
 256 //
 257 //  Generate tracing code for one component.
 258 //
 259 ///////////////////////////////////////////////////////////////////////////////
 260 void DatatypeCompiler::gen_trace (Ty ty, Id exp)
 261 {  pr ("%^");
 262    match (deref(ty))
 263    {  ARRAYty(ty,bound) | bound != NOexp:
 264       {  if (is_gc_ty(ty))
 265             pr ("{  int _i_;%+"
 266                    "%^for (_i_ = (%e) - 1; _i_ >= 0; --_i_)%+"
 267                       "%^%S[_i_] = (%t)_gc_->trace(%S[_i_]);"
 268                    "%-%-%^}",
 269                 bound, exp, ty, "", exp);
 270       }
 271    |  ty: {  if (is_gc_ty(ty))
 272              {  if (is_pointer_ty(ty))
 273                    pr("%S = (%t)_gc_->trace(%S); ", exp, ty, "", exp);
 274                 else
 275                    pr("%S.trace(_gc_); ", exp);
 276              }
 277           }
 278    }
 279    pr ("// %T\n", deref_all(ty));
 280 }
 281
 282 ///////////////////////////////////////////////////////////////////////////////
 283 //
 284 //  Method to generate the persistence read/write methods for one subclass
 285 //
 286 ///////////////////////////////////////////////////////////////////////////////
 287 Bool DatatypeCompiler::gen_persistence
 288    (Bool extern_def, Id id, TyVars tyvars, Tys tys, Id name,
 289     Ty ty, Ty alg_ty, int opt, Inherits inherits, Bool has_persistence)
 290 {
 291    if (extern_def) return false;
 292
 293    Bool is_base = (name == 0) || (opt & OPTsubclassless);
 294    if (is_base)
 295       pr ("%^%/%^// Persistence read/write methods for base class of %s%P%^%/",
 296           id, tys);
 297    else
 298       pr ("%^%/%^// Persistence read/write methods for %s%P::%S %T%^%/",
 299           id, tys, name, ty);
 300
 301    Id prefix = is_base ? "a" : id;
 302    Id suffix = is_base ? id : name;
 303
 304    Pid pid = lookup_persistent(id, tys);
 305    Id  object_type = temp_vars.new_label();
 306    pr ("%^static PObjectType %s(%Q \"(%s%P::%s)\");"
 307        "%^const PObjectType& %s_%S%P::persist_type_id() const { return %s; }",
 308        object_type, pid, id, tys, (name ? name : "base_class"),
 309        prefix, suffix, tys, object_type
 310       );
 311
 312    // base class cannot have its own object factory
 313    if (! is_base)
 314       pr ("%^static PObjectFactory< %s_%S%P > %s(%s);\n",
 315           prefix, suffix, tys, temp_vars.new_label(), object_type);
 316
 317    pr ("%^Pistream& %s_%S%P::persist_read  (Pistream& _f_)\n",
 318        prefix, suffix, tys, inherits);
 319    has_persistence =
 320       gen_persist_IO_body(id,tyvars,tys,name,ty,">>",inherits,has_persistence);
 321    pr ("%^Postream& %s_%S%P::persist_write (Postream& _f_) const\n",
 322        prefix, suffix, tys, inherits);
 323    has_persistence =
 324       gen_persist_IO_body(id,tyvars,tys,name,ty,"<<",inherits,has_persistence);
 325    return has_persistence;
 326 }
 327
 328 ///////////////////////////////////////////////////////////////////////////////
 329 //
 330 //  Method to generate the persistence read/write method body.
 331 //
 332 ///////////////////////////////////////////////////////////////////////////////
 333 Bool DatatypeCompiler::gen_persist_IO_body
 334    (Id id, TyVars tyvars, Tys tys, Id name, Ty ty, Id io, Inherits inherits,
 335     Bool has_persistence)
 336 {  Id read_or_write = io[0] == '>' ? "read" : "write";
 337    pr ("%^{%+");
 338    if (name != 0)
 339    {  if (is_array_constructor(name))
 340          ty = TYCONty(ARRAYtycon(IDexp("len_")),#[ty]);
 341       if (has_persistence)
 342          pr ("%^a_%s%P::persist_%s(_f_);", id, tys, read_or_write);
 343       match (deref ty)
 344       {  TYCONty(TUPLEtycon, tys):
 345          {  int i = 1;
 346             for_each(Ty, t, tys) { gen_persist_IO(t, index_of(i), io); i++; }
 347          }
 348       |  TYCONty(RECORDtycon (labs,_), tys):
 349          {  Ids l; Tys t;
 350             for(l = labs, t = tys; l; l = l->#2, t = t->#2)
 351                gen_persist_IO(t->#1,l->#1,io);
 352          }
 353       |  ty: { gen_persist_IO(ty,name,io); }
 354       }
 355    } else {
 356       // generate base class persistence calls.
 357       for_each(Inherit, i, inherits)
 358       {  match (i)
 359          { { super_class, qualifiers ... }:
 360            {  if ((qualifiers & QUALpersistent) ||
 361                   has_qual(QUALpersistent,super_class))
 362               {  Ty super_ty = apply_ty(mkpolyty(super_class,tyvars), tys);
 363                  pr ("%^%t::persist_%s(_f_);", super_ty, "", read_or_write);
 364                  has_persistence = true;
 365               }
 366            }
 367          }
 368       }
 369    }
 370
 371    pr ("%-%^}\n\n");
 372    return has_persistence;
 373 }
 374
 375 ///////////////////////////////////////////////////////////////////////////////
 376 //
 377 //  Method to generate a persistence read/write call.
 378 //
 379 ///////////////////////////////////////////////////////////////////////////////
 380 void DatatypeCompiler::gen_persist_IO(Ty ty, Id exp, Id io)
 381 {  Bool is_reading = io[0] == '>';
 382
 383    match (deref_all(ty))
 384    {  ARRAYty(ty,bound) | bound != NOexp:
 385       {  pr ("%^{  int _i_;%+"
 386                 "%^for (_i_ = (%e) - 1; _i_ >= 0; --_i_)%+",
 387                 bound
 388             );
 389         if (is_reading && is_datatype(ty))
 390            pr("%^%S[_i_] = (%t)read_object(_f_); ", exp, ty, "");
 391         else
 392            pr("%^_f_ %s %S[_i_]; ", io, exp);
 393         pr ("%-%-%^}");
 394       }
 395    |  ty: {  if (is_reading && is_datatype(ty))
 396                 pr("%^%S = (%t)read_object(_f_); ", exp, ty, "");
 397              else
 398                 pr("%^_f_ %s %S; ", io, exp);
 399           }
 400    }
 401    pr ("// %T\n", deref_all(ty));
 402 }