TypeValRes.cxx

Go to the documentation of this file.

/**************************************************************************
 *
 * Copyright (C) 2008, Johns Hopkins University.
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or
 * without modification, are permitted provided that the following
 * conditions are met:
 *
 *   - Redistributions of source code must contain the above 
 *     copyright notice, this list of conditions, and the following
 *     disclaimer. 
 *
 *   - Redistributions in binary form must reproduce the above
 *     copyright notice, this list of conditions, and the following
 *     disclaimer in the documentation and/or other materials 
 *     provided with the distribution.
 *
 *   - Neither the names of the copyright holders nor the names of any
 *     of any contributors may be used to endorse or promote products
 *     derived from this software without specific prior written
 *     permission. 
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *
 **************************************************************************/

#include <assert.h>
#include <stdint.h>
#include <stdlib.h>
#include <dirent.h>
#include <fstream>
#include <iostream>
#include <string>
#include <sstream>

#include <libsherpa/UExcept.hxx>

#include "UocInfo.hxx"
#include "AST.hxx"
#include "Type.hxx"
#include "TypeInfer.hxx"
#include "TypeScheme.hxx"
#include "TypeMut.hxx"
#include "Typeclass.hxx"
#include "inter-pass.hxx"
#include "Unify.hxx"

using namespace boost;
using namespace sherpa;
using namespace std;


#define CHKEXP(itsExpansive, exp) do {\
bool ans = (exp);\
if (ans == true) \
 (itsExpansive) = true; \
}while (0)
           
// Shap has tripped on the term "expansive" for years. What
// "expansive" means is that term substitution might result in a term
// that requires more evaluation steps than the original term. That
// is, it violates the downward deconstructive induction intuition. A
// discussion of the term "expansive" can probably be found in the ML
// book or the value restriction paper.

// FIX: I am not clear why an identifier is intrinsically considered
// expansive, since many identifiers are bound to compile-time deeply 
// immutable values and these can be viewed as term
// substitutions. Handling them in this way would let many of the
// special cases below collapse.
// Swaroop: Identifiers are intrinsically NOT expansive. This code
// only detects applications as expansive. I think I am missing your
// point.

bool
isExpansive(std::ostream& errStream, 
            shared_ptr<const TSEnvironment > gamma,
            shared_ptr<const AST> ast) 
{
  bool itsExpansive = false;
  
  switch (ast->astType) {
  case at_intLiteral:
  case at_floatLiteral:
  case at_boolLiteral:
  case at_charLiteral:
  case at_stringLiteral:
  case at_lambda:
  case at_sizeof:
  case at_bitsizeof:
    {
      itsExpansive = false;
      break;
    }

  case at_apply:
    {
      itsExpansive = true;
      break;
    }
  case at_setbang:
    {
      itsExpansive = true;
      break;
    }

  case at_allocREF:
  case at_mkClosure:
  case at_ident:
  case at_fill:
  case at_usesel:
  case at_dup:
  case at_docString:
    {
      itsExpansive = false;
      break;
    }

  case at_letStar:
  case at_let:
  case at_letrec:
    {
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(0)));
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(1)));
      break;
    }

  case at_copyREF:
  case at_setClosure:
  case at_letbindings:
  case at_loopbindings:
    {
      for (size_t i=0; !itsExpansive && i < ast->children.size(); i++)
        CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                         ast->child(i)));
      break;
    }

  case at_letbinding:
    {
      itsExpansive = isExpansive(errStream, gamma,
                                 ast->child(1));
      break;
    }

  case at_loopbinding:
    {
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(1)));
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(2)));
      break;
    }

  case at_try:
  case at_throw:
  case at_labeledBlock:
  case at_return_from:
#if 0
    {
      itsExpansive = true;
      break;
    }
