WIPHEADmaster

12 files changed, 187 insertions, 7 deletions

diff --git a/.gitignore b/.gitignore
index f8862b3..0f8ab09 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,2 +1,3 @@
 dist-newstyle/
-test
+output
+mandel.ppm
diff --git a/Language/C.hs b/Language/C.hs
index 9a65115..8b2a9d5 100644
--- a/Language/C.hs
+++ b/Language/C.hs
@@ -44,6 +44,9 @@ data Stmt
     | SCall Name [Expr]
     -- | @SFor ty i lo hi body@: @for (ty i = lo; i < hi; i++) body@
     | SFor Type Name Expr Expr [Stmt]
+    -- | @SWhile pre cond post@: @while (true) { pre; if (!cond) break; post; }@
+    -- Special case if @pre == []@: @while (cond) { post; }
+    | SWhile [Stmt] Expr [Stmt]
     | SIf Expr [Stmt] [Stmt]
   deriving (Show, Eq)
 
@@ -56,6 +59,7 @@ data Expr
     | EIndex Name Expr
     | EPtrTo Expr
     | ESizeOf Type
+    | ECast Type Expr
   deriving (Show, Eq)
 
 
diff --git a/Language/C/Print.hs b/Language/C/Print.hs
index 5852601..3d7688c 100644
--- a/Language/C/Print.hs
+++ b/Language/C/Print.hs
@@ -50,10 +50,14 @@ printType = printString . showType
         printBits B64 = "64"
 
 printBlock :: [Stmt] -> PrintS
-printBlock ss =
-    printString "{\n  "
-    % addIndent 2 (intercalates "\n" (map printStmt ss))
-    % printString "\n}"
+printBlock ss = printBlock' (intercalates "\n" (map printStmt ss))
+
+printBlock' :: PrintS -> PrintS
+printBlock' body =
+    getIndent $ \d ->
+        printString ("{\n" ++ replicate (d + 2) ' ')
+        % addIndent 2 body
+        % printString "\n}"
 
 printStmt :: Stmt -> PrintS
 printStmt (SDecl ty name rhs) =
@@ -75,6 +79,13 @@ printStmt (SFor ty name lo hi body) =
     % printString "; "
     % printName name % printString "++) "
     % printBlock body
+printStmt (SWhile [] cond body) =
+    printString "while (" % printExpr cond % printString ") " % printBlock body
+printStmt (SWhile pre cond post) =
+    printString "while (true) "
+    % printBlock' (intercalates "\n" (map printStmt pre)
+                   % printString "\nif (" % printExpr cond % printString ") break;\n"
+                   % intercalates "\n" (map printStmt post))
 printStmt (SIf e b1 b2) =
     printString "if (" % printExpr e % printString ") "
     % printBlock b1 % printString " else " % printBlock b2
@@ -93,6 +104,7 @@ printExpr (ECall name args) =
 printExpr (EIndex name e) = printName name % printString "[" % printExpr e % printString "]"
 printExpr (EPtrTo e) = printString "&(" % printExpr e % printString ")"
 printExpr (ESizeOf t) = printString "(sizeof (" % printType t % printString "))"
+printExpr (ECast t e) = printString "(" % printType t % printString ")(" % printExpr e % printString ")"
 
 
 addIndent :: Int -> PrintS -> PrintS
@@ -101,6 +113,9 @@ addIndent plusd f d = f (d + plusd)
 withIndent :: Int -> PrintS -> PrintS
 withIndent d f _ = f d
 
+getIndent :: (Int -> PrintS) -> PrintS
+getIndent f d = f d d
+
 intercalates :: String -> [PrintS] -> PrintS
 intercalates sep l = foldr (%) (\_ -> id) $ intersperse (printString sep) l
 
