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

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

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

revision 196, Fri Nov 20 18:16:19 1998 UTC revision 197, Sun Nov 22 01:25:23 1998 UTC
# Line 121  Line 121 
121   * tyc to an association list that maps the kinds of the free   * tyc to an association list that maps the kinds of the free
122   * variables in the tyc (represented as a TK_SEQ) to the tyc's kind.   * variables in the tyc (represented as a TK_SEQ) to the tyc's kind.
123   *)   *)
 structure Memo :> sig  
     type dict  
     val newDict         : unit -> dict  
     val recallOrCompute : dict * tkindEnv * tyc * (unit -> tkind) -> tkind  
 end =  
 struct  
124      structure TcDict = BinaryDict      structure TcDict = BinaryDict
125                             (struct                             (struct
126                                 type ord_key = tyc                                 type ord_key = tyc
127                                 val cmpKey = LK.tc_cmp                                 val cmpKey = LK.tc_cmp
128                             end)                             end)
129    
130    structure Memo :> sig
131        type dict
132        val newDict         : unit -> dict
133        val recallOrCompute : dict * tkindEnv * tyc * (unit -> tkind) -> tkind
134    end =
135    struct
136      type dict = (tkind * tkind) list TcDict.dict ref      type dict = (tkind * tkind) list TcDict.dict ref
137      val newDict : unit -> dict = ref o TcDict.mkDict      val newDict : unit -> dict = ref o TcDict.mkDict
138    
# Line 530  Line 530 
530    end    end
531    
532    
533    (************************************************************************
534     *            SUBSTITION OF NAMED VARS IN A TYC/LTY                     *
535     ************************************************************************)
536    structure LtDict = BinaryDict
537                           (struct
538                               type ord_key = lty
539                               val cmpKey = LtyKernel.lt_cmp
540                           end)
541    
542    fun tc_nvar_elim_gen() = let
543        val dict = ref (TcDict.mkDict())
544    
545        fun tc_nvar_elim s d tyc =
546            case LK.tc_nvars tyc of
547                [] => tyc                   (* nothing to elim *)
548              | _ =>
549        let
550            (* encode the tyc and the depth for memoization
551             * using tcc_proj *)
552            val tycdepth = tcc_proj (tyc, d)
553        in
554            case TcDict.peek(!dict, tycdepth) of
555                SOME t => t                 (* hit! *)
556              | NONE => let                 (* must recompute *)
557                    val r = tc_nvar_elim s d (* default recursive invoc. *)
558                    val rs = map r          (* recursive invocation on list *)
559                    val t =
560                        case tc_out tyc of
561                            LK.TC_NVAR tvar =>
562                                (case s (tvar, d) of
563                                     SOME t => t
564                                   | NONE => tyc)
565                          | LK.TC_VAR _ => tyc
566                          | LK.TC_PRIM _ => tyc
567                          | LK.TC_FN (tks, t) =>
568                                tcc_fn (tks, tc_nvar_elim s (DI.next d) t)
569                          | LK.TC_APP (t, ts) =>
570                                tcc_app (r t, rs ts)
571                          | LK.TC_SEQ ts =>
572                                tcc_seq (rs ts)
573                          | LK.TC_PROJ (t, i) =>
574                                tcc_proj (r t, i)
575                          | LK.TC_SUM ts =>
576                                tcc_sum (rs ts)
577                          | LK.TC_FIX ((i,t,ts),j) =>
578                                tcc_fix ((i, r t, rs ts), j)
579                          | LK.TC_TUPLE (rf,ts) =>
580                                tcc_tuple (rs ts)
581                          | LK.TC_ARROW (ff, ts, ts') =>
582                                tcc_arrow (ff, rs ts, rs ts')
583                          | LK.TC_PARROW (t, t') =>
584                                tcc_parrow (r t, r t')
585                          | LK.TC_BOX t =>
586                                tcc_box (r t)
587                          | LK.TC_ABS t =>
588                                tcc_abs (r t)
589                          | LK.TC_TOKEN (tok, t) =>
590                                tc_inj (LK.TC_TOKEN (tok, r t))
591                          | LK.TC_CONT ts =>
592                                tcc_cont (rs ts)
593                          | LK.TC_IND _ =>
594                                bug "unexpected TC_IND in tc_nvar_elim"
595                          | LK.TC_ENV _ =>
596                                bug "unexpected TC_ENV in tc_nvar_elim"
597                in
598                    dict := TcDict.insert(!dict, tycdepth, t);
599                    t
600                end
601        end (* tc_nvar_elim *)
602    in
603        tc_nvar_elim
604    end
605    
606    fun lt_nvar_elim_gen() = let
607        val dict = ref (LtDict.mkDict())
608        val tc_nvar_elim = tc_nvar_elim_gen()
609    
610        fun lt_nvar_elim s d lty =
611            case LK.lt_nvars lty of
612                [] => lty                   (* nothing to elim *)
613              | _ =>
614        let
615            (* encode the lty and depth info using LT_ENV
616             * (only first 2 args are useful) *)
617            val ltydepth = lt_inj (LK.LT_ENV (lty, d, 0, LK.initTycEnv))
618        in
619            case LtDict.peek(!dict, ltydepth) of
620                SOME t => t                 (* hit! *)
621              | NONE => let                 (* must recompute *)
622                    val r = lt_nvar_elim s d (* default recursive invoc. *)
623                    val rs = map r          (* recursive invocation on list *)
624                    val t =
625                        case lt_out lty of
626                            LK.LT_TYC t =>
627                                ltc_tyc (tc_nvar_elim s d t)
628                          | LK.LT_STR ts =>
629                                ltc_str (rs ts)
630                          | LK.LT_FCT (ts, ts') =>
631                                ltc_fct (rs ts, rs ts')
632                          | LK.LT_POLY (tks, ts) =>
633                                ltc_poly (tks,
634                                          map (lt_nvar_elim s (DI.next d)) ts)
635                          | LK.LT_CONT ts =>
636                                ltc_cont (rs ts)
637                          | LK.LT_IND _ =>
638                                bug "unexpected LT_IND in lt_nvar_elim"
639                          | LK.LT_ENV _ =>
640                                bug "unexpected LT_ENV in lt_nvar_elim"
641                in
642                    dict := LtDict.insert(!dict, ltydepth, t);
643                    t
644                end
645        end (* lt_nvar_elim *)
646    in
647        lt_nvar_elim
648    end (* lt_nvar_elim_gen *)
649    
650    (************************************************************)
651    
652    type smap = (tvar * tyc) list
653    
654    (* is the intersection of two sorted lists non-nil? *)
655    fun intersectionNonEmpty(nil,_:tvar list) = false
656      | intersectionNonEmpty(_,nil) = false
657      | intersectionNonEmpty(s1 as (h1:tvar,_)::t1, s2 as h2::t2) =
658            case Int.compare (h1, h2) of
659                LESS => intersectionNonEmpty(t1, s2)
660              | GREATER => intersectionNonEmpty(s1, t2)
661              | EQUAL => true
662    
663    fun searchSubst (tv:tvar, s) =
664        let fun h [] = NONE
665              | h ((tv':tvar,tyc)::s) =
666                    case Int.compare (tv, tv') of
667                        LESS => NONE
668                      | GREATER => h s
669                      | EQUAL => SOME tyc
670        in h s
671        end
672    
673    fun tc_nvar_subst_gen() = let
674        val dict = ref (TcDict.mkDict())
675    
676        fun tc_nvar_subst subst = let
677            fun loop tyc =
678            (* check if substitution overlaps with free vars list *)
679            (case intersectionNonEmpty(subst, LK.tc_nvars tyc) of
680                 false => tyc               (* nothing to subst *)
681               | true =>
682                 (* next check the memoization table *)
683                 (case TcDict.peek(!dict, tyc) of
684                      SOME t => t           (* hit! *)
685                    | NONE =>
686                  let                       (* must recompute *)
687                      val t =
688                        case tc_out tyc of
689                            LK.TC_NVAR tv =>
690                                (case searchSubst(tv,subst) of
691                                     SOME t => t
692                                   | NONE => tyc
693                                     )
694                          | LK.TC_VAR _ => tyc
695                          | LK.TC_PRIM _ => tyc
696                          | LK.TC_FN (tks, t) =>
697                                tcc_fn (tks, loop t)
698                          | LK.TC_APP (t, ts) =>
699                                tcc_app (loop t, map loop ts)
700                          | LK.TC_SEQ ts =>
701                                tcc_seq (map loop ts)
702                          | LK.TC_PROJ (t, i) =>
703                                tcc_proj (loop t, i)
704                          | LK.TC_SUM ts =>
705                                tcc_sum (map loop ts)
706                          | LK.TC_FIX ((i,t,ts),j) =>
707                                tcc_fix ((i, loop t, map loop ts), j)
708                          | LK.TC_TUPLE (rf,ts) =>
709                                tcc_tuple (map loop ts)
710                          | LK.TC_ARROW (ff, ts, ts') =>
711                                tcc_arrow (ff, map loop ts, map loop ts')
712                          | LK.TC_PARROW (t, t') =>
713                                tcc_parrow (loop t, loop t')
714                          | LK.TC_BOX t =>
715                                tcc_box (loop t)
716                          | LK.TC_ABS t =>
717                                tcc_abs (loop t)
718                          | LK.TC_TOKEN (tok, t) =>
719                                tc_inj (LK.TC_TOKEN (tok, loop t))
720                          | LK.TC_CONT ts =>
721                                tcc_cont (map loop ts)
722                          | LK.TC_IND _ =>
723                                bug "unexpected TC_IND in substTyc"
724                          | LK.TC_ENV _ =>
725                                bug "unexpected TC_ENV in substTyc"
726                  in
727                      (* update memoization table *)
728                      dict := TcDict.insert(!dict, tyc, t);
729                      t
730                  end
731                      )) (* end cases *)
732        in loop
733        end (* tc_nvar_subst *)
734    in tc_nvar_subst
735    end (* tc_nvar_subst_gen *)
736    
737    fun lt_nvar_subst_gen() = let
738        val dict = ref (LtDict.mkDict())
739        val tc_nvar_subst' = tc_nvar_subst_gen()
740    
741        fun lt_nvar_subst subst = let
742            val tc_nvar_subst = tc_nvar_subst' subst
743    
744            fun loop lty =
745            (* check if there are any free type variables first *)
746            (case intersectionNonEmpty(subst, LK.lt_nvars lty) of
747                 false => lty                  (* nothing to subst *)
748               | true =>
749                 (* next check the memoization table *)
750                 (case LtDict.peek(!dict, lty) of
751                      SOME t => t           (* hit! *)
752                    | NONE =>
753                  let                       (* must recompute *)
754                      val t =
755                        case lt_out lty of
756                            LK.LT_TYC t =>
757                                ltc_tyc (tc_nvar_subst t)
758                          | LK.LT_STR ts =>
759                                ltc_str (map loop ts)
760                          | LK.LT_FCT (ts, ts') =>
761                                ltc_fct (map loop ts, map loop ts')
762                          | LK.LT_POLY (tks, ts) =>
763                                ltc_poly (tks, map loop ts)
764                          | LK.LT_CONT ts =>
765                                ltc_cont (map loop ts)
766                          | LK.LT_IND _ =>
767                                bug "unexpected LT_IND in lt_nvar_elim"
768                          | LK.LT_ENV _ =>
769                                bug "unexpected LT_ENV in lt_nvar_elim"
770                  in
771                      (* update memoization table *)
772                      dict := LtDict.insert(!dict, lty, t);
773                      t
774                  end
775                      )) (* end cases *)
776        in loop
777        end (* lt_nvar_subst *)
778    in lt_nvar_subst
779    end (* lt_nvar_subst_gen *)
780    
781    (************************************************************)
782    
783    (** building up a polymorphic type by abstracting over a
784     ** list of named vars
785     **)
786    type tvoffs = (tvar * int) list
787    
788    fun intersect(nil, _:tvar list) = nil
789      | intersect(_, nil) = nil
790      | intersect(s1 as (h1:tvar,n)::t1, s2 as h2::t2) =
791            case Int.compare (h1, h2) of
792                LESS => intersect(t1, s2)
793              | GREATER => intersect(s1, t2)
794              | EQUAL => (h1,n) :: intersect(t1, t2)
795    
796    val s_iter = Stats.makeStat "Cvt Iterations"
797    val s_hits = Stats.makeStat "Cvt Hits in dict"
798    val s_cuts = Stats.makeStat "Cvt Freevar cutoffs"
799    
800    val s_tvoffs = Stats.makeStat "Cvt tvoffs length"
801    val s_nvars = Stats.makeStat "Cvt free nvars length"
802    
803    fun tc_nvar_cvt_gen() = let
804        val dict = ref (TcDict.mkDict())
805    
806        fun tc_nvar_cvt (tvoffs:tvoffs) d tyc =
807            (Stats.addStat s_iter 1;
808             Stats.addStat s_tvoffs (length tvoffs);
809             Stats.addStat s_nvars (length (LK.tc_nvars tyc));
810            (* check if substitution overlaps with free vars list *)
811            case intersect(tvoffs, LK.tc_nvars tyc) of
812                [] => (Stats.addStat s_cuts 1;
813                       tyc           (* nothing to cvt *)
814                       )
815              | tvoffs =>
816        let
817            (* encode the tyc and the depth for memoization
818             * using tcc_proj *)
819            val tycdepth = tcc_proj (tyc, d)
820        in
821            case TcDict.peek(!dict, tycdepth) of
822                SOME t => (Stats.addStat s_hits 1;
823                           t                 (* hit! *)
824                           )
825              | NONE => let                 (* must recompute *)
826                    val r = tc_nvar_cvt tvoffs d (* default recursive invoc. *)
827                    val rs = map r          (* recursive invocation on list *)
828                    val t =
829                        case tc_out tyc of
830                            LK.TC_NVAR tvar =>
831                                (case searchSubst(tvar,tvoffs) of
832                                     SOME i => tcc_var (d, i)
833                                   | NONE => tyc)
834                          | LK.TC_VAR _ => tyc
835                          | LK.TC_PRIM _ => tyc
836                          | LK.TC_FN (tks, t) =>
837                                tcc_fn (tks, tc_nvar_cvt tvoffs (DI.next d) t)
838                          | LK.TC_APP (t, ts) =>
839                                tcc_app (r t, rs ts)
840                          | LK.TC_SEQ ts =>
841                                tcc_seq (rs ts)
842                          | LK.TC_PROJ (t, i) =>
843                                tcc_proj (r t, i)
844                          | LK.TC_SUM ts =>
845                                tcc_sum (rs ts)
846                          | LK.TC_FIX ((i,t,ts),j) =>
847                                tcc_fix ((i, r t, rs ts), j)
848                          | LK.TC_TUPLE (rf,ts) =>
849                                tcc_tuple (rs ts)
850                          | LK.TC_ARROW (ff, ts, ts') =>
851                                tcc_arrow (ff, rs ts, rs ts')
852                          | LK.TC_PARROW (t, t') =>
853                                tcc_parrow (r t, r t')
854                          | LK.TC_BOX t =>
855                                tcc_box (r t)
856                          | LK.TC_ABS t =>
857                                tcc_abs (r t)
858                          | LK.TC_TOKEN (tok, t) =>
859                                tc_inj (LK.TC_TOKEN (tok, r t))
860                          | LK.TC_CONT ts =>
861                                tcc_cont (rs ts)
862                          | LK.TC_IND _ =>
863                                bug "unexpected TC_IND in tc_nvar_cvt"
864                          | LK.TC_ENV _ =>
865                                bug "unexpected TC_ENV in tc_nvar_cvt"
866                in
867                    dict := TcDict.insert(!dict, tycdepth, t);
868                    t
869                end
870        end (* tc_nvar_cvt *)
871            )
872    in
873        tc_nvar_cvt
874    end (* tc_nvar_cvt_gen *)
875    
876    
877    fun lt_nvar_cvt_gen() = let
878        val dict = ref (LtDict.mkDict())
879        val tc_nvar_cvt = tc_nvar_cvt_gen()
880    
881        fun lt_nvar_cvt tvoffs d lty =
882            (* check if substitution overlaps with free vars list *)
883            case intersect(tvoffs, LK.lt_nvars lty) of
884                [] => lty                (* nothing to cvt *)
885              | tvoffs =>
886        let
887            (* encode the lty and depth info using LT_ENV
888             * (only first 2 args are useful) *)
889            val ltydepth = lt_inj (LK.LT_ENV (lty, d, 0, LK.initTycEnv))
890        in
891            case LtDict.peek(!dict, ltydepth) of
892                SOME t => t                 (* hit! *)
893              | NONE => let                 (* must recompute *)
894                    val r = lt_nvar_cvt tvoffs d (* default recursive invoc. *)
895                    val rs = map r          (* recursive invocation on list *)
896                    val t =
897                        case lt_out lty of
898                            LK.LT_TYC t =>
899                                ltc_tyc (tc_nvar_cvt tvoffs d t)
900                          | LK.LT_STR ts =>
901                                ltc_str (rs ts)
902                          | LK.LT_FCT (ts, ts') =>
903                                ltc_fct (rs ts, rs ts')
904                          | LK.LT_POLY (tks, ts) =>
905                                ltc_poly (tks,
906                                          map (lt_nvar_cvt tvoffs (DI.next d)) ts)
907                          | LK.LT_CONT ts =>
908                                ltc_cont (rs ts)
909                          | LK.LT_IND _ =>
910                                bug "unexpected LT_IND in lt_nvar_cvt"
911                          | LK.LT_ENV _ =>
912                                bug "unexpected LT_ENV in lt_nvar_cvt"
913                in
914                    dict := LtDict.insert(!dict, ltydepth, t);
915                    t
916                end
917        end (* lt_nvar_cvt *)
918    in
919        lt_nvar_cvt
920    end (* lt_nvar_cvt_gen *)
921    
922    
923  end (* top-level local *)  end (* top-level local *)
924  end (* structure LtyExtern *)  end (* structure LtyExtern *)
925    

Legend:
Removed from v.196  
changed lines
  Added in v.197

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