Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Tracker SCM

SCM Repository

[smlnj] Diff of /sml/branches/SMLNJ/src/compiler/FLINT/plambda/pflatten.sml
ViewVC logotype

Diff of /sml/branches/SMLNJ/src/compiler/FLINT/plambda/pflatten.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 44, Sun Mar 22 20:10:57 1998 UTC revision 45, Sun Mar 22 20:11:09 1998 UTC
# Line 1  Line 1 
1    (* Copyright (c) 1997 YALE FLINT PROJECT *)
2    (* pflatten.sml *)
3    
4  structure PFlatten : PFLATTEN =  structure PFlatten : PFLATTEN =
5  struct  struct
6    
7  local structure LT = PLambdaType  local structure LT = PLambdaType
8        structure LV = LambdaVar        structure LV = LambdaVar
9        structure F = FLINT        structure F = FLINT
10          structure FU = FlintUtil
11  in  in
12    
13      type llty = PLambda.lty      type llty = PLambda.lty
# Line 14  Line 18 
18      type value = FLINT.value      type value = FLINT.value
19      type lvar = FLINT.lvar      type lvar = FLINT.lvar
20    
21    fun bug s = ErrorMsg.impossible ("Pflatten:" ^ s)
22  val mkv = LambdaVar.mkLvar  val mkv = LambdaVar.mkLvar
23    val say = Control.Print.say
24    
25  (* all_flatten: lty -> (lty list * bool * unflattenfn * flattenfn)  (*****************************************************************************
26   *   `lty list': the flattened types   *                 FUNCTIONS USED BY PLAMBDA TO FLINT NORMALIZATION          *
27   *   `bool': whether the `lty list' is raw   *****************************************************************************)
28   * unflattenfn: (lvar * lexp) -> (lvar list * lexp)  (* 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'   *   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'.   *   to an expression expecting multiple values to be bound to `lvar list'.
55   *   It seems generally more convenient to choose the `lvar list' inside   *   It seems generally more convenient to choose the `lvar list' inside
56   *   bundlefn than outside.   *   bundlefn than outside.
57   * flattenfn: value -> (value list * (lexp -> lexp))   * pflatten: value -> (value list * (lexp -> lexp))
58   *   expand `value' into its flattened `value list' around `lexp'.   *   expand `value' into its flattened `value list' around `lexp'.
59   *   The `value list' might be required in order to construct the   *   The `value list' might be required in order to construct the
60   *   `lexp' argument, which explains the fact that `value' and `lexp'   *   `lexp' argument, which explains the fact that `value' and `lexp'
61   *   are passed in two steps. *)   *   are passed in two steps. *)
62    
63  fun all_flatten lty =  fun t_pflatten (lty : llty) = LT.lt_autoflat lty
64    let val (raw, ltys, flag) = LT.lt_autoflat lty  
65     in if flag then  fun v_punflatten (lty : llty) =
66          (ltys, raw,    let val x as (_, ltys, flag) = LT.lt_autoflat lty
67           fn (lv, lexp) =>     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             let val lvs = map (fn _ => mkv()) ltys
83              in (lvs, F.RECORD(F.RK_RECORD, map F.VAR lvs, lv, lexp))            in (lvs, F.RECORD(FU.rk_tuple,
84             end,                              map F.VAR lvs, lv, lexp))
85           fn v =>           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             let val lvs = map (fn _ => mkv()) ltys
91              in (map (fn v => F.VAR v) lvs,           in (map (fn x => F.VAR x) lvs,
92                  fn lexp =>                  fn lexp =>
93                     #1 (foldl (fn (lv, (lexp, field)) =>                     #1 (foldl (fn (lv, (lexp, field)) =>
94                          (F.SELECT(v, field, lv, lexp), field+1))                          (F.SELECT(v, field, lv, lexp), field+1))
95                            (lexp, 0)                      (lexp, 0) lvs))
96                              lvs))          end
97             end)      | _ => bug "unexpected case in v_flattenGen")
       else  
         (ltys, raw,  
          fn (lv, lexp) => ([lv], lexp),  
          fn v => ([v], fn lexp => lexp))  
   end  
   
 (*  
   if !Control.CG.misc4 = 1998 then  
      ([lty], true, fn (lv, lexp) => ([lv], lexp),  
       fn v => ([v], fn lexp => lexp))  
   else  
 *)  
   
   
 fun ltc_flat    lty = #1 (all_flatten lty)  
 fun ltp_flat    lty = #2 (all_flatten lty)  
 fun v_unflatten lty = #3 (all_flatten lty)  
 fun v_flatten   lty = #4 (all_flatten lty)  
98    
99  fun ltc_raw x = x  val v_unflattenDef = fn (vs, lexp) => (vs, lexp)
100  fun tcc_raw x = x  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  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  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 *)

Legend:
Removed from v.44  
changed lines
  Added in v.45

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