Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /sml/trunk/src/compiler/FLINT/opt/split.sml
ViewVC logotype

View of /sml/trunk/src/compiler/FLINT/opt/split.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 215 - (download) (annotate)
Wed Feb 17 14:17:40 1999 UTC (21 years, 8 months ago) by monnier
File size: 6623 byte(s)
* opt/split.sml: new file.  Does the lambda-splitting for cross-module
  inlining.  Currently in a simplified form.
* opt/fcontract.sml (fcEta): bug with (mutually) recursive eta redexes.
(* copyright 1999 YALE FLINT project *)
(* monnier@cs.yale.edu *)

signature FSPLIT =
sig
    type flint = FLINT.prog
    val split: flint -> flint * flint option
end

structure FSplit :> FSPLIT =
struct

local
    structure F  = FLINT
    structure S  = IntSetF
    structure OU = OptUtils
    structure FU = FlintUtil
    structure LT = LtyDef
    structure PO = PrimOp
    structure PP = PPFlint
in

val say = Control.Print.say
fun bug msg = ErrorMsg.impossible ("FSplit: "^msg)
fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
fun assert p = if p then () else bug ("assertion failed")

type flint = F.prog
val mklv = LambdaVar.mkLvar
val cplv = LambdaVar.dupLvar

fun addv (s,F.VAR lv) = S.add(lv, s)
  | addv (s,_) = s
fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
fun rmvs (s,lvs) = foldl S.rmv s lvs

