Subversion Repositories tendra.SVN

Rev

Rev 5 | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 5 Rev 6
Line -... Line 1...
- 
 
 1 
/*
- 
 
 2 
 * Copyright (c) 2002-2005 The TenDRA Project <http://www.tendra.org/>.
- 
 
 3 
 * All rights reserved.
- 
 
 4 
 *
- 
 
 5 
 * Redistribution and use in source and binary forms, with or without
- 
 
 6 
 * modification, are permitted provided that the following conditions are met:
- 
 
 7 
 *
- 
 
 8 
 * 1. Redistributions of source code must retain the above copyright notice,
- 
 
 9 
 *    this list of conditions and the following disclaimer.
- 
 
 10 
 * 2. Redistributions in binary form must reproduce the above copyright notice,
- 
 
 11 
 *    this list of conditions and the following disclaimer in the documentation
- 
 
 12 
 *    and/or other materials provided with the distribution.
- 
 
 13 
 * 3. Neither the name of The TenDRA Project nor the names of its contributors
- 
 
 14 
 *    may be used to endorse or promote products derived from this software
- 
 
 15 
 *    without specific, prior written permission.
- 
 
 16 
 *
- 
 
 17 
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
- 
 
 18 
 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
- 
 
 19 
 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
- 
 
 20 
 * PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
- 
 
 21 
 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- 
 
 22 
 * EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- 
 
 23 
 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
- 
 
 24 
 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
- 
 
 25 
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
- 
 
 26 
 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
- 
 
 27 
 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- 
 
 28 
 *
- 
 
 29 
 * $Id$
- 
 
 30 
 */
1 
/*
 31 
/*
2 
    		 Crown Copyright (c) 1997
 32 
    		 Crown Copyright (c) 1997
3 
 
 33 
 
4 
    This TenDRA(r) Computer Program is subject to Copyright
 34 
    This TenDRA(r) Computer Program is subject to Copyright
5 
    owned by the United Kingdom Secretary of State for Defence
 35 
    owned by the United Kingdom Secretary of State for Defence
Line 55... Line 85...
55 
 
 85 
 
56 
#define crit_inline 50
 86 
#define crit_inline 50
57 
#define decs_allowed 4
 87 
#define decs_allowed 4
58 
#define decs_with_apply 0
 88 
#define decs_with_apply 0
59 
 
 89 
 
60 
static int  complexity PROTO_S ((exp e, int count, int newdecs));
 90 
static int  complexity(exp e, int count, int newdecs);
61 
 
 91 
 
62 
/* applies complexity to the members of a list */
 92 
/* applies complexity to the members of a list */
63 
static int  sbl
 93 
static int  sbl
64 
    PROTO_N ( (e, count, newdecs) )
 - 
 
65 
    PROTO_T ( exp e X int count X int newdecs )
 94 
(exp e, int count, int newdecs)
66 
{
 95 
{
67 
  int  c = complexity (e, count,newdecs);
 96 
  int  c = complexity(e, count,newdecs);
68 
  if (c < 0)
 97 
  if (c < 0)
69 
    return (c);
 98 
    return(c);
70 
  if (last (e))
 99 
  if (last(e))
71 
    return (c);
 100 
    return(c);
72 
  return (sbl (bro (e), c, newdecs));
 101 
  return(sbl(bro(e), c, newdecs));
73 
}
 102 
}
74 
 
 103 
 
75 
static int  complexity
 104 
static int  complexity
76 
    PROTO_N ( (e, count, newdecs) )
 - 
 
77 
    PROTO_T ( exp e X int count X int newdecs )
 105 
