diff options
Diffstat (limited to 'SC')
| -rw-r--r-- | SC/Acc.hs | 2 | ||||
| -rw-r--r-- | SC/Exp.hs | 25 |
2 files changed, 25 insertions, 2 deletions
@@ -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 @@ -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 |