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

Diff of /sml/trunk/src/compiler/FLINT/opt/optutils.sml

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

revision 163, Thu Oct 29 21:00:27 1998 UTC revision 203, Sat Dec 19 20:51:39 1998 UTC
# Line 4  Line 4 
4  signature OPT_UTILS =  signature OPT_UTILS =
5  sig  sig
6    
7        datatype ('a,'b) either = A of 'a | B of 'b
8    
9      (* takes the fk of a function and returns the fk of the wrapper      (* takes the fk of a function and returns the fk of the wrapper
10       * along with the new fk of the actual body *)       * along with the new fk of the actual body *)
11      val fk_wrap : FLINT.fkind * FLINT.lty list option ->      val fk_wrap : FLINT.fkind * FLINT.lty list option ->
12                        (FLINT.fkind * FLINT.fkind)                        (FLINT.fkind * FLINT.fkind)
13    
     (* sometimes I get fed up rewriting the identity function *)  
     val id : 'a -> 'a  
   
14      (* this is a known APL function, but I don't know its real name *)      (* this is a known APL function, but I don't know its real name *)
15      val filter : bool list * 'a list -> 'a list      val filter : bool list -> 'a list -> 'a list
16    
17        (* A less brain-dead version of ListPair.all: returns false if
18         * length l1 <> length l2 *)
19        val ListPair_all : ('a * 'b -> bool) -> 'a list * 'b list -> bool
20    
21        val pow2 : int -> int
22    
23        (* This is not a proper transposition in that the order is reversed
24         * in the following way:  transpose x = map rev (proper_trans x) *)
25        exception Unbalanced
26        val transpose : 'a list list -> 'a list list
27    
28        val foldl3 : ('a * 'b * 'c * 'd -> 'd) -> 'd -> 'a list * 'b list * 'c list -> 'd
29  end  end
30    
31  structure OptUtils :> OPT_UTILS =  structure OptUtils :> OPT_UTILS =
# Line 21  Line 33 
33  local structure F = FLINT  local structure F = FLINT
34        structure LK = LtyKernel        structure LK = LtyKernel
35  in  in
36        datatype ('a,'b) either = A of 'a | B of 'b
37    
38      fun bug msg = ErrorMsg.impossible ("OptUtils: "^msg)      fun bug msg = ErrorMsg.impossible ("OptUtils: "^msg)
39    
40      fun fk_wrap (F.FK_FCT,_) = (F.FK_FCT, F.FK_FCT)      fun fk_wrap ({inline,known,isrec,cconv},rtys') =
41        | fk_wrap (F.FK_FUN{isrec,known,fixed,inline},rtys') =          let val cconv' =
42          let val fixed' = case fixed                  case cconv
43                            of LK.FF_VAR(f1,f2) => LK.FF_VAR(true, f2)                   of F.CC_FUN(LK.FF_VAR(f1,f2)) => F.CC_FUN(LK.FF_VAR(true, f2))
44                             | LK.FF_FIXED => LK.FF_FIXED                    | (F.CC_FCT | F.CC_FUN(LK.FF_FIXED)) => cconv
45          in (F.FK_FUN{isrec=isrec, known=known, fixed=fixed, inline=true},              val isrec' = Option.map (fn ltys => (ltys, F.LK_UNKNOWN)) rtys'
46              F.FK_FUN{isrec=rtys', known=true, fixed=fixed', inline=inline})          in ({isrec=isrec, known=known, cconv=cconv, inline=F.IH_ALWAYS},
47                {isrec=isrec', known=true, cconv=cconv', inline=inline})
48          end          end
49    
50      fun filter ([],[]) = []      fun filter [] [] = []
51        | filter (true::fs,x::xs)  = x::(filter(fs, xs))        | filter (true::fs) (x::xs)  = x::(filter fs xs)
52        | filter (false::fs,x::xs) = (filter(fs, xs))        | filter (false::fs) (x::xs) = (filter fs xs)
53        | filter _ = bug "unmatched list length in filter"        | filter _ _ = bug "unmatched list length in filter"
54    
55        fun ListPair_all pred =
56            let fun allp (a::r1, b::r2) = pred(a, b) andalso allp (r1, r2)
57                  | allp ([],[]) = true
58                  | allp _ = false
59            in allp
60            end
61    
62        fun pow2 n = Word.toInt(Word.<<(Word.fromInt 1, Word.fromInt n))
63    
64        exception Unbalanced
65        fun transpose [] = []
66          | transpose (xs::xss) =
67            let fun tr [] accs = accs
68                  | tr (xs::xss) accs =
69                    let fun f [] [] = []
70                          | f (x::xs) (acc::accs) = (x::acc)::(f xs accs)
71                          | f _ _ = raise Unbalanced
72                    in tr xss (f xs accs)
73                    end
74            in tr xss (map (fn x => [x]) xs)
75            end
76    
77      fun id x = x      fun foldl3 f =
78            let fun l s ([],[],[]) = s
79                  | l s (x1::x1s,x2::x2s,x3::x3s) = l (f(x1,x2,x3,s)) (x1s,x2s,x3s)
80                  | l _ _ = raise Unbalanced
81            in l
82            end
83    
84  end  end
85  end  end

Legend:
Removed from v.163  
changed lines
  Added in v.203

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