├── .gitignore ├── Doxyfile ├── Examples ├── Data │ ├── add90.hs │ ├── addsx.hs │ ├── ashcroft.hs │ ├── biglist.hs │ ├── circular.hs │ ├── collatz.hs │ ├── deadapp.hs │ ├── df1.hs │ ├── df2.hs │ ├── df3.hs │ ├── digits_of_e1.hs │ ├── error.hs │ ├── example1.hs │ ├── example2.hs │ ├── example3.hs │ ├── example4.hs │ ├── example5.hs │ ├── exmh88.hs │ ├── fadd90.hs │ ├── faddsx.hs │ ├── fast-reverse.hs │ ├── heap-ovwr.hs │ ├── hodata.hs │ ├── hof.hs │ ├── hof2.hs │ ├── infinite.hs │ ├── io.hs │ ├── lam3.hs │ ├── lazy-constr-params.hs │ ├── lazy-data.hs │ ├── length.hs │ ├── let-destruct.hs │ ├── neglist.hs │ ├── nested.hs │ ├── okasaki14.hs │ ├── okasaki15.hs │ ├── okasaki17.hs │ ├── pairlist.hs │ ├── papp.hs │ ├── patmatch1.hs │ ├── patterns.hs │ ├── prog16.hs │ ├── qs.hs │ ├── quick-sort.hs │ ├── quot.hs │ ├── records.hs │ ├── result-case.hs │ ├── reverse.hs │ ├── separate.hs │ ├── strict-data.hs │ ├── tc1.hs │ ├── test.hs │ ├── test1-dlet.hs │ ├── test1.hs │ ├── test2-dlet.hs │ ├── test2.hs │ ├── test5.hs │ ├── test6.hs │ ├── tree-let.hs │ ├── tree-sort.hs │ ├── tree.hs │ ├── underscore.hs │ └── unit.hs ├── GADT │ └── PDefunc.hs ├── Modules │ ├── Example1 │ │ ├── Main.hs │ │ ├── ModuleA.hs │ │ └── ModuleB.hs │ ├── Example2 │ │ ├── Lib.hs │ │ └── Main.hs │ ├── Example3 │ │ ├── Lib.hs │ │ └── Main.hs │ └── Example4 │ │ ├── Lib.hs │ │ └── Main.hs ├── NewBench │ ├── ack.hs │ ├── church.hs │ ├── collatz.hs │ ├── digits_of_e1.hs │ ├── fast-reverse.hs │ ├── fib.hs │ ├── naive-reverse.hs │ ├── ntak.hs │ ├── primes.hs │ ├── queens-num.hs │ ├── queens.hs │ ├── quick-sort.hs │ └── tree-sort.hs ├── Num │ ├── ack.hs │ ├── bigints.hs │ ├── cbn.hs │ ├── church.hs │ ├── church_defun.hs │ ├── defunc-test.hs │ ├── exmh1.hs │ ├── exmh100.hs │ ├── exmh101.hs │ ├── exmh2.hs │ ├── exmh20.hs │ ├── exmh200.hs │ ├── exmh201.hs │ ├── exmh202.hs │ ├── exmh203.hs │ ├── exmh205.hs │ ├── exmh21.hs │ ├── exmh3.hs │ ├── exmh31.hs │ ├── exmh9.hs │ ├── exmh90.hs │ ├── exmh91.hs │ ├── exmpl_with_cafs_2.hs │ ├── fact-tr.hs │ ├── fact.hs │ ├── fib.hs │ ├── fibs.hs │ ├── let-enum.hs │ ├── memoize.hs │ ├── myex0.hs │ ├── myex3.hs │ ├── myex4.hs │ ├── myex5.hs │ ├── myex6.hs │ ├── ntak.hs │ ├── pj1.hs │ ├── primes.hs │ ├── queens.hs │ ├── share.hs │ ├── sum.hs │ ├── tak.hs │ └── test-let.hs ├── Parallel │ ├── Parfib.hs │ └── Parmap.hs └── Polymorphic │ ├── Lists.hs │ ├── Poly1.hs │ ├── Poly2.hs │ ├── Poly3.hs │ ├── Tc1.hs │ └── Tuples.hs ├── LICENSE ├── Main.hs ├── Makefile ├── README ├── README.md ├── SLIC ├── AuxFun.hs ├── CompManager.hs ├── Constants.hs ├── DFI.hs ├── Distr │ └── EvalErl.hs ├── Driver.hs ├── Front │ ├── CAF.hs │ ├── Defunc.hs │ ├── EvalFL.hs │ ├── GHCBackEnd.hs │ ├── GHCFrontEnd.hs │ ├── HStoHF.hs │ ├── LLifter │ │ ├── Equations.hs │ │ └── Lifter.hs │ ├── PatternCompiler.hs │ ├── Preprocessor.hs │ ├── Renamer.hs │ ├── TailCalls.hs │ ├── TypeInfer.hs │ └── Typeclass.hs ├── ITrans │ ├── Eval.hs │ ├── EvalEduction.hs │ ├── HFtoHI.hs │ ├── HItoZI.hs │ ├── ITrans.hs │ ├── Optimizations.hs │ ├── Syntax.hs │ └── ZLinker.hs ├── LAR │ ├── LAR.hs │ ├── LARAux.hs │ ├── LARBuiltins.hs │ ├── LARDebug.hs │ ├── LARGraph.hs │ ├── LARLinker.hs │ ├── LARTC.hs │ ├── OptimizationsLAR.hs │ ├── SMacrosAux.hs │ ├── SyntaxLAR.hs │ └── ZItoLAR.hs ├── Maude │ └── ZItoMaude.hs ├── State.hs ├── SyntaxAux.hs ├── SyntaxFL.hs ├── TTD │ ├── DFG.hs │ ├── EvalTTD.hs │ ├── SyntaxTTD.hs │ ├── TTD.hs │ └── ZItoTTD.hs ├── Tags.hs └── Types.hs ├── Setup.hs ├── build-archive.sh ├── buildwin.bat ├── c ├── cat.c ├── gc.c ├── gc.h ├── gic_builtins.h ├── lar.h ├── lar_compact.h ├── lar_opt.h └── lar_semi.h ├── compile-link-mods.sh ├── compile-module.sh ├── doc ├── .gitignore ├── doxygen │ └── .gitignore └── haddock │ └── .gitignore ├── erlang ├── distr_eduction.erl ├── warehouse.erl ├── warehouse2.erl └── warehouse_redis.erl ├── eval_erl.sh ├── eval_maude.sh ├── find-gic.sh ├── gen-dfg-graph.sh ├── gic.cabal ├── maude ├── eduction.maude └── full-maude26.maude ├── newbench.sh ├── pcomp.sh ├── run_distr.sh ├── run_erl.sh ├── run_lar.sh ├── run_libgc.sh ├── scomp-tests.sh ├── scripts ├── diff_repr.sh ├── measure_mem.py ├── perf-greedy.sh └── test64.sh ├── stack.yaml └── testLangs.sh /.gitignore: -------------------------------------------------------------------------------- 1 | *.c 2 | *.dfi 3 | *.ii 4 | *.o 5 | *.hi 6 | *.g.o 7 | Bench/ 8 | Examples/Misc/ 9 | THIH/ 10 | gic-pack/ 11 | mdefunc/ 12 | old/ 13 | misc/ 14 | ptheof/ 15 | related/ 16 | gic 17 | a.out 18 | -------------------------------------------------------------------------------- /Examples/Data/add90.hs: -------------------------------------------------------------------------------- 1 | result :: Int 2 | result = repeat2 10000 addsx2 30; 3 | 4 | addsx2 :: Int -> Int 5 | addsx2 z = f sq z ; 6 | 7 | sq :: Int -> Int 8 | sq c = c * c ; 9 | 10 | add :: Int -> Int -> Int 11 | add a b = a + b ; 12 | 13 | f :: (Int -> Int) -> Int -> Int 14 | f s x = if (x <= 0) then s x else f (add (s x)) (x-1) ; 15 | 16 | repeat2 :: Int -> (Int -> Int) -> Int -> Int 17 | repeat2 n f a = repeat_aux n f a 0 ; 18 | 19 | repeat_aux :: Int -> (Int -> Int) -> Int -> Int -> Int 20 | repeat_aux n f a b = if n > 0 then repeat_aux (n-1) f a (b + f a - b) else b 21 | -------------------------------------------------------------------------------- /Examples/Data/addsx.hs: -------------------------------------------------------------------------------- 1 | result :: Int 2 | result = f sq 10 ; 3 | 4 | sq :: Int -> Int 5 | sq c = c * c ; 6 | 7 | add :: Int -> Int -> Int 8 | add a b = a + b ; 9 | 10 | f :: (Int -> Int) -> Int -> Int 11 | f s x = if (x <= 0) then s x else f (add (s x)) (x-1) 12 | -------------------------------------------------------------------------------- /Examples/Data/ashcroft.hs: -------------------------------------------------------------------------------- 1 | result :: Int 2 | result = head2 (f (g 800000)) -- 8000000)) 3 | 4 | head2 :: [Int] -> Int 5 | head2 hl = case hl of 6 | cons_0 : cons_1 -> cons_0 7 | tail2 :: [Int] -> [Int] 8 | tail2 tl = case tl of 9 | cons_0 : cons_1 -> cons_1 10 | null2 :: [Int] -> Bool 11 | null2 ds = case ds of [] -> True 12 | cons_0 : cons_1 -> False 13 | g :: Int -> [Int] 14 | g n = if n == 0 then [] else n : (g (n-1)) 15 | f :: [Int] -> [Int] 16 | f xs = if null2 xs then [] else f1 xs (tail2 xs) 17 | f1 :: [Int] -> [Int] -> [Int] 18 | f1 xs t = if null2 t then xs else f2 xs (f t) 19 | f2 :: [Int] -> [Int] -> [Int] 20 | f2 xs l = (head2 l) : (f ((head2 xs) : (f (tail2 l)))) 21 | -------------------------------------------------------------------------------- /Examples/Data/biglist.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Int List ; 2 | result = length2 (f 10) + length2 (f 10); 3 | f x = if (x==0) then Nil else Cons x (f (x-1)) ; 4 | inc l = 5 | case l of 6 | Nil -> Nil 7 | Cons h t -> Cons (h+1) (inc t) ; 8 | length2 d = 9 | case d of 10 | Nil -> 0 11 | Cons h t -> 1 + (length2 t) 12 | -------------------------------------------------------------------------------- /Examples/Data/circular.hs: -------------------------------------------------------------------------------- 1 | -- Taking the first and the second element of an infinite stream, described 2 | -- by an infinite data structure. 3 | data Stream = Cons Int Stream ; 4 | result = (head2 circ) + (head2 (tail2 circ)) ; 5 | circ = Cons 10 circ ; 6 | head2 hl = case hl of Cons cons_0 cons_1 -> cons_0 ; 7 | tail2 tl = case tl of Cons cons_0 cons_1 -> cons_1 8 | -------------------------------------------------------------------------------- /Examples/Data/collatz.hs: -------------------------------------------------------------------------------- 1 | -- Computes the lengths of the Collatz sequences for the first 110000 natural 2 | -- numbers. 3 | 4 | module Main where 5 | 6 | main :: IO () 7 | main = putStrLn (show result) 8 | 9 | result :: Int 10 | result = sum1 (mymap f (nums 1 110000)) 11 | 12 | f :: Int -> Int; 13 | f x = if (x==1) then 0 else if ((x `mod` 2) == 0) then 1+ (f (x `div` 2)) else 1+(f ((3*x)+1)); 14 | 15 | length1 :: [Int] -> Int; 16 | length1 ls = 17 | case ls of 18 | [] -> 0; 19 | h : tl -> 1 + (length1 tl); 20 | 21 | nums :: Int -> Int -> [Int] ; 22 | nums a b = if (a <= b) then (a : (nums (a+1) b)) else [] 23 | 24 | mymap :: (Int -> Int) -> [Int] -> [Int] ; 25 | mymap f xs = 26 | case xs of 27 | [] -> []; 28 | a : b -> (f a) : (mymap f b) ; 29 | 30 | sum1 :: [Int] -> Int; 31 | sum1 xs = 32 | case xs of 33 | [] -> 0; 34 | a : b -> a + (sum1 b); 35 | -------------------------------------------------------------------------------- /Examples/Data/deadapp.hs: -------------------------------------------------------------------------------- 1 | -- Tests the "dead-code apply" defunctionalization problem. 2 | 3 | result = add 10 20 4 | add a b = a + b 5 | dead f = f 10 6 | -------------------------------------------------------------------------------- /Examples/Data/df1.hs: -------------------------------------------------------------------------------- 1 | -- defunctionalization test 2 | -- one closure of 'sq with type :: Int -> Int 3 | 4 | result = double sq 10 5 | double f x = f (f x) 6 | sq a = a * a 7 | -------------------------------------------------------------------------------- /Examples/Data/df2.hs: -------------------------------------------------------------------------------- 1 | -- defunctionalization test 2 | 3 | result = (double sq 10) + (double (add3 1 2) 1) 4 | double f x = f (f x) 5 | sq a = a * a 6 | add3 i j k = i + j + k 7 | -------------------------------------------------------------------------------- /Examples/Data/df3.hs: -------------------------------------------------------------------------------- 1 | -- Test for proper typed defunctionalization 2 | 3 | data Node1 = NodeA deriving (Show) 4 | data Node2 = NodeB deriving (Show) 5 | 6 | result :: Node1 7 | result = test1 8 | 9 | test1 :: Node1 10 | test1 = 11 | case (double2 f2) of 12 | NodeB -> double1 f1 13 | 14 | f1 :: Node1 -> Node1 -> Node1 15 | f1 x1 y1 = NodeA 16 | 17 | f2 :: Node2 -> Node2 -> Node2 18 | f2 x2 y2 = NodeB 19 | 20 | -- TODO: these should also be 'g1 NodeA NodeB' etc. 21 | 22 | double1 :: (Node1 -> Node1 -> Node1) -> Node1 23 | double1 g1 = g1 (g1 NodeA NodeA) (g1 NodeA NodeA) 24 | 25 | double2 :: (Node2 -> Node2 -> Node2) -> Node2 26 | double2 g2 = g2 (g2 NodeB NodeB) (g2 NodeB NodeB) 27 | -------------------------------------------------------------------------------- /Examples/Data/digits_of_e1.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn (show result) 5 | 6 | eContFrac :: [Int] 7 | eContFrac = 2 : (aux 2); 8 | aux :: Int -> [Int] 9 | aux n = 1 : (n : (1 : (aux (n+2)))) ; 10 | 11 | -- Output a digit if we can 12 | ratTrans :: Int -> Int -> Int -> Int -> [Int] -> [Int] 13 | ratTrans a b c d xs = 14 | case xs of 15 | [] -> [] 16 | h : tl -> if (((signum1 c == signum1 d) || (abs1 c < abs1 d)) && (((c+d)*(b `div` d)) <= (a+b)) && ((c+d)*(b `div` d) + (c+d) > (a+b))) 17 | then 18 | ((b `div` d) : (ratTrans c d (a-((b `div` d)*c)) (b-((b `div` d)*d)) xs)) 19 | else 20 | (ratTrans b (a+(h*b)) d (c+(h*d)) tl); 21 | signum1 :: Int -> Int 22 | signum1 x = if (x<0) then (-1) else if (x>0) then 1 else 0; 23 | abs1 :: Int -> Int 24 | abs1 x = if (x>=0) then x else (-x); 25 | 26 | --Finally, we convert a continued fraction to digits by repeatedly multiplying by 10. 27 | toDigits :: [Int] -> [Int] 28 | toDigits l = 29 | case l of 30 | [] -> [] 31 | a : b -> a : (toDigits (ratTrans 10 0 0 1 b)); 32 | 33 | e :: [Int] 34 | e = toDigits eContFrac 35 | 36 | select1 :: [Int] -> Int -> Int 37 | select1 xs n = 38 | case xs of 39 | a : b -> if (n==0) then a else select1 b (n-1); 40 | 41 | result :: Int 42 | result = select1 e 1000; 43 | -------------------------------------------------------------------------------- /Examples/Data/error.hs: -------------------------------------------------------------------------------- 1 | result = head2 [] 2 | head2 l = case l of 3 | [] -> error "empty list!" 4 | x:xs -> x -------------------------------------------------------------------------------- /Examples/Data/example1.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn (show result) ; 5 | 6 | result :: Int 7 | result = case k of cons_0 : cons_1 -> cons_0 ; 8 | 9 | k :: [Int] 10 | k = [42] ; 11 | 12 | -------------------------------------------------------------------------------- /Examples/Data/example2.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | main = putStrLn (show result) ; 3 | 4 | result :: Int 5 | result = head2 (tail2 (f 2)) ; 6 | lst :: [Int] 7 | lst = f 300 ; 8 | head2 :: [Int] -> Int 9 | head2 hl = case hl of cons_0 : cons_1 -> cons_0 ; 10 | tail2 :: [Int] -> [Int] 11 | tail2 tl = case tl of cons_0 : cons_1 -> cons_1 ; 12 | f :: Int -> [Int] 13 | f x = if (x <= 0) then [x+10] else (x*2) : (f (x-1)) 14 | 15 | 16 | -------------------------------------------------------------------------------- /Examples/Data/example3.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Int List ; 2 | data Defunc = DFSq | DFAdd Int ; 3 | 4 | result :: Int 5 | result = f DFSq 20 ; 6 | 7 | f :: Defunc -> Int -> Int 8 | f s x = if (x <= 1) then apply s x else f (DFAdd (apply s x)) (x-1) ; 9 | 10 | apply :: Defunc -> Int -> Int 11 | apply h y = case h of DFSq -> sq y 12 | DFAdd dfadd_0 -> add dfadd_0 y ; 13 | 14 | sq :: Int -> Int 15 | sq c = c * c ; 16 | 17 | add :: Int -> Int -> Int 18 | add a b = a + b 19 | -------------------------------------------------------------------------------- /Examples/Data/example4.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Pair List ; 2 | data Pair = P Int Int ; 3 | 4 | result :: Int 5 | result = fst2 (head2 (tail2 lst)) ; 6 | 7 | fst2 :: Pair -> Int 8 | fst2 p = case p of P p_0 p_1 -> p_0 ; 9 | 10 | lst :: List 11 | lst = Cons (P (10) (20)) (Cons (P (100) (200)) (Nil)) ; 12 | -- lst = f 300 ; 13 | -- f x = if (x <= 0) then Cons (P (x+1) (x+2)) (Nil) else Cons (P (x*2) 0) (f (x-1)) 14 | 15 | head2 :: List -> Pair 16 | head2 hl = case hl of Cons cons_0 cons_1 -> cons_0 ; 17 | tail2 :: List -> List 18 | tail2 tl = case tl of Cons cons_0 cons_1 -> cons_1 19 | -------------------------------------------------------------------------------- /Examples/Data/example5.hs: -------------------------------------------------------------------------------- 1 | data List= Nil | Cons Int List ; 2 | result = head2 (tail2 (f(2))) ; 3 | head2 hl = case hl of Cons cons_0 cons_1 -> cons_0 ; 4 | tail2 ll = case ll of Cons cons_0 cons_1 -> cons_1 ; 5 | f x = if (x<=0) then Cons (x+10) Nil 6 | else Cons (2*x) (f (x-1)) 7 | -------------------------------------------------------------------------------- /Examples/Data/exmh88.hs: -------------------------------------------------------------------------------- 1 | result :: [Int] 2 | result = qsort2 [32, 7, 42, 8, 1] ; 3 | 4 | append2 :: [Int] -> [Int] -> [Int] 5 | append2 l1 l2 = if null2 l1 then l2 else (head2 l1) : (append2 (tail2 l1) l2); 6 | 7 | filter2 :: (Int -> Int -> Bool) -> Int -> [Int] -> [Int] 8 | filter2 f p l = if null2 l then [] else if f (head2 l) p then (head2 l) : (filter2 f p (tail2 l)) else filter2 f p (tail2 l); 9 | 10 | qsort2 :: [Int] -> [Int] 11 | qsort2 l = if null2 l then [] else append2 (qsort2 (filter2 lt (head2 l) (tail2 l))) ( (head2 l) : (qsort2 (filter2 ge (head2 l) (tail2 l)))); 12 | 13 | lt :: Int -> Int -> Bool 14 | lt x y = x < y; 15 | ge :: Int -> Int -> Bool 16 | ge x y = x >= y; 17 | null2 :: [Int] -> Bool 18 | null2 ds = case ds of [] -> True 19 | cons_0 : cons_1 -> False; 20 | head2 :: [Int] -> Int 21 | head2 hl = case hl of cons_0 : cons_1 -> cons_0; 22 | tail2 :: [Int] -> [Int] 23 | tail2 tl = case tl of cons_0 : cons_1 -> cons_1; 24 | val1 :: Int 25 | val1 = head2 result; 26 | val2 :: Int 27 | val2 = head2 (tail2 result); 28 | val3 :: Int 29 | val3 = head2 (tail2 (tail2 result)); 30 | val4 :: Int 31 | val4 = head2 (tail2 (tail2 (tail2 result))); 32 | val5 :: Int 33 | val5 = head2 (tail2 (tail2 (tail2 (tail2 result)))) 34 | -------------------------------------------------------------------------------- /Examples/Data/fadd90.hs: -------------------------------------------------------------------------------- 1 | result = repeat2 4 faddsx2 3 ; 2 | faddsx2 z = f sq z ; 3 | sq c = c * c ; 4 | add a b = a + b ; 5 | f s x = if (x <= 0) then s x else f (f (add (s x))) (x-1) ; 6 | repeat2 n f a = repeat_aux n f a 0 ; 7 | repeat_aux n f a b = if n > 0 then repeat_aux (n-1) f a (b + f a - b) else b 8 | -------------------------------------------------------------------------------- /Examples/Data/faddsx.hs: -------------------------------------------------------------------------------- 1 | result = f sq 5 ; 2 | sq c = c * c ; 3 | add a b = a + b ; 4 | f s x = if (x <= 0) then s x else f (f (add (s x))) (x-1) 5 | -------------------------------------------------------------------------------- /Examples/Data/fast-reverse.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Int List; 2 | 3 | head2 hl = case hl of Cons cons_0 cons_1 -> cons_0 ; 4 | tail2 tl = case tl of Cons cons_0 cons_1 -> cons_1 ; 5 | null2 ds = case ds of Nil -> True 6 | Cons cons_0 cons_1 -> False ; 7 | append1 xs ys = if (null2 xs) then ys else (Cons (head2 xs) (append1 (tail2 xs) ys)); 8 | 9 | reverse1 xs = rev2 xs Nil; 10 | 11 | rev xs ys = if (null2 xs) then ys else (rev (tail2 xs) (Cons (head2 xs) ys)); 12 | rev2 xs ys = 13 | case xs of 14 | Nil -> ys 15 | Cons cons_0 cons_1 -> rev2 cons_1 (Cons cons_0 ys) 16 | createlist n = if (n==0) then Nil else (Cons n (createlist (n-1))); 17 | 18 | -- result = head2 ( reverse1 (reverse1 (createlist 5000000))) 19 | result = head2 ( reverse1 (reverse1 (createlist 50000))) 20 | 21 | -------------------------------------------------------------------------------- /Examples/Data/heap-ovwr.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Int List ; 2 | result = (head1 (f 10)) + (head2 (f 20)) ; 3 | head1 hl = case hl of Cons cons_0 cons_1 -> cons_0 ; 4 | head2 hl = case hl of Cons cons_0 cons_1 -> (cons_0 + 1); 5 | f x = if (x <= 0) then Cons (x+10) (Nil) else Cons (x*2) (f (x-1)) 6 | -------------------------------------------------------------------------------- /Examples/Data/hodata.hs: -------------------------------------------------------------------------------- 1 | data Object = Object Int (Int -> Int) ; 2 | 3 | result :: Int 4 | result = use obj ; 5 | 6 | obj :: Object 7 | obj = Object 1 inc ; 8 | 9 | use :: Object -> Int 10 | use o = case o of Object field func -> func field ; 11 | 12 | inc :: Int -> Int 13 | inc a = a + 1 14 | -------------------------------------------------------------------------------- /Examples/Data/hof.hs: -------------------------------------------------------------------------------- 1 | -- Higher-order function bodies. 2 | 3 | result :: Int 4 | result = (y 10 20) + (z 30 1); 5 | 6 | z :: Int -> Int -> Int 7 | z = mult 20 ; 8 | 9 | y :: Int -> Int -> Int 10 | y c = mult c c 11 | 12 | mult :: Int -> Int -> Int -> Int 13 | mult a b c = a * b * c 14 | -------------------------------------------------------------------------------- /Examples/Data/hof2.hs: -------------------------------------------------------------------------------- 1 | result = g add 1 2 | g f x = h (f x) 3 | h t = t 3 4 | add a b = a + b 5 | -------------------------------------------------------------------------------- /Examples/Data/infinite.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Int List ; 2 | result = head2 (take2 1 inf) ; 3 | take2 n l = 4 | if n==0 then 5 | Nil 6 | else 7 | take2_aux n l ; 8 | take2_aux n_aux l_aux = 9 | case l_aux of 10 | Cons cons_0 cons_1 -> Cons cons_0 (take2 (n_aux-1) cons_1) ; 11 | head2 hl = case hl of Cons cons_0 cons_1 -> cons_0 ; 12 | -- tail2 tl = case tl of Cons cons_0 cons_1 -> cons_1 ; 13 | inf = Cons 42 inf 14 | 15 | -------------------------------------------------------------------------------- /Examples/Data/io.hs: -------------------------------------------------------------------------------- 1 | result :: IO () 2 | result = sequ (putStr (takeI 3 "hello")) ( 3 | sequ (putStr "-" ) ( 4 | (putStrLn (dropI 3 "hello")) )) 5 | dropI :: Int -> String -> String 6 | dropI i l = if i==0 then l else case l of x:xs -> dropI (i-1) xs 7 | takeI :: Int -> String -> String 8 | takeI i l = if i==0 then [] 9 | else case l of 10 | x : xs -> x : (takeI (i-1) xs) 11 | sequ :: IO () -> IO () -> IO () 12 | sequ a b = 13 | do () <- a 14 | b 15 | -------------------------------------------------------------------------------- /Examples/Data/lam3.hs: -------------------------------------------------------------------------------- 1 | -- lambda abstraction test 2 | result = double (\z -> z+1) 10 + ((\x y -> x + y) 13 17) 3 | double f x = f (f x) 4 | -------------------------------------------------------------------------------- /Examples/Data/lazy-constr-params.hs: -------------------------------------------------------------------------------- 1 | -- Test to see if constructor parameters are memoized as needed for lazy 2 | -- languages. The two versions of the branch in the ffib function should 3 | -- take about the same time (the second may take a bit more due to the 4 | -- repeated thunk accesses, but the difference should be tiny here). 5 | data Box = Box Int ; 6 | result = case (Box boundComputation) of 7 | -- Box box_0 -> (box_0 + box_0) + (box_0 + (box_0 + box_0)) ; 8 | Box box_0 -> 5 * box_0 ; 9 | boundComputation = fib 5 ; -- fib 35 ; 10 | fib x = if x<2 then 1 else (fib (x-1)) + (fib (x-2)) 11 | -------------------------------------------------------------------------------- /Examples/Data/lazy-data.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Int List deriving Show ; 2 | result = d ; 3 | test x = (head2 x) + (head2inc x) ; 4 | d = Cons (2) (Cons (9) (Nil)) ; 5 | head2 hl = case hl of Cons cons_0 cons_1 -> cons_0 ; 6 | head2inc hl = case hl of Cons cons_0 cons_1 -> cons_0 + 1 7 | -------------------------------------------------------------------------------- /Examples/Data/length.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Int List; 2 | 3 | head2 hl = case hl of Cons cons_0 cons_1 -> cons_0 ; 4 | tail2 tl = case tl of Cons cons_0 cons_1 -> cons_1 ; 5 | null2 ds = case ds of Nil -> True 6 | Cons cons_0 cons_1 -> False ; 7 | 8 | createlist n = if (n==0) then Nil else (Cons 1 (createlist (n-1))); 9 | 10 | len xs = if (null2 xs) then 0 else (1+(len (tail2 xs))); 11 | 12 | result = (len (createlist 700000)) 13 | 14 | -------------------------------------------------------------------------------- /Examples/Data/let-destruct.hs: -------------------------------------------------------------------------------- 1 | -- Test for destructuring an expression with 'let'. 2 | 3 | data M = J Box | N 4 | data Box = Box1 Int | Box2 Int Int | Box3 Box Int Box 5 | 6 | result :: Int 7 | result = (f (Box1 21)) + (g 1) 8 | 9 | f :: Box -> Int 10 | f x = let Box1 i = x 11 | in i + i 12 | 13 | g :: Int -> Int 14 | g x = let J (Box3 (Box2 a b) c (Box2 _ d)) = bx x 15 | in a + b + c + d 16 | 17 | bx :: Int -> M 18 | bx x = J (Box3 (Box2 x 2) 3 (Box2 4 5)) 19 | -------------------------------------------------------------------------------- /Examples/Data/neglist.hs: -------------------------------------------------------------------------------- 1 | -- | Tests the negation operator and pretty printing of negative lists 2 | -- (which check the value flag when -compact is on). 3 | 4 | result :: [Int] 5 | result = [-1, -2, -3, -4, -5, -7, -8, -9, -16, -17, -42] 6 | -------------------------------------------------------------------------------- /Examples/Data/nested.hs: -------------------------------------------------------------------------------- 1 | data Tree = Node Int | Tr Tree Tree 2 | 3 | result = f tree 4 | 5 | f x = 6 | case x of 7 | Node i1 -> i1 8 | Tr a1 b1 -> 9 | case a1 of 10 | Node i2 -> i2 11 | Tr a2 b2 -> f a2 + f b2 12 | 13 | tree = Tr (Node 10) (Tr (Tr (Node 20) (Node 30)) (Node 40)) -------------------------------------------------------------------------------- /Examples/Data/okasaki14.hs: -------------------------------------------------------------------------------- 1 | data List2 = Nil | Cons Int List2 ; 2 | pmax pmax_n1 pmax_n2 = if pmax_n1 > pmax_n2 then pmax_n1 else pmax_n2 ; 3 | psucceed psucceed_x psucceed_sc psucceed_fc psucceed_ts psucceed_n = psucceed_sc psucceed_x psucceed_fc psucceed_ts psucceed_n ; 4 | palt palt_p palt_q palt_sc palt_fc palt_ts palt_n = palt_p palt_sc (palt_1 palt_q palt_sc palt_fc palt_ts palt_n) palt_ts palt_n ; 5 | pbind pbind_p pbind_f pbind_sc pbind__1 pbind__2 pbind__3 = pbind_p (pbind_1 pbind_f pbind_sc) pbind__1 pbind__2 pbind__3 ; 6 | psatisfy psatisfy_p psatisfy_sc psatisfy_fc psatisfy_ts psatisfy_n = if null2 psatisfy_ts then psatisfy_fc psatisfy_n else if psatisfy_p (head2 psatisfy_ts) then psatisfy_sc (head2 psatisfy_ts) psatisfy_fc (tail2 psatisfy_ts) psatisfy_n else psatisfy_fc psatisfy_n ; 7 | pliteral pliteral_t pliteral__1 pliteral__2 pliteral__3 pliteral__4 = psatisfy (equ pliteral_t) pliteral__1 pliteral__2 pliteral__3 pliteral__4 ; 8 | fail0 fail0_n = 0 - 999 ; 9 | success0 success0_x success0_fc success0_ts success0_n = if null2 success0_ts then success0_x else (0 - 999) ; 10 | ntdigit ntdigit__1 ntdigit__2 ntdigit__3 ntdigit__4 = palt (pliteral 0) (pliteral 1) ntdigit__1 ntdigit__2 ntdigit__3 ntdigit__4 ; 11 | ntnumber ntnumber_n ntnumber__1 ntnumber__2 ntnumber__3 ntnumber__4 = palt (pbind ntdigit (ntnumber_1 ntnumber_n)) (pbind ntdigit (ntnumber_2 ntnumber_n)) ntnumber__1 ntnumber__2 ntnumber__3 ntnumber__4 ; 12 | result = ntnumber 0 success0 fail0 (Cons (1) (Cons (0) (Cons (1) (Cons (0) (Cons (1) (Cons (0) (Nil))))))) 0 ; 13 | palt_1 palt_1_q palt_1_sc palt_1_fc palt_1_ts palt_1_n palt_1_np = palt_1_q palt_1_sc (palt_1_1 palt_1_fc palt_1_np) palt_1_ts palt_1_n ; 14 | pbind_1 pbind_1_f pbind_1_sc pbind_1_x pbind_1__1 pbind_1__2 pbind_1__3 = pbind_1_f pbind_1_x pbind_1_sc pbind_1__1 pbind_1__2 pbind_1__3 ; 15 | ntnumber_1 ntnumber_1_n ntnumber_1_x ntnumber_1__1 ntnumber_1__2 ntnumber_1__3 ntnumber_1__4 = ntnumber (2 * ntnumber_1_n + ntnumber_1_x) ntnumber_1__1 ntnumber_1__2 ntnumber_1__3 ntnumber_1__4 ; 16 | ntnumber_2 ntnumber_2_n ntnumber_2_x ntnumber_2__1 ntnumber_2__2 ntnumber_2__3 ntnumber_2__4 = psucceed (2 * ntnumber_2_n + ntnumber_2_x) ntnumber_2__1 ntnumber_2__2 ntnumber_2__3 ntnumber_2__4 ; 17 | palt_1_1 palt_1_1_fc palt_1_1_np palt_1_1_nq = palt_1_1_fc (pmax palt_1_1_np palt_1_1_nq) ; 18 | null2 ds = case ds of Nil -> True 19 | Cons cons_0 cons_1 -> False ; 20 | head2 hl = case hl of Cons cons_0 cons_1 -> cons_0 ; 21 | tail2 tl = case tl of Cons cons_0 cons_1 -> cons_1 ; 22 | -- added for (==) aplication in pliteral 23 | equ equ1 equ2 = equ1 == equ2 24 | -------------------------------------------------------------------------------- /Examples/Data/okasaki15.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Int List ; 2 | psucceed x1 sc1 fc1 ts1 = sc1 x1 fc1 ts1 ; 3 | palt p2 q2 sc2 fc2 ts2 = p2 sc2 (q2 sc2 fc2 ts2) ts2 ; 4 | pbind p3 f3 sc3 a3 b3 = p3 (pbind_aux f3 sc3) a3 b3 ; 5 | pany sc4 fc4 ts4 = if null2 ts4 then fc4 else sc4 (head2 ts4) fc4 (tail2 ts4) ; 6 | success0 x5 fc5 ts5 = if null2 ts5 then x5 else fc5 ; 7 | ntdigit a6 b6 c6 = palt pany pany a6 b6 c6 ; 8 | ntnumber n7 a7 b7 c7 = palt (pbind ntdigit ntnumber_aux1) (pbind ntdigit (ntnumber_aux2 n7)) a7 b7 c7 ; 9 | result = ntnumber 0 success0 (0 - 999) (Cons 1 (Cons 0 (Nil))) ; 10 | pbind_aux f8 sc8 x8 a8 b8 = f8 x8 sc8 a8 b8 ; 11 | ntnumber_aux1 x9 a9 b9 c9 = ntnumber x9 a9 b9 c9 ; 12 | ntnumber_aux2 n10 x10 a10 b10 c10 = psucceed n10 a10 b10 c10 ; 13 | null2 ds = case ds of Nil -> True 14 | Cons cons_0 cons_1 -> False ; 15 | head2 hl = case hl of Cons cons_0 cons_1 -> cons_0 ; 16 | tail2 tl = case tl of Cons cons_0 cons_1 -> cons_1 17 | -------------------------------------------------------------------------------- /Examples/Data/okasaki17.hs: -------------------------------------------------------------------------------- 1 | psucceed x1 sc1 ts1 = sc1 x1 ts1 ; 2 | pbind p2 f2 sc2 ts2 = p2 (pbind_aux f2 sc2 ts2) ts2 ; 3 | pany sc3 ts3 = if ts3 == 0 then 999 else sc3 1 (ts3 - 1) ; 4 | success0 x4 ts4 = x4 ; 5 | ntnumber n5 sc5 ts5 = pbind pany (ntnumber_aux1 n5) sc5 ts5 + pbind pany (ntnumber_aux2 n5) sc5 ts5 ; 6 | result = ntnumber 0 success0 5 ; 7 | pbind_aux f6 sc6 ts6 x6 a6 = f6 ts6 sc6 a6 ; 8 | ntnumber_aux1 n7 x7 a7 b7 = ntnumber (n7 + x7) a7 b7 ; 9 | ntnumber_aux2 n8 x8 a8 b8 = psucceed n8 a8 b8 10 | -------------------------------------------------------------------------------- /Examples/Data/pairlist.hs: -------------------------------------------------------------------------------- 1 | data Pair = Pair Int Int deriving Show ; 2 | data PairList = NoPairs | Elem Pair PairList deriving Show; 3 | result = Elem (Pair 1 2) (Elem (Pair 3 4) NoPairs) 4 | -------------------------------------------------------------------------------- /Examples/Data/papp.hs: -------------------------------------------------------------------------------- 1 | result = g add 1 2 | g f x = h (f x) 3 | h t = t 3 4 | add a b = a + b 5 | -------------------------------------------------------------------------------- /Examples/Data/patmatch1.hs: -------------------------------------------------------------------------------- 1 | data Tree = Leaf | Node Tree Tree ; 2 | 3 | result :: Int 4 | -- result = if isLeaf (case d of Node a1 b1 -> Leaf ; Leaf -> Node Leaf Leaf) then 1 else 0 5 | result = if isLeaf (case d of Node a1 b1 -> Leaf ; Leaf -> Node Leaf Leaf) then 6 | (case d of 7 | Node a b -> 10 8 | Leaf -> 1 9 | ) + 1 10 | else 200 11 | ; 12 | isLeaf :: Tree -> Bool 13 | isLeaf t = case t of 14 | Leaf -> True 15 | Node a b -> False ; 16 | 17 | d :: Tree 18 | d = Node (Node Leaf Leaf) Leaf 19 | -------------------------------------------------------------------------------- /Examples/Data/patterns.hs: -------------------------------------------------------------------------------- 1 | -- Pattern compiler test. 2 | 3 | result :: Int 4 | result = length2 [1,2,3,4,5] 5 | 6 | length2 :: [Int] -> Int 7 | length2 [] = 0 8 | length2 (a:b:xs) = 2 + length2 xs 9 | length2 (x:xs) | (x > 0) = 1 + length2 xs 10 | length2 _ = 0 11 | 12 | -- length2 l | l == [] = 13 | -- case l of 14 | -- [] -> 0 15 | -- (a:b:xs) -> 2 + length2 xs 16 | -- (x:xs) | (x > 0) -> 1 + length2 xs 17 | -- _ -> 0 18 | -------------------------------------------------------------------------------- /Examples/Data/prog16.hs: -------------------------------------------------------------------------------- 1 | result = f sq 2 ; 2 | f s x = if x < 1 then s x else f (g s) (x - 1) ; 3 | g t y = f (add (t y)) y ; 4 | sq z = z * z ; 5 | add a b = a + b 6 | -------------------------------------------------------------------------------- /Examples/Data/qs.hs: -------------------------------------------------------------------------------- 1 | result :: Int 2 | result = select1 (qsort2 (nums 500)) 100 3 | append2 :: [Int] -> [Int] -> [Int] 4 | append2 l1 l2 = if (null2 l1) then l2 else (head2 l1) : (append2 (tail2 l1) l2); 5 | filter2 :: (Int -> Int -> Bool) -> Int -> [Int] -> [Int] 6 | filter2 f p l = if (null2 l) then [] else (if f (head2 l) p then (head2 l) : (filter2 f p (tail2 l)) else filter2 f p (tail2 l)); 7 | qsort2 :: [Int] -> [Int] 8 | qsort2 l = if null2 l then [] else append2 (qsort2 (filter2 lt (head2 l) (tail2 l))) ((head2 l) : (qsort2 (filter2 ge (head2 l) (tail2 l)))); 9 | lt :: Int -> Int -> Bool 10 | lt x y = if (x < y) then True else False; 11 | ge :: Int -> Int -> Bool 12 | ge x y = if (x >= y) then True else False; 13 | null2 :: [Int] -> Bool 14 | null2 ds = case ds of [] -> True 15 | cons_0 : cons_1 -> False; 16 | head2 :: [Int] -> Int 17 | head2 hl = case hl of cons_0 : cons_1 -> cons_0; 18 | tail2 :: [Int] -> [Int] 19 | tail2 tl = case tl of cons_0 : cons_1 -> cons_1; 20 | nums :: Int -> [Int] 21 | nums n = if (n==0) then [] else n : (nums (n-1)) ; 22 | select1 :: [Int] -> Int -> Int 23 | select1 xs n = if (n==0) then (head2 xs) else (select1 (tail2 xs) (n-1)); 24 | -------------------------------------------------------------------------------- /Examples/Data/quick-sort.hs: -------------------------------------------------------------------------------- 1 | -- GC test: 2 | --make && ./bench.sh -mh -mflags "-mem 2000000000 -gc" Examples/Data/quick-sort.hs 3 | -- uses 66% semi-space 4 | 5 | result :: Int 6 | result = select1 (qsort2 (nums 2000)) 999 7 | 8 | append2 :: [Int] -> [Int] -> [Int] 9 | append2 l1 l2 = case l1 of 10 | [] -> l2 11 | a : b -> a : (append2 b l2) ; 12 | filter2 :: (Int -> Int -> Bool) -> Int -> [Int] -> [Int] 13 | filter2 f p l = 14 | case l of 15 | [] -> [] 16 | a : b -> if f a p then a : (filter2 f p b) else filter2 f p b; 17 | 18 | qsort2 :: [Int] -> [Int] 19 | qsort2 l = 20 | case l of 21 | [] -> [] 22 | a : b -> append2 (qsort2 (filter2 lt a b)) (a : (qsort2 (filter2 ge a (b)))); 23 | 24 | lt :: Int -> Int -> Bool 25 | lt x y = x < y; 26 | ge :: Int -> Int -> Bool 27 | ge x y = x >= y; 28 | 29 | nums :: Int -> [Int] 30 | nums n = if (n==0) then [] else n : (nums (n-1)) ; 31 | 32 | select1 :: [Int] -> Int -> Int 33 | select1 xs n = 34 | case xs of 35 | a : b -> if (n==0) then a else select1 b (n-1); 36 | 37 | -------------------------------------------------------------------------------- /Examples/Data/quot.hs: -------------------------------------------------------------------------------- 1 | -- test for use of the ' symbol with the C back-end 2 | data List' = Nil' | Cons' Int List' 3 | result = head2 z' 4 | z' = Cons' 10 (Cons' 20 Nil') 5 | head2 x' = case x' of Cons' c cs -> c 6 | -------------------------------------------------------------------------------- /Examples/Data/records.hs: -------------------------------------------------------------------------------- 1 | -- Tests records and their selection/updating functions. 2 | 3 | data Person = Person { pAge :: Int , pShoeSize :: Int } 4 | 5 | result :: Int 6 | result = (nextYear p1) + (nextYear p2) + (nextYear p3) + (nextYear p4) 7 | 8 | p1 :: Person 9 | p1 = Person 30 40 10 | 11 | -- test field update 12 | p2 :: Person 13 | p2 = p1{pAge=10} 14 | 15 | -- test partial initialization, Haskell98 report, 3.15.2 16 | -- needs -w to be accepted by GHCi 17 | p3 :: Person 18 | p3 = Person {pAge = 10} 19 | 20 | -- named field initialization 21 | p4 :: Person 22 | p4 = Person {pShoeSize = 11, pAge = 10} 23 | 24 | nextYear :: Person -> Int 25 | nextYear p = pAge p + 1 26 | -------------------------------------------------------------------------------- /Examples/Data/result-case.hs: -------------------------------------------------------------------------------- 1 | -- Test for pattern matching at the level of the dummy LAR of 'result'. 2 | 3 | data List = Nil | Cons Int List 4 | result = 5 | case l of 6 | Nil -> 1 7 | Cons x xs -> 8 | case xs of 9 | Nil -> x+x 10 | Cons a as -> a+a 11 | from i = Cons i (from (i+10)) 12 | l = from 10 13 | 14 | -------------------------------------------------------------------------------- /Examples/Data/reverse.hs: -------------------------------------------------------------------------------- 1 | -- | Reverses a long list twice. 2 | -- 3 | module Main where 4 | 5 | main :: IO () 6 | main = putStrLn (show result) 7 | 8 | head2 :: [Int] -> Int 9 | head2 hl = 10 | case hl of 11 | cons_0:cons_1 -> cons_0 ; 12 | 13 | append1 :: [Int] -> [Int] -> [Int] 14 | append1 xs ys = 15 | case xs of 16 | [] -> ys 17 | a:b -> a:(append1 b ys) 18 | 19 | reverse1 :: [Int] -> [Int] 20 | reverse1 xs = 21 | case xs of 22 | [] -> [] 23 | a:b -> append1 (reverse1 b) (a:[]) ; 24 | 25 | createlist :: Int -> [Int] 26 | createlist n = if (n==0) then [] else n:(createlist (n-1)); 27 | 28 | result :: Int 29 | result = head2 (reverse1 (reverse1 (createlist 3000))) 30 | -------------------------------------------------------------------------------- /Examples/Data/separate.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Int List; 2 | 3 | mymap :: (Int -> Int) -> List -> List; 4 | mymap f xs = 5 | case xs of 6 | Nil -> Nil; 7 | Cons a b -> (Cons (f a) (mymap f b)); 8 | 9 | mysum :: List -> Int; 10 | mysum xs = 11 | case xs of 12 | Nil -> 0; 13 | Cons a b -> a + (mysum b); 14 | 15 | add :: Int -> Int -> Int 16 | add a b = a + b 17 | 18 | myid :: Int -> Int 19 | myid z = z 20 | 21 | f :: List -> Int 22 | f l = mysum (mymap (add 1) l) 23 | 24 | g :: List -> Int 25 | g l = mysum (mymap myid l) 26 | 27 | result :: Int 28 | result = f (Cons 0 (Cons 1 (Cons 2 Nil))) * g (Cons 3 (Cons 4 Nil)) 29 | -------------------------------------------------------------------------------- /Examples/Data/strict-data.hs: -------------------------------------------------------------------------------- 1 | data SList = SNil | SCons !Int SList ; 2 | result = f 10 (g 11) ; 3 | f a b = a + 1 ; 4 | g x = g (x + 1) ; 5 | test = SNil 6 | -------------------------------------------------------------------------------- /Examples/Data/tc1.hs: -------------------------------------------------------------------------------- 1 | result = putStrLn (show (142)) 2 | 3 | {- 4 | 5 | - the code below is not recognized by GHC, only by GIC 6 | 7 | showNum x = 8 | if x==0 then [] 9 | else if x<0 then (45):(showNum (-x)) 10 | else append (showNum (x `div` 10)) [(x `mod` 10)+48] 11 | append as bs = 12 | case as of 13 | [] -> bs 14 | x:xs -> x:(append xs bs) 15 | -} 16 | -------------------------------------------------------------------------------- /Examples/Data/test.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Int List ; 2 | result = head2 (tail2 lst) ; 3 | lst = Cons (10) (Cons (20) (Nil)) ; 4 | head2 hl = case hl of Cons cons_0 cons_1 -> cons_0 ; 5 | tail2 tl = case tl of Cons cons_0 cons_1 -> cons_1 6 | -------------------------------------------------------------------------------- /Examples/Data/test1-dlet.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Int List ; 2 | result = f 2 (h Nil 3); 3 | f x1 x2 = let g y = let z a = 1 + a + y 4 | in x1 + x2 + y + (z 10) 5 | h y = x1+x2 6 | in let k = (g 3) + x1 7 | in k ; 8 | h a b = let zz = case a of Nil -> 2*b 9 | in case a of Nil -> 2*zz ; 10 | 11 | -------------------------------------------------------------------------------- /Examples/Data/test1.hs: -------------------------------------------------------------------------------- 1 | data Func = FAdd Int; 2 | 3 | result :: Int 4 | result = repeat_many 2000 (twice (FAdd 1) 5); 5 | twice :: Func -> Int -> Int 6 | twice f x = apply f (apply f x); 7 | add :: Int -> Int -> Int 8 | add a b = a+b; 9 | repeat_many :: Int -> Int -> Int 10 | repeat_many n x = if (n==0) then 0 else x+ repeat_many (n-1) x 11 | apply :: Func -> Int -> Int 12 | apply cl d = case cl of FAdd c -> add c d; 13 | -------------------------------------------------------------------------------- /Examples/Data/test2-dlet.hs: -------------------------------------------------------------------------------- 1 | result = f 2 (h 0 3); 2 | f x1 x2 = let g y = let z a = 1 + a + y 3 | in x1 + x2 + y + (z 10) 4 | h y = x1+x2 5 | in let k = (g 3) + x1 6 | in k ; 7 | h a b = let zz = if a==0 then 2*b else 999 8 | in if a==0 then 2*zz else 888; 9 | 10 | -------------------------------------------------------------------------------- /Examples/Data/test2.hs: -------------------------------------------------------------------------------- 1 | result = repeat_many 200000 (twice (add 1) 5); 2 | twice f x = f(f x); 3 | add a b = a+b; 4 | repeat_many n x = if (n==0) then 0 else x + repeat_many (n-1) x 5 | -------------------------------------------------------------------------------- /Examples/Data/test5.hs: -------------------------------------------------------------------------------- 1 | result = f inc 17 ; 2 | sq c = c * c ; 3 | inc t = t+1; 4 | add a b = a + b ; 5 | f s x = if (x <= 0) then s x else f (f (add (s x))) (x-1) 6 | -------------------------------------------------------------------------------- /Examples/Data/test6.hs: -------------------------------------------------------------------------------- 1 | data Defunc1 = D_INC_0_I | D_F_1_I Defunc1 | D_ADD_1_I Int 2 | result = f d_inc_0_i 7; 3 | sq sq_c = sq_c * sq_c; 4 | inc inc_t = inc_t + 1; 5 | add add_a add_b = add_a + add_b; 6 | f f_s f_x = if (f_x <= 0) then (d_Apply_i_i f_s f_x) else (f (d_f_1_i (d_add_1_i (d_Apply_i_i f_s f_x))) (f_x - 1)); 7 | d_Apply_i_i cl_i_i d_Apply_i_i_0 = case cl_i_i of { 8 | D_INC_0_I -> inc d_Apply_i_i_0; 9 | D_F_1_I d_f_1_i_0 -> f d_f_1_i_0 d_Apply_i_i_0; 10 | D_ADD_1_I d_add_1_i_0 -> add d_add_1_i_0 d_Apply_i_i_0 11 | }; 12 | 13 | d_inc_0_i = D_INC_0_I ; 14 | d_f_1_i d_f_1_i_0 = D_F_1_I d_f_1_i_0; 15 | d_add_1_i d_add_1_i_0 = D_ADD_1_I d_add_1_i_0; 16 | -------------------------------------------------------------------------------- /Examples/Data/tree-let.hs: -------------------------------------------------------------------------------- 1 | data Tree = Node Tree Tree | Leaf; 2 | 3 | result = 4 | let t = Node (Node Leaf Leaf) (Node Leaf (Node Leaf Leaf)) 5 | in countDepth t; 6 | 7 | countDepth tr = 8 | let max a b = if a > b then a else b 9 | in case tr of 10 | Leaf -> 1 11 | Node node_0 node_1 -> 1 + (max (countDepth node_0) (countDepth node_1)); 12 | 13 | -------------------------------------------------------------------------------- /Examples/Data/tree-sort.hs: -------------------------------------------------------------------------------- 1 | data Tree = Empty | Node Int Tree Tree; 2 | 3 | append1 :: [Int] -> [Int] -> [Int] 4 | append1 xs ys = 5 | case xs of 6 | [] -> ys 7 | a : b -> a : (append1 b ys); 8 | treesort :: [Int] -> [Int] 9 | treesort xs = flatten1 (maketree xs); 10 | maketree :: [Int] -> Tree 11 | maketree xs = 12 | case xs of 13 | [] -> Empty 14 | a : b -> insert a (maketree b); 15 | insert :: Int -> Tree -> Tree 16 | insert x tr = 17 | case tr of 18 | Empty -> Node x Empty Empty 19 | Node el l r -> if (x <= el) then 20 | (Node el (insert x l) r) 21 | else (Node el l (insert x r)); 22 | createlist :: Int -> [Int] 23 | createlist n = if (n==0) then [] else n : (createlist (n-1)); 24 | flatten1 :: Tree -> [Int] 25 | flatten1 tr = 26 | case tr of 27 | Empty -> [] 28 | Node el l r -> append1 (append1 (flatten1 l) ([el])) (flatten1 r); 29 | select1 :: [Int] -> Int -> Int 30 | select1 xs n = 31 | case xs of 32 | a : b -> if (n==0) then a else (select1 b (n-1)); 33 | result :: Int 34 | result = select1 (treesort (createlist 5000)) 1000 35 | -------------------------------------------------------------------------------- /Examples/Data/tree.hs: -------------------------------------------------------------------------------- 1 | data Tree = Node Tree Tree | Leaf ; 2 | result = countDepth t ; 3 | t = Node (Node Leaf Leaf) (Node Leaf (Node Leaf Leaf)) ; 4 | countDepth tr = case tr of 5 | Leaf -> 1 6 | Node node_0 node_1 -> 1 + (max2 (countDepth node_0) (countDepth node_1)) ; 7 | -- "max" clashes with Prelude.max 8 | max2 a b = if a > b then a else b 9 | -------------------------------------------------------------------------------- /Examples/Data/underscore.hs: -------------------------------------------------------------------------------- 1 | -- Test for '_' binders. 2 | 3 | data List = Nil | Cons Int List 4 | result = test l 5 | l = Cons 1 (Cons 2 (Cons 3 Nil)) 6 | test x = 7 | case x of 8 | Nil -> 0 9 | Cons a _ -> a 10 | -------------------------------------------------------------------------------- /Examples/Data/unit.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | main = putStrLn (show result) ; 3 | 4 | result = test u 5 | u = () 6 | test x = 7 | case x of 8 | () -> 42 9 | -------------------------------------------------------------------------------- /Examples/GADT/PDefunc.hs: -------------------------------------------------------------------------------- 1 | -- | Defunctionalization's polymorphic closure dispatchers using GADTs. 2 | 3 | module PDefunc where 4 | 5 | {- 6 | -- Example source program. 7 | 8 | result :: Int 9 | result = if h aux True then h (add 2) 5 else 42 10 | 11 | h :: (a -> b) -> a -> b 12 | h g x = g x 13 | 14 | add :: Int -> Int -> Int 15 | add a b = a + b 16 | 17 | aux :: a -> a 18 | aux z = not z 19 | -} 20 | 21 | -- =============> defunctionalized: 22 | 23 | result :: Int 24 | result = 25 | if (h Aux True) then 26 | h (apply Add 2) 5 -- apply a closure that is a partial app. 27 | -- h AddP (2, 5) -- multiple argument application 28 | else 29 | 42 30 | 31 | h :: Closure a b -> a -> b 32 | h g x = apply g x 33 | 34 | add :: Int -> Int -> Int 35 | add a b = a + b 36 | 37 | aux :: a -> a 38 | aux z = z 39 | 40 | -- =======> code generated by defunctionalization: 41 | 42 | -- a closure taking a 'par' argument and returning a 'res' value 43 | data Closure par res where 44 | Aux :: Closure a a -- name 'aux', takes arg, polymorphic 45 | Add :: Closure Int (Closure Int Int) -- name 'add', takes first arg 46 | Add1 :: Int -> Closure Int Int -- name 'add', takes second arg 47 | AddP :: Closure (Int, Int) Int -- name 'add', takes all (2) args 48 | 49 | -- note: if we eta-reduce, apply functions become equal to constructors 50 | -- (only for single argument application) 51 | apply :: (Closure par res) -> par -> res 52 | apply cl arg = 53 | case cl of 54 | Add -> Add1 arg 55 | Add1 i -> add i arg 56 | Aux -> aux arg 57 | AddP -> 58 | case arg of 59 | (i, j) -> add i j 60 | -------------------------------------------------------------------------------- /Examples/Modules/Example1/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ModuleA (f, caf1, ThisOrThat(This, That)) 4 | 5 | main :: IO () 6 | main = putStrLn (show result) 7 | 8 | result :: Int 9 | result = f 10 + caf1 + caf2 10 | 11 | test1 :: Int -> ThisOrThat 12 | test1 x = This x 13 | 14 | caf2 :: Int 15 | caf2 = case (test1 10) of 16 | This a -> a 17 | That b -> 1000 18 | -------------------------------------------------------------------------------- /Examples/Modules/Example1/ModuleA.hs: -------------------------------------------------------------------------------- 1 | module ModuleA(f, g, caf1, ThisOrThat(This, That)) where 2 | 3 | data ThisOrThat = This Int | That Bool 4 | 5 | f :: Int -> Int 6 | f x = x + 1 7 | 8 | g :: Int -> Int 9 | g y = (y * 5) + (f caf1) 10 | 11 | caf1 :: Int 12 | caf1 = f 10 13 | 14 | zfun :: ThisOrThat 15 | zfun = This 10 16 | -------------------------------------------------------------------------------- /Examples/Modules/Example1/ModuleB.hs: -------------------------------------------------------------------------------- 1 | module ModuleB(f2) where 2 | 3 | f2 :: Int -> Int 4 | f2 x = 10 5 | -------------------------------------------------------------------------------- /Examples/Modules/Example2/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib where 2 | 3 | add3 :: Int -> Int -> Int -> Int 4 | add3 x y z = x + y + z 5 | 6 | high1 :: (Int -> Int -> Int) -> (Int -> Int) -> Int -> Int -> Int 7 | high1 f g x y = (f x y) + (g x) 8 | -- dummy1 = high1 (add3 18) (add3 19 1) 1 2 9 | -------------------------------------------------------------------------------- /Examples/Modules/Example2/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib (add3, high1) 4 | 5 | main :: IO () 6 | main = putStrLn (show result) 7 | 8 | result :: Int 9 | result = high1 (add3 18) (add3 19 1) 1 2 10 | -- result = high1 (add3 1 21) 3 11 | -------------------------------------------------------------------------------- /Examples/Modules/Example3/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib where 2 | 3 | data Rec = RecC { fieldA :: Int, fieldB :: Int } 4 | 5 | seventynine :: Int 6 | seventynine = let f x = let g y = x*x + y in g 3 + g 4 in f 6 7 | 8 | z1 :: Rec 9 | z1 = RecC 6 6 10 | 11 | z2 :: Int 12 | z2 = fieldA z1 13 | -------------------------------------------------------------------------------- /Examples/Modules/Example3/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib (Rec(RecC), fieldB, seventynine) 4 | 5 | data TestData = Test Int 6 | 7 | main :: IO () 8 | main = putStrLn (show result) 9 | 10 | -- test the corner case of "result" doing pattern matching 11 | result :: Int 12 | result = 13 | case test of 14 | Test t -> g + f (seventynine + 10) + t ; 15 | 16 | -- test imported constructor unpacking with let 17 | g :: Int 18 | g = let RecC x1 x2 = record 19 | in x2 20 | 21 | -- test if selectors and updaters work across modules 22 | f :: Int -> Int 23 | f x = x + (fieldB record) -- (fieldB (record{fieldB=2})) 24 | 25 | test :: TestData 26 | test = Test seventynine 27 | 28 | record :: Rec 29 | record = RecC 10 8 30 | -------------------------------------------------------------------------------- /Examples/Modules/Example4/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib where 2 | 3 | high :: (a -> b) -> a ->b 4 | high g x = g x 5 | 6 | h :: Int -> Int 7 | h y = y + 1 8 | 9 | test :: Int 10 | test = high h 1 11 | 12 | add :: Int -> Int -> Int 13 | add a b = a + b 14 | 15 | double :: (a -> a) -> a -> a 16 | double f x = f (f x) 17 | -------------------------------------------------------------------------------- /Examples/Modules/Example4/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Lib (high, test, add, double) 3 | 4 | main :: IO () 5 | main = putStrLn (show result) 6 | 7 | result :: Int 8 | result = f 10 + test 9 | 10 | f :: Int -> Int 11 | f a = a + (high (double (add 1)) 1) + (double ident (high dec 2)) 12 | 13 | dec :: Int -> Int 14 | dec x = x - 1 15 | 16 | ident :: a -> a 17 | ident z = z 18 | -------------------------------------------------------------------------------- /Examples/NewBench/ack.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn (show result) 5 | 6 | size :: Int 7 | size = 10 8 | 9 | result :: Int 10 | result = a 3 size ; 11 | 12 | a :: Int -> Int -> Int 13 | a m n = 14 | if m <= 0 then 15 | (n + 1) 16 | else (if n == 0 then 17 | a (m-1) 1 18 | else 19 | a (m-1) (a m (n-1))) 20 | -------------------------------------------------------------------------------- /Examples/NewBench/church.hs: -------------------------------------------------------------------------------- 1 | -- Church numerals 2 | 3 | module Main where 4 | 5 | main :: IO () 6 | main = putStrLn (show result) 7 | 8 | church :: Int -> (Int -> Int) -> Int -> Int 9 | church i f x = 10 | if i == 0 then 11 | x 12 | else 13 | church (i-1) f (f x); 14 | 15 | successor :: Int -> Int 16 | successor i = i + 1; 17 | 18 | unchurch :: ((Int -> Int) -> Int -> Int) -> Int 19 | unchurch n = n successor 0; 20 | 21 | c_succ :: ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 22 | c_succ n f x = 23 | n f (f x); 24 | 25 | c_plus :: ((Int -> Int) -> Int -> Int) -> 26 | ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 27 | c_plus n m f x = 28 | n f (m f x); 29 | 30 | c_nonzero :: ((Int -> Int) -> Int -> Int) -> 31 | ((Int -> Int) -> Int -> Int) -> 32 | ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 33 | c_nonzero n a b f x = 34 | n (c_nonzero_aux a f x) (b f x); 35 | 36 | c_nonzero_aux :: ((Int -> Int) -> Int -> Int) -> 37 | (Int -> Int) -> Int -> Int -> Int 38 | c_nonzero_aux a f x y = a f x; 39 | 40 | c_2x0 :: ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 41 | c_2x0 n f x = c_plus n n f x; 42 | c_2x1 :: ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 43 | c_2x1 n f x = n f (n f (f x)); 44 | 45 | c0 :: (Int -> Int) -> Int -> Int 46 | c0 f x = church 0 f x; 47 | c1 :: (Int -> Int) -> Int -> Int 48 | c1 f x = c_2x1 c0 f x; 49 | c3 :: (Int -> Int) -> Int -> Int 50 | c3 f x = c_2x1 c1 f x; 51 | c6 :: (Int -> Int) -> Int -> Int 52 | c6 f x = c_2x0 c3 f x; 53 | c12 :: (Int -> Int) -> Int -> Int 54 | c12 f x = c_2x0 c6 f x; 55 | c24 :: (Int -> Int) -> Int -> Int 56 | c24 f x = c_2x0 c12 f x; 57 | c48 :: (Int -> Int) -> Int -> Int 58 | c48 f x = c_2x0 c24 f x; 59 | c96 :: (Int -> Int) -> Int -> Int 60 | c96 f x = c_2x0 c48 f x; 61 | c192 :: (Int -> Int) -> Int -> Int 62 | c192 f x = c_2x0 c96 f x; 63 | c385 :: (Int -> Int) -> Int -> Int 64 | c385 f x = c_2x1 c192 f x; 65 | c771 :: (Int -> Int) -> Int -> Int 66 | c771 f x = c_2x1 c385 f x; 67 | c1543 :: (Int -> Int) -> Int -> Int 68 | c1543 f x = c_2x1 c771 f x; 69 | c3087 :: (Int -> Int) -> Int -> Int 70 | c3087 f x = c_2x1 c1543 f x; 71 | c6174 :: (Int -> Int) -> Int -> Int 72 | c6174 f x = c_2x0 c3087 f x; 73 | 74 | c7 :: (Int -> Int) -> Int -> Int 75 | c7 f x = c_succ c6 f x; 76 | 77 | c :: (Int -> Int) -> Int -> Int 78 | c f x = c_nonzero c3 c6174 c7 f x; 79 | 80 | rep :: Int -> Int -> Int 81 | rep n x = if (n<=0) then x else (rep (n-1) x) + x - (rep (n-2) x) 82 | 83 | size :: Int 84 | size = 36 85 | 86 | result :: Int 87 | result = rep size (unchurch c); 88 | -------------------------------------------------------------------------------- /Examples/NewBench/collatz.hs: -------------------------------------------------------------------------------- 1 | -- Computes the lengths of the Collatz sequences 2 | -- for the first 112000 natural numbers. 3 | 4 | size :: Int 5 | size = 112000 6 | 7 | data List = Nil | Cons Int List; 8 | 9 | result :: Int 10 | result = (sum1 (mymap f (nums1 1 size)) + 11 | sum1 (mymap f (nums2 1 size))) `div` 2 12 | 13 | f :: Int -> Int; 14 | f x = 15 | if (x==1) then 16 | 0 17 | else if ((x `mod` 2) == 0) then 18 | 1 + (f (x `div` 2)) 19 | else 20 | 1 + (f ((3*x)+1)); 21 | 22 | nums1 :: Int -> Int -> List; 23 | nums1 a b = 24 | if (a <= b) then 25 | (Cons a (nums2 (a+1) b)) 26 | else 27 | Nil 28 | 29 | nums2 :: Int -> Int -> List; 30 | nums2 a b = 31 | if (a <= b) then 32 | (Cons b (nums1 a (b-1))) 33 | else 34 | Nil 35 | 36 | mymap :: (Int -> Int) -> List -> List; 37 | mymap f xs = 38 | case xs of 39 | Nil -> Nil 40 | Cons a b -> (Cons (f a) (mymap f b)); 41 | 42 | sum1 :: List -> Int; 43 | sum1 xs = 44 | case xs of 45 | Nil -> 0 46 | Cons a b -> a+(sum1 b); 47 | -------------------------------------------------------------------------------- /Examples/NewBench/digits_of_e1.hs: -------------------------------------------------------------------------------- 1 | size :: Int 2 | size = 1500 3 | 4 | result :: Int 5 | result = select1 e size 6 | 7 | eContFrac :: [Int] 8 | eContFrac = 2 : (aux 2) 9 | 10 | aux :: Int -> [Int] 11 | aux n = 1 : (n : (1 : (aux (n+2)))) 12 | 13 | -- Output a digit if we can 14 | ratTrans :: Int -> Int -> Int -> Int -> [Int] -> [Int] 15 | ratTrans a b c d xs = 16 | case xs of 17 | [] -> [] 18 | h : tl -> 19 | if (((signum1 c == signum1 d) || 20 | (abs1 c < abs1 d)) && (((c+d)*(b `div` d)) <= (a+b)) && 21 | ((c+d)*(b `div` d) + (c+d) > (a+b))) then 22 | (b `div` d) : 23 | (ratTrans c d (a-((b `div` d)*c)) (b-((b `div` d)*d)) xs) 24 | else 25 | (ratTrans b (a+(h*b)) d (c+(h*d)) tl) 26 | 27 | signum1 :: Int -> Int 28 | signum1 x = if (x<0) then (0-1) else if (x>0) then 1 else 0 29 | 30 | abs1 :: Int -> Int 31 | abs1 x = if (x>=0) then x else (-x) 32 | 33 | -- Finally, we convert a continued fraction to digits 34 | -- by repeatedly multiplying by 10. 35 | 36 | toDigits :: [Int] -> [Int] 37 | toDigits l = case l of 38 | [] -> [] 39 | a : b -> a : (toDigits (ratTrans 10 0 0 1 b)) 40 | 41 | e :: [Int] 42 | e = toDigits eContFrac 43 | 44 | select1 :: [Int] -> Int -> Int 45 | select1 xs n = 46 | case xs of 47 | a : b -> if (n==0) then a else select1 b (n-1) 48 | -------------------------------------------------------------------------------- /Examples/NewBench/fast-reverse.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Int List; 2 | 3 | head2 :: List -> Int 4 | head2 hl = case hl of Cons cons_0 cons_1 -> cons_0 ; 5 | 6 | tail2 :: List -> List 7 | tail2 tl = case tl of Cons cons_0 cons_1 -> cons_1 ; 8 | 9 | append1 :: List -> List -> List 10 | append1 xs ys = 11 | case xs of 12 | Nil -> ys 13 | Cons a b -> Cons a (append1 b ys) ; 14 | 15 | reverse1 :: List -> List 16 | reverse1 xs = rev2 xs Nil; 17 | 18 | rev2 :: List -> List -> List 19 | rev2 xs ys = 20 | case xs of 21 | Nil -> ys 22 | Cons cons_0 cons_1 -> rev2 cons_1 (Cons cons_0 ys) 23 | 24 | createlist :: Int -> List 25 | createlist n = if (n==0) then Nil else (Cons n (createlist (n-1))); 26 | 27 | size :: Int 28 | size = 5000000 29 | 30 | result :: Int 31 | result = head2 (reverse1 (reverse1 (createlist size))) 32 | -------------------------------------------------------------------------------- /Examples/NewBench/fib.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn (show result) 5 | 6 | size :: Int 7 | size = 37 8 | 9 | result :: Int 10 | result = fib size ; 11 | 12 | fib :: Int -> Int 13 | fib x = if x<2 then 1 else (fib (x-1)) + (fib (x-2)) 14 | -------------------------------------------------------------------------------- /Examples/NewBench/naive-reverse.hs: -------------------------------------------------------------------------------- 1 | data List = Nil | Cons Int List 2 | 3 | head2 :: List -> Int 4 | head2 hl = 5 | case hl of 6 | Cons a b -> a 7 | 8 | append1 xs ys = 9 | case xs of 10 | Nil -> ys 11 | Cons a b -> Cons a (append1 b ys) 12 | 13 | reverse1 xs = 14 | case xs of 15 | Nil -> Nil 16 | Cons a b -> append1 (reverse1 b) (Cons a Nil) 17 | 18 | createlist :: Int -> List 19 | createlist n = if (n==0) then Nil else (Cons n (createlist (n-1))) 20 | 21 | size :: Int 22 | size = 5000 23 | 24 | result :: Int 25 | result = head2 (reverse1 (reverse1 (createlist size))) 26 | -------------------------------------------------------------------------------- /Examples/NewBench/ntak.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn (show result) 5 | 6 | size :: Int 7 | size = 32168 8 | 9 | shuffle :: (Int -> Int -> Int -> Int) -> Int -> Int -> Int -> Int -> Int 10 | shuffle h x y z n = 11 | if n `mod` 3 == 0 then 12 | ntak shuffle h (n+3) (x-1) y z 13 | else if n `mod` 3 == 1 then 14 | ntak shuffle h (n+2) (y-1) z x 15 | else 16 | ntak shuffle h (n+1) (z-1) x y 17 | 18 | ntak :: ((Int -> Int -> Int -> Int) -> Int -> Int -> Int -> Int -> Int) -> (Int -> Int -> Int -> Int) -> Int -> Int -> Int -> Int -> Int 19 | ntak f h n x y z = 20 | if x <= y then 21 | h x y z 22 | else 23 | ntak f h n (f h x y z n) 24 | (f h x y z (n+1)) 25 | (f h x y z (n+2)) 26 | 27 | third :: Int -> Int -> Int -> Int 28 | third x y z = z 29 | 30 | result :: Int 31 | result = ntak shuffle third 0 32 | (size `div` 1000) (size `mod` 1000 `div` 10) (size `mod` 10); 33 | -------------------------------------------------------------------------------- /Examples/NewBench/primes.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn (show result) 5 | 6 | size :: Int 7 | size = 175000; 8 | 9 | primes :: Int -> Int 10 | primes n = 11 | if n <= 0 then 12 | 2 13 | else if n == 1 then 14 | 3 15 | else 16 | findPrimeMinus (n-2) 1; 17 | 18 | findPrimeMinus :: Int -> Int -> Int 19 | findPrimeMinus n i = 20 | if testPrime (6*i-1) 1 then 21 | if n == 0 then 22 | 6*i-1 23 | else 24 | findPrimePlus (n-1) i 25 | else 26 | findPrimePlus n i; 27 | 28 | findPrimePlus :: Int -> Int -> Int 29 | findPrimePlus n i = 30 | if testPrime (6*i+1) 1 then 31 | if n == 0 then 32 | 6*i+1 33 | else 34 | findPrimeMinus (n-1) (i+1) 35 | else 36 | findPrimeMinus n (i+1); 37 | 38 | testPrime :: Int -> Int -> Bool 39 | testPrime n i = 40 | if (6*i-1) * (6*i-1) > n then 41 | True 42 | else if n `mod` (6*i-1) == 0 then 43 | False 44 | else if n `mod` (6*i+1) == 0 then 45 | False 46 | else 47 | testPrime n (i+1); 48 | 49 | result :: Int 50 | result = primes size; 51 | -------------------------------------------------------------------------------- /Examples/NewBench/queens-num.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn (show result) 5 | 6 | size :: Int 7 | size = 10; 8 | 9 | safe :: Int -> Int -> Int -> Int -> Int -> Bool 10 | safe q x n s d = 11 | if n == 0 then 12 | True 13 | else 14 | ((x /= (s `mod` q)) && 15 | (x /= ((s `mod` q) + d)) && 16 | (x /= ((s `mod` q) - d)) && 17 | safe q x (n-1) (s `div` q) (d+1)); 18 | 19 | count :: Int -> Int -> Int -> Int -> Int 20 | count x n s q = 21 | if n < q then 22 | if x < q then 23 | if safe q x n s 1 then 24 | count 0 (n+1) (x+(q*s)) q + count (x+1) n s q 25 | else 26 | count (x+1) n s q 27 | else 28 | 0 29 | else 30 | 1; 31 | 32 | data List = Nil | Cons Int List; 33 | 34 | mymap :: (Int -> Int) -> List -> List; 35 | mymap f xs = 36 | case xs of 37 | Nil -> Nil 38 | Cons a b -> (Cons (f a) (mymap f b)); 39 | 40 | sum1 :: List -> Int; 41 | sum1 xs = 42 | case xs of 43 | Nil -> 0 44 | Cons a b -> a + (sum1 b); 45 | 46 | nums1 :: Int -> Int -> List; 47 | nums1 a b = 48 | if (a <= b) then 49 | (Cons a (nums2 (a+1) b)) 50 | else 51 | Nil 52 | 53 | nums2 :: Int -> Int -> List; 54 | nums2 a b = 55 | if (a <= b) then 56 | (Cons b (nums1 a (b-1))) 57 | else 58 | Nil 59 | 60 | result :: Int 61 | result = 62 | (sum1 (mymap (count 0 0 0) (nums1 1 size)) + 63 | sum1 (mymap (count 0 0 0) (nums2 1 size))) `div` 2 64 | -------------------------------------------------------------------------------- /Examples/NewBench/queens.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn (show result) 5 | 6 | size :: Int 7 | size = 12 8 | 9 | result :: Int 10 | result = count size 11 | 12 | count :: Int -> Int 13 | count n = length2 (queens n) 14 | 15 | queens :: Int -> [[Int]] 16 | queens n = gen n n 17 | 18 | gen :: Int -> Int -> [[Int]] 19 | gen nq n = if n == 0 then [[]] else gen_1 nq (gen nq (n-1)) 20 | 21 | gen_1 :: Int -> [[Int]] -> [[Int]] 22 | gen_1 nq bs = 23 | case bs of 24 | [] -> [] 25 | b:bs' -> gen_2 nq b 1 (gen_1 nq bs') 26 | 27 | gen_2 :: Int -> [Int] -> Int -> [[Int]] -> [[Int]] 28 | gen_2 nq b q rest = if q <= nq then 29 | if safe q 1 b then 30 | (q:b) : (gen_2 nq b (q+1) rest) 31 | else 32 | gen_2 nq b (q+1) rest 33 | else 34 | rest 35 | 36 | safe :: Int -> Int -> [Int] -> Bool 37 | safe x d qs = 38 | case qs of 39 | [] -> True 40 | q:l -> (x /= q) && (x /= (q+d)) && (x /= (q-d)) && (safe x (d+1) l) 41 | 42 | length2 :: [[Int]] -> Int 43 | length2 bs = 44 | case bs of 45 | [] -> 0 46 | b : bs' -> 1 + length2 bs' 47 | -------------------------------------------------------------------------------- /Examples/NewBench/quick-sort.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn (show result) 5 | 6 | size :: Int 7 | size = 2500 8 | 9 | result :: Int 10 | result = (select1 (qsort2 (nums (size+10))) (size `div` 2)) + 11 | (select1 (qsort2 (nums (size-10))) (size `div` 2)) 12 | 13 | append2 :: [Int] -> [Int] -> [Int] 14 | append2 l1 l2 = case l1 of 15 | [] -> l2 16 | a:b -> a:(append2 b l2) ; 17 | 18 | filter2 :: (Int -> Int -> Bool) -> Int -> [Int] -> [Int] 19 | filter2 f p l = 20 | case l of 21 | [] -> [] 22 | a:b -> if f a p then a:(filter2 f p b) else filter2 f p b; 23 | 24 | qsort2 :: [Int] -> [Int] 25 | qsort2 l = 26 | case l of 27 | [] -> [] 28 | a:b -> append2 (qsort2 (filter2 lt a b)) 29 | (a:(qsort2 (filter2 ge a (b)))); 30 | 31 | lt :: Int -> Int -> Bool 32 | lt x y = x < y; 33 | 34 | ge :: Int -> Int -> Bool 35 | ge x y = x >= y; 36 | 37 | nums :: Int -> [Int] 38 | nums n = if (n==0) then [] else (n:(nums (n-1))); 39 | 40 | select1 :: [Int] -> Int -> Int 41 | select1 xs n = 42 | case xs of 43 | a:b -> if (n==0) then a else select1 b (n-1); 44 | -------------------------------------------------------------------------------- /Examples/NewBench/tree-sort.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | size :: Int 4 | size = 5000 5 | 6 | main :: IO () 7 | main = putStrLn (show result) 8 | 9 | data Tree = Empty | Node Int Tree Tree 10 | 11 | append1 :: [Int] -> [Int] -> [Int] 12 | append1 xs ys = 13 | case xs of 14 | [] -> ys 15 | a:b -> a:(append1 b ys) 16 | 17 | treesort :: [Int] -> [Int] 18 | treesort xs = flatten1 (maketree xs) 19 | 20 | maketree :: [Int] -> Tree 21 | maketree xs = 22 | case xs of 23 | [] -> Empty 24 | a:b -> insert a (maketree b) 25 | 26 | insert :: Int -> Tree -> Tree 27 | insert x tr = 28 | case tr of 29 | Empty -> 30 | Node x Empty Empty 31 | Node el l r -> 32 | if (x <= el) then 33 | (Node el (insert x l) r) 34 | else 35 | (Node el l (insert x r)) 36 | 37 | createlist :: Int -> [Int] 38 | createlist n = 39 | if (n==0) then [] else (n:(createlist (n-1))) 40 | 41 | flatten1 :: Tree -> [Int] 42 | flatten1 tr = 43 | case tr of 44 | Empty -> [] 45 | Node el l r -> append1 (append1 (flatten1 l) [el]) (flatten1 r); 46 | 47 | select1 :: [Int] -> Int -> Int 48 | select1 xs n = 49 | case xs of 50 | a:b -> if (n==0) then a else (select1 b (n-1)); 51 | 52 | result :: Int 53 | result = select1 (treesort (createlist size)) (size `div` 2) 54 | -------------------------------------------------------------------------------- /Examples/Num/ack.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn (show result) 3 | 4 | result :: Int 5 | result = a 3 3; 6 | 7 | a :: Int -> Int -> Int 8 | a m n = if m <= 0 then (n + 1) else if n == 0 then a (m-1) 1 else a (m-1) (a m (n-1)) 9 | -------------------------------------------------------------------------------- /Examples/Num/bigints.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn (show result) 3 | 4 | result :: Integer 5 | result = fact 30 6 | 7 | fact :: Int -> Integer 8 | fact x = if x<=1 then (toInteger 1) else (toInteger x) `mulI` fact (x-1) 9 | -------------------------------------------------------------------------------- /Examples/Num/cbn.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn (show result) 3 | 4 | result :: Int 5 | result = f 10 10 6 | 7 | f :: Int -> Int -> Int 8 | f x y = if x < 9 then y else f (y-1) (y-1) 9 | -------------------------------------------------------------------------------- /Examples/Num/church.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn (show result) 3 | 4 | identity :: Int -> Int 5 | identity i = i; 6 | 7 | successor :: Int -> Int 8 | successor i = i + 1; 9 | 10 | successor_h :: (Int -> Int) -> Int -> Int 11 | successor_h f x = f x + 1; 12 | 13 | -- first x y = x; 14 | -- second x y = y; 15 | 16 | 17 | -- Pairs 18 | 19 | -- type Pair a b c = (a -> b -> c) -> c 20 | 21 | -- c_pair :: a -> b -> Pair a b c 22 | -- c_pair x y z = z x y; 23 | 24 | -- c_fst :: Pair a b a -> a 25 | -- c_fst p = p first; 26 | 27 | -- c_snd :: Pair a b b -> b 28 | -- c_snd p = p second ; 29 | 30 | 31 | -- Church numerals 32 | 33 | -- type Church a = (a -> a) -> a -> a 34 | -- type Func a = a -> a 35 | 36 | -- church :: Int -> Church a 37 | church :: Int -> (Int -> Int) -> Int -> Int 38 | church i f x = 39 | if i == 0 then 40 | x 41 | else 42 | church (i-1) f (f x); 43 | 44 | -- church_h :: Int -> Church (Func a) 45 | church_h :: Int -> ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 46 | church_h i f x z = 47 | if i == 0 then 48 | x z 49 | else 50 | church_h (i-1) f x (f x z); 51 | 52 | -- unchurch :: Church Int -> Int 53 | unchurch :: ((Int -> Int) -> Int -> Int) -> Int 54 | unchurch n = n successor 0; 55 | 56 | -- unchurch_h :: Church (Func Int) -> Int 57 | unchurch_h :: (((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int) -> Int 58 | unchurch_h n = n successor_h identity 0; 59 | 60 | -- c_succ :: Church a -> Church a 61 | c_succ :: ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 62 | c_succ n f x = 63 | n f (f x); 64 | 65 | -- c_plus :: Church a -> Church a -> Church a 66 | -- c_plus :: (Int -> Int -> Int) -> (Int -> Int -> Int) -> Int -> Int -> Int 67 | c_plus :: ((Int -> Int) -> Int -> Int) -> ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 68 | c_plus n m f x = 69 | n f (m f x); 70 | 71 | -- c_plus_h :: Church (Func (Func a)) -> Church a -> Church a 72 | {- 73 | c_plus_h n m f x = 74 | n c_succ m f x; 75 | -} 76 | 77 | -- c_nonzero :: Church a -> Church a -> Church a -> Church a 78 | {- Not definable like this 79 | c_nonzero n a b f x = 80 | n (\y -> a f x) (b f x); 81 | -} 82 | c_nonzero :: ((Int -> Int) -> Int -> Int) -> ((Int -> Int) -> Int -> Int) -> ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 83 | c_nonzero n a b f x = 84 | if unchurch n == 0 then b f x else a f x; 85 | 86 | -- c_times :: Church a -> Church a -> Church a 87 | {- Not definable like this 88 | c_times n m f = 89 | n (m f); 90 | -} 91 | 92 | -- c_reduce :: Church (Func a) -> Church a 93 | {- Not necessary and not definable like this 94 | c_reduce n f = 95 | n (\h -> \x -> f (h x)) (\x -> x); 96 | -} 97 | 98 | -- c_exp :: Church a -> Church (Func a) -> Church a 99 | {- Not definable like this 100 | c_exp n m = 101 | m n; 102 | -} 103 | c_exp :: ((Int -> Int) -> Int -> Int) -> (((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 104 | c_exp n m f x = 105 | m n f x; 106 | {- 107 | c_exp n m = 108 | m (c_times n) (church 1); 109 | -} 110 | 111 | -- c_pred :: Church (Func (Func (Func a))) -> Church a 112 | {- Not definable like this 113 | c_pred n = 114 | n (\z -> \s -> c_nonzero s (z (church 0)) (c_plus (church 1) (z (church 0)))) 115 | (\s -> c_nonzero s (church 0) (church 0)) 116 | (church 1); 117 | -} 118 | -- c_pred :: Church (Pair (Church a) (Church a) (Church a)) -> Church a 119 | {- 120 | c_pred n f x = 121 | c_fst (n c_pred_aux_1 c_pred_aux_2) f x; 122 | -} 123 | -- c_pred_aux_1 :: Pair (Church a) (Church a) (Church a) -> 124 | -- Pair (Church a) (Church a) (Church a) 125 | {- 126 | c_pred_aux_1 p = 127 | c_pair (c_snd p) (c_succ (c_snd p)); 128 | c_pred_aux_2 = 129 | c_pair (church 0) (church 0); 130 | -} 131 | 132 | -- c_minus_h :: Church a -> Church (Func (Func a)) -> Church a 133 | {- 134 | c_minus_h :: 135 | Church a -> 136 | ((Church (Pair (Church a) (Church a) (Church a)) -> Church a) -> 137 | Church a -> Church a) -> 138 | Church a 139 | -} 140 | {- 141 | c_minus_h n m f x = m c_pred n f x; 142 | -} 143 | 144 | c_2x0 :: ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 145 | c_2x0 n f x = c_plus n n f x; 146 | c_2x1 :: ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 147 | c_2x1 n f x = n f (n f (f x)); 148 | 149 | c0 :: (Int -> Int) -> Int -> Int 150 | c0 f x = church 0 f x; 151 | c1 :: (Int -> Int) -> Int -> Int 152 | c1 f x = c_2x1 c0 f x; 153 | c3 :: (Int -> Int) -> Int -> Int 154 | c3 f x = c_2x1 c1 f x; 155 | c6 :: (Int -> Int) -> Int -> Int 156 | c6 f x = c_2x0 c3 f x; 157 | c12 :: (Int -> Int) -> Int -> Int 158 | c12 f x = c_2x0 c6 f x; 159 | c24 :: (Int -> Int) -> Int -> Int 160 | c24 f x = c_2x0 c12 f x; 161 | c48 :: (Int -> Int) -> Int -> Int 162 | c48 f x = c_2x0 c24 f x; 163 | c96 :: (Int -> Int) -> Int -> Int 164 | c96 f x = c_2x0 c48 f x; 165 | c192 :: (Int -> Int) -> Int -> Int 166 | c192 f x = c_2x0 c96 f x; 167 | c385 :: (Int -> Int) -> Int -> Int 168 | c385 f x = c_2x1 c192 f x; 169 | c771 :: (Int -> Int) -> Int -> Int 170 | c771 f x = c_2x1 c385 f x; 171 | c1543 :: (Int -> Int) -> Int -> Int 172 | c1543 f x = c_2x1 c771 f x; 173 | c3087 :: (Int -> Int) -> Int -> Int 174 | c3087 f x = c_2x1 c1543 f x; 175 | c6174 :: (Int -> Int) -> Int -> Int 176 | c6174 f x = c_2x0 c3087 f x; 177 | 178 | c7 :: (Int -> Int) -> Int -> Int 179 | c7 f x = c_succ c6 f x; 180 | c3_h :: ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 181 | c3_h f x z = church_h 3 f x z; 182 | c343 :: (Int -> Int) -> Int -> Int 183 | c343 f x = c_exp c7 c3_h f x; 184 | 185 | c :: (Int -> Int) -> Int -> Int 186 | c f x = c_nonzero c3 c6174 c343 f x; 187 | 188 | result :: Int 189 | result = unchurch c771; 190 | -------------------------------------------------------------------------------- /Examples/Num/church_defun.hs: -------------------------------------------------------------------------------- 1 | data Defunc = D_SUCCESSOR_0_I | D_SUCCESSOR_H_0_TI | D_IDENTITY_0_I | D_C0_0_TI | D_C1_0_TI | D_C3_0_TI | D_C6_0_TI | D_C12_0_TI | D_C24_0_TI | D_C48_0_TI | D_C96_0_TI | D_C192_0_TI | D_C385_0_TI | D_C771_0_TI | D_C1543_0_TI | D_C3087_0_TI | D_C7_0_TI | D_C3_H_0_TTI | D_C6174_0_TI | D_C343_0_TI 2 | 3 | main :: IO () 4 | main = putStrLn (show result) 5 | 6 | identity identity_i = identity_i; 7 | successor successor_i = successor_i + 1; 8 | successor_h successor_h_f successor_h_x = (d_Apply_i_i successor_h_f successor_h_x) + 1; 9 | church church_i church_f church_x = if (church_i == 0) then church_x else (church (church_i - 1) church_f (d_Apply_i_i church_f church_x)); 10 | church_h church_h_i church_h_f church_h_x church_h_z = if (church_h_i == 0) then (d_Apply_i_i church_h_x church_h_z) else (church_h (church_h_i - 1) church_h_f church_h_x (d_Apply_ti_i church_h_f church_h_x church_h_z)); 11 | unchurch unchurch_n = d_Apply_ti_i unchurch_n d_successor_0_i 0; 12 | unchurch_h unchurch_h_n = d_Apply_tti_i unchurch_h_n d_successor_h_0_ti d_identity_0_i 0; 13 | c_succ c_succ_n c_succ_f c_succ_x = d_Apply_ti_i c_succ_n c_succ_f (d_Apply_i_i c_succ_f c_succ_x); 14 | c_plus c_plus_n c_plus_m c_plus_f c_plus_x = d_Apply_ti_i c_plus_n c_plus_f (d_Apply_ti_i c_plus_m c_plus_f c_plus_x); 15 | c_nonzero c_nonzero_n c_nonzero_a c_nonzero_b c_nonzero_f c_nonzero_x = if ((unchurch c_nonzero_n) == 0) then (d_Apply_ti_i c_nonzero_b c_nonzero_f c_nonzero_x) else (d_Apply_ti_i c_nonzero_a c_nonzero_f c_nonzero_x); 16 | c_exp c_exp_n c_exp_m c_exp_f c_exp_x = d_Apply_tti_i c_exp_m c_exp_n c_exp_f c_exp_x; 17 | c_2x0 c_2x0_n c_2x0_f c_2x0_x = c_plus c_2x0_n c_2x0_n c_2x0_f c_2x0_x; 18 | c_2x1 c_2x1_n c_2x1_f c_2x1_x = d_Apply_ti_i c_2x1_n c_2x1_f (d_Apply_ti_i c_2x1_n c_2x1_f (d_Apply_i_i c_2x1_f c_2x1_x)); 19 | c0 c0_f c0_x = church 0 c0_f c0_x; 20 | c1 c1_f c1_x = c_2x1 d_c0_0_ti c1_f c1_x; 21 | c3 c3_f c3_x = c_2x1 d_c1_0_ti c3_f c3_x; 22 | c6 c6_f c6_x = c_2x0 d_c3_0_ti c6_f c6_x; 23 | c12 c12_f c12_x = c_2x0 d_c6_0_ti c12_f c12_x; 24 | c24 c24_f c24_x = c_2x0 d_c12_0_ti c24_f c24_x; 25 | c48 c48_f c48_x = c_2x0 d_c24_0_ti c48_f c48_x; 26 | c96 c96_f c96_x = c_2x0 d_c48_0_ti c96_f c96_x; 27 | c192 c192_f c192_x = c_2x0 d_c96_0_ti c192_f c192_x; 28 | c385 c385_f c385_x = c_2x1 d_c192_0_ti c385_f c385_x; 29 | c771 c771_f c771_x = c_2x1 d_c385_0_ti c771_f c771_x; 30 | c1543 c1543_f c1543_x = c_2x1 d_c771_0_ti c1543_f c1543_x; 31 | c3087 c3087_f c3087_x = c_2x1 d_c1543_0_ti c3087_f c3087_x; 32 | c6174 c6174_f c6174_x = c_2x0 d_c3087_0_ti c6174_f c6174_x; 33 | c7 c7_f c7_x = c_succ d_c6_0_ti c7_f c7_x; 34 | c3_h c3_h_f c3_h_x c3_h_z = church_h 3 c3_h_f c3_h_x c3_h_z; 35 | c343 c343_f c343_x = c_exp d_c7_0_ti d_c3_h_0_tti c343_f c343_x; 36 | c c_f c_x = c_nonzero d_c3_0_ti d_c6174_0_ti d_c343_0_ti c_f c_x; 37 | rep rep_n rep_x = if (rep_n <= 0) then rep_x else ((1 + (rep (rep_n - 1) rep_x)) + (rep (rep_n - 2) rep_x)); 38 | result = rep 30 (unchurch d_c771_0_ti); 39 | d_Apply_tti_i cl_tti_i d_Apply_tti_i_0 d_Apply_tti_i_1 d_Apply_tti_i_2 = case cl_tti_i of { 40 | D_C3_H_0_TTI -> c3_h d_Apply_tti_i_0 d_Apply_tti_i_1 d_Apply_tti_i_2 41 | }; 42 | d_Apply_ti_i cl_ti_i d_Apply_ti_i_0 d_Apply_ti_i_1 = case cl_ti_i of { 43 | D_SUCCESSOR_H_0_TI -> successor_h d_Apply_ti_i_0 d_Apply_ti_i_1; 44 | D_C0_0_TI -> c0 d_Apply_ti_i_0 d_Apply_ti_i_1; 45 | D_C1_0_TI -> c1 d_Apply_ti_i_0 d_Apply_ti_i_1; 46 | D_C3_0_TI -> c3 d_Apply_ti_i_0 d_Apply_ti_i_1; 47 | D_C6_0_TI -> c6 d_Apply_ti_i_0 d_Apply_ti_i_1; 48 | D_C12_0_TI -> c12 d_Apply_ti_i_0 d_Apply_ti_i_1; 49 | D_C24_0_TI -> c24 d_Apply_ti_i_0 d_Apply_ti_i_1; 50 | D_C48_0_TI -> c48 d_Apply_ti_i_0 d_Apply_ti_i_1; 51 | D_C96_0_TI -> c96 d_Apply_ti_i_0 d_Apply_ti_i_1; 52 | D_C192_0_TI -> c192 d_Apply_ti_i_0 d_Apply_ti_i_1; 53 | D_C385_0_TI -> c385 d_Apply_ti_i_0 d_Apply_ti_i_1; 54 | D_C771_0_TI -> c771 d_Apply_ti_i_0 d_Apply_ti_i_1; 55 | D_C1543_0_TI -> c1543 d_Apply_ti_i_0 d_Apply_ti_i_1; 56 | D_C3087_0_TI -> c3087 d_Apply_ti_i_0 d_Apply_ti_i_1; 57 | D_C7_0_TI -> c7 d_Apply_ti_i_0 d_Apply_ti_i_1; 58 | D_C6174_0_TI -> c6174 d_Apply_ti_i_0 d_Apply_ti_i_1; 59 | D_C343_0_TI -> c343 d_Apply_ti_i_0 d_Apply_ti_i_1 60 | }; 61 | d_Apply_i_i cl_i_i d_Apply_i_i_0 = case cl_i_i of { 62 | D_SUCCESSOR_0_I -> successor d_Apply_i_i_0; 63 | D_IDENTITY_0_I -> identity d_Apply_i_i_0 64 | }; 65 | d_successor_0_i = D_SUCCESSOR_0_I ; 66 | d_successor_h_0_ti = D_SUCCESSOR_H_0_TI ; 67 | d_identity_0_i = D_IDENTITY_0_I ; 68 | d_c0_0_ti = D_C0_0_TI ; 69 | d_c1_0_ti = D_C1_0_TI ; 70 | d_c3_0_ti = D_C3_0_TI ; 71 | d_c6_0_ti = D_C6_0_TI ; 72 | d_c12_0_ti = D_C12_0_TI ; 73 | d_c24_0_ti = D_C24_0_TI ; 74 | d_c48_0_ti = D_C48_0_TI ; 75 | d_c96_0_ti = D_C96_0_TI ; 76 | d_c192_0_ti = D_C192_0_TI ; 77 | d_c385_0_ti = D_C385_0_TI ; 78 | d_c771_0_ti = D_C771_0_TI ; 79 | d_c1543_0_ti = D_C1543_0_TI ; 80 | d_c3087_0_ti = D_C3087_0_TI ; 81 | d_c7_0_ti = D_C7_0_TI ; 82 | d_c3_h_0_tti = D_C3_H_0_TTI ; 83 | d_c6174_0_ti = D_C6174_0_TI ; 84 | d_c343_0_ti = D_C343_0_TI ; 85 | 86 | -------------------------------------------------------------------------------- /Examples/Num/defunc-test.hs: -------------------------------------------------------------------------------- 1 | -- c :: Int 2 | -- c = apply sq 2 ; 3 | 4 | sq :: Int -> Int 5 | sq a = a * a ; 6 | 7 | result :: Int 8 | result = 8 + 6 ; 9 | 10 | apply :: (Int -> Int) -> Int -> Int 11 | apply f x = f x 12 | -------------------------------------------------------------------------------- /Examples/Num/exmh1.hs: -------------------------------------------------------------------------------- 1 | result :: Int 2 | result = f 2 ; 3 | -- result2 = f 4 + f 5; 4 | 5 | f :: Int -> Int 6 | f x = g (x + 1) 0; 7 | 8 | g :: Int -> Int -> Int 9 | g y a = y ; 10 | -------------------------------------------------------------------------------- /Examples/Num/exmh100.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn (show result) 3 | 4 | result :: Int 5 | result = donut four three two one 4 200; 6 | 7 | donut :: ((((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int) -> ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int) -> 8 | (((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int) -> ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int -> Int 9 | donut a b c d e num = if num == 0 then 0 else a b c d e + donut a b c d (e + 17) (num - 1); 10 | 11 | four :: (((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int) -> 12 | ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 13 | four a b c d = a b c d; 14 | 15 | three :: ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int 16 | three b c d = b c d; 17 | 18 | two :: (Int -> Int) -> Int -> Int 19 | two c d = c d; 20 | 21 | one :: Int -> Int 22 | one d = d + 1 23 | -------------------------------------------------------------------------------- /Examples/Num/exmh101.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn (show result) 3 | 4 | result :: Int 5 | result = hfib apply add pred2 10; 6 | 7 | hfib :: ((Int -> Int) -> Int -> Int) -> (Int -> Int -> Int) -> 8 | (Int -> Int) -> Int -> Int 9 | hfib a f s n = if n <= 1 then n 10 | else f (hfib a f s (a s n)) (hfib a f s (a s (a s n))); 11 | 12 | apply :: (Int -> Int) -> Int -> Int 13 | apply g x = g x; 14 | 15 | pred2 :: Int -> Int 16 | pred2 m = m - 1; 17 | 18 | add :: Int -> Int -> Int 19 | add b c = b + c 20 | -------------------------------------------------------------------------------- /Examples/Num/exmh2.hs: -------------------------------------------------------------------------------- 1 | result :: Int 2 | result = apply inc 8 + apply dec 5; 3 | 4 | apply :: (Int -> Int) -> Int -> Int 5 | apply f x = f x; 6 | 7 | inc :: Int -> Int 8 | inc a = a + 1; 9 | 10 | dec :: Int -> Int 11 | dec b = b - 1 12 | -------------------------------------------------------------------------------- /Examples/Num/exmh20.hs: -------------------------------------------------------------------------------- 1 | result = apply four 3; 2 | apply f x = f x; 3 | four y = w y; 4 | z y1 = y1 * y1; 5 | w y2 = z y2 * z y2 6 | -------------------------------------------------------------------------------- /Examples/Num/exmh200.hs: -------------------------------------------------------------------------------- 1 | forget x = 42; 2 | id2 x = x; 3 | result = forget id2 4 | -------------------------------------------------------------------------------- /Examples/Num/exmh201.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn (show result) 3 | 4 | integ :: ((Int -> Int) -> Int -> Int) -> (Int -> Int) -> Int -> Int -> 5 | Int -> Int -> Int 6 | integ g h a b i s = 7 | if i < (b-a) then 8 | integ g h a b (i+1) (s + g h (a + i)) 9 | else 10 | s; 11 | 12 | trapezoid :: (Int -> Int) -> Int -> Int 13 | trapezoid f x = 14 | (f(x) + f(x+1)) `div` 2; 15 | 16 | {- 17 | --simpson13 f x = 18 | -- (f(x) + 4 * f(x+1) + f(x+2)) `div` 6; 19 | 20 | --simpson38 f x = 21 | -- (f(x) + 3 * f(x+1) + 3 * f(x+2) + f(x+3)) * 3 `div` 24; 22 | -} 23 | 24 | square :: Int -> Int 25 | square z = z * z; 26 | {- 27 | --inverse x = 10 `div` x; 28 | --absolute x = if x < 0 then -x else x; 29 | 30 | --diff g1 g2 = 31 | -- absolute (integ g1 square 0 10 0 0 - integ g2 square 0 10 0 0) + 32 | -- absolute (integ g1 inverse 1 10 0 0 - integ g2 inverse 1 10 0 0); 33 | -} 34 | 35 | result :: Int 36 | result = integ trapezoid square 0 10 0 0 37 | {- 38 | -- diff trapezoid simpson13 + 39 | -- diff simpson13 simpson38 + 40 | -- diff simpson38 trapezoid 41 | -} 42 | -------------------------------------------------------------------------------- /Examples/Num/exmh202.hs: -------------------------------------------------------------------------------- 1 | integ g h a b i s = 2 | if i < (b-a) then 3 | integ g h a b (i+1) (s + g h (a + i)) 4 | else 5 | s; 6 | 7 | {- 8 | trapezoid f x = 9 | (f(x) + f(x+1)) `div` 2; 10 | 11 | simpson13 f x = 12 | (f(x) + 4 * f(x+1) + f(x+2)) `div` 6; 13 | -} 14 | 15 | simpson38 f x = 16 | ((f(x) + (3 * f(x+1)) + (3 * f(x+2)) + f(x+3)) * 3) `div` 24; 17 | 18 | square x = x * x; 19 | {- 20 | inverse x = 10 `div` x; 21 | absolute x = if x < 0 then -x else x; 22 | 23 | diff g1 g2 = 24 | absolute (integ g1 square 0 10 0 0 - integ g2 square 0 10 0 0) + 25 | absolute (integ g1 inverse 1 10 0 0 - integ g2 inverse 1 10 0 0); 26 | -} 27 | 28 | result = 29 | {- 30 | diff trapezoid simpson13 + 31 | diff simpson13 simpson38 + 32 | diff simpson38 trapezoid 33 | -} 34 | integ simpson38 square 0 730 0 0 35 | -------------------------------------------------------------------------------- /Examples/Num/exmh203.hs: -------------------------------------------------------------------------------- 1 | fun f x = if x == 0 then f 0 + fun f 1 else 0; 2 | one a = a+1; 3 | two b = b+2; 4 | id2 t = t; 5 | diff g = id2 (fun g 0); 6 | result = diff one + diff two 7 | -------------------------------------------------------------------------------- /Examples/Num/exmh205.hs: -------------------------------------------------------------------------------- 1 | integrate g h a b = 2 | integ g h a b 0 0; 3 | 4 | integ g h a b i s = 5 | if i < (b-a) then 6 | integ g h a b (i+1) (s + g h (a + i)) 7 | else 8 | s; 9 | 10 | trapezoid f x = 11 | (f(x) + f(x+1)) `div` 2; 12 | 13 | square x = x * x; 14 | absolute x = if x < 0 then 0-x else x; 15 | 16 | diff g1 = 17 | absolute (integrate g1 square 0 1); 18 | 19 | result = 20 | diff trapezoid 21 | -------------------------------------------------------------------------------- /Examples/Num/exmh21.hs: -------------------------------------------------------------------------------- 1 | result = apply four 1; 2 | apply f x = f x; 3 | four y = w y; 4 | three y k = (m y k) + (n y k) + (two y k 1 ((n y k) - (m y k))); 5 | z y = (three y y) * y; 6 | w y = z y * three y (z y); 7 | two y k p a = p + (2 * a); 8 | m y k = 4 * k; 9 | n y k = k * (m y k) * (two y k 5 k) 10 | -------------------------------------------------------------------------------- /Examples/Num/exmh3.hs: -------------------------------------------------------------------------------- 1 | result :: Int 2 | result = ffac sq 8; 3 | 4 | ffac :: (Int -> Int) -> Int -> Int 5 | ffac h n = if n <= 1 then 1 else h n * ffac h (n - 1); 6 | 7 | sq :: Int -> Int 8 | sq a = a * a 9 | -------------------------------------------------------------------------------- /Examples/Num/exmh31.hs: -------------------------------------------------------------------------------- 1 | result = fourth third second first 4; 2 | fourth a b c d = a b c d; 3 | third e f g = e f g; 4 | second h i = h i; 5 | first j = j + 1 6 | -------------------------------------------------------------------------------- /Examples/Num/exmh9.hs: -------------------------------------------------------------------------------- 1 | result = third f sq 3; 2 | third g f x = g f x; 3 | f h x = twice h x; 4 | sq z = z * z; 5 | twice h y = h (h y) 6 | -------------------------------------------------------------------------------- /Examples/Num/exmh90.hs: -------------------------------------------------------------------------------- 1 | result = repeat2 100 fib 22; 2 | fib x = if x <= 1 then 1 else fib(x-1) + fib(x-2); 3 | repeat2 n f a = repeat_aux n f a 0; 4 | repeat_aux n f a b = if n > 0 then repeat_aux (n-1) f a (b + f a - b) else b 5 | -------------------------------------------------------------------------------- /Examples/Num/exmh91.hs: -------------------------------------------------------------------------------- 1 | result = fib 16; 2 | fib n = if n <= 1 then 1 else fib(n-1) + fib(n-2) 3 | -------------------------------------------------------------------------------- /Examples/Num/exmpl_with_cafs_2.hs: -------------------------------------------------------------------------------- 1 | fib x = if x<2 then 1 else (fib (x-1)) + (fib (x-2)) 2 | f34 = fib 34 3 | result = f34 + f34 + f34 4 | -------------------------------------------------------------------------------- /Examples/Num/fact-tr.hs: -------------------------------------------------------------------------------- 1 | result = fact 5 1; 2 | fact n r = if n == 0 then r else fact (n-1) (n*r) 3 | -------------------------------------------------------------------------------- /Examples/Num/fact.hs: -------------------------------------------------------------------------------- 1 | result = fact 6 ; 2 | fact x = if x < 2 then 1 else x * (fact (x - 1)) 3 | -------------------------------------------------------------------------------- /Examples/Num/fib.hs: -------------------------------------------------------------------------------- 1 | result = fib 22 ; 2 | fib x = if x<2 then 1 else (fib (x-1)) + (fib (x-2)) 3 | 4 | -- fib x = if x<2 then 1 else paradd (fib (x-1)) (fib (x-2)) ; 5 | -- paradd a b = (a `par` b) `pseq` (a+b) 6 | 7 | -------------------------------------------------------------------------------- /Examples/Num/fibs.hs: -------------------------------------------------------------------------------- 1 | -- result = h 50000 (fib 25); 2 | 3 | result :: Int 4 | result = h 8 17; 5 | -- h y a = if y <= 1 then 0 else a + (h (y-1) a); 6 | 7 | h :: Int -> Int -> Int 8 | h y a = if y <= 1 then 0 else (fib a) + (h (y-1) a); 9 | 10 | fib :: Int -> Int 11 | fib x = if x <= 1 then 1 else fib(x-1) + fib(x-2) 12 | -------------------------------------------------------------------------------- /Examples/Num/let-enum.hs: -------------------------------------------------------------------------------- 1 | result = (let x = 2 in x) + (let x = 3 in x) 2 | -------------------------------------------------------------------------------- /Examples/Num/memoize.hs: -------------------------------------------------------------------------------- 1 | result = f 80 2 | f a = a + a 3 | -------------------------------------------------------------------------------- /Examples/Num/myex0.hs: -------------------------------------------------------------------------------- 1 | result = f inc 2; 2 | f g y = g y * apply g y; 3 | apply h x = h x; 4 | inc a = a + 1 5 | 6 | 7 | {- 8 | "result" = CALL (1,"f_g__0") CALL (0,"f_y__0") ("f") 9 | "f" = "*" [CALL (0,"f_g_0__0") (ARG 1 0),CALL (1,"apply_h__0") CALL (0,"apply_x__0") ("apply")] 10 | "apply" = CALL (0,"apply_h_0__0") (ARG 1 0) 11 | "inc" = "+" [ARG 0 0,"1" ] 12 | "f_g__0" = SAVE (1,0) ACT_1 CALL (0,"inc_a__0") ("inc") 13 | "apply_h__0" = SAVE (1,0) ACT_1 CALL (0,"f_g_0__1") (ARG 1 0) 14 | "f_y__0" = SAVE (0,0) ACT_0 ACT_1 "2" 15 | "apply_x__0" = SAVE (0,0) ACT_0 ACT_1 ARG 0 0 16 | "inc_a__0" = SAVE (0,0) ACT_0 CALL (1,"f_g__0") (ARG 0 0) 17 | "f_g_0__0" = SAVE (0,0) ACT_0 ARG 0 0 18 | "f_g_0__1" = SAVE (0,0) ACT_0 CALL (1,"apply_h__0") (ARG 0 0) 19 | "apply_h_0__0" = SAVE (0,0) ACT_0 ARG 0 0 20 | -} 21 | -------------------------------------------------------------------------------- /Examples/Num/myex3.hs: -------------------------------------------------------------------------------- 1 | result = g ptwo + g ptwo; 2 | g h = h 0; 3 | --succ x = x + 1; 4 | ptwo x = x + 2 5 | -------------------------------------------------------------------------------- /Examples/Num/myex4.hs: -------------------------------------------------------------------------------- 1 | result = f ptwo 0; 2 | f g y = g y + g y; 3 | ptwo x = x + 2 4 | 5 | {- 6 | "result" = CALL (1,"f_g__0") CALL (0,"f_y__0") ("f") 7 | "f" = "+" [CALL (0,"f_g_0__0") (ARG 1 0),CALL (0,"f_g_0__0") (ARG 1 0)] 8 | "ptwo" = "+" [ARG 0 0,"2" ] 9 | "f_g__0" = SAVE (1,0) ACT_1 CALL (0,"ptwo_x__0") ("ptwo") 10 | "f_y__0" = SAVE (0,0) ACT_0 ACT_1 "0" 11 | "ptwo_x__0" = SAVE (0,0) ACT_0 CALL (1,"f_g__0") (ARG 0 0) 12 | "f_g_0__0" = SAVE (0,0) ACT_0 ARG 0 0 13 | -} 14 | -------------------------------------------------------------------------------- /Examples/Num/myex5.hs: -------------------------------------------------------------------------------- 1 | result = fib 5; 2 | fib n = if n <= 1 then 1 else fib(n-1) + fib(n-2) 3 | 4 | {- 5 | "result" = CALL (0,"fib_n__0") ("fib") 6 | "fib" = "if" ["<=" [ARG 0 0,"1" ],"1" ,"+" [CALL (0,"fib_n__1") ("fib"),CALL (0,"fib_n__2") ("fib")]] 7 | "fib_n__0" = SAVE (0,0) ACT_0 "2" 8 | "fib_n__1" = SAVE (0,0) ACT_0 "-" [ARG 0 0,"1" ] 9 | "fib_n__2" = SAVE (0,0) ACT_0 "-" [ARG 0 0,"2" ] 10 | -} 11 | -------------------------------------------------------------------------------- /Examples/Num/myex6.hs: -------------------------------------------------------------------------------- 1 | result = f inc 2; 2 | f g y = g y * apply g 5; 3 | apply h x = h x; 4 | inc a = a + 1 5 | 6 | 7 | {- 8 | "result" = CALL (1,"f_g__0") CALL (0,"f_y__0") ("f") 9 | "f" = "*" [CALL (0,"f_g_0__0") (ARG 1 0),CALL (1,"apply_h__0") CALL (0,"apply_x__0") ("apply")] 10 | "apply" = CALL (0,"apply_h_0__0") (ARG 1 0) 11 | "inc" = "+" [ARG 0 0,"1" ] 12 | "f_g__0" = SAVE (1,0) ACT_1 CALL (0,"inc_a__0") ("inc") 13 | "apply_h__0" = SAVE (1,0) ACT_1 CALL (0,"f_g_0__1") (ARG 1 0) 14 | "f_y__0" = SAVE (0,0) ACT_0 ACT_1 "2" 15 | "apply_x__0" = SAVE (0,0) ACT_0 ACT_1 ARG 0 0 16 | "inc_a__0" = SAVE (0,0) ACT_0 CALL (1,"f_g__0") (ARG 0 0) 17 | "f_g_0__0" = SAVE (0,0) ACT_0 ARG 0 0 18 | "f_g_0__1" = SAVE (0,0) ACT_0 CALL (1,"apply_h__0") (ARG 0 0) 19 | "apply_h_0__0" = SAVE (0,0) ACT_0 ARG 0 0 20 | -} 21 | -------------------------------------------------------------------------------- /Examples/Num/ntak.hs: -------------------------------------------------------------------------------- 1 | shuffle h x y z n = 2 | if n `mod` 3 == 0 then 3 | ntak shuffle h (n+3) (x-1) y z 4 | else if n `mod` 3 == 1 then 5 | ntak shuffle h (n+2) (y-1) z x 6 | else 7 | ntak shuffle h (n+1) (z-1) x y 8 | 9 | ntak f h n x y z = 10 | if x <= y then 11 | h x y z 12 | else 13 | ntak f h n (f h x y z n) 14 | (f h x y z (n+1)) 15 | (f h x y z (n+2)) 16 | 17 | third x y z = z 18 | 19 | -- result = ntak shuffle third 0 32 16 8 20 | result = ntak shuffle third 0 32 14 8 21 | -------------------------------------------------------------------------------- /Examples/Num/pj1.hs: -------------------------------------------------------------------------------- 1 | result = let f x = let g y = x*x + y in g 3 + g 4 in f 6 2 | -------------------------------------------------------------------------------- /Examples/Num/primes.hs: -------------------------------------------------------------------------------- 1 | primes :: Int -> Int 2 | primes n = 3 | if n <= 0 then 4 | 2 5 | else if n == 1 then 6 | 3 7 | else 8 | findPrimeMinus (n-2) 1; 9 | 10 | findPrimeMinus :: Int -> Int -> Int 11 | findPrimeMinus n i = 12 | if testPrime (6*i-1) 1 then 13 | if n == 0 then 14 | 6*i-1 15 | else 16 | findPrimePlus (n-1) i 17 | else 18 | findPrimePlus n i; 19 | 20 | findPrimePlus :: Int -> Int -> Int 21 | findPrimePlus n i = 22 | if testPrime (6*i+1) 1 then 23 | if n == 0 then 24 | 6*i+1 25 | else 26 | findPrimeMinus (n-1) (i+1) 27 | else 28 | findPrimeMinus n (i+1); 29 | 30 | testPrime :: Int -> Int -> Bool 31 | testPrime n i = 32 | if (6*i-1) * (6*i-1) > n then 33 | True 34 | else if n `mod` (6*i-1) == 0 then 35 | False 36 | else if n `mod` (6*i+1) == 0 then 37 | False 38 | else 39 | testPrime n (i+1); 40 | 41 | result :: Int 42 | result = primes 7500; 43 | -------------------------------------------------------------------------------- /Examples/Num/queens.hs: -------------------------------------------------------------------------------- 1 | safe :: Int -> Int -> Int -> Int -> Int -> Bool 2 | safe q x n s d = 3 | if n == 0 then 4 | True 5 | else 6 | ((x /= (s `mod` q)) && 7 | (x /= ((s `mod` q) + d)) && 8 | (x /= ((s `mod` q) - d)) && 9 | safe q x (n-1) (s `div` q) (d+1)); 10 | 11 | count :: Int -> Int -> Int -> Int -> Int 12 | count q x n s = 13 | if n < q then 14 | if x < q then 15 | if safe q x n s 1 then 16 | count q 0 (n+1) (x+(q*s)) + count q (x+1) n s 17 | else 18 | count q (x+1) n s 19 | else 20 | 0 21 | else 22 | 1; 23 | 24 | result :: Int 25 | result = count 11 0 0 0; 26 | -------------------------------------------------------------------------------- /Examples/Num/share.hs: -------------------------------------------------------------------------------- 1 | result = double a ; 2 | double x = x + x ; 3 | a = 42 4 | -------------------------------------------------------------------------------- /Examples/Num/sum.hs: -------------------------------------------------------------------------------- 1 | result = sum2 10000; 2 | sum2 x = if x<=1 then 1 else x + (sum2 (x-1)) 3 | -------------------------------------------------------------------------------- /Examples/Num/tak.hs: -------------------------------------------------------------------------------- 1 | result = tarai 220000 220000 220000; 2 | tarai x y z = if y < x then tarai (tarai (x-1) y z) (tarai (y-1) z x) (tarai (z-1) x y) else z 3 | -------------------------------------------------------------------------------- /Examples/Num/test-let.hs: -------------------------------------------------------------------------------- 1 | -- result = let y = 1 in y + (f 2 3); 2 | result = f 2 3; 3 | {-- 4 | f1 x1 x2 = let g a b = a + (b + (x1 + x2)) 5 | in let h z = x1 + (x1 + (z + 1)) 6 | in h (g 10 20) 7 | --} 8 | f x1 x2 = let g y = let z a = 1 + a + y 9 | in x1 + x2 + y + (z 10) 10 | h y = x1+x2 11 | in let k = (g 3) + x1 12 | in k ; 13 | -- h a b = let zz = case a of Nil -> 0+b 14 | -- in zz ; 15 | 16 | -------------------------------------------------------------------------------- /Examples/Parallel/Parfib.hs: -------------------------------------------------------------------------------- 1 | -- | Parallel Fibonacci example, parallelism cutoff at parameter 11. 2 | 3 | module Parfib where 4 | 5 | import Control.Parallel (par, pseq) 6 | 7 | result :: Int 8 | result = fib 31 9 | 10 | fib :: Int -> Int 11 | fib x = if x<2 then 1 else if x<11 then ((fib (x-1)) + (fib (x-2))) else addpar (fib (x-1)) (fib (x-2)) ; 12 | 13 | addpar :: Int -> Int -> Int 14 | addpar a b = (a `par` b) `pseq` (a+b) 15 | -------------------------------------------------------------------------------- /Examples/Parallel/Parmap.hs: -------------------------------------------------------------------------------- 1 | -- | Parallel map example. 2 | module Parmap where 3 | 4 | import Control.Parallel (par, pseq) 5 | 6 | result :: Int 7 | result = sum2 (parmap fib (ints 33)) 8 | 9 | ints :: Int -> [Int] 10 | ints i = if i==0 then [] else i:(ints (i-1)) 11 | 12 | fib :: Int -> Int 13 | fib x = if x<2 then 1 else ((fib (x-1)) + (fib (x-2))) 14 | 15 | sum2 :: [Int] -> Int 16 | sum2 l = case l of [] -> 0 ; x:xs -> x+(sum2 xs) 17 | 18 | parmap :: (Int -> Int) -> [Int] -> [Int] 19 | parmap f l = 20 | case l of 21 | [] -> [] 22 | x:xs -> auxpar (f x) (parmap f xs) 23 | 24 | auxpar :: Int -> [Int] -> [Int] 25 | auxpar z fxs = (z `par` fxs) `pseq` (z:fxs) 26 | -------------------------------------------------------------------------------- /Examples/Polymorphic/Lists.hs: -------------------------------------------------------------------------------- 1 | -- Polymorphic lists. 2 | 3 | module Lists where 4 | 5 | result :: Int 6 | result = (lengthP xP) + (lengthP yP) + (lengthL xL) + (lengthL yL) 7 | 8 | -- user-defined 9 | 10 | data List a = Nil | Cons a (List a) 11 | 12 | lengthP :: List a -> Int 13 | lengthP as = 14 | case as of 15 | Nil -> 0 16 | Cons l ls -> 1 + (lengthP ls) 17 | 18 | xP :: List Int 19 | xP = Cons 1 (Cons 2 (Cons 3 Nil)) 20 | 21 | yP :: List Bool 22 | yP = Cons True (Cons True (Cons False Nil)) 23 | 24 | -- built-in 25 | 26 | lengthL :: [a] -> Int 27 | lengthL as = 28 | case as of 29 | [] -> 0 30 | l:ls -> 1 + (lengthL ls) 31 | 32 | xL :: [Int] 33 | xL = [1, 2, 3] 34 | 35 | yL :: [Bool] 36 | yL = [True, True, False] 37 | -------------------------------------------------------------------------------- /Examples/Polymorphic/Poly1.hs: -------------------------------------------------------------------------------- 1 | module Poly1 where 2 | 3 | data List = Nil | Cons Int List 4 | 5 | main :: IO () 6 | main = putStrLn (show result) 7 | 8 | result :: Int 9 | result = (length1 (ident a)) + (length2 (ident b)) 10 | 11 | length1 :: [Int] -> Int 12 | length1 xl = 13 | case xl of 14 | [] -> 0 15 | x:xs -> 1 + length1 xs 16 | a :: [Int] 17 | a = [1,2,3] 18 | 19 | length2 :: List -> Int 20 | length2 xl = 21 | case xl of 22 | Nil -> 0 23 | Cons x xs -> 1 + length2 xs 24 | b :: List 25 | b = Cons 1 (Cons 2 (Cons 3 Nil)) 26 | 27 | ident :: z -> z 28 | ident z = z 29 | 30 | -------------------------------------------------------------------------------- /Examples/Polymorphic/Poly2.hs: -------------------------------------------------------------------------------- 1 | module Poly2 where 2 | 3 | main :: IO () 4 | main = putStrLn (show result) 5 | 6 | result :: Int 7 | result = (double inc 1) + lengthZ (double ident [1, 2, 3]) 8 | 9 | double :: (a->a) -> a -> a 10 | double f x = f (f x) 11 | 12 | inc :: Int -> Int 13 | inc z = z + 1 14 | 15 | ident :: a -> a 16 | ident x = x 17 | 18 | lengthZ :: [Int] -> Int 19 | lengthZ z = 20 | case z of 21 | [] -> 0 22 | x:xs -> 1 + (lengthZ xs) 23 | -------------------------------------------------------------------------------- /Examples/Polymorphic/Poly3.hs: -------------------------------------------------------------------------------- 1 | module Poly3 where 2 | 3 | main :: IO () 4 | main = putStrLn (show result) 5 | 6 | result :: Int 7 | result = if h ident True then (h add 17) 25 8 | else h (add 2) 5 9 | 10 | h :: (a1 -> a2) -> a1 -> a2 11 | h g x = g x 12 | 13 | add :: Int -> Int -> Int 14 | add a b = a + b 15 | 16 | ident :: a1 -> a1 17 | ident z = z 18 | -------------------------------------------------------------------------------- /Examples/Polymorphic/Tc1.hs: -------------------------------------------------------------------------------- 1 | -- Type classes test. 2 | -- 3 | -- The type class instance methods used here can be resolved statically, no 4 | -- need for passing around dictionaries. 5 | -- 6 | 7 | module Tc1 where 8 | 9 | data Pair = Pair Int Int 10 | data Triple = Triple Int Int Int 11 | 12 | class Sum a where 13 | sumFields :: a -> Int 14 | 15 | instance Sum Pair where 16 | sumFields x = 17 | case x of 18 | Pair a b -> a + b 19 | 20 | instance Sum Triple where 21 | sumFields x = 22 | case x of 23 | Triple a b c -> a + b + c 24 | 25 | main :: IO () 26 | main = putStrLn (show result) 27 | 28 | result :: Int 29 | result = invokeTcMethods 30 | 31 | invokeTcMethods :: Int 32 | invokeTcMethods = (sumFields (Pair 10 20)) + (sumFields (Triple 12 3 2)) 33 | -------------------------------------------------------------------------------- /Examples/Polymorphic/Tuples.hs: -------------------------------------------------------------------------------- 1 | module Tuples where 2 | 3 | main :: IO () 4 | main = putStrLn (show result) 5 | 6 | result :: Int 7 | result = (sum2 (1, 2)) + (sum3 (3, 4, 5)) 8 | 9 | sum2 :: (Int, Int) -> Int 10 | sum2 x = 11 | case x of (a, b) -> a+b 12 | 13 | sum3 :: (Int, Int, Int) -> Int 14 | sum3 x = 15 | case x of (a, b, c) -> a+b+c 16 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # GHC profiling options 2 | # HPROFILE=-prof -fprof-auto 3 | HPROFILE= 4 | 5 | # C profiling options 6 | #CPROFILE=-pg -fprofile-arcs 7 | CPROFILE= 8 | 9 | #CC=gcc-3.0 10 | CC=gcc 11 | CFLAGS=-O3 -std=c99 -pedantic -Wall -g $(CPROFILE) 12 | 13 | EXTRA=-package ghc -fwarn-unused-binds -Wall 14 | #EXTRA=-Wall 15 | #EXTRA= 16 | #EXTRA=-fhpc 17 | #EXTRA=-auto -prof 18 | 19 | # Use of the GHC API for type checking. 20 | USE_GHC=-DUSE_GHC -XRankNTypes 21 | # USE_GHC= 22 | 23 | HADDOCK=haddock 24 | 25 | .PHONY: gic 26 | 27 | gic: 28 | ghc $(EXTRA) $(HPROFILE) $(USE_GHC) --make -o $@ Main.hs 29 | 30 | erl-gic: gic 31 | gcc $(CFLAGS) -fpic -shared -DERLANG_NIF_C c/cat.c -o libcat.so 32 | 33 | clean: 34 | $(RM) *.hi *.o SLIC/*.hi SLIC/*.o SLIC/*/*.hi SLIC/*/*.o SLIC/*/*/*.hi SLIC/*/*/*.o libcat.so main.c dfmod.c main-link.c main.erl main.beam gc.beam warehouse.beam warehouse_redis.beam test.maude a.out gmon.out *~ *.da graph.dot doc/haddock/* Examples/Modules/Example*/*.dfi Examples/Modules/Example*/*.ii Examples/Modules/Example*/*.o 35 | $(RM) -r doc/doxygen/* 36 | 37 | distclean: clean 38 | $(RM) gic 39 | 40 | haddock: 41 | $(HADDOCK) Main.hs --optghc='-package ghc' -h -o doc/haddock 42 | 43 | doxygen: 44 | doxygen 45 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | The generalized intensional compiler 2 | ==================================== 3 | 4 | A compiler for a subset of Haskell based on the intensional transformation and 5 | modular polymorphic defunctionalization. Under development, version 0.10. 6 | 7 | Features: 8 | 9 | * Separate module compilation. 10 | * Parametric polymorphism, GADTs. 11 | * A dataflow interpreter. 12 | * A compiler to the rewriting logic of Maude. 13 | 14 | See the examples under /Examples for the language features supported. 15 | 16 | Requirements 17 | ------------ 18 | 19 | To build the compiler, you need: 20 | 21 | * GHC 8.0.2 22 | * ghc-paths 23 | * haskell-src-exts 1.18.2 24 | * For the C back-end: 25 | * GCC (with OpenMP support if the parallel runtime is enabled) 26 | * The Boehm-Demers-Weiser garbage collector from: 27 | (http://www.hpl.hp.com/personal/Hans_Boehm/gc/) 28 | Note: configure with --enable-parallel-mark/-DTHREAD_LOCAL_ALLOC for the parallel runtime. 29 | * Optional: libgmp (is the `HAS_GMP` macro is enabled) for big integers 30 | (the Integer data type, see `run_lar.sh`). 31 | * Optional: libunwind if using the semi-space collector (needed for the compact 32 | representation back-end). 33 | * For the Erlang back-end: Erlang/OTP R16 or greater. 34 | * For the Maude back-end: Maude 2.6 and Full Maude. 35 | * Optional: the GHC profiling libs (if HPROFILE is set in the Makefile), 36 | to support stack traces in the compiler executable. 37 | 38 | Building the compiler (stack) 39 | ----------------------------- 40 | 41 | stack setup 42 | stack build 43 | 44 | Building the compiler (make) 45 | ---------------------------- 46 | 47 | * To disable type checking with the GHC API, comment out the `USE_GHC` flag in 48 | the Makefile. 49 | 50 | * To build the compiler on Linux or Windows with Cygwin, run the following command 51 | at the top-level directory (where Main.hs is located): 52 | 53 | make 54 | 55 | To build gic in Windows without Cygwin, use buildwin.bat. 56 | 57 | Using the compiler 58 | ------------------ 59 | 60 | To use the Boehm-Demers-Weiser garbage collector change macros 61 | `GC_INCLUDE` and `GC_LIB` in `run_libgc.sh` to point to the location 62 | of the collector. 63 | 64 | To compile and run an example `Main.hs`, run: 65 | 66 | ./run_libgc.sh Main.hs 67 | 68 | The result binary will be in `./a.out`. To use the GHC-based type checker, run: 69 | 70 | GICFLAGS="-ghc-tc" ./run_libgc.sh Main.hs 71 | 72 | To compile and run an example `Test.hs` using the type checker of the GHC API, run: 73 | 74 | ./run_lar.sh -ghc-tc Test.hs 75 | 76 | The module must have all types filled in by the user with explicit type signatures. 77 | 78 | To display the options that can be used with `gic`, run: 79 | 80 | ./gic -help 81 | 82 | To compile a program using the OpenMP-based runtime, set the OMP environment variable: 83 | 84 | OMP=1 ./run_libgc.sh Fibpar.hs 85 | 86 | Using the built-in interpreter 87 | ------------------------------ 88 | 89 | The built-in interpreter is invoked with `-e`, for example: 90 | 91 | ./gic -e Examples/Data/addsx.hs 92 | 93 | This transforms the input program to a 0-order intensional one and runs it 94 | using a warehouse for laziness. 95 | 96 | Documentation 97 | ------------- 98 | 99 | To generate the code documentation using haddock, run: 100 | 101 | make haddock 102 | 103 | The resulting documentation is in `doc/haddock`. 104 | 105 | Contributors 106 | ------------ 107 | 108 | * Angelos Charalambidis 109 | * Georgios Fourtounis 110 | * Nikolaos Papaspyrou 111 | * Panos Rondogiannis 112 | * Panagiotis Theofilopoulos 113 | 114 | License 115 | ------- 116 | 117 | The compiler is licensed under the terms of the GNU LGPL. 118 | 119 | If the compiler is linked with libgmp or the GHC API, the restrictions of their 120 | respective licenses apply. 121 | 122 | Copyright 2009-2014, Georgios Fourtounis, Software Engineering Laboratory, 123 | National Technical University of Athens. 124 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | The generalized intensional compiler 2 | ==================================== 3 | 4 | A compiler for a subset of Haskell based on the intensional transformation and 5 | modular polymorphic defunctionalization. Under development, version 0.10. 6 | 7 | Features: 8 | 9 | * Separate module compilation. 10 | * Parametric polymorphism, GADTs. 11 | * A dataflow interpreter. 12 | * A compiler to the rewriting logic of Maude. 13 | 14 | See the examples under /Examples for the language features supported. 15 | 16 | For more information about building and using it, consult the README. 17 | -------------------------------------------------------------------------------- /SLIC/AuxFun.hs: -------------------------------------------------------------------------------- 1 | -- | Auxiliay functions that do not fit anywhere else. 2 | 3 | module SLIC.AuxFun (comment, foldDot, errM, ierr, insCommIfMore, lkUpSure, 4 | mergeM, nameOf, pathOf, showNum, showStrings, 5 | spaces, toLowerFirst, threadfunc_l, trace2) where 6 | 7 | import Debug.Trace (trace) 8 | import Data.Char (toLower) 9 | import Data.List (intercalate) 10 | import Data.Map (Map, lookup, unionWithKey) 11 | import Data.Sequence (elemIndexR, fromList) 12 | import SLIC.Constants 13 | 14 | -- | Debugging trace. 15 | trace2 :: String -> a -> a 16 | trace2 = Debug.Trace.trace 17 | 18 | -- | A 'foldl (.)'. 19 | foldDot :: (a1 -> a -> a) -> [a1] -> a -> a 20 | foldDot f l = foldl (.) id (map f l) 21 | 22 | -- | Looks up an entry in a map (by key), or shows an error. 23 | lkUpSure :: (Ord a, Show a, Show b) => a -> Map a b -> b 24 | lkUpSure x l = 25 | case Data.Map.lookup x l of 26 | Nothing -> ierr ("lkUpSure: "++show x++" must be existing key in "++show l) 27 | Just v -> v 28 | 29 | -- | Show positive big numbers in a nice way. 30 | showNum :: Int -> String 31 | showNum num = 32 | let showTripl n 33 | | n < 0 = ierr "showTripl only works for positive numbers" 34 | | n < 10 = "00" ++ show n 35 | | n < 100 = "0" ++ show n 36 | | n < 1000 = show n 37 | | otherwise = ierr "showTripl can't handle numbers => 1000" 38 | ndiv = num `div` 1000 39 | nmod = num `mod` 1000 40 | in if ndiv == 0 then show nmod 41 | else showNum ndiv ++ "," ++ showTripl nmod 42 | 43 | -- | Iterate a function over lists with a threaded counter. 44 | threadfunc_l :: Int -> [a] -> (Int -> a -> (b, Int)) -> ([b], Int) 45 | threadfunc_l i [] _ = ([], i) 46 | threadfunc_l i (x:xs) f = 47 | let (x', i') = f i x 48 | (xs', i'') = threadfunc_l i' xs f 49 | in (x' : xs', i'') 50 | 51 | -- | Merges two maps, aborts with an error when duplicate keys 52 | -- are found. 53 | mergeM :: (Ord k, Show k, Show a) => Map k a -> Map k a -> Map k a 54 | mergeM = Data.Map.unionWithKey 55 | (\ k a1 a2 -> ierr $ "duplicate renaming for key "++(show k)++" and values: "++(show [a1, a2])++". Possible cause: local name inside let bindings is the same as local name inside function") 56 | 57 | -- | Make the first letter of a string lowercase. 58 | toLowerFirst :: String -> String 59 | toLowerFirst [] = error "toLowerFirst: string is empty" 60 | toLowerFirst (s:r) = (toLower s):r 61 | 62 | -- * Error reporting 63 | 64 | -- | Produce an 'internal error' mesage. 65 | ierr :: String -> a 66 | ierr msg = error $ "internal error: "++msg 67 | 68 | -- | Show an error about something (2nd arg) happening in a module (1st arg). 69 | errM :: (String, String) -> String -> a 70 | errM (m, _) msg = error $ "[GIC] Module "++m++": "++msg 71 | 72 | -- * Pretty printing 73 | 74 | -- | Shows a list of strings, separated by a given delimiter. 75 | showStrings :: String -> [String] -> ShowS 76 | showStrings delim0 ps = ((intercalate delim0 ps)++) 77 | 78 | -- | Create a comment containing some text. 79 | comment :: ShowS -> ShowS 80 | comment s = if comments then spaces 1.lcomment.spaces 1.s.spaces 1.rcomment.spaces 1 else id 81 | 82 | -- | Spacing function. 83 | spaces :: Int -> ShowS 84 | spaces n = ((replicate n ' ')++) 85 | 86 | -- | Prints a list, separating the elements with commas. 87 | insCommIfMore :: [ShowS] -> ShowS 88 | insCommIfMore [] = id 89 | insCommIfMore [l] = l 90 | insCommIfMore (l:ls) = l.(", "++).insCommIfMore ls 91 | 92 | -- * Name handling 93 | 94 | -- | Returns the path of a file path (the part until the directory separator). 95 | pathOf :: String -> String 96 | pathOf fName = 97 | case elemIndexR dirSeparator (Data.Sequence.fromList fName) of 98 | Nothing -> defaultPath 99 | Just idx -> take idx fName 100 | 101 | -- | Returns the filename of a file path (the part after the directory separator). 102 | nameOf :: String -> String 103 | nameOf fName = 104 | case elemIndexR dirSeparator (Data.Sequence.fromList fName) of 105 | Nothing -> fName 106 | Just idx -> drop (idx+1) fName 107 | -------------------------------------------------------------------------------- /SLIC/CompManager.hs: -------------------------------------------------------------------------------- 1 | -- | The compilation manager. 2 | -- 3 | 4 | module SLIC.CompManager (ModFPre, contProcFL, prepareFL, rearrangeMods, 5 | readMGraphForL) where 6 | 7 | import Data.Graph (SCC(..), stronglyConnComp) 8 | import Data.List ((\\)) 9 | import Data.Map (Map, fromList, insert, keys, lookup, member, singleton, 10 | toList, union, unions) 11 | import Data.Maybe (mapMaybe) 12 | import SLIC.AuxFun (pathOf, showStrings) 13 | import SLIC.DFI 14 | import SLIC.Driver (processFL) 15 | import SLIC.Front.Preprocessor (qual) 16 | import SLIC.Front.Typeclass 17 | import SLIC.State 18 | import SLIC.SyntaxAux 19 | import SLIC.SyntaxFL 20 | import SLIC.Types 21 | 22 | -- * Module dependencies 23 | 24 | -- | A module graph node is a module importing other modules. 25 | type MGNodes = Map MName [MName] 26 | 27 | -- | Given a module, generates the full graph of all imported modules. 28 | createMGraph :: (MNameF, [IDecl]) -> IO MGNodes 29 | createMGraph ((mn, file), imports) = 30 | do let imods = filterRealMods imports 31 | readMGraphForL (mn, pathOf file) imods (singleton mn imods) 32 | 33 | -- | For a given module/file, read the interface of some other module and 34 | -- proceed recursively to the modules imported there. In the end, return 35 | -- the list of all visited modules. The last argument is the accumulator 36 | -- of the visited modules. 37 | readMGraphFor :: (MName, FPath) -> MName -> MGNodes -> IO MGNodes 38 | readMGraphFor si@(startM, fPath) m visited = 39 | if m==startM then 40 | error $ "Cyclic dependency found while following the imports of module "++m 41 | else 42 | do dfi <- parseDFI $ dfiFor fPath m 43 | let (_, ms) = dfiMInfo dfi 44 | readMGraphForL si (ms \\ (keys visited)) (Data.Map.insert m ms visited) 45 | 46 | -- | Version of 'readMGraphFor' for module lists. 47 | readMGraphForL :: (MName, FPath) -> [MName] -> MGNodes -> IO MGNodes 48 | readMGraphForL _ [] visited = return visited 49 | readMGraphForL si (m:ms) visited = 50 | if m `member` visited then 51 | readMGraphForL si ms visited 52 | else 53 | do visited1 <- readMGraphFor si m visited 54 | visited2 <- readMGraphForL si ms visited1 55 | return $ union visited1 visited2 56 | 57 | findCompOrder :: [ModFPre] -> IO [MName] 58 | findCompOrder modsFL = 59 | let getMName (AcyclicSCC mn) = mn 60 | getMName (CyclicSCC mns) = 61 | error $ "Modules form cycle: "++(showList mns "") 62 | in do mGraphs <- mapM createMGraph $ 63 | map (\(m, _)->(modNameF m, modImports m)) modsFL 64 | let mGraph = Data.Map.toList $ Data.Map.unions mGraphs 65 | let topolSorted = stronglyConnComp $ map (\(m, ms)->(m, m, ms)) mGraph 66 | return $ map getMName topolSorted 67 | 68 | type ModFPre = (ModF, [TcInstF]) 69 | 70 | -- | Analyzes the dependencies needed to build a set of modules. Returns the 71 | -- modules in the order that they should be built, together with the full 72 | -- module list (which may contain names of external modules) in topologically 73 | -- sorted order. 74 | rearrangeMods :: Bool -> [ModFPre] -> IO ([ModFPre], [MName]) 75 | rearrangeMods showMsg modsFL = 76 | let modTable = fromList $ map (\modFL->((fst.modNameF.fst) modFL, modFL)) modsFL 77 | in do mNames <- findCompOrder modsFL 78 | (if showMsg then 79 | putStrLn $ "Module graph: "++(showStrings ", " mNames "") 80 | else 81 | return ()) 82 | return (mapMaybe (`Data.Map.lookup` modTable) mNames, mNames) 83 | 84 | -- * Compilation manager 85 | 86 | -- | Processes each parsed input module: it prepares it using 'prepareFL', then 87 | -- it feeds it to the driver ("SLIC.Driver") and finally uses the generated 88 | -- DFI to continue (if more than one files were given). 89 | contProcFL :: Options -> FPath -> [ModFPre] -> [DFI] -> IO () 90 | contProcFL opts path (modF:modsF) dfis = 91 | do modF' <- prepareFL (optVerbose opts) path dfis modF 92 | mDfi <- processFL opts dfis modF' 93 | case mDfi of 94 | Just dfi -> contProcFL opts path modsF (dfi:dfis) 95 | Nothing -> return () 96 | contProcFL _ _ [] _ = return () 97 | 98 | -- | Prepares FL modules after parsing: reads interface files to fill in 99 | -- imported symbol information, does name qualification and adds the 100 | -- type class instance methods as top-level definitions. 101 | prepareFL :: Bool -> FPath -> [DFI] -> ModFPre -> IO ModF 102 | prepareFL verb path dfis (modF, tcInsts) = 103 | let mThis = modNameF modF 104 | imports = modImports modF 105 | in do -- read interface files to update imported symbol information 106 | imports' <- updExtTypes verb mThis path dfis imports 107 | let modFI = modF{modImports=imports'} 108 | -- qualify all names 109 | let (modFQ, tcInstsQ) = qual (modFI, tcInsts) 110 | -- add the type class instance methods defined in the code 111 | let modFTcI = addTcInsts tcInstsQ modFQ 112 | return modFTcI 113 | 114 | -- | Read referenced interfaces to type the imported functions and find the 115 | -- imported names information. 116 | updExtTypes :: Verb -> MNameF -> FPath -> [DFI] -> [IDecl] -> 117 | IO [IDecl] 118 | updExtTypes _ _ _ _ [] = return [] 119 | updExtTypes v mThis fPath dfis idecl = updExtTypesDFI v mThis fPath dfis idecl 120 | -------------------------------------------------------------------------------- /SLIC/Constants.hs: -------------------------------------------------------------------------------- 1 | -- | Constants used in the implementation. 2 | 3 | module SLIC.Constants where 4 | 5 | -- * Pretty printing 6 | 7 | -- | Enable comments when pretty printing. 8 | comments :: Bool ; comments = False 9 | 10 | nl :: ShowS ; nl = ("\n"++) 11 | space :: ShowS ; space = (" "++) 12 | tab :: ShowS ; tab = (" "++) ; -- ^ Tabs are two spaces. 13 | dquot :: ShowS ; dquot = ("\""++) 14 | comma :: ShowS ; comma = (","++) 15 | semi :: ShowS ; semi = (";"++) 16 | colon :: ShowS ; colon = (":"++) 17 | lbracket :: ShowS ; lbracket = ("{"++) 18 | rbracket :: ShowS ; rbracket = ("}"++) 19 | lparen :: ShowS ; lparen = ("("++) 20 | rparen :: ShowS ; rparen = (")"++) 21 | lcurl :: ShowS ; lcurl = ("{"++) 22 | rcurl :: ShowS ; rcurl = ("}"++) 23 | langle :: ShowS ; langle = ("<"++) 24 | rangle :: ShowS ; rangle = (">"++) 25 | hyph :: ShowS ; hyph = ("-"++) 26 | plus :: ShowS ; plus = ("+"++) 27 | times :: ShowS ; times = ("*"++) 28 | uscore :: ShowS ; uscore = ("_"++) 29 | lcomment :: ShowS ; lcomment = lcurl.hyph 30 | rcomment :: ShowS ; rcomment = hyph.rcurl 31 | 32 | -- * Defunctionalization 33 | 34 | -- | The delimiter character used for unique names during defunctionalization. 35 | delim :: Char 36 | delim = '_' 37 | 38 | -- | The delimiter between the types of a constructor's fields. Used 39 | -- by defunctionalization, for the serialization of closure types. 40 | dfTypDelim :: Char 41 | dfTypDelim = '$' 42 | 43 | -- | The name of the mini-interpreter. 44 | dfApply :: String 45 | dfApply = "apply" 46 | 47 | -- | The prefix of the /apply()/ interpreter functions of defunctionalization. 48 | -- Should not appear as a prefix of functions in the input program. 49 | applPref :: String 50 | applPref = dfApply++[delim] 51 | 52 | -- | The suffix of the defunctionalization interface files. 53 | dfiSuffix :: String 54 | dfiSuffix = ".dfi" 55 | 56 | -- | The suffix of the intensional interface files. 57 | iiSuffix :: String 58 | iiSuffix = ".ii" 59 | 60 | -- | The prefix of the closure formal variable in the defunctionalization dispatchers. 61 | dfClosurePre :: String 62 | dfClosurePre = "cl"++[delim] 63 | 64 | -- | The name of the pseudo-module, where defunctionalization places its 65 | -- generated code. 66 | dfMod :: String 67 | dfMod = "LibDef" 68 | 69 | -- * TTD back-end 70 | 71 | -- | The default number of workers to use for concurrent message dispatch and 72 | -- join operations. 73 | defaultWorkers :: Int 74 | defaultWorkers = 10 75 | 76 | -- * LAR/C constants 77 | 78 | -- | The default maximum memory size (in bytes). 79 | defaultMemSize :: Int 80 | defaultMemSize = 120*1000*1000 81 | 82 | -- | Names that clash with the C reserved words in the LAR back-end. 83 | cReservedWords :: [String] 84 | cReservedWords = 85 | [ "and", "and_eq", "asm", "auto", "bitand", "bitor", "bool", "break", "case" 86 | , "catch", "char", "class", "compl", "const", "const_cast", "continue" 87 | , "default", "delete", "do", "double", "dynamic_cast", "else", "enum" 88 | , "explicit", "export", "extern", "false", "float", "for", "friend", "goto" 89 | , "if", "inline", "int", "long", "mutable", "namespace", "new", "not", "not_eq" 90 | , "operator", "or", "or_eq", "private", "protected", "public", "register" 91 | , "reinterpret_cast", "return", "short", "signed", "sizeof", "static" 92 | , "static_cast", "struct", "switch", "template", "this", "throw", "true", "try" 93 | , "typedef", "typeid", "typename", "union", "unsigned", "using", "virtual" 94 | , "void", "volatile", "wchar_t", "whie", "xor", "xor_eq" ] 95 | 96 | -- | The number of the maximum LARs that can be nested under another LAR. 97 | -- The value corresponds to the 'unsigned char' of the implementation. 98 | maxNestedLARs :: Int 99 | maxNestedLARs = 255 100 | 101 | -- | Maximum LAR arity. The value corresponds to the 'unsigned char' of the 102 | -- implementation. 103 | maxLARArity :: Int 104 | maxLARArity = 255 105 | 106 | -- * Distributed eduction 107 | 108 | -- | The default number of warehouse to use for distributed eduction. 109 | defaultWhs :: Int 110 | defaultWhs = 10 111 | 112 | -- | The default maximum number of contexts per warehouse in distributed eduction. 113 | defaultMaxCtxts :: Int 114 | defaultMaxCtxts = 500000 115 | 116 | -- * Misc. constants 117 | 118 | -- | The name of the default module, if no name is given. 119 | defaultMod :: String 120 | defaultMod = "Main" 121 | 122 | -- | The name of the built-in pseudo-module. 123 | bModN :: String 124 | bModN = "GIC" 125 | 126 | -- | The name of the built-in pseudo-module ('Maybe' version). 127 | bMod :: Maybe String 128 | bMod = Just bModN 129 | 130 | -- | The name of the built-in \"Control.Parallel\" module. 131 | mControlParallelN :: String 132 | mControlParallelN = "Control.Parallel" 133 | 134 | -- | The name of the built-in \"Control.Parallel\" module ('Maybe' version). 135 | mControlParallel :: Maybe String 136 | mControlParallel = Just mControlParallelN 137 | 138 | -- | The type classes pseudo-module that contains method dispatchers. 139 | tcMod :: String 140 | tcMod = "$Typeclasses$" 141 | 142 | -- | The default working path. 143 | defaultPath :: String 144 | defaultPath = "." 145 | 146 | -- | The directories separator. Depends on the OS. 147 | dirSeparator :: Char 148 | dirSeparator = '/' 149 | 150 | -- | The \"path\" for dynamically generated modules. 151 | modNoPath :: String 152 | modNoPath = "" 153 | 154 | -- | The \"module\" that all code belongs to when compiled in whole-program mode. 155 | wpMod :: String 156 | wpMod = "" 157 | 158 | -- | The default maximum warehouse size. 159 | defaultMaxWHSize :: Int 160 | defaultMaxWHSize = 20000 161 | 162 | -- | The maximum size of the explicit stack (in machine words). 163 | defaultEStackSize :: Int 164 | defaultEStackSize = 5000000 165 | -------------------------------------------------------------------------------- /SLIC/Distr/EvalErl.hs: -------------------------------------------------------------------------------- 1 | -- | Distributed back-end, prototype Erlang interpreter. 2 | -- 3 | -- This is the Erlang representation generator for use 4 | -- with the 'erlang/par_eduction.erl' interpreter. 5 | -- To use it, see the 'eval_erl.sh' script. 6 | -- 7 | -- The execution model of distributed eduction is described in: 8 | -- /G. Fourtounis, P. C. Olveczky, N. Papaspyrou. Formally Specifying / 9 | -- /and Analyzing a Parallel Virtual Machine for Lazy Functional Languages / 10 | -- /Using Maude. In Proc. of the Fifth International Workshop on High-level / 11 | -- /Parallel Programming and Applications, 2011./ 12 | -- 13 | -- This interpreter supports only first-order programs without data types. 14 | -- 15 | 16 | module SLIC.Distr.EvalErl (makeErlRepr) where 17 | 18 | import Data.List (intercalate) 19 | import SLIC.AuxFun 20 | import SLIC.ITrans.Syntax 21 | import SLIC.SyntaxAux 22 | import SLIC.Types 23 | 24 | -- | Produces the Erlang representation of a ZOIL program. 25 | makeErlRepr :: MName -> ProgZ -> String 26 | makeErlRepr m (Prog _ defs) = 27 | let defsZ = filter isDefZ defs 28 | actualsZ = filter (not.isDefZ) defs 29 | defsErl = intercalate ";\n" 30 | ((map makeErlDef defsZ)++(makeErlActuals actualsZ)) 31 | in "-module(main).\n" ++ 32 | "-export([init/0, run/6]).\n\n" ++ 33 | "p(Id) -> case Id of\n" ++ defsErl ++ "\nend.\n" ++ 34 | makeErlR m 35 | 36 | -- | Produces the Erlang representation for a ZOIL definition. 37 | makeErlDef :: DefZ -> String 38 | makeErlDef (DefZ v e) = 39 | "\'"++(qName v)++"\' -> {def, "++(makeErlE e)++"}" 40 | makeErlDef (ActualsZ {}) = 41 | ierr "makeErlDef was called for actuals()" 42 | 43 | makeErlActuals :: [DefZ] -> [String] 44 | makeErlActuals actualsZ = 45 | let actNames = map defVarZ actualsZ 46 | filtAct _ (DefZ _ _) = ierr "filtAct was called for function definition" 47 | filtAct a (ActualsZ v _ _) = v==a 48 | actGroups = map (\a -> (a, filter (filtAct a) actualsZ)) actNames 49 | makeAct (v, acts) = 50 | let aux (ActualsZ _ m el) = 51 | let el' = map makeErlE el 52 | mEl = intercalate ", " el' 53 | in "'"++m++"' -> ["++mEl++"]" 54 | aux (DefZ _ _) = ierr "makeErlActuals found function definition" 55 | in "\'"++(qName v)++"' -> fun (Module) -> case Module of "++ 56 | (intercalate "; " $ map aux acts)++" end end" 57 | in map makeAct actGroups 58 | 59 | {- 60 | -- | Prepends a ''c'' to constructor names to make them Erlang atoms. 61 | makeErlConstr :: CstrName -> String 62 | makeErlConstr cName = "c"++cName 63 | -} 64 | 65 | makeErlVar :: QName -> String 66 | makeErlVar v = "{id, '"++(qName v)++"'}" 67 | 68 | -- | Produces the Erlang representation for a ZOIL expression. 69 | makeErlE :: ExprZ -> String 70 | makeErlE (CaseZ {}) = 71 | error "Pattern matching clauses are not supported yet in the Erlang interpreter" 72 | {- 73 | let erlE = makeErlE e 74 | makeErlPat (PatZ c' e') = "("++(makeErlConstr c')++") -> "++(makeErlE e') 75 | patsE = concat (intersperse "; " (map makeErlPat pats)) 76 | in "{match, "++(show d)++", "++erlE++", fun "++patsE++" end}" 77 | -} 78 | makeErlE (ConstrZ _) = 79 | error "Thunks are not supported yet in the Erlang interpreter" 80 | -- "{thunk, '"++(makeErlConstr c)++"'}" 81 | makeErlE (XZ (V v)) = makeErlVar v 82 | makeErlE (XZ (BV _ _)) = 83 | error "Bound variables are not supported yet in the Erlang interpreter" 84 | -- "{bid, '"++bv++"', "++(show d)++"}" 85 | makeErlE (FZ NOp v _) = makeErlVar v 86 | makeErlE (FZ (Call m) v _) = "{call, "++(makeErlIdx m)++", "++(makeErlVar v)++"}" 87 | -- all builtins with two arguments are strict 88 | makeErlE (ConZ (CN bOp) [e1, e2]) = 89 | "{'"++(pprint bOp "")++"', "++(makeErlE e1)++", "++(makeErlE e2)++"}" 90 | makeErlE (ConZ (CN CTrue) []) = "{val, 1}" 91 | makeErlE (ConZ (CN CFalse) []) = "{val, 0}" 92 | -- numbers 93 | makeErlE (ConZ (LitInt val) []) = "{val, "++(show val)++"}" 94 | -- the "if" clause 95 | makeErlE (ConZ (CN CIf) [e0, e1, e2]) = 96 | "{iff, "++(makeErlE e0)++", "++(makeErlE e1)++", "++(makeErlE e2)++"}" 97 | makeErlE e = ierr ("Erlang back-end -- missing case: "++(pprint e "")) 98 | 99 | makeErlIdx :: IIndex -> String 100 | makeErlIdx (m, i) = "{'"++m++"', "++(show i)++"}" 101 | 102 | -- | Generates the function that returns the 'result' definition name. 103 | makeErlR :: MName -> String 104 | makeErlR m = "resultName() -> '"++(qName $ mainDefQName m)++"' .\n" 105 | -------------------------------------------------------------------------------- /SLIC/Front/CAF.hs: -------------------------------------------------------------------------------- 1 | -- | A simple analysis that finds constant applicative forms (CAFs) and 2 | -- assigns them indices in a special LAR to be used for memoization. 3 | -- 4 | -- For more information about CAFs, check 5 | -- . 6 | -- 7 | 8 | module SLIC.Front.CAF (nmsids2nms, getCAFid, getCAFDcts) where 9 | 10 | import SLIC.SyntaxAux 11 | import SLIC.SyntaxFL 12 | import SLIC.Types 13 | 14 | -- | Gets the name of a defined function, if it is a CAF. 15 | -- Constructor functions are not considered CAFs (even if nullary). 16 | nmifCAF :: DefF -> Maybe QName 17 | nmifCAF (DefF _ [] (ConstrF _ _)) = Nothing 18 | nmifCAF (DefF vn [] _) = Just vn 19 | nmifCAF _ = Nothing 20 | 21 | -- | Returns a dictionary of the CAFs found in an FL module. 22 | getCAFDcts :: ModF -> CAFDct 23 | getCAFDcts m = 24 | let Prog _ defs = modProg m 25 | addSomething (Just x) l = x:l 26 | addSomething Nothing l = l 27 | in nms2nmsids $ foldr addSomething [] (map nmifCAF defs) 28 | 29 | -- | Takes a list of names (names of CAFs) and returns a 30 | -- list of name-id pairs. Ids are unique numbers that 31 | -- are used as indices of CAFs in a global LAR. 32 | nms2nmsids :: [QName] -> CAFDct 33 | nms2nmsids vnl = 34 | let f x l = if x == 0 then x:l else f (x-1) (x:l) 35 | in zip vnl (f ((length vnl)-1) []) 36 | 37 | -- | Takes a CAF name and returns its id. 38 | getCAFid :: QName -> CAFDct -> Maybe CAFId 39 | getCAFid vn dct = lookup vn dct 40 | 41 | -- | Takes a list of name-id pairs and returns the list of names. 42 | nmsids2nms :: CAFDct -> [QName] 43 | nmsids2nms dct = map fst dct 44 | -------------------------------------------------------------------------------- /SLIC/Front/LLifter/Equations.hs: -------------------------------------------------------------------------------- 1 | module SLIC.Front.LLifter.Equations (EqE(..), EqnSys, solveEqs) where 2 | 3 | import SLIC.AuxFun (ierr) 4 | import Data.List as List 5 | import Data.Set as Set 6 | import Data.Map as Map 7 | 8 | -- | EqV wraps known values, EqU wraps unknowns to be found 9 | data EqE a b = 10 | EqV a | EqU b 11 | deriving (Eq, Ord, Read, Show) 12 | 13 | -- | The equation type 14 | type Eqn a b = (a, Set b) 15 | 16 | -- | The equation system type 17 | type EqnSys a b = Map a (Set b) 18 | 19 | -- | Get the right hand side of an equation 20 | getRhs :: Eqn a b -> [b] 21 | getRhs (_, s) = Set.elems s 22 | 23 | -- | Split the rhs of an equation in two lists: known and unknown values 24 | getRhsS :: Eqn a (EqE b c) -> ([EqE b d], [EqE e c]) 25 | getRhsS e = 26 | let mark :: ([EqE a c], [EqE d b]) -> EqE a b -> 27 | ([EqE a c], [EqE d b]) 28 | mark (eqeV, eqeU) (EqV v) = ((EqV v):eqeV, eqeU) 29 | mark (eqeV, eqeU) (EqU u) = (eqeV, (EqU u):eqeU) 30 | l = getRhs e 31 | in List.foldl mark ([], []) l 32 | 33 | -- | Take an equation `eqn' and an equation system in which *all unknowns 34 | -- of `eqn' are defined* and substitute the rhs of every equation in the 35 | -- system for their lhs-s in the rhs of `eqn'. 36 | -- 37 | -- All unknowns appearing in `eqn' but not defined in the equation 38 | -- system are considered to have an empty rhs 39 | subEqsFlLub :: Ord a => Ord b => Ord c => 40 | Eqn a (EqE b c) -> EqnSys c (EqE b c) -> Eqn a (EqE b c) 41 | subEqsFlLub eqn@(n, _) eqnSys = 42 | let (rhsK, rhsU) = getRhsS eqn 43 | unwrapU :: EqE j c -> c 44 | unwrapU (EqU u) = u 45 | unwrapU (EqV _) = ierr "unwrapU: found EqV" 46 | unknowns = List.map unwrapU rhsU 47 | f rhs n' = Set.union 48 | (findWithDefault (Set.empty) n' eqnSys) 49 | rhs 50 | rhs' = List.foldl f (Set.empty) unknowns 51 | eqnSys' = Map.filterWithKey 52 | (\n' _ -> not $ List.elem n' unknowns) 53 | eqnSys 54 | in if List.null rhsU then (n, Set.fromList rhsK) 55 | else subEqsFlLub (n, Set.union rhs' (Set.fromList rhsK)) eqnSys' 56 | 57 | -- | Take an equation system and return the corresponding solved 58 | -- equation system. 59 | solveEqs :: Ord a => Ord b => 60 | EqnSys a (EqE b a) -> EqnSys a (EqE b a) 61 | solveEqs eqnSys = 62 | Map.foldWithKey 63 | (\n rhs eqnSys' -> 64 | Map.insert n (snd (subEqsFlLub (n, rhs) eqnSys)) eqnSys') 65 | Map.empty eqnSys 66 | 67 | -------------------------------------------------------------------------------- /SLIC/Front/PatternCompiler.hs: -------------------------------------------------------------------------------- 1 | -- | A pattern compiler from FL with full patterns (containing arbitrary 2 | -- expressions), to simple patterns (one head constructor and a list of 3 | -- pattern-bound formals). 4 | -- 5 | -- Currently a placeholder, see the implementation of 'patCompMatches'. 6 | -- 7 | 8 | module SLIC.Front.PatternCompiler (patComp, patCompMatches) where 9 | 10 | import SLIC.AuxFun (ierr) 11 | import SLIC.Front.Typeclass 12 | import SLIC.SyntaxAux 13 | import SLIC.SyntaxFL 14 | import SLIC.Types 15 | 16 | -- | The pattern compiler entry point. 17 | patComp :: ProgFH -> [TcInstFH] -> (ProgF, [TcInstF]) 18 | patComp (Prog dtsFL defsFH) tcInsts = 19 | let pcE :: ExprFH -> ExprF 20 | pcE (XF var) = XF var 21 | pcE (ConF c el) = ConF c (map pcE el) 22 | pcE (FF v el ci) = FF v (map pcE el) ci 23 | pcE (ConstrF c el) = ConstrF c (map pcE el) 24 | pcE (CaseF d e s pats) = 25 | if allSimple pats then 26 | CaseF d (pcE e) s 27 | (map (\(PatB (fP, pI) eP)->PatB (pcP fP, pI) (pcE eP)) pats) 28 | else 29 | let mkMatch (PatB (fPat, _) eP) = ([fPat], Nothing, eP) 30 | in patCompMatches [pcE e] (map mkMatch pats) 31 | pcE (LetF d defs e) = LetF d (map pcD defs) (pcE e) 32 | pcE (LamF d v e) = LamF d v (pcE e) 33 | pcD :: DefFH -> DefF 34 | pcD (DefF f fs e) = DefF f fs (pcE e) 35 | pcP :: FullPat -> SimplePat 36 | pcP (FPatC c vars) = SPat c (map (\(FPatV v)->v) vars) 37 | pcP (FPatI i) = SPat (intConstrQN i) [] 38 | pcP _ = ierr "pcP: pattern not simple" 39 | pcTcI (TcInst tcn tv methods) = TcInst tcn tv (map pcD methods) 40 | in (Prog dtsFL (map pcD defsFH), map pcTcI tcInsts) 41 | 42 | -- | Checks if all patterns are simple. 43 | allSimple :: [PatFH] -> Bool 44 | allSimple pats = 45 | let isSimple (FPatC _ ps) = all isFPV ps 46 | isSimple (FPatI _) = True 47 | isSimple _ = False 48 | in all (\(PatB (fp, _) _)->isSimple fp) pats 49 | 50 | -- | A pattern guard is just an expression (well-formedness checked by the parser). 51 | type GuardFH = ExprFH 52 | -- | A match is a list of full patterns, maybe a guard, and an expression body. 53 | type Match = ([FullPat], Maybe GuardFH, ExprFH) 54 | 55 | -- | The core function of the pattern compiler, takes a list of expression 56 | -- scrutinees, a list of matches and generates the resulting case expression. 57 | patCompMatches :: PPrint a => [ExprFL a] -> [Match] -> ExprFL a 58 | patCompMatches es _ = 59 | error $ "Found expressions that need the pattern compiler: "++(pprint es "") 60 | -------------------------------------------------------------------------------- /SLIC/ITrans/HFtoHI.hs: -------------------------------------------------------------------------------- 1 | -- | Simple translation from FL to the intermediate language HIL, used for 2 | -- the transformation. 3 | 4 | module SLIC.ITrans.HFtoHI (fromHFtoHI) where 5 | 6 | import SLIC.AuxFun (ierr) 7 | import SLIC.SyntaxFL 8 | import SLIC.ITrans.Syntax 9 | import SLIC.SyntaxAux 10 | import SLIC.Types 11 | 12 | -- | FL to HIL, expression translation. 13 | fromHFtoHIe :: ExprF -> ExprH 14 | fromHFtoHIe (XF vn) = XH vn 15 | fromHFtoHIe (ConF cn exprs) = ConH cn (map fromHFtoHIe exprs) 16 | fromHFtoHIe (FF (V vn) exprs ci) = FH NOp vn (map fromHFtoHIe exprs) ci 17 | fromHFtoHIe (ConstrF c _) = ConstrH c 18 | fromHFtoHIe app@(FF (BV _ _) _ _) = 19 | ierr $ "fromHFtoHIe: the intensional transformation cannot process higher-order bound variables, as in "++(pprint app "") 20 | fromHFtoHIe (CaseF cloc e _ pats) = 21 | let fromHFtoHIpat (PatB (SPat c bvs, _) eP) = 22 | let bvars = zip bvs (repeat cloc) 23 | in PatB (c, PatInfo (areBound bvars eP)) (fromHFtoHIe eP) 24 | in CaseH cloc (fromHFtoHIe e) (map fromHFtoHIpat pats) 25 | fromHFtoHIe (LetF {}) = ierr "let found when translating from FL to HIL" 26 | fromHFtoHIe (LamF {}) = ierr "lambda found when translating from FL to HIL" 27 | 28 | -- | FL to HIL, definition translation. 29 | fromHFtoHId :: DefF -> DefH 30 | fromHFtoHId (DefF vn fs expr) = DefH vn (frmsToNames fs) (fromHFtoHIe expr) 31 | 32 | -- | FL to HIL, program translation. 33 | fromHFtoHIp :: ProgF -> ProgH 34 | fromHFtoHIp (Prog ds defs) = Prog ds (map fromHFtoHId defs) 35 | 36 | -- | FL to HIL, module translation. 37 | fromHFtoHI :: ModF -> ModH 38 | fromHFtoHI m = m{modProg=(fromHFtoHIp $ modProg m)} 39 | -------------------------------------------------------------------------------- /SLIC/ITrans/HItoZI.hs: -------------------------------------------------------------------------------- 1 | -- | Translates the HIL intermediate language to the zero-order intensional 2 | -- language (ZOIL). 3 | -- 4 | -- Used in the Yaghi-style intensional transformation. 5 | 6 | module SLIC.ITrans.HItoZI (fromHItoZI) where 7 | 8 | import SLIC.ITrans.Syntax 9 | import SLIC.SyntaxAux 10 | import SLIC.Types 11 | 12 | -- | HIL -> ZOIL, program translation. 13 | fromHItoZIp :: ProgH -> ProgZ 14 | fromHItoZIp (Prog ds defs) = 15 | let fromHItoZId (DefH vn _ expr) = DefZ vn (fromHItoZIe expr) 16 | fromHItoZId (ActualsH vn m exprs) = 17 | ActualsZ vn m (map fromHItoZIe exprs) 18 | fromHItoZIe (XH v) = XZ v 19 | fromHItoZIe (ConH cn exprs) = ConZ cn (map fromHItoZIe exprs) 20 | fromHItoZIe (FH NOp vn [] _) = XZ (V vn) 21 | fromHItoZIe (ConstrH c) = ConstrZ c 22 | fromHItoZIe (FH qOp vn exprs ci) 23 | | vn == constV = 24 | let [XH (V qn)] = exprs 25 | in FZ qOp qn ci 26 | | otherwise = FZ qOp vn ci 27 | fromHItoZIe (CaseH d e pats) = 28 | let pats' = map fromHItoZIpat pats 29 | in CaseZ d (fromHItoZIe e) pats' 30 | fromHItoZIpat (PatB c e) = PatB c (fromHItoZIe e) 31 | in Prog ds (map fromHItoZId defs) 32 | 33 | -- | HIL -> ZOIL, module translation. 34 | fromHItoZI :: ModH -> ModZ 35 | fromHItoZI m = m{modProg=(fromHItoZIp $ modProg m)} 36 | -------------------------------------------------------------------------------- /SLIC/ITrans/ZLinker.hs: -------------------------------------------------------------------------------- 1 | -- | The linker for the 0-order language of the intensional transformation. 2 | -- 3 | -- Some functions take a single DFI; this is the result of merging all 4 | -- input module DFIs using "DFI.mergeDFIs". 5 | -- 6 | 7 | module SLIC.ITrans.ZLinker (mergeAndLinkZ) where 8 | 9 | import Data.Map (lookup) 10 | import SLIC.Front.Defunc (DfFlags, genDfModFinal) 11 | import SLIC.DFI (DFI) 12 | import SLIC.ITrans.ITrans (itransM) 13 | import SLIC.ITrans.HFtoHI (fromHFtoHI) 14 | import SLIC.ITrans.HItoZI (fromHItoZI) 15 | import SLIC.ITrans.Syntax (ModZ, ProgZ, DefZ(DefZ), ExprZ(ConstrZ)) 16 | import SLIC.SyntaxAux 17 | import SLIC.Types 18 | 19 | -- | Merges together a number of 0-order modules, adding the required closure 20 | -- constructor and dispatching functions. 21 | mergeAndLinkZ :: DfFlags -> DFI -> [ModZ] -> ProgZ 22 | mergeAndLinkZ flags@(_, str, _, _, _) dfi mods = 23 | concatProgs [concatCode mods, genDfCodeZ flags dfi, bProgZ str] 24 | 25 | -- | Generates the 0-order module needed for linking defunctionalized modules. 26 | -- Also generates the signatures table of the module. 27 | genDfModZ :: DfFlags -> DFI -> ModZ 28 | genDfModZ flags dfi = 29 | let (dfModFL, _) = genDfModFinal flags dfi 30 | in fromHItoZI $ itransM $ fromHFtoHI dfModFL 31 | 32 | -- | Generates the 0-order code needed for linking defunctionalized modules. 33 | genDfCodeZ :: DfFlags -> DFI -> ProgZ 34 | genDfCodeZ flags dfi = modProg $ genDfModZ flags dfi 35 | 36 | -- | The built-in data types and constructors. 37 | bProgZ :: Strictness -> ProgZ 38 | bProgZ s = 39 | let Just (t_cons_0, _) = Data.Map.lookup bf_cons_0 builtinTEnv 40 | Just (t_cons_1, _) = Data.Map.lookup bf_cons_1 builtinTEnv 41 | eo = defaultEvOrder s 42 | in Prog [ Data dtList [v_a] 43 | [ DConstr bf_Cons 44 | [DT t_cons_0 eo Nothing, DT t_cons_1 eo Nothing] Nothing 45 | , DConstr bf_Nil [] Nothing ] 46 | , Data dtUnit [] [ DConstr bf_Unit [] Nothing ] 47 | ] 48 | [ DefZ bf_Cons (ConstrZ bf_Cons) 49 | , DefZ bf_Nil (ConstrZ bf_Nil ) 50 | , DefZ bf_Unit (ConstrZ bf_Unit) 51 | ] -------------------------------------------------------------------------------- /SLIC/LAR/LARAux.hs: -------------------------------------------------------------------------------- 1 | -- | Helper definitions for the LAR back-end. 2 | 3 | module SLIC.LAR.LARAux (ConfigLAR(..), enumNames, mkAct, mkCall, mkSusp, 4 | wrapIfMacro, wrapIfNotMacro, 5 | wrapIfARGTAGS, wrapIfGMP, wrapIfOMP, wrapIfGC) where 6 | 7 | import SLIC.Constants 8 | import SLIC.LAR.LARGraph 9 | import SLIC.LAR.SyntaxLAR 10 | import SLIC.State 11 | import SLIC.Types 12 | 13 | -- | The configuration needed for compilation. 14 | data ConfigLAR = 15 | ConfigLAR 16 | { getCBNVars :: CBNVars -- ^ table of call-by-name formals 17 | , getStricts :: Stricts -- ^ table of strict variables 18 | , getCIDs :: CIDs -- ^ numeric constructor id information 19 | , getArities :: Arities -- ^ table of function arities 20 | , getOptions :: Options -- ^ the user options 21 | , getPMDepths :: PMDepths -- ^ the mapping between variables 22 | -- and pattern matching depth 23 | , getCAFnmsids :: CAFDct -- ^ dictionary from CAF names to indices 24 | , getModName :: MName -- ^ the name of the module being compiled 25 | } 26 | 27 | -- | Label each argument with a number (index in the LAR). 28 | enumNames :: [QName] -> [(Int, QName)] 29 | enumNames names = zip [0..] names 30 | 31 | -- | Generates C code for an intensional operator (/ACTUAL/). 32 | mkAct :: IsActuals -> Options -> ShowS 33 | mkAct b opts = 34 | if b then 35 | ("ACTUAL;"++).nl 36 | else 37 | -- for functions, output a graphviz entry for the LAR entered, 38 | -- if graphviz trace mode is enabled 39 | logPrev opts 40 | 41 | -- | Makes a suspended value (a lazy constructor). Takes the global options, 42 | -- the compiled constructor ID, the (optional) data type tag, and a flag 43 | -- that shows if the constructor takes parameters. 44 | mkSusp :: Options -> CID -> ShowS -> Bool -> ShowS 45 | mkSusp opts cId tag hasParams = 46 | ("return (SUSP("++).shows cId.(", "++).tag. 47 | -- Keeps the context if the constructor is not nullary (or when debugging). 48 | (if hasParams || optDebug opts then 49 | (", AR_TP(T0)));"++) 50 | else (", NULL));"++)) 51 | 52 | -- | Wraps a piece of code in @\#ifdef USE_OMP ... \#else ... \#endif@. 53 | wrapIfOMP :: ShowS -> ShowS -> ShowS 54 | wrapIfOMP = wrapIfMacro "USE_OMP" 55 | 56 | -- | Wraps a piece of code in @\#ifdef HAS_GMP ... \#else ... \#endif@. 57 | wrapIfGMP :: ShowS -> ShowS -> ShowS 58 | wrapIfGMP = wrapIfMacro "HAS_GMP" 59 | 60 | -- | Wraps a piece of code in @\#ifdef ARGTAGS ... \#else ... \#endif@. 61 | wrapIfARGTAGS :: ShowS -> ShowS -> ShowS 62 | wrapIfARGTAGS = wrapIfMacro "ARGTAGS" 63 | 64 | -- | Wraps a piece of code in @\#ifdef GC ... \#else ... \#endif@. 65 | wrapIfGC :: ShowS -> ShowS -> ShowS 66 | wrapIfGC = wrapIfMacro "GC" 67 | 68 | -- | Wraps a piece of code in @\#ifdef macro ... \#else .. \#endif@. 69 | wrapIfMacro :: String -> ShowS -> ShowS -> ShowS 70 | wrapIfMacro macroName s1 s2 = 71 | ("#ifdef "++).(macroName++).nl. 72 | s1. 73 | ("#else"++).nl. 74 | s2. 75 | ("#endif /* "++).(macroName++).(" */"++).nl 76 | 77 | -- | Wraps a piece of code in @\#ifndef macro ... \#endif@. 78 | wrapIfNotMacro :: String -> ShowS -> ShowS 79 | wrapIfNotMacro macroName s = 80 | ("#ifndef "++).(macroName++).nl. 81 | s. 82 | ("#endif /* "++).(macroName++).(" */"++).nl 83 | 84 | -- | Makes a function call. If the semi-space collector is enabled, uses 85 | -- the explicit pointer stack. 86 | mkCall :: GC -> QName -> ShowS -> ShowS 87 | mkCall SemiGC v t0 = ("RETVAL("++).pprint v.("(PUSHAR("++).t0.(")))"++) 88 | mkCall LibGC v t0 = pprint v.("("++).t0.(")"++) 89 | -------------------------------------------------------------------------------- /SLIC/LAR/LARDebug.hs: -------------------------------------------------------------------------------- 1 | -- | Debugging code for the LAR back-end. 2 | 3 | module SLIC.LAR.LARDebug where 4 | 5 | import SLIC.AuxFun (foldDot) 6 | import SLIC.Constants (nl) 7 | import SLIC.LAR.LARAux (wrapIfGC) 8 | import SLIC.State (DebugFlag) 9 | import SLIC.Types 10 | 11 | debugPrologue :: String -> QName -> ShowS 12 | debugPrologue descr f = 13 | let printfHalf = ("printf(\"\\\\-> Entered "++).(descr++).(" "++).pprint f 14 | in wrapIfGC 15 | (printfHalf.("(T0 = %p -> %p)\\n\", T0, *T0);"++).nl) 16 | (printfHalf.("(T0 = %p)\\n\", T0);"++).nl) 17 | 18 | -- | Generates a debugging prologue before each function body. If the 19 | -- first argument is False, it returns an empty prologue. 20 | debugFuncPrologue :: DebugFlag -> QName -> ShowS 21 | debugFuncPrologue True f = debugPrologue "function" f 22 | debugFuncPrologue _ _ = id 23 | 24 | -- | Generates a debugging prologue before an actual. If the 25 | -- first argument is False, it returns an empty prologue. 26 | debugVarPrologue :: DebugFlag -> QName -> ShowS 27 | debugVarPrologue True v = debugPrologue "actual" v 28 | debugVarPrologue _ _ = id 29 | 30 | -- | Generate debugging information after program finishes with a value. 31 | debugMainFinish :: DebugFlag -> ShowS 32 | debugMainFinish True = 33 | wrapIfGC 34 | (("printf(\"Pointer stack [%p-%p], elements: %ld\\n\", "++). 35 | ("sstack_bottom, sstack_ptr, (sstack_ptr-sstack_bottom));"++).nl) id 36 | debugMainFinish False = id 37 | 38 | -- | Takes a list of symbols and generates a function that takes an address 39 | -- and prints out the symbol name. If the first parameter is False, returns 40 | -- a dummy function. 41 | debugPrintSymbol :: DebugFlag -> [QName] -> ShowS 42 | debugPrintSymbol True qns = 43 | let aux qn = 44 | let qS = pprint qn 45 | in ("if (sym == "++).qS.(") { printf(\""++).qS.("\"); return; };"++).nl 46 | in ("void DEBUG_printSymbol(LarArg sym) {"++).nl. 47 | foldDot aux qns. 48 | ("printf(\"\");"++).nl. 49 | ("}"++).nl 50 | debugPrintSymbol False _ = 51 | ("void DEBUG_printSymbol(LarArg sym) {"++).nl. 52 | ("printf(\"\");"++).nl. 53 | ("}"++).nl 54 | 55 | -- | Generates a debug message when a LAR for a CAF is allocated. 56 | debugCreateCAF :: DebugFlag -> ShowS -> ShowS 57 | debugCreateCAF True caf = ("printf(\"Allocating CAF "++).caf.(":\\n\");"++).nl 58 | debugCreateCAF False _ = id 59 | 60 | -- | Generates a debug message when the top-level LAR is allocated. 61 | debugCreateTopLAR :: DebugFlag -> ShowS 62 | debugCreateTopLAR True = ("printf(\"Allocating dummy top-level CAF:\\n\");"++).nl 63 | debugCreateTopLAR False = id 64 | -------------------------------------------------------------------------------- /SLIC/LAR/LARGraph.hs: -------------------------------------------------------------------------------- 1 | -- | Graphviz output mode: C code snippets that are inserted in the 2 | -- output program to log memory allocation. 3 | -- 4 | -- The resulting file can be converted to PNG from the command line as follows: 5 | -- 6 | -- @dot -Tpng graph.dot -o graph.png@ 7 | -- 8 | -- Note: for programs that allocate a lot, this may take /a lot of time/. 9 | -- 10 | 11 | module SLIC.LAR.LARGraph (logConstr, logDict, logGraphStart, logGraphEnd, 12 | logPrev) where 13 | 14 | import SLIC.Constants (nl, tab) 15 | import SLIC.State (Options(optVerbose)) 16 | import SLIC.Types (Counter, CstrName, PPrint(pprint)) 17 | 18 | -- | Logs a dictionary connection. 19 | logDict :: Options -> Counter -> ShowS 20 | logDict opts counter = 21 | if optVerbose opts then 22 | tab.("fprintf(p, \"\\\"LAR_%p\\\" -> \\\"LAR_%p\\\" [style=dashed] ; \\n\", T0, CPTR(cl["++).shows counter.("])); "++) 23 | else id 24 | 25 | -- | Logs a constructor evaluation hit. 26 | logConstr :: Options -> CstrName -> ShowS 27 | logConstr opts c = 28 | if optVerbose opts then 29 | tab.("fprintf(p, \"LAR_%p [style=dashed] [label=\\\"LAR_%p [:"++).pprint c.("]\\\"];\\n\", T0, T0);"++).nl 30 | else id 31 | 32 | -- | Opens the output file and creates its header. 33 | logGraphStart :: Options -> ShowS 34 | logGraphStart opts = 35 | if optVerbose opts then 36 | tab.("counter = 0;"++).nl. 37 | tab.("p = fopen(\"graph.dot\", \"w\");"++).nl. 38 | tab.("if (p== NULL) { printf(\"Error in opening graph file.\"); exit(-1); } ; "++).nl. 39 | tab.("printf(\"Initial LAR:%p\\n\", T0);"++).nl. 40 | tab.("fprintf(p, \"digraph G {\\n\");"++).nl. 41 | tab.("fprintf(p, \"LAR_%p [shape=house];\\n\", T0);"++).nl 42 | else id 43 | 44 | -- | Closes the graph file. 45 | logGraphEnd :: Options -> ShowS 46 | logGraphEnd opts = 47 | if optVerbose opts then 48 | tab.("fprintf(p, \"}\\n\");"++).nl. 49 | tab.("fclose(p);"++).nl 50 | else id 51 | 52 | -- | Logs a link to the parent LAR. 53 | logPrev :: Options -> ShowS 54 | logPrev opts = 55 | (if optVerbose opts then 56 | ("fprintf(p, \"\\\"LAR_%p\\\" -> \\\"LAR_%p\\\" [color=black] [label=\\\"%d\\\"] ; \\n\", T0->prev, T0, counter++); "++).nl 57 | else id) 58 | -------------------------------------------------------------------------------- /SLIC/LAR/LARLinker.hs: -------------------------------------------------------------------------------- 1 | -- | Generates the top-level C source that will link a set of modules. 2 | -- 3 | -- The modules must have already been separately compiled and their 4 | -- DFI interface files generated. 5 | -- The linker will then read the DFI information and generate the 6 | -- required closure constructors and /apply()/ dispatching functions 7 | -- needed by the defunctionalized compiled code. 8 | -- 9 | -- Some functions take a single DFI; this is the result of merging all 10 | -- input module DFIs using 'mergeDFIs' from "SLIC.DFI". 11 | -- 12 | 13 | module SLIC.LAR.LARLinker (compileWholeL, linkLAR) where 14 | 15 | import Data.List (map) 16 | import qualified Data.Map as Map (empty, fromList, insert, map, union) 17 | import Data.Set as Set (toList) 18 | 19 | import SLIC.AuxFun (foldDot, nameOf) 20 | import SLIC.Constants 21 | import SLIC.DFI 22 | import SLIC.Front.Defunc 23 | import SLIC.ITrans.HFtoHI (fromHFtoHI) 24 | import SLIC.ITrans.HItoZI (fromHItoZI) 25 | import SLIC.ITrans.ITrans (itransM) 26 | import SLIC.ITrans.Optimizations (canOptEnums, optEnumsKernel) 27 | import SLIC.LAR.ZItoLAR 28 | import SLIC.LAR.LAR 29 | import SLIC.LAR.LARAux 30 | import SLIC.LAR.LARBuiltins 31 | import SLIC.LAR.SMacrosAux 32 | import SLIC.LAR.SyntaxLAR 33 | import SLIC.State 34 | import SLIC.SyntaxAux 35 | import SLIC.Types 36 | 37 | -- | Links a given program with its missing defunctionalization code. Used 38 | -- in whole-program mode. Returns the extra usage information needed for 39 | -- later stages of compilation. Takes the merged DFI of all 40 | -- the DFIs to link. 41 | linkWithDf :: DfFlags -> DFI -> ProgL -> (ModL, ProgInfo) 42 | linkWithDf flags dfi p = 43 | let (modDF, pInfo) = genDfModLAR flags dfi 44 | in (modDF{modProg = concatProgs [p, modProg modDF]}, pInfo) 45 | 46 | -- | Generates defunctionalization's LAR module. Also returns information 47 | -- required by later stages of compilation. Takes the merged DFI of all 48 | -- the DFIs to link. 49 | genDfModLAR :: DfFlags -> DFI -> (ModL, ProgInfo) 50 | genDfModLAR flags dfi@(DFI _ _ sigs dfInfo _ _) = 51 | let dfCArities = map (\(DFC c ar _ _)->(c, ar)) $ toList $ diDfcs dfInfo 52 | (dfModuleF, progInfo@(defSigs, _, _)) = genDfModFinal flags dfi 53 | dfModuleZ = fromHItoZI $ itransM $ fromHFtoHI dfModuleF 54 | cids = Map.fromList $ map (\((a, b), c)->(a, (b, c))) $ zip dfCArities [0..] 55 | sigs' = Map.union sigs defSigs 56 | dfModuleL = fromZOILtoLAR sigs' cids dfModuleZ 57 | in (dfModuleL, progInfo) 58 | 59 | -- | Generates the C code for defunctionalization's module. Takes the 60 | -- user options and the merged defunctionalization interfaces. 61 | makeDfModC :: Options -> DFI -> ShowS 62 | makeDfModC opts dfi = 63 | let env = dfiTEnv dfi 64 | (mL, (_, (cbns, stricts), pmds)) = genDfModLAR (dfFlags opts) dfi 65 | is = modImports mL 66 | pL@(Prog dts _) = modProg mL 67 | config = ConfigLAR { getCBNVars = cbns 68 | , getStricts = stricts 69 | , getCIDs = calcCIDs dts 70 | , getArities = calcFuncArities mL 71 | , getOptions = opts{optCMode=CompileModule} 72 | , getPMDepths = pmds 73 | , getCAFnmsids = [] 74 | , getModName = dfMod 75 | } 76 | imports = mergeINames is 77 | in makeC pL env config (dfi, imports, Map.empty) 78 | 79 | -- | Generates the linking C code. 80 | makeCLinker :: Options -> [DFI] -> [MName] -> ShowS 81 | makeCLinker opts dfis modNames = 82 | let env = mergeEnvs dfis 83 | extInitMod m = ("void "++).genInitMod m.("(TP_ T0);"++).nl 84 | mainDepth = getMainDepth dfis 85 | arities = builtinArities 86 | modName = "Main$Linker" 87 | mainDef = mainDefQName "Main" 88 | pmDepths = Map.insert mainDef mainDepth builtinPmDepths 89 | cafs = [] 90 | arityCAF = length cafs 91 | larStyle = optLARStyle opts 92 | in headersC larStyle. 93 | macrosC opts modName arities pmDepths arityCAF. 94 | prologue opts modName arityCAF. 95 | (case gcFor larStyle of 96 | SemiGC -> 97 | createSemiGCARInfra modName larStyle arities pmDepths arityCAF 98 | LibGC -> 99 | mkLARMacroOpt opts (qName mainDef) 0 0 mainDepth.nl). 100 | ("extern "++).protoFunc mainDef. 101 | foldDot extInitMod modNames. -- linked module initializers 102 | declarationsBuiltins opts. 103 | mainFunc env opts mainDepth modNames. 104 | prettyPrintersC larStyle.nl. 105 | epilogue opts.nl 106 | 107 | -- | Whole program compilation: generates the defunctionalization module, 108 | -- links it with the current LAR code, and gives it to the LAR back-end. 109 | compileWholeL :: DFI -> ProgL -> ConfigLAR -> ImportedNames -> IO () 110 | compileWholeL dfi finalProgLAR config allImports = 111 | let eLAR = dfiTEnv dfi 112 | opts = getOptions config 113 | (modFinal, (fsigs', (cbns', strs'), pmdepths')) = 114 | linkWithDf (dfFlags opts) dfi finalProgLAR 115 | Prog dts blocks = modProg modFinal 116 | -- update the configuration with defunctionalization's usage information 117 | cbns = Map.union (getCBNVars config) cbns' 118 | stricts = Map.union (getStricts config) strs' 119 | pmds = Map.union (getPMDepths config) pmdepths' 120 | ars = Map.union (getArities config) (Map.map length fsigs') 121 | config' = config{getCBNVars = cbns}{getStricts = stricts}{getPMDepths=pmds}{getArities=ars} 122 | -- Do the enumeration transformation in the generated code. 123 | (dts', eLAR') = (if canOptEnums opts then optEnumsKernel else id) (dts, eLAR) 124 | finalProgLAR' = Prog dts' blocks 125 | in putOutput 126 | (makeC finalProgLAR' eLAR' config' (dfi, allImports, Map.empty) "") 127 | 128 | -- | Prints a string to a file. 129 | putOutput :: String -> IO () 130 | putOutput s = do 131 | let fName = "./main.c" 132 | putStrLn $ "Output written to " ++ fName 133 | writeFile fName s 134 | 135 | -- | Links a list of separately compiled modules using the LAR back-end. 136 | linkLAR :: [String] -> Options -> IO () 137 | linkLAR files opts = 138 | do dfis <- parseDFIs (optVerbose opts) (Data.List.map dfiFile files) 139 | -- disable verbosity, or the LAR back-end will generate code for graphviz 140 | let opts' = opts{optVerbose = False}{optCMode=Whole} 141 | -- let cMain = makeCLinker opts' (Data.Map.fromList [(mainDefName, (tInt,Just 0))]) dfis modNames "" 142 | let dfModC = makeDfModC opts (mergeDFIs dfis) "" 143 | writeFile "dfmod.c" dfModC 144 | let modNames = map nameOf files 145 | let cMain = makeCLinker opts' dfis modNames "" 146 | writeFile "main-link.c" cMain 147 | -------------------------------------------------------------------------------- /SLIC/LAR/LARTC.hs: -------------------------------------------------------------------------------- 1 | -- | Code generator for type classes. 2 | -- 3 | 4 | module SLIC.LAR.LARTC where 5 | 6 | import Data.List (intersperse) 7 | import SLIC.AuxFun (foldDot) 8 | import SLIC.Constants 9 | import SLIC.Front.Typeclass 10 | import SLIC.State 11 | import SLIC.SyntaxAux 12 | import SLIC.Tags 13 | import SLIC.Types 14 | 15 | {- 16 | builtinTCs :: Options -> ShowS 17 | builtinTCs opts = 18 | if optTag opts then 19 | mkC_builtinTcInsts "Show" 20 | else id 21 | -} 22 | 23 | -- | Generates the C name for the implementation of type class tc for dt. 24 | tcNameC :: TcName -> DTName -> ShowS 25 | tcNameC tc dt = (tc++).("_"++).pprint dt 26 | 27 | {- 28 | -- | Generates the code for all built-in implementations of a type class. 29 | mkC_builtinTcInsts :: TcName -> ShowS 30 | mkC_builtinTcInsts tcName = 31 | let nmTcInst (TcInst (tcN, dtN) _) = tcNameC tcN dtN 32 | in mkC_TcInst btc_Show_Int. 33 | ("void * tcImpl$"++).(tcName++).("[] = { "++). 34 | nmTcInst btc_Show_Int. 35 | (" };"++).nl 36 | 37 | -- | Generates the C dictionary for a type class implementation. 38 | mkC_TcInst :: TcInst -> ShowS 39 | mkC_TcInst (TcInst (tc, dt) dict) = 40 | let mkMember (_, ifun) = pprint ifun 41 | in ("void * "++).tcNameC tc dt.("[] = { "++). 42 | foldDot id (intersperse (", "++) (map mkMember dict)). 43 | (" };"++).nl 44 | -} 45 | -------------------------------------------------------------------------------- /SLIC/LAR/OptimizationsLAR.hs: -------------------------------------------------------------------------------- 1 | -- | LAR Optimizations. 2 | -- 3 | -- * Actuals inlining. 4 | 5 | module SLIC.LAR.OptimizationsLAR (inlineActs) where 6 | 7 | import SLIC.LAR.SyntaxLAR 8 | import SLIC.SyntaxAux (Mod(Mod), Prog(Prog)) 9 | 10 | -- * Inline actuals 11 | 12 | -- | Removes the actuals() operator from constant formals. 13 | inlineActs :: ModL -> ModL 14 | inlineActs (Mod m es is (Prog dts blocks) an tcs) = 15 | let inlineActsB b@(DefL {}) = b 16 | inlineActsB (ActualL v True e@(LARC _ [])) = 17 | ActualL v False e 18 | inlineActsB b@(ActualL {}) = b 19 | in Mod m es is (Prog dts (map inlineActsB blocks)) an tcs 20 | -------------------------------------------------------------------------------- /SLIC/LAR/SyntaxLAR.hs: -------------------------------------------------------------------------------- 1 | -- | The syntax of the intermediate language used by the LAR back-end. 2 | -- 3 | 4 | module SLIC.LAR.SyntaxLAR (ProgL, BlockL(..), CCstrName(..), ExprL(..), 5 | IsActuals, ModL, calcFuncArities, 6 | countPMDepthL, countPMDepthsL, getBlockName, 7 | isFun, mkCC, printLAR) where 8 | 9 | import Data.Map (empty, insert, insertWithKey) 10 | import SLIC.AuxFun (ierr, showStrings, spaces) 11 | import SLIC.Constants (nl) 12 | import SLIC.SyntaxAux 13 | import SLIC.Types 14 | 15 | -- * The LAR language 16 | 17 | -- | A LAR program. 18 | type ProgL = Prog BlockL 19 | 20 | -- | A LAR block. 21 | data BlockL = 22 | DefL QName ExprL [QName] -- ^ a function is an expression and bindings 23 | | ActualL QName IsActuals ExprL -- ^ an actual variable is an expression 24 | 25 | -- | A flag to indicate that a LAR statement is an /actuals()/. It is set to 26 | -- False by constant inlining (see "OptimizationsLAR"). 27 | type IsActuals = Bool 28 | 29 | -- | Compiled LAR constructor (accompanied by numerical ID and arity). 30 | data CCstrName = CC CstrName CID Arity 31 | 32 | -- | A LAR module. 33 | type ModL = Mod ProgL 34 | 35 | -- | Returns a compiled constructor using a CIDs table. 36 | mkCC :: CstrName -> CIDs -> CCstrName 37 | mkCC c cids = 38 | let (cArity, cId) = findArID c cids 39 | in CC c cId cArity 40 | 41 | -- | A LAR expression. 42 | data ExprL = LARCall QName [QName] CI -- ^ call variable with a LAR of variables 43 | | LARC Const [ExprL] -- ^ built-in constant application 44 | | ConstrL CCstrName -- ^ constructor call 45 | | BVL QName CaseLoc -- ^ bound variable (constructor projection) 46 | | CaseL CaseLoc ExprL [PatL] -- ^ pattern matching expression 47 | 48 | -- | A LAR pattern. 49 | type PatL = PatB CCstrName ExprL 50 | 51 | instance PPrint CCstrName where 52 | pprint (CC c cid ar) = pprintTH c.("{"++).shows cid.("}/"++).shows ar 53 | 54 | instance PPrint BlockL where 55 | pprint (DefL v e bind) = 56 | pprint v.spaces 1.showStrings " " (map qName bind).(" = "++).pprint e 57 | pprint (ActualL v act e) = 58 | pprint v.(" = "++).(if act then ("ACTUAL."++) else id).pprint e 59 | 60 | instance PPrint ExprL where 61 | pprint (LARCall v vs _) = pprint v.spaces 1.showStrings " " (map qName vs) 62 | pprint (LARC cn el) = prettyConst 0 cn el 63 | pprint (ConstrL c) = pprint c 64 | pprint (BVL v cn) = pprintBVC v cn 65 | pprint (CaseL cl@(cn, _) e pats) = 66 | let dep = tabIdxOf cn 67 | pprintPats [] = id 68 | pprintPats (pat : ps) = nl.spaces dep.pprint pat.pprintPats ps 69 | in ("case "++).pprint e.(" of{"++).pprintCaseLoc cl.("}"++).pprintPats pats 70 | 71 | -- | Pretty printer for LAR modules. The typing environment is also given. 72 | printLAR :: TEnv -> ModL -> IO () 73 | printLAR eLAR modL = 74 | putStrLn "== Environment ==" >> 75 | putStrLn (pprintE eLAR "") >> 76 | putStrLn "== Module ==" >> 77 | putStr (pprint modL "") 78 | 79 | -- | Filter for function definition blocks. 80 | isFun :: BlockL -> Bool 81 | isFun (DefL {}) = True 82 | isFun (ActualL {}) = False 83 | 84 | -- | Returns the name of a block. 85 | getBlockName :: BlockL -> QName 86 | getBlockName (DefL vnm _ _) = vnm 87 | getBlockName (ActualL vnm _ _) = vnm 88 | 89 | -- | Counts the maximum depth of nested pattern matching expressions 90 | -- in a LAR expression. 91 | countPMDepthL :: ExprL -> Int 92 | countPMDepthL (LARCall _ _ _) = 0 93 | countPMDepthL (ConstrL _) = 0 94 | countPMDepthL (BVL _ _) = 0 95 | countPMDepthL (LARC _ []) = 0 96 | countPMDepthL (LARC _ args) = maximum (map countPMDepthL args) 97 | -- addition of dict arrays, to reuse/do any better we need some analysis 98 | countPMDepthL (CaseL (cn, _) e pats) = 99 | let patE (PatB _ eP) = eP 100 | maxPatDepth [] = 0 101 | maxPatDepth ps = maximum $ map (countPMDepthL.patE) ps 102 | cDep = case cn of CLoc _ -> 1 ; CFrm _ -> 0 103 | in cDep + (countPMDepthL e) + (maxPatDepth pats) 104 | 105 | -- | Counts the maximum depths of nested pattern matching expressions 106 | -- in a LAR program, for every definition. 107 | countPMDepthsL :: ModL -> PMDepths 108 | countPMDepthsL mL = 109 | let blocks = progDefs $ modProg mL 110 | mUpd m (DefL v e _) = insert v (countPMDepthL e) m 111 | mUpd m (ActualL v _ e) = insert v (countPMDepthL e) m 112 | aux m [] = m 113 | aux m (b : bs) = aux (mUpd m b) bs 114 | in aux empty blocks 115 | 116 | -- | Calculates a table of all function arities. 117 | calcFuncArities :: ModL -> Arities 118 | calcFuncArities mL = 119 | let blocks = progDefs $ modProg mL 120 | aux m [] = m 121 | aux m ((DefL v _ vs) : bs) = 122 | aux (insertWithKey checker v (length vs) m) bs 123 | aux m ((ActualL {}) : bs) = aux m bs 124 | checker v a a' = 125 | if a==a' then a 126 | else ierr $ "Duplicate function "++(qName v)++" of different arities "++ 127 | (show a)++", "++(show a') 128 | in aux empty blocks 129 | -------------------------------------------------------------------------------- /SLIC/LAR/ZItoLAR.hs: -------------------------------------------------------------------------------- 1 | -- | Translates the zero-order intensional language (ZOIL) of the 2 | -- intensional transformation to the LAR language needed for code 3 | -- generation. 4 | -- 5 | -- During translation, constructors are paired with assigned numerical IDs 6 | -- and arity information, to be used during code generation. 7 | -- 8 | 9 | module SLIC.LAR.ZItoLAR (fromZOILtoLAR) where 10 | 11 | import SLIC.ITrans.Syntax 12 | import SLIC.LAR.SyntaxLAR 13 | import SLIC.SyntaxAux(CI(..), Mod(..), Prog(Prog), PatB(PatB)) 14 | import SLIC.Types 15 | 16 | -- | Translates ZOIL to LAR syntax. 17 | fromZOILtoLAR :: FuncSigs -> CIDs -> ModZ -> ModL 18 | fromZOILtoLAR sigs cids m = 19 | let Prog dt ds = modProg m 20 | pL = Prog dt (concatMap (mkBlocks sigs cids) ds) 21 | in m{modProg=pL} 22 | 23 | -- | Translates a 0-order definition to LAR blocks. If the definition is a 24 | -- function, it is translated to a LAR function block. If it is a list of N 25 | -- actuals, it is translated to a list of N LAR variable blocks. 26 | mkBlocks :: FuncSigs -> CIDs -> DefZ -> [BlockL] 27 | mkBlocks sigs cids (DefZ x e) = 28 | [DefL x (mkExp sigs cids e) (frmsOf x sigs)] 29 | mkBlocks sigs cids (ActualsZ qn m exps) = 30 | let aux :: (Int, ExprZ) -> BlockL 31 | aux (i, e) = 32 | let qn' = procLName (larIIndex (m, i)) qn 33 | in ActualL qn' True (mkExp sigs cids e) 34 | in map aux (zip [0..] exps) 35 | 36 | mkExp :: FuncSigs -> CIDs -> ExprZ -> ExprL 37 | mkExp _ _ (XZ (V n)) = LARCall n [] NoCI 38 | mkExp _ _ (XZ (BV n d)) = BVL n d 39 | mkExp sigs cids (ConZ c exprs) = LARC c (map (mkExp sigs cids) exprs) 40 | mkExp _ _ (FZ NOp v ci) = LARCall v [] ci 41 | mkExp sigs _ (FZ (Call idx) v ci) = 42 | let args z = [ procLName (larIIndex idx) x | x <- (frmsOf z sigs) ] 43 | ci' = case ci of 44 | Mut mut Nothing -> Mut mut (Just idx) 45 | _ -> ci 46 | in LARCall v (args v) ci' 47 | -- constructors are accompanied by their numbers and arities (for compilation) 48 | mkExp _ cids (ConstrZ c) = 49 | ConstrL (mkCC c cids) 50 | mkExp sigs cids (CaseZ d e ps) = 51 | let mkPat (PatB (cP, pI) eP) = PatB (mkCC cP cids, pI) (mkExp sigs cids eP) 52 | in CaseL d (mkExp sigs cids e) (map mkPat ps) 53 | 54 | -- | Translates an intensional index of a variable to a name suitable for C. 55 | larIIndex :: IIndex -> SName -> String 56 | larIIndex (m, i) sn = sn++"__"++m++"_"++(show i) 57 | -------------------------------------------------------------------------------- /SLIC/Maude/ZItoMaude.hs: -------------------------------------------------------------------------------- 1 | -- | The Maude back-end. 2 | -- 3 | -- Translates ZOIL (without data types and modules) to Maude. The resulting 4 | -- Maude term can be subject to concurrent term rewriting. 5 | -- 6 | -- The translation is described in: 7 | -- /G. Fourtounis, P. C. Ölveczky, N. Papaspyrou. Formally Specifying / 8 | -- /and Analyzing a Parallel Virtual Machine for Lazy Functional Languages / 9 | -- /Using Maude. In Proc. of the Fifth International Workshop on High-level / 10 | -- /Parallel Programming and Applications, 2011./ 11 | -- 12 | 13 | module SLIC.Maude.ZItoMaude (callMaudeBackend) where 14 | 15 | import Data.List (intercalate) 16 | import SLIC.AuxFun (ierr) 17 | import SLIC.ITrans.Syntax 18 | import SLIC.State 19 | import SLIC.SyntaxAux 20 | import SLIC.Types 21 | 22 | -- | Generates the Maude term for a ZOIL program. 23 | makeMaude :: ProgZ -> Int -> String 24 | makeMaude (Prog _ defs) numWarehouses = 25 | let defsMaude = concatMap makeMaudeDef defs 26 | whouse j = "whouse(" ++ (show j) ++ ") " 27 | whouseNames = (concatMap whouse [0..(numWarehouses-1)]) ++ " none" 28 | warehouse j = "< "++ (whouse j) ++ ": WHouse | slots : none, pend : none >\n" 29 | warehouses = concatMap warehouse [0..(numWarehouses-1)] 30 | in "(omod TESTS is\n" ++ 31 | " protecting EXECUTION .\n" ++ 32 | " op defs : -> List{Def} .\n" ++ 33 | " eq defs = " ++ defsMaude ++ " .\n\n" ++ 34 | " op user : -> Oid .\n" ++ 35 | " op init : -> Configuration .\n" ++ 36 | " eq init = \n" ++ 37 | " < root : Node | expr : < $ \""++(qName $ mainDefQName "Main")++"\" ; snil >, status : running, wp : none, whs : " ++ whouseNames ++ 38 | ", prog : defs >\n " ++ warehouses ++ " .\n\n" ++ 39 | " eq choose(ID:String, CTXT:Stack, WHS:Oids) = whouse(sz(CTXT:Stack) rem "++ (show numWarehouses) ++ ") .\n" ++ 40 | "endom)\n\n" ++ 41 | "(frew in TESTS : init .)\n" 42 | 43 | -- | Generates the Maude term for a ZOIL definition. 44 | makeMaudeDef :: DefZ -> String 45 | makeMaudeDef (DefZ v e) = "def(\""++(qName v)++"\", "++(makeMaudeE e)++")\n" 46 | makeMaudeDef (ActualsZ _ _ []) = "" 47 | makeMaudeDef (ActualsZ v _ el) = 48 | let el' = map (\x -> "("++(makeMaudeE x)++")") el 49 | mEl = intercalate " : " el' 50 | in "def(\""++(qName v)++"\", actuals("++mEl++"))\n" 51 | 52 | makeMaudeVar :: QName -> String 53 | makeMaudeVar v = "$ \""++(qName v)++"\"" 54 | 55 | -- | Generates the Maude term for a ZOIL expression. 56 | makeMaudeE :: ExprZ -> String 57 | makeMaudeE (CaseZ {}) = error "Maude backend doesn't support pattern matching" 58 | makeMaudeE (ConstrZ _) = error "Maude backend doesn't support thunks" 59 | makeMaudeE (XZ (V v)) = makeMaudeVar v 60 | makeMaudeE (XZ (BV _ _)) = error "Maude backend doesn't support bound variables" 61 | makeMaudeE (FZ NOp v _) = makeMaudeVar v 62 | makeMaudeE (FZ (Call (_, i)) v _) = "call("++(show i)++", "++(makeMaudeVar v)++")" 63 | -- all builtins with two arguments are strict 64 | makeMaudeE (ConZ (CN bOp) [e1, e2]) = 65 | let m1 = makeMaudeE e1 66 | m2 = makeMaudeE e2 67 | in "cOp(\""++(pprint bOp "")++"\", ("++m1++") : ("++m2++"))" 68 | -- if-then-else 69 | makeMaudeE (ConZ (CN CIf) [e0, e1, e2]) = 70 | let m0 = makeMaudeE e0 71 | m1 = makeMaudeE e1 72 | m2 = makeMaudeE e2 73 | in "cOp(\"if\", ("++m0++") : ("++m1++") : ("++m2++"))" 74 | -- numbers 75 | makeMaudeE (ConZ (LitInt val) []) = "# "++(show val) 76 | makeMaudeE e = 77 | error $ "Found unknown expression to translate into Maude: "++(pprint e "") 78 | 79 | callMaudeBackend :: ProgZ -> Options -> IO () 80 | callMaudeBackend p options = 81 | case optAction options of 82 | ACompileMaude -> putStrLn $ makeMaude p $ optWhNum options 83 | a -> ierr $ "The Maude back-end cannot handle action "++(show a) 84 | -------------------------------------------------------------------------------- /SLIC/TTD/SyntaxTTD.hs: -------------------------------------------------------------------------------- 1 | -- | The language of the Tagged-Token Dataflow back-end. 2 | -- 3 | -- The TTD back-end compiles the intensional program to a dataflow graph. 4 | -- The execution model follows closely the ideas of tagged-token dataflow 5 | -- architectures (where contexts are tags), aided by a distributed warehouse 6 | -- to do value memoization. 7 | -- 8 | -- The intensional program is broken down to dataflow instructions. No nesting 9 | -- is allowed; for example, a 0-order expression that has two subexpressions 10 | -- will be represented as three intructions, with the first depending on the 11 | -- other two. 12 | -- 13 | -- An instruction is a node in the dataflow graph and is connected to other 14 | -- instructions. If an instruction depends on N other instructions and M other 15 | -- instructions depend on it, it has N+1 ports: N ports for the dependencies 16 | -- and one \"firing\" port multiplexing input from the M dependent instructions. 17 | -- 18 | 19 | module SLIC.TTD.SyntaxTTD where 20 | 21 | import Data.List (elemIndex) 22 | import Data.Map (Map, fromList) 23 | import SLIC.AuxFun (foldDot, ierr, insCommIfMore) 24 | import SLIC.Constants (nl, tab) 25 | import SLIC.ITrans.Syntax (QOp) 26 | import SLIC.SyntaxAux 27 | import SLIC.Types 28 | 29 | -- * The TTD language 30 | 31 | -- | The unique identifier characterizing every instruction. 32 | type InstrID = Int 33 | 34 | -- | The actual values of formals in all program locations. 35 | type Acts = [(IIndex, InstrID)] 36 | 37 | -- | A dataflow instruction. 38 | data InstrT = CallT QOp InstrID -- ^ call instruction with intensional index 39 | | VarT InstrID -- ^ call instruction using current context 40 | | BVarT InstrID CaseLoc -- ^ call instruction using nested context 41 | | ActualsT Acts -- ^ intensional /actuals/ operator 42 | | ConT Const [InstrID] -- ^ built-in operator (including values) 43 | | CaseT CaseLoc InstrID [PatT] -- ^ pattern matching expression 44 | | ConstrT CstrName -- ^ constructor 45 | 46 | -- | A pattern branch contains a constructor and an instruction dependency. 47 | data PatT = PatT CstrName InstrID 48 | 49 | -- | An instruction entry is an instruction labelled by an ID. 50 | type IEntry = (InstrID, InstrT) 51 | 52 | -- | A dataflow program is a list of instruction entries. 53 | data ProgT = ProgT [IEntry] 54 | 55 | instance PPrint ProgT where 56 | pprint (ProgT entries) = 57 | foldDot (\(nID, instrT)->shows nID.(" | "++).pprint instrT.nl) entries 58 | 59 | instance PPrint InstrT where 60 | pprint (CallT qOp iID) = pprint qOp.pprintInstrPtr iID 61 | pprint (VarT iID) = ("var"++).pprintInstrPtr iID 62 | pprint (BVarT iID (CLoc (Just (c, _)), _)) = 63 | ("bvar"++).pprintInstrPtr iID.("{"++).shows c.("}"++) 64 | pprint (ActualsT acts) = 65 | let aux (iidx, iID) = ("({"++).pprintIdx iidx.("}: "++). 66 | pprintInstrPtr iID.(")"++).nl 67 | in ("actuals:"++).nl.foldDot aux acts 68 | pprint (ConT (LitInt i) []) = shows i 69 | pprint (ConT (CN c) iIDs) = 70 | ("["++).pprint c.("]("++).insCommIfMore (map pprintInstrPtr iIDs).(")"++) 71 | pprint (ConstrT c) = pprintTH c 72 | pprint (CaseT _ iID pats) = 73 | let pprintPat (PatT cP iIDP) = tab.pprintTH cP.(" -> "++).pprintInstrPtr iIDP.nl 74 | in ("case "++).pprintInstrPtr iID.(" of"++).nl. 75 | foldDot pprintPat pats 76 | pprint _ = ierr "Unknown instruction, no pretty printer available." 77 | 78 | -- | Pretty printer for pointers to instructions. 79 | pprintInstrPtr :: InstrID -> ShowS 80 | pprintInstrPtr iId = ("~["++).shows iId.("]"++) 81 | 82 | -- | Returns the position in the actuals list pointed to by an index. 83 | calcIdxBranch :: IIndex -> Acts -> Int 84 | calcIdxBranch iidx acts = 85 | case elemIndex iidx (map fst acts) of 86 | Just i -> i 87 | Nothing -> ierr $ "calcIdxBranch: no index "++(pprintIdx iidx "") 88 | 89 | -- | Program representation with a map for fast instruction lookup. 90 | type ProgT' = Map InstrID InstrT 91 | 92 | -- | Generates a ProgT' for fast lookup. 93 | mkProgT' :: ProgT -> ProgT' 94 | mkProgT' (ProgT entries) = fromList entries 95 | -------------------------------------------------------------------------------- /SLIC/TTD/TTD.hs: -------------------------------------------------------------------------------- 1 | -- | The top-level module of the TTD back-end. 2 | 3 | module SLIC.TTD.TTD (callTTDBackend) where 4 | 5 | import SLIC.AuxFun (ierr) 6 | import SLIC.DFI (DFI) 7 | import SLIC.Front.Defunc (dfFlags) 8 | import SLIC.ITrans.Syntax 9 | import SLIC.ITrans.ZLinker (mergeAndLinkZ) 10 | import SLIC.State 11 | import SLIC.SyntaxAux (Prog(..), Mod(..)) 12 | import SLIC.TTD.DFG (generateDFG) 13 | import SLIC.TTD.EvalTTD (evalTTD) 14 | import SLIC.TTD.ZItoTTD (fromZOILtoTTD, idOf) 15 | import SLIC.Types (mainDefQName, pprint) 16 | 17 | -- | The entry point to the TTD back-end. 18 | callTTDBackend :: Options -> DFI -> ModZ -> IO () 19 | callTTDBackend opts dfi m = 20 | let mn = fst $ modNameF m 21 | Prog _ defsZ = mergeAndLinkZ (dfFlags opts) dfi [m] 22 | (pTTD, defIDs) = fromZOILtoTTD defsZ 23 | resultID = idOf defIDs (mainDefQName mn) 24 | in case optAction opts of 25 | APrintTTD -> 26 | putStrLn "== Dataflow program ==" >> 27 | putStrLn (pprint pTTD "") 28 | AGenerateDFG -> 29 | let file = "./dfg.dot" 30 | in putStrLn ("Writing graph to file: "++file) >> 31 | writeFile file (generateDFG (True, False) defIDs resultID pTTD "") 32 | AEvalTTD -> 33 | if optLink opts then 34 | error "The TTD emulator does not support linking." 35 | else 36 | case optCMode opts of 37 | CompileModule -> 38 | error "The TTD emulator does not support separate compilation." 39 | Whole -> evalTTD dfi (optNWorkers opts) resultID pTTD 40 | a -> ierr $ "The TTD back-end cannot handle action "++(show a) 41 | -------------------------------------------------------------------------------- /SLIC/Tags.hs: -------------------------------------------------------------------------------- 1 | -- | Tags for value annotations. 2 | -- 3 | 4 | module SLIC.Tags (builtinTags, intTag, integerTag, listTag, findTagOfDT, uTag, 5 | mBoolTag, mIntTag) where 6 | 7 | import Data.Map (Map, fromList, lookup, toList) 8 | import SLIC.AuxFun (foldDot, ierr) 9 | import SLIC.LAR.LARAux (ConfigLAR(getOptions)) 10 | import SLIC.State (Options(optTag)) 11 | import SLIC.Types 12 | 13 | -- | Unknown tags, placeholder. 14 | uTag :: ShowS 15 | uTag = ("0"++) 16 | 17 | -- | The tag for the built-in Int data type. 18 | builtinTag :: DTName -> ShowS 19 | builtinTag dt = shows (findTagOfDT dt builtinTags) 20 | 21 | -- | The tag for the Int type. 22 | intTag :: ShowS 23 | intTag = builtinTag dtInt 24 | 25 | -- | The tag for the Bool type. 26 | boolTag :: ShowS 27 | boolTag = builtinTag dtBool 28 | 29 | -- | The tag for the Integer type. 30 | integerTag :: ShowS 31 | integerTag = builtinTag dtInteger 32 | 33 | -- | The tag for the list type. 34 | listTag :: ShowS 35 | listTag = builtinTag dtList 36 | 37 | -- | A tag is a nuber. 38 | type Tag = Int 39 | 40 | -- | An assignment from data types to tags. 41 | type Tags = Map DTName Tag 42 | 43 | pprintTags :: Tags -> ShowS 44 | pprintTags tags = 45 | let aux (dt, tag) = pprint dt.(" : "++).shows tag 46 | in foldDot aux $ toList tags 47 | 48 | -- | The tags assigned to built-in data types. 49 | builtinTags :: Tags 50 | builtinTags = fromList $ zip builtinDTypes [0..] 51 | 52 | -- | Finds the tag of a data type in the tags table. Fails if no tag is found. 53 | findTagOfDT :: DTName -> Tags -> Tag 54 | findTagOfDT dt tags = 55 | case Data.Map.lookup dt tags of 56 | Just tId -> tId 57 | Nothing -> ierr $ (qName dt)++" is not in tags: "++(pprintTags tags "") 58 | 59 | mTag :: ShowS -> ConfigLAR -> ShowS 60 | mTag tag config = if (optTag $ getOptions config) then (", "++).tag else id 61 | 62 | mIntTag :: ConfigLAR -> ShowS ; mIntTag = mTag intTag 63 | mBoolTag :: ConfigLAR -> ShowS ; mBoolTag = mTag boolTag 64 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /build-archive.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | TARGET_DIR=gic-pack 3 | mkdir -p $TARGET_DIR $TARGET_DIR/SLIC \ 4 | $TARGET_DIR/SLIC/Distr $TARGET_DIR/SLIC/Front $TARGET_DIR/SLIC/ITrans \ 5 | $TARGET_DIR/SLIC/LAR $TARGET_DIR/SLIC/Maude $TARGET_DIR/SLIC/TTD \ 6 | $TARGET_DIR/SLIC/Front/LLifter \ 7 | $TARGET_DIR/c $TARGET_DIR/erlang $TARGET_DIR/maude \ 8 | $TARGET_DIR/Examples $TARGET_DIR/Examples/Num $TARGET_DIR/Examples/Data \ 9 | $TARGET_DIR/Examples/NewBench \ 10 | $TARGET_DIR/Examples/Polymorphic $TARGET_DIR/Examples/GADT \ 11 | $TARGET_DIR/Examples/Modules $TARGET_DIR/Examples/Modules/Example1 \ 12 | $TARGET_DIR/Examples/Modules/Example2 $TARGET_DIR/Examples/Modules/Example3 \ 13 | $TARGET_DIR/Examples/Modules/Example4 14 | cp bench-libGC.sh eval_maude.sh \ 15 | newbench.sh Main.hs Makefile README testLangs.sh scomp-tests.sh \ 16 | run_lar.sh compile-link-mods.sh compile-module.sh \ 17 | $TARGET_DIR 18 | cp SLIC/*.hs $TARGET_DIR/SLIC 19 | cp SLIC/Distr/*.hs $TARGET_DIR/SLIC/Distr 20 | cp SLIC/Front/*.hs $TARGET_DIR/SLIC/Front 21 | cp SLIC/ITrans/*.hs $TARGET_DIR/SLIC/ITrans 22 | cp SLIC/LAR/*.hs $TARGET_DIR/SLIC/LAR 23 | cp SLIC/Maude/*.hs $TARGET_DIR/SLIC/Maude 24 | cp SLIC/TTD/*.hs $TARGET_DIR/SLIC/TTD 25 | cp SLIC/Front/LLifter/*.hs $TARGET_DIR/SLIC/Front/LLifter 26 | cp c/gc.h c/gc.c c/cat.c c/lar.h c/lar_opt.h c/lar_compact.h c/gic_builtins.h \ 27 | $TARGET_DIR/c 28 | cp maude/full-maude26.maude maude/eduction.maude \ 29 | $TARGET_DIR/maude 30 | cp Examples/NewBench/*.hs \ 31 | $TARGET_DIR/Examples/NewBench 32 | cp Examples/Num/exmh*.hs Examples/Num/myex*.hs Examples/Num/memoize.hs \ 33 | Examples/Num/bigints.hs \ 34 | $TARGET_DIR/Examples/Num 35 | cp Examples/Data/*.hs $TARGET_DIR/Examples/Data 36 | cp Examples/Polymorphic/*.hs $TARGET_DIR/Examples/Polymorphic 37 | cp Examples/GADT/*.hs $TARGET_DIR/Examples/GADT 38 | cp Examples/Modules/Example1/ModuleA.hs Examples/Modules/Example1/Main.hs \ 39 | $TARGET_DIR/Examples/Modules/Example1 40 | cp Examples/Modules/Example2/Lib.hs Examples/Modules/Example2/Main.hs \ 41 | $TARGET_DIR/Examples/Modules/Example2 42 | cp Examples/Modules/Example3/Lib.hs Examples/Modules/Example3/Main.hs \ 43 | $TARGET_DIR/Examples/Modules/Example3 44 | cp Examples/Modules/Example4/Lib.hs Examples/Modules/Example4/Main.hs \ 45 | $TARGET_DIR/Examples/Modules/Example4 46 | tar -czf gic.tar.gz $TARGET_DIR 47 | 48 | -------------------------------------------------------------------------------- /buildwin.bat: -------------------------------------------------------------------------------- 1 | ghc -package ghc -fwarn-unused-binds -Wall --make -o gic Main.hs 2 | -------------------------------------------------------------------------------- /c/gc.h: -------------------------------------------------------------------------------- 1 | /** @file gc.h 2 | 3 | GC macros. 4 | 5 | */ 6 | 7 | #ifdef GC 8 | 9 | /** Enables internal consistency check (used for debugging). */ 10 | #define DEBUG_GC 1 11 | /** Print (lots of) diagnostic messages. */ 12 | #define VERBOSE_GC 0 13 | /** Print statistics. */ 14 | #define GC_STATS 1 15 | 16 | /** GC assertion. */ 17 | #if DEBUG_GC 18 | #include 19 | #define ASSERT_GC(c, m) assert((c) && (m)) 20 | #else 21 | #define ASSERT_GC(n, m) do { } while(0) 22 | #endif 23 | /** GC assertion (used as an expression). */ 24 | #define ASSERT_GC_EXPR(c, m) ({ ASSERT_GC(c, m); }) 25 | 26 | /** Check if a pointer belongs to space 1. */ 27 | #define ISSPACE1(x) ((x >= space1) && (x <= space1 + MAXMEMSPACE)) 28 | /** Check if a pointer belongs to space 2. */ 29 | #define ISSPACE2(x) ((x >= space2) && (x <= space2 + MAXMEMSPACE)) 30 | 31 | #else 32 | 33 | /** Dummy GC assertion (used as an expression). */ 34 | #define ASSERT_GC_EXPR(c, m) ( { } ) 35 | 36 | #endif /* GC */ 37 | -------------------------------------------------------------------------------- /c/gic_builtins.h: -------------------------------------------------------------------------------- 1 | /** @file gic_builtins.h 2 | 3 | The built-in functions of the GIC runtime. 4 | 5 | */ 6 | 7 | /** Big integer multiplication using libgmp. 8 | \param a The first big integer. 9 | \param b The second big integer. 10 | \return The product of a and b. 11 | */ 12 | Susp mulI(Susp a, Susp b); 13 | 14 | /** Converts C strings to GIC lists. 15 | \param str The C string to convert. 16 | \param chars The length of the C string. 17 | \return A GIC string (i.e. a lazy list of characters). 18 | */ 19 | Susp strToList(char *str, int chars, TP_ AR_TP(T0)); 20 | 21 | #if defined(GC) || defined(LAR_COMPACT) 22 | /** Prints a thunk value at position 'n' in a LAR. */ 23 | static void MM_printThunk(int n, TP_ lar); 24 | #endif /* GC, LAR_COMPACT */ 25 | -------------------------------------------------------------------------------- /c/lar_opt.h: -------------------------------------------------------------------------------- 1 | /* 2 | LAR infrastructure, optimized representation for use with the libgc 3 | garbage collector. 4 | 5 | This covers both the single-threaded runtime, and the OpenMP-based parallel 6 | runtime. 7 | */ 8 | 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include "gc.h" 15 | 16 | #ifdef USE_OMP 17 | #include 18 | #endif /* USE_OMP */ 19 | 20 | // Types 21 | 22 | typedef unsigned char byte; 23 | 24 | typedef struct T_* TP_; 25 | 26 | typedef struct Susp { 27 | int constr; // constructor id 28 | #ifdef USE_TAGS 29 | int tag; // data type tag 30 | #endif /* USE_TAGS */ 31 | TP_ ctxt; // lazy constructor context 32 | } Susp; 33 | 34 | #ifndef USE_OMP 35 | typedef Susp (*LarArg)(TP_); 36 | #else 37 | typedef struct LarArg { 38 | Susp (*volatile larArg)(TP_); 39 | omp_lock_t larArgLock; 40 | } LarArg; 41 | #endif /* USE_OMP */ 42 | 43 | typedef struct T_ { 44 | TP_ prev; // link to parent LAR (also GC forwarded pointer) 45 | void* data[]; // the rest of this struct contains: 46 | // - array of args to evaluate (ARGS) 47 | // - computed thunk values (VALS) 48 | // - nested contexts (NESTED) 49 | } T_; 50 | 51 | // Macros 52 | 53 | #define True 1 54 | #define False 0 55 | 56 | /* Give a warning in untested platforms. */ 57 | #ifndef __x86_64__ 58 | #warning "The compiler has only been tested on the x86-64 architecture." 59 | #endif /* __x86_64__ */ 60 | 61 | /* LAR_STRUCT is used to allocate LARs on the stack. */ 62 | #ifndef USE_OMP 63 | #define LAR_STRUCT(n_arity_a, n_arity_v, n_nesting)\ 64 | struct { \ 65 | TP_ prev; \ 66 | Susp the_vals[n_arity_v]; \ 67 | TP_ the_nested[n_nesting]; \ 68 | } 69 | #else 70 | #define LAR_STRUCT(n_arity_a, n_arity_v, n_nesting)\ 71 | struct { \ 72 | TP_ prev; \ 73 | LarArg the_args[n_arity_a]; \ 74 | Susp the_vals[n_arity_v]; \ 75 | TP_ the_nested[n_nesting]; \ 76 | } 77 | #endif 78 | 79 | #define THE_ARGS(T) ((byte *) &((T)->data)) 80 | #define THE_NESTED(VARSARITY, VALSARITY, T) (THE_VALS(VARSARITY, T) + VALSARITY * sizeof(Susp)) 81 | 82 | // single-threaded runtime 83 | #ifndef USE_OMP 84 | 85 | #define ZEROIFTAG(x) 0 86 | #define THE_VALS(VARSARITY, T) (THE_ARGS(T)) 87 | #define ARGS(x, T) ((((Susp*) THE_VALS(0, T))[x])).ctxt 88 | #define ARGS_FLAG(x, T) ((LarArg)((uintptr_t)ARGS(x, T) & (uintptr_t)0x1)) 89 | #define ARGC(arg) (TP_)((uintptr_t)arg | (uintptr_t)0x1) 90 | #define CODE(x, T) ((LarArg)((uintptr_t)ARGS(x, T) & (~1))) 91 | #define INIT_ARG_LOCKS(arity_a) { } 92 | #define GETARG(x, ARGSARITY, T) ({ \ 93 | if (ARGS_FLAG(x, T) != NULL) { \ 94 | Susp val = CODE(x, T)(T); \ 95 | VALS(x, ARGSARITY, T) = val; \ 96 | } \ 97 | VALS(x, ARGSARITY, T); \ 98 | }) 99 | 100 | #else 101 | 102 | // parallel runtime 103 | 104 | #define ZEROIFTAG(x) x 105 | #define THE_VALS(VARSARITY, T) (THE_ARGS(T) + VARSARITY * sizeof(LarArg)) 106 | #define ARGS(x, T) ((((LarArg*) THE_ARGS(T))[x]).larArg) 107 | #define CODE(x, T) ARGS(x, T) 108 | #define ARGC(arg) arg 109 | #define LOCKS(x, T) (omp_lock_t*)(&((((LarArg*) THE_ARGS(T))[x]).larArgLock)) 110 | 111 | /* Initializes the arity_a locks of a LAR. */ 112 | #define INIT_ARG_LOCKS(arity_a) {int a; for (a=0; aprev 148 | 149 | /* A strict argument is already evaluated, just return its value. */ 150 | #define GETSTRICTARG(x, VARSARITY, T) VALS(x, VARSARITY, T) 151 | 152 | /* A call-by-name argument calls directly the argument, does no memoization. */ 153 | #define GETCBNARG(x, T) (CODE(x, T)(T)) 154 | 155 | /* *********** Macros of the LAR API *********** */ 156 | 157 | /** Reads a LAR pointer from a thunk. */ 158 | #define CPTR(p) ((p).ctxt) 159 | /** Returns the constructor field of a thunk. */ 160 | #define CONSTR(p) ((p).constr) 161 | 162 | /* Primitive value read/create macros. Isomorphic to nullary constructors. */ 163 | #define PVAL_R(p) (p).constr 164 | 165 | #ifdef USE_TAGS 166 | #error TODO: USE_TAGS for lar_opt.h 167 | #else 168 | #define PVAL_C(i) ((Susp) { i, NULL }) 169 | #endif /* USE_TAGS */ 170 | 171 | #ifdef USE_TAGS 172 | /* Thunk constructor: (constructor, tag, ctxt). */ 173 | #define SUSP(c, t, p) ((Susp) {(c), (t), (p)}) 174 | #else 175 | /* Thunk constructor, ignores the tag 't'. */ 176 | #define SUSP(c, t, p) ((Susp) {(c), (p)}) 177 | #endif /* USE_TAGS */ 178 | 179 | /* Dummy LAR wrapper (*-operator). */ 180 | #define AR_TP(tp) tp 181 | /* Dummy LAR wrapper (&-operator). */ 182 | #define AR_REF(tp) tp 183 | -------------------------------------------------------------------------------- /c/lar_semi.h: -------------------------------------------------------------------------------- 1 | /** 2 | Macros used for the LAR representation using the semi-space collector. 3 | This file contains common macros for both the standard and the compact 4 | representation. 5 | */ 6 | 7 | #ifdef GC 8 | /* LAR wrapper (*-operator). */ 9 | #define AR_TP(tp) *(tp) 10 | /* LAR wrapper (&-operator). */ 11 | #define AR_REF(tp) &(tp) 12 | #else 13 | /* Dummy LAR wrapper (*-operator). */ 14 | #define AR_TP(tp) (tp) 15 | /* Dummy LAR wrapper (&-operator). */ 16 | #define AR_REF(tp) (tp) 17 | #endif /* GC */ 18 | 19 | /** The start of the ARGS fields, holding the code pointers of the thunks. 20 | \param T The LAR. */ 21 | #ifdef GC 22 | #define THE_ARGS(T) ((byte *) &((*(T))->data)) 23 | #else 24 | #define THE_ARGS(T) ((byte *) &((T)->data)) 25 | #endif /* GC */ 26 | 27 | /** Printer for activation records (used for debugging). 28 | \param a The LAR. This is used many times, it should not be a macro. */ 29 | #ifdef GC 30 | #define DEBUG_PRINT_AR(a) { printf("%p@{ prev=%p, a=%d, n=%d } [size=%ld] ", a, AR_prev(a), ARITY(a), NESTING(a), AR_SIZE(a)); printf("thunks: "); int i; for (i=0; i "); }; } 31 | #else 32 | #define DEBUG_PRINT_AR(a) { } 33 | #endif /* GC */ 34 | -------------------------------------------------------------------------------- /compile-link-mods.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # Separately compiles two modules and then links them using the modular 4 | # defunctionalization technique. 5 | # 6 | 7 | # Use libgc 7.2 @ greedy 8 | GC_INCLUDE="-I/var/tmp/gfour/gc-inst-7.2/include/" 9 | GC_LIB="-pthread /var/tmp/gfour/gc-inst-7.2/lib/libgc.a" 10 | # Use libgc @ ~ptheof 11 | # GC_INCLUDE="-I/home/ptheof/gc-inst/include" 12 | # GC_LIB=/home/ptheof/gc-inst/lib/libgc.a 13 | 14 | # Needed for tagged pointers to work. 15 | OPT="-falign-functions" 16 | 17 | set -e 18 | 19 | source find-gic.sh 20 | echo "Using GIC=${GIC}" 21 | 22 | # generates a .hi file for the module (used by the GHC type checker) 23 | function generateHI { 24 | MOD=`basename $1` 25 | echo Generating $1.hi... 26 | pushd `dirname $1` > /dev/null 27 | rm -f $MOD.o $MOD.c $MOD.hi 28 | ghc -o /dev/null -ohi $MOD.hi -c $MOD.hs 29 | rm -f $MOD.o $MOD.c 30 | cp $MOD.hi ../../../ 31 | popd > /dev/null 32 | } 33 | 34 | # if using the GHC type checker, generate .hi files for the modules 35 | if [ "$TC" = "-ghc-tc" ]; then 36 | generateHI $1 37 | generateHI $2 38 | fi 39 | 40 | ./compile-module.sh $1 41 | ./compile-module.sh $2 42 | 43 | echo Creating linker... 44 | 45 | if [ "$TC" = "-ghc-tc" ]; then 46 | rm -f `basename $1`.hi `basename $2`.hi 47 | fi 48 | 49 | ${GIC} -link $1 $2 50 | echo Linking with gcc... 51 | gcc $GC_INCLUDE -I . dfmod.c main-link.c "$1.g.o" "$2.g.o" $GC_LIB -o a.out -ggdb3 -Wall $OPT 52 | echo -n LAR\ \ result:\ 53 | ./a.out 54 | 55 | # GHCi test 56 | echo -n GHCi result:\ 57 | echo "Main.result" | ghci -v0 $1.hs $2.hs 58 | -------------------------------------------------------------------------------- /compile-module.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Compile a module Module.hs to Module.o through Module.c using the 4 | # separate compilation mode of the LAR back-end of GIC. 5 | # 6 | # To call this script, omit the .hs module extension: 7 | # 8 | # ./compile-module.sh Examples/Modules/example2/Main 9 | # 10 | 11 | # Use libgc 7.2 @ greedy 12 | GC_INCLUDE="-I/var/tmp/gfour/gc-inst-7.2/include/" 13 | GC_LIB="-pthread /var/tmp/gfour/gc-inst-7.2/lib/libgc.a" 14 | # Use libgc @ ~ptheof 15 | # GC_INCLUDE="-I/home/ptheof/gc-inst/include" 16 | # GC_LIB=/home/ptheof/gc-inst/lib/libgc.a 17 | 18 | # Use the allocator of semi-gc 19 | # GC_INCLUDE="-I ./c/" 20 | 21 | # STACKTRACE="+RTS -xc -RTS" 22 | STACKTRACE= 23 | 24 | # Needed for tagged pointers to work. 25 | OPT="-falign-functions" 26 | 27 | set -e 28 | 29 | source find-gic.sh 30 | echo "Using GIC=${GIC}" 31 | 32 | echo Compiling $1.g.o... 33 | ${GIC} $TC $STACKTRACE -cmod $1.hs && gcc $OPT $GC_INCLUDE -I . -c $1.c -o $1.g.o -ggdb3 -Wall 34 | -------------------------------------------------------------------------------- /doc/.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore everything in this directory 2 | * 3 | # Except: 4 | !.gitignore 5 | !doxygen 6 | !haddock 7 | -------------------------------------------------------------------------------- /doc/doxygen/.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore everything in this directory 2 | * 3 | # Except: 4 | !.gitignore 5 | -------------------------------------------------------------------------------- /doc/haddock/.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore everything in this directory 2 | * 3 | # Except: 4 | !.gitignore 5 | -------------------------------------------------------------------------------- /erlang/warehouse2.erl: -------------------------------------------------------------------------------- 1 | % The warehouse processes of the parallel eduction interpreter. 2 | 3 | -module(warehouse2). 4 | -export([magic/1, spawn_warehouses/1, warehouses_num/0, winit/0]). 5 | 6 | % The number of the warehouses during execution. 7 | warehouses_num() -> 20. 8 | 9 | % Spawns all the warehouses (to be used at the beginnig). 10 | spawn_warehouses(N) -> 11 | case N of 12 | 0 -> []; 13 | _ -> 14 | WPID = spawn(warehouse2, winit, []), 15 | [WPID|spawn_warehouses(N-1)] 16 | end. 17 | 18 | % The warehouse entry point. 19 | winit() -> 20 | % create warehouse data tables 21 | WValues = ets:new(w_values, []), 22 | PendingSlots = ets:new(pending_slots, [bag]), 23 | deb("Warehouse ~p started\n", [self()]), 24 | wrun(WValues, PendingSlots). 25 | 26 | deb(_, _) -> true. 27 | % deb(Msg, Args) -> io:fwrite(string:concat("**", Msg), Args). 28 | 29 | % 30 | % The Warehouse actor. 31 | % 32 | % The warehouse contains 2 tables: WValues, which stores the computed 33 | % values, and PendingSlots, which contains the pending slots for 34 | % current computations. 35 | % Tables format: 36 | % - WValues: {{identifier, context}, value} 37 | % - PendingSlots: {pid, {identifier, context}} 38 | % 39 | wrun(WValues, PendingSlots) -> 40 | % deb("Warehouse: waiting for messages...\n", []), 41 | receive 42 | {demand, PID, V, C} -> 43 | deb("Warehouse: got a demand from ~p for ~s under ~p...\n", [PID, V, C]), 44 | case ets:lookup(WValues, {V, C}) of 45 | % if not found, create a new pending slot in both tables 46 | [] -> 47 | deb("not found, creating new slot (~p, {~p, ~p}).\n", [PID, V, C]), 48 | ets:insert(WValues, {{V, C}, {pending, PID}}), 49 | ets:insert(PendingSlots, {PID, {V, C}}), 50 | % and tell the requesting process to continue 51 | deb("...and the original node continues.\n", []), 52 | PID ! {continue}; 53 | % if already pending, let the demanding node wait 54 | % (but record the nodes dependency in the pending slots) 55 | [{_, {pending, PID2}}] -> 56 | % DEBUG, remove for better performance 57 | %% if 58 | %% PID==PID2 -> io:fwrite("*** Cycle detected.\n"), erlang:exit(-1); 59 | %% true -> 60 | deb("Blocked: ~p demands a computation (~p, ~p) of ~p, creating pending {~p, ~p}.\n", [PID, V, C, PID2, PID2, PID]), 61 | % create a pending slot for this new node (so that it will get unblocked later) 62 | ets:insert(PendingSlots, {PID2, PID}); 63 | %% end; 64 | % if a value is found, return it to the demanding node 65 | [{_, Val}] -> 66 | deb("*** Warehouse has a value ~p for ~p.\n", [Val, PID]), 67 | PID ! {notify, leftNode, Val} 68 | end; 69 | {regval, PID, Val} -> 70 | deb("Warehouse: Received a registration demand for (~p, ~p).\n", [PID, Val]), 71 | % A message for value registration 72 | case ets:lookup(PendingSlots, PID) of 73 | [] -> deb("No pending slots for ~p found.\n", [PID]); 74 | PIDSlots -> 75 | deb("Pending slots found: ~p\n", [PIDSlots]), 76 | % delete the pending slots 77 | ets:match_delete(PendingSlots, {PID, '_'}), 78 | % ets:select(TAB,[{{'$1', '$2'}, [], ['$$']}]). 79 | % deletePending(PendingSlots, PIDSlots), 80 | updateWH(WValues, PIDSlots, Val) 81 | end 82 | end, 83 | wrun(WValues, PendingSlots). 84 | 85 | updateWH(WValues, PIDSlots, Val) -> 86 | deb("WH: UPDATE-START (Val: ~p)... \n", [Val]), 87 | case PIDSlots of 88 | [] -> deb("No more Pid slots.\n", []); 89 | % A slot waiting for the value of from PID 90 | [{PID, {V, C}} | XS] -> 91 | deb("updated waiting slot ([~p, ~p] -> ~p)\n", [V, C, Val]), 92 | ets:insert(WValues, {{V, C}, Val}), 93 | % unblock updated node 94 | PID ! {notify, leftNode, Val}, 95 | % case ets:lookup(WValues, {V, C}) of 96 | % X2 -> deb("DEBUG: Does it exist? ~p", [X2]) 97 | % end, 98 | updateWH(WValues, XS, Val); 99 | % A slot of PID waiting for some value from another node 100 | [{_, PID} | XS] -> 101 | deb("Unblocking node ~p.\n", [PID]), 102 | PID ! {notify, leftNode, Val}, 103 | updateWH(WValues, XS, Val) 104 | end, 105 | deb("UPDATE-END.\n", []). 106 | 107 | % Chooses the warehouse to hit, according to the context. 108 | % The (+1) is due to the 1-based Erlang list indices. 109 | magic(C) -> 110 | (length(C) rem warehouse2:warehouses_num()) + 1. 111 | -------------------------------------------------------------------------------- /eval_erl.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | source find-gic.sh 4 | echo "Using GIC=${GIC}" 5 | 6 | (${GIC} -erl ${1} > main.erl) && 7 | (cat erlang/distr_eduction.erl >> main.erl) && 8 | (erlc main.erl erlang/warehouse2.erl) && 9 | # echo ${1} transformed to main.erl 10 | # (echo "main:init()." | erl +sct L0-0c0-0 +P 1677216 main.beam) 11 | (echo "main:init()." | erl +P 1677216 main.beam) 12 | -------------------------------------------------------------------------------- /eval_maude.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Compiles the file to Maude code and evaluates it with the Maude model. 3 | # Arguments: 4 | 5 | set -e 6 | 7 | function usage { 8 | echo "Usage: ./eval_maude.sh [run|search] " 9 | exit 10 | } 11 | 12 | if [ $# -ne 3 ] 13 | then 14 | usage 15 | else 16 | 17 | source find-gic.sh 18 | echo "Using GIC=${GIC}" 19 | 20 | cp maude/eduction.maude test.maude 21 | ${GIC} -cm $2 -wh $3 >> test.maude 22 | if [ "$1" = "search" ]; then 23 | echo "(search init =>! C:Configuration .)" >> test.maude 24 | echo Starting search in Maude... 25 | else 26 | if [ "$1" = "run" ]; then 27 | echo Rewriting in Maude... 28 | else 29 | usage 30 | fi 31 | fi 32 | 33 | (maude maude/full-maude26.maude < test.maude) | 34 | sed -e "s/< /\n < /g" | 35 | sed -e "s/notify/\n notify/g" | 36 | sed -e "s/continue/\n continue/g" | 37 | sed -e "s/demand/\n demand/g" | 38 | sed -e "s/regVal/\n regVal/g" 39 | 40 | fi 41 | -------------------------------------------------------------------------------- /find-gic.sh: -------------------------------------------------------------------------------- 1 | # Finds the location of gic binary. 2 | 3 | CABAL_GIC="./dist/build/gic/gic" 4 | MAKE_GIC="./gic" 5 | 6 | if [ ! -e "${GIC}" ]; then 7 | if [ -x "$(command -v stack)" ]; then 8 | GIC=`stack path --local-install-root`/bin/gic 9 | else 10 | if [ -e "${CABAL_GIC}" ]; then 11 | GIC="${CABAL_GIC}" 12 | else 13 | if [ -e "${MAKE_GIC}" ]; then 14 | GIC="${MAKE_GIC}" 15 | else 16 | echo "Could not find gic, plase set environment variable GIC (checked: '${GIC}', '${CABAL_GIC}', '${MAKE_GIC}', plus 'stack')." 17 | exit 18 | fi 19 | fi 20 | fi 21 | fi 22 | -------------------------------------------------------------------------------- /gen-dfg-graph.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Generates a dataflow graph from a Graphviz file (that is the output of 3 | # the GIC TTD mode). 4 | 5 | dot -Gnodesep=0.75 -Tpng dfg.dot -o dfg.png 6 | -------------------------------------------------------------------------------- /gic.cabal: -------------------------------------------------------------------------------- 1 | -- Initial gic.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | -- The name of the package. 5 | name: gic 6 | 7 | -- The package version. See the Haskell package versioning policy (PVP) 8 | -- for standards guiding when and how versions should be incremented. 9 | -- https://wiki.haskell.org/Package_versioning_policy 10 | -- PVP summary: +-+------- breaking API changes 11 | -- | | +----- non-breaking API additions 12 | -- | | | +--- code changes with no API change 13 | version: 0.1.0.0 14 | 15 | -- A short (one-line) description of the package. 16 | -- synopsis: 17 | 18 | -- A longer description of the package. 19 | -- description: 20 | 21 | -- URL for the project homepage or repository. 22 | homepage: https://gfour.github.io/gic/ 23 | 24 | -- The license under which the package is released. 25 | license: LGPL-2.1 26 | 27 | -- The file containing the license text. 28 | license-file: LICENSE 29 | 30 | -- The package author(s). 31 | author: George Fourtounis 32 | 33 | -- An email address to which users can send suggestions, bug reports, and 34 | -- patches. 35 | maintainer: gfour@di.uoa.gr 36 | 37 | -- A copyright notice. 38 | -- copyright: 39 | 40 | category: Compiler 41 | 42 | build-type: Simple 43 | 44 | -- Extra files to be distributed with the package, such as examples or a 45 | -- README. 46 | extra-source-files: README, README.md 47 | 48 | -- Constraint on the version of Cabal needed to build this package. 49 | cabal-version: >=1.10 50 | 51 | 52 | executable gic 53 | -- .hs or .lhs file containing the Main module. 54 | main-is: Main.hs 55 | 56 | -- Modules included in this executable, other than Main. 57 | -- other-modules: 58 | 59 | -- LANGUAGE extensions used by modules in this package. 60 | other-extensions: CPP, MagicHash 61 | 62 | cpp-options: -DUSE_GHC 63 | 64 | -- Other library packages from which modules are imported. 65 | build-depends: base >=4.9 && <4.10, ghc-paths >=0.1 && <0.2, ghc-boot >=8.0 && <8.1, haskell-src-exts >=1.18.2 && <1.20, containers >=0.5 && <0.6, ghc >=8.0.2 66 | 67 | other-modules: SLIC.AuxFun 68 | , SLIC.CompManager 69 | , SLIC.Constants 70 | , SLIC.DFI 71 | , SLIC.Distr.EvalErl 72 | , SLIC.Driver 73 | , SLIC.Front.CAF 74 | , SLIC.Front.Defunc 75 | , SLIC.Front.EvalFL 76 | , SLIC.Front.GHCFrontEnd 77 | , SLIC.Front.HStoHF 78 | , SLIC.Front.LLifter.Equations 79 | , SLIC.Front.LLifter.Lifter 80 | , SLIC.Front.PatternCompiler 81 | , SLIC.Front.Preprocessor 82 | , SLIC.Front.Renamer 83 | , SLIC.Front.TailCalls 84 | , SLIC.Front.TypeInfer 85 | , SLIC.Front.Typeclass 86 | , SLIC.ITrans.Eval 87 | , SLIC.ITrans.EvalEduction 88 | , SLIC.ITrans.HFtoHI 89 | , SLIC.ITrans.HItoZI 90 | , SLIC.ITrans.ITrans 91 | , SLIC.ITrans.Optimizations 92 | , SLIC.ITrans.Syntax 93 | , SLIC.ITrans.ZLinker 94 | , SLIC.LAR.LAR 95 | , SLIC.LAR.LARAux 96 | , SLIC.LAR.LARBuiltins 97 | , SLIC.LAR.LARDebug 98 | , SLIC.LAR.LARGraph 99 | , SLIC.LAR.LARLinker 100 | , SLIC.LAR.OptimizationsLAR 101 | , SLIC.LAR.SMacrosAux 102 | , SLIC.LAR.SyntaxLAR 103 | , SLIC.LAR.ZItoLAR 104 | , SLIC.Maude.ZItoMaude 105 | , SLIC.State 106 | , SLIC.SyntaxAux 107 | , SLIC.SyntaxFL 108 | , SLIC.TTD.DFG 109 | , SLIC.TTD.EvalTTD 110 | , SLIC.TTD.SyntaxTTD 111 | , SLIC.TTD.TTD 112 | , SLIC.TTD.ZItoTTD 113 | , SLIC.Tags 114 | , SLIC.Types 115 | 116 | -- Directories containing source files. 117 | -- hs-source-dirs: 118 | 119 | -- Base language which the package is written in. 120 | default-language: Haskell2010 121 | 122 | -------------------------------------------------------------------------------- /maude/full-maude26.maude: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gfour/gic/d5f2e506b31a1a28e02ca54af9610b3d8d618e9a/maude/full-maude26.maude -------------------------------------------------------------------------------- /newbench.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ./bench.sh -mflags "-mem 4000000000" NewBench/*.hs 4 | ./bench.sh -llvm -mflags "-mem 4000000000" NewBench/*.hs 5 | 6 | ./bench-ghc.sh -nogc NewBench/*.hs 7 | ./bench-ghc.sh -nogc -noopt NewBench/*.hs 8 | ./bench-ghc.sh -ghc ghc6 -nogc NewBench/*.hs 9 | ./bench-ghc.sh -ghc ghc6 -nogc -noopt NewBench/*.hs 10 | 11 | ./bench-nhc.sh -nogc NewBench/*.hs 12 | 13 | ./bench-jhc.sh -nogc NewBench/*.hs 14 | 15 | ./bench-uhc.sh -nogc NewBench/*.hs 16 | -------------------------------------------------------------------------------- /pcomp.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # Test the separate compilation features using the simple LAR representation. 4 | # 5 | 6 | set -e 7 | 8 | # Use the built-in type checker. 9 | export TC="-gic-tc" 10 | 11 | # Semi-space GC 12 | GC="-semigc" 13 | CFLAGS="-I . -I ./c" 14 | # CFLAGS="-DGC -I . -I ./c" 15 | 16 | source find-gic.sh 17 | echo "Using GIC=${GIC}" 18 | 19 | function compileLink { 20 | for module in $1 $2 21 | do 22 | echo Compiling module: ${module} -- 23 | ${GIC} ${TC} -cmod -debug ${GC} ${module}.hs 24 | gcc -c ${CFLAGS} ${module}.c -o ${module}.o 25 | done 26 | echo Creating linker... 27 | ${GIC} ${GC} -link $1 $2 28 | echo Adding GC... 29 | cat c/gc.c >> main-link.c 30 | echo Linking with gcc... 31 | gcc ${CFLAGS} dfmod.c main-link.c $1.o $2.o -o a.out -ggdb3 -Wall 32 | 33 | echo -n LAR\ \ result:\ 34 | ./a.out 35 | 36 | # GHCi test 37 | echo -n GHCi result:\ 38 | echo "Main.result" | ghci -v0 $1.hs $2.hs 39 | } 40 | 41 | echo --- Separate compilation tests [lar, simple] --- 42 | echo -- [Example1] -- 43 | compileLink Examples/Modules/Example1/ModuleA Examples/Modules/Example1/Main 44 | echo -- [Example2] -- 45 | compileLink Examples/Modules/Example2/Lib Examples/Modules/Example2/Main 46 | echo -- [Example2] -- 47 | compileLink Examples/Modules/Example3/Lib Examples/Modules/Example3/Main 48 | echo -- [Example4] -- 49 | compileLink Examples/Modules/Example4/Lib Examples/Modules/Example4/Main 50 | -------------------------------------------------------------------------------- /run_distr.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | source find-gic.sh 4 | echo "Using GIC=${GIC}" 5 | 6 | for f in Examples/Num/fib.hs Examples/Num/cbn.hs Examples/Num/ack.hs Examples/Num/queens.hs 7 | do 8 | echo "------ Testing $f..." 9 | (${GIC} -autopar -cerl -wh 20 $f > main.erl) && (erlc main.erl erlang/warehouse.erl > /dev/null) 10 | echo "------- gic " 11 | (echo "main:init()." | erl +P 1677216 main.beam | grep result) 12 | echo "------- GHCi " 13 | (echo "putStr \"result = \" >> putStrLn (show result)" | ghci $f | grep result) 14 | done 15 | 16 | -------------------------------------------------------------------------------- /run_erl.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | WH=20 3 | MC=2000000 4 | 5 | # Use the custom warehouse 6 | REDIS= 7 | WHERL=erlang/warehouse.erl 8 | # Use the Redis-based warehouse 9 | # REDIS=-redis 10 | # WHERL=erlang/warehouse_redis.erl 11 | 12 | source find-gic.sh 13 | echo "Using GIC=${GIC}" 14 | 15 | echo Running ${1} with $WH warehouses and $MC maximum contexts per warehouse... 16 | (${GIC} -cerl -wh $WH $REDIS -ctxts $MC ${1} ${2} ${3} ${4} ${5} > main.erl) && 17 | (erlc -v main.erl $WHERL erlang/gc.erl) && 18 | # echo ${1} transformed to main.erl 19 | # (echo "main:init()." | erl +sct L0-0c0-0 +P 1677216 main.beam) 20 | # (echo "c(main, [native]), main:init()." | erl +P 1677216 main.beam) 21 | (echo "main:init()." | erl -pa ~/custom/redis/eredis/ebin +P 1677216 main.beam) 22 | -------------------------------------------------------------------------------- /run_lar.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # Compiles and runs a program using the "simple" LAR representation. 4 | # 5 | # Reads the following environment variables: 6 | # 7 | # CC : the C compiler to use (default=gcc) 8 | # GICFLAGS : flags passed on to gic 9 | # CFLAGS2 : extra flags passed to the C compiler 10 | # 11 | 12 | set -e 13 | 14 | source find-gic.sh 15 | 16 | # USE_GMP= 17 | USE_GMP="-DHAS_GMP -lgmp" 18 | if [ "$CC" = "" ]; then 19 | CC=gcc 20 | fi 21 | 22 | CFLAGS="-O3 -I . -ggdb3" 23 | # CFLAGS2 are used but undefined: extra flags to be filled in from the command-line 24 | # e.g. add -DUSE_TAGS if compiling with -tag 25 | 26 | GC=0 27 | 28 | if [ "$GC" = "1" ]; then 29 | # Add -DGC to the gcc flags to use the semi-space collector. 30 | USE_GC="-DGC" 31 | # USE_GC="-DGC -DVERBOSE_GC" 32 | else 33 | USE_GC="" 34 | fi 35 | 36 | # if using GCC and the gold linker exists, do link-time optimization 37 | if [ `echo "$CC" | tail -c 4 | head -c 3` = "gcc" ]; then 38 | hash gold 2>/dev/null && { CFLAGS="${CFLAGS} -fwhole-program -fuse-ld=gold -flto"; } 39 | fi 40 | 41 | ${GIC} -semigc $GICFLAGS $* > /dev/null 42 | 43 | cat c/gc.c >> main.c 44 | 45 | CMD="${CC} main.c ${CFLAGS} ${CFLAGS2} ${USE_GC} ${USE_GMP}" 46 | # echo $CMD 47 | $CMD 48 | 49 | ./a.out 50 | -------------------------------------------------------------------------------- /run_libgc.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # Compiles and runs a Haskell file using the Boehm-Demers-Weiser garbage 4 | # collector. The collector is available from: 5 | # 6 | # http://www.hpl.hp.com/personal/Hans_Boehm/gc/ 7 | # 8 | # Reads the following environment variables: 9 | # 10 | # CC : the C compiler to use (default=gcc) 11 | # GICFLAGS : flags passed on to gic (e.g. the type checker to use) 12 | # OMP : set it to any value, to enable the OpenMP runtime 13 | # 14 | 15 | set -e 16 | 17 | # If optimization level is less than 2, add -falign-functions (required 18 | # for using tagged argument pointers). 19 | # CFLAGS="-I . -O1 -falign-functions -ggdb3" 20 | CFLAGS="-I . -O3 -ggdb3" 21 | # CFLAGS=-Wpadded 22 | 23 | # Use libgmp 24 | USE_GMP= 25 | # USE_GMP="-DHAS_GMP -lgmp" 26 | 27 | # Use libgc 7.2 @ greedy 28 | GC_INCLUDE="-I/var/tmp/gfour/gc-inst-7.2/include/" 29 | GC_LIB="-pthread /var/tmp/gfour/gc-inst-7.2/lib/libgc.a" 30 | # Use libgc @ ~ptheof 31 | # GC_INCLUDE="-I/home/ptheof/gc-inst/include" 32 | # GC_LIB=/home/ptheof/gc-inst/lib/libgc.a 33 | 34 | # If set, enables the shadow stack. 35 | # SSTACK="-DSSTACK" 36 | SSTACK= 37 | 38 | if [ "$CC" == "" ]; then 39 | CC=gcc 40 | fi 41 | 42 | if [ "$OMP" != "" ]; then 43 | # echo Using the OpenMP-based runtime. 44 | # USE_OMP="-DGC_REDIRECT_TO_LOCAL -DUSE_OMP -fopenmp -fsplit-stack" 45 | USE_OMP="-DGC_REDIRECT_TO_LOCAL -DUSE_OMP -fopenmp" 46 | else 47 | USE_OMP="" 48 | fi 49 | 50 | if [ "$GICFLAGS" = "" ]; then 51 | GICFLAGS="-ghc-tc" 52 | fi 53 | 54 | source find-gic.sh 55 | echo "Using GIC=${GIC}" 56 | 57 | ${GIC} ${GICFLAGS} -cl $* > /dev/null 58 | CMD="${CC} ${SSTACK} ${GC_INCLUDE} ${CFLAGS} ${USE_GMP} ${USE_OMP} main.c ${GC_LIB}" 59 | # echo $CMD 60 | $CMD 61 | ./a.out 62 | -------------------------------------------------------------------------------- /scomp-tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # Test the separate compilation features using the optimized LAR representation. 4 | # 5 | # The TC variable contains the type checker to use. For polymorphic examples, the 6 | # type checker of the GHC API is used. For examples with 'let', the built-in 7 | # type inference engine is used. 8 | # 9 | 10 | set -e 11 | 12 | # Use the built-in typechecker. 13 | export TC="-gic-tc" 14 | 15 | echo --- Separate compilation tests [lar-opt] --- 16 | echo -- [Example1] -- 17 | ./compile-link-mods.sh Examples/Modules/Example1/ModuleA Examples/Modules/Example1/Main 18 | echo -- [Example2] -- 19 | ./compile-link-mods.sh Examples/Modules/Example2/Lib Examples/Modules/Example2/Main 20 | echo -- [Example3] -- 21 | ./compile-link-mods.sh Examples/Modules/Example3/Lib Examples/Modules/Example3/Main 22 | echo -- [Example4] -- 23 | ./compile-link-mods.sh Examples/Modules/Example4/Lib Examples/Modules/Example4/Main 24 | -------------------------------------------------------------------------------- /scripts/diff_repr.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Test script that reads the results of the counter measurements, and generates the comparison tables. 4 | 5 | # Takes three parameters: the benchmark name, the representation, and the property to find. 6 | function progStats { 7 | # tail -n +6 $1_$2_stats.txt | head -n -3 | awk '{print $1,$2}' 8 | STATS_FILE=$1_$2_$3_stats.txt 9 | echo Reading stats file $STATS_FILE... > /dev/stderr 10 | # tail -n +6 $STATS_FILE | head -n -3 | cut -b 1-17,19-44,50-54,82-86 --output-delimiter=" " 11 | grep $3 $STATS_FILE | cut -b 1-17,19-44,50-54,82-86 --output-delimiter=" " 12 | } 13 | 14 | # Takes two parameters: the benchmark name and the property to find. 15 | function diffProg { 16 | BINARY=gic_$1 17 | echo -e \# Reading property \'$2\' of $BINARY... > /dev/stderr 18 | STATS_FULL=`progStats $BINARY "full" $2 | grep $2` 19 | STATS_COMPACT=`progStats $BINARY "compact" $2 | grep $2` 20 | # echo \# $STATS_FULL 21 | # echo \# $STATS_COMPACT 22 | if [ "$FIELD_TYPE" = "NUM" ] 23 | then 24 | # Print out the numerical values. 25 | FIELD_NUM_FULL=`echo -n $STATS_FULL | awk '{printf "%d", $1}'` 26 | FIELD_NUM_COMPACT=`echo -n $STATS_COMPACT | awk '{printf "%d", $1}'` 27 | echo -e $1 '\t' $FIELD_NUM_FULL '\t' $FIELD_NUM_COMPACT 28 | elif [ "$FIELD_TYPE" = "PERCENT" ] 29 | then 30 | # Print out the percent values. 31 | FIELD_PCENT_FULL=`echo -n $STATS_FULL | awk '{printf "%d.%d", $3, 44}'` 32 | FIELD_PCENT_COMPACT=`echo -n $STATS_COMPACT | awk '{printf "%d.%d", $3, $4}'` 33 | echo -e $1 '\t' $FIELD_PCENT_FULL '\t' $FIELD_PCENT_COMPACT 34 | else 35 | echo FIELD_TYPE is not set. > /dev/stderr 36 | exit 37 | fi 38 | } 39 | 40 | # Takes a single parameter, the property to measure. 41 | function diffProgs { 42 | echo benchmark GIC_full GIC_compact 43 | diffProg "ack" $1 44 | diffProg "collatz" $1 45 | diffProg "digits_of_e1" $1 46 | diffProg "fib" $1 47 | diffProg "ntak" $1 48 | diffProg "primes" $1 49 | diffProg "church" $1 50 | diffProg "queens" $1 51 | diffProg "queens_num" $1 52 | diffProg "quick_sort" $1 53 | diffProg "tree_sort" $1 54 | diffProg "reverse" $1 55 | } 56 | 57 | # Generates the table of side-by-side comparison between the two representations. 58 | function diffProperty { 59 | PROPERTY=$1 60 | FILE="diff_${PROPERTY}_${FIELD_TYPE}.txt" 61 | diffProgs $PROPERTY > $FILE 62 | # cat $FILE 63 | echo Results saved in $FILE. 64 | } 65 | 66 | FIELD_TYPE="NUM" 67 | diffProperty "L1-dcache-loads" 68 | diffProperty "L1-dcache-load-misses" 69 | diffProperty "L1-dcache-stores" 70 | diffProperty "L1-dcache-store-misses" 71 | diffProperty "L1-dcache-prefetches" 72 | diffProperty "L1-icache-loads" 73 | diffProperty "L1-icache-load-misses" 74 | diffProperty "LLC-loads" 75 | diffProperty "LLC-load-misses" 76 | diffProperty "LLC-stores" 77 | diffProperty "LLC-store-misses" 78 | diffProperty "dTLB-loads" 79 | diffProperty "dTLB-load-misses" 80 | diffProperty "dTLB-stores" 81 | diffProperty "dTLB-store-misses" 82 | diffProperty "iTLB-loads" 83 | diffProperty "iTLB-load-misses" 84 | diffProperty "branch-loads" 85 | diffProperty "branch-load-misses" 86 | diffProperty "cpu-cycles" 87 | diffProperty "instructions" 88 | diffProperty "cache-references" 89 | diffProperty "cache-misses" 90 | diffProperty "branch-instructions" 91 | diffProperty "branch-misses" 92 | diffProperty "bus-cycles" 93 | diffProperty "ref-cycles" 94 | FIELD_TYPE="PERCENT" 95 | diffProperty "L1-dcache-load-misses" 96 | diffProperty "L1-icache-load-misses" 97 | diffProperty "LLC-load-misses" 98 | diffProperty "dTLB-load-misses" 99 | diffProperty "iTLB-load-misses" 100 | diffProperty "cpu-cycles" 101 | diffProperty "instructions" 102 | diffProperty "cache-misses" 103 | diffProperty "branch-misses" 104 | -------------------------------------------------------------------------------- /scripts/measure_mem.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | # Measure the heap usage of the (already compiled) benchmarks. 3 | # Takes no parameters. 4 | 5 | import os 6 | from subprocess import Popen, PIPE 7 | try: 8 | from subprocess import DEVNULL # py3k 9 | except ImportError: 10 | import os 11 | DEVNULL = open(os.devnull, 'wb') 12 | 13 | VERBOSE = False 14 | 15 | def exitCode(program, mem): 16 | FNULL = open(os.devnull, 'w') 17 | process = Popen([program, str(mem*2)], stdout=DEVNULL, stderr=DEVNULL) 18 | # (output, err) = process.communicate() 19 | exit_code = process.wait() 20 | # print "Command output : ", output 21 | return exit_code 22 | 23 | def findMemory(program, mem, grain): 24 | if (grain<2): 25 | if (exitCode('./'+program, mem) == 0): 26 | return mem 27 | else: 28 | print "Could not find minimum heap size for "+program 29 | exit(-1) 30 | else: 31 | currMem = mem 32 | if (VERBOSE): 33 | print "Trying: "+str(currMem) 34 | while (exitCode('./'+program, currMem) == 0): 35 | currMem = currMem - grain 36 | if (VERBOSE): 37 | print "Trying again: "+str(currMem) 38 | return findMemory(program, currMem+grain, grain/10) 39 | 40 | def main(): 41 | print "Measuring memory..." 42 | 43 | benchmarks = ['collatz', 'digits_of_e1', 'ntak', 'church', 'queens', 'queens_num', 'quick_sort', 'tree_sort', 'reverse'] 44 | mem = {} 45 | 46 | for bench in benchmarks: 47 | mem[bench] = {} 48 | 49 | # Starting (approximate) heap sizes (multiply with 2 when using the two-space 50 | # collector). Some of the sizes below have already been set to their minimum 51 | # measured values (esp. for long-running benchmarks). Make them bigger to 52 | # measure them again. 53 | mem['collatz']['full'] = 41400000 54 | mem['collatz']['compact'] = 13500000 55 | mem['digits_of_e1']['full'] = 625000000 56 | mem['digits_of_e1']['compact'] = 195000000 57 | mem['ntak']['full'] = 11516398810 58 | mem['ntak']['compact'] = 3636757520 59 | mem['church']['full'] = 2250000 60 | mem['church']['compact'] = 700000 61 | mem['queens']['full'] = 1503132770 62 | mem['queens']['compact'] = 498798920 63 | mem['queens_num']['full'] = 8500 64 | mem['queens_num']['compact'] = 2750 65 | mem['quick_sort']['full'] = 2788938330 66 | mem['quick_sort']['compact'] = 875448910 67 | mem['reverse']['full'] = 685380260 68 | mem['reverse']['compact'] = 216432080 69 | mem['tree_sort']['full'] = 1652780690 70 | mem['tree_sort']['compact'] = 525870220 71 | 72 | for bench in benchmarks: 73 | meas = {} 74 | for repr in ['full', 'compact']: 75 | program = 'gic_'+bench+'_'+repr 76 | m = mem[bench][repr] 77 | if (VERBOSE): 78 | print "Measuring memory for", bench, "representation =",repr, "program =",program,"start =",m 79 | memDigits = len(str(m)) 80 | meas[repr] = findMemory(program, m, 10**(memDigits-1)) 81 | mFull = meas['full'] 82 | mCompact = meas['compact'] 83 | reduction = (float(mFull) - float(mCompact))/float(mFull) 84 | print '* program: '+bench+', full='+str(mFull)+', compact='+str(mCompact)+', reduction = '+str(reduction)+'%' 85 | 86 | main() 87 | 88 | # Results: 89 | # * program: collatz, full=41360250, compact=13200080, reduction = 0.680851058686% 90 | # * program: digits_of_e1, full=602368070, compact=192246560, reduction = 0.680848687747% 91 | # * program: ntak, full=11516398810, compact=3636757520, reduction = 0.684210526224% 92 | # * program: church, full=2198570, compact=672690, reduction = 0.694032939593% 93 | # * program: queens, full=1503132770, compact=498798920, reduction = 0.668160438016% 94 | # * program: queens_num, full=8140, compact=2600, reduction = 0.68058968059% 95 | # * program: quick_sort, full=2788938330, compact=875448910, reduction = 0.686099581126% 96 | # * program: tree_sort, full=1652780690, compact=525870220, reduction = 0.681826982139% 97 | # * program: reverse, full=685380260, compact=216432080, reduction = 0.684216058397% 98 | -------------------------------------------------------------------------------- /scripts/perf-greedy.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # perf stat -e L1-dcache-loads,L1-dcache-load-misses,L1-dcache-stores,L1-dcache-store-misses,L1-dcache-prefetches,L1-icache-loads,L1-icache-load-misses,LLC-loads,LLC-load-misses,LLC-stores,LLC-store-misses,dTLB-loads,dTLB-load-misses,dTLB-stores,dTLB-store-misses,iTLB-loads,iTLB-load-misses,branch-loads,branch-load-misses,cpu-cycles,instructions,cache-references,cache-misses,branch-instructions,branch-misses,bus-cycles,ref-cycles -o $2_$1_stats.txt $2 3 | if [ "$1" == "" ] || [ "$2" == "" ] 4 | then 5 | echo -e Usage: perf-greedy \ \ 6 | echo -e Run \'perf list\' to see the properties available. 7 | else 8 | # Check if the property depends on another property for percent counts and set EXTRA. 9 | case "$1" in 10 | branch-misses) 11 | EXTRA=",branch-instructions" 12 | ;; 13 | dTLB-load-misses) 14 | EXTRA=",dTLB-loads" 15 | ;; 16 | iTLB-load-misses) 17 | EXTRA=",iTLB-loads" 18 | ;; 19 | L1-icache-load-misses) 20 | EXTRA=",L1-icache-loads" 21 | ;; 22 | cache-misses) 23 | EXTRA=",cache-references" 24 | ;; 25 | instructions) 26 | EXTRA=",cpu-cycles" 27 | ;; 28 | L1-dcache-load-misses) 29 | EXTRA=",L1-dcache-loads" 30 | ;; 31 | LLC-load-misses) 32 | EXTRA=",LLC-loads" 33 | ;; 34 | esac 35 | perf stat -e $1$EXTRA -o $2_$1_stats.txt $2 36 | fi 37 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-9.14 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.4" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /testLangs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # Compiler sanity check, tests the following: 4 | # (1) The C (LAR) back-end: tagged Susp values, the -enum transformation, 5 | # numerical and data benchmarks, polymorphism (including GADTs), 6 | # the OpenMP-based runtime, and arbitrary precision integers (with libgmp). 7 | # The tests use the lar_opt.h representation and garbage collection with libgc. 8 | # (2) The 0-order call-by-name interpreter (intensional with context dictionaries). 9 | # (3) The FL non-strict interpreter (with non-strict activation records). 10 | # (4) The 0-order lazy eduction interpreter (intensional with a warehouse). 11 | # 12 | 13 | GHCI_FLAGS="-v0 -w -XGADTs" 14 | 15 | export GICFLAGS="-gic-tc" 16 | source find-gic.sh 17 | echo "Using GIC=${GIC}" 18 | 19 | if [ -x "$(command -v stack)" ]; then 20 | GHCI=`stack path --compiler-bin`/ghci 21 | else 22 | GHCI="ghci" 23 | fi 24 | echo "Using GHCI=${GHCI}" 25 | 26 | ############# Test tags 27 | 28 | echo Testing -tag... 29 | TAG_EXAMPLE=Examples/Data/example2.hs 30 | CFLAGS2="-DUSE_TAGS" ./run_lar.sh -tag ${TAG_EXAMPLE} 31 | echo "result" | ${GHCI} ${GHCI_FLAGS} ${TAG_EXAMPLE} 32 | unset CFLAGS2 33 | 34 | ############# Test -enum type transformation 35 | 36 | echo Testing -enum... 37 | TAG_EXAMPLE=Examples/Data/example2.hs 38 | CC=gcc ./run_lar.sh -enum ${TAG_EXAMPLE} 39 | echo "result" | ${GHCI} ${GHCI_FLAGS} ${TAG_EXAMPLE} 40 | 41 | ############# Test arbitrary precision integers 42 | 43 | echo Testing Integer... 44 | INTEGER_EXAMPLE=Examples/Num/bigints.hs 45 | INTEGER_EXAMPLE2=${INTEGER_EXAMPLE}.x.hs 46 | echo ${INTEGER_EXAMPLE}, LAR: 47 | CC=gcc ./run_lar.sh -gic-tc-nsig ${INTEGER_EXAMPLE} 48 | echo -n ${INTEGER_EXAMPLE}, GHCi: 49 | # replace custom multiplication operator with * for GHC 50 | cat ${INTEGER_EXAMPLE} | sed -e "s/\`mulI\`/*/" > ${INTEGER_EXAMPLE2} 51 | echo "result" | ${GHCI} ${GHCI_FLAGS} ${INTEGER_EXAMPLE2} 52 | rm ${INTEGER_EXAMPLE2} 53 | 54 | ############# Tests the TTD emulator 55 | 56 | echo -- TTD emulator -- 57 | for file in Examples/Num/exmh1.hs Examples/Num/memoize.hs Examples/Data/example1.hs Examples/Data/example2.hs 58 | do 59 | echo -n ${file}, TTD emulator:\ 60 | ${GIC} ${GICFLAGS} -ettd -workers 100 ${file} 61 | echo -n ${file}, GHCi:\ 62 | echo "result" | ${GHCI} ${GHCI_FLAGS} ${file} 63 | done 64 | 65 | ############# Tests the call-by-name eduction interpreter 66 | 67 | echo -- Call-by-name eduction -- 68 | for file in Examples/Num/memoize.hs Examples/Data/example1.hs Examples/Data/addsx.hs Examples/Data/biglist.hs Examples/Data/records.hs Examples/Data/unit.hs 69 | do 70 | echo -n ${file}, call-by-name eduction:\ 71 | ${GIC} ${GICFLAGS} -ecbn ${file} 72 | echo -n ${file}, GHCi:\ 73 | echo "result" | ${GHCI} ${GHCI_FLAGS} ${file} 74 | done 75 | 76 | ############# Tests the non-strict FL interpreter 77 | 78 | echo -- Non-strict FL interpreter -- 79 | for file in Examples/Num/memoize.hs Examples/Data/example1.hs Examples/Data/addsx.hs Examples/Data/biglist.hs Examples/Data/records.hs Examples/Data/unit.hs Examples/Data/addsx.hs 80 | do 81 | echo -n ${file}, non-strict FL interpreter:\ 82 | ${GIC} ${GICFLAGS} -fl ${file} 83 | echo -n ${file}, GHCi:\ 84 | echo "result" | ${GHCI} ${GHCI_FLAGS} ${file} 85 | done 86 | 87 | ############# Tests the lazy eduction interpreter 88 | 89 | echo -- Lazy eduction -- 90 | for file in Examples/Num/memoize.hs Examples/Data/example1.hs Examples/Data/addsx.hs Examples/Data/biglist.hs Examples/Data/nested.hs Examples/Data/records.hs Examples/Data/unit.hs 91 | do 92 | echo -n ${file}, lazy eduction:\ 93 | ${GIC} ${GICFLAGS} -e ${file} 94 | echo -n ${file}, GHCi:\ 95 | echo "result" | ${GHCI} ${GHCI_FLAGS} ${file} 96 | done 97 | 98 | ############# Compares the results from the LAR back-end against those from GHCi 99 | 100 | ulimit -s 262143 101 | 102 | function testLAR { 103 | #echo Testing file ${file}... 104 | 105 | echo -n $1, GHCi\ \ \ \ \ \ :\ 106 | echo "result" | ${GHCI} ${GHCI_FLAGS} $1 107 | 108 | # echo -n $1, LAR, libgc:\ 109 | # ./run_libgc.sh $1 110 | # echo -n $1, LAR, semi:\ 111 | # ./run_lar.sh -mem 1280000000 $1 112 | echo -n $1, LAR, compact-semi:\ 113 | CFLAGS2="-w" ./run_lar.sh -mem 2280000000 -tco -compact $1 114 | } 115 | 116 | # Use the single-threaded runtime. 117 | unset OMP 118 | 119 | echo -- LAR -- 120 | 121 | echo -- 1. Simple types -- 122 | export GICFLAGS="-gic-tc-nsig" 123 | for file in Examples/Num/exmh*.hs Examples/Num/myex*.hs Examples/Data/*.hs 124 | do 125 | testLAR ${file} 126 | done 127 | 128 | echo -- 2. Polymorphic -- 129 | # Use the type checker of the GHC API and explicit type signatures. 130 | export GICFLAGS=-ghc-tc 131 | for file in Examples/Polymorphic/*.hs 132 | do 133 | testLAR ${file} 134 | done 135 | 136 | echo -- 3. GADTs -- 137 | export GICFLAGS=-ghc-tc 138 | for file in Examples/GADT/*.hs 139 | do 140 | testLAR ${file} 141 | done 142 | 143 | echo -- 4. Parallel -- 144 | 145 | # Use the built-in type checker, ignore type signatures. 146 | export GICFLAGS=-gic-tc-nsig 147 | # Use the OpenMP-based runtime. 148 | export OMP=1 149 | GHCIFLAGS="${GHCIFLAGS} -threaded" 150 | for file in Examples/Parallel/*.hs 151 | do 152 | testLAR ${file} 153 | done 154 | --------------------------------------------------------------------------------