--- /dev/null
+ SUBROUTINE DIMOID(DEN,RLMO,SSQU,STRI,ATMU,IATM,IWHI,MAPT,INAT,
+ * IATB,L1,L2,M1,M2,NATS,NOSI,NCAT,NSWE)
+C
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+C
+ DIMENSION RLMO(L1,L1),SSQU(L1,L1),STRI(L2),ATMU(NATS),DEN(M2)
+ DIMENSION IATM(NATS,M1),IWHI(M1+NATS),MAPT(M1),INAT(M1+NATS)
+ DIMENSION IATB(NATS,M1)
+C
+ PARAMETER (MXATM=500, MXSH=1000, MXGTOT=5000, MXAO=2047)
+C
+ LOGICAL GOPARR,DSKWRK,MASWRK
+C
+ COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
+ * ZAN(MXATM),C(3,MXATM)
+ COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(400)
+ COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
+ * CF(MXGTOT),CG(MXGTOT),
+ * KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),
+ * KNG(MXSH),KLOC(MXSH),KMIN(MXSH),
+ * KMAX(MXSH),NSHELL
+ COMMON /OPTLOC/ CVGLOC,MAXLOC,IPRTLO,ISYMLO,IFCORE,NOUTA,NOUTB,
+ * MOOUTA(MXAO),MOOUTB(MXAO)
+ COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
+ COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(MXAO)
+C
+C
+ DO 920 II=1,M1
+ INAT(II) = 0
+ 920 CONTINUE
+C
+
+ DO 900 IO = NOUTA+1,NUMLOC
+ IZ = IO - NOUTA
+ DO 895 II=NST,NEND
+ ATMU(II) = 0.0D+00
+ IATM(II,IZ) = 0
+ 895 CONTINUE
+ IFUNC = 0
+ DO 890 ISHELL = 1,NSHELL
+ IAT = KATOM(ISHELL)
+ IST = KMIN(ISHELL)
+ IEN = KMAX(ISHELL)
+ DO 880 INO = IST,IEN
+ IFUNC = IFUNC + 1
+ IF (IAT.LT.NST.OR.IAT.GT.NEND) GOTO 880
+ ZINT = 0.0D+00
+ DO 870 II = 1,L1
+ ZINT = ZINT + RLMO(II,IO)*SSQU(II,IFUNC)
+ 870 CONTINUE
+ ATMU(IAT) = ATMU(IAT) + RLMO(IFUNC,IO)*ZINT
+ 880 CONTINUE
+ 890 CONTINUE
+ IF (MASWRK) WRITE(IW,9010) IZ,(ATMU(II),II=NST,NEND)
+ 900 CONTINUE
+C
+ NOSI = 0
+ DO 700 II=1,M1
+ NO=0
+ DO 720 JJ=1,NAT
+ NO = NO + 1
+ 720 CONTINUE
+ 740 CONTINUE
+ IF (NO.GT.1.OR.NO.EQ.0) THEN
+ NOSI = NOSI + 1
+ IWHI(NOSI) = II
+ ENDIF
+ IF (MASWRK)
+ * WRITE(IW,9030) II,(IATM(J,II),A(IATM(J,II)),J=1,NO)
+ 700 CONTINUE
+C
+ IF (MASWRK) THEN
+ WRITE(IW,9035) NOSI
+ IF (NOSI.GT.0) THEN
+ WRITE(IW,9040) (IWHI(I),I=1,NOSI)
+ WRITE(IW,9040)
+ ELSE
+ WRITE(IW,9040)
+ ENDIF
+ ENDIF
+C
+ CALL DCOPY(L1*L1,RLMO,1,SSQU,1)
+ CALL DCOPY(M2,DEN,1,STRI,1)
+C
+ IP2 = NOUTA
+ IS2 = M1+NOUTA-NOSI
+ DO 695 II=1,NAT
+ INAT(II) = 0
+ 695 CONTINUE
+C
+ DO 690 IAT=1,NAT
+ DO 680 IORB=1,M1
+ IP1 = IORB + NOUTA
+ IF (IATM(1,IORB).NE.IAT) GOTO 680
+ IF (IATM(2,IORB).NE.0) GOTO 680
+ INAT(IAT) = INAT(IAT) + 1
+ IP2 = IP2 + 1
+ CALL DCOPY(L1,SSQU(1,IP1),1,RLMO(1,IP2),1)
+ CALL ICOPY(NAT,IATM(1,IORB),1,IATB(1,IP2-NOUTA),1)
+ MAPT(IORB) = IP2-NOUTA
+ 680 CONTINUE
+ DO 670 IORB=1,NOSI
+ IS1 = IWHI(IORB) + NOUTA
+ IF (IAT.EQ.NAT.AND.IATM(1,IWHI(IORB)).EQ.0) GOTO 675
+ IF (IATM(1,IWHI(IORB)).NE.IAT) GOTO 670
+ 675 CONTINUE
+ IS2 = IS2 + 1
+ MAPT(IWHI(IORB)) = IS2-NOUTA
+ 670 CONTINUE
+ 690 CONTINUE
+C
+ NSWE = 0
+ NCAT = 0
+ LASP = 1
+ NLAST = 0
+ DO 620 II=1,NAT
+ NSWE = NSWE + (IWHI(II)*(IWHI(II)-1))/2
+ NCAT = NCAT + 1
+ INAT(NCAT) = LASP + NLAST
+ LASP = INAT(NCAT)
+ NLAST = IWHI(II)
+ IWHI(NCAT) = II
+ 620 CONTINUE
+C
+ DO 610 II=1,NOSI
+ NCAT = NCAT + 1
+ INAT(NCAT) = LASP + NLAST
+ LASP = INAT(NCAT)
+ NLAST = 1
+ IWHI(NCAT) = 0
+ 610 CONTINUE
+C
+ RETURN
+C
+ 8000 FORMAT(/1X,'** MULLIKEN ATOMIC POPULATIONS FOR EACH NON-FROZEN ',
+ * 'LOCALIZED ORBITAL **')
+ 9000 FORMAT(/3X,'ATOM',2X,100(I2,1X,A4))
+ 9005 FORMAT(1X,'LMO')
+ 9010 FORMAT(1X,I3,3X,100F7.3)
+ 9015 FORMAT(/1X,'** ATOMIC POPULATIONS GREATER THAN ',F4.2,
+ * ' ARE CONSIDERED MAJOR **')
+ 9020 FORMAT(/2X,'LMO',3X,'MAJOR CONTRIBUTIONS FROM ATOM(S)')
+ 9030 FORMAT(2X,I3,2X,100(I2,1X,A2,2X))
+ 9035 FORMAT(/1X,'NO OF LMOS INVOLVING MORE THAN ONE ATOM =',I3)
+ 9040 FORMAT(1X,'THESE ARE LMOS :',100I3)
+C
+ END
/* Next global expression id number. */
static unsigned int next_expression_id;
+typedef VEC(tree, gc) *vuse_vec;
+DEF_VEC_P (vuse_vec);
+DEF_VEC_ALLOC_P (vuse_vec, heap);
+
+static VEC(vuse_vec, heap) *expression_vuses;
+
/* Mapping from expression to id number we can use in bitmap sets. */
static VEC(tree, heap) *expressions;
ann->aux = XNEW (unsigned int);
* ((unsigned int *)ann->aux) = next_expression_id++;
VEC_safe_push (tree, heap, expressions, expr);
+ VEC_safe_push (vuse_vec, heap, expression_vuses, NULL);
return next_expression_id - 1;
}
return VEC_index (tree, expressions, id);
}
+/* Return the expression vuses for EXPR, if there are any. */
+
+static inline vuse_vec
+get_expression_vuses (tree expr)
+{
+ return VEC_index (vuse_vec, expression_vuses,
+ get_or_alloc_expression_id (expr));
+}
+
+/* Set the expression vuses for EXPR to VUSES. */
+
+static inline void
+set_expression_vuses (tree expr, vuse_vec vuses)
+{
+ VEC_replace (vuse_vec, expression_vuses,
+ get_or_alloc_expression_id (expr), vuses);
+}
+
+
/* Free the expression id field in all of our expressions,
and then destroy the expressions array. */
tree_common_ann (expr)->aux = NULL;
}
VEC_free (tree, heap, expressions);
+ VEC_free (vuse_vec, heap, expression_vuses);
}
static bool in_fre = false;
/* Phi translations of a given expression don't change. */
if (EXPR_P (expr) || GIMPLE_STMT_P (expr))
{
- tree vh;
-
- vh = get_value_handle (expr);
- if (vh && TREE_CODE (vh) == VALUE_HANDLE)
- phitrans = phi_trans_lookup (expr, pred, VALUE_HANDLE_VUSES (vh));
- else
- phitrans = phi_trans_lookup (expr, pred, NULL);
+ phitrans = phi_trans_lookup (expr, pred, get_expression_vuses (expr));
}
else
phitrans = phi_trans_lookup (expr, pred, NULL);
tree oldsc = CALL_EXPR_STATIC_CHAIN (expr);
tree newfn, newsc = NULL;
tree newexpr = NULL_TREE;
- tree vh = get_value_handle (expr);
bool invariantarg = false;
int i, nargs;
- VEC (tree, gc) *vuses = VALUE_HANDLE_VUSES (vh);
+ VEC (tree, gc) *vuses = get_expression_vuses (expr);
VEC (tree, gc) *tvuses;
newfn = phi_translate_1 (find_leader_in_sets (oldfn, set1, set2),
newexpr->base.ann = NULL;
vn_lookup_or_add_with_vuses (newexpr, tvuses);
expr = newexpr;
+ set_expression_vuses (newexpr, tvuses);
}
phi_trans_add (oldexpr, expr, pred, tvuses);
}
VEC (tree, gc) * oldvuses = NULL;
VEC (tree, gc) * newvuses = NULL;
- oldvuses = VALUE_HANDLE_VUSES (get_value_handle (expr));
+ oldvuses = get_expression_vuses (expr);
if (oldvuses)
newvuses = translate_vuses_through_block (oldvuses, phiblock,
pred);
if (oldvuses != newvuses)
- vn_lookup_or_add_with_vuses (expr, newvuses);
-
+ {
+ vn_lookup_or_add_with_vuses (expr, newvuses);
+ set_expression_vuses (expr, newvuses);
+ }
phi_trans_add (oldexpr, expr, pred, newvuses);
}
return expr;
}
}
- oldvuses = VALUE_HANDLE_VUSES (get_value_handle (expr));
+ oldvuses = get_expression_vuses (expr);
if (oldvuses)
newvuses = translate_vuses_through_block (oldvuses, phiblock,
pred);
{
newexpr->base.ann = NULL;
vn_lookup_or_add_with_vuses (newexpr, newvuses);
+ set_expression_vuses (newexpr, newvuses);
}
expr = newexpr;
}
we won't look them up that way, or use the result, anyway. */
if (translated && !is_gimple_min_invariant (translated))
{
- tree vh = get_value_handle (translated);
- VEC (tree, gc) *vuses;
-
- /* The value handle itself may also be an invariant, in
- which case, it has no vuses. */
- vuses = !is_gimple_min_invariant (vh)
- ? VALUE_HANDLE_VUSES (vh) : NULL;
- phi_trans_add (expr, translated, pred, vuses);
+ phi_trans_add (expr, translated, pred,
+ get_expression_vuses (translated));
}
if (translated != NULL)
return NULL;
}
-/* Determine if VALUE, a memory operation, is ANTIC_IN at the top of
+/* Determine if EXPR, a memory expressionn, is ANTIC_IN at the top of
BLOCK by seeing if it is not killed in the block. Note that we are
only determining whether there is a store that kills it. Because
of the order in which clean iterates over values, we are guaranteed
ANTIC_IN set already. */
static bool
-value_dies_in_block_x (tree vh, basic_block block)
+value_dies_in_block_x (tree expr, basic_block block)
{
int i;
tree vuse;
- VEC (tree, gc) *vuses = VALUE_HANDLE_VUSES (vh);
+ VEC (tree, gc) *vuses = get_expression_vuses (expr);
/* Conservatively, a value dies if it's vuses are defined in this
block, unless they come from phi nodes (which are merge operations,
valid_in_sets (bitmap_set_t set1, bitmap_set_t set2, tree expr,
basic_block block)
{
- tree vh = get_value_handle (expr);
switch (TREE_CODE_CLASS (TREE_CODE (expr)))
{
case tcc_binary:
if (!union_contains_value (set1, set2, arg))
return false;
}
- return !value_dies_in_block_x (vh, block);
+ return !value_dies_in_block_x (expr, block);
}
return false;
}
&& !union_contains_value (set1, set2, op3))
return false;
}
- return !value_dies_in_block_x (vh, block);
+ return !value_dies_in_block_x (expr, block);
}
}
return false;
}
case tcc_declaration:
- return !value_dies_in_block_x (vh, block);
+ return !value_dies_in_block_x (expr, block);
default:
/* No other cases should be encountered. */
any). */
static inline void
-add_to_sets (tree var, tree expr, tree stmt, bitmap_set_t s1,
+add_to_sets (tree var, tree expr, VEC(tree, gc) *vuses, bitmap_set_t s1,
bitmap_set_t s2)
{
tree val;
- val = vn_lookup_or_add_with_stmt (expr, stmt);
+ val = vn_lookup_or_add_with_vuses (expr, vuses);
/* VAR and EXPR may be the same when processing statements for which
we are not computing value numbers (e.g., non-assignments, or
and return it if it exists. */
static inline tree
-find_existing_value_expr (tree t, tree stmt)
+find_existing_value_expr (tree t, VEC (tree, gc) *vuses)
{
bitmap_iterator bi;
unsigned int bii;
bitmap_set_t exprset;
if (REFERENCE_CLASS_P (t) || TREE_CODE (t) == CALL_EXPR || DECL_P (t))
- vh = vn_lookup_with_stmt (t, stmt);
+ vh = vn_lookup_with_vuses (t, vuses);
else
vh = vn_lookup (t);
any). Insert EXPR's operands into the EXP_GEN set for BLOCK. */
static inline tree
-create_value_expr_from (tree expr, basic_block block, tree stmt)
+create_value_expr_from (tree expr, basic_block block, VEC (tree, gc) *vuses)
{
int i;
enum tree_code code = TREE_CODE (expr);
/* Recursively value-numberize reference ops and tree lists. */
if (REFERENCE_CLASS_P (op))
{
- tree tempop = create_value_expr_from (op, block, stmt);
+ tree tempop = create_value_expr_from (op, block, vuses);
op = tempop ? tempop : op;
- val = vn_lookup_or_add_with_stmt (op, stmt);
+ val = vn_lookup_or_add_with_vuses (op, vuses);
+ set_expression_vuses (op, vuses);
}
else
{
TREE_OPERAND (vexpr, i) = val;
}
- efi = find_existing_value_expr (vexpr, stmt);
+ efi = find_existing_value_expr (vexpr, vuses);
if (efi)
return efi;
get_or_alloc_expression_id (vexpr);
}
}
-/* Return true if both the statement and the value handles have no
- vuses, or both the statement and the value handle do have vuses.
-
- Unlike SCCVN, PRE needs not only to know equivalence, but what the
- actual vuses are so it can translate them through blocks. Thus,
- we have to make a new value handle if the existing one has no
- vuses but needs them. */
-
-static bool
-vuse_equiv (tree vh1, tree stmt)
-{
- bool stmt_has_vuses = !ZERO_SSA_OPERANDS (stmt, SSA_OP_VIRTUAL_USES);
- return (VALUE_HANDLE_VUSES (vh1) && stmt_has_vuses)
- || (!VALUE_HANDLE_VUSES (vh1) && !stmt_has_vuses);
-}
-
/* Create value handles for STMT in BLOCK. Return true if we handled
the statement. */
tree rhs = GIMPLE_STMT_OPERAND (stmt, 1);
tree valvh = NULL_TREE;
tree lhsval;
+ VEC (tree, gc) *vuses = NULL;
valvh = get_sccvn_value (lhs);
+
if (valvh)
{
vn_add (lhs, valvh);
}
lhsval = valvh ? valvh : get_value_handle (lhs);
-
+ vuses = copy_vuses_from_stmt (stmt);
STRIP_USELESS_TYPE_CONVERSION (rhs);
if (can_value_number_operation (rhs)
&& (!lhsval || !is_gimple_min_invariant (lhsval)))
/* For value numberable operation, create a
duplicate expression with the operands replaced
with the value handles of the original RHS. */
- tree newt = create_value_expr_from (rhs, block, stmt);
+ tree newt = create_value_expr_from (rhs, block, vuses);
if (newt)
{
+ set_expression_vuses (newt, vuses);
/* If we already have a value number for the LHS, reuse
it rather than creating a new one. */
- if (lhsval && vuse_equiv (lhsval, stmt))
+ if (lhsval)
{
set_value_handle (newt, lhsval);
if (!is_gimple_min_invariant (lhsval))
}
else
{
- tree val = vn_lookup_or_add_with_stmt (newt, stmt);
+ tree val = vn_lookup_or_add_with_vuses (newt, vuses);
vn_add (lhs, val);
}
if (lhsval)
{
+ set_expression_vuses (rhs, vuses);
set_value_handle (rhs, lhsval);
if (!is_gimple_min_invariant (lhsval))
add_to_value (lhsval, rhs);
/* Compute a value number for the RHS of the statement
and add its value to the AVAIL_OUT set for the block.
Add the LHS to TMP_GEN. */
- add_to_sets (lhs, rhs, stmt, TMP_GEN (block),
+ set_expression_vuses (rhs, vuses);
+ add_to_sets (lhs, rhs, vuses, TMP_GEN (block),
AVAIL_OUT (block));
}
/* None of the rest of these can be PRE'd. */
projects / platform / upstream / linaro-gcc.git / commitdiff