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 23, Thu Mar 12 00:49:56 1998 UTC revision 24, Thu Mar 12 00:49:58 1998 UTC
# Line 1  Line 1 
1  (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)  (* COPYRIGHT (c) 1996 Bell Laboratories *)
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_parrow(LT.ltc_tuple[LT.ltc_int,LT.ltc_int],LT.ltc_int)  val IntOpTy = LT.ltc_arw(LT.ltc_tuple[LT.ltc_int,LT.ltc_int],LT.ltc_int)
   
 (** based on the given tyc, return its appropriate Update operator *)  
 val tcUpd = LT.tc_upd_prim  
28    
29  (****************************************************************************  (****************************************************************************
30   *                   MISC UTILITY FUNCTIONS                                 *   *                   MISC UTILITY FUNCTIONS                                 *
# Line 38  Line 35 
35  fun ltAppSt x = case LT.lt_inst_st x  fun ltAppSt x = case LT.lt_inst_st x
36                   of [z] => z                   of [z] => z
37                    | _ => bug "unexpected in ltAppSt"                    | _ => bug "unexpected in ltAppSt"
38    val ltAppSt2 = Stats.doPhase(Stats.makePhase "Compiler 051 2-ltAppSt") ltAppSt
39    val ltAppSt = Stats.doPhase(Stats.makePhase "Compiler 051 1-ltAppSt") ltAppSt
40    
41  val ltArrow = LT.lt_arrow  val ltArrow = LT.lt_arrow
42  val ltSelect = LT.lt_select  val ltSelect = LT.lt_select
# Line 50  Line 49 
49  val lt_upd =  val lt_upd =
50    let val x = LT.ltc_array (LT.ltc_tv 0)    let val x = LT.ltc_array (LT.ltc_tv 0)
51     in LT.ltc_poly([LT.tkc_mono],     in LT.ltc_poly([LT.tkc_mono],
52                    [LT.ltc_arrow((true, true), [x, LT.ltc_int, LT.ltc_tv 0],                    [LT.ltc_arw(LT.ltc_tuple [x, LT.ltc_int, LT.ltc_tv 0],
53                                   [LT.ltc_unit])])                               LT.ltc_unit)])
54    end    end
55    
56  val lt_sub =  val lt_sub =
57    let val x = LT.ltc_array (LT.ltc_tv 0)    let val x = LT.ltc_array (LT.ltc_tv 0)
58     in LT.ltc_poly([LT.tkc_mono],     in LT.ltc_poly([LT.tkc_mono],
59                    [LT.ltc_arrow((true,true), [x, LT.ltc_int], [LT.ltc_tv 0])])                    [LT.ltc_arw(LT.ltc_tuple [x, LT.ltc_int], LT.ltc_tv 0)])
60    end    end
61    
62  datatype primKind = STANDARD | PARRAYOP | RARRAYOP  datatype primKind = STANDARD | PARRAYOP | RARRAYOP
# Line 77  Line 76 
76        if lt_eqv(t,lt_upd)        if lt_eqv(t,lt_upd)
77        then if tc_eqv(tc,tc_real)        then if tc_eqv(tc,tc_real)
78             then (PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}, RARRAYOP)             then (PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}, RARRAYOP)
79             else (let val np = tcUpd tc             else (let val np = LU.tcUpd tc
80                    in case np                    in case np
81                        of PO.UPDATE => (np, PARRAYOP)                        of PO.UPDATE => (np, PARRAYOP)
82                         | _ => (np, STANDARD)                         | _ => (np, STANDARD)
83                   end)                   end)
84        else (tcUpd tc, STANDARD)        else (LU.tcUpd tc, STANDARD)
85    | mkPrim(PO.SUBSCRIPT, _, _) = bug "unexpected SUBSCRIPT primops in mkPrim"    | mkPrim(PO.SUBSCRIPT, _, _) = bug "unexpected SUBSCRIPT primops in mkPrim"
86    | mkPrim(PO.UPDATE, _, _) = bug "unexpected UPDATE primops in mkPrim"    | mkPrim(PO.UPDATE, _, _) = bug "unexpected UPDATE primops in mkPrim"
87    | mkPrim(p, _, []) = bug "unexpected arguments in mkPrim"    | mkPrim(p, _, []) = bug "unexpected arguments in mkPrim"
# Line 103  Line 102 
102   *       the following invariants:                                          *   *       the following invariants:                                          *
103   *         The resulting lexp is a simply-typed lambda expression, and      *   *         The resulting lexp is a simply-typed lambda expression, and      *
104   *         all explicit type annotations can only be:  ltc_int, ltc_int32,  *   *         all explicit type annotations can only be:  ltc_int, ltc_int32,  *
105   *         ltc_real, ltc_void, ltc_parrow, ltc_tup, or ltc_cont.            *   *         ltc_real, ltc_void, ltc_arw, ltc_tup, or ltc_cont.               *
106   *                                                                          *   *                                                                          *
107   ****************************************************************************)   ****************************************************************************)
108  fun transform (wenv, venv, d) =  fun transform (wenv, venv, d) =
# Line 111  Line 110 
110    
111  val (tcWrap, ltWrap, tcsWrap) = LU.genWrap true  val (tcWrap, ltWrap, tcsWrap) = LU.genWrap true
112    
 fun fixDconTy lt =  
   let fun fix t =  
         (case LT.ltd_arrow t  
           of (ff, [aty], rtys) =>  
                (case ltWrap aty  
                  of NONE => t  
                   | SOME naty => LT.ltc_arrow(ff, [naty], rtys))  
            | _ => bug "unexpected type in fixDconTy")  
    in if LT.ltp_ppoly lt then  
         let val (ks, t) = LT.ltd_ppoly lt  
          in LT.ltc_ppoly(ks, fix t)  
         end  
       else fix lt  
   end (* function fixDconTy *)  
   
