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/primop-branch-2/src/compiler/FLINT/trans/translate.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml

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

revision 587, Thu Mar 30 09:01:52 2000 UTC revision 1180, Tue Mar 26 22:24:24 2002 UTC
# Line 5  Line 5 
5  sig  sig
6    
7    (* Invariant: transDec always applies to a top-level absyn declaration *)    (* Invariant: transDec always applies to a top-level absyn declaration *)
8    val transDec : Absyn.dec * Access.lvar list    val transDec : { rootdec: Absyn.dec,
9                   * StaticEnv.staticEnv * CompBasic.compInfo                     exportLvars: Access.lvar list,
10                       env: StaticEnv.staticEnv,
11                       cproto_conv: string,
12                       compInfo: Absyn.dec CompInfo.compInfo }
13                   -> {flint: FLINT.prog,                   -> {flint: FLINT.prog,
14                       imports: (PersStamps.persstamp                       imports: (PersStamps.persstamp
15                                 * CompBasic.importTree) list}                                 * ImportTree.importTree) list}
16    
17  end (* signature TRANSLATE *)  end (* signature TRANSLATE *)
18    
# Line 21  Line 24 
24        structure DA = Access        structure DA = Access
25        structure DI = DebIndex        structure DI = DebIndex
26        structure EM = ErrorMsg        structure EM = ErrorMsg
       structure CB = CompBasic  
27        structure II = InlInfo        structure II = InlInfo
28        structure LT = PLambdaType        structure LT = PLambdaType
29        structure M  = Modules        structure M  = Modules
# Line 65  Line 67 
67  (** old-style fold for cases where it is partially applied *)  (** old-style fold for cases where it is partially applied *)
68  fun fold f l init = foldr f init l  fun fold f l init = foldr f init l
69    
 (*  
  * MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken  
  * from the LambdaVar module; I think it should be taken from the  
  * "compInfo". Similarly, should we replace all mkLvar in the backend  
  * with the mkv in "compInfo" ? (ZHONG)  
  *)  
 val mkv = LambdaVar.mkLvar  
 fun mkvN NONE = mkv()  
   | mkvN (SOME s) = LambdaVar.namedLvar s  
   
