├── .gitignore ├── .hlint.yaml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── src ├── A.hs ├── C.hs ├── F.hs ├── K.hs ├── Main.hs ├── TAL.hs ├── Translate.hs └── Util.hs ├── stack.yaml ├── stack.yaml.lock └── tal.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .virtualenv 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | .stack-work 18 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # This file contains a template configuration file, which is typically 6 | # placed as .hlint.yaml in the root of your project 7 | 8 | 9 | # Warnings currently triggered by your code 10 | - ignore: {name: "Unused LANGUAGE pragma"} 11 | - ignore: {name: "Eta reduce"} 12 | - ignore: {name: "Use foldl"} 13 | - ignore: {name: "Redundant bracket"} 14 | - ignore: {name: "Fuse mapM_/map"} 15 | - ignore: {name: "Redundant $"} 16 | 17 | 18 | # Specify additional command line arguments 19 | # 20 | # - arguments: [--color, --cpp-simple, -XQuasiQuotes] 21 | 22 | 23 | # Control which extensions/flags/modules/functions can be used 24 | # 25 | # - extensions: 26 | # - default: false # all extension are banned by default 27 | # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used 28 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module 29 | # 30 | # - flags: 31 | # - {name: -w, within: []} # -w is allowed nowhere 32 | # 33 | # - modules: 34 | # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' 35 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely 36 | # 37 | # - functions: 38 | # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules 39 | 40 | 41 | # Add custom hints for this project 42 | # 43 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" 44 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} 45 | 46 | # The hints are named by the string they display in warning messages. 47 | # For example, if you see a warning starting like 48 | # 49 | # Main.hs:116:51: Warning: Redundant == 50 | # 51 | # You can refer to that hint with `{name: Redundant ==}` (see below). 52 | 53 | # Turn on hints that are off by default 54 | # 55 | # Ban "module X(module X) where", to require a real export list 56 | # - warn: {name: Use explicit module export list} 57 | # 58 | # Replace a $ b $ c with a . b $ c 59 | # - group: {name: dollar, enabled: true} 60 | # 61 | # Generalise map to fmap, ++ to <> 62 | # - group: {name: generalise, enabled: true} 63 | 64 | 65 | # Ignore some builtin hints 66 | # - ignore: {name: Use let} 67 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules 68 | 69 | 70 | # Define some custom infix operators 71 | # - fixity: infixr 3 ~^#^~ 72 | 73 | 74 | # To generate a suitable file for HLint do: 75 | # $ hlint --default > .hlint.yaml 76 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | CHANGELOG 2 | --------- 3 | 4 | * v 0.1.1.0 5 | 6 | Switch binding library to unbound-generics 7 | Add stack support: lts-16.11 8 | Add simple test suite 9 | 10 | * v 0.1.0.0 11 | 12 | Initial version, uses unbound library for variable names. -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 Stephanie Weirich 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | An implementation of a type-preserving Compiler, derived from the paper 2 | 3 | [From System F to Typed Assembly Language](https://www.cs.princeton.edu/~dpw/papers/tal-toplas.pdf) 4 | by Morrisett, Walker, Crary, Glew 5 | 6 | I was inspired to implement this paper while preparing for 7 | [Papers We Love](https://www.youtube.com/watch?v=Epbaka9uTQ4). 8 | 9 | The implementation includes all passes described in the paper: 10 | 11 | * F ==> K (Typed CPS conversion) 12 | * K ==> C (Polymorphic closure conversion) 13 | * C ==> H (Hoisting, reuses the C language) 14 | * H ==> A (Allocation) 15 | * A ==> TAL (Code generation) 16 | 17 | Each language (F, K, C, A, TAL) is defined in the corresponding source 18 | file. These implementations include the abstract syntax, small-step 19 | operational semantics, and type checker for the languages. The file 20 | [Util.hs](src/Util.hs) contains definitions common to all implementations. 21 | 22 | The compiler itself is in the file [translate.hs](src/translate.hs). To run 23 | the compiler, load this file into ghci and try out one of the sample programs from [F.hs](src/F.hs). 24 | 25 | In particular, you can try 26 | 27 | Translate*> printM $ compile F.sixfact 28 | 29 | to see the TAL output for the factorial function applied to six. 30 | 31 | If you would like to compile and then run this function you can try: 32 | 33 | Translate*> test F.sixfact 34 | 35 | ------------------------------------------------------------------------- -------------------------------------------------------------------------------- /src/A.hs: -------------------------------------------------------------------------------- 1 | module A where 2 | 3 | import GHC.Generics 4 | import Unbound.Generics.LocallyNameless hiding (prec,empty,Data,Refl,Val) 5 | import Unbound.Generics.LocallyNameless.Alpha 6 | 7 | import Control.Monad 8 | import Control.Monad.Except 9 | 10 | import Data.Monoid (Monoid(..)) 11 | 12 | import qualified Data.List as List 13 | import Data.Map (Map) 14 | import qualified Data.Map as Map 15 | 16 | 17 | import Util 18 | import Text.PrettyPrint as PP 19 | 20 | 21 | -- System A 22 | 23 | type TyName = Name Ty 24 | type ValName = Name Val 25 | 26 | data Flag = Un | Init 27 | deriving (Eq, Ord, Show, Generic) 28 | 29 | data Ty = TyVar TyName 30 | | TyInt 31 | | All (Bind [TyName] [Ty]) 32 | | TyProd [(Ty, Flag)] -- new 33 | | Exists (Bind TyName Ty) 34 | deriving (Show, Generic) 35 | 36 | data Val = TmInt Int 37 | | TmVar ValName 38 | | TApp (Ann Val) Ty 39 | | Pack Ty (Ann Val) 40 | deriving (Show, Generic) 41 | 42 | data Ann v = Ann v Ty 43 | deriving (Show, Generic) 44 | 45 | data Decl = 46 | DeclVar ValName (Embed (Ann Val)) 47 | | DeclPrj Int ValName (Embed (Ann Val)) 48 | | DeclPrim ValName (Embed (Ann Val, Prim, Ann Val)) 49 | | DeclUnpack TyName ValName (Embed (Ann Val)) 50 | | DeclMalloc ValName (Embed [Ty]) -- new 51 | | DeclAssign ValName (Embed (Ann Val, Int, Ann Val)) --new 52 | -- x = v1 [i] <- v2 53 | deriving (Show, Generic) 54 | 55 | data Tm = 56 | Let (Bind Decl Tm) 57 | | App (Ann Val) [Ann Val] 58 | | TmIf0 (Ann Val) Tm Tm 59 | | Halt Ty (Ann Val) 60 | deriving (Show, Generic) 61 | 62 | data HeapVal = 63 | Tuple [Ann Val] 64 | | Code (Bind [TyName] (Bind [ValName] Tm)) 65 | deriving (Show, Generic) 66 | 67 | newtype Heap = Heap (Map ValName (Ann HeapVal)) 68 | deriving (Semigroup, Monoid) 69 | 70 | ------------------------------------------------------ 71 | instance Alpha Flag 72 | instance Alpha Ty 73 | instance Alpha Val 74 | instance Alpha a => Alpha (Ann a) 75 | instance Alpha Decl 76 | instance Alpha Tm 77 | 78 | instance Subst Ty Ty where 79 | isvar (TyVar x) = Just (SubstName x) 80 | isvar _ = Nothing 81 | instance Subst Ty Prim 82 | instance Subst Ty Tm 83 | instance Subst Ty (Ann Val) 84 | instance Subst Ty Decl 85 | instance Subst Ty Val 86 | instance Subst Ty Flag 87 | 88 | instance Subst Val Flag 89 | instance Subst Val Prim 90 | instance Subst Val Ty 91 | instance Subst Val (Ann Val) 92 | instance Subst Val Decl 93 | instance Subst Val Tm 94 | instance Subst Val Val where 95 | isvar (TmVar x) = Just (SubstName x) 96 | isvar _ = Nothing 97 | 98 | ------------------------------------------------------ 99 | -- Helper functions 100 | ------------------------------------------------------ 101 | 102 | -- Tag all error messages as from this module 103 | throwErrorA :: MonadError String m => String -> m a 104 | throwErrorA s = throwError ("A:" ++ s) 105 | 106 | mkTyApp :: (MonadError String m, Fresh m) => Ann Val -> [Ty] -> m (Ann Val) 107 | mkTyApp av [] = return av 108 | mkTyApp av@(Ann _ (All bnd)) (ty:tys) = do 109 | (as, atys) <- unbind bnd 110 | case as of 111 | a:as' -> 112 | let atys' = subst a ty atys in 113 | mkTyApp (Ann (TApp av ty) (All (bind as' atys'))) tys 114 | _ -> throwErrorA "mkTyApp: not a polymorphic All" 115 | mkTyApp (Ann _ ty) _ = throwErrorA "type error: not an All" 116 | 117 | lets :: [Decl] -> Tm -> Tm 118 | lets [] tm = tm 119 | lets (d:ds) tm = Let (bind d (lets ds tm)) 120 | 121 | ----------------------------------------------------------------- 122 | -- Typechecker 123 | ----------------------------------------------------------------- 124 | 125 | type Delta = [ TyName ] 126 | type Gamma = [ (ValName, Ty) ] 127 | 128 | data Ctx = Ctx { getDelta :: Delta , getGamma :: Gamma } 129 | deriving Show 130 | 131 | emptyCtx :: Ctx 132 | emptyCtx = Ctx { getDelta = [], getGamma = [] } 133 | 134 | checkTyVar :: Ctx -> TyName -> M () 135 | checkTyVar g v = do 136 | unless (v `List.elem` getDelta g) $ 137 | throwErrorA $ "Type variable not found " ++ show v ++ "\n" 138 | ++ "in context: " ++ pp g 139 | 140 | lookupTmVar :: Ctx -> ValName -> M Ty 141 | lookupTmVar g v = do 142 | case lookup v (getGamma g) of 143 | Just s -> return s 144 | Nothing -> throwErrorA $ "Term variable not found " ++ show v ++ "\n" 145 | ++ "in context: " ++ pp g 146 | 147 | extendTy :: TyName -> Ctx -> Ctx 148 | extendTy n ctx = ctx { getDelta = n : getDelta ctx } 149 | 150 | extendTys :: [TyName] -> Ctx -> Ctx 151 | extendTys ns ctx = foldr extendTy ctx ns 152 | 153 | extendTm :: ValName -> Ty -> Ctx -> Ctx 154 | extendTm n ty ctx = ctx { getGamma = (n, ty) : getGamma ctx } 155 | 156 | extendTms :: [ValName] -> [Ty] -> Ctx -> Ctx 157 | extendTms [] [] ctx = ctx 158 | extendTms (n:ns) (ty:tys) ctx = extendTm n ty (extendTms ns tys ctx) 159 | extendTms _ _ _ = error "wrong number" 160 | 161 | 162 | tcty :: Ctx -> Ty -> M () 163 | tcty g (TyVar x) = 164 | checkTyVar g x 165 | tcty g (All b) = do 166 | (xs, tys) <- unbind b 167 | let g' = extendTys xs g 168 | mapM_ (tcty g') tys 169 | tcty g TyInt = return () 170 | tcty g (TyProd tys) = do 171 | mapM_ (tcty g . fst) tys 172 | tcty g (Exists b) = do 173 | (a, ty) <- unbind b 174 | tcty (extendTy a g) ty 175 | 176 | 177 | typecheckHeapVal :: Ctx -> Ann HeapVal -> M Ty 178 | typecheckHeapVal g (Ann (Code bnd) (All bnd')) = do 179 | mb <- unbind2 bnd bnd' -- may fail 180 | case mb of 181 | Just (as, bnd2, _, tys) -> do 182 | (xs, e) <- unbind bnd2 183 | let g' = extendTys as g 184 | mapM_ (tcty g') tys 185 | typecheck (extendTms xs tys g') e 186 | return (All bnd') 187 | Nothing -> throwErrorA "wrong # of type variables" 188 | typecheckHeapVal g (Ann (Code bnd) _ ) = 189 | throwErrorA "code must have forall type" 190 | 191 | typecheckHeapVal g (Ann (Tuple es) ty) = do 192 | tys <- mapM (typecheckAnnVal g) es 193 | let ty' = TyProd $ map (,Un) tys 194 | if ty `aeq` ty' 195 | then return ty 196 | else throwErrorA "incorrect annotation on tuple" 197 | 198 | typecheckVal :: Ctx -> Val -> M Ty 199 | typecheckVal g (TmVar x) = lookupTmVar g x 200 | typecheckVal g (TmInt i) = return TyInt 201 | typecheckVal g (TApp av ty) = do 202 | tcty g ty 203 | ty' <- typecheckAnnVal g av 204 | case ty' of 205 | All bnd -> do 206 | (as, bs) <- unbind bnd 207 | case as of 208 | [] -> throwErrorA "can't instantiate non-polymorphic function" 209 | (a:as') -> do 210 | let bs' = subst a ty bs 211 | return (All (bind as' bs')) 212 | _ -> throwErrorA "type error" 213 | typecheckVal g (Pack _ _) = throwErrorA "pack must be annotated" 214 | 215 | typecheckAnnVal :: Ctx -> Ann Val -> M Ty 216 | typecheckAnnVal g (Ann (Pack ty1 av) ty) = do 217 | case ty of 218 | Exists bnd -> do 219 | (a, ty2) <- unbind bnd 220 | tcty g ty1 221 | ty' <- typecheckAnnVal g av 222 | if not (ty' `aeq` subst a ty1 ty2) 223 | then throwErrorA "type error" 224 | else return ty 225 | _ -> throwErrorA "must be exists for pack" 226 | typecheckAnnVal g (Ann v ty) = do 227 | tcty g ty 228 | ty' <- typecheckVal g v 229 | if ty `aeq` ty' 230 | then return ty 231 | else throwErrorA $ "wrong annotation on: " ++ pp v ++ "\nInferred: " ++ pp ty' ++ "\nAnnotated: " ++ pp ty 232 | 233 | typecheckDecl :: Ctx -> Decl -> M Ctx 234 | typecheckDecl g (DeclVar x (Embed av)) = do 235 | ty <- typecheckAnnVal g av 236 | return $ extendTm x ty g 237 | typecheckDecl g (DeclPrj i x (Embed av@(Ann v _))) = do 238 | ty <- typecheckAnnVal g av 239 | case ty of 240 | TyProd tys | i < length tys -> 241 | return $ extendTm x (fst (tys !! i)) g 242 | _ -> throwErrorA "cannot project" 243 | typecheckDecl g (DeclPrim x (Embed (av1, _, av2))) = do 244 | ty1 <- typecheckAnnVal g av1 245 | ty2 <- typecheckAnnVal g av2 246 | case (ty1 , ty2) of 247 | (TyInt, TyInt) -> return $ extendTm x TyInt g 248 | _ -> throwErrorA "TypeError" 249 | typecheckDecl g (DeclUnpack a x (Embed av)) = do 250 | tya <- typecheckAnnVal g av 251 | case tya of 252 | Exists bnd -> do 253 | let ty = patUnbind a bnd 254 | return $ extendTy a (extendTm x ty g) 255 | _ -> throwErrorA "TypeError" 256 | typecheckDecl g (DeclMalloc x (Embed tys)) = do 257 | mapM_ (tcty g) tys 258 | return $ extendTm x (TyProd (map (,Un) tys)) g 259 | typecheckDecl g (DeclAssign x (Embed (av1@(Ann v1 _), i, av2))) = do 260 | ty1 <- typecheckAnnVal g av1 261 | ty2 <- typecheckAnnVal g av2 262 | case ty1 of 263 | TyProd tys | i < length tys -> 264 | let (xs,(ty,_):ys) = splitAt i tys in 265 | if ty `aeq` ty2 266 | then return $ extendTm x (TyProd (xs ++ (ty,Init) : ys)) g 267 | else throwErrorA "TypeError" 268 | _ -> throwErrorA "TypeError" 269 | 270 | typecheck :: Ctx -> Tm -> M () 271 | typecheck g (Let bnd) = do 272 | (d,e) <- unbind bnd 273 | g' <- typecheckDecl g d 274 | typecheck g' e 275 | typecheck g (App av es) = do 276 | ty <- typecheckAnnVal g av 277 | case ty of 278 | (All bnd) -> do 279 | (as, argtys) <- unbind bnd 280 | argtys' <- mapM (typecheckAnnVal g) es 281 | if not (null as) 282 | then throwErrorA "must use type application" 283 | else 284 | if length argtys /= length argtys' 285 | then throwErrorA "incorrect args" 286 | else unless (and (zipWith aeq argtys argtys')) $ 287 | throwErrorA "arg mismatch" 288 | _ -> throwErrorA "need forall type" 289 | typecheck g (TmIf0 av e1 e2) = do 290 | ty0 <- typecheckAnnVal g av 291 | typecheck g e1 292 | typecheck g e2 293 | if ty0 `aeq` TyInt then 294 | return () 295 | else 296 | throwErrorA "TypeError" 297 | typecheck g (Halt ty av) = do 298 | ty' <- typecheckAnnVal g av 299 | unless (ty `aeq` ty') $ 300 | throwErrorA "type error" 301 | 302 | 303 | 304 | progcheck :: (Tm, Heap) -> M () 305 | progcheck (tm, Heap m) = do 306 | let g = 307 | Map.foldlWithKey (\ctx x (Ann _ ty) -> extendTm x ty ctx) 308 | emptyCtx m 309 | mapM_ (typecheckHeapVal g) (Map.elems m) 310 | typecheck g tm 311 | 312 | ----------------------------------------------------------------- 313 | -- Pretty-printer 314 | ----------------------------------------------------------------- 315 | 316 | instance Display Ty where 317 | display (TyVar n) = display n 318 | display TyInt = return $ text "Int" 319 | display (All bnd) = lunbind bnd $ \ (as,tys) -> do 320 | da <- displayList as 321 | dt <- displayList tys 322 | if null as 323 | then return $ parens dt <+> text "-> void" 324 | else prefix "forall" (brackets da PP.<> text "." <+> parens dt <+> text "-> void") 325 | display (TyProd tys) = displayTuple tys 326 | display (Exists bnd) = lunbind bnd $ \ (a,ty) -> do 327 | da <- display a 328 | dt <- display ty 329 | prefix "exists" (da PP.<> text "." <+> dt) 330 | 331 | instance Display (Ty, Flag) where 332 | display (ty, fl) = do 333 | dty <- display ty 334 | let f = case fl of { Un -> "0" ; Init -> "1" } 335 | return $ dty PP.<> text "^" PP.<> text f 336 | 337 | instance Display (ValName,Embed Ty) where 338 | display (n, Embed ty) = do 339 | dn <- display n 340 | dt <- display ty 341 | return $ dn PP.<> colon PP.<> dt 342 | 343 | instance Display Val where 344 | display (TmInt i) = return $ int i 345 | display (TmVar n) = display n 346 | display (Pack ty e) = do 347 | dty <- display ty 348 | de <- display e 349 | prefix "pack" (brackets (dty PP.<> comma PP.<> de)) 350 | display (TApp av ty) = do 351 | dv <- display av 352 | dt <- display ty 353 | return $ dv <+> brackets dt 354 | 355 | instance Display HeapVal where 356 | display (Code bnd) = lunbind bnd $ \(as, bnd2) -> lunbind bnd2 $ \(xtys, e) -> do 357 | ds <- displayList as 358 | dargs <- displayList xtys 359 | de <- withPrec (precedence "code") $ display e 360 | let tyArgs = if null as then empty else brackets ds 361 | let tmArgs = if null xtys then empty else parens dargs 362 | prefix "code" (tyArgs PP.<> tmArgs PP.<> text "." $$ de) 363 | 364 | display (Tuple es) = displayTuple es 365 | 366 | 367 | instance Display a => Display (Ann a) where 368 | display (Ann av _) = display av 369 | 370 | instance Display Tm where 371 | display (App av args) = do 372 | da <- display av 373 | dargs <- displayList args 374 | let tmArgs = if null args then empty else space PP.<> parens dargs 375 | return $ da PP.<> tmArgs 376 | display (Halt ty v) = do 377 | dv <- display v 378 | --dt <- display ty 379 | return $ text "halt" <+> dv -- <+> text ":" <+> dt 380 | display (Let bnd) = lunbind bnd $ \(d, e) -> do 381 | dd <- display d 382 | de <- display e 383 | return (text "let" <+> dd <+> text "in" $$ de) 384 | display (TmIf0 e0 e1 e2) = do 385 | d0 <- display e0 386 | d1 <- display e1 387 | d2 <- display e2 388 | prefix "if0" $ parens $ sep [d0 PP.<> comma , d1 PP.<> comma, d2] 389 | 390 | instance Display Decl where 391 | display (DeclVar x (Embed av)) = do 392 | dx <- display x 393 | dv <- display av 394 | return $ dx <+> text "=" <+> dv 395 | display (DeclPrj i x (Embed av)) = do 396 | dx <- display x 397 | dv <- display av 398 | return $ dx <+> text "=" <+> text "pi" PP.<> int i <+> dv 399 | display (DeclPrim x (Embed (e1, p, e2))) = do 400 | dx <- display x 401 | let str = show p 402 | d1 <- display e1 403 | d2 <- display e2 404 | return $ dx <+> text "=" <+> d1 <+> text str <+> d2 405 | display (DeclUnpack a x (Embed av)) = do 406 | da <- display a 407 | dx <- display x 408 | dav <- display av 409 | return $ brackets (da PP.<> comma PP.<> dx) <+> text "=" <+> dav 410 | display (DeclMalloc x (Embed tys)) = do 411 | dx <- display x 412 | dtys <- displayTuple tys 413 | return $ dx <+> text "= malloc" PP.<> dtys 414 | display (DeclAssign x (Embed (av1, i, av2))) = do 415 | dx <- display x 416 | dav1 <- display av1 417 | dav2 <- display av2 418 | return $ dx <+> text "=" <+> dav1 <+> brackets (text (show i)) 419 | <+> text "<-" <+> dav2 420 | 421 | instance Display Heap where 422 | display (Heap m) = do 423 | fcns <- mapM (\(d,v) -> do 424 | dn <- display d 425 | dv <- display v 426 | return (dn, dv)) (Map.toList m) 427 | return $ hang (text "letrec") 2 $ 428 | vcat [ n <+> text "=" <+> dv | (n,dv) <- fcns ] 429 | 430 | instance Display (Tm, Heap) where 431 | display (tm,h) = do 432 | dh <- display h 433 | dt <- display tm 434 | return $ dh $$ text "in" <+> dt 435 | 436 | instance Display (ValName, Ty) where 437 | display (v, ty) = do 438 | dt <- display ty 439 | return $ text (show v) <+> colon <+> dt 440 | 441 | instance Display Ctx where 442 | display (Ctx delta gamma) = do 443 | tyvars <- mapM display delta 444 | tmvars <- mapM display gamma 445 | return $ vcat [text "delta:" <+> hsep tyvars, 446 | text "gamma:" <+> sep tmvars ] -------------------------------------------------------------------------------- /src/C.hs: -------------------------------------------------------------------------------- 1 | module C where 2 | 3 | import Unbound.Generics.LocallyNameless hiding (prec,empty,Data,Refl,Val) 4 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf) 5 | import Unbound.Generics.LocallyNameless.Alpha 6 | 7 | import Control.Monad 8 | import Control.Monad.Except 9 | 10 | import qualified Data.List as List 11 | import Data.Map (Map) 12 | import qualified Data.Map as Map 13 | 14 | 15 | import Util 16 | import Text.PrettyPrint as PP 17 | 18 | 19 | ------------------ 20 | -- should move to Unbound.LocallyNameless.Ops 21 | -- patUnbind :: (Alpha p, Alpha t) => p -> Bind p t -> t 22 | -- patUnbind p (B _ t) = openT p t 23 | ------------------ 24 | 25 | 26 | -- System C 27 | 28 | type TyName = Name Ty 29 | type TmName = Name Tm 30 | type ValName = Name Val 31 | 32 | data Ty = TyVar TyName 33 | | TyInt 34 | | All (Bind [TyName] [Ty]) 35 | | TyProd [Ty] 36 | | Exists (Bind TyName Ty) -- new 37 | deriving (Show, Generic) 38 | 39 | data Val = TmInt Int 40 | | TmVar ValName 41 | | Fix (Bind (ValName, [TyName]) (Bind [(ValName, Embed Ty)] Tm)) 42 | | TmProd [AnnVal] 43 | | TApp AnnVal Ty -- new 44 | | Pack Ty AnnVal -- new 45 | deriving (Show, Generic) 46 | 47 | data AnnVal = Ann Val Ty 48 | deriving (Show, Generic) 49 | 50 | data Decl = 51 | DeclVar ValName (Embed AnnVal) 52 | | DeclPrj Int ValName (Embed AnnVal) 53 | | DeclPrim ValName (Embed (AnnVal, Prim, AnnVal)) 54 | | DeclUnpack TyName ValName (Embed AnnVal) -- new 55 | deriving (Show, Generic) 56 | 57 | data Tm = Let (Bind Decl Tm) 58 | | App AnnVal [AnnVal] -- updated 59 | | TmIf0 AnnVal Tm Tm 60 | | Halt Ty AnnVal 61 | deriving (Show, Generic) 62 | 63 | -- For H 64 | 65 | newtype Heap = Heap (Map ValName AnnVal) 66 | deriving (Show, Semigroup, Monoid) 67 | 68 | 69 | ------------------------------------------------------ 70 | instance Alpha Ty 71 | instance Alpha Val 72 | instance Alpha AnnVal 73 | instance Alpha Decl 74 | instance Alpha Tm 75 | 76 | instance Subst Ty Ty where 77 | isvar (TyVar x) = Just (SubstName x) 78 | isvar _ = Nothing 79 | instance Subst Ty Prim 80 | instance Subst Ty Tm 81 | instance Subst Ty AnnVal 82 | instance Subst Ty Decl 83 | instance Subst Ty Val 84 | 85 | 86 | instance Subst Val Prim 87 | instance Subst Val Ty 88 | instance Subst Val AnnVal 89 | instance Subst Val Decl 90 | instance Subst Val Tm 91 | instance Subst Val Val where 92 | isvar (TmVar x) = Just (SubstName x) 93 | isvar _ = Nothing 94 | 95 | ------------------------------------------------------ 96 | -- Helper functions 97 | ------------------------------------------------------ 98 | 99 | mkTyApp :: (MonadError String m, Fresh m) => AnnVal -> [Ty] -> m AnnVal 100 | mkTyApp av [] = return av 101 | mkTyApp av@(Ann _ (All bnd)) (ty:tys) = do 102 | (as, atys) <- unbind bnd 103 | case as of 104 | a:as' -> 105 | let atys' = subst a ty atys in 106 | mkTyApp (Ann (TApp av ty) (All (bind as' atys'))) tys 107 | _ -> throwError "type error: not a polymorphic All" 108 | mkTyApp (Ann _ ty) _ = throwError "type error: not an All" 109 | 110 | mkProd :: [AnnVal] -> AnnVal 111 | mkProd vs = Ann (TmProd vs) (TyProd tys) where 112 | tys = map (\(Ann _ ty) -> ty) vs 113 | 114 | ----------------------------------------------------------------- 115 | -- Free variables, with types 116 | ----------------------------------------------------------------- 117 | 118 | x :: Name Tm 119 | y :: Name Tm 120 | z :: Name Tm 121 | (x,y,z) = (string2Name "x", string2Name "y", string2Name "z") 122 | 123 | a :: Name Ty 124 | b :: Name Ty 125 | c :: Name Ty 126 | (a,b,c) = (string2Name "a", string2Name "b", string2Name "c") 127 | 128 | ----------------------------------------------------------------- 129 | -- Typechecker 130 | ----------------------------------------------------------------- 131 | type Delta = [ TyName ] 132 | type Gamma = [ (ValName, Ty) ] 133 | 134 | data Ctx = Ctx { getDelta :: Delta , getGamma :: Gamma } 135 | emptyCtx = Ctx { getDelta = [], getGamma = [] } 136 | 137 | checkTyVar :: Ctx -> TyName -> M () 138 | checkTyVar g v = do 139 | if v `List.elem` getDelta g then 140 | return () 141 | else 142 | throwError $ "Type variable not found " ++ show v 143 | 144 | lookupTmVar :: Ctx -> ValName -> M Ty 145 | lookupTmVar g v = do 146 | case lookup v (getGamma g) of 147 | Just s -> return s 148 | Nothing -> throwError $ "Term variable notFound " ++ show v 149 | 150 | extendTy :: TyName -> Ctx -> Ctx 151 | extendTy n ctx = ctx { getDelta = n : getDelta ctx } 152 | 153 | extendTys :: [TyName] -> Ctx -> Ctx 154 | extendTys ns ctx = foldr extendTy ctx ns 155 | 156 | extendTm :: ValName -> Ty -> Ctx -> Ctx 157 | extendTm n ty ctx = ctx { getGamma = (n, ty) : getGamma ctx } 158 | 159 | extendTms :: [ValName] -> [Ty] -> Ctx -> Ctx 160 | extendTms [] [] ctx = ctx 161 | extendTms (n:ns) (ty:tys) ctx = extendTm n ty (extendTms ns tys ctx) 162 | 163 | extendDecl :: Decl -> Ctx -> Ctx 164 | extendDecl (DeclVar x (Embed (Ann _ ty))) = extendTm x ty 165 | extendDecl (DeclPrj i x (Embed (Ann _ (TyProd tys)))) = extendTm x (tys !! i) 166 | extendDecl (DeclPrim x _) = extendTm x TyInt 167 | extendDecl (DeclUnpack b x (Embed (Ann _ (Exists bnd)))) = 168 | extendTy b . extendTm x (patUnbind b bnd) 169 | 170 | 171 | 172 | tcty :: Ctx -> Ty -> M () 173 | tcty g (TyVar x) = 174 | checkTyVar g x 175 | tcty g (All b) = do 176 | (xs, tys) <- unbind b 177 | let g' = extendTys xs g -- XX 178 | mapM_ (tcty g') tys 179 | tcty g TyInt = return () 180 | tcty g (TyProd tys) = do 181 | mapM_ (tcty g) tys 182 | tcty g (Exists b) = do 183 | (a, ty) <- unbind b 184 | tcty (extendTy a g) ty 185 | 186 | 187 | typecheckVal :: Ctx -> Val -> M Ty 188 | typecheckVal g (TmVar x) = lookupTmVar g x 189 | typecheckVal g (Fix bnd) = do 190 | ((f, as), bnd2) <- unbind bnd 191 | (xtys, e) <- unbind bnd2 192 | let g' = extendTys as g 193 | let (xs,tys) = unzip $ map (\(x,Embed y) -> (x,y)) xtys 194 | mapM_ (tcty g') tys 195 | let fty = All (bind as tys) 196 | typecheck (extendTm f fty (extendTms xs tys g')) e 197 | return fty 198 | typecheckVal g (TmProd es) = do 199 | tys <- mapM (typecheckAnnVal g) es 200 | return $ TyProd tys 201 | typecheckVal g (TmInt i) = return TyInt 202 | typecheckVal g (TApp av ty) = do 203 | tcty g ty 204 | ty' <- typecheckAnnVal g av 205 | case ty' of 206 | All bnd -> do 207 | (as, bs) <- unbind bnd 208 | case as of 209 | [] -> throwError "can't instantiate non-polymorphic function" 210 | (a:as') -> do 211 | let bs' = subst a ty bs 212 | return (All (bind as' bs')) 213 | 214 | typecheckAnnVal g (Ann (Pack ty1 av) ty) = do 215 | case ty of 216 | Exists bnd -> do 217 | (a, ty2) <- unbind bnd 218 | tcty g ty1 219 | ty' <- typecheckAnnVal g av 220 | if not (ty' `aeq` subst a ty1 ty2) 221 | then throwError "type error" 222 | else return ty 223 | typecheckAnnVal g (Ann v ty) = do 224 | tcty g ty 225 | ty' <- typecheckVal g v 226 | if ty `aeq` ty' 227 | then return ty 228 | else throwError $ "wrong annotation on: " ++ pp v ++ "\nInferred: " ++ pp ty ++ "\nAnnotated: " ++ pp ty' 229 | 230 | typecheckDecl g (DeclVar x (Embed av)) = do 231 | ty <- typecheckAnnVal g av 232 | return $ extendTm x ty g 233 | typecheckDecl g (DeclPrj i x (Embed av)) = do 234 | ty <- typecheckAnnVal g av 235 | case ty of 236 | TyProd tys | i < length tys -> 237 | return $ extendTm x (tys !! i) g 238 | _ -> throwError "cannot project" 239 | typecheckDecl g (DeclPrim x (Embed (av1, _, av2))) = do 240 | ty1 <- typecheckAnnVal g av1 241 | ty2 <- typecheckAnnVal g av2 242 | case (ty1 , ty2) of 243 | (TyInt, TyInt) -> return $ extendTm x TyInt g 244 | _ -> throwError "TypeError" 245 | typecheckDecl g (DeclUnpack a x (Embed av)) = do 246 | tya <- typecheckAnnVal g av 247 | case tya of 248 | Exists bnd -> do 249 | let ty = patUnbind a bnd 250 | return $ extendTy a (extendTm x ty g) 251 | _ -> throwError "TypeError" 252 | 253 | typecheck :: Ctx -> Tm -> M () 254 | typecheck g (Let bnd) = do 255 | (d,e) <- unbind bnd 256 | g' <- typecheckDecl g d 257 | typecheck g' e 258 | typecheck g (App av es) = do 259 | ty <- typecheckAnnVal g av 260 | case ty of 261 | (All bnd) -> do 262 | (as, argtys) <- unbind bnd 263 | argtys' <- mapM (typecheckAnnVal g) es 264 | if not (null as) 265 | then throwError "must use type application" 266 | else 267 | if length argtys /= length argtys' 268 | then throwError "incorrect args" 269 | else unless (and (zipWith aeq argtys argtys')) $ 270 | throwError "arg mismatch" 271 | 272 | typecheck g (TmIf0 av e1 e2) = do 273 | ty0 <- typecheckAnnVal g av 274 | typecheck g e1 275 | typecheck g e2 276 | if ty0 `aeq` TyInt then 277 | return () 278 | else 279 | throwError "TypeError" 280 | typecheck g (Halt ty av) = do 281 | ty' <- typecheckAnnVal g av 282 | unless (ty `aeq` ty') $ 283 | throwError "type error" 284 | 285 | ----------------------------------------------------------------- 286 | 287 | heapvalcheck g ann@(Ann (Fix bnd) _) = 288 | typecheckAnnVal g ann 289 | heapvalcheck g (Ann _ _) = 290 | throwError "type error: only code in heap" 291 | 292 | hoistcheck (tm, Heap m) = do 293 | let g' = 294 | Map.foldlWithKey (\ctx x (Ann _ ty) -> extendTm x ty ctx) 295 | emptyCtx m 296 | mapM_ (heapvalcheck g') (Map.elems m) 297 | typecheck g' tm 298 | 299 | ----------------------------------------------------------------- 300 | -- Small-step semantics 301 | ----------------------------------------------------------------- 302 | 303 | mkSubst :: Decl -> M (Tm -> Tm) 304 | mkSubst (DeclVar x (Embed (Ann v _))) = return $ subst x v 305 | mkSubst (DeclPrj i x (Embed (Ann (TmProd avs) _))) | i < length avs = 306 | let Ann vi _ = avs !! i in return $ subst x vi 307 | mkSubst (DeclPrim x (Embed (Ann (TmInt i1) _, p, Ann (TmInt i2) _))) = 308 | let v = TmInt (evalPrim p i1 i2) in 309 | return $ subst x v 310 | mkSubst (DeclUnpack a x (Embed (Ann (Pack ty (Ann u _)) _))) = 311 | return $ subst a ty . subst x u 312 | mkSubst (DeclPrj i x (Embed av)) = 313 | throwError $ "invalid prj " ++ pp i ++ ": " ++ pp av 314 | mkSubst (DeclUnpack a x (Embed av)) = 315 | throwError $ "invalid unpack:" ++ pp av 316 | 317 | 318 | 319 | step :: Tm -> M Tm 320 | 321 | step (Let bnd) = do 322 | (d, e) <- unbind bnd 323 | ss <- mkSubst d 324 | return $ ss e 325 | 326 | step (App (Ann e1@(Fix bnd) _) avs) = do 327 | ((f, as), bnd2) <- unbind bnd 328 | (xtys, e) <- unbind bnd2 329 | let us = map (\(Ann u _) -> u) avs 330 | let xs = map fst xtys 331 | return $ substs ((f,e1):zip xs us) e 332 | 333 | step (TmIf0 (Ann (TmInt i) _) e1 e2) = if i==0 then return e1 else return e2 334 | 335 | step _ = throwError "cannot step" 336 | 337 | evaluate :: Tm -> M Val 338 | evaluate (Halt _ (Ann v _)) = return v 339 | evaluate e = do 340 | e' <- step e 341 | evaluate e' 342 | 343 | ----------------------------------------------------------------- 344 | -- Pretty-printer 345 | ----------------------------------------------------------------- 346 | 347 | instance Display Ty where 348 | display (TyVar n) = display n 349 | display TyInt = return $ text "Int" 350 | display (All bnd) = lunbind bnd $ \ (as,tys) -> do 351 | da <- displayList as 352 | dt <- displayList tys 353 | if null as 354 | then return $ parens dt <+> text "-> void" 355 | else prefix "forall" (brackets da PP.<> text "." <+> parens dt <+> text "-> void") 356 | display (TyProd tys) = displayTuple tys 357 | display (Exists bnd) = lunbind bnd $ \ (a,ty) -> do 358 | da <- display a 359 | dt <- display ty 360 | prefix "exists" (da PP.<> text "." <+> dt) 361 | 362 | instance Display (ValName,Embed Ty) where 363 | display (n, Embed ty) = do 364 | dn <- display n 365 | dt <- display ty 366 | return $ dn PP.<> colon PP.<> dt 367 | 368 | instance Display Val where 369 | display (TmInt i) = return $ int i 370 | display (TmVar n) = display n 371 | display (Fix bnd) = lunbind bnd $ \((f, as), bnd2) -> lunbind bnd2 $ \(xtys, e) -> do 372 | df <- display f 373 | ds <- displayList as 374 | dargs <- displayList xtys 375 | de <- withPrec (precedence "fix") $ display e 376 | let tyArgs = if null as then empty else brackets ds 377 | let tmArgs = if null xtys then empty else parens dargs 378 | if f `elem` (toListOf fv e :: [ValName]) 379 | then prefix "fix" (df <+> tyArgs PP.<> tmArgs PP.<> text "." $$ de) 380 | else prefix "\\" (tyArgs PP.<> tmArgs PP.<> text "." $$ de) 381 | 382 | display (TmProd es) = displayTuple es 383 | 384 | display (Pack ty e) = do 385 | dty <- display ty 386 | de <- display e 387 | prefix "pack" (brackets (dty PP.<> comma PP.<> de)) 388 | display (TApp av ty) = do 389 | dv <- display av 390 | dt <- display ty 391 | return $ dv <+> brackets dt 392 | 393 | instance Display AnnVal where 394 | {- display (Ann av ty) = do 395 | da <- display av 396 | dt <- display ty 397 | return $ parens (da PP.<> text ":" PP.<> dt) -} 398 | display (Ann av _) = display av 399 | 400 | instance Display Tm where 401 | display (App av args) = do 402 | da <- display av 403 | dargs <- displayList args 404 | let tmArgs = if null args then empty else space PP.<> parens dargs 405 | return $ da PP.<> tmArgs 406 | display (Halt ty v) = do 407 | dv <- display v 408 | --dt <- display ty 409 | return $ text "halt" <+> dv -- <+> text ":" <+> dt 410 | display (Let bnd) = lunbind bnd $ \(d, e) -> do 411 | dd <- display d 412 | de <- display e 413 | return (text "let" <+> dd <+> text "in" $$ de) 414 | display (TmIf0 e0 e1 e2) = do 415 | d0 <- display e0 416 | d1 <- display e1 417 | d2 <- display e2 418 | prefix "if0" $ parens $ sep [d0 PP.<> comma , d1 PP.<> comma, d2] 419 | 420 | instance Display Decl where 421 | display (DeclVar x (Embed av)) = do 422 | dx <- display x 423 | dv <- display av 424 | return $ dx <+> text "=" <+> dv 425 | display (DeclPrj i x (Embed av)) = do 426 | dx <- display x 427 | dv <- display av 428 | return $ dx <+> text "=" <+> text "pi" PP.<> int i <+> dv 429 | display (DeclPrim x (Embed (e1, p, e2))) = do 430 | dx <- display x 431 | let str = show p 432 | d1 <- display e1 433 | d2 <- display e2 434 | return $ dx <+> text "=" <+> d1 <+> text str <+> d2 435 | display (DeclUnpack a x (Embed av)) = do 436 | da <- display a 437 | dx <- display x 438 | dav <- display av 439 | return $ brackets (da PP.<> comma PP.<> dx) <+> text "=" <+> dav 440 | 441 | -------------------------------------------- 442 | -- C to H (actually C) Hoisting 443 | -------------------------------------------- 444 | 445 | displayCode (Ann v ty) = display v 446 | 447 | instance Display Heap where 448 | display (Heap m) = do 449 | fcns <- mapM (\(d,v) -> do 450 | dn <- display d 451 | dv <- displayCode v 452 | return (dn, dv)) (Map.toList m) 453 | return $ hang (text "letrec") 2 $ 454 | vcat [ n <+> text "=" <+> dv | (n,dv) <- fcns ] 455 | 456 | instance Display (Tm, Heap) where 457 | display (tm,h) = do 458 | dh <- display h 459 | dt <- display tm 460 | return $ dh $$ text "in" <+> dt -------------------------------------------------------------------------------- /src/F.hs: -------------------------------------------------------------------------------- 1 | module F where 2 | 3 | import Unbound.Generics.LocallyNameless 4 | ( string2Name, 5 | aeq, 6 | bind, 7 | lunbind, 8 | unbind, 9 | Alpha, 10 | Bind, 11 | Embed(..), 12 | Name, 13 | Subst(isvar, subst, substs), 14 | SubstName(SubstName) ) 15 | 16 | import Control.Monad.Trans.Except ( throwE ) 17 | import qualified Data.List as List 18 | import qualified Text.PrettyPrint as PP 19 | 20 | import Util 21 | 22 | 23 | ------------------------------------------------------ 24 | -- System F with type and term variables 25 | ------------------------------------------------------ 26 | 27 | type TyName = Name Ty 28 | type TmName = Name Tm 29 | 30 | data Ty = TyVar TyName 31 | | TyInt 32 | | Arr Ty Ty 33 | | All (Bind TyName Ty) 34 | | TyProd [Ty] 35 | deriving (Show, Generic) 36 | 37 | data Tm = TmInt Int 38 | | TmVar TmName 39 | | Fix (Bind (TmName, TmName, Embed (Ty, Ty)) Tm) 40 | | App Tm Tm 41 | | TmProd [Tm] 42 | | TmPrj Tm Int 43 | | TmPrim Tm Prim Tm 44 | | TmIf0 Tm Tm Tm 45 | | TLam (Bind TyName Tm) 46 | | TApp Tm Ty 47 | | Ann Tm Ty 48 | deriving (Show, Generic) 49 | 50 | ------------------------------------------------------ 51 | -- Use unbound-generics to derive substitution, alpha-equivalence 52 | -- and free variable functions 53 | ------------------------------------------------------ 54 | 55 | instance Alpha Ty 56 | instance Alpha Tm 57 | 58 | instance Subst Tm Prim 59 | instance Subst Tm Ty 60 | instance Subst Ty Prim 61 | instance Subst Ty Tm 62 | instance Subst Tm Tm where 63 | isvar (TmVar x) = Just (SubstName x) 64 | isvar _ = Nothing 65 | instance Subst Ty Ty where 66 | isvar (TyVar x) = Just (SubstName x) 67 | isvar _ = Nothing 68 | 69 | instance Eq Ty where 70 | (==) = aeq 71 | instance Eq Tm where 72 | (==) = aeq 73 | 74 | ------------------------------------------------------ 75 | -- Example terms 76 | ------------------------------------------------------ 77 | 78 | x :: Name Tm 79 | y :: Name Tm 80 | z :: Name Tm 81 | f :: Name Tm 82 | n :: Name Tm 83 | (x,y,z,f,n) = (string2Name "x", string2Name "y", string2Name "z", string2Name "f", string2Name "n") 84 | 85 | a :: Name Ty 86 | b :: Name Ty 87 | c :: Name Ty 88 | (a,b,c) = (string2Name "a", string2Name "b", string2Name "c") 89 | 90 | -- /\a. \x:a. x 91 | polyid :: Tm 92 | polyid = TLam (bind a (Fix (bind (y, x, Embed (TyVar a, TyVar a)) (TmVar x)))) 93 | 94 | 95 | -- /\a. \x:a. x 96 | polyconst :: Tm 97 | polyconst = TLam (bind a (Fix (bind (y, x, Embed (TyVar a, TyInt)) (TmInt 3)))) 98 | 99 | 100 | -- All a. a -> a 101 | polyidty :: Ty 102 | polyidty = All (bind a (Arr (TyVar a) (TyVar a))) 103 | 104 | 105 | two :: Tm 106 | two = App (Fix (bind (y, x, Embed (TyInt, TyInt)) 107 | (TmPrim (TmVar x) Plus (TmInt 1)))) (TmInt 1) 108 | 109 | -- 1 + 1 110 | onePlusOne :: Tm 111 | onePlusOne = TmPrim (TmInt 1) Plus (TmInt 1) 112 | 113 | -- Factorial function applied to 6 114 | sixfact :: Tm 115 | sixfact = App (Fix (bind (f, n, Embed (TyInt, TyInt)) 116 | (TmIf0 (TmVar n) (TmInt 1) 117 | (TmPrim (TmVar n) Times 118 | (App (TmVar f) 119 | (TmPrim (TmVar n) Minus (TmInt 1))))))) (TmInt 6) 120 | 121 | 122 | 123 | -- /\a. \f:a. \x:a. f 124 | ctrue :: Tm 125 | ctrue = TLam (bind a 126 | (Fix (bind (y,n, Embed (TyVar a, Arr (TyVar a) (TyVar a))) 127 | (Fix (bind (z, x, Embed (TyVar a, TyVar a)) 128 | (TmVar n)))))) 129 | 130 | 131 | -- /\a. \f:a -> a. \x:a. f (f x) 132 | twice :: Tm 133 | twice = TLam (bind a 134 | (Fix (bind (y,f, Embed (Arr (TyVar a) (TyVar a), 135 | Arr (TyVar a) (TyVar a))) 136 | (Fix (bind (z, x, Embed (TyVar a, TyVar a)) 137 | (App (TmVar f) (App (TmVar f) (TmVar x)))))))) 138 | 139 | 140 | ----------------------------------------------------------------- 141 | -- Typechecker 142 | ----------------------------------------------------------------- 143 | type Delta = [ TyName ] 144 | type Gamma = [ (TmName, Ty) ] 145 | 146 | data Ctx = Ctx { getDelta :: Delta , getGamma :: Gamma } 147 | emptyCtx :: Ctx 148 | emptyCtx = Ctx { getDelta = [], getGamma = [] } 149 | 150 | checkTyVar :: Ctx -> TyName -> M () 151 | checkTyVar g v = do 152 | if v `List.elem` getDelta g then 153 | return () 154 | else 155 | throwE "NotFound" 156 | 157 | lookupTmVar :: Ctx -> TmName -> M Ty 158 | lookupTmVar g v = do 159 | case lookup v (getGamma g) of 160 | Just s -> return s 161 | Nothing -> throwE "NotFound" 162 | 163 | extendTy :: TyName -> Ctx -> Ctx 164 | extendTy n ctx = ctx { getDelta = n : getDelta ctx } 165 | 166 | extendTm :: TmName -> Ty -> Ctx -> Ctx 167 | extendTm n ty ctx = ctx { getGamma = (n, ty) : getGamma ctx } 168 | 169 | -- could be replaced with a function that checks that all 170 | -- free variables are contained in delta 171 | tcty :: Ctx -> Ty -> M () 172 | tcty g (TyVar x) = 173 | checkTyVar g x 174 | tcty g (All b) = do 175 | (x, ty') <- unbind b 176 | tcty (extendTy x g) ty' 177 | tcty g (Arr ty1 ty2) = do 178 | tcty g ty1 179 | tcty g ty2 180 | tcty g TyInt = return () 181 | tcty g (TyProd tys) = 182 | mapM_ (tcty g) tys 183 | 184 | 185 | typecheck :: Ctx -> Tm -> M Tm 186 | typecheck g e@(TmVar x) = do 187 | ty <- lookupTmVar g x 188 | return $ Ann e ty 189 | typecheck g (Fix bnd) = do 190 | ((f, x, Embed (ty1, ty2)), e1) <- unbind bnd 191 | tcty g ty1 192 | tcty g ty2 193 | ae1 <- typecheck (extendTm f (Arr ty1 ty2) (extendTm x ty1 g)) e1 194 | case ae1 of 195 | (Ann _ ty2') -> 196 | if not (ty2 `aeq` ty2') 197 | then throwE $ "Type Error: Can't match " ++ pp ty2 ++ " and " ++ pp ty2' 198 | else return $ Ann 199 | (Fix (bind (f,x, Embed (ty1, ty2)) ae1)) 200 | (Arr ty1 ty2) 201 | _ -> throwE "Annotated expression expected" 202 | typecheck g e@(App e1 e2) = do 203 | ae1 <- typecheck g e1 204 | ae2 <- typecheck g e2 205 | case (ae1, ae2) of 206 | (Ann _ ty1, Ann _ ty2) -> 207 | case ty1 of 208 | Arr ty11 ty21 | ty2 `aeq` ty11 -> 209 | return (Ann (App ae1 ae2) ty21) 210 | _ -> throwE "TypeError" 211 | typecheck g (TLam bnd) = do 212 | (x, e) <- unbind bnd 213 | ae <- typecheck (extendTy x g) e 214 | case ae of 215 | (Ann _ ty) -> 216 | return $ Ann (TLam (bind x ae)) (All (bind x ty)) 217 | typecheck g (TApp e ty) = do 218 | ae <- typecheck g e 219 | case ae of 220 | (Ann _ tyt) -> 221 | case tyt of 222 | (All b) -> do 223 | tcty g ty 224 | (n1, ty1) <- unbind b 225 | return $ Ann (TApp ae ty) (subst n1 ty ty1) 226 | _ -> throwE "TypeError" 227 | typecheck g (TmProd es) = do 228 | atys <- mapM (typecheck g) es 229 | let tys = map (\(Ann _ ty) -> ty) atys 230 | return $ Ann (TmProd atys) (TyProd tys) 231 | typecheck g (TmPrj e i) = do 232 | ae <- typecheck g e 233 | case ae of 234 | (Ann _ ty) -> 235 | case ty of 236 | TyProd tys | i < length tys -> return $ Ann (TmPrj ae i) (tys !! i) 237 | _ -> throwE "TypeError" 238 | typecheck g (TmInt i) = return (Ann (TmInt i) TyInt) 239 | typecheck g (TmPrim e1 p e2) = do 240 | ae1 <- typecheck g e1 241 | ae2 <- typecheck g e2 242 | case (ae1, ae2) of 243 | (Ann _ ty1, Ann _ ty2) -> 244 | case (ty1 , ty2) of 245 | (TyInt, TyInt) -> return (Ann (TmPrim ae1 p ae2) TyInt) 246 | _ -> throwE "TypeError" 247 | typecheck g (TmIf0 e0 e1 e2) = do 248 | ae0 <- typecheck g e0 249 | ae1 <- typecheck g e1 250 | ae2 <- typecheck g e2 251 | case (ae0, ae1, ae2) of 252 | (Ann _ ty0, Ann _ ty1, Ann _ ty2) -> 253 | if ty1 `aeq` ty2 && ty0 `aeq` TyInt then 254 | return (Ann (TmIf0 ae0 ae1 ae2) ty1) 255 | else 256 | throwE "TypeError" 257 | typecheck g _ = throwE "TypeError" 258 | ----------------------------------------------------------------- 259 | -- Small-step semantics 260 | ----------------------------------------------------------------- 261 | 262 | value :: Tm -> Bool 263 | value (TmInt _) = True 264 | value (Fix _) = True 265 | value (TmProd es) = all value es 266 | value (TLam _) = True 267 | value _ = False 268 | 269 | steps :: [Tm] -> M [Tm] 270 | steps [] = throwE "can't step empty list" 271 | steps (e:es) | value e = do 272 | es' <- steps es 273 | return (e : es') 274 | steps (e:es) = do 275 | e' <- step e 276 | return (e' : es) 277 | 278 | step :: Tm -> M Tm 279 | step e | value e = throwE "can't step value" 280 | step (TmVar _) = throwE "unbound variable" 281 | step (App e1@(Fix bnd) e2) = 282 | if value e2 283 | then do 284 | ((f, x, _), t) <- unbind bnd 285 | return $ substs [ (x, e2), (f,e1) ] t 286 | else do 287 | e2' <- step e2 288 | return (App e1 e2') 289 | step (App e1 e2) = do 290 | e1' <- step e1 291 | return (App e1' e2) 292 | step (TmPrj e1@(TmProd es) i) | value e1 && i < length es = return $ es !! i 293 | step (TmPrj e1 i) = do 294 | e1' <- step e1 295 | return (TmPrj e1' i) 296 | step (TmProd es) = do 297 | es' <- steps es 298 | return (TmProd es') 299 | step (TmPrim (TmInt i1) p (TmInt i2)) = 300 | return (TmInt (evalPrim p i1 i2)) 301 | step (TmPrim e1 p e2) | value e1 = do 302 | e2' <- step e2 303 | return (TmPrim e1 p e2') 304 | | otherwise = do 305 | e1' <- step e1 306 | return (TmPrim e1' p e2) 307 | step (TmIf0 (TmInt i) e1 e2) = if i==0 then return e1 else return e2 308 | step (TmIf0 e0 e1 e2) = do 309 | e0' <- step e0 310 | return (TmIf0 e0' e1 e2) 311 | step (TApp (TLam bnd) ty) = do 312 | (a, e) <- unbind bnd 313 | return $ subst a ty e 314 | step (TApp e ty) = do 315 | e' <- step e 316 | return $ TApp e' ty 317 | step (Ann e ty) = return e 318 | 319 | evaluate :: Tm -> M Tm 320 | evaluate e = if value e then return e else do 321 | e' <- step e 322 | evaluate e' 323 | 324 | ----------------------------------------------------------------- 325 | -- Pretty-printer 326 | ----------------------------------------------------------------- 327 | 328 | instance Display Ty where 329 | display (TyVar n) = display n 330 | display TyInt = return $ text "Int" 331 | display (Arr ty1 ty2) = do 332 | d1 <- withPrec (precedence "->" + 1) $ display ty1 333 | d2 <- withPrec (precedence "->") $ display ty2 334 | binop d1 "->" d2 335 | display (All bnd) = lunbind bnd $ \ (a,ty) -> do 336 | da <- display a 337 | dt <- display ty 338 | prefix "forall" (da PP.<> text "." <+> dt) 339 | display (TyProd tys) = displayTuple tys 340 | 341 | instance Display Tm where 342 | display (TmInt i) = return $ int i 343 | display (TmVar n) = display n 344 | display (Fix bnd) = lunbind bnd $ \((f,x,Embed (ty1,ty2)), e) -> do 345 | df <- display f 346 | dx <- display x 347 | d1 <- display ty1 348 | d2 <- display ty2 349 | de <- withPrec (precedence "fix") $ display e 350 | let arg = parens (dx PP.<> colon PP.<> d1) 351 | --if f `elem` (fv e :: [F.TmName]) 352 | -- then 353 | prefix "fix" (df <+> arg PP.<> colon PP.<> d2 PP.<> text "." <+> de) 354 | -- else prefix "\\" (arg PP.<> text "." <+> de) 355 | display (App e1 e2) = do 356 | d1 <- withPrec (precedence " ") $ display e1 357 | d2 <- withPrec (precedence " " + 1) $ display e2 358 | binop d1 " " d2 359 | display (TmProd es) = displayTuple es 360 | 361 | display (TmPrj e i) = do 362 | de <- display e 363 | return $ text "Pi" PP.<> int i <+> de 364 | display (TmPrim e1 p e2) = do 365 | let str = show p 366 | d1 <- withPrec (precedence str) $ display e1 367 | d2 <- withPrec (precedence str + 1) $ display e2 368 | binop d1 str d2 369 | display (TmIf0 e0 e1 e2) = do 370 | d0 <- display e0 371 | d1 <- display e1 372 | d2 <- display e2 373 | prefix "if0" $ sep [d0 , text "then" <+> d1 , text "else" <+> d2] 374 | display (TLam bnd) = lunbind bnd $ \(a,e) -> do 375 | da <- display a 376 | de <- withPrec (precedence "/\\") $ display e 377 | prefix "/\\" (da PP.<> text "." <+> de) 378 | display (TApp e ty) = do 379 | d1 <- withPrec (precedence " ") $ display e 380 | d2 <- withPrec (precedence " " + 1) $ display ty 381 | binop d1 " " d2 382 | display (Ann e ty) = display e -------------------------------------------------------------------------------- /src/K.hs: -------------------------------------------------------------------------------- 1 | module K where 2 | 3 | import Control.Monad 4 | import Control.Monad.Trans.Except 5 | import qualified Data.List as List 6 | 7 | import Util 8 | import Unbound.Generics.LocallyNameless hiding (prec,empty,Data,Refl,Val) 9 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf) 10 | 11 | import qualified Text.PrettyPrint as PP 12 | import Data.Typeable (Typeable, cast) 13 | 14 | -- System K 15 | 16 | type TyName = Name Ty 17 | type ValName = Name Val 18 | 19 | data Ty = TyVar TyName 20 | | TyInt 21 | | All (Bind [TyName] [Ty]) 22 | | TyProd [Ty] 23 | deriving (Show, Generic) 24 | 25 | data Val = TmInt Int 26 | | TmVar ValName 27 | | Fix (Bind (ValName, [TyName]) (Bind [(ValName, Embed Ty)] Tm)) 28 | | TmProd [AnnVal] 29 | deriving (Show, Generic) 30 | 31 | data AnnVal = Ann Val Ty 32 | deriving (Show, Generic) 33 | 34 | data Decl = 35 | DeclVar ValName (Embed AnnVal) 36 | | DeclPrj Int ValName (Embed AnnVal) 37 | | DeclPrim ValName (Embed (AnnVal, Prim, AnnVal)) 38 | deriving (Show, Generic) 39 | 40 | data Tm = Let (Bind Decl Tm) 41 | | App AnnVal [Ty] [AnnVal] 42 | | TmIf0 AnnVal Tm Tm 43 | | Halt Ty AnnVal 44 | deriving (Show, Generic) 45 | 46 | 47 | ------------------------------------------------------ 48 | instance Alpha Ty 49 | instance Alpha Val 50 | instance Alpha AnnVal 51 | instance Alpha Decl 52 | instance Alpha Tm 53 | 54 | instance Subst Ty Ty where 55 | isvar (TyVar x) = Just (SubstName x) 56 | isvar _ = Nothing 57 | instance Subst Ty Prim 58 | instance Subst Ty Tm 59 | instance Subst Ty AnnVal 60 | instance Subst Ty Decl 61 | instance Subst Ty Val 62 | 63 | 64 | instance Subst Val Prim 65 | instance Subst Val Ty 66 | instance Subst Val AnnVal 67 | instance Subst Val Decl 68 | instance Subst Val Tm 69 | instance Subst Val Val where 70 | isvar (TmVar x) = Just (SubstName x) 71 | isvar _ = Nothing 72 | 73 | ------------------------------------------------------ 74 | -- Example terms 75 | ------------------------------------------------------ 76 | 77 | x :: Name Tm 78 | y :: Name Tm 79 | z :: Name Tm 80 | (x,y,z) = (string2Name "x", string2Name "y", string2Name "z") 81 | 82 | a :: Name Ty 83 | b :: Name Ty 84 | c :: Name Ty 85 | (a,b,c) = (string2Name "a", string2Name "b", string2Name "c") 86 | 87 | ----------------------------------------------------------------- 88 | -- Typechecker 89 | ----------------------------------------------------------------- 90 | type Delta = [ TyName ] 91 | type Gamma = [ (ValName, Ty) ] 92 | 93 | data Ctx = Ctx { getDelta :: Delta , getGamma :: Gamma } 94 | emptyCtx = Ctx { getDelta = [], getGamma = [] } 95 | 96 | checkTyVar :: Ctx -> TyName -> M () 97 | checkTyVar g v = do 98 | if v `List.elem` getDelta g then 99 | return () 100 | else 101 | throwE $ "NotFound " ++ show v 102 | 103 | lookupTmVar :: Ctx -> ValName -> M Ty 104 | lookupTmVar g v = do 105 | case lookup v (getGamma g) of 106 | Just s -> return s 107 | Nothing -> throwE $ "NotFound " ++ show v 108 | 109 | extendTy :: TyName -> Ctx -> Ctx 110 | extendTy n ctx = ctx { getDelta = n : getDelta ctx } 111 | 112 | extendTys :: [TyName] -> Ctx -> Ctx 113 | extendTys ns ctx = foldr extendTy ctx ns 114 | 115 | extendTm :: ValName -> Ty -> Ctx -> Ctx 116 | extendTm n ty ctx = ctx { getGamma = (n, ty) : getGamma ctx } 117 | 118 | extendTms :: [ValName] -> [Ty] -> Ctx -> Ctx 119 | extendTms [] [] ctx = ctx 120 | extendTms (n:ns) (ty:tys) ctx = extendTm n ty (extendTms ns tys ctx) 121 | extendTms _ _ _ = error "BUG: should have same names" 122 | 123 | tcty :: Ctx -> Ty -> M () 124 | tcty g (TyVar x) = 125 | checkTyVar g x 126 | tcty g (All b) = do 127 | (xs, tys) <- unbind b 128 | let g' = extendTys xs g 129 | mapM_ (tcty g') tys 130 | tcty g TyInt = return () 131 | tcty g (TyProd tys) = do 132 | mapM_ (tcty g) tys 133 | 134 | 135 | 136 | typecheckVal :: Ctx -> Val -> M Ty 137 | typecheckVal g (TmVar x) = lookupTmVar g x 138 | typecheckVal g (Fix bnd) = do 139 | ((f, as), bnd2) <- unbind bnd 140 | (xtys, e) <- unbind bnd2 141 | let g' = extendTys as g 142 | let (xs,tys) = unzip $ map (\(x,Embed y) -> (x,y)) xtys 143 | mapM_ (tcty g') tys 144 | let fty = All (bind as tys) 145 | typecheck (extendTm f fty (extendTms xs tys g')) e 146 | return fty 147 | typecheckVal g (TmProd es) = do 148 | tys <- mapM (typecheckAnnVal g) es 149 | return $ TyProd tys 150 | typecheckVal g (TmInt i) = return TyInt 151 | 152 | typecheckAnnVal g (Ann v ty) = do 153 | tcty g ty 154 | ty' <- typecheckVal g v 155 | if ty `aeq` ty' 156 | then return ty 157 | else throwE "wrong anntation" 158 | 159 | typecheckDecl g (DeclVar x (Embed av)) = do 160 | ty <- typecheckAnnVal g av 161 | return $ extendTm x ty g 162 | typecheckDecl g (DeclPrj i x (Embed av)) = do 163 | ty <- typecheckAnnVal g av 164 | case ty of 165 | TyProd tys | i < length tys -> 166 | return $ extendTm x (tys !! i) g 167 | _ -> throwE "cannot project" 168 | typecheckDecl g (DeclPrim x (Embed (av1, _, av2))) = do 169 | ty1 <- typecheckAnnVal g av1 170 | ty2 <- typecheckAnnVal g av2 171 | case (ty1 , ty2) of 172 | (TyInt, TyInt) -> return $ extendTm x TyInt g 173 | _ -> throwE "TypeError" 174 | 175 | typecheck :: Ctx -> Tm -> M () 176 | typecheck g (Let bnd) = do 177 | (d,e) <- unbind bnd 178 | g' <- typecheckDecl g d 179 | typecheck g' e 180 | typecheck g (App av tys es) = do 181 | ty <- typecheckAnnVal g av 182 | mapM_ (tcty g) tys 183 | case ty of 184 | (All bnd) -> do 185 | (as, argtys) <- unbind bnd 186 | let tys' = map (substs (zip as tys)) argtys 187 | argtys' <- mapM (typecheckAnnVal g) es 188 | if length argtys /= length argtys' then throwE "incorrect args" 189 | else unless (and (zipWith aeq argtys argtys')) $ 190 | throwE "arg mismatch" 191 | _ -> throwE "type error" 192 | typecheck g (TmIf0 av e1 e2) = do 193 | ty0 <- typecheckAnnVal g av 194 | typecheck g e1 195 | typecheck g e2 196 | if ty0 `aeq` TyInt then 197 | return () 198 | else 199 | throwE "TypeError" 200 | typecheck g (Halt ty av) = do 201 | ty' <- typecheckAnnVal g av 202 | unless (ty `aeq` ty') $ 203 | throwE "type error" 204 | 205 | 206 | ----------------------------------------------------------------- 207 | -- Small-step semantics 208 | ----------------------------------------------------------------- 209 | 210 | mkSubst :: Decl -> M (Tm -> Tm) 211 | mkSubst (DeclVar x (Embed (Ann v _))) = return $ subst x v 212 | mkSubst (DeclPrj i x (Embed (Ann (TmProd avs) _))) | i < length avs = 213 | let Ann vi _ = avs !! i in return $ subst x vi 214 | mkSubst (DeclPrim x (Embed (Ann (TmInt i1) _, p, Ann (TmInt i2) _))) = 215 | let v = TmInt (evalPrim p i1 i2) in 216 | return $ subst x v 217 | mkSubst _ = throwE "invalid decl" 218 | 219 | 220 | 221 | step :: Tm -> M Tm 222 | 223 | step (Let bnd) = do 224 | (d, e) <- unbind bnd 225 | ss <- mkSubst d 226 | return $ ss e 227 | 228 | step (App (Ann e1@(Fix bnd) _) tys avs) = do 229 | ((f, as), bnd2) <- unbind bnd 230 | (xtys, e) <- unbind bnd2 231 | let us = map (\(Ann u _) -> u) avs 232 | let xs = map fst xtys 233 | return $ substs ((f,e1):zip xs us) (substs (zip as tys) e) 234 | 235 | step (TmIf0 (Ann (TmInt i) _) e1 e2) = if i==0 then return e1 else return e2 236 | 237 | step _ = throwE "cannot step" 238 | 239 | evaluate :: Tm -> M Val 240 | evaluate (Halt _ (Ann v _)) = return v 241 | evaluate e = do 242 | e' <- step e 243 | evaluate e' 244 | 245 | ----------------------------------------------------------------- 246 | -- Pretty-printer 247 | ----------------------------------------------------------------- 248 | 249 | instance Display Ty where 250 | display (TyVar n) = display n 251 | display TyInt = return $ text "Int" 252 | display (All bnd) = lunbind bnd $ \ (as,tys) -> do 253 | da <- displayList as 254 | dt <- displayList tys 255 | if null as 256 | then return $ parens dt <+> text "-> void" 257 | else prefix "forall" (brackets da PP.<> text "." <+> parens dt <+> text "-> void") 258 | display (TyProd tys) = displayTuple tys 259 | 260 | instance Display (ValName,Embed Ty) where 261 | display (n, Embed ty) = do 262 | dn <- display n 263 | dt <- display ty 264 | return $ dn PP.<> colon PP.<> dt 265 | 266 | 267 | 268 | 269 | instance Display Val where 270 | display (TmInt i) = return $ int i 271 | display (TmVar n) = display n 272 | display (Fix bnd) = lunbind bnd $ \((f, as), bnd2) -> lunbind bnd2 $ \(xtys, e) -> do 273 | df <- display f 274 | ds <- displayList as 275 | dargs <- displayList xtys 276 | de <- withPrec (precedence "fix") $ display e 277 | let tyArgs = if null as then PP.empty else brackets ds 278 | let tmArgs = if null xtys then PP.empty else parens dargs 279 | if f `elem` toListOf fv e 280 | then prefix "fix" (df <+> tyArgs PP.<> tmArgs PP.<> text "." $$ de) 281 | else prefix "\\" (tyArgs PP.<> tmArgs PP.<> text "." $$ de) 282 | 283 | display (TmProd es) = displayTuple es 284 | 285 | instance Display AnnVal where 286 | display (Ann av _) = display av 287 | 288 | instance Display Tm where 289 | display (App av tys args) = do 290 | da <- display av 291 | dtys <- displayList tys 292 | dargs <- displayList args 293 | let tyArgs = if null tys then PP.empty else brackets dtys 294 | let tmArgs = if null args then PP.empty else parens dargs 295 | return $ da PP.<> tyArgs <+> tmArgs 296 | display (Halt ty v) = do 297 | dv <- display v 298 | return $ text "halt" <+> dv 299 | display (Let bnd) = lunbind bnd $ \(d, e) -> do 300 | dd <- display d 301 | de <- display e 302 | return (text "let" <+> dd <+> text "in" $$ de) 303 | display (TmIf0 e0 e1 e2) = do 304 | d0 <- display e0 305 | d1 <- display e1 306 | d2 <- display e2 307 | prefix "if0" $ parens $ sep [d0 PP.<> comma , d1 PP.<> comma, d2] 308 | 309 | instance Display Decl where 310 | display (DeclVar x (Embed av)) = do 311 | dx <- display x 312 | dv <- display av 313 | return $ dx <+> text "=" <+> dv 314 | display (DeclPrj i x (Embed av)) = do 315 | dx <- display x 316 | dv <- display av 317 | return $ dx <+> text "=" <+> text "pi" PP.<> int i <+> dv 318 | display (DeclPrim x (Embed (e1, p, e2))) = do 319 | dx <- display x 320 | let str = show p 321 | d1 <- display e1 322 | d2 <- display e2 323 | return $ dx <+> text "=" <+> d1 <+> text str <+> d2 324 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Util ( pp, runM, Display, M ) 4 | import qualified Data.Map as Map 5 | import qualified F 6 | import qualified K 7 | import qualified C 8 | import qualified A 9 | import qualified TAL 10 | import qualified Translate 11 | import Control.Monad.Except ( MonadError(throwError), unless ) 12 | 13 | import System.Exit (exitFailure) 14 | 15 | -- Run a few test cases that produce int values 16 | main :: IO () 17 | main = do 18 | checkInt "1+1" (test F.onePlusOne) 2 19 | checkInt "two" (test F.two) 2 20 | checkInt "6!" (test F.sixfact) 720 21 | 22 | ------------------------------- 23 | -- Helper functions for testing 24 | ------------------------------- 25 | test :: F.Tm -> TAL.WordVal 26 | test f = runM $ do 27 | tal <- Translate.compile f 28 | (h, r, _) <- TAL.run tal 29 | case Map.lookup TAL.reg1 r of 30 | Just v -> return v 31 | Nothing -> throwError "no result!" 32 | 33 | checkInt :: String -> TAL.WordVal -> Int -> IO () 34 | checkInt name actual expected = do 35 | case actual of 36 | TAL.TmInt y -> 37 | unless (y == expected) $ do 38 | putStrLn $ name ++ " returned:" ++ pp y 39 | exitFailure 40 | wv -> do 41 | putStrLn $ name ++ " returned: " ++ pp wv 42 | exitFailure 43 | putStrLn $ "Test passed: " ++ name 44 | 45 | 46 | printM :: (Display a) => M a -> IO () 47 | printM x = putStrLn $ pp $ runM x 48 | 49 | printK :: F.Tm -> IO () 50 | printK f = do 51 | putStrLn "--- K ---" 52 | printM $ do af <- F.typecheck F.emptyCtx f 53 | Translate.toProgK af 54 | 55 | printC :: F.Tm -> IO () 56 | printC f = do 57 | putStrLn "--- C ---" 58 | printM $ do af <- F.typecheck F.emptyCtx f 59 | k <- Translate.toProgK af 60 | Translate.toProgC k 61 | 62 | printH :: F.Tm -> IO () 63 | printH f = do 64 | putStrLn "--- H ---" 65 | printM $ do af <- F.typecheck F.emptyCtx f 66 | k <- Translate.toProgK af 67 | c <- Translate.toProgC k 68 | Translate.toProgH c 69 | 70 | printA :: F.Tm -> IO () 71 | printA f = do 72 | putStrLn "--- A ---" 73 | printM $ do af <- F.typecheck F.emptyCtx f 74 | k <- Translate.toProgK af 75 | c <- Translate.toProgC k 76 | h <- Translate.toProgH c 77 | Translate.toProgA h 78 | 79 | t1 = do 80 | print "Compiling 1 + 1" 81 | printM $ return F.onePlusOne 82 | printM $ Translate.compile F.onePlusOne 83 | 84 | t2 = do 85 | print "Compiling 2" 86 | printM $ return F.two 87 | printM $ Translate.compile F.two 88 | 89 | t3 = do 90 | print "Compiling ctrue" 91 | printM $ return F.ctrue 92 | printM $ Translate.compile F.ctrue 93 | 94 | t4 = do 95 | print "Compiling 6!" 96 | printM $ return F.sixfact 97 | printM $ Translate.compile F.sixfact 98 | 99 | t5 = do 100 | print "Compiling twice" 101 | printM $ return F.twice 102 | printM $ Translate.compile F.twice 103 | -------------------------------------------------------------------------------- /src/TAL.hs: -------------------------------------------------------------------------------- 1 | module TAL where 2 | 3 | import Util 4 | import Unbound.Generics.LocallyNameless hiding (prec,empty,Data,Refl,Val) 5 | 6 | import Control.Monad 7 | import Control.Monad.Except 8 | import Control.Monad.Reader 9 | import Control.Monad.Trans.Except 10 | 11 | import qualified Data.List as List 12 | import qualified Data.Map as Map 13 | import qualified Text.PrettyPrint as PP 14 | 15 | -- Typed Assembly Language 16 | 17 | type TyName = Name Ty 18 | 19 | data Ty = TyVar TyName 20 | | TyInt 21 | | All (Bind [TyName] Gamma) 22 | | TyProd [(Ty, Flag)] 23 | | Exists (Bind TyName Ty) 24 | deriving (Show, Generic) 25 | 26 | data Flag = Un | Init 27 | deriving (Eq, Ord, Show, Generic) 28 | 29 | -- Heap types 30 | type Psi = Map Label Ty 31 | 32 | -- Register file types 33 | type Gamma = [(Register, Ty)] 34 | 35 | newtype Register = Register String deriving (Eq, Ord, Generic) 36 | instance Show Register where 37 | show (Register s) = s 38 | 39 | -- designated result register 40 | reg1 :: Register 41 | reg1 = Register "r1" 42 | 43 | -- temporary register names 44 | rtmp :: Int -> Register 45 | rtmp i = Register ("rt" ++ show i) 46 | 47 | instance Enum Register where 48 | toEnum i = Register ("r" ++ show i) 49 | fromEnum (Register ('r' : str)) = read str 50 | 51 | newtype Label = Label (Name Heap) deriving (Eq, Ord, Generic) 52 | instance Show Label where 53 | show (Label n) = show n 54 | 55 | data TyApp a = TyApp a Ty deriving (Show, Generic) 56 | 57 | sapps :: SmallVal -> [Ty] -> SmallVal 58 | sapps a tys = foldr (\ ty a -> SApp (TyApp a ty)) a tys 59 | 60 | data Pack a = Pack Ty a Ty deriving (Show, Generic) 61 | 62 | data WordVal = LabelVal Label 63 | | TmInt Int 64 | | Junk Ty 65 | | WApp (TyApp WordVal) 66 | | WPack (Pack WordVal) 67 | deriving (Show, Generic) 68 | 69 | data SmallVal = RegVal Register 70 | | WordVal WordVal 71 | | SApp (TyApp SmallVal) 72 | | SPack (Pack SmallVal) 73 | deriving (Show, Generic) 74 | 75 | data HeapVal = 76 | Tuple [WordVal] 77 | | Code [TyName] Gamma InstrSeq -- nominal binding 78 | deriving (Show, Generic) 79 | 80 | type Heap = Map Label HeapVal 81 | type RegisterFile = Map Register WordVal 82 | 83 | data Instruction = 84 | Add Register Register SmallVal 85 | | Bnz Register SmallVal 86 | | Ld Register Register Int 87 | | Malloc Register [Ty] 88 | | Mov Register SmallVal 89 | | Mul Register Register SmallVal 90 | | St Register Int Register 91 | | Sub Register Register SmallVal 92 | | Unpack TyName Register SmallVal -- binds type variable 93 | deriving (Show, Generic) 94 | 95 | data InstrSeq = 96 | Seq Instruction InstrSeq -- annoying to do bind here, skipping 97 | | Jump SmallVal 98 | | Halt Ty 99 | deriving (Show,Generic) 100 | 101 | --instance Monoid A.Heap where 102 | -- mempty = A.Heap Map.empty 103 | -- mappend (A.Heap h1) (A.Heap h2) = A.Heap (Map.union h1 h2) 104 | 105 | type Machine = (Heap, RegisterFile, InstrSeq) 106 | 107 | 108 | ------------------------------------------------------ 109 | instance Alpha Flag 110 | instance Alpha Ty 111 | instance Alpha Register 112 | instance Alpha Label 113 | instance Alpha a => Alpha (TyApp a) 114 | instance Alpha a => Alpha (Pack a) 115 | instance Alpha WordVal 116 | instance Alpha SmallVal 117 | instance Alpha HeapVal 118 | instance Alpha Instruction 119 | instance Alpha InstrSeq 120 | 121 | 122 | 123 | instance Subst Ty Ty where 124 | isvar (TyVar x) = Just (SubstName x) 125 | isvar _ = Nothing 126 | instance Subst Ty Flag 127 | instance (Subst Ty a) => Subst Ty (TyApp a) 128 | instance (Subst Ty a) => Subst Ty (Pack a) 129 | instance Subst Ty WordVal 130 | instance Subst Ty SmallVal 131 | instance Subst Ty HeapVal 132 | instance Subst Ty Instruction 133 | instance Subst Ty InstrSeq 134 | instance Subst Ty Label 135 | instance Subst Ty Register 136 | 137 | 138 | freshForHeap :: Heap -> Label 139 | freshForHeap h = Label (makeName str (i+1)) where 140 | Label nm = maximum (Map.keys h) 141 | (str, i) = (name2String nm, name2Integer nm) 142 | 143 | ----------------------------------------------------- 144 | -- operational semantics 145 | ----------------------------------------------------- 146 | 147 | getIntReg :: RegisterFile -> Register -> M Int 148 | getIntReg r rs = 149 | case Map.lookup rs r of 150 | Just (TmInt i) -> return i 151 | Just _ -> throwError "register not an int" 152 | Nothing -> throwError "register not found" 153 | 154 | arith :: (Int -> Int -> Int) -> RegisterFile -> 155 | Register -> SmallVal -> M WordVal 156 | arith op r rs v = do 157 | i <- getIntReg r rs 158 | (wv,_) <- loadReg r v 159 | case wv of 160 | TmInt j -> return (TmInt (i `op` j)) 161 | _ -> throwError 162 | $ "arith: word val " ++ pp wv ++" is not an int" 163 | 164 | -- R^(sv) 165 | loadReg :: RegisterFile -> SmallVal -> M (WordVal, [Ty]) 166 | loadReg r (RegVal rs) = case Map.lookup rs r of 167 | Just w -> return (w, []) 168 | Nothing -> throwError "register val not found" 169 | loadReg r (WordVal w) = return (w, []) 170 | loadReg r (SApp (TyApp sv ty)) = do 171 | (w, tys) <- loadReg r sv 172 | return (w, ty:tys) 173 | loadReg r (SPack (Pack t1 sv t2)) = do 174 | (w, tys) <- loadReg r sv 175 | return (WPack (Pack t1 (tyApp w tys) t2), []) 176 | 177 | tyApp :: WordVal -> [Ty] -> WordVal 178 | tyApp w [] = w 179 | tyApp w (ty:tys) = tyApp (WApp (TyApp w ty)) tys 180 | 181 | jmpReg :: Heap -> RegisterFile -> SmallVal -> M Machine 182 | jmpReg h r v = do 183 | (w,tys) <- loadReg r v 184 | case w of 185 | LabelVal l -> 186 | case (Map.lookup l h) of 187 | Just (Code alphas gamma instrs') -> do 188 | when (length alphas /= length tys) $ 189 | throwError "Bnz: wrong # type args" 190 | return (h, r, substs (zip alphas tys) instrs') 191 | _ -> throwError "Bnz: cannot jump, not code" 192 | _ -> throwError "Bnz: cannot jump, not label" 193 | 194 | step :: Machine -> M Machine 195 | step (h, r, Add rd rs v `Seq` instrs) = do 196 | v' <- arith (+) r rs v 197 | return (h, Map.insert rd v' r, instrs) 198 | 199 | step (h, r, Mul rd rs v `Seq` instrs) = do 200 | v' <- arith (*) r rs v 201 | return (h, Map.insert rd v' r, instrs) 202 | step (h, r, Sub rd rs v `Seq` instrs) = do 203 | v' <- arith (-) r rs v 204 | return (h, Map.insert rd v' r, instrs) 205 | step (h, r, Bnz rs v `Seq` instrs) = do 206 | case Map.lookup rs r of 207 | Just (TmInt 0) -> return (h, r, instrs) 208 | Just (TmInt _) -> jmpReg h r v 209 | step (h, r, Jump v) = jmpReg h r v 210 | step (h, r, Ld rd rs i `Seq` instrs) = do 211 | case Map.lookup rs r of 212 | Just (LabelVal l) -> 213 | case Map.lookup l h of 214 | Just (Tuple ws) | i < length ws -> 215 | return (h, Map.insert rd (ws !! i) r, instrs) 216 | _ -> throwError "ld: Cannot load location" 217 | _ -> throwError "ld: not label" 218 | step (h, r, Malloc rd tys `Seq` instrs) = do 219 | let l = freshForHeap h 220 | return (Map.insert l (Tuple (map Junk tys)) h, 221 | Map.insert rd (LabelVal l) r, 222 | instrs) 223 | step (h, r, Mov rd v `Seq` instrs) = do 224 | (w,tys) <- loadReg r v 225 | return (h, Map.insert rd (tyApp w tys) r, instrs) 226 | step (h, r, St rd i rs `Seq` instrs) = do 227 | case Map.lookup rs r of 228 | Just w' -> 229 | case Map.lookup rd r of 230 | Just (LabelVal l) -> 231 | case Map.lookup l h of 232 | Just (Tuple ws) | i < length ws -> do 233 | let (ws0,(_:ws1)) = splitAt i ws 234 | return 235 | (Map.insert l (Tuple (ws0 ++ (w':ws1))) h, 236 | r, instrs) 237 | _ -> throwError "heap label not found or wrong val" 238 | _ -> throwError "register not found or wrong val" 239 | _ -> throwError "register not found" 240 | step (h, r, Unpack alpha rd v `Seq` instrs) = do 241 | (w0, tys) <- loadReg r v 242 | case tyApp w0 tys of 243 | WPack (Pack ty w _) -> 244 | return (h, Map.insert rd w r, subst alpha ty instrs) 245 | _ -> throwError "not a pack" 246 | 247 | run :: Machine -> M Machine 248 | run m@(h, r, Halt t) = return m 249 | run m = do 250 | m' <- step m 251 | run m' 252 | 253 | 254 | 255 | 256 | ------------------------------------------------------ 257 | -- Typechecker 258 | ------------------------------------------------------ 259 | 260 | type Delta = [ TyName ] 261 | 262 | data Ctx = Ctx { getDelta :: Delta , 263 | getGamma :: Gamma , 264 | getPsi :: Psi } 265 | emptyCtx = Ctx { getDelta = [], 266 | getGamma = [], 267 | getPsi = Map.empty } 268 | 269 | checkTyVar :: Ctx -> TyName -> M () 270 | checkTyVar g v = do 271 | if v `List.elem` getDelta g then 272 | return () 273 | else 274 | throwError $ "Type variable not found " ++ show v 275 | 276 | 277 | extendTy :: TyName -> Ctx -> Ctx 278 | extendTy n ctx = ctx { getDelta = n : getDelta ctx } 279 | 280 | extendTys :: [TyName] -> Ctx -> Ctx 281 | extendTys ns ctx = foldr extendTy ctx ns 282 | 283 | insertGamma :: Register -> Ty -> Gamma -> Gamma 284 | insertGamma r ty [] = [(r,ty)] 285 | insertGamma r ty ((r',ty'):rest) | r < r' = (r',ty') : insertGamma r ty rest 286 | insertGamma r ty ((r',ty'):rest) | r == r' = (r,ty) : rest 287 | 288 | insertGamma r ty rest = (r,ty) : rest 289 | 290 | 291 | lookupHeapLabel :: Ctx -> Label -> M Ty 292 | lookupHeapLabel ctx v = do 293 | case Map.lookup v (getPsi ctx) of 294 | Just s -> return s 295 | Nothing -> throwError $ "Label not found " ++ (show v) 296 | 297 | lookupReg :: Ctx -> Register -> M Ty 298 | lookupReg ctx v = do 299 | case lookup v (getGamma ctx) of 300 | Just s -> return s 301 | Nothing -> throwError $ "Register not found " ++ (show v) 302 | 303 | -- tau is a well-formed type 304 | tcty :: Ctx -> Ty -> M () 305 | tcty ctx (TyVar x) = 306 | checkTyVar ctx x 307 | tcty ctx (All b) = do 308 | (xs, reg) <- unbind b 309 | let ctx' = extendTys xs ctx 310 | tcGamma ctx' reg 311 | tcty ctx TyInt = return () 312 | tcty ctx (TyProd tys) = do 313 | mapM_ (tcty ctx . fst) tys 314 | tcty ctx (Exists b) = do 315 | (a, ty) <- unbind b 316 | tcty (extendTy a ctx) ty 317 | 318 | -- Psi is a well-formed heap type 319 | -- Only uses D 320 | tcPsi :: Ctx -> Psi -> M () 321 | tcPsi ctx psi = mapM_ (tcty ctx) (Map.elems psi) 322 | 323 | -- Gamma is a well-formed register file 324 | -- D |- G 325 | tcGamma :: Ctx -> Gamma -> M () 326 | tcGamma ctx g = mapM_ (tcty ctx) (map snd g) 327 | 328 | unJust :: M (Maybe a) -> M a 329 | unJust mma = do 330 | ma <- mma 331 | case ma of 332 | Just x -> return x 333 | Nothing -> throwE "" 334 | 335 | -- t1 is a subtype of t2 336 | -- D |- t1 <= t2 337 | subtype :: Ctx -> Ty -> Ty -> M () 338 | subtype ctx (TyVar x) (TyVar y) | x == y = return () 339 | subtype ctx TyInt TyInt = return () 340 | subtype ctx (All bnd1) (All bnd2) = do 341 | (vs1, g1, vs2, g2) <- unJust (unbind2 bnd1 bnd2) 342 | subGamma ctx g1 g2 343 | subtype ctx (Exists bnd1) (Exists bnd2) = do 344 | (v1, t1, v2, t2) <- unJust (unbind2 bnd1 bnd2) 345 | subtype ctx t1 t2 346 | subtype ctx (TyProd tfs1) (TyProd tfs2) | (length tfs1 >= length tfs2) = do 347 | zipWithM_ (\ (t1, f1) (t2, f2) -> 348 | if f2 == Un then return () 349 | else subtype ctx t1 t2) tfs1 tfs2 350 | subtype ctx t1 t2 = throwError $ "not a subtype:" ++ pp t1 ++ "\n" ++ pp t2 351 | 352 | -- D |- G1 <= G2 353 | subGamma :: Ctx -> Gamma -> Gamma -> M () 354 | subGamma ctx g1 g2 = do 355 | mapM_ (\(r, t2) -> case lookup r g1 of 356 | Just t1 -> subtype ctx t1 t1 357 | Nothing -> throwError $ 358 | "subgamma -- register not found:" ++ show r ++ "\n" 359 | ++ pp g1 ++ "\n" 360 | ++ pp g2 ++ "\n") 361 | g2 362 | 363 | -- |- H : Psi 364 | typeCheckHeap :: Heap -> Psi -> M () 365 | typeCheckHeap h psi = mapM_ tcHeapDecl (Map.assocs h) where 366 | ctx = emptyCtx { getPsi = psi } 367 | 368 | tcHeapDecl :: (Label, HeapVal) -> M () 369 | tcHeapDecl (l,hv) = 370 | case Map.lookup l psi of 371 | Just ty -> tcHeapVal hv ty 372 | Nothing -> throwError $ "heap type not found:" ++ show l 373 | 374 | tcTuple (Junk ty', (ty,Un)) = 375 | -- maybe we know these are the same already? 376 | subtype ctx ty' ty 377 | tcTuple (wv, (ty,Init)) = do 378 | ty' <- tcWordVal ctx wv 379 | subtype ctx ty' ty 380 | 381 | tcHeapVal (Tuple wvs) (TyProd tys) | length wvs == length tys = do 382 | mapM_ tcTuple (zip wvs tys) 383 | 384 | tcHeapVal (Code as g is) _ = do 385 | -- TODO: better error message. What if wrong # binders? 386 | -- let g' = patUnbind as bnd 387 | -- check (All bnd) ?? 388 | let ctx = Ctx as g psi 389 | tcInstrSeq ctx is 390 | tcHeapVal _ _ = throwError $ "wrong type for heap val" 391 | 392 | tcWordVal :: Ctx -> WordVal -> M Ty 393 | tcWordVal ctx (LabelVal l) = lookupHeapLabel ctx l 394 | tcWordVal ctx (TmInt i) = return TyInt 395 | tcWordVal ctx (Junk ty') = throwError $ "BUG: no Junk here" 396 | tcWordVal ctx (WApp tapp) = tcApp tcWordVal ctx tapp 397 | tcWordVal ctx (WPack pack) = tcPack tcWordVal ctx pack 398 | 399 | tcApp :: (Ctx -> a -> M Ty) -> Ctx -> TyApp a -> M Ty 400 | tcApp f ctx (TyApp wv ty) = do 401 | tcty ctx ty 402 | ty' <- f ctx wv 403 | case ty' of 404 | All bnd -> do 405 | (as, bs) <- unbind bnd 406 | case as of 407 | [] -> throwError "can't instantiate non-polymorphic function" 408 | (a:as') -> do 409 | let bs' = subst a ty bs 410 | return (All (bind as' bs')) 411 | 412 | tcPack :: Display a => (Ctx -> a -> M Ty) -> Ctx -> Pack a -> M Ty 413 | tcPack f ctx (Pack ty1 wv ty) = do 414 | case ty of 415 | Exists bnd -> do 416 | (a, ty2) <- unbind bnd 417 | tcty ctx ty1 418 | ty' <- f ctx wv 419 | --return ty 420 | 421 | if (not (ty' `aeq` subst a ty1 ty2)) 422 | then throwError $ "type error in pack " ++ pp wv ++ ":\n" 423 | ++ pp ty' ++ "\n" 424 | ++ " does not equal\n" 425 | ++ pp (subst a ty1 ty2) 426 | else return ty 427 | 428 | tcSmallVal :: Ctx -> SmallVal -> M Ty 429 | tcSmallVal ctx (RegVal r) = lookupReg ctx r 430 | tcSmallVal ctx (WordVal wv) = tcWordVal ctx wv 431 | tcSmallVal ctx (SApp app) = tcApp tcSmallVal ctx app 432 | tcSmallVal ctx (SPack pack) = tcPack tcSmallVal ctx pack 433 | 434 | tcInstrSeq :: Ctx -> InstrSeq -> M () 435 | tcInstrSeq ctx (Seq i is) = do 436 | ctx' <- tcInstr ctx i 437 | tcInstrSeq ctx' is 438 | tcInstrSeq ctx (Jump sv) = do 439 | ty <- tcSmallVal ctx sv 440 | case ty of 441 | All bnd -> 442 | let g = patUnbind [] bnd in 443 | subGamma ctx (getGamma ctx) g 444 | tcInstrSeq ctx (Halt ty) = do 445 | ty' <- lookupReg ctx reg1 446 | subtype ctx ty ty' 447 | 448 | tcArith :: Ctx -> Register -> Register -> SmallVal -> M Ctx 449 | tcArith ctx rd rs sv = do 450 | ty1 <- lookupReg ctx rs 451 | ty2 <- tcSmallVal ctx sv 452 | unless (ty1 `aeq` TyInt) $ throwError "source reg must be int" 453 | unless (ty2 `aeq` TyInt) $ throwError "immediate must be int" 454 | let g' = insertGamma rd TyInt (getGamma ctx) 455 | return (ctx { getGamma = g' }) 456 | 457 | tcInstr :: Ctx -> Instruction -> M Ctx 458 | tcInstr ctx i = case i of 459 | (Add rd rs sv) -> tcArith ctx rd rs sv 460 | (Bnz r sv) -> do 461 | ty1 <- lookupReg ctx r 462 | ty2 <- tcSmallVal ctx sv 463 | unless (ty1 `aeq` TyInt) $ throwError "source reg must be int" 464 | case ty2 of 465 | All bnd -> do 466 | let g = patUnbind [] bnd 467 | subGamma ctx (getGamma ctx) g 468 | return ctx 469 | _ -> throwError "must bnz to code label" 470 | 471 | (Ld rd rs i) -> do 472 | ty1 <- lookupReg ctx rs 473 | case ty1 of 474 | TyProd tyfs -> do 475 | when (i >= length tyfs) $ throwError "Ld: index out of range" 476 | let (ty,f) = tyfs !! i 477 | unless (f == Init) $ throwError "Ld: load from unitialized field" 478 | let g = insertGamma rd ty (getGamma ctx) 479 | return $ ctx { getGamma = g } 480 | _ -> throwError $ "Ld: not a tuple" 481 | 482 | (Malloc rd tys) -> do 483 | let ty = TyProd (map (,Un) tys) 484 | let g = insertGamma rd ty (getGamma ctx) 485 | return $ ctx { getGamma = g } 486 | 487 | (Mov rd sv) -> do 488 | ty <- tcSmallVal ctx sv 489 | let g = insertGamma rd ty (getGamma ctx) 490 | return $ ctx { getGamma = g } 491 | 492 | (Mul rd rs sv) -> tcArith ctx rd rs sv 493 | 494 | (St rd i rs) -> do 495 | ty1 <- lookupReg ctx rd 496 | ty2 <- lookupReg ctx rs 497 | case ty1 of 498 | TyProd tyfs -> do 499 | when (i >= length tyfs) $ throwError "St: index out of range" 500 | let (before, _:after) = List.splitAt i tyfs 501 | let ty = TyProd (before ++ [(ty2,Init)] ++ after) 502 | let g = insertGamma rd ty (getGamma ctx) 503 | return $ ctx { getGamma = g } 504 | _ -> throwError $ "St: rd not a tuple" 505 | 506 | (Sub rd rs sv) -> tcArith ctx rd rs sv 507 | 508 | (Unpack a rd sv) -> do 509 | when (a `elem` getDelta ctx) $ throwError "Unpack: tyvar not fresh" 510 | ty1 <- tcSmallVal ctx sv 511 | case ty1 of 512 | Exists bnd -> do 513 | let ty = patUnbind a bnd 514 | let g = insertGamma rd ty (getGamma ctx) 515 | return $ ctx { getDelta = a : (getDelta ctx) }{ getGamma = g } 516 | 517 | 518 | progcheck :: Machine -> M () 519 | progcheck (heap, regfile, is) = do 520 | let getHeapTy (_,Tuple _ ) = throwError $ "only code to start" 521 | getHeapTy (l,Code as g _) = return $ (l,All (bind as g)) 522 | psi_assocs <- mapM getHeapTy (Map.assocs heap) 523 | let psi = Map.fromList psi_assocs 524 | unless (Map.null regfile) $ throwError "must start with empty registers" 525 | let ctx = Ctx [] [] psi 526 | tcPsi ctx psi 527 | tcInstrSeq ctx is 528 | 529 | ----------------------------------------------------------------- 530 | -- Pretty-printer 531 | ----------------------------------------------------------------- 532 | 533 | instance Display Ty where 534 | display (TyVar n) = display n 535 | display (TyInt) = return $ text "Int" 536 | display (All bnd) = lunbind bnd $ \ (as,g) -> do 537 | da <- displayList as 538 | dt <- display g 539 | if null as 540 | then return dt 541 | else prefix "forall" (brackets da PP.<> text "." <+> dt) 542 | display (TyProd tys) = displayTuple tys 543 | display (Exists bnd) = lunbind bnd $ \ (a,ty) -> do 544 | da <- display a 545 | dt <- display ty 546 | prefix "exists" (da PP.<> text "." <+> dt) 547 | 548 | instance Display (Ty, Flag) where 549 | display (ty, fl) = do 550 | dty <- display ty 551 | let f = case fl of { Un -> "0" ; Init -> "1" } 552 | return $ dty PP.<> text "^" PP.<> text f 553 | 554 | instance Display a => Display (Map Register a) where 555 | display m = do 556 | fcns <- mapM (\(r,v) -> do 557 | dv <- display v 558 | return (r, dv)) (Map.toList m) 559 | return $ braces (sep (punctuate comma 560 | [ text (show n) 561 | <+> text ":" <+> dv | (n,dv) <- fcns ])) 562 | 563 | instance Display a => Display [(Register, a)] where 564 | display m = do 565 | fcns <- mapM (\(r,v) -> do 566 | dv <- display v 567 | return (r, dv)) m 568 | return $ braces (sep (punctuate comma 569 | [ text (show n) 570 | <+> text ":" <+> dv | (n,dv) <- fcns ])) 571 | 572 | instance Display a => Display (Pack a) where 573 | display (Pack ty e _) = do 574 | dty <- display ty 575 | de <- display e 576 | prefix "pack" (brackets (dty PP.<> comma PP.<> de)) 577 | 578 | instance Display a => Display (TyApp a) where 579 | display (TyApp av ty) = do 580 | dv <- display av 581 | dt <- display ty 582 | return $ dv <+> (brackets dt) 583 | 584 | instance Display WordVal where 585 | display (LabelVal l) = return $ text ( show l) 586 | display (TmInt i) = return $ int i 587 | display (Junk ty) = return $ text "?" 588 | display (WPack p) = display p 589 | display (WApp a) = display a 590 | 591 | instance Display SmallVal where 592 | display (RegVal r) = return (text $ show r) 593 | display (WordVal n) = display n 594 | display (SPack p) = display p 595 | display (SApp a) = display a 596 | 597 | 598 | instance Display HeapVal where 599 | display (Code as gamma is) = do 600 | ds <- displayList as 601 | dargs <- display gamma 602 | de <- display is 603 | let tyArgs = if null as then PP.empty else brackets ds 604 | prefix "code" (tyArgs PP.<> dargs PP.<> text "." $$ de) 605 | 606 | display (Tuple es) = displayTuple es 607 | 608 | dispArith str rd rs sv = do 609 | dv <- display sv 610 | return $ text str <+> text (show rd) 611 | PP.<> comma PP.<> text (show rs) PP.<> comma <+> dv 612 | 613 | instance Display Instruction where 614 | display i = case i of 615 | Add rd rs sv -> dispArith "add" rd rs sv 616 | Bnz r sv -> do 617 | dv <- display sv 618 | return $ text "bnz" <+> text (show r) PP.<> comma PP.<> dv 619 | 620 | (Ld rd rs i) -> 621 | return $ text "ld" <+> text (show rd) PP.<> comma PP.<> text (show rs) 622 | PP.<> brackets (int i) 623 | 624 | (Malloc rd tys) -> do 625 | dtys <- displayList tys 626 | return $ text "malloc" <+> text (show rd) PP.<> comma PP.<> brackets dtys 627 | 628 | (Mov rd sv) -> do 629 | dv <- display sv 630 | return $ text "mov" <+> text (show rd) PP.<> comma PP.<> dv 631 | 632 | (Mul rd rs sv) -> dispArith "mul" rd rs sv 633 | 634 | (St rd i rs) -> do 635 | return $ text "st" <+> text (show rd) PP.<> brackets (int i) PP.<> comma 636 | PP.<> text (show rs) 637 | 638 | (Sub rd rs sv) -> dispArith "sub" rd rs sv 639 | 640 | (Unpack a rd sv) -> do 641 | dv <- display sv 642 | return $ text "unpack" 643 | PP.<> brackets (text (show a) PP.<> comma PP.<> text (show rd)) 644 | PP.<> comma PP.<> dv 645 | 646 | instance Display InstrSeq where 647 | display (Seq i is) = do 648 | di <- display i 649 | dis <- display is 650 | return $ di $+$ dis 651 | display (Jump sv) = do 652 | ds <- display sv 653 | return $ text "jmp" <+> ds 654 | display (Halt _) = do 655 | return $ text "halt" 656 | 657 | 658 | instance Display Label where 659 | display l = return (text (show l)) 660 | 661 | instance Display a => Display (Map Label a) where 662 | display m = do 663 | fcns <- mapM (\(d,v) -> do 664 | dn <- display d 665 | dv <- display v 666 | return (dn, dv)) (Map.toList m) 667 | return $ vcat [ n <+> text ":" $$ nest 4 dv | (n,dv) <- fcns ] 668 | 669 | 670 | instance Display (Heap, RegisterFile, InstrSeq) where 671 | display (h, r, is) = do 672 | dh <- display h 673 | dr <- display r 674 | di <- display is 675 | return $ dh $$ dr $$ text "main:" $$ nest 4 di 676 | -------------------------------------------------------------------------------- /src/Translate.hs: -------------------------------------------------------------------------------- 1 | 2 | module Translate where 3 | 4 | import Unbound.Generics.LocallyNameless hiding (to) 5 | 6 | import Control.Monad.Except 7 | import Control.Monad.Reader 8 | import Control.Monad.State 9 | 10 | import qualified Data.List as List 11 | import Data.Map (Map) 12 | import qualified Data.Map as Map 13 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf) 14 | import Unbound.Generics.PermM ( single ) 15 | 16 | import Debug.Trace 17 | 18 | import Util 19 | import qualified F 20 | import qualified K 21 | import qualified C 22 | import qualified A 23 | import qualified TAL 24 | 25 | -- Not sure the right way to do this. But a is a Phantom type in 26 | -- unbound generics 27 | translate :: Name a -> Name b 28 | translate n = makeName s i where 29 | (s,i) = (name2String n, name2Integer n) 30 | 31 | ------------------------------------ 32 | -- The compiler pipeline, all passes 33 | ------------------------------------ 34 | 35 | compile :: F.Tm -> M TAL.Machine 36 | compile f = do 37 | af <- F.typecheck F.emptyCtx f 38 | k <- toProgK af 39 | K.typecheck K.emptyCtx k 40 | c <- toProgC k 41 | C.typecheck C.emptyCtx c 42 | h <- toProgH c 43 | C.hoistcheck h 44 | a <- toProgA h 45 | A.progcheck a 46 | tal <- toProgTAL a 47 | TAL.progcheck tal 48 | return tal 49 | 50 | 51 | -------------------------------------------- 52 | -- F ==> K 53 | -------------------------------------------- 54 | 55 | -- type translation 56 | 57 | 58 | toTyK :: F.Ty -> M K.Ty 59 | toTyK (F.TyVar n) = return $ K.TyVar (translate n) 60 | toTyK F.TyInt = return K.TyInt 61 | toTyK (F.Arr t1 t2) = do 62 | k1 <- toTyK t1 63 | k2 <- toTyContK t2 64 | return $ K.All (bind [] [k1,k2]) 65 | toTyK (F.All bnd) = do 66 | (a,ty) <- unbind bnd 67 | let a' = translate a 68 | ty' <- toTyContK ty 69 | return $ K.All (bind [a'][ty']) 70 | toTyK (F.TyProd tys) = do 71 | tys' <- mapM toTyK tys 72 | return $ K.TyProd tys' 73 | 74 | toTyContK :: F.Ty -> M K.Ty 75 | toTyContK fty = do 76 | kty <- toTyK fty 77 | return $ K.All (bind [] [kty]) 78 | 79 | -- expression translation 80 | 81 | -- Here we actually use Danvy & Filinski's "optimizing" closure-conversion 82 | -- algorithm. It is actually no more complicated than the one presented in 83 | -- the paper and produces output with no "administrative" redices. 84 | 85 | toProgK :: F.Tm -> M K.Tm 86 | toProgK ae@(F.Ann _ fty) = do 87 | kty <- toTyK fty 88 | toExpK ae (return . K.Halt kty) 89 | toProgK _ = throwError "toProgK given unannotated expression!" 90 | 91 | toExpK :: F.Tm -> (K.AnnVal -> M K.Tm) -> M K.Tm 92 | toExpK (F.Ann ftm fty) k = to ftm where 93 | 94 | to (F.TmVar y) = do 95 | kty <- toTyK fty 96 | k (K.Ann (K.TmVar (translate y)) kty) 97 | 98 | to (F.TmInt i) = k (K.Ann (K.TmInt i) K.TyInt) 99 | 100 | to (F.Fix bnd) = do 101 | ((f, x, Embed (t1,t2)), e) <- unbind bnd 102 | kty1 <- toTyK t1 103 | kcty2 <- toTyContK t2 104 | kvar <- fresh (string2Name "k") 105 | ke <- toExpK e (\v -> return $ K.App (K.Ann (K.TmVar kvar) kcty2) [] [v]) 106 | let kfix = K.Fix (bind (translate f, []) 107 | (bind [(translate x, Embed kty1),(kvar, Embed kcty2)] 108 | ke)) 109 | k (K.Ann kfix (K.All (bind [] [kty1,kcty2]))) 110 | 111 | to (F.App ae1 ae2) = do 112 | kty <- toTyK fty 113 | let body v1 v2 = do 114 | kv <- reifyCont k kty 115 | return (K.App v1 [] [v2, kv]) 116 | toExpK ae1 (toExpK ae2 . body) 117 | 118 | to (F.TmPrim ae1 p ae2) = do 119 | y <- fresh (string2Name "y") 120 | let body v1 v2 = do 121 | tm <- k (K.Ann (K.TmVar y) K.TyInt) 122 | return (K.Let (bind (K.DeclPrim y (Embed (v1,p, v2))) tm)) 123 | toExpK ae1 (toExpK ae2 . body) 124 | 125 | to (F.TmIf0 ae0 ae1 ae2) = do 126 | e1 <- toExpK ae1 k 127 | e2 <- toExpK ae2 k 128 | toExpK ae0 (\v1 -> return (K.TmIf0 v1 e1 e2)) 129 | 130 | to (F.TmProd aes) = do 131 | kty <- toTyK fty 132 | let loop [] k = k [] 133 | loop (ae:aes) k = 134 | toExpK ae (\v -> loop aes (\vs -> k (v:vs))) 135 | loop aes (\vs -> k (K.Ann (K.TmProd vs) kty)) 136 | 137 | to (F.TmPrj ae i) = do 138 | y <- fresh (string2Name "y") 139 | yty <- toTyK fty 140 | toExpK ae (\ v1 -> do 141 | tm <- k (K.Ann (K.TmVar y) yty) 142 | return (K.Let (bind (K.DeclPrj i y (Embed v1)) tm))) 143 | 144 | to (F.TLam bnd) = do 145 | (a,e) <- unbind bnd 146 | case e of 147 | F.Ann _ ty -> do 148 | kcty <- toTyContK ty 149 | kvar <- fresh (string2Name "k") 150 | ke <- toExpK e (\v -> return $ K.App (K.Ann (K.TmVar kvar) kcty) [] [v]) 151 | f <- fresh (string2Name "f") 152 | let kfix = K.Fix (bind (f, [translate a]) 153 | (bind [(kvar, Embed kcty)] ke)) 154 | k (K.Ann kfix (K.All (bind [translate a] [kcty]))) 155 | _ -> throwError "toExpK: need annotation" 156 | to (F.TApp ae ty) = do 157 | aty <- toTyK ty 158 | let body v1 = do 159 | kty <- toTyK fty 160 | kv <- reifyCont k kty 161 | return (K.App v1 [aty] [kv]) 162 | toExpK ae body 163 | 164 | 165 | to (F.Ann e ty) = throwError "found nested Ann" 166 | toExpK _ _ = throwError "toExpK: found unannotated expression" 167 | 168 | 169 | -- Turn a meta continuation into an object language continuation 170 | -- Requires knowing the type of the expected value. 171 | 172 | reifyCont :: (K.AnnVal -> M K.Tm) -> K.Ty -> M K.AnnVal 173 | reifyCont k vty = do 174 | kont <- fresh (string2Name "kont") 175 | v <- fresh (string2Name "v") 176 | body <- k (K.Ann (K.TmVar v) vty) 177 | return $ K.Ann (K.Fix (bind (kont, []) 178 | (bind [(v, Embed vty)] body))) 179 | (K.All (bind [][vty])) 180 | 181 | -------------------------------------------- 182 | -- K to C Closure conversion 183 | -------------------------------------------- 184 | 185 | -- NOTE: we need to keep track of the current context 186 | -- so that we can find out the types of free variables 187 | -- (The FV function only gives us free names, not free 188 | -- annotated variables) 189 | type N a = ReaderT C.Ctx M a 190 | 191 | toTyC :: K.Ty -> N C.Ty 192 | toTyC (K.TyVar v) = return $ C.TyVar (translate v) 193 | toTyC K.TyInt = return C.TyInt 194 | toTyC (K.All bnd) = do 195 | (as, tys) <- unbind bnd 196 | let as' = map translate as 197 | tys' <- local (C.extendTys as') $ mapM toTyC tys 198 | b' <- fresh (string2Name "b") 199 | let prod = C.TyProd [C.All (bind as' (C.TyVar b' : tys')), C.TyVar b'] 200 | return (C.Exists (bind b' prod)) 201 | toTyC (K.TyProd tys) = do 202 | tys' <- mapM toTyC tys 203 | return $ C.TyProd tys' 204 | 205 | toProgC :: K.Tm -> M C.Tm 206 | toProgC k = runReaderT (toTmC k) C.emptyCtx 207 | 208 | toTmC :: K.Tm -> N C.Tm 209 | toTmC (K.Let bnd) = do 210 | (decl, tm) <- unbind bnd 211 | decl' <- toDeclC decl 212 | tm' <- local (C.extendDecl decl') (toTmC tm) 213 | return $ C.Let (bind decl' tm') 214 | toTmC (K.App v@(K.Ann _ t) tys vs) = do 215 | z <- fresh $ string2Name "z" 216 | zcode <- fresh $ string2Name "zcode" 217 | zenv <- fresh $ string2Name "zenv" 218 | v' <- toAnnValC v 219 | t' <- toTyC t 220 | tys' <- mapM toTyC tys 221 | vs' <- mapM toAnnValC vs 222 | case t' of 223 | C.Exists bnd -> do 224 | (b, prodty) <- unbind bnd 225 | case prodty of 226 | C.TyProd [ tcode, C.TyVar b' ] | b == b' -> do 227 | let vz = C.Ann (C.TmVar z) prodty 228 | let ds = [C.DeclUnpack b z (Embed v'), 229 | C.DeclPrj 1 zenv (Embed vz), 230 | C.DeclPrj 0 zcode (Embed vz)] 231 | ann <- C.mkTyApp (C.Ann (C.TmVar zcode) tcode) tys' 232 | let prd = C.Ann (C.TmVar zenv) (C.TyVar b):vs' 233 | return $ foldr (\ b e -> C.Let (bind b e)) (C.App ann prd) ds 234 | _ -> throwError "type error" 235 | _ -> throwError "type error" 236 | toTmC (K.TmIf0 v tm1 tm2) = do 237 | liftM3 C.TmIf0 (toAnnValC v) (toTmC tm1) (toTmC tm2) 238 | toTmC (K.Halt ty v) = 239 | liftM2 C.Halt (toTyC ty) (toAnnValC v) 240 | 241 | toDeclC :: K.Decl -> N C.Decl 242 | toDeclC (K.DeclVar x (Embed v)) = do 243 | v' <- toAnnValC v 244 | return $ C.DeclVar (translate x) (Embed v') 245 | toDeclC (K.DeclPrj i x (Embed v)) = do 246 | v' <- toAnnValC v 247 | return $ C.DeclPrj i (translate x) (Embed v') 248 | toDeclC (K.DeclPrim x (Embed (v1, p, v2))) = do 249 | v1' <- toAnnValC v1 250 | v2' <- toAnnValC v2 251 | return $ C.DeclPrim (translate x) (Embed (v1',p, v2')) 252 | 253 | toAnnValC :: K.AnnVal -> N C.AnnVal 254 | toAnnValC (K.Ann (K.TmInt i) K.TyInt) = 255 | return $ C.Ann (C.TmInt i) C.TyInt 256 | toAnnValC (K.Ann (K.TmVar v) ty) = do 257 | ty' <- toTyC ty 258 | return $ C.Ann (C.TmVar (translate v)) ty' 259 | toAnnValC (K.Ann v@(K.Fix bnd1) t@(K.All _)) = do 260 | t' <- toTyC t 261 | ((f,as), bnd2) <- unbind bnd1 262 | (xtys, e) <- unbind bnd2 263 | let (xs,tys) = unzip $ map (\(x,Embed ty) -> (x,ty)) xtys 264 | let xs' = map translate xs 265 | tys' <- mapM toTyC tys 266 | let ys = map translate (List.nub (toListOf fv v :: [K.ValName])) 267 | ctx <- ask 268 | ss' <- lift $ mapM (C.lookupTmVar ctx) ys 269 | let as' = map translate as 270 | let bs = map translate (List.nub (toListOf fv v :: [K.TyName])) 271 | let tenv = C.TyProd ss' 272 | let trawcode = C.All (bind (bs ++ as') (tenv:tys')) 273 | zvar <- fresh $ string2Name "zfix" 274 | let zcode = C.Ann (C.TmVar zvar) trawcode 275 | zenvvar <- fresh $ string2Name "zfenv" 276 | let zenv = C.Ann (C.TmVar zenvvar) tenv 277 | tyAppZenv <- C.mkTyApp zcode (map C.TyVar bs) 278 | 279 | let mkprj (x, i) e = 280 | C.Let (bind (C.DeclPrj i x (Embed zenv)) e) 281 | let extend = \c -> foldr (uncurry C.extendTm) c (zip xs' tys') 282 | e' <- local (C.extendTm (translate f) t' . extend) $ toTmC e 283 | let vcode = C.Fix (bind (zvar, bs ++ as') 284 | (bind ((zenvvar, Embed tenv): 285 | zipWith (\x ty -> (x,Embed ty)) xs' tys') 286 | (C.Let (bind (C.DeclVar (translate f) 287 | (Embed (C.Ann (C.Pack tenv (C.mkProd [tyAppZenv, zenv])) 288 | t'))) 289 | (foldr mkprj e' (zip ys [0..])))))) 290 | let venv = C.mkProd (zipWith (C.Ann . C.TmVar) ys ss') 291 | tyAppVcode <- C.mkTyApp (C.Ann vcode trawcode) (map C.TyVar bs) 292 | return $ 293 | C.Ann (C.Pack tenv (C.mkProd [tyAppVcode, venv])) t' 294 | 295 | toAnnValC (K.Ann (K.TmProd vs) ty) = do 296 | ty' <- toTyC ty 297 | vs' <- mapM toAnnValC vs 298 | return $ C.Ann (C.TmProd vs') ty' 299 | toAnnValC _ = throwError "toAnnValC: inconsistent annotation" 300 | 301 | -------------------------------------------- 302 | -- C to H (actually C) Hoisting 303 | -------------------------------------------- 304 | 305 | -- we keep track of the current heap as we hoist 306 | -- 'fix' expressions out of expressions 307 | type H a = StateT C.Heap M a 308 | 309 | toProgH :: C.Tm -> M (C.Tm, C.Heap) 310 | toProgH tm = runStateT (toTmH tm) mempty 311 | 312 | toTmH :: C.Tm -> H C.Tm 313 | toTmH (C.Let bnd) = do 314 | (decl, tm) <- unbind bnd 315 | decl' <- toDeclH decl 316 | tm' <- toTmH tm 317 | return $ C.Let (bind decl' tm') 318 | toTmH (C.App v vs) = do 319 | v' <- toAnnValH v 320 | vs' <- mapM toAnnValH vs 321 | return $ C.App v' vs' 322 | toTmH (C.TmIf0 v tm1 tm2) = do 323 | liftM3 C.TmIf0 (toAnnValH v) (toTmH tm1) (toTmH tm2) 324 | toTmH (C.Halt ty v) = 325 | C.Halt ty <$> toAnnValH v 326 | 327 | toDeclH :: C.Decl -> H C.Decl 328 | toDeclH (C.DeclVar x (Embed v)) = do 329 | v' <- toAnnValH v 330 | return $ C.DeclVar x (Embed v') 331 | toDeclH (C.DeclPrj i x (Embed v)) = do 332 | v' <- toAnnValH v 333 | return $ C.DeclPrj i x (Embed v') 334 | toDeclH (C.DeclPrim x (Embed (v1, p, v2))) = do 335 | v1' <- toAnnValH v1 336 | v2' <- toAnnValH v2 337 | return $ C.DeclPrim x (Embed (v1',p, v2')) 338 | toDeclH (C.DeclUnpack g x (Embed v)) = do 339 | v' <- toAnnValH v 340 | return $ C.DeclUnpack g x (Embed v') 341 | 342 | 343 | toAnnValH :: C.AnnVal -> H C.AnnVal 344 | toAnnValH (C.Ann (C.TmInt i) _) = 345 | return $ C.Ann (C.TmInt i) C.TyInt 346 | toAnnValH (C.Ann (C.TmVar v) ty) = do 347 | return $ C.Ann (C.TmVar v) ty 348 | toAnnValH (C.Ann (C.Fix bnd1) ty) = do 349 | ((f, as),bnd2) <- unbind bnd1 350 | (xtys, tm) <- unbind bnd2 351 | codef <- fresh f 352 | tm' <- toTmH tm 353 | let v' = C.Ann (C.Fix (bind (f,as) (bind xtys tm'))) ty 354 | modify (\s -> mappend s (C.Heap (Map.singleton codef v'))) 355 | return (C.Ann (C.TmVar codef) ty) 356 | 357 | toAnnValH (C.Ann (C.TmProd ps) ty) = do 358 | ps' <- mapM toAnnValH ps 359 | return $ C.Ann (C.TmProd ps') ty 360 | toAnnValH (C.Ann (C.TApp v ty1) ty) = do 361 | v' <- toAnnValH v 362 | return $ C.Ann (C.TApp v' ty1) ty 363 | toAnnValH (C.Ann (C.Pack ty1 v) ty) = do 364 | v' <- toAnnValH v 365 | return $ C.Ann (C.Pack ty1 v') ty 366 | 367 | -------------------------------------------- 368 | -- H to A (Allocation) 369 | -------------------------------------------- 370 | 371 | toTyA :: C.Ty -> M A.Ty 372 | toTyA (C.TyVar v) = return $ A.TyVar (translate v) 373 | toTyA C.TyInt = return A.TyInt 374 | toTyA (C.All bnd) = do 375 | (as, tys) <- unbind bnd 376 | let as' = map translate as 377 | tys' <- mapM toTyA tys 378 | return (A.All (bind as' tys')) 379 | toTyA (C.TyProd tys) = do 380 | tys' <- mapM toTyA tys 381 | return $ A.TyProd $ map (,A.Init) tys' 382 | toTyA (C.Exists bnd) = do 383 | (a, ty) <- unbind bnd 384 | let a' = translate a 385 | ty' <- toTyA ty 386 | return $ A.Exists (bind a' ty') 387 | 388 | toProgA :: (C.Tm, C.Heap) -> M (A.Tm, A.Heap) 389 | toProgA (tm, C.Heap heap) = do 390 | asc <- mapM (\(x,hv) -> let x' = translate x in 391 | (x',) <$> toHeapValA x' hv) 392 | (Map.assocs heap) 393 | let heap' = A.Heap (Map.fromDistinctAscList asc) 394 | tm' <- toExpA tm 395 | return (tm', heap') 396 | 397 | toHeapValA :: A.ValName -> C.AnnVal -> M (A.Ann A.HeapVal) 398 | toHeapValA f' (C.Ann (C.Fix bnd) _) = do 399 | ((f,as), bnd2) <- unbind bnd 400 | (xtys, e) <- unbind bnd2 401 | let 402 | f1 :: C.ValName 403 | f1 = translate f' 404 | let e' = swaps (single (AnyName f1)(AnyName f)) e 405 | let (xs,tys) = unzip $ map (\(x,Embed y) -> (x,y)) xtys 406 | tys' <- mapM toTyA tys 407 | let as' = map translate as 408 | let xs' = map translate xs 409 | e'' <- toExpA e' 410 | return (A.Ann (A.Code (bind as' (bind xs' e''))) (A.All (bind as' tys'))) 411 | toHeapValA _ _ = throwError "only code in the heap" 412 | 413 | 414 | toExpA :: C.Tm -> M A.Tm 415 | toExpA (C.Let bnd) = do 416 | (d, tm) <- unbind bnd 417 | ds' <- toDeclA d 418 | tm' <- toExpA tm 419 | return $ A.lets ds' tm' 420 | toExpA (C.App av avs) = do 421 | (ds', av') <- toAnnValA av 422 | dsav <- mapM toAnnValA avs 423 | let (dss, avs') = unzip dsav 424 | return $ A.lets (ds' ++ concat dss) (A.App av' avs') 425 | toExpA (C.TmIf0 av e1 e2) = do 426 | (ds', av') <- toAnnValA av 427 | e1' <- toExpA e1 428 | e2' <- toExpA e2 429 | return $ A.lets ds' (A.TmIf0 av' e1' e2') 430 | toExpA (C.Halt ty av) = do 431 | ty' <- toTyA ty 432 | (ds', av') <- toAnnValA av 433 | return (A.lets ds' (A.Halt ty' av')) 434 | 435 | 436 | toDeclA :: C.Decl -> M [A.Decl] 437 | toDeclA (C.DeclVar x (Embed av)) = do 438 | (ds', av') <- toAnnValA av 439 | return (ds' ++ [A.DeclVar (translate x) (Embed av')]) 440 | toDeclA (C.DeclPrj i x (Embed av)) = do 441 | (ds', av') <- toAnnValA av 442 | return (ds' ++ [A.DeclPrj i (translate x) (Embed av')]) 443 | toDeclA (C.DeclPrim x (Embed (av1,p,av2))) = do 444 | (ds1', av1') <- toAnnValA av1 445 | (ds2', av2') <- toAnnValA av2 446 | return (ds1' ++ ds1' ++ [A.DeclPrim (translate x) 447 | (Embed (av1', p, av2'))]) 448 | 449 | toDeclA (C.DeclUnpack a x (Embed av)) = do 450 | (ds', av') <- toAnnValA av 451 | return (ds' ++ [A.DeclUnpack (translate a) (translate x) 452 | (Embed av')]) 453 | 454 | -- create the type [ ty_0^1 ... ty_{i-1}^1 ty_i^0 ty_{i+1}^0 ...] 455 | updateProd :: [A.Ty] -> Int -> [(A.Ty,A.Flag)] 456 | updateProd tys i = [ (ty, if j < i then A.Init else A.Un) | 457 | (ty, j) <- zip tys [0..] ] 458 | 459 | 460 | 461 | toAnnValA :: C.AnnVal -> M ([A.Decl],A.Ann A.Val) 462 | toAnnValA (C.Ann (C.TmProd vs) (C.TyProd tys)) = do 463 | dvs' <- mapM toAnnValA vs 464 | let (dss', vs') = unzip dvs' 465 | tys' <- mapM toTyA tys 466 | y <- fresh $ string2Name "ym" 467 | -- combine helper function for initialization 468 | -- y -- name of tuple to initialize 469 | -- -- typle type [ ty_0^1 ... ty_{i-1}^1 ty_i^0 ...] 470 | -- ds -- current list of declarations 471 | -- i -- index of the tuple to initialize 472 | -- avi -- value initialize y[i] 473 | let initialize tys' (yt, ds) (i,avi) = do 474 | y1 <- fresh $ string2Name "ya" 475 | let ay0 = A.Ann (A.TmVar yt) (A.TyProd (updateProd tys' i)) 476 | return (y1, ds ++ [A.DeclAssign y1 (Embed (ay0, i, avi))]) 477 | (yn, ds') <- foldM (initialize tys') 478 | (y, concat dss' ++ [A.DeclMalloc y (Embed tys')]) 479 | (zip [0..] vs') 480 | return (ds', A.Ann (A.TmVar yn) (A.TyProd (map (,A.Init) tys'))) 481 | 482 | 483 | toAnnValA (C.Ann v ty) = do 484 | (d,v') <- toValA v 485 | ty' <- toTyA ty 486 | return (d, A.Ann v' ty') 487 | 488 | toValA :: C.Val -> M ([A.Decl],A.Val) 489 | toValA (C.TmInt i) = return ([], A.TmInt i) 490 | toValA (C.TmVar v) = return ([], A.TmVar (translate v)) 491 | toValA (C.TApp av ty) = do 492 | (ds', av') <- toAnnValA av 493 | ty' <- toTyA ty 494 | return (ds', A.TApp av' ty') 495 | toValA (C.Pack ty av) = do 496 | ty' <- toTyA ty 497 | (ds', av') <- toAnnValA av 498 | return (ds', A.Pack ty' av') 499 | toValA (C.Fix _) = throwError "no fix after hoist" 500 | toValA (C.TmProd _) = throwError "catch in Annval" 501 | 502 | -------------------------------------------- 503 | -- A to TAL (Code Generation) 504 | -------------------------------------------- 505 | 506 | toFlag :: A.Flag -> TAL.Flag 507 | toFlag A.Init = TAL.Init 508 | toFlag A.Un = TAL.Un 509 | 510 | toTyTAL :: A.Ty -> M TAL.Ty 511 | toTyTAL (A.TyVar v) = return $ TAL.TyVar (translate v) 512 | toTyTAL A.TyInt = return TAL.TyInt 513 | toTyTAL (A.All bnd) = do 514 | (as, tys) <- unbind bnd 515 | let as' = map translate as 516 | tys' <- mapM toTyTAL tys 517 | let gamma = zip [TAL.reg1 ..] tys' 518 | return (TAL.All (bind as' gamma)) 519 | toTyTAL (A.TyProd tys) = do 520 | tys' <- mapM (\(ty,f) -> (,toFlag f) <$> toTyTAL ty) tys 521 | return $ TAL.TyProd tys' 522 | toTyTAL (A.Exists bnd) = do 523 | (a, ty) <- unbind bnd 524 | let a' = translate a 525 | ty' <- toTyTAL ty 526 | let ty2 = TAL.Exists $ bind a' ty' 527 | return $ TAL.Exists (bind a' ty') 528 | 529 | -- Keep track of the mapping between variables and registers 530 | -- or heap locations 531 | type Varmap = Map A.ValName TAL.SmallVal 532 | 533 | -- Create a register corresponding to a particular 534 | -- value variable 535 | var2reg :: A.ValName -> M (TAL.Register, Varmap) 536 | var2reg x = let rd = TAL.Register ("r" ++ name2String x ++ show (name2Integer x)) in 537 | return (rd,Map.singleton x (TAL.RegVal rd)) 538 | 539 | 540 | toSmallVal :: Varmap -> A.Ann A.Val -> M (TAL.SmallVal, TAL.Ty) 541 | toSmallVal vm (A.Ann (A.TmInt i) _) = 542 | return (TAL.WordVal (TAL.TmInt i), TAL.TyInt) 543 | toSmallVal vm (A.Ann (A.TmVar x) ty) = do 544 | ty' <- toTyTAL ty 545 | case Map.lookup x vm of 546 | Just sv -> return (sv, ty') 547 | Nothing -> throwError $ show x ++ " not found" 548 | toSmallVal vm (A.Ann (A.TApp av ty) ty1) = do 549 | ty1' <- toTyTAL ty1 550 | ty' <- toTyTAL ty 551 | (sv',_) <- toSmallVal vm av 552 | return (TAL.SApp (TAL.TyApp sv' ty'), ty1') 553 | toSmallVal vm (A.Ann (A.Pack ty1 av) ty2) = do 554 | ty1' <- toTyTAL ty1 555 | (av', _) <- toSmallVal vm av 556 | ty2' <- toTyTAL ty2 557 | return (TAL.SPack (TAL.Pack ty1' av' ty2'), ty2') 558 | 559 | toWordVal :: Varmap -> A.Ann A.Val -> M TAL.WordVal 560 | toWordVal vm (A.Ann (A.TmInt i) _) = return $ TAL.TmInt i 561 | toWordVal vm (A.Ann (A.TmVar x) _) = case Map.lookup x vm of 562 | Just (TAL.WordVal wv) -> return wv 563 | Just _ -> throwError "must be wordval" 564 | Nothing -> throwError "not found" 565 | toWordVal vm (A.Ann (A.TApp av ty) _) = do 566 | ty' <- toTyTAL ty 567 | sv' <- toWordVal vm av 568 | return $ TAL.WApp (TAL.TyApp sv' ty') 569 | toWordVal vm (A.Ann (A.Pack ty1 av) ty2) = do 570 | ty1' <- toTyTAL ty1 571 | av' <- toWordVal vm av 572 | ty2' <- toTyTAL ty2 573 | return $ TAL.WPack (TAL.Pack ty1' av' ty2') 574 | 575 | 576 | toInstrsTAL :: Varmap -> TAL.Delta -> TAL.Gamma -> A.Tm 577 | -> M (TAL.Heap, TAL.InstrSeq) 578 | toInstrsTAL vm delta gamma (A.Let bnd) = do 579 | (decl, tm) <- unbind bnd 580 | (vm', delta', gamma', is) <- toDeclTAL vm delta gamma decl 581 | (heap, is') <- toInstrsTAL vm' delta' gamma' tm 582 | return (heap, foldr TAL.Seq is' is) 583 | toInstrsTAL vm delta gamma (A.App av args) = do 584 | (sv, _) <- toSmallVal vm av 585 | (svs,_) <- unzip <$> mapM (toSmallVal vm) args 586 | let rtmps = zipWith (\ i _ -> TAL.rtmp i) [1 .. ] svs 587 | let movs1 = zipWith TAL.Mov rtmps svs 588 | let movs2 = zipWith TAL.Mov [TAL.reg1 ..] 589 | (map TAL.RegVal rtmps) 590 | return (Map.empty, 591 | foldr TAL.Seq 592 | (TAL.Jump (TAL.RegVal (TAL.rtmp 0))) 593 | ([TAL.Mov (TAL.rtmp 0) sv] ++ movs1 ++ movs2)) 594 | 595 | toInstrsTAL vm delta gamma (A.TmIf0 av e1 e2) = do 596 | (sv,_) <- toSmallVal vm av 597 | (h1,is1) <- toInstrsTAL vm delta gamma e1 598 | (h2,is2) <- toInstrsTAL vm delta gamma e2 599 | l <- TAL.Label <$> fresh (string2Name "l") 600 | let h = Map.singleton l (TAL.Code (map translate delta) gamma is2) 601 | return (Map.unions [h1,h2, h], 602 | TAL.Mov (TAL.rtmp 0) sv `TAL.Seq` 603 | (TAL.Bnz (TAL.rtmp 0) 604 | (TAL.sapps (TAL.WordVal (TAL.LabelVal l)) 605 | (map TAL.TyVar delta)) `TAL.Seq` 606 | is1)) 607 | 608 | toInstrsTAL vm delta gamma (A.Halt ty av) = do 609 | (sv,_) <- toSmallVal vm av 610 | ty' <- toTyTAL ty 611 | return (Map.empty, 612 | TAL.Mov TAL.reg1 sv `TAL.Seq` 613 | TAL.Halt ty') 614 | 615 | 616 | toDeclTAL :: Varmap -> TAL.Delta -> TAL.Gamma -> A.Decl -> M (Varmap, TAL.Delta, TAL.Gamma, [TAL.Instruction]) 617 | toDeclTAL vm delta gamma (A.DeclVar x (Embed av)) = do 618 | (sv, ty) <- toSmallVal vm av 619 | (rd, vm') <- var2reg x 620 | return (Map.union vm vm', 621 | delta, 622 | TAL.insertGamma rd ty gamma, 623 | [TAL.Mov rd sv]) 624 | 625 | toDeclTAL vm delta gamma (A.DeclPrj i x (Embed av)) = do 626 | (rd, vm') <- var2reg x 627 | (sv, ty) <- toSmallVal vm av 628 | ty1 <- case ty of 629 | TAL.TyProd tyfs -> do 630 | when (i >= length tyfs) $ throwError "Ld: index out of range" 631 | return $ fst (tyfs !! i) 632 | _ -> throwError "BUG: A.DeclPrj, not a product" 633 | return (Map.union vm vm', 634 | delta, 635 | TAL.insertGamma rd ty1 gamma, 636 | [TAL.Mov rd sv, 637 | TAL.Ld rd rd i]) 638 | 639 | toDeclTAL vm delta gamma (A.DeclPrim x (Embed (av1,p,av2))) = do 640 | (rd, vm') <- var2reg x 641 | (sv1, ty1) <- toSmallVal vm av1 642 | (sv2, ty2) <- toSmallVal vm av2 643 | let arith = case p of 644 | Plus -> TAL.Add 645 | Times -> TAL.Mul 646 | Minus -> TAL.Sub 647 | return (Map.union vm vm', 648 | delta, 649 | TAL.insertGamma rd TAL.TyInt gamma, 650 | [TAL.Mov rd sv1, arith rd rd sv2]) 651 | 652 | 653 | toDeclTAL vm delta gamma (A.DeclUnpack a x (Embed av)) = do 654 | (rd, vm') <- var2reg x 655 | (sv, ty1) <- toSmallVal vm av 656 | let a' = translate a 657 | ty2 <- case ty1 of 658 | TAL.Exists bnd -> return $ patUnbind a' bnd 659 | _ -> throwError "BUG: Unpack, not an exists" 660 | return (Map.union vm vm', 661 | a' : delta, 662 | TAL.insertGamma rd ty2 gamma, 663 | [TAL.Unpack a' rd sv]) 664 | 665 | toDeclTAL vm delta gamma (A.DeclMalloc x (Embed tys)) = do 666 | (rd, vm') <- var2reg x 667 | tys' <- mapM toTyTAL tys 668 | return (Map.union vm vm', 669 | delta, 670 | TAL.insertGamma rd (TAL.TyProd (map (,TAL.Un) tys')) gamma, 671 | [TAL.Malloc rd tys']) 672 | 673 | toDeclTAL vm delta gamma (A.DeclAssign x (Embed (av1, i, av2))) = do 674 | (rd, vm') <- var2reg x 675 | (sv1, ty1) <- toSmallVal vm av1 676 | (sv2, ty2) <- toSmallVal vm av2 677 | ty <- case ty1 of 678 | TAL.TyProd tyfs -> do 679 | when (i >= length tyfs) $ throwError "St: index out of range" 680 | let (before, _:after) = List.splitAt i tyfs 681 | return $ TAL.TyProd (before ++ [(ty2,TAL.Init)] ++ after) 682 | _ -> throwError "BUG: St: not a product" 683 | return (Map.union vm vm', 684 | delta, 685 | TAL.insertGamma rd ty gamma, 686 | [TAL.Mov rd sv1, 687 | TAL.Mov (TAL.rtmp 0) sv2, 688 | TAL.St rd i (TAL.rtmp 0)]) 689 | 690 | toHeapVal :: Varmap -> A.Ann A.HeapVal -> M (TAL.Heap, TAL.HeapVal) 691 | toHeapVal vm (A.Ann (A.Code bnd) (A.All bnd')) = do 692 | mb <- unbind2 bnd bnd' -- may fail 693 | case mb of 694 | Just (as, bnd2, _, tys) -> do 695 | (xs, e) <- unbind bnd2 696 | tys' <- mapM toTyTAL tys 697 | let rs = [TAL.reg1 ..] 698 | let gamma = zip rs tys' 699 | let vm' = Map.union vm (Map.fromList (zip xs (map TAL.RegVal rs))) 700 | let as' = map translate as 701 | (h, is) <- toInstrsTAL vm' as' gamma e 702 | return (h, TAL.Code as' gamma is) 703 | Nothing -> throwError "BUG!" 704 | 705 | toHeapVal vm (A.Ann (A.Tuple avs) (A.TyProd tyfs)) = do 706 | wvs <- mapM (toWordVal vm) avs 707 | return (Map.empty, TAL.Tuple wvs) 708 | 709 | toHeapVal vm _ = throwError "wrong type for heap val" 710 | 711 | 712 | toProgTAL :: (A.Tm, A.Heap) -> M TAL.Machine 713 | toProgTAL (tm, A.Heap hp) = do 714 | let vars = Map.keys hp 715 | let labels = map (TAL.Label . translate) vars 716 | let vm = 717 | Map.fromList (zip vars (map (TAL.WordVal . TAL.LabelVal) labels)) 718 | hhvs <- mapM (toHeapVal vm) (Map.elems hp) 719 | let (heaps, hvals) = unzip hhvs 720 | let hroot = Map.fromList (zip labels hvals) 721 | (hexp, is) <- toInstrsTAL vm [] [] tm 722 | let heap = Map.unions (hroot : heaps ++ [hexp]) 723 | return (heap, Map.empty, is) 724 | -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | module Util( 2 | -- ** Local 3 | patUnbind, 4 | Prim(..),evalPrim,M,runM, 5 | 6 | pp, Display(..), DM(..), displayList, displayTuple, intersperse, prefix, withPrec, precedence, binop, 7 | 8 | -- * GHC.Generics 9 | Generic(..), 10 | 11 | Set, Map, 12 | -- ** PrettyPrint 13 | Doc, (<+>), ($$), ($+$), int, punctuate, comma, colon, text, nest, vcat, sep, parens, braces, brackets) where 14 | 15 | import Text.PrettyPrint (Doc, (<+>), ($$), ($+$), vcat, int, punctuate, nest, 16 | comma, colon, text, sep, parens, braces, brackets, empty, 17 | render) 18 | import qualified Text.PrettyPrint as PP 19 | import Control.Applicative 20 | import Control.Monad.Identity 21 | import Control.Monad.Trans.Except 22 | import Control.Monad.Reader 23 | import Data.Set(Set) 24 | import qualified Data.Set as Set 25 | import qualified Data.List as List 26 | import Data.Map(Map) 27 | import qualified Data.Map as Map 28 | 29 | import GHC.Generics (Generic(..)) 30 | import Unbound.Generics.LocallyNameless hiding (prec,empty,Data,Refl,Val) 31 | import Unbound.Generics.LocallyNameless.Alpha 32 | import Unbound.Generics.LocallyNameless.Bind 33 | 34 | 35 | ------------------ 36 | -- should move to Unbound.LocallyNameless.Ops 37 | -- ? what if the pattern binds the wrong number of variables??? 38 | 39 | patUnbind :: (Alpha p, Alpha t) => p -> Bind p t -> t 40 | patUnbind p b = case b of 41 | (B _ t) -> open initialCtx (nthPatFind p) t 42 | 43 | ------------------ 44 | 45 | -- need to replace this with a better instance 46 | instance (Show a, Ord a, Ord b, Alpha b) => Alpha (Map a b) where 47 | aeq' _ctx i j = i == j 48 | 49 | fvAny' _ctx _nfn i = error "TAL: TODO" 50 | 51 | close ctx b = Map.map (close ctx b) 52 | open ctx b = Map.map (open ctx b) 53 | 54 | isPat _ = mempty 55 | isTerm _ = mempty 56 | 57 | nthPatFind _ = error "TAL: Don't use a finite map as a pattern" 58 | namePatFind _ = error "TAL: Don't use a finite map as a pattern" 59 | 60 | swaps' ctx p = Map.map (swaps' ctx p) 61 | 62 | freshen' _ctx i = return (i, mempty) 63 | lfreshen' _ctx i cont = cont i mempty 64 | 65 | acompare' _ctx i j = compare i j 66 | 67 | instance (Alpha b, Subst ty b) => Subst ty (Map a b) where 68 | subst n u m = Map.map (subst n u) m 69 | substs ss m = Map.map (substs ss) m 70 | 71 | 72 | ------------------------------------------------------------------------- 73 | -- Primitives 74 | ------------------------------------------------------------------------- 75 | 76 | data Prim = Plus | Minus | Times deriving (Eq, Ord, Generic) 77 | 78 | instance Show Prim where 79 | show Plus = "+" 80 | show Minus = "-" 81 | show Times = "*" 82 | 83 | 84 | instance Alpha Prim 85 | 86 | evalPrim :: Prim -> Int -> Int -> Int 87 | evalPrim Plus = (+) 88 | evalPrim Times = (*) 89 | evalPrim Minus = (-) 90 | 91 | 92 | ------------------------------------------------------------------------- 93 | -- Monad for evaluation, typechecking and translation. 94 | ------------------------------------------------------------------------- 95 | 96 | type M = ExceptT String FreshM 97 | 98 | runM :: M a -> a 99 | runM m = case runFreshM (runExceptT m) of 100 | Left s -> error s 101 | Right a -> a 102 | 103 | 104 | ------------------------------------------------------------------------- 105 | -- The Display class and other pretty printing helper functions 106 | ------------------------------------------------------------------------- 107 | 108 | -- | pretty-print 109 | pp :: Display t => t -> String 110 | pp d = render (runIdentity (runReaderT (runDM (display d)) initDI)) 111 | 112 | class Display t where 113 | -- | Convert a value to a 'Doc'. 114 | display :: t -> DM Doc 115 | 116 | newtype DM a = DM { runDM :: (ReaderT DispInfo Identity) a } 117 | deriving (Functor,Applicative,Monad) 118 | 119 | 120 | 121 | maybeParens :: Bool -> Doc -> Doc 122 | maybeParens b d = if b then parens d else d 123 | 124 | 125 | prefix :: String -> Doc -> DM Doc 126 | prefix str d = do 127 | di <- ask 128 | return $ maybeParens (precedence str < prec di) (PP.text str <+> d) 129 | 130 | binop :: Doc -> String -> Doc -> DM Doc 131 | binop d1 str d2 = do 132 | di <- ask 133 | let dop = if str == " " then sep [d1, d2] else sep [d1, PP.text str, d2] 134 | return $ maybeParens (precedence str < prec di) dop 135 | 136 | 137 | 138 | precedence :: String -> Int 139 | precedence "->" = 10 140 | precedence " " = 10 141 | precedence "forall" = 9 142 | precedence "if0" = 9 143 | precedence "fix" = 9 144 | precedence "\\" = 9 145 | precedence "*" = 8 146 | precedence "+" = 7 147 | precedence "-" = 7 148 | precedence _ = 0 149 | 150 | 151 | 152 | instance MonadReader DispInfo DM where 153 | ask = DM ask 154 | local f (DM m) = DM (local f m) 155 | 156 | -- | The data structure for information about the display 157 | -- 158 | data DispInfo = DI 159 | { 160 | prec :: Int, -- ^ precedence level 161 | showTypes :: Bool, -- ^ should we show types? 162 | dispAvoid :: Set.Set AnyName -- ^ names that have been used 163 | } 164 | 165 | instance LFresh DM where 166 | lfresh nm = do 167 | let s = name2String nm 168 | di <- ask; 169 | return $ head (filter (\x -> AnyName x `Set.notMember` dispAvoid di) 170 | (map (makeName s) [0..])) 171 | getAvoids = asks dispAvoid 172 | avoid names = local upd where 173 | upd di = di { dispAvoid = 174 | Set.fromList names `Set.union` dispAvoid di } 175 | 176 | 177 | -- | An empty 'DispInfo' context 178 | initDI :: DispInfo 179 | initDI = DI 10 False Set.empty 180 | 181 | withPrec :: Int -> DM a -> DM a 182 | withPrec i = 183 | local $ \ di -> di { prec = i } 184 | 185 | getPrec :: DM Int 186 | getPrec = asks prec 187 | 188 | 189 | 190 | intersperse :: Doc -> [Doc] -> [Doc] 191 | intersperse _ [] = [] 192 | intersperse _ [x] = [x] 193 | intersperse sep (x:xs) = x <> sep : intersperse sep xs 194 | 195 | displayList :: Display t => [t] -> DM Doc 196 | displayList es = do 197 | ds <- mapM (withPrec 0 . display) es 198 | return $ PP.cat (intersperse PP.comma ds) 199 | 200 | displayTuple :: Display t => [t] -> DM Doc 201 | displayTuple es = do 202 | ds <- displayList es 203 | return $ PP.text "<" <> ds <> PP.text ">" 204 | 205 | -------------------------------------------- 206 | 207 | instance Display (Name a) where 208 | display n = return $ (PP.text . show) n 209 | 210 | -------------------------------------------- 211 | 212 | instance Display String where 213 | display = return . PP.text 214 | instance Display Int where 215 | display = return . PP.text . show 216 | instance Display Integer where 217 | display = return . PP.text . show 218 | instance Display Double where 219 | display = return . PP.text . show 220 | instance Display Float where 221 | display = return . PP.text . show 222 | instance Display Char where 223 | display = return . PP.text . show 224 | instance Display Bool where 225 | display = return . PP.text . show 226 | 227 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-18.12 19 | 20 | 21 | # User packages to be built. 22 | # Various formats can be used as shown in the example below. 23 | # 24 | # packages: 25 | # - some-directory 26 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 27 | # - location: 28 | # git: https://github.com/commercialhaskell/stack.git 29 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # extra-dep: true 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | # 36 | # A package marked 'extra-dep: true' will only be built if demanded by a 37 | # non-dependency (i.e. a user package), and its test suites and benchmarks 38 | # will not be run. This is useful for tweaking upstream packages. 39 | packages: 40 | - . 41 | # Dependency packages to be pulled from upstream that are not in the resolver 42 | # (e.g., acme-missiles-0.3) 43 | extra-deps: 44 | - unbound-generics-0.4.1@sha256:5020e8397dad610846cbd5bdc855e20edf9b9cb74f93f6c09488bba21118c409,5485 45 | 46 | 47 | # Override default flag values for local packages and extra-deps 48 | flags: {} 49 | 50 | # Extra package databases containing global packages 51 | extra-package-dbs: [] 52 | 53 | # Control whether we use the GHC we find on the path 54 | # system-ghc: true 55 | # 56 | # Require a specific version of stack, using version ranges 57 | # require-stack-version: -any # Default 58 | # require-stack-version: ">=1.5" 59 | # 60 | # Override the architecture used by stack, especially useful on Windows 61 | # arch: i386 62 | # arch: x86_64 63 | # 64 | # Extra directories used by stack for building 65 | # extra-include-dirs: [/path/to/dir] 66 | # extra-lib-dirs: [/path/to/dir] 67 | # 68 | # Allow a newer minor version of GHC than the snapshot specifies 69 | # compiler-check: newer-minor 70 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: unbound-generics-0.4.1@sha256:5020e8397dad610846cbd5bdc855e20edf9b9cb74f93f6c09488bba21118c409,5485 9 | pantry-tree: 10 | size: 3046 11 | sha256: 3f6a21308ef8d6e6127448715671ef4cd21d71b81198c77d58f55008aee988f8 12 | original: 13 | hackage: unbound-generics-0.4.1@sha256:5020e8397dad610846cbd5bdc855e20edf9b9cb74f93f6c09488bba21118c409,5485 14 | snapshots: 15 | - completed: 16 | size: 586041 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/12.yaml 18 | sha256: 80fc6391195ff00c36f2a605ecbb07de909bfaa2eaa9722a27e486a6ecf8ecb0 19 | original: lts-18.12 20 | -------------------------------------------------------------------------------- /tal.cabal: -------------------------------------------------------------------------------- 1 | -- Initial tal.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: tal 5 | version: 0.1.1.0 6 | synopsis: An implementation of Typed Assembly Language (Morrisett, Walker, Crary, Glew) 7 | -- description: 8 | homepage: https://github.com/sweirich/tal 9 | license: MIT 10 | license-file: LICENSE 11 | author: Stephanie Weirich 12 | maintainer: sweirich@cis.upenn.edu 13 | copyright: 2015 Stephanie Weirich 14 | category: Language 15 | build-type: Simple 16 | extra-source-files: README.md 17 | cabal-version: >=1.10 18 | 19 | library 20 | exposed-modules: A, C, Util, TAL, K, F, Translate 21 | default-extensions: ScopedTypeVariables 22 | , FlexibleInstances 23 | , MultiParamTypeClasses 24 | , FlexibleContexts 25 | , UndecidableInstances 26 | , TupleSections 27 | , GADTs 28 | , TypeSynonymInstances 29 | , DeriveGeneric 30 | , TypeApplications 31 | , GeneralizedNewtypeDeriving 32 | build-depends: base >=4.7 && < 5 33 | , containers 34 | , mtl 35 | , pretty 36 | , transformers 37 | , unbound-generics 38 | hs-source-dirs: src 39 | default-language: Haskell2010 40 | 41 | Test-Suite test 42 | type: exitcode-stdio-1.0 43 | hs-source-dirs: src 44 | main-is: Main.hs 45 | other-modules: A, C, Util, TAL, K, F, Translate 46 | build-depends: base 47 | , containers 48 | , mtl 49 | , pretty 50 | , transformers 51 | , unbound-generics 52 | default-language: Haskell2010 53 | default-extensions: 54 | ScopedTypeVariables 55 | , FlexibleInstances 56 | , MultiParamTypeClasses 57 | , FlexibleContexts 58 | , UndecidableInstances 59 | , TupleSections 60 | , GADTs 61 | , TypeSynonymInstances 62 | , DeriveGeneric 63 | , TypeApplications 64 | , GeneralizedNewtypeDeriving --------------------------------------------------------------------------------