[hcoop/debian/mlton.git] / mlton / ssa / analyze2.fun

(* Copyright (C) 2011,2017 Matthew Fluet.
 * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-2000 NEC Research Institute.
 *
 * MLton is released under a BSD-style license.
 * See the file MLton-LICENSE for details.
 *)

functor Analyze2 (S: ANALYZE2_STRUCTS): ANALYZE2 = 
struct

open S
datatype z = datatype Exp.t
datatype z = datatype Statement.t
datatype z = datatype Transfer.t

fun 'a analyze
   {base, coerce, const, filter, filterWord, fromType, inject, layout, object, primApp,
    program = Program.T {functions, globals, main, ...},
    select, update, useFromTypeOnBinds} =
   let
      fun coerces (msg, from, to) =
         if Vector.length from = Vector.length to
            then Vector.foreach2 (from, to, fn (from, to) =>
                                  coerce {from = from, to = to})
         else Error.bug (concat ["Analyze2.coerces (length mismatch: ", msg, ")"])
      val {get = value: Var.t -> 'a, set = setValue, ...} =
         Property.getSetOnce
         (Var.plist,
          Property.initRaise ("Analyze2.value", Var.layout))
      val value = Trace.trace ("Analyze2.value", Var.layout, layout) value
      fun values xs = Vector.map (xs, value)
      val {get = funcInfo, set = setFuncInfo, ...} =
         Property.getSetOnce
         (Func.plist, Property.initRaise ("Analyze2.funcInfo", Func.layout))
      val {get = labelInfo, set = setLabelInfo, ...} =
         Property.getSetOnce
         (Label.plist, Property.initRaise ("Analyze2.labelInfo", Label.layout))
      val labelArgs = #args o labelInfo
      val labelValues = #values o labelInfo
      fun loopArgs args =
         Vector.map (args, fn (x, t) =>
                     let val v = fromType t
                     in setValue (x, v)
                        ; v
                     end)
      val _ =
         List.foreach
         (functions, fn f =>
          let
             val {args, name, raises, returns, ...} = Function.dest f
          in
             setFuncInfo (name, {args = loopArgs args,
                                 raises = Option.map (raises, fn ts =>
                                                      Vector.map (ts, fromType)),
                                 returns = Option.map (returns, fn ts =>
                                                       Vector.map (ts, fromType))})
          end)
      fun loopTransfer (t: Transfer.t,
                        shouldReturns: 'a vector option,
                        shouldRaises: 'a vector option): unit =
        (case t of
            Arith {prim, args, overflow, success, ty} =>
               (coerces ("arith overflow", Vector.new0 (), labelValues overflow)
                ; coerce {from = primApp {prim = prim,
                                          args = values args,
                                          resultType = ty,
                                          resultVar = NONE},
                          to = Vector.sub (labelValues success, 0)})
          | Bug => ()
          | Call {func, args, return, ...} =>
               let
                  val {args = formals, raises, returns} = funcInfo func
                  val _ = coerces ("call args/formals", values args, formals)
                  fun noHandler () =
                     case (raises, shouldRaises) of
                        (NONE, NONE) => ()
                      | (NONE, SOME _) => ()
                      | (SOME _, NONE) => 
                           Error.bug "Analyze2.loopTransfer (raise mismatch)"
                      | (SOME vs, SOME vs') => coerces ("call caller/raises", vs, vs')
                  datatype z = datatype Return.t
               in
                  case return of
                     Dead =>
                        if isSome returns orelse isSome raises
                           then Error.bug "Analyze2.loopTransfer (return mismatch at Dead)"
                        else ()
                   | NonTail {cont, handler} => 
                        (Option.app (returns, fn vs =>
                                     coerces ("call non-tail/returns", vs, labelValues cont))
                         ; (case handler of
                               Handler.Caller => noHandler ()
                             | Handler.Dead =>
                                  if isSome raises
                                     then Error.bug "Analyze2.loopTransfer (raise mismatch at NonTail/Dead)"
                                  else ()
                             | Handler.Handle h =>
                                  let
                                     val _ =
                                        case raises of
                                           NONE => ()
                                         | SOME vs =>
                                              coerces ("call handle/raises", vs, labelValues h)
                                  in
                                     ()
                                  end))
                   | Tail =>
                        let
                           val _ = noHandler ()
                           val _ =
                              case (returns, shouldReturns) of
                                 (NONE, NONE) => ()
                               | (NONE, SOME _) => ()
                               | (SOME _, NONE) =>
                                    Error.bug "Analyze2.loopTransfer (return mismatch at Tail)"
                               | (SOME vs, SOME vs') =>
                                    coerces ("call tail/return", vs, vs')
                        in
                           ()
                        end

               end
          | Case {test, cases, default, ...} =>
               let
                  val test = value test
                  fun ensureSize (w, s) =
                     if WordSize.equals (s, WordX.size w)
                        then ()
                     else Error.bug (concat ["Analyze.loopTransfer (case ",
                                             WordX.toString w,
                                             " must be size ",
                                             WordSize.toString s,
                                             ")"])
                  fun ensureNullary j =
                     if Vector.isEmpty (labelValues j)
                        then ()
                     else Error.bug (concat ["Analyze2.loopTransfer (case:",
                                             Label.toString j,
                                             " must be nullary)"])
                  fun doitWord (s, cs) =
                     (ignore (filterWord (test, s))
                      ; Vector.foreach (cs, fn (w, j) =>
                                        (ensureSize (w, s)
                                         ; ensureNullary j)))
                  fun doitCon cs =
                     Vector.foreach
                     (cs, fn (c, j) =>
                      let
                         val v = labelValues j
                         val variant =
                            case Vector.length v of
                               0 => NONE
                             | 1 => SOME (Vector.first v)
                             | _ => Error.bug "Analyze2.loopTransfer (case conApp with >1 arg)"
                      in
                         filter {con = c,
                                 test = test,
                                 variant = variant}
                      end)
                  datatype z = datatype Cases.t
                  val _ =
                     case cases of
                        Con cs => doitCon cs
                      | Word (s, cs) => doitWord (s, cs)
                  val _ = Option.app (default, ensureNullary)
               in ()
               end
          | Goto {dst, args} => coerces ("goto", values args, labelValues dst)
          | Raise xs =>
               (case shouldRaises of
                   NONE => Error.bug "Analyze2.loopTransfer (raise mismatch at Raise)"
                 | SOME vs => coerces ("raise", values xs, vs))
          | Return xs =>
               (case shouldReturns of
                   NONE => Error.bug "Analyze2.loopTransfer (return mismatch at Return)"
                 | SOME vs => coerces ("return", values xs, vs))
          | Runtime {prim, args, return} =>
               let
                  val xts = labelArgs return
                  val (resultVar, resultType) =
                     if Vector.isEmpty xts
                        then (NONE, Type.unit)
                     else
                        let
                           val (x, t) = Vector.first xts
                        in
                           (SOME x, t)
                        end
                  val _ =
                     primApp {prim = prim,
                              args = values args,
                              resultType = resultType,
                              resultVar = resultVar}
               in 
                  ()
               end)
        handle exn => Error.reraiseSuffix (exn, concat [" in ", Layout.toString (Transfer.layout t)])
      val loopTransfer =
         Trace.trace3
         ("Analyze2.loopTransfer",
          Transfer.layout, 
          Option.layout (Vector.layout layout),
          Option.layout (Vector.layout layout),
          Layout.ignore)
         loopTransfer
      fun baseValue b = base (Base.map (b, value))
      fun loopBind {exp, ty, var}: 'a =
         case exp of
            Const c => const c
          | Inject {sum, variant} =>
               inject {sum = sum,
                       variant = value variant}
          | Object {args, con} =>
               let
                  val args =
                     case Type.dest ty of
                        Type.Object {args = ts, ...} =>
                           Prod.make
                           (Vector.map2
                            (args, Prod.dest ts,
                             fn (x, {isMutable, ...}) =>
                             {elt = value x,
                              isMutable = isMutable}))
                      | _ => Error.bug "Analyze2.loopBind (strange object)"
               in
                  object {args = args,
                          con = con,
                          resultType = ty}
               end
          | PrimApp {prim, args, ...} =>
               primApp {prim = prim,
                        args = values args,
                        resultType = ty,
                        resultVar = var}
          | Select {base, offset} =>
               select {base = baseValue base,
                       offset = offset,
                       resultType = ty}
          | Var x => value x
      fun loopStatement (s: Statement.t): unit =
         (case s of
             Bind (b as {ty, var, ...}) =>
                let
                   val v = loopBind b
                in
                   Option.app
                   (var, fn var =>
                    if useFromTypeOnBinds
                       then let
                               val v' = fromType ty
                               val _ = coerce {from = v, to = v'}
                               val _ = setValue (var, v')
                            in
                               ()
                            end
                    else setValue (var, v))
                end
          | Profile _ => ()
          | Update {base, offset, value = v} =>
             update {base = baseValue base,
                     offset = offset,
                     value = value v})
         handle exn => Error.reraiseSuffix (exn, concat [" in ", Layout.toString (Statement.layout s)])
      val loopStatement =
         Trace.trace ("Analyze2.loopStatement",
                      Statement.layout,
                      Unit.layout)
         loopStatement
      val _ = coerces ("main", Vector.new0 (), #args (funcInfo main))
      val _ = Vector.foreach (globals, loopStatement)
              handle exn => Error.reraiseSuffix (exn, concat [" in Globals"])
      val _ =
         List.foreach
         (functions, fn f =>
          let
             val {blocks, name, start, ...} = Function.dest f
             val _ =
                Vector.foreach
                (blocks, fn b as Block.T {label, args, ...} =>
                 setLabelInfo (label, {args = args,
                                       block = b,
                                       values = loopArgs args,
                                       visited = ref false}))
             val {returns, raises, ...} = funcInfo name
             fun visit (l: Label.t) =
                let
                   val {block, visited, ...} = labelInfo l
                in
                   if !visited
                      then ()
                   else
                      let
                         val _ = visited := true
                         val Block.T {statements, transfer, ...} = block
                         val _ = (Vector.foreach (statements, loopStatement)
                                  ; loopTransfer (transfer, returns, raises))
                                 handle exn => Error.reraiseSuffix (exn, concat [" in ", Label.toString l])
                      in
                         Transfer.foreachLabel (transfer, visit)
                      end
                end
             val _ = visit start
          in
             ()
          end
          handle exn => Error.reraiseSuffix (exn, concat [" in ", Func.toString (Function.name f)]))
   in
      {func = funcInfo,
       label = labelValues,
       value = value}
   end

end
Commit	Line	Data
7f918cf1 CE	1	(* Copyright (C) 2011,2017 Matthew Fluet.
	2	* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
	3	* Jagannathan, and Stephen Weeks.
	4	* Copyright (C) 1997-2000 NEC Research Institute.
	5	*
	6	* MLton is released under a BSD-style license.
	7	* See the file MLton-LICENSE for details.
	8	*)
	9
	10	functor Analyze2 (S: ANALYZE2_STRUCTS): ANALYZE2 =
	11	struct
	12
	13	open S
	14	datatype z = datatype Exp.t
	15	datatype z = datatype Statement.t
	16	datatype z = datatype Transfer.t
	17
	18	fun 'a analyze
	19	{base, coerce, const, filter, filterWord, fromType, inject, layout, object, primApp,
	20	program = Program.T {functions, globals, main, ...},
	21	select, update, useFromTypeOnBinds} =
	22	let
	23	fun coerces (msg, from, to) =
	24	if Vector.length from = Vector.length to
	25	then Vector.foreach2 (from, to, fn (from, to) =>
	26	coerce {from = from, to = to})
	27	else Error.bug (concat ["Analyze2.coerces (length mismatch: ", msg, ")"])
	28	val {get = value: Var.t -> 'a, set = setValue, ...} =
	29	Property.getSetOnce
	30	(Var.plist,
	31	Property.initRaise ("Analyze2.value", Var.layout))
	32	val value = Trace.trace ("Analyze2.value", Var.layout, layout) value
	33	fun values xs = Vector.map (xs, value)
	34	val {get = funcInfo, set = setFuncInfo, ...} =
	35	Property.getSetOnce
	36	(Func.plist, Property.initRaise ("Analyze2.funcInfo", Func.layout))
	37	val {get = labelInfo, set = setLabelInfo, ...} =
	38	Property.getSetOnce
	39	(Label.plist, Property.initRaise ("Analyze2.labelInfo", Label.layout))
	40	val labelArgs = #args o labelInfo
	41	val labelValues = #values o labelInfo
	42	fun loopArgs args =
	43	Vector.map (args, fn (x, t) =>
	44	let val v = fromType t
	45	in setValue (x, v)
	46	; v
	47	end)
	48	val _ =
	49	List.foreach
	50	(functions, fn f =>
	51	let
	52	val {args, name, raises, returns, ...} = Function.dest f
	53	in
	54	setFuncInfo (name, {args = loopArgs args,
	55	raises = Option.map (raises, fn ts =>
	56	Vector.map (ts, fromType)),
	57	returns = Option.map (returns, fn ts =>
	58	Vector.map (ts, fromType))})
	59	end)
	60	fun loopTransfer (t: Transfer.t,
	61	shouldReturns: 'a vector option,
	62	shouldRaises: 'a vector option): unit =
	63	(case t of
	64	Arith {prim, args, overflow, success, ty} =>
65	(coerces ("arith overflow", Vector.new0 (), labelValues overflow)
66	; coerce {from = primApp {prim = prim,
67	args = values args,
68	resultType = ty,
69	resultVar = NONE},
70	to = Vector.sub (labelValues success, 0)})
71	\| Bug => ()
72	\| Call {func, args, return, ...} =>
73	let
74	val {args = formals, raises, returns} = funcInfo func
75	val _ = coerces ("call args/formals", values args, formals)
76	fun noHandler () =
77	case (raises, shouldRaises) of
78	(NONE, NONE) => ()
79	\| (NONE, SOME _) => ()
80	\| (SOME _, NONE) =>
81	Error.bug "Analyze2.loopTransfer (raise mismatch)"
82	\| (SOME vs, SOME vs') => coerces ("call caller/raises", vs, vs')
83	datatype z = datatype Return.t
84	in
85	case return of
86	Dead =>
87	if isSome returns orelse isSome raises
88	then Error.bug "Analyze2.loopTransfer (return mismatch at Dead)"
89	else ()
90	\| NonTail {cont, handler} =>
91	(Option.app (returns, fn vs =>
92	coerces ("call non-tail/returns", vs, labelValues cont))
93	; (case handler of
94	Handler.Caller => noHandler ()
95	\| Handler.Dead =>
96	if isSome raises
97	then Error.bug "Analyze2.loopTransfer (raise mismatch at NonTail/Dead)"
98	else ()
99	\| Handler.Handle h =>
100	let
101	val _ =
102	case raises of
103	NONE => ()
104	\| SOME vs =>
105	coerces ("call handle/raises", vs, labelValues h)
106	in
107	()
108	end))
109	\| Tail =>
110	let
111	val _ = noHandler ()
112	val _ =
113	case (returns, shouldReturns) of
114	(NONE, NONE) => ()
115	\| (NONE, SOME _) => ()
116	\| (SOME _, NONE) =>
117	Error.bug "Analyze2.loopTransfer (return mismatch at Tail)"
118	\| (SOME vs, SOME vs') =>
119	coerces ("call tail/return", vs, vs')
120	in
121	()
122	end
123
124	end
125	\| Case {test, cases, default, ...} =>
126	let
127	val test = value test
128	fun ensureSize (w, s) =
129	if WordSize.equals (s, WordX.size w)
130	then ()
131	else Error.bug (concat ["Analyze.loopTransfer (case ",
132	WordX.toString w,
133	" must be size ",
134	WordSize.toString s,
135	")"])
136	fun ensureNullary j =
137	if Vector.isEmpty (labelValues j)
138	then ()
139	else Error.bug (concat ["Analyze2.loopTransfer (case:",
140	Label.toString j,
141	" must be nullary)"])
142	fun doitWord (s, cs) =
143	(ignore (filterWord (test, s))
144	; Vector.foreach (cs, fn (w, j) =>
145	(ensureSize (w, s)
146	; ensureNullary j)))
147	fun doitCon cs =
148	Vector.foreach
149	(cs, fn (c, j) =>
150	let
151	val v = labelValues j
152	val variant =
153	case Vector.length v of
154	0 => NONE
155	\| 1 => SOME (Vector.first v)
156	\| _ => Error.bug "Analyze2.loopTransfer (case conApp with >1 arg)"
157	in
158	filter {con = c,
159	test = test,
160	variant = variant}
161	end)
162	datatype z = datatype Cases.t
163	val _ =
164	case cases of
165	Con cs => doitCon cs
166	\| Word (s, cs) => doitWord (s, cs)
167	val _ = Option.app (default, ensureNullary)
168	in ()
169	end
170	\| Goto {dst, args} => coerces ("goto", values args, labelValues dst)
171	\| Raise xs =>
172	(case shouldRaises of
173	NONE => Error.bug "Analyze2.loopTransfer (raise mismatch at Raise)"
174	\| SOME vs => coerces ("raise", values xs, vs))
175	\| Return xs =>
176	(case shouldReturns of
177	NONE => Error.bug "Analyze2.loopTransfer (return mismatch at Return)"
178	\| SOME vs => coerces ("return", values xs, vs))
179	\| Runtime {prim, args, return} =>
180	let
181	val xts = labelArgs return
182	val (resultVar, resultType) =
183	if Vector.isEmpty xts
184	then (NONE, Type.unit)
185	else
186	let
187	val (x, t) = Vector.first xts
188	in
189	(SOME x, t)
190	end
191	val _ =
192	primApp {prim = prim,
193	args = values args,
194	resultType = resultType,
195	resultVar = resultVar}
196	in
197	()
198	end)
199	handle exn => Error.reraiseSuffix (exn, concat [" in ", Layout.toString (Transfer.layout t)])
200	val loopTransfer =
201	Trace.trace3
202	("Analyze2.loopTransfer",
203	Transfer.layout,
204	Option.layout (Vector.layout layout),
205	Option.layout (Vector.layout layout),
206	Layout.ignore)
207	loopTransfer
208	fun baseValue b = base (Base.map (b, value))
209	fun loopBind {exp, ty, var}: 'a =
210	case exp of
211	Const c => const c
212	\| Inject {sum, variant} =>
213	inject {sum = sum,
214	variant = value variant}
215	\| Object {args, con} =>
216	let
217	val args =
218	case Type.dest ty of
219	Type.Object {args = ts, ...} =>
220	Prod.make
221	(Vector.map2
222	(args, Prod.dest ts,
223	fn (x, {isMutable, ...}) =>
224	{elt = value x,
225	isMutable = isMutable}))
226	\| _ => Error.bug "Analyze2.loopBind (strange object)"
227	in
228	object {args = args,
229	con = con,
230	resultType = ty}
231	end
232	\| PrimApp {prim, args, ...} =>
233	primApp {prim = prim,
234	args = values args,
235	resultType = ty,
236	resultVar = var}
237	\| Select {base, offset} =>
238	select {base = baseValue base,
239	offset = offset,
240	resultType = ty}
241	\| Var x => value x
242	fun loopStatement (s: Statement.t): unit =
243	(case s of
244	Bind (b as {ty, var, ...}) =>
245	let
246	val v = loopBind b
247	in
248	Option.app
249	(var, fn var =>
250	if useFromTypeOnBinds
251	then let
252	val v' = fromType ty
253	val _ = coerce {from = v, to = v'}
254	val _ = setValue (var, v')
255	in
256	()
257	end
258	else setValue (var, v))
259	end
260	\| Profile _ => ()
261	\| Update {base, offset, value = v} =>
262	update {base = baseValue base,
263	offset = offset,
264	value = value v})
265	handle exn => Error.reraiseSuffix (exn, concat [" in ", Layout.toString (Statement.layout s)])
266	val loopStatement =
267	Trace.trace ("Analyze2.loopStatement",
268	Statement.layout,
269	Unit.layout)
270	loopStatement
271	val _ = coerces ("main", Vector.new0 (), #args (funcInfo main))
272	val _ = Vector.foreach (globals, loopStatement)
273	handle exn => Error.reraiseSuffix (exn, concat [" in Globals"])
274	val _ =
275	List.foreach
276	(functions, fn f =>
277	let
278	val {blocks, name, start, ...} = Function.dest f
279	val _ =
280	Vector.foreach
281	(blocks, fn b as Block.T {label, args, ...} =>
282	setLabelInfo (label, {args = args,
283	block = b,
284	values = loopArgs args,
285	visited = ref false}))
286	val {returns, raises, ...} = funcInfo name
287	fun visit (l: Label.t) =
288	let
289	val {block, visited, ...} = labelInfo l
290	in
291	if !visited
292	then ()
293	else
294	let
295	val _ = visited := true
296	val Block.T {statements, transfer, ...} = block
297	val _ = (Vector.foreach (statements, loopStatement)
298	; loopTransfer (transfer, returns, raises))
299	handle exn => Error.reraiseSuffix (exn, concat [" in ", Label.toString l])
300	in
301	Transfer.foreachLabel (transfer, visit)
302	end
303	end
304	val _ = visit start
305	in
306	()
307	end
308	handle exn => Error.reraiseSuffix (exn, concat [" in ", Func.toString (Function.name f)]))
309	in
310	{func = funcInfo,
311	label = labelValues,
312	value = value}
313	end
314
315	end