70  (** sorting the record fields for record types and record expressions *)  (** sorting the record fields for record types and record expressions *)
71  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)
72  fun sorted x = ListMergeSort.sorted elemgtr x  fun sorted x = ListMergeSort.sorted elemgtr x
# Line 95  Line 87 
87   *                 * StaticEnv.staticEnv * CompBasic.compInfo               *   *                 * StaticEnv.staticEnv * CompBasic.compInfo               *
88   *                 -> {flint: FLINT.prog,                                   *   *                 -> {flint: FLINT.prog,                                   *
89   *                     imports: (PersStamps.persstamp                       *   *                     imports: (PersStamps.persstamp                       *
90   *                               * CompBasic.importTree) list}              *   *                               * ImportTree.importTree) list}             *
91   ****************************************************************************)   ****************************************************************************)
92    
93  fun transDec (rootdec, exportLvars, env,  fun transDec
94                compInfo as {coreEnv,errorMatch,error,...}: CB.compInfo) =          { rootdec, exportLvars, env, cproto_conv,
95             compInfo as {errorMatch,error,...}: Absyn.dec CompInfo.compInfo } =
96  let  let
97    
98    (* We take mkLvar from compInfo.  This should answer Zhong's question... *)
99    (*
100    (*
101     * MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken
102     * from the LambdaVar module; I think it should be taken from the
103     * "compInfo". Similarly, should we replace all mkLvar in the backend
104     * with the mkv in "compInfo" ? (ZHONG)
105     *)
106    val mkv = LambdaVar.mkLvar
107    fun mkvN NONE = mkv()
108      | mkvN (SOME s) = LambdaVar.namedLvar s
109    *)
110    
111    val mkvN = #mkLvar compInfo
112    fun mkv () = mkvN NONE
113    
114  (** generate the set of ML-to-FLINT type translation functions *)  (** generate the set of ML-to-FLINT type translation functions *)
115  val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty} = TT.genTT()  val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty, markLBOUND} =
116        TT.genTT()
117  fun toTcLt d = (toTyc d, toLty d)  fun toTcLt d = (toTyc d, toLty d)
118    
119  (** translating the typ field in DATACON into lty; constant datacons  (** translating the typ field in DATACON into lty; constant datacons
# Line 120  Line 130 
130    
131  (** the special lookup functions for the Core environment *)  (** the special lookup functions for the Core environment *)
132  fun coreLookup(id, env) =  fun coreLookup(id, env) =
133    let val sp = SymPath.SPATH [S.strSymbol "Core", S.varSymbol id]    let val sp = SymPath.SPATH [CoreSym.coreSym, S.varSymbol id]
134        val err = fn _ => fn _ => fn _ => raise NoCore        val err = fn _ => fn _ => fn _ => raise NoCore
135     in Lookup.lookVal(env, sp, err)     in Lookup.lookVal(env, sp, err)
136    end    end
# Line 174  Line 184 
184    
185  (** hashkey of accesspath + accesspath + resvar *)  (** hashkey of accesspath + accesspath + resvar *)
186  type info = (key * int list * lvar)  type info = (key * int list * lvar)
187  val hashtable : info list Intmap.intmap = Intmap.new(32,HASHTABLE)  val hashtable : info list IntHashTable.hash_table =
188        IntHashTable.mkTable(32,HASHTABLE)
189  fun hashkey l = foldr (fn (x,y) => ((x * 10 + y) mod 1019)) 0 l  fun hashkey l = foldr (fn (x,y) => ((x * 10 + y) mod 1019)) 0 l
190    
191  fun buildHdr v =  fun buildHdr v =
192    let val info = Intmap.map hashtable v    let val info = IntHashTable.lookup hashtable v
193        fun h((_, l, w), hdr) =        fun h((_, l, w), hdr) =
194               let val le = foldl (fn (k,e) => SELECT(k,e)) (VAR v) l               let val le = foldl (fn (k,e) => SELECT(k,e)) (VAR v) l
195                in fn e => hdr(LET(w, le, e))                in fn e => hdr(LET(w, le, e))
# Line 188  Line 199 
199    
200  fun bindvar (v, [], _) =  v  fun bindvar (v, [], _) =  v
201    | bindvar (v, l, nameOp) =    | bindvar (v, l, nameOp) =
202        let val info = (Intmap.map hashtable v) handle _ => []        let val info = (IntHashTable.lookup hashtable v) handle _ => []
203            val key = hashkey l            val key = hashkey l
204            fun h [] =            fun h [] =
205                  let val u = mkvN nameOp                  let val u = mkvN nameOp
206                   in Intmap.add hashtable (v,(key,l,u)::info); u                   in IntHashTable.insert hashtable (v,(key,l,u)::info); u
207                  end                  end
208              | h((k',l',w)::r) =              | h((k',l',w)::r) =
209                  if (k' = key) then (if (l'=l) then w else h r) else h r                  if (k' = key) then (if (l'=l) then w else h r) else h r
# Line 281  Line 292 
292   * clean up this is to put all the core constructors and primitives into   * clean up this is to put all the core constructors and primitives into
293   * the primitive environment. (ZHONG)   * the primitive environment. (ZHONG)
294   *)   *)
295    exception NoCore
296    
297  fun coreExn id =  fun coreExn id =
298    ((case coreLookup(id, coreEnv)      (case CoreAccess.getCon' (fn () => raise NoCore) (env, id) of
299       of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>           TP.DATACON { name, rep as DA.EXN _, typ, ... } =>
300            let val nt = toDconLty DI.top typ            let val nt = toDconLty DI.top typ
301                val nrep = mkRep(rep, nt, name)                val nrep = mkRep(rep, nt, name)
302             in CON'((name, nrep, nt), [], unitLexp)             in CON'((name, nrep, nt), [], unitLexp)
303            end            end
304        | _ => bug "coreExn in translate")        | _ => bug "coreExn in translate")
305     handle NoCore => (say "WARNING: no Core access \n"; INT 0))      handle NoCore => (say "WARNING: no Core access\n"; INT 0)
306    
307  and coreAcc id =  and coreAcc id =
308    ((case coreLookup(id, coreEnv)      (case CoreAccess.getVar' (fn () => raise NoCore) (env, id) of
309       of V.VAL(V.VALvar{access, typ, path, ...}) =>           V.VALvar { access, typ, path, ... } =>
310             mkAccT(access, toLty DI.top (!typ), getNameOp path)             mkAccT(access, toLty DI.top (!typ), getNameOp path)
311        | _ => bug "coreAcc in translate")        | _ => bug "coreAcc in translate")
312     handle NoCore => (say "WARNING: no Core access \n"; INT 0))      handle NoCore => (say "WARNING: no Core access\n"; INT 0)
   
