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/plambda/pflatten.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/plambda/pflatten.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* Copyright (c) 1997 YALE FLINT PROJECT *)
2 :     (* pflatten.sml *)
3 :    
4 :     structure PFlatten : PFLATTEN =
5 :     struct
6 :    
7 :     local structure LT = PLambdaType
8 :     structure LV = LambdaVar
9 :     structure F = FLINT
10 :     structure FU = FlintUtil
11 :     in
12 :    
13 :     type llty = PLambda.lty
14 :     type ltyc = PLambda.tyc
15 :     type flty = FLINT.lty
16 :     type ftyc = FLINT.tyc
17 :     type lexp = FLINT.lexp
18 :     type value = FLINT.value
19 :     type lvar = FLINT.lvar
20 :    
21 :     fun bug s = ErrorMsg.impossible ("Pflatten:" ^ s)
22 :     val mkv = LambdaVar.mkLvar
23 :    
24 :     (*****************************************************************************
25 :     * FUNCTIONS USED BY PLAMBDA TO FLINT NORMALIZATION *
26 :     *****************************************************************************)
27 :     (* recursively turn cooked types into raw when possible *)
28 :     fun ltc_raw x = x
29 :     fun tcc_raw x = x
30 :    
31 :     fun v_punflattenGen ltys =
32 :     (fn (lv, lexp) =>
33 :     let val lvs = map (fn _ => mkv()) ltys
34 :     in (lvs, F.RECORD(FU.rk_tuple, map F.VAR lvs, lv, lexp))
35 :     end)
36 :    
37 :     fun v_pflattenGen ltys =
38 :     (fn v =>
39 :     let val lvs = map (fn _ => mkv()) ltys
40 :     in (map (fn v => F.VAR v) lvs,
41 :     fn lexp =>
42 :     #1 (foldl (fn (lv, (lexp, field)) =>
43 :     (F.SELECT(v, field, lv, lexp), field+1))
44 :     (lexp, 0) lvs))
45 :     end)
46 :    
47 :     val v_punflattenDef = fn (lv, lexp) => ([lv], lexp)
48 :     val v_pflattenDef = fn v => ([v], fn lexp => lexp)
49 :    
50 :    
51 :     (* punflatten: (lvar * lexp) -> (lvar list * lexp)
52 :     * turn `lexp' from an expression expecting a single value bound to `lvar'
53 :     * to an expression expecting multiple values to be bound to `lvar list'.
54 :     * It seems generally more convenient to choose the `lvar list' inside
55 :     * bundlefn than outside.
56 :     * pflatten: value -> (value list * (lexp -> lexp))
57 :     * expand `value' into its flattened `value list' around `lexp'.
58 :     * The `value list' might be required in order to construct the
59 :     * `lexp' argument, which explains the fact that `value' and `lexp'
60 :     * are passed in two steps. *)
61 :    
62 :     fun t_pflatten (lty : llty) = LT.lt_autoflat lty
63 :    
64 :     fun v_punflatten (lty : llty) =
65 :     let val x as (_, ltys, flag) = LT.lt_autoflat lty
66 :     in (x, if flag then v_punflattenGen ltys else v_punflattenDef)
67 :     end
68 :    
69 :     fun v_pflatten (lty : llty) =
70 :     let val x as (_, ltys, flag) = LT.lt_autoflat lty
71 :     in (x, if flag then v_pflattenGen ltys else v_pflattenDef)
72 :     end
73 :    
74 :    
75 :     (*****************************************************************************
76 :     * FUNCTIONS USED BY FLINT TYPE SPECIALIZATION *
77 :     *****************************************************************************)
78 :    
79 :     fun v_unflattenGen ltys =
80 :     (fn ([lv], lexp) =>
81 :     let val lvs = map (fn _ => mkv()) ltys
82 :     in (lvs, F.RECORD(FU.rk_tuple,
83 :     map F.VAR lvs, lv, lexp))
84 :     end
85 :     | _ => bug "unexpected case in v_unflattenGen")
86 :    
87 :     fun v_flattenGen ltys =
88 :     (fn [v] =>
89 :     let val lvs = map (fn _ => mkv()) ltys
90 :     in (map (fn x => F.VAR x) lvs,
91 :     fn lexp =>
92 :     #1 (foldl (fn (lv, (lexp, field)) =>
93 :     (F.SELECT(v, field, lv, lexp), field+1))
94 :     (lexp, 0) lvs))
95 :     end
96 :     | _ => bug "unexpected case in v_flattenGen")
97 :    
98 :     val v_unflattenDef = fn (vs, lexp) => (vs, lexp)
99 :     val v_flattenDef = fn vs => (vs, fn lexp => lexp)
100 :    
101 :     fun t_flatten ([flty], false) = LT.lt_autoflat flty
102 :     | t_flatten (fltys, true) = (true, fltys, false)
103 :     | t_flatten _ = bug "unexpected case in ltc_flat"
104 :    
105 :     fun v_unflatten ([flty], false) =
106 :     let val x as (_, fltys, flag) = LT.lt_autoflat flty
107 :     in (x, if flag then v_unflattenGen fltys else v_unflattenDef)
108 :     end
109 :     | v_unflatten (fltys, false) = ((true, fltys, false), v_unflattenDef)
110 :     | v_unflatten (fltys, true) = ((true, fltys, false), v_unflattenDef)
111 :    
112 :     fun v_flatten ([flty], false) =
113 :     let val x as (_, fltys, flag) = LT.lt_autoflat flty
114 :     in (x, if flag then v_flattenGen fltys else v_flattenDef)
115 :     end
116 :     | v_flatten (fltys, false) = ((true, fltys, false), v_flattenDef)
117 :     | v_flatten (fltys, true) = ((true, fltys, false), v_flattenDef)
118 :    
119 :     end (* local *)
120 :     end (* structure PFlatten *)

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