├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── closure.cabal └── src ├── ANF.hs ├── Closure.hs ├── LL.hs ├── LLVM.hs └── Machine.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .ghc.* 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for closure 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Isaac Elliott 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Isaac Elliott nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # closure 2 | 3 | An implementation of Barry Jay's *closure calculus* - a calculus 4 | of explicit substitutions. 5 | 6 | Jay, B. (2019, January). A simpler lambda calculus. In Proceedings of the 2019 ACM SIGPLAN Workshop on Partial Evaluation and Program Manipulation (pp. 1-9). ACM. 7 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /closure.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | -- Initial package description 'closure.cabal' generated by 'cabal init'. 3 | -- For further documentation, see http://haskell.org/cabal/users-guide/ 4 | 5 | name: closure 6 | version: 0.1.0.0 7 | -- synopsis: 8 | -- description: 9 | -- bug-reports: 10 | license: BSD-3-Clause 11 | license-file: LICENSE 12 | author: Isaac Elliott 13 | maintainer: isaace71295@gmail.com 14 | -- copyright: 15 | category: Language 16 | extra-source-files: CHANGELOG.md 17 | 18 | library 19 | exposed-modules: Closure, ANF, Machine, LL, LLVM 20 | build-depends: base ^>=4.12.0.0 21 | , megaparsec 22 | , mtl 23 | , vector 24 | , ansi-wl-pprint 25 | , llvm-hs-pure ^>=7.0 26 | ghc-options: -Wall -Werror 27 | hs-source-dirs: src 28 | default-language: Haskell2010 29 | -------------------------------------------------------------------------------- /src/ANF.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts #-} 2 | module ANF where 3 | 4 | import Control.Monad.State (MonadState, evalStateT, get, put) 5 | import Control.Monad.Writer (MonadWriter, runWriter, runWriterT, tell) 6 | import Data.Monoid (Endo(..)) 7 | import Data.Word (Word32) 8 | 9 | import qualified Closure 10 | 11 | data AExp a 12 | = A_Var a 13 | | A_Ix !Int 14 | | A_AppF (AExp a) (AExp a) 15 | | A_Lam (AExp a) (Exp a) Closure.Ty Closure.Ty 16 | | A_Nat32 !Word32 17 | | A_Unit 18 | | A_Nil 19 | | A_AddNat32 (AExp a) (AExp a) 20 | deriving (Eq, Show) 21 | 22 | data CExp a 23 | = C_AppT (AExp a) (AExp a) 24 | | C_Cons (AExp a) (AExp a) 25 | | C_ConsMany [AExp a] 26 | | C_Subst (AExp a) (AExp a) 27 | deriving (Eq, Show) 28 | 29 | data Exp a 30 | = E_Let a Closure.Ty (CExp a) (Exp a) 31 | | E_AExp (AExp a) 32 | deriving (Eq, Show) 33 | 34 | newtype LocalName = LocalName String 35 | deriving (Eq, Show) 36 | 37 | freshLocalName :: MonadState Int m => m LocalName 38 | freshLocalName = do 39 | n <- get 40 | LocalName ('x' : show n) <$ put (n+1) 41 | 42 | aexp :: 43 | ( MonadWriter (Endo (Exp LocalName)) m 44 | , MonadState Int m 45 | ) => 46 | Closure.Exp Closure.Ty -> 47 | m (AExp LocalName, Closure.Ty) 48 | aexp tm = 49 | case tm of 50 | Closure.VZ t -> 51 | case Closure.toInt tm of 52 | Nothing -> error "malformed index" 53 | Just a -> pure (A_Ix a, t) 54 | Closure.VS t _ -> 55 | case Closure.toInt tm of 56 | Nothing -> error "malformed index" 57 | Just a -> pure (A_Ix a, t) 58 | Closure.AppF t a b -> do 59 | (a', _) <- aexp a 60 | (b', _) <- aexp b 61 | pure (A_AppF a' b', t) 62 | Closure.AppT t a b -> do 63 | (va, _) <- aexp a 64 | (vb, _) <- aexp b 65 | var <- freshLocalName 66 | tell . Endo $ E_Let var t (C_AppT va vb) 67 | pure (A_Var var, t) 68 | Closure.Subst t a b -> do 69 | (va, _) <- aexp a 70 | (vb, _) <- aexp b 71 | var <- freshLocalName 72 | tell . Endo $ E_Let var t (C_Subst va vb) 73 | pure (A_Var var, t) 74 | Closure.Lam t a b -> 75 | case t of 76 | Closure.TyArr inTy outTy -> do 77 | (a', _) <- aexp a 78 | (b', _) <- exp_ b 79 | pure (A_Lam a' b' inTy outTy, t) 80 | _ -> error "incorrect type for lam" 81 | Closure.Nil t -> pure (A_Nil, t) 82 | Closure.Cons t a b -> 83 | case Closure.toList tm of 84 | Nothing -> do 85 | (va, _) <- aexp a 86 | (vb, _) <- aexp b 87 | var <- freshLocalName 88 | tell . Endo $ E_Let var t (C_Cons va vb) 89 | pure (A_Var var, t) 90 | Just ls -> do 91 | ls' <- traverse (fmap fst . aexp) ls 92 | var <- freshLocalName 93 | tell . Endo $ E_Let var t (C_ConsMany ls') 94 | pure (A_Var var, t) 95 | Closure.Unit t -> pure (A_Unit, t) 96 | Closure.Nat32 t a -> pure (A_Nat32 a, t) 97 | Closure.AddNat32 t a b -> do 98 | (a', _) <- aexp a 99 | (b', _) <- aexp b 100 | pure (A_AddNat32 a' b', t) 101 | 102 | exp_ :: 103 | MonadState Int m => 104 | Closure.Exp Closure.Ty -> 105 | m (Exp LocalName, Closure.Ty) 106 | exp_ tm = do 107 | ((v, t), rest) <- runWriterT $ aexp tm 108 | pure (appEndo rest $ E_AExp v, t) 109 | 110 | anf :: Closure.Exp Closure.Ty -> Exp LocalName 111 | anf tm = appEndo rest $ E_AExp v 112 | where 113 | ((v, _), rest) = runWriter $ evalStateT (aexp tm) 0 -------------------------------------------------------------------------------- /src/Closure.hs: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns, FlexibleContexts, TypeFamilies #-} 2 | {-# language OverloadedStrings #-} 3 | {-# language DeriveFunctor #-} 4 | module Closure where 5 | 6 | import Control.Applicative ((<|>), (<**>), many, some, optional) 7 | import Control.Monad (void) 8 | import Data.String (IsString) 9 | import Data.Void (Void) 10 | import Data.Word (Word32) 11 | import Text.Megaparsec (MonadParsec, Tokens, Token, sepBy, between, try) 12 | import Text.Megaparsec.Char (char, digitChar, space1, string) 13 | 14 | data Exp t 15 | = VZ t 16 | | VS t !(Exp t) 17 | | AppF t !(Exp t) !(Exp t) 18 | | AppT t !(Exp t) !(Exp t) 19 | | Subst t !(Exp t) !(Exp t) 20 | | Lam t !(Exp t) !(Exp t) 21 | | Nil t 22 | | Cons t !(Exp t) !(Exp t) 23 | | Unit t 24 | | Nat32 t !Word32 25 | | AddNat32 t (Exp t) (Exp t) 26 | deriving (Eq, Show, Functor) 27 | 28 | vz_ :: Exp () 29 | vz_ = VZ () 30 | 31 | nil_ :: Exp () 32 | nil_ = Nil () 33 | 34 | unit_ :: Exp () 35 | unit_ = Unit () 36 | 37 | vs_ :: Exp () -> Exp () 38 | vs_ = VS () 39 | 40 | nat32_ :: Word32 -> Exp () 41 | nat32_ = Nat32 () 42 | 43 | appF_ :: Exp () -> Exp () -> Exp () 44 | appF_ = AppF () 45 | 46 | appT_ :: Exp () -> Exp () -> Exp () 47 | appT_ = AppT () 48 | 49 | subst_ :: Exp () -> Exp () -> Exp () 50 | subst_ = Subst () 51 | 52 | lam_ :: Exp () -> Exp () -> Exp () 53 | lam_ = Lam () 54 | 55 | cons_ :: Exp () -> Exp () -> Exp () 56 | cons_ = Cons () 57 | 58 | addNat32_ :: Exp () -> Exp () -> Exp () 59 | addNat32_ = AddNat32 () 60 | 61 | data Ty 62 | = TyArr !Ty !Ty 63 | | TyUnit 64 | | TyNat32 65 | | TySub [Ty] 66 | deriving (Eq, Show) 67 | 68 | fromInt :: Int -> Exp () 69 | fromInt !n = 70 | case compare n 0 of 71 | LT -> error $ "fromInt: invalid input: " <> show n 72 | EQ -> VZ () 73 | GT -> VS () $! fromInt (n-1) 74 | 75 | toInt :: Exp a -> Maybe Int 76 | toInt (VZ _) = Just 0 77 | toInt (VS _ n) = (+1) <$> toInt n 78 | toInt _ = Nothing 79 | 80 | fromList :: [Exp ()] -> Exp () 81 | fromList [] = Nil () 82 | fromList (a:as) = Cons () a $! fromList as 83 | 84 | toList :: Exp a -> Maybe [Exp a] 85 | toList (Nil _) = Just [] 86 | toList (Cons _ a b) = (a :) <$> toList b 87 | toList _ = Nothing 88 | 89 | chainl1 :: MonadParsec e s m => m a -> m (a -> a -> a) -> m a 90 | chainl1 p op = scan where 91 | scan = p <**> rst 92 | rst = try ((\f y g x -> g (f x y)) <$> op <*> p) <*> rst <|> pure id 93 | {-# INLINE chainl1 #-} 94 | 95 | token :: (IsString (Tokens s), MonadParsec Void s m, Token s ~ Char) => m a -> m a 96 | token m = m <* many space1 97 | 98 | parseTy :: (IsString (Tokens s), MonadParsec Void s m, Token s ~ Char) => m Ty 99 | parseTy = token ty 100 | where 101 | ty = tyArr 102 | atom = 103 | unit <|> 104 | nat <|> 105 | between (token $ char '(') (char ')') (token ty) 106 | unit = TyUnit <$ string "Unit" 107 | nat = TyNat32 <$ string "Nat32" 108 | tyArr = 109 | (\a -> maybe a (TyArr a)) <$> 110 | atom <*> 111 | optional (try (many space1 *> token (string "->")) *> tyArr) 112 | 113 | parseExp :: (IsString (Tokens s), MonadParsec Void s m, Token s ~ Char) => m (Exp ()) 114 | parseExp = token expr 115 | where 116 | expr = lam <|> appF 117 | lam = Lam () <$ token (char '\\') <*> token ctx <* token (string "->") <*> expr 118 | appF = chainl1 (token appT) (AppF () <$ token (char '@')) 119 | appT = chainl1 atom (AppT () <$ some space1) 120 | atom = 121 | unit <|> 122 | nat32 <|> 123 | var <|> 124 | ctx <|> 125 | between (token $ char '(') (char ')') (token expr) 126 | unit = Unit () <$ string "unit" 127 | nat32 = Nat32 () . read <$> some digitChar 128 | ctx = 129 | fromList <$> 130 | between 131 | (token $ char '[') 132 | (char ']') 133 | (sepBy (token expr) (token $ char ',')) 134 | var = fromInt . read <$ char '#' <*> some digitChar 135 | 136 | isCtx :: Exp a -> Bool 137 | isCtx Nil{} = True 138 | isCtx Cons{} = True 139 | isCtx _ = False 140 | 141 | step :: Exp () -> Maybe (Exp ()) 142 | step (AppT _ a b) = 143 | (\a' -> AppT () a' b) <$> step a <|> 144 | -- this is a call-by-value kind of thing 145 | 146 | -- but we could also get a call-by-name kind of thing by only 147 | -- reducing `b` when we're composing substitutions 148 | 149 | -- a behaviour that we wouldn't carry over to compilation is the 150 | -- duplication of subtitutions. when `(a, b)(x @ y) ~> (a, b)x (a, b)y`, that closure on both 151 | -- sides should be the same pointer. then we can hopefully get a call-by-need thing going 152 | (\b' -> AppT () a b') <$> step b <|> 153 | case a of 154 | VZ{} -> pure $ AppF () (VZ ()) b 155 | VS{} -> pure $ AppF () a b 156 | AppF _ x y -> pure $ AppF () (AppF () x y) b 157 | Lam () x y -> pure $ Subst () (Cons () b x) y 158 | _ -> Nothing 159 | step (Subst _ a b) = 160 | (\a' -> Subst () a' b) <$> step a <|> 161 | (\b' -> Subst () a b') <$> step b <|> 162 | case a of 163 | Nil{} -> pure b 164 | Cons _ x _ | VZ{} <- b -> pure x 165 | Cons _ _ x | VS _ y <- b -> pure $ Subst () x y 166 | Cons{} | AppF _ z w <- b -> pure $ AppT () (Subst () a z) (Subst () a w) 167 | Cons{} | Lam _ z w <- b -> pure $ Lam () (Subst () a z) w 168 | Cons{} | Nil{} <- b -> pure $ Nil () 169 | Cons{} | Cons _ z w <- b -> pure $ Cons () (Subst () a z) (Subst () a w) 170 | _ -> Nothing 171 | step (VS _ a) = VS () <$> step a 172 | step (AppF _ a b) = 173 | (\a' -> AppF () a' b) <$> step a <|> 174 | (\b' -> AppF () a b') <$> step b 175 | step (Lam _ a b) = 176 | (\a' -> Lam () a' b) <$> step a <|> 177 | (\b' -> Lam () a b') <$> step b 178 | step (Cons _ a b) = 179 | (\a' -> Cons () a' b) <$> step a <|> 180 | (\b' -> Cons () a b') <$> step b 181 | step _ = Nothing 182 | 183 | eval :: Exp () -> Exp () 184 | eval = go where go a = maybe a go $ step a 185 | 186 | data TypeError 187 | = TypeMismatch Ty Ty 188 | | ExpectedFunction (Exp ()) 189 | | ExpectedArrow (Exp ()) Ty 190 | | Can'tInfer (Exp ()) 191 | | ExpectedTySub (Exp ()) 192 | | ScopeError 193 | deriving (Eq, Show) 194 | 195 | check :: 196 | [Ty] -> 197 | Exp a -> 198 | Ty -> 199 | Either TypeError (Exp Ty) 200 | check ctx e ty = 201 | case e of 202 | Lam _ a b -> 203 | case ty of 204 | TyArr u t -> do 205 | (a', aTy) <- infer ctx a 206 | case aTy of 207 | TySub ctx' -> do 208 | b' <- check (u : ctx') b t 209 | pure $ Lam ty a' b' 210 | _ -> Left $ ExpectedTySub $ void a 211 | _ -> Left $ ExpectedArrow (void e) ty 212 | _ -> do 213 | (e', eTy) <- infer ctx e 214 | if eTy == ty 215 | then pure e' 216 | else Left $ TypeMismatch ty eTy 217 | 218 | infer :: 219 | [Ty] -> 220 | Exp a -> 221 | Either TypeError (Exp Ty, Ty) 222 | infer ctx e = 223 | case e of 224 | Nil{} -> do 225 | let t = TySub [] 226 | pure $ (Nil t, t) 227 | Cons _ a b -> do 228 | (a', aTy) <- infer ctx a 229 | (b', bTy) <- infer ctx b 230 | case bTy of 231 | TySub bs -> do 232 | let t = TySub $ aTy : bs 233 | pure (Cons t a' b', t) 234 | _ -> Left $ ExpectedTySub $ void b 235 | Unit{} -> do 236 | let t = TyUnit 237 | pure (Unit t, t) 238 | VZ{} -> 239 | case ctx of 240 | [] -> Left ScopeError 241 | t:_ -> pure (VZ t, t) 242 | VS _ n -> 243 | case ctx of 244 | [] -> Left ScopeError 245 | _:ts -> do 246 | (n', nTy) <- infer ts n 247 | pure (VS nTy n', nTy) 248 | Nat32 _ a -> do 249 | let t = TyNat32 250 | pure (Nat32 t a, t) 251 | AppF _ a b -> do 252 | (a', aTy) <- infer ctx a 253 | case aTy of 254 | TyArr bTy retTy -> do 255 | b' <- check ctx b bTy 256 | pure (AppF retTy a' b', retTy) 257 | _ -> Left $ ExpectedFunction $ void a 258 | AppT _ a b -> do 259 | (a', aTy) <- infer ctx a 260 | case aTy of 261 | TyArr bTy retTy -> do 262 | b' <- check ctx b bTy 263 | pure (AppF retTy a' b', retTy) 264 | _ -> Left $ ExpectedFunction $ void a 265 | Subst _ a b -> do 266 | (a', aTy) <- infer ctx a 267 | case aTy of 268 | TySub ctx' -> do 269 | (b', bTy) <- infer ctx' b 270 | pure (Subst bTy a' b', bTy) 271 | _ -> Left $ ExpectedTySub $ void a 272 | AddNat32 _ a b -> do 273 | a' <- check ctx a TyNat32 274 | b' <- check ctx b TyNat32 275 | let t = TyNat32 276 | pure (AddNat32 t a' b', t) 277 | _ -> Left $ Can'tInfer $ void e -------------------------------------------------------------------------------- /src/LL.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts #-} 2 | {-# language TupleSections #-} 3 | module LL 4 | ( Ty(..), ANF.LocalName(..), FunName(..) 5 | , AExpL(..), CExpL(..), Decl(..), Prog(..) 6 | , lambdaLift 7 | ) 8 | where 9 | 10 | import Control.Monad.Writer (MonadWriter, runWriterT, tell) 11 | import Control.Monad.State (MonadState, evalState, get, put) 12 | import Data.Word (Word32) 13 | 14 | import Closure (Ty(..)) 15 | import qualified ANF 16 | 17 | data AExpL a b 18 | = A_Var (Either a b) 19 | | A_Ix !Int 20 | | A_AppF (AExpL a b) (AExpL a b) 21 | | A_Fun a (AExpL a b) 22 | | A_Nat32 !Word32 23 | | A_Unit 24 | | A_Nil 25 | | A_AddNat32 (AExpL a b) (AExpL a b) 26 | deriving (Eq, Show) 27 | 28 | data CExpL a b 29 | = C_AppT (AExpL a b) (AExpL a b) 30 | | C_Cons (AExpL a b) (AExpL a b) 31 | | C_ConsMany [AExpL a b] 32 | | C_Subst (AExpL a b) (AExpL a b) 33 | deriving (Eq, Show) 34 | 35 | data Decl a b 36 | -- | 37 | -- At this stage, a lifted lambda takes two arguments: a closure 38 | -- and a formal parameter 39 | = D_Fun Ty a Ty [(Ty, b, CExpL a b)] (AExpL a b) 40 | | D_Val Ty b (CExpL a b) 41 | deriving (Eq, Show) 42 | 43 | newtype FunName = FunName String 44 | deriving (Eq, Show) 45 | 46 | data Prog a b = Prog [Decl a b] (AExpL a b) 47 | deriving (Eq, Show) 48 | 49 | freshFunName :: MonadState Int m => m FunName 50 | freshFunName = do 51 | n <- get 52 | FunName ('f' : show n) <$ put (n+1) 53 | 54 | toValDecl :: (Ty, b, CExpL a b) -> Decl a b 55 | toValDecl (a, b, c) = D_Val a b c 56 | 57 | liftAExp :: 58 | ( MonadWriter [Decl FunName b] m 59 | , MonadState Int m 60 | ) => 61 | ANF.AExp b -> 62 | m (AExpL FunName b) 63 | liftAExp tm = 64 | case tm of 65 | ANF.A_Var a -> pure $ A_Var (Right a) 66 | ANF.A_Ix a -> pure $ A_Ix a 67 | ANF.A_AppF a b -> A_AppF <$> liftAExp a <*> liftAExp b 68 | ANF.A_Lam a b inTy retTy -> do 69 | a' <- liftAExp a 70 | (b', bdecls) <- liftExp b 71 | n <- freshFunName 72 | tell [D_Fun retTy n inTy bdecls b'] 73 | pure $ A_Fun n a' 74 | ANF.A_Nat32 a -> pure $ A_Nat32 a 75 | ANF.A_Unit -> pure A_Unit 76 | ANF.A_Nil -> pure A_Nil 77 | ANF.A_AddNat32 a b -> A_AddNat32 <$> liftAExp a <*> liftAExp b 78 | 79 | liftCExp :: 80 | ( MonadWriter [Decl FunName b] m 81 | , MonadState Int m 82 | ) => 83 | ANF.CExp b -> 84 | m (CExpL FunName b) 85 | liftCExp tm = 86 | case tm of 87 | ANF.C_AppT a b -> C_AppT <$> liftAExp a <*> liftAExp b 88 | ANF.C_Cons a b -> C_Cons <$> liftAExp a <*> liftAExp b 89 | ANF.C_ConsMany a -> C_ConsMany <$> traverse liftAExp a 90 | ANF.C_Subst a b -> C_Subst <$> liftAExp a <*> liftAExp b 91 | 92 | liftExp :: 93 | ( MonadState Int m 94 | , MonadWriter [Decl FunName b] m 95 | )=> 96 | ANF.Exp b -> 97 | m (AExpL FunName b, [(Ty, b, CExpL FunName b)]) 98 | liftExp e = 99 | case e of 100 | ANF.E_Let a ty b c -> do 101 | b' <- liftCExp b 102 | (c', cdecls) <- liftExp c 103 | pure (c', (ty, a, b') : cdecls) 104 | ANF.E_AExp a -> (, []) <$> liftAExp a 105 | 106 | lambdaLift :: ANF.Exp b -> Prog FunName b 107 | lambdaLift e = Prog (decls <> fmap toValDecl adecls) a 108 | where 109 | ((a, adecls), decls) = evalState (runWriterT $ liftExp e) 0 -------------------------------------------------------------------------------- /src/LLVM.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts #-} 2 | {-# language OverloadedStrings #-} 3 | module LLVM where 4 | 5 | import Control.Monad (void) 6 | import Control.Monad.Reader (MonadReader, asks, local) 7 | import Data.Foldable (traverse_) 8 | 9 | import LLVM.AST (Operand) 10 | import LLVM.IRBuilder (MonadModuleBuilder, MonadIRBuilder) 11 | 12 | import qualified LLVM.AST.Constant as LLVM 13 | import qualified LLVM.AST.Name as LLVM 14 | import qualified LLVM.AST.Type as LLVM 15 | import qualified LLVM.IRBuilder as LLVM 16 | 17 | import LL 18 | 19 | data Env 20 | = Env 21 | { names :: [(Either FunName LocalName, Operand)] 22 | , args :: Maybe (Operand, Operand) 23 | } 24 | 25 | aexpLLVM :: 26 | ( MonadIRBuilder m 27 | , MonadReader Env m 28 | ) => 29 | AExpL FunName LocalName -> 30 | m Operand 31 | aexpLLVM tm = 32 | case tm of 33 | A_Var a -> do 34 | mv <- asks $ lookup a . names 35 | case mv of 36 | Nothing -> error "missing variable" 37 | Just v -> pure v 38 | A_Ix a -> do 39 | mv <- asks args 40 | case mv of 41 | Nothing -> error "not in function" 42 | Just (env, arg) -> 43 | case a of 44 | 0 -> pure arg 45 | n -> LLVM.extractValue env [fromIntegral $ n-1] 46 | A_AppF a b -> error "appF unsupported" 47 | A_Fun a b -> do 48 | b' <- aexpLLVM b 49 | clos <- 50 | LLVM.struct 51 | Nothing 52 | False 53 | [ LLVM.Undef $ LLVM.ptr LLVM.void 54 | , LLVM.Undef $ 55 | LLVM.FunctionType 56 | LLVM.void 57 | [LLVM.ptr LLVM.void, LLVM.void] 58 | False 59 | ] 60 | mv <- asks $ lookup (Left a) . names 61 | case mv of 62 | Nothing -> error "function name not found" 63 | Just v -> do 64 | LLVM.insertValue clos b' [0] 65 | LLVM.insertValue clos v [1] 66 | A_Nat32 a -> LLVM.int32 $ fromIntegral a 67 | A_Unit -> LLVM.array [] 68 | A_Nil -> LLVM.array [] 69 | A_AddNat32 a b -> do 70 | a' <- aexpLLVM a 71 | b' <- aexpLLVM b 72 | LLVM.add a' b' 73 | 74 | tyLLVM :: Ty -> LLVM.Type 75 | tyLLVM t = 76 | case t of 77 | TyArr a b -> 78 | LLVM.StructureType 79 | False 80 | [ LLVM.ptr LLVM.void 81 | , LLVM.FunctionType 82 | (tyLLVM b) 83 | [LLVM.ptr LLVM.void, tyLLVM a] 84 | False 85 | ] 86 | TyUnit -> LLVM.void 87 | TyNat32 -> LLVM.i32 88 | TySub{} -> LLVM.ptr LLVM.void 89 | 90 | valDeclLLVM :: 91 | ( MonadModuleBuilder m 92 | , MonadReader Env m 93 | ) => 94 | (Ty, LocalName, CExpL FunName LocalName) -> 95 | m Operand 96 | valDeclLLVM (ty, n, body) = _ 97 | 98 | valDeclsLLVM :: 99 | ( MonadModuleBuilder m 100 | , MonadReader Env m 101 | ) => 102 | [(Ty, LocalName, CExpL FunName LocalName)] -> 103 | m a -> 104 | m a 105 | valDeclsLLVM [] m = m 106 | valDeclsLLVM (d@(_, n, _) : ds) m = do 107 | vname <- valDeclLLVM d 108 | local (\e -> e { names = (Right n, vname) : names e}) $ 109 | valDeclsLLVM ds m 110 | 111 | declsLLVM :: 112 | ( MonadModuleBuilder m 113 | , MonadReader Env m 114 | ) => 115 | [Decl FunName LocalName] -> 116 | m a -> 117 | m a 118 | declsLLVM [] m = m 119 | declsLLVM (d : ds) m = 120 | case d of 121 | D_Fun retTy (FunName n) inTy body ret -> do 122 | fname <- 123 | LLVM.function 124 | (LLVM.mkName n) 125 | [ (LLVM.ptr LLVM.void, LLVM.ParameterName "env") 126 | , (tyLLVM inTy, LLVM.ParameterName "x") 127 | ] 128 | (tyLLVM retTy) $ \[env, arg] -> 129 | local (\e -> e { args = Just (env, arg) }) $ 130 | valDeclsLLVM body $ LLVM.ret =<< aexpLLVM ret 131 | local (\e -> e { names = (Left $ FunName n, fname) : names e}) $ 132 | declsLLVM ds m 133 | D_Val ty n body -> do 134 | vname <- valDeclLLVM (ty, n, body) 135 | local (\e -> e { names = (Right n, vname) : names e}) $ 136 | declsLLVM ds m 137 | 138 | progLLVM :: 139 | ( MonadModuleBuilder m 140 | , MonadReader Env m 141 | ) => 142 | Prog FunName LocalName -> 143 | m () 144 | progLLVM (Prog ds val) = 145 | declsLLVM ds $ 146 | void . LLVM.function "main" [] LLVM.i32 $ \_ -> do 147 | LLVM.ret =<< aexpLLVM val 148 | -------------------------------------------------------------------------------- /src/Machine.hs: -------------------------------------------------------------------------------- 1 | module Machine where 2 | 3 | import Prelude hiding (read) 4 | 5 | import Control.Monad (when) 6 | import Control.Monad.ST (ST, runST) 7 | import Control.Monad.Except (ExceptT, runExceptT, throwError) 8 | import Control.Monad.Trans (lift) 9 | import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef, modifySTRef) 10 | import Data.Vector (Vector) 11 | import Data.Vector.Mutable (MVector) 12 | import Data.Word (Word32) 13 | 14 | import qualified Data.Vector as Vector 15 | import qualified Data.Vector.Mutable as MVector 16 | 17 | import Closure (Exp(..), toInt, toList) 18 | 19 | data Prim 20 | = PAddr !Int 21 | | PVar !Int 22 | | PNat32 !Word32 23 | deriving (Eq, Show) 24 | 25 | data PrimOp 26 | = PAddNat32 Prim Prim 27 | deriving (Eq, Show) 28 | 29 | data Node 30 | = NodeAppF Prim Prim 31 | | NodeAppT Prim Prim 32 | | NodeSubst Prim Prim 33 | | NodeLam Prim Prim 34 | | NodeUnit 35 | | NodeClosure (Vector Prim) 36 | | NodePrimOp PrimOp 37 | deriving (Eq, Show) 38 | 39 | data Code = CPrim Prim | CNode Node 40 | deriving (Eq, Show) 41 | 42 | data Cell 43 | = Node Node 44 | | Prim Prim 45 | | Blackhole 46 | | Empty 47 | deriving (Eq, Show) 48 | 49 | data Action 50 | = Eval 51 | | Apply Prim 52 | | Update Int 53 | | Spread Prim 54 | | Extend Prim 55 | deriving (Eq, Show) 56 | 57 | data State s 58 | = State 59 | { heapPointer :: STRef s Int 60 | , heap :: MVector s Cell 61 | , kont :: STRef s [Action] 62 | , code :: STRef s Code 63 | } 64 | 65 | data Trace 66 | = Trace 67 | { traceHP :: Int 68 | , traceHeap :: Vector Cell 69 | , traceKont :: [Action] 70 | , traceCode :: Code 71 | } deriving (Eq, Show) 72 | 73 | traceState :: State s -> ST s Trace 74 | traceState st = do 75 | h <- readSTRef $ heapPointer st 76 | hp <- Vector.freeze $ heap st 77 | ks <- readSTRef $ kont st 78 | cde <- readSTRef $ code st 79 | pure $ 80 | Trace 81 | { traceHP = h 82 | , traceHeap = hp 83 | , traceKont = ks 84 | , traceCode = cde 85 | } 86 | 87 | data RuntimeError 88 | = HeapExhausted 89 | | OutOfBounds 90 | | InvalidNode 91 | | Loop 92 | | InvalidState Trace 93 | deriving (Eq, Show) 94 | 95 | alloc :: State s -> Cell -> ExceptT RuntimeError (ST s) Int 96 | alloc st n = do 97 | addr <- lift $ readSTRef (heapPointer st) 98 | when (addr == MVector.length (heap st)) $ throwError HeapExhausted 99 | lift $ writeSTRef (heapPointer st) (addr+1) 100 | addr <$ MVector.write (heap st) addr n 101 | 102 | checkBounds :: State s -> Int -> ExceptT RuntimeError (ST s) () 103 | checkBounds st addr = do 104 | hp <- lift $ readSTRef (heapPointer st) 105 | when (addr >= hp) $ throwError OutOfBounds 106 | 107 | update :: State s -> Int -> Cell -> ExceptT RuntimeError (ST s) () 108 | update st addr c = checkBounds st addr *> MVector.write (heap st) addr c 109 | 110 | read :: State s -> Int -> ExceptT RuntimeError (ST s) Cell 111 | read st addr = checkBounds st addr *> MVector.read (heap st) addr 112 | 113 | loadVar :: Exp a -> ExceptT RuntimeError (ST s) Prim 114 | loadVar e = 115 | case toInt e of 116 | Nothing -> throwError InvalidNode 117 | Just n -> pure $ PVar n 118 | 119 | loadCtx :: State s -> Exp a -> ExceptT RuntimeError (ST s) Prim 120 | loadCtx st e = 121 | case toList e of 122 | Nothing -> throwError InvalidNode 123 | Just as -> do 124 | as' <- traverse (load st) as 125 | PAddr <$> alloc st (Node $ NodeClosure $ Vector.fromList as') 126 | 127 | load :: State s -> Exp a -> ExceptT RuntimeError (ST s) Prim 128 | load st e = 129 | case e of 130 | VZ{} -> loadVar e 131 | VS{} -> loadVar e 132 | Nat32 _ n -> pure $ PNat32 n 133 | AppF _ a b -> do 134 | a' <- load st a 135 | b' <- load st b 136 | PAddr <$> alloc st (Node $ NodeAppF a' b') 137 | AppT _ a b -> do 138 | a' <- load st a 139 | b' <- load st b 140 | PAddr <$> alloc st (Node $ NodeAppT a' b') 141 | Subst _ a b -> do 142 | a' <- load st a 143 | b' <- load st b 144 | PAddr <$> alloc st (Node $ NodeSubst a' b') 145 | Lam _ a b -> do 146 | a' <- load st a 147 | b' <- load st b 148 | PAddr <$> alloc st (Node $ NodeLam a' b') 149 | Nil{} -> loadCtx st e 150 | Cons{} -> loadCtx st e 151 | Unit _ -> PAddr <$> alloc st (Node NodeUnit) 152 | AddNat32 _ a b -> do 153 | a' <- load st a 154 | b' <- load st b 155 | PAddr <$> alloc st (Node $ NodePrimOp $ PAddNat32 a' b') 156 | 157 | initialState :: Int -> ST s (State s) 158 | initialState sz = do 159 | hp <- newSTRef 0 160 | h <- MVector.replicate sz Empty 161 | ks <- newSTRef [] 162 | cde <- newSTRef undefined 163 | pure $ 164 | State 165 | { heapPointer = hp 166 | , heap = h 167 | , kont = ks 168 | , code = cde 169 | } 170 | 171 | run :: Int -> Exp a -> Either RuntimeError [Trace] 172 | run sz e = 173 | runST $ do 174 | st <- initialState sz 175 | runExceptT $ eval st e 176 | 177 | eval :: State s -> Exp a -> ExceptT RuntimeError (ST s) [Trace] 178 | eval st e = do 179 | start <- load st e 180 | lift $ writeSTRef (code st) (CPrim start) 181 | lift $ modifySTRef (kont st) (Eval :) 182 | go 183 | where 184 | halt tr = pure [tr] 185 | 186 | continue tr = (tr :) <$> go 187 | 188 | invalidState :: Trace -> ExceptT RuntimeError (ST s) a 189 | invalidState tr = throwError $ InvalidState tr 190 | 191 | go = do 192 | tr <- lift $ traceState st 193 | insts <- lift $ readSTRef (kont st) 194 | case insts of 195 | [] -> halt tr 196 | Update a : rest -> do 197 | cur <- lift $ readSTRef (code st) 198 | case cur of 199 | CPrim p -> update st a $ Prim p 200 | CNode n -> update st a $ Node n 201 | lift $ writeSTRef (kont st) rest 202 | continue tr 203 | Apply arg : rest -> do 204 | cur <- lift $ readSTRef (code st) 205 | case cur of 206 | CPrim{} -> invalidState tr 207 | CNode n -> 208 | case n of 209 | NodePrimOp{} -> invalidState tr 210 | NodeAppF{} -> do 211 | addr' <- PAddr <$> alloc st (Node n) 212 | lift $ writeSTRef (code st) (CNode $ NodeAppF addr' arg) 213 | lift $ writeSTRef (kont st) rest 214 | NodeSubst{} -> 215 | lift $ modifySTRef (kont st) (Eval :) 216 | NodeAppT{} -> 217 | lift $ modifySTRef (kont st) (Eval :) 218 | NodeLam a b -> do 219 | lift $ writeSTRef (code st) (CPrim a) 220 | lift $ writeSTRef (kont st) (Eval : Extend arg : Apply b : Eval : rest) 221 | NodeUnit -> invalidState tr 222 | NodeClosure{} -> invalidState tr 223 | continue tr 224 | Extend addr : rest -> do 225 | cur <- lift $ readSTRef (code st) 226 | case cur of 227 | CPrim{} -> invalidState tr 228 | CNode n -> 229 | case n of 230 | NodeClosure cl -> do 231 | lift $ writeSTRef (code st) (CNode $ NodeClosure $ Vector.cons addr cl) 232 | lift $ writeSTRef (kont st) rest 233 | continue tr 234 | _ -> invalidState tr 235 | Spread arg : rest -> do 236 | cur <- lift $ readSTRef (code st) 237 | case arg of 238 | PAddr addr -> 239 | case cur of 240 | CPrim p -> 241 | case p of 242 | PNat32{} -> invalidState tr 243 | PVar v -> do 244 | c <- read st addr 245 | case c of 246 | Node (NodeClosure cl) -> lift $ writeSTRef (code st) (CPrim $ cl Vector.! v) 247 | _ -> invalidState tr 248 | PAddr{} -> lift $ modifySTRef (kont st) (Eval :) 249 | CNode n -> 250 | case n of 251 | NodePrimOp p -> do 252 | c <- read st addr 253 | case c of 254 | Node (NodeClosure cl) -> 255 | case p of 256 | PAddNat32 a b -> do 257 | a' <- 258 | case a of 259 | PNat32{} -> pure a 260 | PAddr{} -> invalidState tr 261 | PVar v -> pure $ cl Vector.! v 262 | b' <- 263 | case b of 264 | PNat32{} -> pure b 265 | PAddr{} -> invalidState tr 266 | PVar v -> pure $ cl Vector.! v 267 | lift $ writeSTRef (code st) (CNode $ NodePrimOp $ PAddNat32 a' b') 268 | lift $ writeSTRef (kont st) rest 269 | _ -> invalidState tr 270 | NodeUnit -> invalidState tr 271 | NodeAppF a b -> do 272 | a' <- PAddr <$> alloc st (Node $ NodeAppT (PAddr addr) a) 273 | b' <- PAddr <$> alloc st (Node $ NodeAppT (PAddr addr) b) 274 | lift $ writeSTRef (code st) (CNode $ NodeAppT a' b') 275 | lift $ writeSTRef (kont st) rest 276 | NodeSubst{} -> lift $ modifySTRef (kont st) (Eval :) 277 | NodeAppT{} -> lift $ modifySTRef (kont st) (Eval :) 278 | NodeLam a b -> do 279 | a' <- PAddr <$> alloc st (Node $ NodeAppT (PAddr addr) a) 280 | lift $ writeSTRef (code st) (CNode $ NodeLam a' b) 281 | lift $ writeSTRef (kont st) rest 282 | NodeClosure cl -> do 283 | cl' <- traverse (\c -> PAddr <$> alloc st (Node $ NodeAppT (PAddr addr) c)) cl 284 | lift $ writeSTRef (code st) (CNode $ NodeClosure cl') 285 | lift $ writeSTRef (kont st) rest 286 | _ -> invalidState tr 287 | continue tr 288 | Eval : rest -> do 289 | cur <- lift $ readSTRef (code st) 290 | let 291 | evalNode n = 292 | case n of 293 | NodePrimOp p -> 294 | case p of 295 | PAddNat32 a b -> 296 | case (a, b) of 297 | (PNat32 v1, PNat32 v2) -> 298 | lift $ writeSTRef (code st) (CPrim $ PNat32 (v1+v2)) 299 | _ -> pure () 300 | NodeAppF{} -> pure () 301 | NodeUnit -> pure () 302 | NodeLam{} -> pure () 303 | NodeClosure{} -> pure () 304 | NodeSubst a b -> do 305 | lift $ writeSTRef (code st) (CPrim b) 306 | lift $ writeSTRef (kont st) (Spread a : rest) 307 | NodeAppT a b -> do 308 | lift $ writeSTRef (code st) (CPrim a) 309 | lift $ modifySTRef (kont st) ((:) Eval . (:) (Apply b)) 310 | 311 | case cur of 312 | CPrim p -> 313 | case p of 314 | PVar{} -> do 315 | lift $ writeSTRef (kont st) rest 316 | continue tr 317 | PNat32{} -> do 318 | lift $ writeSTRef (kont st) rest 319 | continue tr 320 | PAddr addr -> do 321 | c <- read st addr 322 | case c of 323 | Prim p' -> do 324 | lift $ writeSTRef (code st) (CPrim p') 325 | lift $ writeSTRef (kont st) rest 326 | continue tr 327 | Blackhole -> throwError Loop 328 | Empty -> throwError OutOfBounds 329 | Node n -> do 330 | lift $ writeSTRef (kont st) (Update addr : rest) 331 | lift $ writeSTRef (code st) (CNode n) 332 | evalNode n 333 | continue tr 334 | CNode n -> do 335 | lift $ writeSTRef (kont st) rest 336 | evalNode n 337 | continue tr --------------------------------------------------------------------------------