bug in src/backend/limit-check.fun

[Stephen Weeks]

Today, I found and fixed a bug in limit-check.fun.  The bug caused
certain loops to go undetected, and hence allowed the generation of
loops that allocated but had no limit check.  Obviously bad :-(

If you want the fix, you should replace limit-check.fun with the file
below and rebuild MLton.

--------------------------------------------------------------------------------

(* Copyright (C) 1997-1999 NEC Research Institute.
 * Please see the file LICENSE for license information.
 *)
(* Insert limit checks at
 * 1. Loop headers
 * 2. Continuations
 * 3. Handlers
 *)
functor LimitCheck(S: LIMIT_CHECK_STRUCTS): LIMIT_CHECK = 
struct

open S
open Dec Transfer
   
fun limitCheck(Program.T{functions, ...}) =
   let
      val {get = limitCheck, set = setLimitCheck} =
	 Property.new(Jump.plist, Property.initConst false)

      val {get = inBody, set = setInBody, destroy} =
	 Property.newDest(Jump.plist, Property.initConst false)

      fun yes j = setLimitCheck(j, true)

      fun jump j = if inBody j then yes j else ()
	 
      fun loopExp e =
	 let val {decs, transfer} = Exp.dest e
	 in List.foreach(Exp.decs e,
			 fn Fun{name, body, ...} => (setInBody(name, true)
						     ; loopExp body
						     ; setInBody(name, false))
			  | HandlerPush h => setLimitCheck(h, true)
			  | _ => ())
	    ; (case transfer of
		  Jump{dst, ...} => jump dst
		| Case{cases, default, ...} =>
		     (List.foreach(cases, jump o #2)
		      ; Option.map'(default, jump))
		| Call{cont, ...} => (case cont of
					 SOME c => yes c
				       | _ => ())
		| _ => ())
	 end
   in
      List.foreach(functions, loopExp o #body)
      ; destroy()
      ; limitCheck
   end
   
end