(exp e, int count, int newdecs)
78 
{
 106 
{
79 
  unsigned char  n = name (e);
 107 
  unsigned char  n = name(e);
80 
  if (count < 0 || newdecs >= decs_allowed)
 108 
  if (count < 0 || newdecs >= decs_allowed)
81 
    return (-1);
 109 
    return(-1);
82 
  if (son(e) == nilexp) return count;
 110 
  if (son(e) == nilexp) return count;
83 
  switch (n) {
 111 
  switch (n) {
84 
  	case apply_tag: {
 112 
  	case apply_tag: {
85 
  	   if (newdecs > decs_with_apply)
 113 
  	   if (newdecs > decs_with_apply)
86 
		 return -1;
 114 
		 return -1;
Line 91... Line 119...
91 
	  if (isloadparam(son(e)))
 119 
	  if (isloadparam(son(e)))
92 
	    return sbl(son(e), count-1, newdecs);
 120 
	    return sbl(son(e), count-1, newdecs);
93 
	  else
 121 
	  else
94 
	    return sbl(son(e), count-1, newdecs+1);
 122 
	    return sbl(son(e), count-1, newdecs+1);
95 
        case top_tag: case clear_tag: case prof_tag: return count;
 123 
        case top_tag: case clear_tag: case prof_tag: return count;
96 
	case case_tag: return (complexity (son (e), count - 1, newdecs));
 124 
	case case_tag: return(complexity(son(e), count - 1, newdecs));
97 
	case name_tag: case string_tag: case env_offset_tag:
 125 
	case name_tag: case string_tag: case env_offset_tag:
98 
        case general_env_offset_tag:
 126 
        case general_env_offset_tag:
99 
               return (count - 1);
 127 
               return(count - 1);
100 
	case labst_tag: return (complexity (bro (son (e)), count,
 128 
	case labst_tag: return(complexity(bro(son(e)), count,
101 
                        newdecs));
 129 
                        newdecs));
102 
	case solve_tag: case seq_tag: return sbl(son(e), count, newdecs);
 130 
	case solve_tag: case seq_tag: return sbl(son(e), count, newdecs);
103 
	default: return (sbl (son (e), count - 1, newdecs));
 131 
	default: return(sbl(son(e), count - 1, newdecs));
104 
  }
 132 
  }
105 
}
 133 
}
106 
 
 134 
 
107 
int inlinechoice
 135 
int inlinechoice
108 
    PROTO_N ( (t, def, total) )
 - 
 
109 
    PROTO_T ( exp t X exp def X int total )
 136 
(exp t, exp def, int total)
110 
{
 137 
{
111 
	/* delivers 0 if no uses of this proc can be inlined.
 138 
	/* delivers 0 if no uses of this proc can be inlined.
112 
	   delivers 1 if this use cannot be inlined
 139 
	   delivers 1 if this use cannot be inlined
113 
	   delivers 2 if this use can be inlined.
 140 
	   delivers 2 if this use can be inlined.
114 
	*/
 141 
	*/
Line 116... Line 143...
116 
  exp fpars;
 143 
  exp fpars;
117 
  int newdecs = 0;
 144 
  int newdecs = 0;
118 
  shape shdef = pt(def) /* Oh, yes it is! */;
 145 
  shape shdef = pt(def) /* Oh, yes it is! */;
119 
  UNUSED(total);
 146 
  UNUSED(total);
120 
 
 147 
 
121 
  if (!eq_shape(sh(father(t)), shdef) ) {
 148 
  if (!eq_shape(sh(father(t)), shdef)) {
122 
      /* shape required by application is different from definition */
 149 
      /* shape required by application is different from definition */
123 
	return 1;
 150 
	return 1;
124 
  }
 151 
  }
125 
 
 152 
 
126 
  apars = t; /* only uses are applications */
 153 
  apars = t; /* only uses are applications */
127 
  fpars = son(def);
 154 
  fpars = son(def);
128 
 
 155 
 
129 
  for(;;) {
 156 
  for (;;) {
130 
     if (name(fpars)!=ident_tag || !isparam(fpars)) {
 157 
     if (name(fpars)!=ident_tag || !isparam(fpars)) {
131 
	if (!last(apars)) return 1;
 158 
	if (!last(apars)) return 1;
132 
      	break;
 159 
      	break;
133 
     }
 160 
     }
134 
 
 161 
 
Line 137... Line 164...
137 
 
 164 
 
138 
     switch (name(apars)) {
 165 
     switch (name(apars)) {
139 
      case val_tag: case real_tag: case string_tag: case name_tag:
 166 
      case val_tag: case real_tag: case string_tag: case name_tag:
140 
      	   break;
 167 
      	   break;
141 
      case cont_tag: {
 168 
      case cont_tag: {
142 
      	   if (name(son(apars))==name_tag && isvar(son(son(apars))) &&
 169 
      	   if (name(son(apars)) ==name_tag && isvar(son(son(apars))) &&
143 
      	        		!isvar(fpars) ) break;
 170 
      	        		!isvar(fpars))break;
144 
      	   } /* ... else continue */
 171 
      	   } /* ... else continue */
145 
      default: newdecs++;
 172 
      default: newdecs++;
146 
     }
 173 
     }
147 
     fpars = bro(son(fpars));
 174 
     fpars = bro(son(fpars));
148 
  }
 175 
  }