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 246 - (view) (download)

1 : monnier 245 (* 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 :     val say = Control.Print.say
24 :    
25 :     (*****************************************************************************
26 :     * FUNCTIONS USED BY PLAMBDA TO FLINT NORMALIZATION *
27 :     *****************************************************************************)
28 :     (* recursively turn cooked types into raw when possible *)
29 :     fun ltc_raw x = x
30 :     fun tcc_raw x = x
31 :    
32 :     fun v_punflattenGen ltys =
33 :     (fn (lv, lexp) =>
34 :     let val lvs = map (fn _ => mkv()) ltys
35 :     in (lvs, F.RECORD(FU.rk_tuple, map F.VAR lvs, lv, lexp))
36 :     end)
37 :    
38 :     fun v_pflattenGen ltys =
39 :     (fn v =>
40 :     let val lvs = map (fn _ => mkv()) ltys
41 :     in (map (fn v => F.VAR v) lvs,
42 :     fn lexp =>
43 :     #1 (foldl (fn (lv, (lexp, field)) =>
44 :     (F.SELECT(v, field, lv, lexp), field+1))
45 :     (lexp, 0) lvs))
46 :     end)
47 :    
48 :     val v_punflattenDef = fn (lv, lexp) => ([lv], lexp)
49 :     val v_pflattenDef = fn v => ([v], fn lexp => lexp)
50 :    
51 :    
52 :     (* punflatten: (lvar * lexp) -> (lvar list * lexp)
53 :     * turn `lexp' from an expression expecting a single value bound to `lvar'
54 :     * to an expression expecting multiple values to be bound to `lvar list'.
55 :     * It seems generally more convenient to choose the `lvar list' inside
56 :     * bundlefn than outside.
57 :     * pflatten: value -> (value list * (lexp -> lexp))
58 :     * expand `value' into its flattened `value list' around `lexp'.
59 :     * The `value list' might be required in order to construct the
60 :     * `lexp' argument, which explains the fact that `value' and `lexp'
61 :     * are passed in two steps. *)
62 :    
63 :     fun t_pflatten (lty : llty) = LT.lt_autoflat lty
64 :    
65 :     fun v_punflatten (lty : llty) =
66 :     let val x as (_, ltys, flag) = LT.lt_autoflat lty
67 :     in (x, if flag then v_punflattenGen ltys else v_punflattenDef)
68 :     end
69 :    
70 :     fun v_pflatten (lty : llty) =
71 :     let val x as (_, ltys, flag) = LT.lt_autoflat lty
72 :     in (x, if flag then v_pflattenGen ltys else v_pflattenDef)
73 :     end
74 :    
75 :    
76 :     (*****************************************************************************
77 :     * FUNCTIONS USED BY FLINT TYPE SPECIALIZATION *
78 :     *****************************************************************************)
79 :    
80 :     fun v_unflattenGen ltys =
81 :     (fn ([lv], lexp) =>
82 :     let val lvs = map (fn _ => mkv()) ltys
83 :     in (lvs, F.RECORD(FU.rk_tuple,
84 :     map F.VAR lvs, lv, lexp))
85 :     end
86 :     | _ => bug "unexpected case in v_unflattenGen")
87 :    
88 :     fun v_flattenGen ltys =
89 :     (fn [v] =>
90 :     let val lvs = map (fn _ => mkv()) ltys
91 :     in (map (fn x => F.VAR x) lvs,
92 :     fn lexp =>
93 :     #1 (foldl (fn (lv, (lexp, field)) =>
94 :     (F.SELECT(v, field, lv, lexp), field+1))
95 :     (lexp, 0) lvs))
96 :     end
97 :     | _ => bug "unexpected case in v_flattenGen")
98 :    
99 :     val v_unflattenDef = fn (vs, lexp) => (vs, lexp)
100 :     val v_flattenDef = fn vs => (vs, fn lexp => lexp)
101 :    
102 :     fun t_flatten ([flty], false) = LT.lt_autoflat flty
103 :     | t_flatten (fltys, true) = (true, fltys, false)
104 :     | t_flatten _ = bug "unexpected case in ltc_flat"
105 :    
106 :     fun v_unflatten ([flty], false) =
107 :     let val x as (_, fltys, flag) = LT.lt_autoflat flty
108 :     in (x, if flag then v_unflattenGen fltys else v_unflattenDef)
109 :     end
110 :     | v_unflatten (fltys, false) = ((true, fltys, false), v_unflattenDef)
111 :     | v_unflatten (fltys, true) = ((true, fltys, false), v_unflattenDef)
112 :    
113 :     fun v_flatten ([flty], false) =
114 :     let val x as (_, fltys, flag) = LT.lt_autoflat flty
115 :     in (x, if flag then v_flattenGen fltys else v_flattenDef)
116 :     end
117 :     | v_flatten (fltys, false) = ((true, fltys, false), v_flattenDef)
118 :     | v_flatten (fltys, true) = ((true, fltys, false), v_flattenDef)
119 :    
120 :    
121 :     (*****************************************************************************
122 :     * FUNCTIONS USED BY FLINT REPRESENTATION ANALYSIS *
123 :     *****************************************************************************)
124 :    
125 :     (* NOTE: the implementation of v_coerce should be consistent with that
126 :     of v_flattenGen and v_unflattenGen *)
127 :     fun v_coerce (wflag, nftcs, oftcs) =
128 :     let val nlen = length nftcs
129 :     val olen = length oftcs
130 :     in if nlen = olen then
131 :     (oftcs, NONE)
132 :     else if (nlen = 1) andalso ((olen > 1) orelse (olen = 0))
133 :     then ([LT.tcc_tuple oftcs],
134 :     if wflag then
135 :     let val v = mkv()
136 :     in SOME (fn vs =>
137 :     ([F.VAR v],
138 :     fn le => F.RECORD(FU.rk_tuple, vs, v, le)))
139 :     end
140 :     else SOME (v_flattenGen (map LT.ltc_tyc oftcs)))
141 :     else bug "unexpected case in v_coerce"
142 :     end (* function v_coerce *)
143 :    
144 :     end (* local *)
145 :     end (* structure PFlatten *)
146 :    
147 :     (*
148 :     * $Log$
149 :     *)

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