Unexplained infinite loop

["Jacques Carette" <carette@mcmaster.ca>]

Hello,

I am writing some stateful code in continuation-passing-style, and am
encountering an infinite loop that I cannot explain.  

The code below is extracted from a larger piece of code (which performs
Gaussian Elimination).  All that is left is a loop on a 1 cell vector, and
that does not work :-(

The real mystery (to me) is that if I annotate this code with lots of .< >.
and .~ for MetaOCaml, then not only does the code work, the generated code
works too.  I am somewhat at a loss to explain the infinite loop below.

Using the debugger, I can see that the while loop condition is only fully
evaluated once, and then on subsequent passes through, only the 2nd and 3rd
parameters are evaluated, the first (which is the one that changes!) is not
re-evaluated.  I don't understand why not. Could someone from this list shed
some light on this issue for me?

Jacques

(* Base monad type, to be used throughout *)
type ('v,'s,'w) monad = 's -> ('s -> 'v -> 'w) -> 'w

let ret a = fun s k -> k s a
let retN a = fun s k -> let t = a in k s t
let bind a f = fun s k -> a s (fun s' b -> f b s' k)
let k0 s v = v  (* Initial continuation -- for `reset' and `run' *)
let runM m = m [] k0 (* running our monad *)
let liftGet x = ! x
let liftRef x = ref x

let l1 f x = bind x (fun t -> f t)

let seqM a b = fun s k -> k s (begin a s k0 ; b s k0 end)

(* while ``loops'' do not naturally bind a value *)
let retWhileM cond body = fun s k -> 
    k s (while cond s k0 do body s k0 done)

(* monadic logic combinators *)
module LogicCode = struct
  let and_ a b = ret (a && b)
end

(* operations on indices *)
module Idx = struct
  let zero = 0
  let succ a = a+1
  let less a b = a<b
end

(* code generators *)
module Code = struct
  let update a f = let b = f (liftGet a) in ret (a := b) 
end

let dogen a = 
  bind (retN (liftRef Idx.zero)) (fun c ->
  bind (retN (Array.length a)) (fun m -> 
    (retWhileM (ret (Idx.less (liftGet c) m))
       (bind (retN (liftGet c)) (fun cc ->
       Printf.printf "%i %i\n" cc !c;
       Code.update c Idx.succ ))))) ;;

let gen a = runM (dogen a) ;;

gen (Array.make 1 1.) ;;