113  fun primExp(sv as (PRIM _ | GENOP _), t) =  fun primExp(sv as (PRIM _ | GENOP _), t) =
114        let val x = mkv()        let val x = mkv()
115            val (argt,_) = ltArrow t            val (argt,_) = ltArrow t
# Line 136  Line 120 
120  fun lpve sv =  fun lpve sv =
121    (case sv    (case sv
122      of VAR v => (SVAL sv, LT.ltLookup(venv, v, d))      of VAR v => (SVAL sv, LT.ltLookup(venv, v, d))
123       | (INT _ | WORD _) => (SVAL sv, LT.ltc_int)       | INT i =>
124            ((i+i+2; (SVAL sv, LT.ltc_int)) handle Overflow =>
125             (let val x = mkv()
126                  val z = i div 2
127                  val (ne,_) = loop(RECORD([INT z,INT (i-z)]))
128    
129                  (*
130                   *  The ordering of the above three lines has caused
131                   *  interesting trap-related instruction-scheduling bug. (zsh)
132                   *)
133               in (LET(x, ne, APP(PRIM(PO.IADD,IntOpTy,[]), VAR x)), LT.ltc_int)
134              end))
135         | WORD w =>
136            let val maxWord = 0wx20000000
137             in if Word.<(w, maxWord) then
138                  (SVAL sv, LT.ltc_int)
139                else let val addu =
140                           PO.ARITH{oper=PO.+, overflow=false, kind=PO.UINT 31}
141                         val x1 = Word.div(w, 0w2)
142                         val x2 = Word.-(w, x1)
143                         val (ne,_) = loop(RECORD [WORD x1, WORD x2])
144                         val x = mkv()
145                      in (LET(x, ne, APP(PRIM(addu, IntOpTy, []), VAR x)),
146                          LT.ltc_int)
147                     end
148            end
149       | (INT32 _ | WORD32 _) => (SVAL sv, LT.ltc_int32)       | (INT32 _ | WORD32 _) => (SVAL sv, LT.ltc_int32)
150       | REAL _ => (SVAL sv, LT.ltc_real)       | REAL _ => (SVAL sv, LT.ltc_real)
151       | STRING _ => (SVAL sv, LT.ltc_string)       | STRING _ => (SVAL sv, LT.ltc_string)
# Line 214  Line 223 
223            in (case tcsWrap ts            in (case tcsWrap ts
224                 of NONE => (hdr0(TAPP(nv, ts)), ltApply(lt, ts))                 of NONE => (hdr0(TAPP(nv, ts)), ltApply(lt, ts))
225                  | SOME nts =>                  | SOME nts =>
226                      let val nt = ltAppSt(lt, nts)                      let val nt = ltAppSt2(lt, nts)
227                          val ot = ltAppSt(lt, ts)                          val ot = ltAppSt2(lt, ts)
228                          val hdr = CO.unwrapOp (wenv, nt, ot, d)                          val hdr = CO.unwrapOp (wenv, nt, ot, d)
229    
230                       in (hdr0(hdr(TAPP(nv, nts))), ot)                       in (hdr0(hdr(TAPP(nv, nts))), ot)
# Line 236  Line 245 
245                 of NONE => (hdr0(CON(x, ts, nv)), res)                 of NONE => (hdr0(CON(x, ts, nv)), res)
246                  | SOME nargt =>                  | SOME nargt =>
247                      let val hdr = CO.wrapOp (wenv, nargt, argt, d)                      let val hdr = CO.wrapOp (wenv, nargt, argt, d)
                         val x = (name, rep, fixDconTy lt)  
248                          val ne = hdr0(hdr(SVAL nv))                          val ne = hdr0(hdr(SVAL nv))
249                       in case ne                       in case ne
250                           of SVAL nnv => (CON(x, ts, nnv), res)                           of SVAL nnv => (CON(x, ts, nnv), res)
# Line 257  Line 265 
265                 of NONE => (hdr0(DECON(x, ts, nv)), res)                 of NONE => (hdr0(DECON(x, ts, nv)), res)
266                  | SOME nres =>                  | SOME nres =>
267                      let val hdr = CO.unwrapOp (wenv, nres, res, d)                      let val hdr = CO.unwrapOp (wenv, nres, res, d)
                         val x = (name, rep, fixDconTy lt)  
268                       in (hdr(hdr0(DECON(x, ts, nv))), res)                       in (hdr(hdr0(DECON(x, ts, nv))), res)
269                      end)                      end)
270           end           end

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