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

Parent Directory | Revision Log

---

Revision 220 - (view) (download)

1 :	monnier	111	signature LSPLIT_INLINE = sig
2 :
3 :			type flint = CompBasic.flint
4 :			type pid = PersStamps.persstamp
5 :			type importTree = CompBasic.importTree
6 :			type import = pid * importTree
7 :			type symenv = SymbolicEnv.symenv
8 :
9 :			val inline: flint * import list * symenv -> flint * import list
10 :			end
11 :
12 :			structure LSplitInline :> LSPLIT_INLINE = struct
13 :
14 :			type flint = CompBasic.flint
15 :			type pid = PersStamps.persstamp
16 :			datatype importTree = datatype CompBasic.importTree
17 :			type import = pid * importTree
18 :			type symenv = SymbolicEnv.symenv
19 :
20 :			structure LK = LtyKernel
21 :			structure LV = LambdaVar
22 :	monnier	216	structure F = FLINT
23 :	monnier	111	structure FU = FlintUtil
24 :
25 :			fun bug s = ErrorMsg.impossible ("LSplitInline: " ^ s)
26 :
27 :			fun inline0 ((mainFkind, mainLvar, [(mainArgLvar, mainArgLty)], mainBody),
28 :			imports, symenv) =
29 :			let
30 :			val importTypes =
31 :			case LK.lt_out mainArgLty of
32 :			LK.LT_STR it => it
33 :			| _ => bug "non-structure arg to comp-unit"
34 :			val newArgLvar = LV.mkLvar ()
35 :			val symLook = SymbolicEnv.look symenv
36 :			fun cnt (ITNODE []) = 1
37 :			| cnt (ITNODE l) = foldl (fn ((_, t), n) => cnt t + n) 0 l
38 :			fun selHdr (v, t, rvl) = let
39 :			fun oneNode (v, ITNODE [], h, r) = (h, v :: r)
40 :			| oneNode (v, ITNODE l, h, r) = let
41 :			fun oneBranch ((s, t), (h, r)) = let
42 :			val v' = LV.mkLvar ()
43 :			val (h, r) = oneNode (v', t, h, r)
44 :			in
45 :	monnier	220	(fn e => F.SELECT(F.VAR v, s, v', h e), r)
46 :	monnier	111	end
47 :			in
48 :			foldl oneBranch (h, r) l
49 :			end
50 :			in
51 :			oneNode (v, t, fn e => e, rvl)
52 :			end
53 :			(*
54 :			* build: imports * types * offset * vars -> types * imports * lexp
55 :			*)
56 :			fun build ([], [], _, rvl) =
57 :			([], [],
58 :			F.RECORD (F.RK_STRUCT, rev (map F.VAR rvl),
59 :			mainArgLvar, mainBody))
60 :			| build ([], _, _, _) = bug "build mismatch: too many types"
61 :			| build ((imp as (pid, tr)) :: rest, tyl, i, rvl) = let
62 :			val lc = cnt tr
63 :			in
64 :	monnier	216	case Option.map FU.copyfdec (symLook pid) of
65 :	monnier	111	NONE => let
66 :			fun h (0, tyl, i, rvl) = build (rest, tyl, i, rvl)
67 :			| h (n, ty :: tyl, i, rvl) = let
68 :			val rv = LV.mkLvar ()
69 :			val (tyl, imps, body) =
70 :			h (n - 1, tyl, i + 1, rv :: rvl)
71 :			in
72 :			(ty :: tyl, imps,
73 :			F.SELECT (F.VAR newArgLvar, i, rv, body))
74 :			end
75 :			| h _ = bug "build mismatch: too few types"
76 :			val (tyl, imps, body) = h (lc, tyl, i, rvl)
77 :			in
78 :			(tyl, imp :: imps, body)
79 :			end
80 :			| SOME (f as (fk, fv, [(av, at)], b)) => let
81 :	monnier	220	(* val _ = Control_Print.say "hello\n" *)
82 :	monnier	111	val inlv = LV.mkLvar ()
83 :			val (wrapSel, rvl) = selHdr (inlv, tr, rvl)
84 :			val (tyl, imps, body) =
85 :			build (rest, List.drop (tyl, lc), i + 1, rvl)
86 :			in
87 :			(at :: tyl, (pid, ITNODE []) :: imps,
88 :			F.SELECT (F.VAR newArgLvar, i, av,
89 :			F.LET ([inlv], b, wrapSel body)))
90 :			end
91 :			| _ => bug "bad cross-inlining argument list"
92 :			end
93 :
94 :			val (tyl, imps, newBody) = build (imports, importTypes, 0, [])
95 :			val newArgLty = LK.lt_inj (LK.LT_STR tyl)
96 :			in
97 :			((mainFkind, mainLvar, [(newArgLvar, newArgLty)], newBody), imps)
98 :			end
99 :			| inline0 _ = bug "bad comp-unit argument list"
100 :
101 :			fun inline args = let
102 :			val (e, i) = inline0 args
103 :			in
104 :	monnier	150	((* LContract.lcontract *) e, i)
105 :	monnier	111	end
106 :			end

---

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