diff --git a/src/Naturals.hs b/src/Naturals.hs index 7ccaffa..7dc5144 100644 --- a/src/Naturals.hs +++ b/src/Naturals.hs @@ -1,5 +1,9 @@ module Naturals where +import Data.Int (Int64) + +import SIL + data NaturalType = NZeroType | NArrType NaturalType NaturalType @@ -17,9 +21,38 @@ data NExpr | NLeft NExpr | NRight NExpr | NTrace NExpr - | NChurch + | NChurch Int64 | NAdd NExpr NExpr | NMult NExpr NExpr | NPow NExpr NExpr | NITE NExpr NExpr NExpr deriving (Eq, Show, Ord) + +toNExpr :: IExpr -> NExpr +toNExpr x = case x of + Zero -> NZero + (Pair a b) -> NPair (toNExpr a) (toNExpr b) + Env -> NEnv + (SetEnv x) -> NSetEnv (toNExpr x) + (Defer x) -> NDefer (toNExpr x) + (Twiddle x) -> toNExpr $ twiddle x -- temporary hack while Twiddle exists + (Abort x) -> NAbort (toNExpr x) + (Gate x) -> NGate (toNExpr x) + (PLeft x) -> NLeft (toNExpr x) + (PRight x) -> NRight (toNExpr x) + (Trace x) -> NTrace (toNExpr x) + -- TODO Church numerals and natural ops + +fromNExpr :: NExpr -> IExpr +fromNExpr x = case x of + NZero -> Zero + (NPair a b) -> Pair (fromNExpr a) (fromNExpr b) + NEnv -> Env + (NSetEnv x) -> SetEnv (fromNExpr x) + (NDefer x) -> Defer (fromNExpr x) + (NAbort x) -> Abort (fromNExpr x) + (NGate x) -> Gate (fromNExpr x) + (NLeft x) -> PLeft (fromNExpr x) + (NRight x) -> PRight (fromNExpr x) + (NTrace x) -> Trace (fromNExpr x) + _ -> error "TODO" diff --git a/src/SIL.hs b/src/SIL.hs index 8ed47fc..0a2c0e6 100644 --- a/src/SIL.hs +++ b/src/SIL.hs @@ -102,9 +102,11 @@ var = Env env :: IExpr env = Env twiddle :: IExpr -> IExpr -twiddle = Twiddle +twiddle x = setenv (pair (defer (pair (pleft (pright env)) (pair (pleft env) (pright (pright env))))) x) app :: IExpr -> IExpr -> IExpr -app c i = setenv (twiddle (pair i c)) +--app c i = setenv (twiddle (pair i c)) +app c i = setenv (setenv (pair (defer (pair (pleft (pright env)) (pair (pleft env) (pright (pright env))))) + (pair i c))) check :: IExpr -> IExpr -> IExpr check c tc = setenv (pair (defer (ite (app (pleft env) (pright env)) diff --git a/src/SIL/Llvm.hs b/src/SIL/Llvm.hs index 12d7382..0d2b653 100644 --- a/src/SIL/Llvm.hs +++ b/src/SIL/Llvm.hs @@ -39,7 +39,7 @@ import qualified LLVM.IRBuilder.Instruction as IRI import qualified LLVM.IRBuilder.Constant as IRC import qualified LLVM.IRBuilder.Module as IRM -import qualified SIL as SIL +import Naturals foreign import ccall "dynamic" haskFun :: FunPtr (IO (Ptr Int64)) -> IO (Ptr Int64) @@ -63,14 +63,14 @@ run fn = do pairs <- (reverse . snd) <$> foldM readPair (startHeap, []) [1..numPairs] pure (resultPair, pairs) -convertPairs :: (Int64, [(Int64,Int64)]) -> SIL.IExpr +convertPairs :: (Int64, [(Int64,Int64)]) -> NExpr convertPairs (x, pairs)= - let convertPair 0 = SIL.Zero + let convertPair 0 = NZero convertPair n = let (l,r) = pairs !! fromIntegral n - in SIL.Pair (convertPair l) (convertPair r) + in NPair (convertPair l) (convertPair r) in convertPair x -makeModule :: SIL.IExpr -> AST.Module +makeModule :: NExpr -> AST.Module makeModule iexpr = flip evalState startBuilderInternal . buildModuleT "SILModule" $ do mapM_ emitDefn [pairHeap, heapIndex, resultStructure] @@ -150,7 +150,7 @@ debugLog = if debug then hPutStrLn stderr else const $ pure () -evalJIT :: AST.Module -> IO (Either String SIL.IExpr) +evalJIT :: AST.Module -> IO (Either String NExpr) evalJIT amod = do b <- Linking.loadLibraryPermanently Nothing withContext $ \ctx -> @@ -323,11 +323,11 @@ envC = LocalReference intT "env" lComment :: a -> (a, MDRef MDNode) lComment s = (s, MDInline (MDTuple [])) -toLLVM :: SIL.IExpr -> SILBuilder Operand +toLLVM :: NExpr -> SILBuilder Operand -- chunks of AST that can be translated to optimized instructions -toLLVM (SIL.SetEnv (SIL.Pair (SIL.Gate i) (SIL.Pair e t))) = case i of - SIL.Zero -> toLLVM e - (SIL.Pair _ _) -> toLLVM t +toLLVM (NSetEnv (NPair (NGate i) (NPair e t))) = case i of + NZero -> toLLVM e + (NPair _ _) -> toLLVM t _ -> do ip <- toLLVM i elseB <- freshUnName @@ -349,30 +349,16 @@ toLLVM (SIL.SetEnv (SIL.Pair (SIL.Gate i) (SIL.Pair e t))) = case i of emitBlockStart exitB IRI.phi [(ep, endElseB), (tp, endThenB)] -- single instruction translation -toLLVM SIL.Zero = pure zero -toLLVM (SIL.Pair a b) = do +toLLVM NZero = pure zero +toLLVM (NPair a b) = do oa <- toLLVM a ob <- toLLVM b makePair oa ob -toLLVM (SIL.Twiddle x) = do - xp <- toLLVM x - -- get values for current pairs - ia <- IRI.gep heapC [zero, xp, zero32] - ca <- IRI.gep heapC [zero, xp, one32] - i <- IRI.load ia 0 - c <- IRI.load ca 0 - cla <- IRI.gep heapC [zero, c, zero32] - cea <- IRI.gep heapC [zero, c, one32] - cl <- IRI.load cla 0 - ce <- IRI.load cea 0 - -- create new pairs - nenv <- makePair i ce - makePair cl nenv -toLLVM (SIL.PLeft x) = toLLVM x >>= doLeft -toLLVM (SIL.PRight x) = toLLVM x >>= doRight -toLLVM SIL.Env = pure envC -toLLVM (SIL.Defer x) = doFunction $ toLLVM x -toLLVM (SIL.SetEnv x) = do +toLLVM (NLeft x) = toLLVM x >>= doLeft +toLLVM (NRight x) = toLLVM x >>= doRight +toLLVM NEnv = pure envC +toLLVM (NDefer x) = doFunction $ toLLVM x +toLLVM (NSetEnv x) = do -- Evaluate x to (clo, env) xp <- toLLVM x l <- IRI.gep heapC [zero, xp, zero32] @@ -382,13 +368,13 @@ toLLVM (SIL.SetEnv x) = do funPtr <- IRI.inttoptr clo funT -- Call the function stored at clo with argument env IRI.call funPtr [(env, [])] -toLLVM (SIL.Gate x) = do +toLLVM (NGate x) = do lx <- toLLVM x bool <- IRI.icmp IP.NE lx zero IRI.select bool (ConstantOperand (C.PtrToInt (C.GlobalReference funT "goRight") intT)) (ConstantOperand (C.PtrToInt (C.GlobalReference funT "goLeft") intT)) -toLLVM (SIL.Abort x) = do +toLLVM (NAbort x) = do lx <- toLLVM x abortB <- freshUnName @@ -404,7 +390,7 @@ toLLVM (SIL.Abort x) = do pure zero -- TODO this will be hard -toLLVM (SIL.Trace x) = toLLVM x +toLLVM (NTrace x) = toLLVM x resultC :: Operand resultC = ConstantOperand $ C.GlobalReference (PointerType resultStructureT (AddrSpace.AddrSpace 0)) resultStructureN diff --git a/src/SIL/RunTime.hs b/src/SIL/RunTime.hs index d402944..e0ddad1 100644 --- a/src/SIL/RunTime.hs +++ b/src/SIL/RunTime.hs @@ -10,6 +10,7 @@ import Control.Monad.Fix import System.IO (hPutStrLn, stderr) import SIL +import Naturals import qualified SIL.Llvm as LLVM debug :: Bool @@ -200,7 +201,7 @@ fasterEval = llvmEval :: IExpr -> IO IExpr llvmEval iexpr = do - let lmod = LLVM.makeModule iexpr + let lmod = LLVM.makeModule $ toNExpr iexpr when debug $ do print $ LLVM.DebugModule lmod putStrLn . concat . take 100 . repeat $ " \n" @@ -211,7 +212,7 @@ llvmEval iexpr = do hPutStrLn stderr $ "failed llvmEval: " ++ s fail s Right x -> do - pure x + pure $ fromNExpr x optimizedEval :: IExpr -> IO IExpr optimizedEval = llvmEval