313    
314  (** expands the flex record pattern and convert the EXN access pat *)  (** expands the flex record pattern and convert the EXN access pat *)
315  (** internalize the conrep's access, always exceptions *)  (** internalize the conrep's access, always exceptions *)
# Line 436  Line 448 
448  fun cmpOp p = PRIM(p, lt_icmp, [])  fun cmpOp p = PRIM(p, lt_icmp, [])
449  fun inegOp p = PRIM(p, lt_ineg, [])  fun inegOp p = PRIM(p, lt_ineg, [])
450    
 fun ADD(b,c) = APP(intOp(PO.IADD), RECORD[b, c])  
 fun SUB(b,c) = APP(intOp(PO.ISUB), RECORD[b, c])  
 fun MUL(b,c) = APP(intOp(PO.IMUL), RECORD[b, c])  
451  fun DIV(b,c) = APP(intOp(PO.IDIV), RECORD[b, c])  fun DIV(b,c) = APP(intOp(PO.IDIV), RECORD[b, c])
452  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}
453    
454    (* pure arith on int31 (guaranteed to not overflow) *)
455    val pIADD = PO.ARITH { oper=PO.+, overflow = false, kind = PO.INT 31 }
456    val pISUB = PO.ARITH { oper=PO.-, overflow = false, kind = PO.INT 31 }
457    val pIMUL = PO.ARITH { oper=PO.*, overflow = false, kind = PO.INT 31 }
458    fun pADD(b,c) = APP(intOp pIADD, RECORD [b, c])
459    fun pSUB(b,c) = APP(intOp pISUB, RECORD [b, c])
460    fun pMUL(b,c) = APP(intOp pIMUL, RECORD [b, c])
461    
462    fun CMP (cop, e1, e2) = APP (cmpOp cop, RECORD [e1, e2])
463    fun EQ (e1, e2) = CMP (PO.IEQL, e1, e2)
464    fun NONNEG e = CMP (PO.IGE, e, INT 0)
465    fun ISZERO e = EQ (e, INT 0)
466    
467  val lt_len = LT.ltc_poly([LT.tkc_mono], [lt_arw(LT.ltc_tv 0, lt_int)])  val lt_len = LT.ltc_poly([LT.tkc_mono], [lt_arw(LT.ltc_tv 0, lt_int)])
468  val lt_upd =  val lt_upd =
469    let val x = LT.ltc_ref (LT.ltc_tv 0)    let val x = LT.ltc_ref (LT.ltc_tv 0)
# Line 500  Line 522 
522                end                end
523    
524          | g (PO.INLDIV) =          | g (PO.INLDIV) =
525              (* This should give a slightly faster path through this
526               * operation for the frequent case that the result is non-negative.
527               * Some hardware calculates the remainder as part of the DIV
528               * operation -- in which case we could save the MUL step.
529               * This will have to be done in the backend because it is
530               * architecture-specific. *)
531              let val a = mkv () and b = mkv ()
532                  and q = mkv () and z = mkv ()
533              in
534                  FN (z, lt_ipair,
535                      LET (a, SELECT (0, VAR z),
536                           LET (b, SELECT (1, VAR z),
537                                LET (q, DIV (VAR a, VAR b),
538                                     COND (NONNEG (VAR q), VAR q,
539                                           COND (EQ (VAR a, pMUL (VAR q, VAR b)),
540                                                 VAR q,
541                                                 pSUB (VAR q, INT 1)))))))
542              end
543    (*
544                let val a = mkv() and b = mkv() and z = mkv()                let val a = mkv() and b = mkv() and z = mkv()
545                 in FN(z, lt_ipair,                 in FN(z, lt_ipair,
546                      LET(a, SELECT(0, VAR z),                      LET(a, SELECT(0, VAR z),
# Line 512  Line 553 
553                                 SUB(DIV(SUB(VAR a, INT 1), VAR b), INT 1),                                 SUB(DIV(SUB(VAR a, INT 1), VAR b), INT 1),
554                                 DIV(VAR a, VAR b))))))                                 DIV(VAR a, VAR b))))))
555                end                end
556    *)
557          | g (PO.INLMOD) =          | g (PO.INLMOD) =
558              (* Same here: Fast path for q >= 0.  However, since the remainder
559               * is the intended result, we can't avoid the MUL.  On architectures
560               * where r is directly available, this should rather be done
561               * in the backend. *)
562              let val a = mkv () and b = mkv ()
563                  and q = mkv () and r = mkv ()
564                  and z = mkv ()
565              in
566                  FN (z, lt_ipair,
567                      LET (a, SELECT (0, VAR z),
568                           LET (b, SELECT (1, VAR z),
569                                LET (q, DIV (VAR a, VAR b),
570                                     LET (r, pSUB (VAR a, pMUL (VAR q, VAR b)),
571                                          COND (NONNEG (VAR q), VAR r,
572                                                COND (ISZERO (VAR r), VAR r,
573                                                      pADD (VAR r, VAR b))))))))
574              end
575    (*
576                let val a = mkv() and b = mkv() and z = mkv()                let val a = mkv() and b = mkv() and z = mkv()
577                 in FN(z, lt_ipair,                 in FN(z, lt_ipair,
578                      LET(a,SELECT(0, VAR z),                      LET(a,SELECT(0, VAR z),
# Line 536  Line 595 
595                                      SUB(VAR a, MUL(DIV(VAR a, VAR b),                                      SUB(VAR a, MUL(DIV(VAR a, VAR b),
596                                                     VAR b))))))))                                                     VAR b))))))))
597                end                end
598    *)
599          | g (PO.INLREM) =          | g (PO.INLREM) =
600                let val a = mkv() and b = mkv() and z = mkv()                let val a = mkv() and b = mkv() and z = mkv()
601                 in FN(z, lt_ipair,                 in FN(z, lt_ipair,
602                      LET(a, SELECT(0,VAR z),                      LET(a, SELECT(0,VAR z),
603                        LET(b, SELECT(1,VAR z),                        LET(b, SELECT(1,VAR z),
604                            SUB(VAR a, MUL(DIV(VAR a,VAR b),VAR b)))))                            pSUB(VAR a, pMUL(DIV(VAR a,VAR b),VAR b)))))
605                end                end
606    
607          | g (PO.INLMIN) =          | g (PO.INLMIN) =
# Line 735  Line 794 
794        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)
795    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
796    
797  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, SOME typ), ...}, ts, d) =  fun mkVE (v, ts, d) = let
798        (case (p, ts)      fun otherwise () =
799          of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)          case ts of
800           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, toTcLt d), toLty d t)              [] => mkVar (v, d)
801              | _ => TAPP(mkVar(v, d), map (toTyc d) ts)
802    in
803        case v of
804            V.VALvar { info, ... } =>
805            II.match info
806               { inl_prim = fn (p, typ) =>
807                 (case (p, ts) of
808                      (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)
809                    | (PO.POLYNEQ, [t]) =>
810                      composeNOT(eqGen(typ, t, toTcLt d), toLty d t)
811           | (PO.INLMKARRAY, [t]) =>           | (PO.INLMKARRAY, [t]) =>
812                  let val dict =                  let val dict =
813                        {default = coreAcc "mkNormArray",                        {default = coreAcc "mkNormArray",
814                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}
815                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)
816                  end                  end
817           | _ => transPrim(p, (toLty d typ), map (toTyc d) ts))                  | (PO.RAW_CCALL NONE, [a, b, c]) =>
818                      let val i = SOME (CProto.decode cproto_conv
819    | mkVE (v as V.VALvar {info=II.INL_PRIM(p, NONE), typ, ...}, ts, d) =                                                    { fun_ty = a, encoding = b })
820        (case ts of [] => transPrim(p, (toLty d (!typ)), [])                                handle CProto.BadEncoding => NONE
821                  | [x] =>                    in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)
822                     (* a temporary hack to resolve the boot/built-in.sml file *)                    end
823                     (let val lt = toLty d (!typ)                  | _ => transPrim(p, (toLty d typ), map (toTyc d) ts)),
824                          val nt = toLty d x               inl_str = fn _ => otherwise (),
825                       in if LT.lt_eqv(LT.ltc_top, lt)               inl_no = fn () => otherwise () }
826                          then transPrim(p, nt, [])        | _ => otherwise ()
827                          else bug "unexpected primop in mkVE"  end
                     end)  
                 | _ => bug "unexpected poly primops in mkVE")  
   
   | mkVE (v, [], d) = mkVar(v, d)  
   | mkVE (v, ts, d) = TAPP(mkVar(v, d), map (toTyc d) ts)  