#endif
  case at_loop:
  case at_looptest:
  case at_begin:
    {
      for (size_t i=0; !itsExpansive && i < ast->children.size(); i++)
        CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                         ast->child(i)));
      break;
    }

  case at_suspend:
    {
      itsExpansive = isExpansive(errStream, gamma,
                                  ast->child(1));
      break;
    }

  case at_typeAnnotation:
    {
      itsExpansive = isExpansive(errStream, gamma,
                                  ast->child(0));
      break;
    }

  case at_if:
    {
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(0)));
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(1)));
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(2)));
      break;
    }

  case at_when:
  case at_unless:
    {
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(0)));
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(1)));
      break;
    }

  case at_cond:
    {
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(0)));
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(1)));
      break;
    }

  case at_cond_legs:
    {
      for (size_t i=0; !itsExpansive && i < ast->children.size(); i++)
        CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                         ast->child(i)));
      break;
    }

  case at_cond_leg:
    {
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(1)));
      break;
    }
    
  case at_condelse:
    {
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(0)));
      break;
    }

  case at_uswitch:
    {
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(2)));
      if (ast->child(3)->astType != at_Null)
        CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                         ast->child(3)));
      break;
    }

  case at_otherwise:
  case at_usw_leg:
    {
      // expr is at the same position
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(1)));
      break;
    }
    
  case at_unit:
    break;

  case at_MakeVector:             
    {
      /* Make vector takes a lambda as the second argument, but
         implicitely performs application on it possibly 
         multiple times */ 
      itsExpansive = true;        
      break;
    }
    
  case at_letGather:
  case at_vector:
  case at_array:
  case at_mkArrayRef:
#ifdef HAVE_INDEXABLE_LENGTH_OPS
  case at_array_length:
  case at_array_ref_length:
  case at_vector_length:
#endif
  case at_array_nth:
  case at_array_ref_nth:
  case at_vector_nth:
  case at_inner_ref:
  case at_deref:
  case at_usw_legs:
  case at_and:
  case at_or:
    {
      for (size_t i=0; !itsExpansive && i < ast->children.size(); i++)
        CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                         ast->child(i)));
      break;
    }
  case at_nth:
    // Shouldn't get here
    assert(false);
    break;
    
  case at_fqCtr:
    {
      itsExpansive = false;
      break;
    }

  case at_select:
  case at_sel_ctr:
    {
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       ast->child(0)));      
      break;
    }

  case at_struct_apply:
  case at_object_apply:
  case at_ucon_apply:
    {
      for (size_t i=1; !itsExpansive && i < ast->children.size(); i++)
        CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                         ast->child(i)));
      break;
    }
   
  case at_container:
    {
        CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                         ast->child(1)));
        break;
    }
    
  case at_tcapp:
    {
      // Special case to facilitate generalization 
      // of instance declarations
      itsExpansive = false;
      break;
    }
    
  case at_unboxedCat:
  case at_boxedCat:
  case at_oc_closed:
  case at_oc_open:
  case at_opaqueCat:
  case agt_category:
  case at_module:
  case at_define:
  case at_recdef:
  case at_defrepr:
  case at_defstruct:
  case at_defunion:
  case at_declrepr:
  case at_declstruct:
  case at_declunion:
  case at_declares:
  case at_declare:
  case at_tvlist:
  case at_constructors:
  case at_constructor:
  case at_fields:
  case at_field:
  case at_fieldType:
  case at_methdecl:
  case at_bitfieldType:
  case at_arrayRefType:
  case at_byRefType:
  case at_boxedType:
  case at_exceptionType:
  case at_dummyType:
  case at_unboxedType:
  case at_fn:
  case at_primaryType:
  case at_arrayType:
  case at_vectorType:
  case at_mutableType:
  case at_constType:
  case at_typeapp:
  case at_qualType:
  case at_methType:
  case at_constraints:
  case at_identPattern:
  case at_Null:
  case at_AnyGroup:
  case agt_literal:
  case agt_tvar:
  case agt_var:
  case agt_definition:
  case agt_type_definition:
  case agt_value_definition:
  case agt_uselhs:
  case agt_type:
  case agt_openclosed:
    //case at_reprbody:
    //case at_reprcase:
    //case at_reprcaselegR:
    //case at_reprtag:
    //case agt_reprbodyitem:
  case at_reprctrs:
  case at_reprctr:
  case at_reprrepr:
  case agt_expr:
  case agt_expr_or_define:
  case agt_eform:
  case at_proclaim:
  case at_interface:
  case at_importAs:
  case at_provide:
  case at_import:
  case at_ifsel:
  case agt_CompilationUnit:
  case at_defexception:
  case at_deftypeclass:
  case at_tcdecls:
  case at_tyfn:
  case at_method_decls:
  case at_method_decl:
  case at_definstance:
  case at_tcmethods:
  case at_tcmethod_binding:
  case agt_tc_definition:
  case agt_if_definition:
  case agt_ow:
  case agt_qtype:
  case agt_fielditem:
  case at_ifident:
  case at_argVec:
  case at_fnargVec:
  case at_localFrame:
  case at_frameBindings:
  case at_identList:
  case agt_ucon:
    {
      errStream << ast->loc << ": "
                << "Internal Compiler Error." 
                << "Unexpected ast-type " << ast->tagName()
                << " obtained by isExpansive() routine."
                << std::endl;
      itsExpansive = true; // be conservative ...
      break;
    }
  }
  return itsExpansive;
}


