import Data.Char
import Text.Read
-import Text.ParserCombinators.ReadP hiding ((+++), choice)
+import Text.ParserCombinators.ReadP hiding ((+++), (<++), choice)
newtype Program = Program [AST]
deriving Show
| Var String
| Call String [Expr]
| If Expr Expr Expr
+ | For String Expr Expr (Maybe Expr) Expr
deriving Show
data BinOpType = Add | Sub | Mul | Cmp Ordering
deriving Show
, parseVar
, parseCall
, parseIf
+ , parseFor
, parseBinOp "+" Add
, parseBinOp "-" Sub
, parseBinOp "*" Mul
skipSpaces
elseE <- step readPrec
return (If cond thenE elseE)
+ parseFor = do
+ lift $ do
+ string "for"
+ skipSpaces
+ identifier <- lift (munch1 isAlpha)
+ lift $ skipSpaces >> char '=' >> skipSpaces
+ start <- step readPrec
+ lift $ skipSpaces >> char ',' >> skipSpaces
+ cond <- step readPrec
+ step' <- (do
+ lift $ skipSpaces >> char ',' >> skipSpaces
+ Just <$> step readPrec) <++ pure Nothing
+ lift $ skipSpaces >> string "in" >> skipSpaces
+ body <- step readPrec
+ return (For identifier start cond step' body)
Left err -> die err
Right mdl' -> withContext $ \ctx ->
withHostTargetMachine $ \tm -> do
- -- hPutStrLn stderr "Before optimisation:"
- -- Text.hPutStrLn stderr (ppllvm mdl')
+ hPutStrLn stderr "Before optimisation:"
+ Text.hPutStrLn stderr (ppllvm mdl')
withModuleFromAST ctx mdl' $ \mdl -> do
let spec = defaultCuratedPassSetSpec { optLevel = Just 3 }
withPassManager spec $ flip runPassManager mdl
- -- hPutStrLn stderr "After optimisation:"
- -- Text.hPutStrLn stderr . ppllvm =<< moduleAST mdl
+ hPutStrLn stderr "After optimisation:"
+ Text.hPutStrLn stderr . ppllvm =<< moduleAST mdl
jit tm mdl >>= print
jit :: TargetMachine -> Module -> IO Double
mergeB <- block `named` "ifcont"
phi [(thenOp, thenB), (elseOp, elseB)]
+
+buildExpr binds (AST.For ident start cond mStep body) = mdo
+ startV <- buildExpr binds start
+
+ preheaderB <- block `named` "preheader"
+
+ br loopB
+
+ loopB <- block `named` "loop"
+
+ i <- phi [(startV, preheaderB), (nextVar, loopB)] `named` "i"
+
+ let newBinds = Map.insert ident i binds
+
+ buildExpr newBinds body `named` "body"
+
+ stepV <- case mStep of
+ Just step -> buildExpr newBinds step
+ Nothing -> pure $ ConstantOperand (Float (Double 1))
+
+ nextVar <- fadd i stepV `named` "nextvar"
+
+ condV <- buildExpr newBinds cond `named` "cond"
+
+ condBr condV loopB afterB
+
+ afterB <- block `named` "after"
+
+ return (ConstantOperand (Float (Double 0)))
+