From 1640830bf5dc0630481e698512064215eb3e8249 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sun, 10 Oct 2021 19:55:59 +0200
Subject: WIP

---
 SC/Exp.hs | 25 +++++++++++++++++++++++--
 1 file changed, 23 insertions(+), 2 deletions(-)

(limited to 'SC/Exp.hs')

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
-- 
cgit v1.2.3-70-g09d2