prop-src/selector.pcc

   1 ///////////////////////////////////////////////////////////////////////////////
   2 //
   3 //  This file implements the selection/projection code generation.
   4 //
   5 ///////////////////////////////////////////////////////////////////////////////
   6
   7 #include <string.h>
   8 #include <limits.h>
   9 #include <stdlib.h>
  10 #include <AD/strings/quark.h>
  11 #include "ir.ph"
  12 #include "ast.ph"
  13 #include "matchcom.ph"
  14 #include "type.h"
  15 #include "options.h"
  16
  17 ///////////////////////////////////////////////////////////////////////////////
  18 //
  19 //  Method to compute the proper selector into a component argument
  20 //  of a constructor
  21 //
  22 ///////////////////////////////////////////////////////////////////////////////
  23 Exp select(Exp e, Cons c, Ty t) { return SELECTORexp(e,c,t); }
  24
  25 ///////////////////////////////////////////////////////////////////////////////
  26 //
  27 //  Method to compute the proper selector into a component argument
  28 //  of a constructor
  29 //
  30 ///////////////////////////////////////////////////////////////////////////////
  31 Exp MatchCompiler::make_select
  32     ( Exp  e,             // the expression
  33       Cons c,             // constructor
  34       Ty   expected_ty,   // expected type (if applicable)
  35       Id   component      // component to extract
  36     )
  37 {  Exp  result         = e;
  38    Bool use_projection = component != 0;
  39    match (c)
  40    {  ONEcons { name,
  41                 alg_ty = DATATYPEty({ qualifiers ... },_),
  42                 ty ...
  43               } | qualifiers & QUALview:   // A view
  44       {  Ty comp_ty = ty;
  45          if (component)
  46          {  match (ty)
  47             {  TUPLEty _:  { use_projection = false;
  48                              comp_ty = component_ty(ty,atol(component+1)); }
  49             |  RECORDty (_,_,_):
  50                            { use_projection = false;
  51                              comp_ty = component_ty(ty,component); }
  52             |  ty:         { comp_ty = ty; }
  53             }
  54          }
  55          Exp selector_exp = default_val(comp_ty);
  56          if (selector_exp == NOexp)
  57          {  error ("%Lview accessor is undefined for constructor %s\n", name);
  58             return NOexp;
  59          }
  60          result = subst(selector_exp,&e);
  61       }
  62    |  ONEcons { name,
  63                 alg_ty = DATATYPEty({ opt, id, tyvars ... },_),
  64                 tag,
  65                 opt = this_opt,
  66                 ty ...
  67               }:      // Normal datatype
  68       {  Bool simple;
  69
  70          match (ty)
  71          {  TYCONty(TUPLEtycon || RECORDtycon _,_): { simple = false; }
  72          |  _:                                      { simple = true; }
  73          }
  74          if (is_array_constructor(name)) simple = false;
  75
  76          Id nm = mangle(name);
  77
  78          if (this_opt & OPTunboxed) {
  79             result = APPexp(IDexp(#"deref_" + name), e);
  80          } else {
  81             if ((opt & OPTtaggedpointer) && tag != 0)
  82                e = APPexp(IDexp(#"derefp"), e);
  83             if (opt & OPTsubclassless) { // No subclass hierarchy
  84                if (simple) result = ARROWexp(e,nm);
  85                else        result = DEREFexp(e);
  86             } else {                          // with subclass hierachy
  87                // Dereference the pointer if the pointer needs to be stripped
  88                // of the tag.
  89                Exp downcast_exp = NOexp;
  90                if (options.inline_casts && tyvars == #[]) {
  91                      downcast_exp =
  92                         CASTexp(mkptrty(mkidty(id + #"_" + nm,#[])),e);
  93                } else if (options.inline_casts && expected_ty != NOty) {
  94                    match (deref_all(expected_ty))
  95                    {  TYCONty(_,tys):
  96                       {  downcast_exp =
  97                             CASTexp(mkptrty(mkidty(id + #"_" + nm,tys)),e);
  98                       }
  99                    |  _: { bug("%Lmake_select"); }
 100                    }
 101                } else {
 102                   downcast_exp = APPexp(IDexp(#"_" + nm),e);
 103                }
 104                if (simple) result = ARROWexp(downcast_exp,nm);
 105                else        result = DEREFexp(downcast_exp);
 106             }
 107          }
 108       }
 109    |  _: // skip
 110    }
 111    return use_projection ? DOTexp(result,component) : result;
 112 }
 113
 114 ///////////////////////////////////////////////////////////////////////////////
 115 //
 116 //  Method to compute the tag name of a constructor
 117 //
 118 ///////////////////////////////////////////////////////////////////////////////
 119 Exp MatchCompiler::tag_name_of(Cons cons, Bool normalized)
 120 {
 121    match (cons)
 122    {  ONEcons { name,
 123                 alg_ty = DATATYPEty({ qualifiers ... },_),
 124                 view_predicate ... }
 125         | qualifiers & QUALview:
 126       {  if (view_predicate == NOexp)
 127          {  error("%Lview case for constructor %s is undefined\n",name);
 128             return NOexp;
 129          }
 130          return view_predicate;
 131       }
 132    |  ONEcons { name, ty = NOty, alg_ty = DATATYPEty({ arg ... },_) ... }
 133          | arg == 0:
 134       {  return IDexp(mangle(name)); }
 135    |  ONEcons { name, ty = NOty, alg_ty = DATATYPEty({ arg ... },_) ... }:
 136       {  return CASTexp(integer_ty,IDexp(mangle(name))); }
 137    |  ONEcons { name, alg_ty = DATATYPEty({ id, arg, unit, tyvars ... },_)
 138                 ... }
 139          | ! normalized && tyvars == #[] && arg > 1:
 140       {  return IDexp(Quark("a_",id,"::tag_",mangle(name)));
 141       }
 142    |  ONEcons { alg_ty = DATATYPEty({ arg, unit ... },_) ... }:
 143       {  int this_tag = tag_of(cons) + (normalized ? unit : 0);
 144          return LITERALexp(INTlit(this_tag)); }
 145    |  _: { return NOexp; }
 146    }
 147 }
 148
 149 ///////////////////////////////////////////////////////////////////////////////
 150 //
 151 //  Method to extract the tag from a term
 152 //
 153 ///////////////////////////////////////////////////////////////////////////////
 154 Exp MatchCompiler::untag(Exp e, Ty ty)
 155 {  match (deref(ty))
 156    {  DATATYPEty ({ view_match, qualifiers ... }, _)
 157         | qualifiers & QUALview: // a view
 158       {  if (view_match == NOexp)
 159          {  error("%Lview test for datatype %T is undefined\n", ty);
 160             return NOexp;
 161          }
 162          return subst(view_match,&e);
 163       }
 164    |  DATATYPEty ({ arg ... },_) | arg > 0:
 165       { return APPexp(IDexp(#"untag"),e); }
 166    |  _: { return e; }
 167    }
 168 }
 169
 170 ///////////////////////////////////////////////////////////////////////////////
 171 //
 172 //  Method to extract the tag from a term (optimized for arg/unit constructors)
 173 //
 174 ///////////////////////////////////////////////////////////////////////////////
 175 Exp MatchCompiler::untag_one (Exp e, Cons c)
 176 {  match (c)
 177    {  ONEcons { name,
 178                 alg_ty = DATATYPEty ({ view_match, qualifiers ... }, _) ... }
 179         | qualifiers & QUALview: // a view
 180       {  if (view_match == NOexp)
 181          {  error("%Lview test for constructor %s is undefined\n",name);
 182             return NOexp;
 183          }
 184          return subst(view_match,&e);
 185       }
 186    |  ONEcons { ty = NOty, alg_ty = DATATYPEty ({ arg ... },_) ... }
 187         | arg == 0:
 188       { return e; }
 189    |  ONEcons { ty = NOty ... }:
 190       { return CASTexp(integer_ty,e); }
 191    |  ONEcons { alg_ty = DATATYPEty({ qualifiers, opt ... }, _) ... }:
 192       {  if (opt & OPTtaggedpointer) e = APPexp(IDexp(#"untagp"),e);
 193          else if (opt & OPTtagless) e = LITERALexp(INTlit(0));
 194          else e = ARROWexp(e,#"tag__");
 195          return e;
 196       }
 197    |  _:  { return NOexp; }
 198    }
 199 }