diff --git a/SC/Acc.hs b/SC/Acc.hs
index 5ae2532..a0ef6b4 100644
--- a/SC/Acc.hs
+++ b/SC/Acc.hs
@@ -88,6 +88,8 @@ compilePAcc' aenv destnames = \case
               usedA = map (\(TypedAName _ n) -> n) (itupList arrnames)
           return [CChunk [] sts usedA]
 
+    A.Anil -> return []
+
     A.Apair a b
       | ANPair destnames1 destnames2 <- destnames -> do
           res1 <- compileAcc' aenv destnames1 a
diff --git a/SC/Exp.hs b/SC/Exp.hs
index cf4e096..e24786c 100644
--- a/SC/Exp.hs
+++ b/SC/Exp.hs
@@ -11,7 +11,7 @@ import Data.Array.Accelerate.Representation.Shape
 import Data.Array.Accelerate.Representation.Type
 import Data.Array.Accelerate.Type
 
--- import Debug.Trace
+import Debug.Trace
 
 import Debug
 import qualified Language.C as C
@@ -46,7 +46,7 @@ compileFun aenv (A.Lam lhs (A.Body body)) = do
     outnames <- itupmap (\(TypedName t n) -> TypedName (C.TPtr t) n)
                     <$> genVars (A.expType body)
     ((_tree, usedA), res) <- compileExp' aenv env body
-    -- traceM ("Compiled expression:\n" ++ prettyTree "  " "  " tree)
+    traceM ("Compiled expression:\n" ++ prettyTree "  " "  " _tree)
     (sts1, retexprs) <- toStExprs (A.expType body) res
     let sts2 = genoutstores outnames retexprs
         arrayarguments =
@@ -116,6 +116,15 @@ compileExp' aenv env = \case
                                 ITupIgnore -> []
                                 ITupSingle _ -> error "wat"))
 
+    A.While (A.Lam condlhs (A.Body condexp)) (A.Lam bodylhs (A.Body bodyexp)) initexp -> do
+        names <- genVars (lhsToTupR condlhs)
+        let condenv = pushVarsLHS condlhs names env
+            bodyenv = pushVarsLHS condlhs names env
+        ((tree1, usedA1), res1) <- compileExp' aenv env condexp
+        ((tree2, usedA2), res2) <- compileExp' aenv env bodyexp
+        ((tree3, usedA3), res3) <- compileExp' aenv env initexp
+        undefined
+
     A.Const ty x
       | Just str <- showExpConst ty x
       -> return ((Leaf ("Const (" ++ str ++ ")"), []), Right ([], ITupSingle (C.ELit str)))
@@ -125,6 +134,11 @@ compileExp' aenv env = \case
     A.PrimApp (A.PrimMul _) e -> binary aenv env "*" e
     A.PrimApp (A.PrimQuot _) e -> binary aenv env "/" e
     A.PrimApp (A.PrimRem _) e -> binary aenv env "%" e
+    A.PrimApp (A.PrimFDiv _) e -> binary aenv env "/" e
+    A.PrimApp (A.PrimLog TypeFloat) e -> unary aenv env "log" (C.ECall (C.Name "logf") . pure) e
+    A.PrimApp (A.PrimLog TypeDouble) e -> unary aenv env "log" (C.ECall (C.Name "log") . pure) e
+    A.PrimApp (A.PrimToFloating _ TypeFloat) e -> unary aenv env "cast float" (C.ECast C.TFloat) e
+    A.PrimApp (A.PrimToFloating _ TypeDouble) e -> unary aenv env "cast double" (C.ECast C.TDouble) e
     A.PrimApp op _ -> throw $ "Unsupported Exp primitive operator: " ++ showPrimFun op
 
     A.Shape (Var _ idx) ->
