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

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/FLINT/lsplit/ls-inline.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 154 - (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 :     structure F = FLINT
23 :     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 :     (fn e => F.SELECT (F.VAR v, s, v', e), r)
46 :     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 : monnier 154 fun copy fdec = let val F.FIX([fdec], F.RET[]) =
64 :     FU.copy IntmapF.empty (F.FIX([fdec], F.RET[]))
65 :     in fdec end
66 : monnier 111 in
67 : monnier 154 case Option.map copy (symLook pid) of
68 : monnier 111 NONE => let
69 :     fun h (0, tyl, i, rvl) = build (rest, tyl, i, rvl)
70 :     | h (n, ty :: tyl, i, rvl) = let
71 :     val rv = LV.mkLvar ()
72 :     val (tyl, imps, body) =
73 :     h (n - 1, tyl, i + 1, rv :: rvl)
74 :     in
75 :     (ty :: tyl, imps,
76 :     F.SELECT (F.VAR newArgLvar, i, rv, body))
77 :     end
78 :     | h _ = bug "build mismatch: too few types"
79 :     val (tyl, imps, body) = h (lc, tyl, i, rvl)
80 :     in
81 :     (tyl, imp :: imps, body)
82 :     end
83 :     | SOME (f as (fk, fv, [(av, at)], b)) => let
84 :     val inlv = LV.mkLvar ()
85 :     val (wrapSel, rvl) = selHdr (inlv, tr, rvl)
86 :     val (tyl, imps, body) =
87 :     build (rest, List.drop (tyl, lc), i + 1, rvl)
88 :     in
89 :     (at :: tyl, (pid, ITNODE []) :: imps,
90 :     F.SELECT (F.VAR newArgLvar, i, av,
91 :     F.LET ([inlv], b, wrapSel body)))
92 :     end
93 :     | _ => bug "bad cross-inlining argument list"
94 :     end
95 :    
96 :     val (tyl, imps, newBody) = build (imports, importTypes, 0, [])
97 :     val newArgLty = LK.lt_inj (LK.LT_STR tyl)
98 :     in
99 :     ((mainFkind, mainLvar, [(newArgLvar, newArgLty)], newBody), imps)
100 :     end
101 :     | inline0 _ = bug "bad comp-unit argument list"
102 :    
103 :     fun inline args = let
104 :     val (e, i) = inline0 args
105 :     in
106 : monnier 150 ((* LContract.lcontract *) e, i)
107 : monnier 111 end
108 :     end

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