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/trunk/src/compiler/FLINT/kernel/ltykernel.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/kernel/ltykernel.sml

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

revision 95, Wed May 13 00:49:12 1998 UTC revision 102, Thu May 14 05:53:10 1998 UTC
# Line 101  Line 101 
101    | LT_FCT of lty list * lty list              (* functor arrow type *)    | LT_FCT of lty list * lty list              (* functor arrow type *)
102    | LT_POLY of tkind list * lty list           (* polymorphic type *)    | LT_POLY of tkind list * lty list           (* polymorphic type *)
103    
   | LT_PST of (int * lty) list                 (* partial-structure type *)  
104    | LT_CONT of lty list                        (* internal cont type *)    | LT_CONT of lty list                        (* internal cont type *)
105    | LT_IND of lty * ltyI                       (* a lty thunk and its sig *)    | LT_IND of lty * ltyI                       (* a lty thunk and its sig *)
106    | LT_ENV of lty * int * int * tycEnv         (* lty closure *)    | LT_ENV of lty * int * int * tycEnv         (* lty closure *)
# Line 283  Line 282 
282        fun lt_hash lt =        fun lt_hash lt =
283          let fun g (LT_TYC t) = combine [1, getnum t]          let fun g (LT_TYC t) = combine [1, getnum t]
284                | g (LT_STR ts) = combine (2::(map getnum ts))                | g (LT_STR ts) = combine (2::(map getnum ts))
               | g (LT_PST ts) = combine (3::(tagnums ts))  
