From e842bccf2c7fd3953c56a5ad5b2903981ef9d5d4 Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Thu, 6 Jul 2023 09:56:08 +0100 Subject: [PATCH] Examples of GHC compatibility --- examples/README.md | 13 + examples/ghc.patch | 701 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 714 insertions(+) create mode 100644 examples/ghc.patch diff --git a/examples/README.md b/examples/README.md index fb74e33d..54fa61c5 100644 --- a/examples/README.md +++ b/examples/README.md @@ -89,3 +89,16 @@ Graphs produced by [`benchmark.py`](benchmark/benchmark.py) therefore show the i Run `benchmark.py -h` for usage information. By default, it will read/write `data.{csv,pdf}` - you can change this with e.g. `benchmark.py --filestem foo` to read/write `foo.{csv,pdf}`. To compile all benchmarks specified in [`bench.config`](benchmark/bench.config) *without* running them, use `benchmark.py --mode compile`. + +## Compiling programs with GHC + +PureLang resembles a subset of Haskell, so PureLang programs are accepted by GHC with minimal changes. +The diff [`ghc.patch`](./ghc.patch) demonstrates these changes on some examples, and can be applied as follows: +``` +git apply ghc.patch +``` +The changes mostly: +- reconcile PureLang/GHC I/O and monads, including converting PureLang's `Array` to GHC's `IOArray` +- adapt PureLang primitives to GHC - including appropriate casts between `Int`/`Integer` +- use functions from GHC's `Prelude` rather than manually defining them + diff --git a/examples/ghc.patch b/examples/ghc.patch new file mode 100644 index 00000000..d8971d56 --- /dev/null +++ b/examples/ghc.patch @@ -0,0 +1,701 @@ +diff --git a/examples/gameOfLife.hs b/examples/gameOfLife.hs +index aad3abf..9bff1c9 100644 +--- a/examples/gameOfLife.hs ++++ b/examples/gameOfLife.hs +@@ -1,13 +1,13 @@ + -- Game of Life example ++import System.Environment + + main :: IO () + main = do +- arg1 <- read_arg1 +- let n = fromString arg1 ++ args <- getArgs ++ let n = read $ head args + parsed = parse circuit + result = step n parsed + printGOL result +- Ret () + + circuit :: String + -- This circuit consists of a 100x100 grid containing 5 Gosper guns. The +@@ -73,7 +73,7 @@ nextCell x1 x2 x3 + z1 z2 z3 = + let sum = x1 + x2 + x3 + y1 + 0 + y3 + z1 + z2 + z3 in + if y2 == 0 then if sum == 3 then 1 else 0 +- else if or (sum == 2) (sum == 3) then 1 else 0 ++ else if (sum == 2) || (sum == 3) then 1 else 0 + + + -- Parsing and printing +@@ -83,26 +83,27 @@ parse s = + let width = 102 + in map (pad width 0) $ split $ expand s + ++ + expand :: String -> String + expand s = + let expandAux idx count = +- if strlen s < idx + 1 then "" else ++ if toInteger (length s) < idx + 1 then "" else + let e = str_elem s idx +- in if and (47 < e) (e < 58) then expandAux (idx + 1) (count * 10 + e - 48) +- else (implode $ replicate (max 1 count) e) ++ (expandAux (idx + 1) 0) ++ in if (47 < e) && (e < 58) then expandAux (idx + 1) (count * 10 + e - 48) ++ else replicate (max 1 $ fromInteger count) (toEnum $ fromInteger e) ++ (expandAux (idx + 1) 0) + in expandAux 0 0 + + split :: String -> [[Integer]] + split s = + let splitAux idx acc = +- if strlen s < idx + 1 then [] else ++ if toInteger (length s) < idx + 1 then [] else + let e = str_elem s idx in + if e == 33 then [reverse acc] -- check for '!' + else if e == 36 then reverse acc : splitAux (idx + 1) [] -- check for '$' + else splitAux (idx + 1) ((if e == 111 then 1 else 0) : acc) -- check for 'b'/'o' + in splitAux 0 [] + +-printGOL :: [[Integer]] -> IO String ++printGOL :: [[Integer]] -> IO () + printGOL l = + let rowToString l = case l of [] -> "" + h:t -> if h == 0 then "-" ++ rowToString t +@@ -122,94 +123,14 @@ hd :: [Integer] -> Integer + hd l = case l of [] -> 0 + h:t -> h + +- +--- Standard functions +- +-f $ x = f x +- +-or :: Bool -> Bool -> Bool +-or b1 b2 = case b1 of True -> True +- False -> b2 +- +-and :: Bool -> Bool -> Bool +-and b1 b2 = case b1 of False -> False +- True -> b2 +- +-max :: Integer -> Integer -> Integer +-max x y = if x < y then y else x +- + tl :: [a] -> [a] + tl l = case l of [] -> [] + h:t -> t + +-length :: [a] -> Integer +-length l = case l of [] -> 0 +- h:t -> 1 + length t +- +-map :: (a -> b) -> [a] -> [b] +-map f l = case l of [] -> [] +- h:t -> f h : map f t +- +-reverse :: [a] -> [a] +-reverse l = +- let revA a l = case l of [] -> a +- h:t -> revA (h:a) t +- in revA [] l +- +-append :: [a] -> [a] -> [a] +-append l r = case l of [] -> r +- h:t -> h : append t r +- +-replicate :: Integer -> a -> [a] +-replicate n a = if n < 1 then [] else a : replicate (n - 1) a +- ++str_elem :: String -> Integer -> Integer ++str_elem s i = toInteger $ fromEnum $ s !! (fromInteger i) + + pad :: Integer -> a -> [a] -> [a] +-pad n a l = append l $ replicate (n - length l) a +- +- +--- I/O helpers +- +-fromDigit :: String -> Integer -> Integer +-fromDigit s i = str_elem s i - 48 +- +-fromString :: String -> Integer +-fromString s = +- let fromStringI i limit acc s = +- if limit == i then acc +- else if limit < i then acc +- else +- fromStringI (i + 1) limit (acc * 10 + fromDigit s i) s +- in fromStringI 0 (strlen s) 0 s +- +-toString :: Integer -> String +-toString i = +- let toString0 i = +- if i == 0 then [] +- else (i `mod` 10 + 48) : toString0 (i `div` 10) +- in if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) +- else if i == 0 then "0" +- else implode $ reverse $ toString0 i +- +-implode l = +- case l of +- [] -> "" +- h:t -> #(__Implode) h ++ implode t +- +-read_arg1 = Act (#(cline_arg) " ") +- +-print s = Act (#(stdout) (s ++ "\n")) +- +- +--- Overloads +- +-s1 ++ s2 = #(__Concat) s1 s2 +- +-str_elem :: String -> Integer -> Integer +-str_elem s i = #(__Elem) s i ++pad n a l = l ++ replicate (fromInteger n - length l) a + +-strlen :: String -> Integer +-strlen s = #(__Len) s + +-str_eq :: String -> String -> Bool +-str_eq s1 s2 = #(__StrEq) s1 s2 +diff --git a/examples/maxCollatzSequence.hs b/examples/maxCollatzSequence.hs +index b1f7654..0227f42 100644 +--- a/examples/maxCollatzSequence.hs ++++ b/examples/maxCollatzSequence.hs +@@ -1,18 +1,19 @@ + -- Calculate longest Collatz sequence less than n (inefficiently, i.e. w/o memo) + -- import Prelude hiding (map, take) ++import System.Environment + + main :: IO () + main = do +- arg1 <- read_arg1 +- let n = fromString arg1 +- print $ "Finding longest Collatz sequence less than " ++ toString n ++ args <- getArgs ++ let n = read $ head args ++ print $ "Finding longest Collatz sequence less than " ++ show n + let res = maxCollatzSequence n +- print $ "Number with longest sequence: " ++ toString (fst res) +- print $ "Length of sequence: " ++ toString (snd res) +- Ret () ++ print $ "Number with longest sequence: " ++ show (fst res) ++ print $ "Length of sequence: " ++ show (snd res) ++ return () + + maxCollatzSequence :: Integer -> (Integer, Integer) +-maxCollatzSequence n = maxIndex (take n collatzSequences) ++maxCollatzSequence n = maxIndex (take (fromInteger n) collatzSequences) + + collatzSequences :: [Integer] + collatzSequences = map collatzSequence (numbers 0) +@@ -42,59 +43,4 @@ maxIndex l = + else maxAux maxIdx maxElem (idx + 1) t + in maxAux (0-1) (0-1) 0 l + +-map :: (a -> b) -> [a] -> [b] +-map f l = case l of [] -> [] +- h:t -> f h : map f t +- +-take :: Integer -> [a] -> [a] +-take n l = +- if n < 1 then [] +- else case l of [] -> [] +- h:t -> h : take (n - 1) t +- +-fst :: (a, b) -> a +-fst p = case p of (a,b) -> a +- +-snd :: (a, b) -> b +-snd p = case p of (a,b) -> b +- +- +--- I/O helpers +- +-f $ x = f x +- +-s1 ++ s2 = #(__Concat) s1 s2 +- +-reverse :: [a] -> [a] +-reverse l = +- let revA a l = case l of [] -> a +- h:t -> revA (h:a) t +- in revA [] l +- +-fromString :: String -> Integer +-fromString s = +- let fromStringI i limit acc s = +- if limit == i then acc +- else if limit < i then acc +- else +- fromStringI (i + 1) limit (acc * 10 + (#(__Elem) s i - 48)) s +- in fromStringI 0 (#(__Len) s) 0 s +- +-toString :: Integer -> String +-toString i = +- let toString0 i = +- if i == 0 then [] +- else (i `mod` 10 + 48) : toString0 (i `div` 10) +- in if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) +- else if i == 0 then "0" +- else implode $ reverse $ toString0 i +- +-implode l = +- case l of +- [] -> "" +- h:t -> #(__Implode) h ++ implode t +- +-read_arg1 = Act (#(cline_arg) " ") +- +-print s = Act (#(stdout) (s ++ "\n")) + +diff --git a/examples/primes.hs b/examples/primes.hs +index 3f02043..2198434 100644 +--- a/examples/primes.hs ++++ b/examples/primes.hs +@@ -1,15 +1,15 @@ + -- Primality testing using two methods ++import System.Environment + + main :: IO () + main = do +- arg1 <- read_arg1 +- let n = fromString arg1 +- print $ "Finding prime no. " ++ toString n ++ args <- getArgs ++ let n = read $ head args ++ print $ "Finding prime no. " ++ show n + let a = primeA n + b = primeB n +- print $ "Sieve of Eratosthenes: " ++ toString a +- print $ "Divisor testing: " ++ toString b +- Ret () ++ print $ "Sieve of Eratosthenes: " ++ show a ++ print $ "Divisor testing: " ++ show b + + + -- Method 1: sieve of Eratosthenes +@@ -23,7 +23,7 @@ primesA = + in sieve $ numbers 2 + + primeA :: Integer -> Integer +-primeA n = idx n primesA ++primeA n = primesA !! fromInteger n + + + -- Method 2: divisor testing +@@ -39,81 +39,8 @@ primesB :: [Integer] + primesB = filter isPrime $ numbers 2 + + primeB :: Integer -> Integer +-primeB n = idx n primesB +- +- +--- Helper functions +- +-f $ x = f x +- +-not :: Bool -> Bool +-not b = case b of True -> False +- False -> True +- +-filter :: (a -> Bool) -> [a] -> [a] +-filter f l = +- case l of +- [] -> [] +- h:t -> if f h then h : filter f t +- else filter f t +- +-idx :: Integer -> [Integer] -> Integer +-idx n l = +- case l of +- [] -> ~1 -- should not happen +- h:t -> if n == 0 then h else idx (n - 1) t ++primeB n = primesB !! fromInteger n + + numbers :: Integer -> [Integer] + numbers n = n : numbers (n + 1) + +- +--- I/O helpers +- +-reverse :: [a] -> [a] +-reverse l = +- let revA a l = case l of [] -> a +- h:t -> revA (h:a) t +- in revA [] l +- +-fromString :: String -> Integer +-fromString s = +- let fromStringI i limit acc s = +- if limit == i then acc +- else if limit < i then acc +- else +- fromStringI (i + 1) limit (acc * 10 + (str_elem s i - 48)) s +- in fromStringI 0 (strlen s) 0 s +- +-toString :: Integer -> String +-toString i = +- let toString0 i = +- if i == 0 then [] +- else (i `mod` 10 + 48) : toString0 (i `div` 10) +- in if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) +- else if i == 0 then "0" +- else implode $ reverse $ toString0 i +- +-implode l = +- case l of +- [] -> "" +- h:t -> #(__Implode) h ++ implode t +- +-read_arg1 = Act (#(cline_arg) " ") +- +-print s = Act (#(stdout) (s ++ "\n")) +- +- +--- Overloads +- +-s1 ++ s2 = #(__Concat) s1 s2 +- +-str_elem :: String -> Integer -> Integer +-str_elem s i = #(__Elem) s i +- +-strlen :: String -> Integer +-strlen s = #(__Len) s +- +- +- +- +- +diff --git a/examples/queens.hs b/examples/queens.hs +index d1ac747..f6940ab 100644 +--- a/examples/queens.hs ++++ b/examples/queens.hs +@@ -1,15 +1,14 @@ + -- Compute number of N-Queens solutions (brute force) + -- adapted from albertnetymk.github.io +- ++import System.Environment + + main :: IO () + main = do +- arg1 <- read_arg1 +- let n = fromString arg1 +- print $ "Finding no. N-Queens solutions for board size " ++ toString n ++ args <- getArgs ++ let n = read $ head args ++ print $ "Finding no. N-Queens solutions for board size " ++ show n + let boards = queens n +- print $ "No. solutions: " ++ toString (length boards) +- Ret () ++ print $ "No. solutions: " ++ show (length boards) + + queens :: Integer -> [[Integer]] + queens n = +@@ -33,77 +32,11 @@ queens n = + + in iter [[]] 0 + +-printBoard :: [[Integer]] -> IO String ++printBoard :: [[Integer]] -> IO () + printBoard l = + let rowToString l = case l of [] -> "" +- h:t -> toString h ++ rowToString t ++ h:t -> show h ++ rowToString t + boardToString l = case l of [] -> "" + h:t -> rowToString h ++ "\n" ++ boardToString t + in print (boardToString l) + +- +--- Helper functions +- +-and :: [Bool] -> Bool +-and l = case l of [] -> True +- h:t -> if h then and t else False +- +-not :: Bool -> Bool +-not b = case b of True -> False +- False -> True +- +-length :: [a] -> Integer +-length l = case l of [] -> 0 +- h:t -> 1 + length t +- +-append :: [a] -> [a] -> [a] +-append l1 l2 = case l1 of [] -> l2 +- h:t -> h : append t l2 +- +-foldr :: (a -> b -> b) -> b -> [a] -> b +-foldr f acc l = case l of [] -> acc +- h:t -> f h (foldr f acc t) +- +-concatMap :: (a -> [b]) -> [a] -> [b] +-concatMap f = foldr (\a -> append (f a)) [] +- +- +--- I/O helpers +- +-f $ x = f x +- +-s1 ++ s2 = #(__Concat) s1 s2 +- +-reverse :: [a] -> [a] +-reverse l = +- let revA a l = case l of [] -> a +- h:t -> revA (h:a) t +- in revA [] l +- +-fromString :: String -> Integer +-fromString s = +- let fromStringI i limit acc s = +- if limit == i then acc +- else if limit < i then acc +- else +- fromStringI (i + 1) limit (acc * 10 + (#(__Elem) s i - 48)) s +- in fromStringI 0 (#(__Len) s) 0 s +- +-toString :: Integer -> String +-toString i = +- let toString0 i = +- if i == 0 then [] +- else (i `mod` 10 + 48) : toString0 (i `div` 10) +- in if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) +- else if i == 0 then "0" +- else implode $ reverse $ toString0 i +- +-implode l = +- case l of +- [] -> "" +- h:t -> #(__Implode) h ++ implode t +- +-read_arg1 = Act (#(cline_arg) " ") +- +-print s = Act (#(stdout) (s ++ "\n")) +- +diff --git a/examples/quicksort.hs b/examples/quicksort.hs +index aad9456..8e87014 100644 +--- a/examples/quicksort.hs ++++ b/examples/quicksort.hs +@@ -1,20 +1,20 @@ + -- Simple functional and imperative quicksort + -- import Prelude hiding (and) ++import System.Environment ++import GHC.IOArray + + main :: IO () + main = do +- arg1 <- read_arg1 +- let n = fromString arg1 +- printOnly $ "Sorting the *list* [" ++ toString n ++ "..0]... " ++ args <- getArgs ++ let n = read $ head args ++ print $ "Sorting the *list* [" ++ show n ++ "..0]... " + let res = qsortList (numbersList n) + print $ if isSortedList res then "Success!" else "Failure :(" +- printOnly $ "Sorting the *array* [" ++ toString n ++ "..0]... " ++ print $ "Sorting the *array* [" ++ show n ++ "..0]... " + a <- numbersArray n +- len <- Length a + qsortArray a + ok <- isSortedArray a + print $ if ok then "Success!" else "Failure :(" +- Ret () + + + -- Functional quicksort +@@ -27,7 +27,7 @@ qsortList l = + let parts = partitionList h t + in case parts of + (less, greaterEq) -> +- append (qsortList less) (h : qsortList greaterEq) ++ (qsortList less) ++ (h : qsortList greaterEq) + + + partitionList :: Integer -> [Integer] -> ([Integer],[Integer]) +@@ -44,58 +44,48 @@ partitionList pivot l = + + -- Imperative quicksort + +-qsortArray :: Array Integer -> IO () ++qsortArray :: IOArray Integer Integer -> IO () + qsortArray a = + let qsortAux a lo hi = +- if lo < 0 then Ret () +- else if hi < lo + 1 then Ret () ++ if lo < 0 then return () ++ else if hi < lo + 1 then return () + else do + pivot <- partitionArray a lo hi + qsortAux a lo (pivot - 1) + qsortAux a (pivot + 1) hi + in do +- len <- Length a ++ let len = snd (boundsIOArray a) + qsortAux a 0 (len - 1) + + +-partitionArray :: Array Integer -> Integer -> Integer -> IO Integer ++partitionArray :: IOArray Integer Integer -> Integer -> Integer -> IO Integer + partitionArray a lo hi = do +- pivotElem <- Deref a hi ++ pivotElem <- readIOArray a hi + let loop i j = do + if j < hi then do +- jElem <- Deref a j ++ jElem <- readIOArray a j + if jElem < pivotElem + 1 then do + do swap a (i + 1) j ; loop (i + 1) (j + 1) + else loop i (j + 1) +- else Ret i ++ else return i + i <- loop (lo - 1) lo + swap a (i + 1) hi +- Ret (i + 1) ++ return (i + 1) + +-swap :: Array a -> Integer -> Integer -> IO () ++swap :: IOArray Integer a -> Integer -> Integer -> IO () + swap a i j = do +- iElem <- Deref a i +- jElem <- Deref a j +- Update a i jElem +- Update a j iElem ++ iElem <- readIOArray a i ++ jElem <- readIOArray a j ++ writeIOArray a i jElem ++ writeIOArray a j iElem + + + -- List helper functions + +-append :: [a] -> [a] -> [a] +-append l1 l2 = case l1 of [] -> l2 +- h:t -> h : append t l2 +- + numbersList :: Integer -> [Integer] + numbersList n = if n < 0 then [] + else n : numbersList (n - 1) + +--- numbersList :: Integer -> [Integer] +--- numbersList n = +--- let numbersAux current = +--- if current < n then current : numbersAux (current + 1) else [] +--- in if n < 0 then [] else numbersAux 0 +- + isSortedList :: [Integer] -> Bool + isSortedList l = + let sortedAux last l = +@@ -108,91 +98,48 @@ isSortedList l = + + -- Array helper functions + +-numbersArray :: Integer -> IO (Array Integer) ++numbersArray :: Integer -> IO (IOArray Integer Integer) + numbersArray n = + let length = if n < 0 then 0 else n + fill a next remaining = +- if remaining == 0 then Ret () ++ if remaining == 0 then return () + else do +- Update a next remaining ++ writeIOArray a next remaining + fill a (next + 1) (remaining - 1) + in do +- a <- Alloc length 0 ++ a <- newIOArray (0, length) 0 + fill a 0 length +- Ret a ++ return a + +-isSortedArray :: Array Integer -> IO Bool ++isSortedArray :: IOArray Integer Integer -> IO Bool + isSortedArray a = + let loop lastElem nextIdx len = + if nextIdx < len then do +- nextElem <- Deref a nextIdx ++ nextElem <- readIOArray a nextIdx + if lastElem < nextElem + 1 then + loop nextElem (nextIdx + 1) len +- else Ret False +- else Ret True ++ else return False ++ else return True + in do +- len <- Length a +- if len < 1 then Ret True else do +- first <- Deref a 0 ++ let len = snd (boundsIOArray a) ++ if len < 1 then return True else do ++ first <- readIOArray a 0 + loop first 1 len + +-printArray :: Array Integer -> IO () ++printArray :: IOArray Integer Integer -> IO () + printArray a = + let printAux i len = + if i < len then do +- elem <- Deref a i +- printOnly (toString elem) ++ elem <- readIOArray a i ++ putStr (show elem) + if i < len - 1 then +- do printOnly ", " ; Ret () +- else Ret () ++ do putStr ", " ; return () ++ else return () + printAux (i + 1) len +- else Ret () ++ else return () + in do +- printOnly "[" +- len <- Length a ++ putStr "[" ++ let len = snd (boundsIOArray a) + printAux 0 len +- printOnly "]\n" +- Ret () +- +- +--- I/O helpers +- +-f $ x = f x +- +-s1 ++ s2 = #(__Concat) s1 s2 +- +-reverse :: [a] -> [a] +-reverse l = +- let revA a l = case l of [] -> a +- h:t -> revA (h:a) t +- in revA [] l +- +-fromString :: String -> Integer +-fromString s = +- let fromStringI i limit acc s = +- if limit == i then acc +- else if limit < i then acc +- else +- fromStringI (i + 1) limit (acc * 10 + (#(__Elem) s i - 48)) s +- in fromStringI 0 (#(__Len) s) 0 s +- +-toString :: Integer -> String +-toString i = +- let toString0 i = +- if i == 0 then [] +- else (i `mod` 10 + 48) : toString0 (i `div` 10) +- in if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) +- else if i == 0 then "0" +- else implode $ reverse $ toString0 i +- +-implode l = +- case l of +- [] -> "" +- h:t -> #(__Implode) h ++ implode t +- +-read_arg1 = Act (#(cline_arg) " ") +- +-printOnly s = Act (#(stdout) s) +- +-print s = Act (#(stdout) (s ++ "\n")) ++ putStr "]\n" +