// Is this AST a Syntactic value? 
// Permitted cases are literals, functions, value constructors that
// take no arguments, and the special case of array-length.
// This function must only be passed an expresssion AST.
// It returns false (rather than asserting false) if an unexpected AST
// like type-AST, group AST or at_Null is passed.
bool
isAValue(shared_ptr<const AST> ast) 
{
  switch (ast->astType) {
  case at_unit:
  case at_boolLiteral:
  case at_charLiteral:
  case at_intLiteral:
  case at_floatLiteral:
  case at_stringLiteral:
  case at_lambda:
  case at_sizeof:
  case at_bitsizeof:
  case at_mkClosure:
  case at_ident:
  case at_usesel:
    return true;
    
  case at_typeAnnotation:
    return isAValue(ast->child(0));
    
#ifdef HAVE_INDEXABLE_LENGTH_OPS
  case at_array_length:
    // This should have just been TRUE, since it always reduces to a
    // constant.
    return isAValue(ast->child(0));
#else
  case at_select:
    {
      shared_ptr<Type> t = ast->child(0)->symType->getBareType();
      if (t->typeTag == ty_array)
        return true;
      else
        return false;
    }
#endif
    
  default:
    return false;
  }
}

bool
isExpansive(std::ostream& errStream, 
            shared_ptr<const TSEnvironment > gamma,
            shared_ptr<Type> typ) 
{
  bool itsExpansive = false;
  shared_ptr<Type> t = typ->getType();
  
  if (t->mark & MARK_PREDICATE)
    return itsExpansive;

  t->mark |= MARK_PREDICATE;

  switch(t->typeTag) {
  case ty_unit:
  case ty_bool:
  case ty_char:
  case ty_string:
  case ty_int8:
  case ty_int16:
  case ty_int32:
  case ty_int64:
  case ty_uint8:
  case ty_uint16:
  case ty_uint32:
  case ty_uint64:
  case ty_word:
  case ty_float:
  case ty_double:
  case ty_quad:
  case ty_field:
    
  case ty_tvar:
  case ty_dummy:
  case ty_kvar:
  case ty_kfix:
    
#ifdef KEEP_BF
  case ty_bitfield:
#endif
  case ty_fn:
  case ty_method:
  case ty_typeclass:
    break;

  case ty_tyfn:
  case ty_fnarg:
  case ty_byref:
    assert(false); // Function case breaks
    break;

  case ty_letGather:
  case ty_array:
  case ty_array_ref:
  case ty_vector:
    for (size_t i=0; i<t->components.size(); i++) 
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       t->CompType(i)));
    break;

  case ty_structv:
  case ty_structr:
  case ty_unionv: 
  case ty_unionr:
  case ty_uconv:
  case ty_uconr:
  case ty_uvalv:
  case ty_uvalr:
  case ty_mbFull:
  case ty_mbTop:
  case ty_pcst:
  case ty_ref:
  case ty_exn:
    {    
      for (size_t i=0; i<t->typeArgs.size(); i++) 
        CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                         t->TypeArg(i)));
    
      for (size_t i=0; i<t->components.size(); i++) 
        CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                         t->CompType(i)));
      break;
    }

  case ty_const:
    {
      CHKEXP(itsExpansive, isExpansive(errStream, gamma,
                                       t->Base()->minimizeMutability()));
      break;
    }
    
  case ty_mutable:
    {
      itsExpansive = true;
      break;
    }
  }
  
  t->mark &= ~MARK_PREDICATE;
  return itsExpansive;
}

---