828    
829  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
830    let val lt = toDconLty d typ    let val lt = toDconLty d typ
# Line 813  Line 877 
877        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
878    
879            fun g (i, []) = ()            fun g (i, []) = ()
880              | g (i, (tv as ref (TP.OPEN _))::rest) =              | g (i, (tv as ref (TP.OPEN _))::rest) = let
881                     (tv := TP.LBOUND{depth=d, num=i}; g(i+1,rest))                    val m = markLBOUND (d, i);
882              | g (i, (tv as ref (TP.LBOUND _))::res) =                in
883                     bug ("unexpected tyvar LBOUND in mkPE")                    tv := TP.TV_MARK m;
884                      g (i+1, rest)
885                  end
886                | g (i, (tv as ref (TP.TV_MARK _))::res) =
887                       bug ("unexpected tyvar TV_MARK in mkPE")
888              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"
889    
890            val _ = g(0, boundtvs) (* assign the LBOUND tyvars *)            val _ = g(0, boundtvs) (* assign the TV_MARK tyvars *)
891            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
892    
893            fun h ([], []) = ()            fun h ([], []) = ()
# Line 1117  Line 1185 
1185  fun wrapPidInfo (body, pidinfos) =  fun wrapPidInfo (body, pidinfos) =
1186    let val imports =    let val imports =
1187          let fun p2itree (ANON xl) =          let fun p2itree (ANON xl) =
1188                    CB.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)                    ImportTree.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)
1189                | p2itree (NAMED _) = CB.ITNODE []                | p2itree (NAMED _) = ImportTree.ITNODE []
1190           in map (fn (p, pi) => (p, p2itree pi)) pidinfos           in map (fn (p, pi) => (p, p2itree pi)) pidinfos
1191          end          end
1192  (*  (*
1193        val _ = let val _ = say "\n ****************** \n"        val _ = let val _ = say "\n ****************** \n"
1194                    val _ = say "\n the current import tree is :\n"                    val _ = say "\n the current import tree is :\n"
1195                    fun tree (CB.ITNODE []) = ["\n"]                    fun tree (ImportTree.ITNODE []) = ["\n"]
1196                      | tree (CB.ITNODE xl) =                      | tree (ImportTree.ITNODE xl) =
1197                          foldr (fn ((i, x), z) =>                          foldr (fn ((i, x), z) =>
1198                            let val ts = tree x                            let val ts = tree x
1199                                val u = (Int.toString i)  ^ "   "                                val u = (Int.toString i)  ^ "   "
# Line 1187  Line 1255 
1255    
1256  end (* top-level local *)  end (* top-level local *)
1257  end (* structure Translate *)  end (* structure Translate *)
   
   

Legend:
Removed from v.587  
changed lines
  Added in v.1180

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