Collatz Tool Box --- any speed ups possible?

Question

I have created a tool box for experimenting with the Collatz conjecture. Info here: Wolfram MathWorld and here: Wikipedia The patterns I have found allow us to make the conjecture jump through some hoops.

Final Edit countOrbit has been re-cast as a Do Until loop because the logic behaves similar to a one-directional linked list and I don't think it can be improved.

Note: the number of sub orbits $\leq$ (total steps) / 6

Edit for the down-voters: the current maximum that collatz projects have reached is around $10^{18}$. The example below has two numbers $10^{301030}$ and $10^{477119}$ that my functions can use quickly and accurately. That is many magnitudes greater that what is currently being done. So, why the down-votes?

This is one example: m is the count of numbers in an ascending sequence. uniqueRank[1,m] returns the first number of the first unique sub orbit of that length. omegaSubOrbit[x,m] returns the last number of that sub orbit. We display the digit counts of these numbers. Then we count the complete orbit down to 1. This takes a bit over 12 minutes on my AMD 1100T. The left-hand number is the count of multiplies (we don't count divisions by two) and the right-hand count is the number of sub orbits used to get the counts.

m = 1000000; x = uniqueRank[1, m];
y = omegaSubOrbit[x, m];
{IntegerLength[x], IntegerLength[y]}
countOrbit[1, x]

{301030, 477119}
{4805005, 1903828}
{13420758, 1903828} 7.8 minutes to count all multiplies and divides

My question: Since I'm using For and While in a few places, is there a way to speed up those functions? Especially, the countOrbit function?

ascendingQ[x_] := 3 == Mod[x, 4]
uniqueQ[x_] := 0 != Mod[2 x - 1, 3]
subOrbit[x_] := 
 Block[{y = x}, 
Flatten[Join[
Table[y \[DirectedEdge] (y = 1/2 (3 y + 1)), {n, 1, 
  IntegerExponent[x + 1, 2] - 1}], {y \[DirectedEdge] (3 y + 1)/
   2^IntegerExponent[3 y + 1, 2]}]]]
createSubOrbitGraph[n_] :=
 Block[{j, v = {}},
  For[j = 1, j <= n, j++,
   If[uniqueQ[2 j + 1], AppendTo[v, subOrbit[2 j + 1]]];
   ];
  Flatten[v]
  ]
uniqueRank[n_, m_] := Block[{a = If[1 != n && OddQ[n], n - 1, n]},
   (n + IntegerExponent[a, 2]) 2^m - 1]  
nonUniqueRank[n_, m_] := (2 n - 1)   2^m - 1
createOrbit[w_, x_] := Block[{u = subOrbit[x]},
  While[w < u[[-1, 2]], 
   u = Flatten[AppendTo[u, subOrbit[u[[-1, 2]]]]]];
   u]
createOrbitGraph[n_] :=
 Block[{j, u = {}},
  For[j = 1, j <= n, j++,
   If[uniqueQ[2 j + 1], u = Union[u, createOrbit[2 j + 1, 2 j + 1]]];
   ];
  Flatten[u]
  ]
omegaSubOrbit[x_, m_] := 
 Block[{z = (-1 + (3/2)^m (1 + x))}, 2^(1 - IntegerExponent[2 z, 2]) z]
omegaSubOrbit[x_] := 
 Block[{m = IntegerExponent[x + 1, 2], z = (-1 + (3/2)^m (1 + x))}, 
  2^(1 - IntegerExponent[2 z, 2]) z]
countOrbit[w_, x_] := 
 Block[{h = x, t, c, d = 0, s = 0, l = 0, m, n, a},
  While[True,
   m = IntegerExponent[h + 1, 2];
   t = -1 + (3/2)^m (1 + h);
   n = IntegerExponent[t, 2];
   l += m;
   d += n;
   s += 1;
   h = t/2^n;
   If[h <= w, Break[]];
   ];
  c = 2 l + d;
  a = If[1 == w, "Full ", "Extended Sub "];
  Print["---Counts ", a, "Orbit---",
   "\nNumber of Sub Orbits: ", s,
   "\nMultiplications by 3: ", l,
   "\nDivisions by 2:       ", l,
   "\nExtra Divisions by 2: ", d,
   "\nTotal for Orbit:      ", c]
  ]    

Some brief documentation:
ascendingQ[x] Returns True if odd x is ascending, False if descending
uniqueQ[x] Returns True if odd x is not embedded in any longer sequence
subOrbit[x] Returns graph data in the form {Head[DirectedEdge]Tail}
createSubOrbitGraph[n] Returns graph data of sub orbits up through n
uniqueRank[n, m] Returns the first number of the n-th unique occurance of a sub orbit of size m
nonUniqueRank[n, m] Returns the first number of the n-th occurance of a sub orbit of size m, which may not be unique.
createOrbit[w, x] Returns graph data for w=1 complete orbit or w=x extended sub orbit
Note: for a graph, both are equivalent. w=x produces fewer duplicates.
createOrbitGraph[n] Returns graph data of extended sub orbits up through n
omegaSubOrbit[x] Returns the last odd number of a sub orbit. (The one that required multiple divides.)
omegaSubOrbit[x, m] Same as above, but uses m to speed up the first step
countOrbit[w, x] Returns the count of multiply and division steps and the count of sub orbits processed, for w=1 complete orbit or w=x extended sub orbit

Edit Replaced countOrbit[w,x] with refined version that counts divisions and multiplication. Reduced the time from 15 minutes to 7.8 minutes for the above example.

Answer 1

Simple speeds ups start with simple coding. Get rid of the modulus. Get rid of all division. If dividing by 2, 4, etc. use bit shifts. If diving by a fraction such as 1/2 multiple by the decimal instead (4 * 0.5 is usually faster than 4 * 1 / 2 as it requires fewer operations). Get rid of multiplication by 3 and use a left shift and an add ( x * 3 is usually slower than x<<1 + x. The above all depend upon how good the compiler is at optimizing the code but it usually works best when the programmer doesn't assume the compiler is smarter than he is.

Answer 2

As stated in the OP, this is a "linked-list" type of algorithm that I don't feel can be speeded up using the usual methods. So, I figured that compiling the functions to use Integers Of Unusual Size would be the only way to speed up things. As noted in an answer on that thread, Mathematica compiles are limited to machine-precision so, I'm debating with myself about crafting a C program using GMP to test some timings. I will accept this answer to clear this thread from the unanswered queue.