285                | g (LT_FCT(ts1, ts2)) =                | g (LT_FCT(ts1, ts2)) =
286                       combine (4::(map getnum (ts1@ts2)))                       combine (3::(map getnum (ts1@ts2)))
287                | g (LT_POLY(ks, ts)) =                | g (LT_POLY(ks, ts)) =
288                       combine (5::((map getnum ts)@(map getnum ks)))                       combine (4::((map getnum ts)@(map getnum ks)))
289                | g (LT_CONT ts) = combine (6::(map getnum ts))                | g (LT_CONT ts) = combine (5::(map getnum ts))
290                | g (LT_ENV(t,i,j,env)) =                | g (LT_ENV(t,i,j,env)) =
291                       combine [7, getnum t, i, j, getnum env]                       combine [6, getnum t, i, j, getnum env]
292                | g (LT_IND _) = bug "unexpected LT_IND in tc_hash"                | g (LT_IND _) = bug "unexpected LT_IND in tc_hash"
293           in g lt           in g lt
294          end          end
# Line 363  Line 361 
361        fun lt_aux lt =        fun lt_aux lt =
362          let fun g (LT_TYC t) = getAux t          let fun g (LT_TYC t) = getAux t
363                | g (LT_STR ts) = fsmerge ts                | g (LT_STR ts) = fsmerge ts
               | g (LT_PST ts) = fsmerge (map #2 ts)  
364                | g (LT_FCT(ts1, ts2)) = fsmerge (ts1@ts2)                | g (LT_FCT(ts1, ts2)) = fsmerge (ts1@ts2)
365                | g (LT_POLY(ks, ts)) = exitAux(fsmerge ts)                | g (LT_POLY(ks, ts)) = exitAux(fsmerge ts)
366                | g (LT_CONT ts) = fsmerge ts                | g (LT_CONT ts) = fsmerge ts
# Line 581  Line 578 
578  val tcc_real = tc_injX (TC_PRIM PT.ptc_real)  val tcc_real = tc_injX (TC_PRIM PT.ptc_real)
579  val ltc_tyc = lt_injX o LT_TYC  val ltc_tyc = lt_injX o LT_TYC
580  val ltc_str = lt_injX o LT_STR  val ltc_str = lt_injX o LT_STR
 val ltc_pst = lt_injX o LT_PST  
581  val ltc_fct = lt_injX o LT_FCT  val ltc_fct = lt_injX o LT_FCT
582  val ltc_poly = lt_injX o LT_POLY  val ltc_poly = lt_injX o LT_POLY
583  val tcc_sum = tc_injX o TC_SUM  val tcc_sum = tc_injX o TC_SUM
584  val tcc_token = tc_injX o TC_TOKEN  val tcc_token = tc_injX o TC_TOKEN
585    
586  (** the following function contains the procedure on how to  (* The following functions decide on how to flatten the arguments
587   *  flatten the arguments and results of an arbitrary FLINT function   * and results of an arbitrary FLINT function. The current threshold
588     * is maintained by the "flatten_limit" parameter. This parameter
589     * is designed as architecture independent, however, some implicit
590     * constraints are:
591     *     (1) flatten_limit <= numgpregs - numcalleesaves - 3
592     *     (2) flatten_limit <= numfpregs - 2
593     * Right now (2) is in general not true for x86; we inserted a
594     * special hack at cpstrans phase to deal with this case. In the
595     * long term, if the spilling phase in the backend can offer more
596     * supports on large-number of arguments, then we can make this
597     * flattening more aggressive. (ZHONG)
598   *)   *)
599  val maxFlat = 10 (* most number of args to flatten *)  val flatten_limit = 9
600    
601  fun isKnown tc =  fun isKnown tc =
602    (case tc_outX(tc_whnm tc)    (case tc_outX(tc_whnm tc)
# Line 610  Line 616 
616           | TC_TUPLE (_, []) =>  (* unit is not flattened to avoid coercions *)           | TC_TUPLE (_, []) =>  (* unit is not flattened to avoid coercions *)
617               (true, [ntc], false)               (true, [ntc], false)
618           | TC_TUPLE (_, ts) =>           | TC_TUPLE (_, ts) =>
619               if length ts < maxFlat then (true, ts, true)               if length ts <= flatten_limit then (true, ts, true)
620               else (true, [ntc], false)  (* ZHONG added the magic number 10 *)               else (true, [ntc], false)  (* ZHONG added the magic number 10 *)
621           | _ => if isKnown ntc then (true, [ntc], false)           | _ => if isKnown ntc then (true, [ntc], false)
622                  else (false, [ntc], false))                  else (false, [ntc], false))
# Line 618  Line 624 
624    
625  and tc_autotuple [x] = x  and tc_autotuple [x] = x
626    | tc_autotuple xs =    | tc_autotuple xs =
627         if length xs < maxFlat then tcc_tup (RF_TMP, xs)         if length xs <= flatten_limit then tcc_tup (RF_TMP, xs)
628         else bug "fatal error with tc_autotuple"         else bug "fatal error with tc_autotuple"
629    
630  and tcs_autoflat (flag, ts) =  and tcs_autoflat (flag, ts) =
# Line 719  Line 725 
725               in (case lt_outX x               in (case lt_outX x
726                    of LT_TYC tc => ltc_tyc (tcc_env(tc, ol, nl, tenv))                    of LT_TYC tc => ltc_tyc (tcc_env(tc, ol, nl, tenv))
727                     | LT_STR ts => ltc_str (map prop ts)                     | LT_STR ts => ltc_str (map prop ts)
                    | LT_PST its => ltc_pst (map (fn (i, t) => (i, prop t)) its)  
728                     | LT_FCT (ts1, ts2) => ltc_fct(map prop ts1, map prop ts2)                     | LT_FCT (ts1, ts2) => ltc_fct(map prop ts1, map prop ts2)
729                     | LT_POLY (ks, ts) =>                     | LT_POLY (ks, ts) =>
730                         let val tenv' = tcInsert(tenv, (NONE, nl))                         let val tenv' = tcInsert(tenv, (NONE, nl))
# Line 845  Line 850 
850                (case lt_outX nt                (case lt_outX nt
851                  of LT_TYC tc => ltc_tyc(tc_norm tc)                  of LT_TYC tc => ltc_tyc(tc_norm tc)
852                   | LT_STR ts => ltc_str(map lt_norm ts)                   | LT_STR ts => ltc_str(map lt_norm ts)
                  | LT_PST its =>  
                      ltc_pst(map (fn (i, t) => (i, lt_norm t)) its)  
853                   | LT_FCT (ts1, ts2) =>                   | LT_FCT (ts1, ts2) =>
854                       ltc_fct(map lt_norm ts1, map lt_norm ts2)                       ltc_fct(map lt_norm ts1, map lt_norm ts2)
855                   | LT_POLY (ks, ts) => ltc_poly (ks, map lt_norm ts)                   | LT_POLY (ks, ts) => ltc_poly (ks, map lt_norm ts)
# Line 1187  Line 1190 
1190    
1191  end (* tyc equivalence utilities *)  end (* tyc equivalence utilities *)
1192    
 (*  
  * all the complexity of lt_eqv comes from the partial-structure (or  
  * partial record) type (the LT_PST type). If we can remove LT_PST  
  * type, then the following can be considerabily simplified. (ZHONG)  
  *)  
1193    
1194  (** lt_eqv_generator, invariant: x and y are in the wh-normal form *)  (** lt_eqv_generator, invariant: x and y are in the wh-normal form *)
1195  fun lt_eqv_gen (eqop1, eqop2) (x : lty, y) =  fun lt_eqv_gen (eqop1, eqop2) (x : lty, y) =
1196    let fun sp (r, []) = true    let (* seq should be called if t1 and t2 are weak-head normal form *)
         | sp (r, (i,t)::s) =  
             (if (eqop1(List.nth(r,i),t))  
              then sp(r,s) else false) handle _ => false  
   
       fun pp ([], _) = true  
         | pp (_, []) = true  
         | pp (a as ((i,t)::l), b as ((j,s)::r)) =  
             if i > j then pp(a,r)  
             else if i < j then pp(l,b)  
                  else if (eqop1(t,s)) then pp(l,r) else false  
   
       (* seq should be called if t1 and t2 are weak-head normal form *)  
1197        fun seq (t1, t2) =        fun seq (t1, t2) =
1198          (case (lt_outX t1, lt_outX t2)          (case (lt_outX t1, lt_outX t2)
1199            of (LT_POLY(ks1, b1), LT_POLY(ks2, b2)) =>            of (LT_POLY(ks1, b1), LT_POLY(ks2, b2)) =>
# Line 1216  Line 1202 
1202                 (eqlist eqop1 (as1, as2)) andalso (eqlist eqop1 (bs1, bs2))                 (eqlist eqop1 (as1, as2)) andalso (eqlist eqop1 (bs1, bs2))
1203             | (LT_TYC a, LT_TYC b) => eqop2(a, b)             | (LT_TYC a, LT_TYC b) => eqop2(a, b)
1204             | (LT_STR s1, LT_STR s2) => eqlist eqop1 (s1, s2)             | (LT_STR s1, LT_STR s2) => eqlist eqop1 (s1, s2)
            | (LT_PST s1, LT_PST s2) => pp(s1, s2)  
            | (LT_PST s1, LT_STR s2) => sp(s2, s1)  
            | (LT_STR s1, LT_PST s2) => sp(s1, s2)  
1205             | (LT_CONT s1, LT_CONT s2) => eqlist eqop1 (s1, s2)             | (LT_CONT s1, LT_CONT s2) => eqlist eqop1 (s1, s2)
1206             | _ => false)             | _ => false)
1207     in seq(x, y)     in seq(x, y)
# Line 1226  Line 1209 
1209    
1210  fun lt_eqv(x : lty, y) =  fun lt_eqv(x : lty, y) =
1211    let val seq = lt_eqv_gen (lt_eqv, tc_eqv)    let val seq = lt_eqv_gen (lt_eqv, tc_eqv)
1212     in if ((ltp_norm x) andalso (ltp_norm y)) then     in if ((ltp_norm x) andalso (ltp_norm y)) then lt_eq(x,y)
            (lt_eq(x, y)) orelse (seq(x, y))  
1213        else (let val t1 = lt_whnm x        else (let val t1 = lt_whnm x
1214                  val t2 = lt_whnm y                  val t2 = lt_whnm y
1215               in if (ltp_norm t1) andalso (ltp_norm t2) then               in if (ltp_norm t1) andalso (ltp_norm t2) then lt_eq(x, y)
                   (lt_eq(t1, t2)) orelse (seq(t1, t2))  
1216                  else seq(t1, t2)                  else seq(t1, t2)
1217              end)              end)
1218    end (* function lt_eqv *)    end (* function lt_eqv *)

Legend:
Removed from v.95  
changed lines
  Added in v.102

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