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/lsplit/ls-inline.sml
ViewVC logotype

View of /sml/trunk/src/compiler/FLINT/lsplit/ls-inline.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 220 - (download) (annotate)
Tue Mar 9 02:15:05 1999 UTC (21 years, 7 months ago) by monnier
File size: 3215 byte(s)
* opt/split.sml (sexp): don't split HANDLE (it's incorrect).
(funeffect): embryo to detect side-effect free APPs (non-functional).
(splitThreshold): to put a cap on inlining.
(stfn): don't bother splitting inlinable TFNs.
* opt/fixfix.sml (curry): fixed bug when uncurrying cooked functions.
* opt/fcontract.sml (fcFun):  fix bug when undertaking mut-rec functions.
* main/flintcomp.sml:  added `recover' to help debugging.
updated the fold to allow extraction of Fi and return it at the end.
* lsplit/ls-inline.sml (oneBranch): fixed the wrapper function.
* flint/flintutil.sml (freevars):  forgot to count the arg of SWITCH.
* flint/flint.sig:  added a tfkind to TFN (only inlining for now).
* main/control.sml: new file. Moved from TopLevel/viscomp/control.sml
(splitThreshold): new var.
* TopLevel/viscomp/control.sig (FLINT.printFctTypes): to reduce clutter.
(splitThreshold): to control splitting agressiveness.
* TopLevel/viscomp/control.sml:  moved substructs outside so that clients
  can refer to them directly (rather than through Control.Foo) to reduce
  spurious dependencies.
* TopLevel/main/{codes,compile}: call `split' from flintcomp, not compile.
* kernel/ltyextern.sml (tnarrow), reps/{reify,rttype,typeoper}.sml:
  flatten arguments when reifying them since the pretty-printer doesn't
  know how to deal with flattened reified TFNs.
signature LSPLIT_INLINE = sig

    type flint = CompBasic.flint
    type pid = PersStamps.persstamp
    type importTree = CompBasic.importTree
    type import = pid * importTree
    type symenv = SymbolicEnv.symenv

    val inline: flint * import list * symenv -> flint * import list
end

structure LSplitInline :> LSPLIT_INLINE = struct

    type flint = CompBasic.flint
    type pid = PersStamps.persstamp
    datatype importTree = datatype CompBasic.importTree
    type import = pid * importTree
    type symenv = SymbolicEnv.symenv

    structure LK = LtyKernel
    structure LV = LambdaVar
    structure F  = FLINT
    structure FU = FlintUtil

    fun bug s = ErrorMsg.impossible ("LSplitInline: " ^ s)

    fun inline0 ((mainFkind, mainLvar, [(mainArgLvar, mainArgLty)], mainBody),
		 imports, symenv) =
	let
	    val importTypes =
		case LK.lt_out mainArgLty of
		    LK.LT_STR it => it
		  | _ => bug "non-structure arg to comp-unit"
	    val newArgLvar = LV.mkLvar ()
	    val symLook = SymbolicEnv.look symenv
	    fun cnt (ITNODE []) = 1
	      | cnt (ITNODE l) = foldl (fn ((_, t), n) => cnt t + n) 0 l
	    fun selHdr (v, t, rvl) = let
		fun oneNode (v, ITNODE [], h, r) = (h, v :: r)
		  | oneNode (v, ITNODE l, h, r) = let
			fun oneBranch ((s, t), (h, r)) = let
			    val v' = LV.mkLvar ()
			    val (h, r) = oneNode (v', t, h, r)
			in
			    (fn e => F.SELECT(F.VAR v, s, v', h e), r)
			end
		    in
			foldl oneBranch (h, r) l
		    end
	    in
		oneNode (v, t, fn e => e, rvl)
	    end
	    (*
	     * build: imports * types * offset * vars -> types * imports * lexp
	     *)
	    fun build ([], [], _, rvl) =
		([], [],
		 F.RECORD (F.RK_STRUCT, rev (map F.VAR rvl),
			   mainArgLvar, mainBody))
	      | build ([], _, _, _) = bug "build mismatch: too many types"
	      | build ((imp as (pid, tr)) :: rest, tyl, i, rvl) = let
		    val lc = cnt tr
		in
		    case Option.map FU.copyfdec (symLook pid) of
			NONE => let
			    fun h (0, tyl, i, rvl) = build (rest, tyl, i, rvl)
			      | h (n, ty :: tyl, i, rvl) = let
				    val rv = LV.mkLvar ()
				    val (tyl, imps, body) =
					h (n - 1, tyl, i + 1, rv :: rvl)
				in
				    (ty :: tyl, imps,
				     F.SELECT (F.VAR newArgLvar, i, rv, body))
				end
			      | h _ = bug "build mismatch: too few types"
			    val (tyl, imps, body) = h (lc, tyl, i, rvl)
			in
			    (tyl, imp :: imps, body)
			end
		      | SOME (f as (fk, fv, [(av, at)], b)) => let
			    (* val _ = Control_Print.say "hello\n" *)
			    val inlv = LV.mkLvar ()
			    val (wrapSel, rvl) = selHdr (inlv, tr, rvl)
			    val (tyl, imps, body) =
				build (rest, List.drop (tyl, lc), i + 1, rvl)
			in
			    (at :: tyl, (pid, ITNODE []) :: imps,
			     F.SELECT (F.VAR newArgLvar, i, av,
				       F.LET ([inlv], b, wrapSel body)))
			end
		      | _ => bug "bad cross-inlining argument list"
		end

	    val (tyl, imps, newBody) = build (imports, importTypes, 0, [])
	    val newArgLty = LK.lt_inj (LK.LT_STR tyl)
	in
	    ((mainFkind, mainLvar, [(newArgLvar, newArgLty)], newBody), imps)
	end
      | inline0 _ = bug "bad comp-unit argument list"

    fun inline args = let
	val (e, i) = inline0 args
    in
	((* LContract.lcontract *) e, i)
    end
end

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