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

Diff of /sml/trunk/src/compiler/FLINT/reps/wrapping.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) 1996 Bell Laboratories *)  (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)
2  (* wrapping.sml *)  (* wrapping.sml *)
3    
4  signature WRAPPING =  signature WRAPPING =
# Line 24  Line 24 
24    
25  val mkv = LambdaVar.mkLvar  val mkv = LambdaVar.mkLvar
26  val ident = fn le => le  val ident = fn le => le
27  val IntOpTy = LT.ltc_arw(LT.ltc_tuple[LT.ltc_int,LT.ltc_int],LT.ltc_int)  val IntOpTy = LT.ltc_parrow(LT.ltc_tuple[LT.ltc_int,LT.ltc_int],LT.ltc_int)
28    
29    (** based on the given tyc, return its appropriate Update operator *)
30    val tcUpd = LT.tc_upd_prim
31    
32  (****************************************************************************  (****************************************************************************
33   *                   MISC UTILITY FUNCTIONS                                 *   *                   MISC UTILITY FUNCTIONS                                 *
# Line 35  Line 38 
38  fun ltAppSt x = case LT.lt_inst_st x  fun ltAppSt x = case LT.lt_inst_st x
39                   of [z] => z                   of [z] => z
40                    | _ => bug "unexpected in ltAppSt"                    | _ => bug "unexpected in ltAppSt"
 val ltAppSt2 = Stats.doPhase(Stats.makePhase "Compiler 051 2-ltAppSt") ltAppSt  
 val ltAppSt = Stats.doPhase(Stats.makePhase "Compiler 051 1-ltAppSt") ltAppSt  
41    
42  val ltArrow = LT.lt_arrow  val ltArrow = LT.lt_arrow
43  val ltSelect = LT.lt_select  val ltSelect = LT.lt_select
# Line 49  Line 50 
50  val lt_upd =  val lt_upd =
51    let val x = LT.ltc_array (LT.ltc_tv 0)    let val x = LT.ltc_array (LT.ltc_tv 0)
52     in LT.ltc_poly([LT.tkc_mono],     in LT.ltc_poly([LT.tkc_mono],
53                    [LT.ltc_arw(LT.ltc_tuple [x, LT.ltc_int, LT.ltc_tv 0],                    [LT.ltc_arrow(LT.ffc_rrflint, [x, LT.ltc_int, LT.ltc_tv 0],
54                               LT.ltc_unit)])                                   [LT.ltc_unit])])
55    end    end
56    
57  val lt_sub =  val lt_sub =
58    let val x = LT.ltc_array (LT.ltc_tv 0)    let val x = LT.ltc_array (LT.ltc_tv 0)
59     in LT.ltc_poly([LT.tkc_mono],     in LT.ltc_poly([LT.tkc_mono],
60                    [LT.ltc_arw(LT.ltc_tuple [x, LT.ltc_int], LT.ltc_tv 0)])                    [LT.ltc_arrow(LT.ffc_rrflint, [x, LT.ltc_int], [LT.ltc_tv 0])])
61    end    end
62    
63  datatype primKind = STANDARD | PARRAYOP | RARRAYOP  datatype primKind = STANDARD | PARRAYOP | RARRAYOP
# Line 76  Line 77 
77        if lt_eqv(t,lt_upd)        if lt_eqv(t,lt_upd)
78        then if tc_eqv(tc,tc_real)        then if tc_eqv(tc,tc_real)
79             then (PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}, RARRAYOP)             then (PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}, RARRAYOP)
80             else (let val np = LU.tcUpd tc             else (let val np = tcUpd tc
81                    in case np                    in case np
82                        of PO.UPDATE => (np, PARRAYOP)                        of PO.UPDATE => (np, PARRAYOP)
83                         | _ => (np, STANDARD)                         | _ => (np, STANDARD)
84                   end)                   end)
85        else (LU.tcUpd tc, STANDARD)        else (tcUpd tc, STANDARD)
86    | mkPrim(PO.SUBSCRIPT, _, _) = bug "unexpected SUBSCRIPT primops in mkPrim"    | mkPrim(PO.SUBSCRIPT, _, _) = bug "unexpected SUBSCRIPT primops in mkPrim"
87    | mkPrim(PO.UPDATE, _, _) = bug "unexpected UPDATE primops in mkPrim"    | mkPrim(PO.UPDATE, _, _) = bug "unexpected UPDATE primops in mkPrim"
88    | mkPrim(p, _, []) = bug "unexpected arguments in mkPrim"    | mkPrim(p, _, []) = bug "unexpected arguments in mkPrim"
# Line 102  Line 103 
103   *       the following invariants:                                          *   *       the following invariants:                                          *
104   *         The resulting lexp is a simply-typed lambda expression, and      *   *         The resulting lexp is a simply-typed lambda expression, and      *
105   *         all explicit type annotations can only be:  ltc_int, ltc_int32,  *   *         all explicit type annotations can only be:  ltc_int, ltc_int32,  *
106   *         ltc_real, ltc_void, ltc_arw, ltc_tup, or ltc_cont.               *   *         ltc_real, ltc_void, ltc_parrow, ltc_tup, or ltc_cont.            *
107   *                                                                          *   *                                                                          *
108   ****************************************************************************)   ****************************************************************************)
109  fun transform (wenv, venv, d) =  fun transform (wenv, venv, d) =
# Line 110  Line 111 
111    
112  val (tcWrap, ltWrap, tcsWrap) = LU.genWrap true  val (tcWrap, ltWrap, tcsWrap) = LU.genWrap true
113    
114    fun fixDconTy lt =
115      let fun fix t =
116            (case LT.ltd_arrow t
117              of (ff, [aty], rtys) =>
118                   (case ltWrap aty
119                     of NONE => t
120                      | SOME naty => LT.ltc_arrow(ff, [naty], rtys))
121               | _ => bug "unexpected type in fixDconTy")
122       in if LT.ltp_ppoly lt then
123            let val (ks, t) = LT.ltd_ppoly lt
124             in LT.ltc_ppoly(ks, fix t)
125            end
126          else fix lt
127      end (* function fixDconTy *)
128    
129  fun primExp(sv as (PRIM _ | GENOP _), t) =  fun primExp(sv as (PRIM _ | GENOP _), t) =
130        let val x = mkv()        let val x = mkv()
131            val (argt,_) = ltArrow t            val (argt,_) = ltArrow t
# Line 120  Line 136 
136  fun lpve sv =  fun lpve sv =
137    (case sv    (case sv
138      of VAR v => (SVAL sv, LT.ltLookup(venv, v, d))      of VAR v => (SVAL sv, LT.ltLookup(venv, v, d))
139       | INT i =>       | (INT _ | WORD _) => (SVAL sv, LT.ltc_int)
         ((i+i+2; (SVAL sv, LT.ltc_int)) handle Overflow =>  
          (let val x = mkv()  
               val z = i div 2  
               val (ne,_) = loop(RECORD([INT z,INT (i-z)]))  
   
               (*  
                *  The ordering of the above three lines has caused  
                *  interesting trap-related instruction-scheduling bug. (zsh)  
                *)  
            in (LET(x, ne, APP(PRIM(PO.IADD,IntOpTy,[]), VAR x)), LT.ltc_int)  
           end))  
      | WORD w =>  
         let val maxWord = 0wx20000000  
          in if Word.<(w, maxWord) then  
               (SVAL sv, LT.ltc_int)  
             else let val addu =  
                        PO.ARITH{oper=PO.+, overflow=false, kind=PO.UINT 31}  
                      val x1 = Word.div(w, 0w2)  
                      val x2 = Word.-(w, x1)  
                      val (ne,_) = loop(RECORD [WORD x1, WORD x2])  
                      val x = mkv()  
                   in (LET(x, ne, APP(PRIM(addu, IntOpTy, []), VAR x)),  
                       LT.ltc_int)  
                  end  
         end  
140       | (INT32 _ | WORD32 _) => (SVAL sv, LT.ltc_int32)       | (INT32 _ | WORD32 _) => (SVAL sv, LT.ltc_int32)
141       | REAL _ => (SVAL sv, LT.ltc_real)       | REAL _ => (SVAL sv, LT.ltc_real)
142       | STRING _ => (SVAL sv, LT.ltc_string)       | STRING _ => (SVAL sv, LT.ltc_string)
# Line 223  Line 214 
214            in (case tcsWrap ts            in (case tcsWrap ts
215                 of NONE => (hdr0(TAPP(nv, ts)), ltApply(lt, ts))                 of NONE => (hdr0(TAPP(nv, ts)), ltApply(lt, ts))
216                  | SOME nts =>                  | SOME nts =>
217                      let val nt = ltAppSt2(lt, nts)                      let val nt = ltAppSt(lt, nts)
218                          val ot = ltAppSt2(lt, ts)                          val ot = ltAppSt(lt, ts)
219                          val hdr = CO.unwrapOp (wenv, nt, ot, d)                          val hdr = CO.unwrapOp (wenv, nt, ot, d)
220    
221                       in (hdr0(hdr(TAPP(nv, nts))), ot)                       in (hdr0(hdr(TAPP(nv, nts))), ot)
# Line 245  Line 236 
236                 of NONE => (hdr0(CON(x, ts, nv)), res)                 of NONE => (hdr0(CON(x, ts, nv)), res)
237                  | SOME nargt =>                  | SOME nargt =>
238                      let val hdr = CO.wrapOp (wenv, nargt, argt, d)                      let val hdr = CO.wrapOp (wenv, nargt, argt, d)
239                            val x = (name, rep, fixDconTy lt)
240                          val ne = hdr0(hdr(SVAL nv))                          val ne = hdr0(hdr(SVAL nv))
241                       in case ne                       in case ne
242                           of SVAL nnv => (CON(x, ts, nnv), res)                           of SVAL nnv => (CON(x, ts, nnv), res)
# Line 265  Line 257 
257                 of NONE => (hdr0(DECON(x, ts, nv)), res)                 of NONE => (hdr0(DECON(x, ts, nv)), res)
258                  | SOME nres =>                  | SOME nres =>
259                      let val hdr = CO.unwrapOp (wenv, nres, res, d)                      let val hdr = CO.unwrapOp (wenv, nres, res, d)
260                            val x = (name, rep, fixDconTy lt)
261                       in (hdr(hdr0(DECON(x, ts, nv))), res)                       in (hdr(hdr0(DECON(x, ts, nv))), res)
262                      end)                      end)
263           end           end

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