(*
fun join (f,args,fdecI as (fkI,fI,argsI,bodyI),fdecE as (fkE,fE,argsE,bodyE)) =
    let val (nfk,_) = OU.fk_wrap(fk, NONE)
	val argsv = map (fn (v,t) => F.VAR v) args
	val nbody =
	    let val tmp = mklv()
	    in F.LET([tmp], F.APP(F.VAR fE, argsv),
		     F.APP(F.VAR fI, (F.VAR tmp)::argsv))
	    end
	val nfdec = (nfk,f,args,nbody)
    in
	SOME(fn e =>
	     F.FIX([fdecE],
		   F.FIX([fdecI],
			 F.FIX([nfdec], e))),
	     F.FIX([fdecI], F.FIX([nfdec], leI)),
	     S.add(fE, rmvs(S.union(fvI, FU.freevars bodyI),
	                    f::(map #1 args))))
    end
*)

fun split (fdec as (fk,f,args,body)) = let
    val {getLty, cleanUp} = Recover.recover (fdec, false)

(*
 * - copy inlinable elements into a second lexp (expI)
 * - make a `lexp -> lexp' wrapper expE that returns the original lexp
 *   with the argument as the last return-lexp
 * - go through expI bottom-up eliminating dead elements and collecting
 *   free variables
 * - return expE and expI along with expI's free variables
 *)
fun sexp lexp =
    case lexp
     (* we can completely move both RET and TAPP to the I part *)
     of F.RET vs =>
	SOME(fn e => e, lexp, addvs(S.empty, vs))
      | F.TAPP (F.VAR tf,tycs) =>
	SOME(fn e => e, lexp, S.singleton tf)

      (* other non-binding lexps result in unsplittable functions *)
      | F.APP (F.VAR f,args) => NONE
      | (F.APP _ | F.TAPP _) => bug "strange (T)APP"
      | (F.SWITCH _ | F.RAISE _ | F.BRANCH _) => NONE

      (* binding-lexps *)
      | (F.LET (_,_,le) | F.FIX (_,le) | F.TFN (_,le) |
	 F.CON (_,_,_,_,le) | F.RECORD (_,_,_,le) | F.SELECT (_,_,_,le) |
	 F.HANDLE (le,_) | F.PRIMOP (_,_,_,le)) =>
	case sexp le
	 of NONE => NONE
	  | SOME (leE,leI,fvI) => let

		fun let1 (lewrap,lv,vs,effect) =
		    let val leE = lewrap o leE
		    in if effect orelse not (S.member fvI lv)
		       then SOME(leE, leI, fvI)
		       else SOME(leE, lewrap leI,
				 addvs(S.rmv(lv, fvI), vs))
		    end

	    in case lexp
		(* Functions definitions fall into the following categories:
		 * - (mutually) recursive:  don't bother
		 * - inlinable:  if exported, copy to leI
		 * - non-inlinable non-recursive:  split recursively *)
		of F.FIX (fs,_) =>
		   let val leE = fn e => F.FIX(fs, leE e)
		   in case fs
		       of [({inline=(F.IH_ALWAYS | F.IH_MAYBE _),...},
			    f,args,body)] =>
			  if not (S.member fvI f)
			  then SOME(leE, leI, fvI)
			  else SOME(leE, F.FIX(fs, leI),
				    rmvs(S.union(fvI, FU.freevars body),
					 f::(map #1 args)))
			| [fdec as (fk as {isrec=NONE,...},f,args,_)] =>
			  (case sfdec fdec
			    of (_, NONE) => SOME(leE, leI, fvI)
			     | (fdecE as (fkE,fE,argsE,bodyE), SOME fdecI) =>
			       let val fdecI as (fkI,fI,argsI,bodyI) =
				       FU.copyfdec fdecI
				   val (nfk,_) = OU.fk_wrap(fk, NONE)
				   val nargs = map (fn (v,t) => (cplv v, t)) args
				   val argsv = map (fn (v,t) => F.VAR v) nargs
				   val nbody =
				       let val tmp = mklv()
				       in F.LET([tmp], F.APP(F.VAR fE, argsv),
						F.APP(F.VAR fI, (F.VAR tmp)::argsv))
				       end
				   val nfdec = (nfk,f,nargs,nbody)
			       in
				   SOME(fn e => F.FIX([fdecE],
						      F.FIX([fdecI],
							    F.FIX([nfdec], e))),
					F.FIX([fdecI], F.FIX([nfdec], leI)),
					S.add(fE, rmvs(S.union(fvI, FU.freevars bodyI),
							 f::(map #1 args))))
			       end)
			| _ => SOME(leE, leI, fvI)
		   end

		 (* TFNs are kinda like FIX except there's no recursion *)
		 | F.TFN (tf,_) =>
		   (* FIXME *)
		   SOME(fn e => F.TFN(tf, leE e), leI, fvI)
		   
		 (* non-side effecting binds are copied to leI if exported *)
		 | F.CON (dc,tycs,v,lv,_) =>
		   let1(fn e => F.CON(dc, tycs, v, lv, e), lv, [v], false)
		 | F.RECORD (rk,vs,lv,_) =>
		   let1(fn e => F.RECORD(rk, vs, lv, e), lv, vs, false)
		 | F.SELECT (v,i,lv,_) =>
		   let1(fn e => F.SELECT(v, i, lv, e), lv, [v], false)
		 | F.PRIMOP (po,vs,lv,_) =>
		   let1(fn e => F.PRIMOP(po,vs,lv,e), lv, vs, PO.effect(#2 po))

		 (* IMPROVEME: lvs should not be restricted to [lv] *)
		 | F.LET (lvs as [lv],body as F.TAPP (v,tycs),_) =>
		   let1(fn e => F.LET(lvs, body, e), lv, [v], false)
		 | F.LET (lvs as [lv],body as F.APP (v,vs),_) =>
		   let1(fn e => F.LET(lvs, body, e), lv, v::vs, true)
		 | F.LET (lvs,body,_) =>
		   SOME(fn e => F.LET(lvs, body, leE e), leI, fvI)

		 | F.HANDLE (_,v) =>
		   SOME(fn e => F.HANDLE(leE e, v), leI, fvI)
		 | _ => bug "second match failed ?!?!"
	    end


and sfdec (fdec as ({cconv=F.CC_FUN _,...},_,_,_)) = (fdec, NONE)
  | sfdec (fdec as (fk as {inline,cconv,known,isrec},f,args,body)) =
    case sexp body
     of NONE => (fdec, NONE)
      | SOME (leE,leI,fvI) =>
	let val fvI = S.members(rmvs(fvI, map #1 args))
	    val fE = cplv f
	    val fI = cplv f
	    val tmp = mklv()
	    val bodyE = leE(F.RECORD(F.RK_STRUCT, map F.VAR fvI,
				     tmp, F.RET[F.VAR tmp]))
	    val argI = mklv()
	    val (_,bodyI) = foldl (fn (lv,(n,le)) =>
				   (n+1, F.SELECT(F.VAR argI, n, lv, le)))
				  (0, leI) fvI
	    val fkI = {inline=F.IH_ALWAYS, cconv=cconv, known=known, isrec=NONE}
	    val argsI = (argI, LT.ltc_str(map (getLty o F.VAR) fvI))::args
	in ((fk, fE, args, bodyE), SOME(fkI, fI, argsI, bodyI))
	end

in case sfdec fdec
    of (fdec,NONE) => (fdec, NONE)
     | (fdecE as (fkE,fE,argsE,bodyE), SOME fdecI) =>
       let val fdecI as (fkI,fI,argsI,bodyI) = FU.copyfdec fdecI
	   val (nfk,_) = OU.fk_wrap(fk, NONE)
	   val nargs = map (fn (v,t) => (cplv v, t)) args
	   val argsv = map (fn (v,t) => F.VAR v) nargs
	   val tmp = mklv()
       in
	   ((fk, f, nargs,
	     F.FIX([fdecE],
		   F.FIX([fdecI],
			 F.LET([tmp], F.APP(F.VAR fE, argsv),
			       F.APP(F.VAR fI, (F.VAR tmp)::argsv))))),
	    NONE)
       end
end

end
end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0