{-| This module defines the syntax of the simple, continuation-passing-style functional language used here, as well as some examples. -} {-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleInstances #-} module CPSScheme where import Data.String( IsString(..) ) import qualified Data.Map as M import Control.Monad.State import Control.Applicative ((<$>)) import Common -- * The CPS styntax -- | A program is defined as a lambda abstraction. The calling convention is -- that the program has one paramater, the final continuation. type Prog = Lambda -- | Labels are used throughout the code to refer to various positions in the code. -- -- Integers are used here, but they are wrapped in a newtype to hide them from -- the implementation. newtype Label = Label Integer deriving (Show, Num, Eq, Ord, Enum) -- | Variable names are just strings. Again, they are wrapped so they can be -- treated abstractly. They also carry the label of their binding position. data Var = Var Label String deriving (Show, Eq, Ord) -- | The label of the 'Lambda' or 'Let' that bound this variable. binder :: Var -> Label binder (Var l _) = l -- | A lambda expression has a label, a list of abstract argument names and a body. data Lambda = Lambda Label [Var] Call deriving (Show, Eq, Ord) -- | The body of a lambda expression is either data Call = App Label Val [Val] -- ^ an application of a value to a list of arguments, or | Let Label [(Var, Lambda)] Call -- ^ it is the definition of a list of (potentially mutable -- recursive) lambda expression, defined for a nother call -- expression. deriving (Show, Eq, Ord) -- | A value can either be data Val = L Lambda -- ^ a lambda abstraction, | R Label Var -- ^ a reference to a variable (which contains the -- label of the binding position of the variable -- for convenience), | C Label Const -- ^ a constant value or | P Prim -- ^ a primitive operation. deriving (Show, Eq, Ord) -- | As constants we only have integers. type Const = Integer -- | Primitive operations. The primitive operations are annotated by labels. These mark the (invisible) call sites that call the continuations, and are one per continuation. data Prim = Plus Label -- ^ Integer addition. Expected parameters: two integers, one continuation. | If Label Label -- ^ Conditional branching. Expected paramters: one integer, one continuation to be called if the argument is nonzero, one continuation to be called if the argument is zero ("false") deriving (Show, Eq, Ord) -- * Smart constructors instance IsString Var where fromString s = Var noProg s instance IsString Val where fromString s = R noProg (Var noProg s) instance IsString a => IsString (Inv a) where fromString s = Inv $ fromString s instance Num (Inv Val) where fromInteger i = Inv $ C noProg i (+) = error "Do not use the Num Val instance" (*) = error "Do not use the Num Val instance" abs = error "Do not use the Num Val instance" signum = error "Do not use the Num Val instance" negate (Inv (C _ i)) = Inv $ (C noProg (-i)) negate _ = error "Do not use the Num Val instance" -- | This wrapper marks values created using the smart constructors that are -- not yet finished by passing them to 'prog' and therefore invalid. newtype Inv a = Inv { unsafeFinish :: a } deriving (Show, Eq) -- | This converts code generated by the smart constructors below to a fully -- annotated 'CPSScheme' syntax tree, by assigning labels and resolving references prog :: Inv Lambda -> Prog prog (Inv p) = evalState (pLambda M.empty p) [1..] where next = do {l <- gets head ; modify tail; return l} pLambda env (Lambda _ vs c) = do l <- next let env' = env `upd` map (\(Var _ n) -> n ↦ l) vs vs' <- mapM (pVar env') vs c' <- pCall env' c return $ Lambda l vs' c' pCall env (App _ v vs) = do l <- next v' <- pVal env v vs' <- mapM (pVal env) vs return $ App l v' vs' pCall env (Let _ binds c) = do l <- next let env' = env `upd` map (\(Var _ n,_) -> (n ↦ l)) binds binds' <- forM binds $ \(v,l) -> do v' <- pVar env' v l' <- pLambda env' l return (v', l') c' <- pCall env' c return (Let l binds' c') pVal env (L lambda) = L <$> pLambda env lambda pVal env (R _ var) = do l <- next var' <- pVar env var return $ R l var' pVal env (C _ i) = do l <- next return $ C l i pVal env (P (Plus _)) = do l <- next return $ P (Plus l) pVal env (P (If _ _)) = do l1 <- next l2 <- next return $ P (If l1 l2) pVar env (Var _ n) = do let r = env M.! n return $ Var r n lambda :: [Inv Var] -> Inv Call -> Inv Lambda lambda vs (Inv c) = Inv $ Lambda noProg (map unsafeFinish vs) c app :: Inv Val -> [Inv Val] -> Inv Call app (Inv v) vs = Inv $ App noProg v (map unsafeFinish vs) let_ :: [(Inv Var, Inv Lambda)] -> Inv Call -> Inv Call let_ binds (Inv c) = Inv $ Let noProg (map (\(Inv v, Inv l) -> (v,l)) binds) c l :: Inv Lambda -> Inv Val l = Inv . L . unsafeFinish c :: Const -> Inv Val c = Inv . C noProg plus :: Inv Val plus = Inv $ P (Plus noProg) if_ :: Inv Val if_ = Inv $ P (If noProg noProg) -- | Internal error value noProg :: a noProg = error "Smart constructors used without calling prog" -- * Some example Programs -- | Returns 0 ex1 :: Prog ex1 = prog $ lambda ["cont"] $ app "cont" [0] -- | Returns 1 + 1 ex2 :: Prog ex2 = prog $ lambda ["cont"] $ app plus [1, 1, "cont"] -- | Returns the sum of the first 10 integers ex3 :: Prog ex3 = prog $ lambda ["cont"] $ let_ [("rec", lambda ["p", "i", "c'"] $ app if_ [ "i" , l $ lambda [] $ app plus ["p", "i", l $ lambda ["p'"] $ app plus ["i", -1, l $ lambda ["i'"] $ app "rec" [ "p'", "i'", "c'" ] ] ] , l $ lambda [] $ app "c'" ["p"] ] )] $ app "rec" [0, 10, "cont"] -- | Does not Terminate ex4 :: Prog ex4 = prog $ lambda ["cont"] $ let_ [("rec", lambda ["c"] $ app "rec" ["c"])] $ app "rec" ["cont"] -- | The puzzle from Shiver's dissertation puzzle :: Prog puzzle = prog $ lambda ["k"] $ app (l $ lambda ["f"] $ app "f" [0, 42, l $ lambda ["v"] $ app "f" [1,"v","k"]]) [l $ lambda ["x","h","k1"] $ app if_ [ "x" , l $ lambda [] $ app "h" ["k1"] , l $ lambda [] $ app "k1" [l $ lambda ["k2"] $ app "k2" ["x"]] ] ]