Permalink
Browse files

Added embedded unsafe interpreter.

  • Loading branch information...
1 parent f264339 commit 9dd3d5f4019f91d78c80bf8d7b45fd64ee754937 @luqui committed Jun 11, 2009
Showing with 72 additions and 9 deletions.
  1. +64 −0 experiments/interp-stack/InterpStack/Embedded.hs
  2. +8 −9 experiments/interp-stack/interpreter.hs
View
64 experiments/interp-stack/InterpStack/Embedded.hs
@@ -0,0 +1,64 @@
+module InterpStack.Embedded (embeddedInterp) where
+
+import InterpStack.Exp
+import Unsafe.Coerce
+import GHC.Prim (Any)
+import Control.Applicative
+
+infixl 9 `SApp`
+data AST
+ = SLam AST
+ | SVar Int
+ | SApp AST AST
+ | SPrim Any
+
+makeAST :: (Value a) => Exp a -> AST
+makeAST = go False
+ where
+ go eta (Lam body) = SLam (go False body)
+ go eta (t :% u) = SApp (go True t) (go False u)
+ go eta (Var v) = SVar v
+ go eta (Lit l)
+ | eta = SPrim (unsafeCoerce (applyValue l))
+ | otherwise = SPrim (unsafeCoerce l)
+
+unfree :: Int -> AST -> Maybe AST
+unfree n (SLam body) = SLam <$> unfree (n+1) body
+unfree n (SVar z) =
+ case compare z n of
+ LT -> Just (SVar z)
+ EQ -> Nothing
+ GT -> Just (SVar (z-1))
+unfree n (SApp t u) = liftA2 SApp (unfree n t) (unfree n u)
+unfree n (SPrim p) = Just (SPrim p)
+
+primK = mkPrim $ \x y -> x
+primS = mkPrim $ \x y z -> x z (y z)
+primB = mkPrim $ \x y z -> x (y z)
+primC = mkPrim $ \x y z -> x z y
+primI = mkPrim $ \x -> x
+mkPrim = SPrim . unsafeCoerce
+
+unlambda :: AST -> AST
+unlambda (SLam t) | Just t' <- unfree 0 t = SApp primK (unlambda t')
+unlambda (SLam (SVar 0)) = primI
+unlambda (SLam (SApp t (SVar 0))) | Just t' <- unfree 0 t = unlambda t
+unlambda (SLam (SLam t)) = unlambda (SLam (unlambda (SLam t)))
+unlambda (SLam (SApp t u))
+ = case (unfree 0 t, unfree 0 u) of
+ (Nothing, Nothing) -> primS `SApp` unlambda t `SApp` unlambda u
+ (Just t', Nothing) -> primB `SApp` t' `SApp` u
+ (Nothing, Just u') -> primC `SApp` t `SApp` u'
+ (Just t', Just u') -> error "Impossible!"
+unlambda (SApp t u) = SApp (unlambda t) (unlambda u)
+unlambda (SVar v) = SVar v
+unlambda (SPrim p) = SPrim p
+
+compile :: AST -> Any
+compile (SPrim p) = p
+compile (SApp t u) = unsafeCoerce (compile t) (compile u)
+compile _ = error "Don't know how to compile that"
+
+embeddedInterp = Interp {
+ eval = Just . unsafeCoerce . compile . unlambda . makeAST
+}
View
17 experiments/interp-stack/interpreter.hs
@@ -1,5 +1,6 @@
import InterpStack.Exp
import InterpStack.LazyNF
+import InterpStack.Embedded
import InterpStack.HOAS
import Debug.Trace
import System.IO
@@ -55,14 +56,12 @@ eInterp_ = fix_ % fun (\interp -> fun (\env -> fun (\ast ->
% fun (\left -> fun (\right -> interp % env % left % (interp % env % right)))
% fun (\lt -> lt))))
---program_ = (exp_ % two_ % two_) % lit IInc % lit (IInt 0)
-
-primify_ = fun (\n -> n % lit IInc % lit (IInt 0))
+primify_ = fun (\n -> n % fun (\x -> lit IInc % x) % lit (IInt 0))
sum_ = fix_ % fun (\self -> fun (\l ->
l % zero_ % fun (\x -> fun (\xs -> plus_ % x % (self % xs)))))
-program_ = fun (\x -> primify_ % (times_ % two_ % x))
+program_ = fun (\x -> primify_ % (times_ % two_ % x)) % two_
quoteInt :: Int -> Term a
@@ -85,12 +84,12 @@ forceExp (Lit a) = Lit a
layer :: Exp a -> Exp a
layer x = buildExp (eInterp_ % nil_) :% quote x
-run :: Exp IVal -> Maybe IVal
-run = eval lazyNFInterp
-
iter n = foldr (.) id . replicate n
main = do
- [n] <- getArgs
+ [interpStr, n] <- getArgs
+ let interp = case interpStr of
+ "lazyNF" -> lazyNFInterp
+ "embedded" -> embeddedInterp
hSetBuffering stdout NoBuffering
- print $ run . iter (read n) layer . buildExp $ program_
+ print . eval interp . iter (read n) layer . buildExp $ program_

0 comments on commit 9dd3d5f

Please sign in to comment.