WIPHEADmaster

2 files changed, 25 insertions, 2 deletions

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