@@ -174,6 +188,13 @@ compileExp' aenv env = \case
             toStExprs (A.expType e') res
         return ((Node ("binary " ++ show op) [tree], usedA), Right (sts, ITupSingle (C.EOp e1 op e2)))
 
+    unary :: AVarEnv aenv -> VarEnv env -> String -> (C.Expr -> C.Expr) -> A.OpenExp env aenv a
+          -> SC ((Tree, [SomeArray]), Either (Names t -> [C.Stmt]) ([C.Stmt], Exprs t))
+    unary aenv' env' name op e' = do
+        ((tree, usedA), res) <- compileExp' aenv' env' e'
+        (sts, ITupSingle e1) <- toStExprs (A.expType e') res
+        return ((Node ("unary " ++ name) [tree], usedA), Right (sts, ITupSingle (op e1)))
+
 toStExprs :: TypeR t -> Either (Names t -> [C.Stmt]) ([C.Stmt], Exprs t) -> SC ([C.Stmt], Exprs t)
 toStExprs ty (Left fun) = do
     names <- genVars ty
diff --git a/accelerate-sc.cabal b/accelerate-sc.cabal
index 378bb2a..5a1923f 100644
--- a/accelerate-sc.cabal
+++ b/accelerate-sc.cabal
@@ -30,3 +30,18 @@ library
   hs-source-dirs:      .
   default-language:    Haskell2010
   ghc-options:         -Wall -O2
+
+test-suite test
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  other-modules:
+    Examples.Mandel
+    Examples.Test
+    Examples.Utils.PPM
+  hs-source-dirs: test
+  ghc-options: -Wall -O2 -threaded
+  build-depends:
+    accelerate-sc,
+    base >= 4.13 && < 4.15,
+    accelerate ^>= 1.3.0.0
+  default-language: Haskell2010
diff --git a/test.c b/output.c
index afd0685..afd0685 100644
--- a/test.c
+++ b/output.c
diff --git a/test/Examples/Mandel.hs b/test/Examples/Mandel.hs
new file mode 100644
index 0000000..adb116b
--- /dev/null
+++ b/test/Examples/Mandel.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
+module Examples.Mandel (afun) where
+
+import Prelude ()
+import qualified Prelude as P
+import Data.Array.Accelerate
+
+
+type Dims = (Int, Int)
+type Pos = (Double, Double)
+type Viewport = (Dims     -- image size
+                ,Pos      -- midpoint
+                ,Double)  -- complex width of the viewport
+
+type RGB = (Word8, Word8, Word8)
+
+-- Arguments: viewport and maxiter
+-- Result: image in row-major order
+afun :: Acc (Scalar (Viewport, Int)) -> Acc (Matrix RGB)
+afun (the -> T2 viewport maxiter) = mandel viewport maxiter (clrBasic maxiter)
+
+clrBasic :: Exp Int -> Exp Int -> Exp RGB
+clrBasic maxiterI nI =
+    let maxiter = log (toFloating maxiterI)
+        n = log (toFloating nI)
+    in cond (n == maxiter)
+            (T3 0 0 0)
+            (let r = slope (Just (maxiter / 4)) Nothing n maxiter
+                 g = slope Nothing Nothing n maxiter
+                 b = slope Nothing (Just (maxiter * 3 / 4)) n maxiter
+             in T3 r g b)
+  where
+    slope :: Maybe (Exp Double) -> Maybe (Exp Double) -> Exp Double -> Exp Double -> Exp Word8
+    slope mlo mhi x m =
+        (P.maybe ($ 0) (\lo' -> max 0 . ($ lo')) mlo) $ \lo ->
+        (P.maybe ($ m) (\hi' -> min 255 . ($ hi')) mhi) $ \hi ->
+            fromIntegral @Int @Word8 $ round @Double @Int $
+                max 0 $ min 255 $ (x - lo) * 255 / (hi - lo)
+
+mandel :: Exp Viewport -> Exp Int -> (Exp Int -> Exp RGB) -> Acc (Matrix RGB)
+mandel (T3 (T2 w h) (T2 cx cy) cw) maxiter clrscheme =
+    generate (I2 h w) $ \(I2 yi xi) ->
+        let minx = cx - cw / 2
+            ch = toFloating h / toFloating w * cw
+            maxy = cy + ch / 2
+            x = minx + toFloating xi / (toFloating w - 1) * cw
+            y = maxy - toFloating yi / (toFloating h - 1) * ch
+        in clrscheme (mandeliter x y maxiter)
+
+mandeliter :: Exp Double -> Exp Double -> Exp Int -> Exp Int
+mandeliter x y maxiter =
+    let T5 _ _ _ _ n =
+            while (\(T5 _ _ a2 b2 i) -> a2 + b2 < 4 && i < maxiter)
+                  (\(T5 a b a2 b2 i) ->
+                      let a' = a2 - b2 + x
+                          b' = 2 * a * b + y
+                      in T5 a' b' (a'*a') (b'*b') (i + 1))
+                  (T5 x y (x*x) (y*y) 0)
+    in n
diff --git a/test/Examples/Mandel/Main.hs b/test/Examples/Mandel/Main.hs
new file mode 100644
index 0000000..f1d49d1
--- /dev/null
+++ b/test/Examples/Mandel/Main.hs
@@ -0,0 +1,14 @@
+module Examples.Mandel.Main where
+
+import qualified Data.Array.Accelerate as A
+import qualified Data.Array.Accelerate.Interpreter as I
+
+import qualified Examples.Mandel as Mandel
+import Examples.Utils.PPM
+
+
+main :: IO ()
+main = do
+    let viewport = ((640, 480), (-0.5, 0.0), 3.0)
+        img = I.run1 Mandel.afun (A.fromList A.Z [(viewport, 200)])
+    ppmWrite img "mandel.ppm"
diff --git a/test/Examples/Test.hs b/test/Examples/Test.hs
new file mode 100644
index 0000000..f3df311
--- /dev/null
+++ b/test/Examples/Test.hs
@@ -0,0 +1,10 @@
+module Examples.Test (afun) where
+
+import Data.Array.Accelerate
+
+
+afun :: Acc (Matrix Int, Vector (Int, Int))
+     -> Acc (Matrix Int)
+afun (T2 a b) = generate (I2 2 3) (\(I2 i j) ->
+                  let T2 x y = b ! I1 i
+                  in i * j + a ! I2 i j + x * y)
diff --git a/test/Examples/Utils/PPM.hs b/test/Examples/Utils/PPM.hs
new file mode 100644
index 0000000..fe8751d
--- /dev/null
+++ b/test/Examples/Utils/PPM.hs
@@ -0,0 +1,18 @@
+module Examples.Utils.PPM where
+
+import qualified Data.Array.Accelerate as A
+import Data.Word
+
+
+type RGB = (Word8, Word8, Word8)
+
+ppmWrite :: A.Matrix RGB -> FilePath -> IO ()
+ppmWrite img fp = do
+    let A.Z A.:. h A.:. w = A.arrayShape img
+        line y = unwords $ concat [[show r, show g, show b] | x <- [0 .. w - 1], let (r, g, b) = A.indexArray img (A.Z A.:. y A.:. x)]
+        contents = unlines $
+            ["P3"
+            ,show w ++ " " ++ show h
+            ,"255"]
+            ++ [line y | y <- [0 .. h - 1]]
+    writeFile fp contents
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
index 0000000..19105dd
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,20 @@
+module Main where
+
+import qualified Data.Array.Accelerate as A
+import qualified Data.Array.Accelerate.Interpreter as I
+import System.Exit
+
+import qualified Data.Array.Accelerate.C as C
+
+import qualified Examples.Mandel as Mandel
+import Examples.Utils.PPM
+
+
+main :: IO ()
+main = do
+    let viewport = ((640, 480), (-0.5, 0.0), 3.0)
+        img = I.run1 Mandel.afun (A.fromList A.Z [(viewport, 200)])
+    case C.translateAcc "mandelkernel" Mandel.afun of
+      Left err -> die err
+      Right (code, _, _) -> writeFile "mandel-out.c" code
+    ppmWrite img "mandel.ppm"