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

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 23, Thu Mar 12 00:49:56 1998 UTC revision 24, Thu Mar 12 00:49:58 1998 UTC
# Line 1  Line 1 
 (* Copyright (c) 1997 YALE FLINT PROJECT *)  
 (* pflatten.sml *)  
   
1  structure PFlatten : PFLATTEN =  structure PFlatten : PFLATTEN =
2  struct  struct
3    
4  local structure LT = PLambdaType  local structure LT = PLambdaType
5        structure LV = LambdaVar        structure LV = LambdaVar
6        structure F = FLINT        structure F = FLINT
       structure FU = FlintUtil  
7  in  in
8    
9  type llty = PLambda.lty  type llty = PLambda.lty
# Line 18  Line 14 
14  type value = FLINT.value  type value = FLINT.value
15  type lvar = FLINT.lvar  type lvar = FLINT.lvar
16    
 fun bug s = ErrorMsg.impossible ("Pflatten:" ^ s)  
17  val mkv = LambdaVar.mkLvar  val mkv = LambdaVar.mkLvar
18    
19  (*****************************************************************************  (* all_flatten: lty -> (lty list * bool * unflattenfn * flattenfn)
20   *                 FUNCTIONS USED BY PLAMBDA TO FLINT NORMALIZATION          *   *   `lty list': the flattened types
21   *****************************************************************************)   *   `bool': whether the `lty list' is raw
22  (* recursively turn cooked types into raw when possible *)   * unflattenfn: (lvar * lexp) -> (lvar list * lexp)
 fun ltc_raw x = x  
 fun tcc_raw x = x  
   
 fun v_punflattenGen ltys =  
   (fn (lv, lexp) =>  
      let val lvs = map (fn _ => mkv()) ltys  
       in (lvs, F.RECORD(FU.rk_tuple, map F.VAR lvs, lv, lexp))  
      end)  
   
 fun v_pflattenGen ltys =  
   (fn v =>  
      let val lvs = map (fn _ => mkv()) ltys  
       in (map (fn v => F.VAR v) lvs,  
           fn lexp =>  
              #1 (foldl (fn (lv, (lexp, field)) =>  
                           (F.SELECT(v, field, lv, lexp), field+1))  
                   (lexp, 0) lvs))  
      end)  
   
 val v_punflattenDef = fn (lv, lexp) => ([lv], lexp)  
 val v_pflattenDef = fn v => ([v], fn lexp => lexp)  
   
   
 (* punflatten: (lvar * lexp) -> (lvar list * lexp)  
23   *   turn `lexp' from an expression expecting a single value bound to `lvar'   *   turn `lexp' from an expression expecting a single value bound to `lvar'
24   *   to an expression expecting multiple values to be bound to `lvar list'.   *   to an expression expecting multiple values to be bound to `lvar list'.
25   *   It seems generally more convenient to choose the `lvar list' inside   *   It seems generally more convenient to choose the `lvar list' inside
26   *   bundlefn than outside.   *   bundlefn than outside.
27   * pflatten: value -> (value list * (lexp -> lexp))   * flattenfn: value -> (value list * (lexp -> lexp))
28   *   expand `value' into its flattened `value list' around `lexp'.   *   expand `value' into its flattened `value list' around `lexp'.
29   *   The `value list' might be required in order to construct the   *   The `value list' might be required in order to construct the
30   *   `lexp' argument, which explains the fact that `value' and `lexp'   *   `lexp' argument, which explains the fact that `value' and `lexp'
31   *   are passed in two steps. *)   *   are passed in two steps. *)
32    
33  fun t_pflatten (lty : llty) = LT.lt_autoflat lty  fun all_flatten lty =
34      let val (raw, ltys, flag) = LT.lt_autoflat lty
35  fun v_punflatten (lty : llty) =     in if flag then
36    let val x as (_, ltys, flag) = LT.lt_autoflat lty          (ltys, raw,
37     in (x, if flag then v_punflattenGen ltys else v_punflattenDef)           fn (lv, lexp) =>
   end  
   
 fun v_pflatten   (lty : llty) =  
   let val x as (_, ltys, flag) = LT.lt_autoflat lty  
    in (x, if flag then v_pflattenGen ltys else v_pflattenDef)  
   end  
   
   
 (*****************************************************************************  
  *                 FUNCTIONS USED BY FLINT TYPE SPECIALIZATION               *  
  *****************************************************************************)  
   
 fun v_unflattenGen ltys =  
   (fn ([lv], lexp) =>  
38           let val lvs = map (fn _ => mkv()) ltys           let val lvs = map (fn _ => mkv()) ltys
39            in (lvs, F.RECORD(FU.rk_tuple,              in (lvs, F.RECORD(F.RK_RECORD, map F.VAR lvs, lv, lexp))
40                              map F.VAR lvs, lv, lexp))             end,
41           end           fn v =>
     | _ => bug "unexpected case in v_unflattenGen")  
   
 fun v_flattenGen ltys =  
   (fn [v] =>  
42          let val lvs = map (fn _ => mkv()) ltys          let val lvs = map (fn _ => mkv()) ltys
43           in (map (fn x => F.VAR x) lvs,              in (map (fn v => F.VAR v) lvs,
44               fn lexp =>               fn lexp =>
45                  #1 (foldl (fn (lv, (lexp, field)) =>                  #1 (foldl (fn (lv, (lexp, field)) =>
46                            (F.SELECT(v, field, lv, lexp), field+1))                            (F.SELECT(v, field, lv, lexp), field+1))
47                      (lexp, 0) lvs))                            (lexp, 0)
48          end                              lvs))
49      | _ => bug "unexpected case in v_flattenGen")             end)
50          else
51            (ltys, raw,
52             fn (lv, lexp) => ([lv], lexp),
53             fn v => ([v], fn lexp => lexp))
54      end
55    
56    (*
57      if !Control.CG.misc4 = 1998 then
58         ([lty], true, fn (lv, lexp) => ([lv], lexp),
59          fn v => ([v], fn lexp => lexp))
60      else
61    *)
62    
63    
64    fun ltc_flat    lty = #1 (all_flatten lty)
65    fun ltp_flat    lty = #2 (all_flatten lty)
66    fun v_unflatten lty = #3 (all_flatten lty)
67    fun v_flatten   lty = #4 (all_flatten lty)
68    
69  val v_unflattenDef = fn (vs, lexp) => (vs, lexp)  fun ltc_raw x = x
70  val v_flattenDef = fn vs => (vs, fn lexp => lexp)  fun tcc_raw x = x
71    
 fun t_flatten ([flty], false) = LT.lt_autoflat flty  
   | t_flatten (fltys, true) = (true, fltys, false)  
   | t_flatten _ = bug "unexpected case in ltc_flat"  
   
 fun v_unflatten ([flty], false) =  
       let val x as (_, fltys, flag) = LT.lt_autoflat flty  
        in (x, if flag then v_unflattenGen fltys else v_unflattenDef)  
72        end        end
   | v_unflatten (fltys, false) = ((true, fltys, false), v_unflattenDef)  
   | v_unflatten (fltys, true) = ((true, fltys, false), v_unflattenDef)  
73    
 fun v_flatten ([flty], false) =  
       let val x as (_, fltys, flag) = LT.lt_autoflat flty  
        in (x, if flag then v_flattenGen fltys else v_flattenDef)  
       end  
   | v_flatten (fltys, false) = ((true, fltys, false), v_flattenDef)  
   | v_flatten (fltys, true) = ((true, fltys, false), v_flattenDef)  
74    
75  end (* local *)  end
 end (* structure PFlatten *)  

Legend:
Removed from v.23  
changed lines
  Added in v.24

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