├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app ├── stgCompile.hs └── stgParse.hs ├── package.yaml ├── src ├── Compiler │ ├── Translate.hs │ └── Util.hs └── Language │ ├── MiniStg.hs │ └── MiniStg │ ├── Lexer.x │ ├── Parser.y │ ├── Prettyprint.hs │ └── Util.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | ### Haskell ### 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.hi 6 | *.o 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | cabal.sandbox.config 12 | .cabal-sandbox/ 13 | *.prof 14 | *.aux 15 | .stack-work/ 16 | *.ghci 17 | 18 | ### Temp Files ### 19 | *.swp 20 | 21 | ### generated files ### 22 | StgLexer.hs 23 | StgParser.hs 24 | ministgwasm.cabal 25 | 26 | ### test file ### 27 | testfiles/ 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2017, Yifan Chen (Neuromancer42) 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Mini-STG-Wasm: a mini compiler 2 | 3 | This is an attempt to compile Spineless Tagless G-Machine ( STG ) language to Web-Assembly bytecode. 4 | 5 | ## About the mini-STG language 6 | The language is similar to the language defined in the classical STG paper by Simon Peyton Jones in 1992: *[The Implementation of Functional Programming Languages](https://www.microsoft.com/en-us/research/publication/the-implementation-of-functional-programming-languages/?from=http%3A%2F%2Fresearch.microsoft.com%2Fen-us%2Fum%2Fpeople%2Fsimonpj%2Fpapers%2Fslpj-book-1987%2Findex.htm)*. 7 | 8 | The syntax file is modified from the syntax file used in [quchen/STGi](https://hackage.haskell.org/package/stgi), since the simplified syntax is just enough to prove my method. 9 | 10 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/stgCompile.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Compiler.Translate 4 | import Control.Monad.Except 5 | import LLVM.AST 6 | import qualified LLVM.AST as AST 7 | import LLVM.Context 8 | import LLVM.Module 9 | import Language.MiniStg as STG 10 | import Language.MiniStg.Parser (parseStg) 11 | import System.Environment 12 | import System.Exit 13 | import System.IO 14 | 15 | main :: IO () 16 | main = do 17 | args <- getArgs 18 | case args of 19 | [ifile, ofile] -> do 20 | input <- readFile ifile 21 | let ast = parseStg input 22 | let defs = trProgram ast 23 | let m = defaultModule {moduleName = "test", moduleDefinitions = defs} 24 | toLLVM m 25 | where 26 | toLLVM :: AST.Module -> IO () 27 | toLLVM m = 28 | withContext $ \ctx -> do 29 | errOrLLVM <- runExceptT $ withModuleFromAST ctx m moduleLLVMAssembly 30 | case errOrLLVM of 31 | Left err -> hPutStrLn stderr $ "error: " ++ err 32 | Right llvm -> writeFile ofile llvm 33 | _ -> hPutStrLn stderr $ "Usage: compileStg " 34 | -------------------------------------------------------------------------------- /app/stgParse.hs: -------------------------------------------------------------------------------- 1 | import Language.MiniStg.Parser (parseStg) 2 | 3 | main = do 4 | s <- getLine 5 | let t = parseStg s 6 | putStrLn . show $ t 7 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: ministgwasm 2 | version: 0.0.1 3 | category: Development 4 | synopsis: A mini-STG to WebAssembly toy-compiler 5 | 6 | stability: alpha 7 | maintainer: Yifan Chen 8 | copyright: (c) 2017 Yifan Chen (Neuromancer42) 9 | license: BSD3 10 | github: Neuromancer42/ministgwasm 11 | 12 | extra-source-files: 13 | - LICENSE 14 | - README.md 15 | 16 | build-tools: alex, happy 17 | 18 | ghc-options: -Wall 19 | 20 | library: 21 | source-dirs: 22 | - src 23 | exposed-modules: 24 | - Language.MiniStg 25 | - Language.MiniStg.Util 26 | - Language.MiniStg.Prettyprint 27 | - Language.MiniStg.Lexer 28 | - Language.MiniStg.Parser 29 | - Compiler.Translate 30 | 31 | executables: 32 | compileStg: 33 | source-dirs: app 34 | main: stgCompile.hs 35 | dependencies: 36 | - ministgwasm 37 | 38 | dependencies: 39 | - base >= 4.8 && < 5 40 | - text 41 | - containers 42 | - semigroups 43 | - deepseq 44 | - th-lift 45 | - ansi-wl-pprint 46 | - array 47 | - llvm-hs 48 | - llvm-hs-pure 49 | - mtl 50 | -------------------------------------------------------------------------------- /src/Compiler/Translate.hs: -------------------------------------------------------------------------------- 1 | module Compiler.Translate 2 | ( trProgram 3 | ) where 4 | 5 | import Compiler.Util 6 | import qualified Data.List as L 7 | import qualified Data.Map.Lazy as M 8 | import qualified Data.Set as S 9 | import qualified Data.Text as T 10 | import LLVM.AST 11 | import LLVM.AST.CallingConvention 12 | import qualified LLVM.AST.Constant as Const 13 | import qualified LLVM.AST.Global as Gbl 14 | import qualified LLVM.AST.IntegerPredicate as P 15 | import LLVM.AST.Type 16 | import qualified Language.MiniStg as STG 17 | 18 | -- | translate localbindings to mallocs. 19 | -- (treat all let-binds as recursive) 20 | -- allocate space for binders first 21 | -- and then fill in all the arguments. 22 | trLocalBinds :: S.Set T.Text -> M.Map STG.Var STG.LambdaForm -> (S.Set T.Text, [Named Instruction]) 23 | trLocalBinds outerRef binds = 24 | (localRef, concatMap (uncurry trPreBind) kvps ++ concatMap (uncurry (trFillBind localRef)) kvps) 25 | where 26 | kvps = M.assocs binds 27 | localRef = S.map (\(STG.Var v) -> v) (M.keysSet binds) `S.union` outerRef 28 | 29 | -- | fill arguments in thunks 30 | trFillBind :: S.Set T.Text -> STG.Var -> STG.LambdaForm -> [Named Instruction] 31 | trFillBind localRef (STG.Var bndr) (STG.LambdaForm [] _ [] expr) = 32 | let bndrname = T.unpack bndr 33 | allocname = Name $ bndrname ++ "_al" 34 | in case expr of 35 | STG.Let {} -> error "Syntax Error: Let expression in local binding not lifted" 36 | STG.Case _ _ -> error "Syntax Error: Case expression in local binding not lifted" 37 | -- ^ complex expressions are not allowed in local bindings 38 | STG.AppF (STG.Var f) as -> 39 | let addrname = bndrname ++ "_ad0" 40 | in (Name addrname := 41 | IntToPtr {operand0 = LocalReference int allocname, type' = intptr, metadata = []}) : 42 | trFunc (Name addrname) f (L.length as) ++ 43 | concat (zipWith (trArg bndrname localRef) as [1 ..]) 44 | STG.AppC (STG.Constr c) as -> 45 | let addrname = bndrname ++ "_ad0" 46 | in (Name addrname := 47 | IntToPtr {operand0 = LocalReference int allocname, type' = intptr, metadata = []}) : 48 | Do 49 | Store 50 | { volatile = False 51 | , address = LocalReference intptr $ Name addrname 52 | , value = ConstantOperand $ trConstr c (L.length as) 53 | , maybeAtomicity = Nothing 54 | , alignment = 8 55 | , metadata = [] 56 | } : 57 | concat (zipWith (trArg bndrname localRef) as [1 ..]) 58 | STG.AppP {} -> error "Syntax error: primitive operation in local binding not supported" 59 | STG.LitE _ -> [] 60 | where 61 | trFunc :: Name -> T.Text -> Int -> [Named Instruction] 62 | trFunc ad f ll = 63 | let l = fromIntegral ll 64 | in if l > 3 65 | then error "Syntax Error: Arguments more than 3 not supported" 66 | else let fname = Name $ T.unpack f 67 | temp = Name $ T.unpack f ++ "_ptr" 68 | temp1 = Name $ T.unpack f ++ "_ptr1" 69 | tagged = Name $ T.unpack f ++ "_tagged" 70 | in [ temp := 71 | BitCast (ConstantOperand $ Const.GlobalReference intintfunc fname) intptr [] 72 | , temp1 := PtrToInt (LocalReference intptr temp) int [] 73 | , tagged := 74 | Add 75 | False 76 | False 77 | (LocalReference int temp1) 78 | (ConstantOperand $ Const.Int 64 (l * 2 + funcTag)) 79 | [] 80 | , Do 81 | Store 82 | { volatile = False 83 | , address = LocalReference intptr ad 84 | , value = LocalReference int tagged 85 | , maybeAtomicity = Nothing 86 | , alignment = 8 87 | , metadata = [] 88 | } 89 | ] 90 | trConstr :: T.Text -> Int -> Const.Constant 91 | trConstr c l = 92 | let s = T.unpack c 93 | in if L.length s > 10 94 | then error "Syntax Error: Constructor name longer than 10 not supported" 95 | else if l > 3 96 | then error "Syntax Error: Arguments more than 3 not supported" 97 | else let hashcode = encConstr s (fromIntegral l) 98 | in Const.Int 64 hashcode 99 | trArg :: String -> S.Set T.Text -> STG.Atom -> Integer -> [Named Instruction] 100 | trArg basename ref a i = 101 | let allocname = Name $ basename ++ "_al" 102 | calcname = Name $ basename ++ "_arg" ++ show i 103 | addr = Name $ basename ++ "_ad" ++ show i 104 | in [ calcname := 105 | Add 106 | False 107 | False 108 | (LocalReference int allocname) 109 | (ConstantOperand (Const.Int 64 (i * 8))) 110 | [] 111 | , addr := IntToPtr (LocalReference int calcname) intptr [] 112 | , Do $ 113 | Store 114 | { volatile = False 115 | , address = LocalReference intptr addr 116 | , value = 117 | case a of 118 | STG.AtomLit (STG.Literal l) -> ConstantOperand $ trLit l 119 | STG.AtomVar (STG.Var v) -> 120 | let vname = Name $ T.unpack v 121 | in if S.member v ref 122 | then LocalReference int vname 123 | else error 124 | "Error: Global reference in local binding arguments not supported" 125 | , maybeAtomicity = Nothing 126 | , alignment = 8 127 | , metadata = [] 128 | } 129 | ] 130 | trFillBind _ _ _ = error "Syntax Error: Lambda expression in local binding not lifted" 131 | -- ^ lambda expressions should be lifted to top bindings 132 | 133 | -- | allocate heap space for thunks created by every single local binding 134 | trPreBind :: STG.Var -> STG.LambdaForm -> [Named Instruction] 135 | trPreBind (STG.Var bndr) (STG.LambdaForm [] _ [] expr) = 136 | let bndrname = T.unpack bndr 137 | in case expr of 138 | STG.Let {} -> error "Syntax Error: Let expression in local binding not lifted" 139 | STG.Case _ _ -> error "Syntax Error: Case expression in local binding not lifted" 140 | -- ^ complex expressions are not allowed in local bindings 141 | STG.AppF _ as -> 142 | let memsize = fromIntegral $ (L.length as + 1) * 8 143 | in crtThunk bndrname memsize unevalFuncTag 144 | STG.AppC _ as -> 145 | let memsize = fromIntegral $ (L.length as + 1) * 8 146 | in crtThunk bndrname memsize evalConTag 147 | STG.AppP {} -> error "Syntax error: primitive operation in local binding not supported" 148 | STG.LitE (STG.Literal l) -> 149 | [ Name bndrname := 150 | Add 151 | False 152 | False 153 | (ConstantOperand (trLit l)) 154 | (ConstantOperand (Const.Int 64 evalLitTag)) 155 | [] 156 | ] 157 | where 158 | callMalloc :: Integer -> Instruction 159 | -- ^ call the external malloc function to allcate space 160 | callMalloc sz = 161 | Call 162 | { tailCallKind = Nothing 163 | , callingConvention = C 164 | , returnAttributes = [] 165 | , function = Right (ConstantOperand (Const.GlobalReference intintfunc (Name "malloc"))) 166 | , arguments = [(ConstantOperand $ Const.Int 64 sz, [])] 167 | , functionAttributes = [] 168 | , metadata = [] 169 | } 170 | crtThunk :: String -> Integer -> Integer -> [Named Instruction] 171 | crtThunk n s t = 172 | let refname = Name n 173 | allocname = Name $ n ++ "_al" 174 | in [ allocname := callMalloc s 175 | , refname := 176 | Add 177 | { nsw = False 178 | , nuw = False 179 | , operand0 = LocalReference int allocname 180 | , operand1 = ConstantOperand $ Const.Int 64 t 181 | , metadata = [] 182 | } 183 | ] 184 | trPreBind _ _ = error "Syntax Error: Lambda expression in local binding not lifted" 185 | -- ^ lambda expressions should be lifted to top bindings 186 | 187 | -- | translate literal number into constants 188 | trLit :: Integer -> Const.Constant 189 | -- ^ a literal number is stored as 3 digits shifted 190 | trLit l = Const.Shl False False (Const.Int 64 l) (Const.Int 64 3) 191 | 192 | -- | tranlate an top-level binding into a function, 193 | -- which is in responsibility to update a thunk 194 | -- into a construction or a literal 195 | trTopBind :: STG.Var -> STG.LambdaForm -> Definition 196 | trTopBind (STG.Var v) (STG.LambdaForm [] _ [] expr) 197 | | T.unpack v == "main" = 198 | trTopBind (STG.Var (T.pack "__main")) (STG.LambdaForm [] STG.Update [] expr) 199 | trTopBind (STG.Var f) (STG.LambdaForm fvs _ bndrs expr) = 200 | GlobalDefinition 201 | Gbl.functionDefaults 202 | { Gbl.name = fname 203 | , Gbl.parameters = ([Parameter int (Name "ptr") []], False) 204 | , Gbl.returnType = int 205 | , Gbl.basicBlocks = 206 | BasicBlock (Name "entry") (initfetch ++ fetches) (Do (Br (Name "layer1") [])) : 207 | trBody 1 initRef expr 208 | , Gbl.alignment = 8 209 | } 210 | where 211 | fname :: Name 212 | fname = Name $ T.unpack f 213 | as :: [T.Text] 214 | as = map (\(STG.Var n) -> n) (fvs ++ bndrs) 215 | fetches :: [Named Instruction] 216 | fetches = concat (zipWith fetcharg as [1 ..]) 217 | initfetch :: [Named Instruction] 218 | initfetch = 219 | [ Name "ptr_trim" := 220 | LShr 221 | { exact = False 222 | , operand0 = LocalReference int (Name "ptr") 223 | , operand1 = ConstantOperand (Const.Int 64 3) 224 | , metadata = [] 225 | } 226 | , Name "ptr_base" := 227 | Shl False False (LocalReference int (Name "ptr_trim")) (ConstantOperand (Const.Int 64 3)) [] 228 | , Name "ptr_addr0" := IntToPtr (LocalReference int (Name "ptr_base")) intptr [] 229 | , Name "ptr_data" := 230 | Load 231 | { volatile = False 232 | , address = LocalReference intptr (Name "ptr_addr0") 233 | , maybeAtomicity = Nothing 234 | , alignment = 8 235 | , metadata = [] 236 | } 237 | , Name "ptr_tag" := 238 | And (LocalReference int (Name "ptr_data")) (ConstantOperand (Const.Int 64 7)) [] 239 | ] 240 | fetcharg :: T.Text -> Integer -> [Named Instruction] 241 | fetcharg v i = 242 | let n = T.unpack v 243 | in if n == "_" 244 | then [] 245 | else [ Name ("ptr_arg" ++ show i) := 246 | Add 247 | False 248 | False 249 | (LocalReference int (Name "ptr_base")) 250 | (ConstantOperand (Const.Int 64 (i * 8))) 251 | [] 252 | , Name ("ptr_ad" ++ show i) := 253 | IntToPtr (LocalReference int (Name ("ptr_arg" ++ show i))) intptr [] 254 | , Name n := 255 | Load 256 | { volatile = False 257 | , address = LocalReference intptr (Name ("ptr_ad" ++ show i)) 258 | , maybeAtomicity = Nothing 259 | , alignment = 8 260 | , metadata = [] 261 | } 262 | ] 263 | initRef :: S.Set T.Text 264 | initRef = 265 | foldr 266 | (\n s -> 267 | if T.unpack n == "_" 268 | then s 269 | else S.insert n s) 270 | S.empty 271 | as 272 | 273 | -- | translate a functions body instructions 274 | trBody :: Integer -> S.Set T.Text -> STG.Expr -> [BasicBlock] 275 | trBody i ref (STG.Let _ (STG.Binds bd) innerExpr) = 276 | let (innerRef, instrs) = trLocalBinds ref bd 277 | in BasicBlock (Name ("layer" ++ show i)) instrs (Do $ Br (Name ("layer" ++ show (i + 1))) []) : 278 | trBody (i + 1) innerRef innerExpr 279 | trBody i ref (STG.Case (STG.AppF (STG.Var v) []) (STG.Alts STG.NoNonDefaultAlts (STG.DefaultNotBound e))) = 280 | case e of 281 | STG.Let {} -> error "Error: Complicated alternatives not supported" 282 | STG.Case {} -> error "Error: Complicated alternatives not supported" 283 | _ -> trUpdateV i ("layer" ++ show i) ("layer" ++ show (i + 1)) (T.unpack v) ++ trBody i ref e 284 | trBody _ _ STG.Case {} = error "Syntax Error: complicated case evaluation not supported" 285 | trBody i ref e@STG.AppC {} = 286 | [ BasicBlock 287 | (Name ("layer" ++ show i)) 288 | (trPreBind (STG.Var $ T.pack "retval") (STG.LambdaForm [] STG.Update [] e) ++ 289 | trFillBind ref (STG.Var $ T.pack "retval") (STG.LambdaForm [] STG.Update [] e) ++ 290 | [replaceThunk "ptr_addr0" "retval"]) 291 | (Do $ Ret (Just (LocalReference int (Name "retval"))) []) 292 | ] 293 | trBody i ref e@STG.LitE {} = 294 | [ BasicBlock 295 | (Name ("layer" ++ show i)) 296 | (trPreBind (STG.Var $ T.pack "retval") (STG.LambdaForm [] STG.Update [] e) ++ 297 | trFillBind ref (STG.Var $ T.pack "retval") (STG.LambdaForm [] STG.Update [] e) ++ 298 | [replaceThunk "ptr_addr0" "retval"]) 299 | (Do $ Ret (Just (LocalReference int (Name "retval"))) []) 300 | ] 301 | trBody i ref e@(STG.AppF (STG.Var f) _) = 302 | [ BasicBlock 303 | (Name ("layer" ++ show i)) 304 | (trPreBind (STG.Var $ T.pack ("__temp" ++ show i)) (STG.LambdaForm [] STG.Update [] e) ++ 305 | trFillBind ref (STG.Var $ T.pack ("__temp" ++ show i)) (STG.LambdaForm [] STG.Update [] e) ++ 306 | trUpdateAppF (T.unpack f) ("__temp" ++ show i) "retval" ++ 307 | [replaceThunk "ptr_addr0" "retval"]) 308 | (Do $ Ret (Just (LocalReference int (Name "retval"))) []) 309 | ] 310 | trBody i _ (STG.AppP op (STG.AtomLit (STG.Literal xl)) (STG.AtomLit (STG.Literal yl))) = 311 | let o = trOp op 312 | in [ BasicBlock 313 | (Name ("layer" ++ show i)) 314 | [ Name "__val" := o (ConstantOperand (Const.Int 64 xl)) (ConstantOperand (Const.Int 64 yl)) 315 | , Name "retval" := 316 | Shl False False (LocalReference int (Name "__val")) (ConstantOperand (Const.Int 64 3)) [] 317 | , replaceThunk "ptr_addr0" "retval" 318 | ] 319 | (Do $ Ret (Just (LocalReference int (Name "retval"))) []) 320 | ] 321 | trBody i ref (STG.AppP op (STG.AtomLit (STG.Literal xl)) (STG.AtomVar (STG.Var y))) 322 | | S.member y ref = 323 | let o = trOp op 324 | in trUpdateV i ("layer" ++ show i) "exit" (T.unpack y) ++ 325 | [ BasicBlock 326 | (Name "exit") 327 | [ Name (T.unpack y ++ "__prim") := 328 | LShr 329 | False 330 | (LocalReference int (Name (T.unpack y ++ "__updated"))) 331 | (ConstantOperand $ Const.Int 64 3) 332 | [] 333 | , Name "__val" := 334 | o 335 | (ConstantOperand (Const.Int 64 xl)) 336 | (LocalReference int (Name (T.unpack y ++ "__prim"))) 337 | , Name "retval" := 338 | Shl 339 | False 340 | False 341 | (LocalReference int (Name "__val")) 342 | (ConstantOperand (Const.Int 64 3)) 343 | [] 344 | , replaceThunk "ptr_addr0" "retval" 345 | ] 346 | (Do $ Ret (Just (LocalReference int (Name "retval"))) []) 347 | ] 348 | trBody i ref (STG.AppP op (STG.AtomVar (STG.Var x)) (STG.AtomLit (STG.Literal yl))) 349 | | S.member x ref = 350 | let o = trOp op 351 | in trUpdateV i ("layer" ++ show i) "exit" (T.unpack x) ++ 352 | [ BasicBlock 353 | (Name "exit") 354 | [ Name (T.unpack x ++ "__prim") := 355 | LShr 356 | False 357 | (LocalReference int (Name (T.unpack x ++ "__updated"))) 358 | (ConstantOperand $ Const.Int 64 3) 359 | [] 360 | , Name "__val" := 361 | o 362 | (LocalReference int (Name (T.unpack x ++ "__prim"))) 363 | (ConstantOperand (Const.Int 64 yl)) 364 | , Name "retval" := 365 | Shl 366 | False 367 | False 368 | (LocalReference int (Name "__val")) 369 | (ConstantOperand (Const.Int 64 3)) 370 | [] 371 | , replaceThunk "ptr_addr0" "retval" 372 | ] 373 | (Do $ Ret (Just (LocalReference int (Name "retval"))) []) 374 | ] 375 | trBody i ref (STG.AppP op (STG.AtomVar (STG.Var x)) (STG.AtomVar (STG.Var y))) 376 | | S.member x ref && S.member y ref = 377 | let o = trOp op 378 | in trUpdateV i ("layer" ++ show i) ("layer" ++ show (i + 1)) (T.unpack x) ++ 379 | trUpdateV (i + 1) ("layer" ++ show (i + 1)) "exit" (T.unpack y) ++ 380 | [ BasicBlock 381 | (Name "exit") 382 | [ Name (T.unpack x ++ "__prim") := 383 | LShr 384 | False 385 | (LocalReference int (Name (T.unpack x ++ "__updated"))) 386 | (ConstantOperand $ Const.Int 64 3) 387 | [] 388 | , Name (T.unpack y ++ "__prim") := 389 | LShr 390 | False 391 | (LocalReference int (Name (T.unpack y ++ "__updated"))) 392 | (ConstantOperand $ Const.Int 64 3) 393 | [] 394 | , Name "__val" := 395 | o 396 | (LocalReference int (Name (T.unpack x ++ "__prim"))) 397 | (LocalReference int (Name (T.unpack y ++ "__prim"))) 398 | , Name "retval" := 399 | Shl 400 | False 401 | False 402 | (LocalReference int (Name "__val")) 403 | (ConstantOperand (Const.Int 64 3)) 404 | [] 405 | , replaceThunk "ptr_addr0" "retval" 406 | ] 407 | (Do $ Ret (Just (LocalReference int (Name "retval"))) []) 408 | ] 409 | trBody _ _ STG.AppP {} = error "Error: Global thunk not supported" 410 | 411 | replaceThunk :: String -> String -> Named Instruction 412 | replaceThunk addr val = 413 | Do 414 | Store 415 | { volatile = False 416 | , address = LocalReference intptr (Name addr) 417 | , value = LocalReference int (Name val) 418 | , maybeAtomicity = Nothing 419 | , alignment = 8 420 | , metadata = [] 421 | } 422 | 423 | trUpdateAppF :: String -> String -> String -> [Named Instruction] 424 | trUpdateAppF func thk ret = 425 | [ Name ret := 426 | Call 427 | { tailCallKind = Nothing 428 | , callingConvention = C 429 | , returnAttributes = [] 430 | , function = Right (ConstantOperand (Const.GlobalReference intintfunc (Name func))) 431 | , arguments = [(LocalReference int (Name thk), [])] 432 | , functionAttributes = [] 433 | , metadata = [] 434 | } 435 | ] 436 | 437 | trUpdateV :: Integer -> String -> String -> String -> [BasicBlock] 438 | trUpdateV i entrylabel exitlabel v = 439 | let vn = v ++ "_" ++ show i 440 | in [ BasicBlock 441 | (Name entrylabel) 442 | [ Name (vn ++ "_tag") := 443 | And (LocalReference int (Name v)) (ConstantOperand (Const.Int 64 1)) [] 444 | , Name (vn ++ "_pred") := 445 | ICmp 446 | P.EQ 447 | (LocalReference int (Name (vn ++ "_tag"))) 448 | (ConstantOperand (Const.Int 64 1)) 449 | [] 450 | ] 451 | (Do $ 452 | CondBr 453 | (LocalReference i1 (Name (vn ++ "_pred"))) 454 | (Name ("fetch" ++ show i)) 455 | (Name ("upd" ++ show i)) 456 | []) 457 | , BasicBlock 458 | (Name ("fetch" ++ show i)) 459 | [ Name (vn ++ "_prim") := 460 | LShr False (LocalReference int (Name v)) (ConstantOperand (Const.Int 64 3)) [] 461 | , Name (vn ++ "_addr") := 462 | Shl 463 | False 464 | False 465 | (LocalReference int (Name (vn ++ "_prim"))) 466 | (ConstantOperand (Const.Int 64 3)) 467 | [] 468 | , Name (vn ++ "_ptr") := IntToPtr (LocalReference int (Name (vn ++ "_addr"))) intptr [] 469 | , Name (vn ++ "_hd") := 470 | Load 471 | { volatile = False 472 | , address = LocalReference intptr (Name (vn ++ "_ptr")) 473 | , maybeAtomicity = Nothing 474 | , alignment = 8 475 | , metadata = [] 476 | } 477 | , Name (vn ++ "_st") := 478 | And (LocalReference int (Name (vn ++ "_hd"))) (ConstantOperand (Const.Int 64 1)) [] 479 | , Name (vn ++ "_pred") := 480 | ICmp P.EQ (LocalReference int (Name (vn ++ "_st"))) (ConstantOperand (Const.Int 64 1)) [] 481 | ] 482 | (Do $ 483 | CondBr 484 | (LocalReference i1 (Name (vn ++ "_pred"))) 485 | (Name ("eval" ++ show i)) 486 | (Name ("upd" ++ show i)) 487 | []) 488 | , BasicBlock 489 | (Name ("eval" ++ show i)) 490 | [ Name (vn ++ "_func_prim") := 491 | LShr 492 | False 493 | (LocalReference int (Name (vn ++ "_hd"))) 494 | (ConstantOperand (Const.Int 64 3)) 495 | [] 496 | , Name (vn ++ "_func_addr") := 497 | Shl 498 | False 499 | False 500 | (LocalReference int (Name (vn ++ "_func_prim"))) 501 | (ConstantOperand (Const.Int 64 3)) 502 | [] 503 | , Name (vn ++ "_func_addr1") := 504 | IntToPtr (LocalReference int (Name (vn ++ "_func_addr"))) intptr [] 505 | , Name (vn ++ "_func") := 506 | BitCast (LocalReference intptr (Name (vn ++ "_func_addr1"))) intintfunc [] 507 | , Name (vn ++ "_eval") := 508 | Call 509 | { tailCallKind = Nothing 510 | , callingConvention = C 511 | , returnAttributes = [] 512 | , function = Right $ LocalReference intintfunc (Name (vn ++ "_func")) 513 | , arguments = [(LocalReference int (Name v), [])] 514 | , functionAttributes = [] 515 | , metadata = [] 516 | } 517 | , replaceThunk v (vn ++ "_eval") 518 | ] 519 | (Do $ Br (Name ("upd" ++ show i)) []) 520 | , BasicBlock 521 | (Name ("upd" ++ show i)) 522 | [ Name (v ++ "__updated") := 523 | Phi 524 | int 525 | [ (LocalReference int (Name v), Name entrylabel) 526 | , (LocalReference int (Name (vn ++ "_hd")), Name ("fetch" ++ show i)) 527 | , (LocalReference int (Name (vn ++ "_eval")), Name ("eval" ++ show i)) 528 | ] 529 | [] 530 | ] 531 | (Do $ Br (Name exitlabel) []) 532 | ] 533 | 534 | trOp :: STG.PrimOp -> Operand -> Operand -> Instruction 535 | trOp STG.Add = \x y -> Add False False x y [] 536 | trOp STG.Sub = \x y -> Sub False False x y [] 537 | trOp STG.Mul = \x y -> Sub False False x y [] 538 | trOp STG.Div = \x y -> SDiv False x y [] 539 | trOp STG.Mod = \x y -> SRem x y [] 540 | trOp _ = error "Error: Primitive function not supported" 541 | 542 | trProgram :: STG.Program -> [Definition] 543 | trProgram (STG.Program (STG.Binds m)) = trMain : map (uncurry trTopBind) (M.assocs m) 544 | 545 | trMain :: Definition 546 | trMain = 547 | GlobalDefinition 548 | functionDefaults 549 | {Gbl.name = Name "main", Gbl.returnType = int, Gbl.alignment = 8, Gbl.basicBlocks = [body]} 550 | where 551 | body = 552 | BasicBlock 553 | (Name "entry") 554 | [ Name "ptr" := Alloca int Nothing 8 [] 555 | , Name "addr" := PtrToInt (LocalReference intptr (Name "ptr")) int [] 556 | , Name "a" := 557 | BitCast (ConstantOperand $ Const.GlobalReference intintfunc (Name "__main")) intptr [] 558 | , Name "callee_cast" := PtrToInt (LocalReference intptr (Name "a")) int [] 559 | , Name "thunk" := 560 | Add 561 | False 562 | False 563 | (LocalReference int (Name "callee_cast")) 564 | (ConstantOperand (Const.Int 64 1)) 565 | [] 566 | , Do 567 | Store 568 | { volatile = False 569 | , address = LocalReference intptr (Name "ptr") 570 | , value = LocalReference int (Name "thunk") 571 | , maybeAtomicity = Nothing 572 | , alignment = 8 573 | , metadata = [] 574 | } 575 | , Name "val" := 576 | Call 577 | { tailCallKind = Nothing 578 | , callingConvention = C 579 | , returnAttributes = [] 580 | , function = Right (ConstantOperand $ Const.GlobalReference intintfunc (Name "__main")) 581 | , arguments = [(LocalReference int (Name "addr"), [])] 582 | , functionAttributes = [] 583 | , metadata = [] 584 | } 585 | , Name "retval" := 586 | LShr False (LocalReference int (Name "val")) (ConstantOperand (Const.Int 64 3)) [] 587 | ] 588 | (Do $ Ret (Just (LocalReference int (Name "retval"))) []) 589 | 590 | -- | declare the malloc function 591 | declMalloc :: Definition 592 | declMalloc = 593 | GlobalDefinition 594 | functionDefaults 595 | { Gbl.returnType = int 596 | , Gbl.name = Name "malloc" 597 | , Gbl.parameters = ([Parameter int (Name "ptr") []], False) 598 | , Gbl.alignment = 8 599 | } 600 | -------------------------------------------------------------------------------- /src/Compiler/Util.hs: -------------------------------------------------------------------------------- 1 | module Compiler.Util where 2 | 3 | import Data.Char 4 | import LLVM.AST 5 | import LLVM.AST.AddrSpace 6 | import qualified Language.MiniStg as STG 7 | 8 | int :: Type 9 | int = IntegerType 64 10 | 11 | intptr :: Type 12 | intptr = PointerType int (AddrSpace 0) 13 | 14 | intintfunc :: Type 15 | intintfunc = FunctionType int [int] False 16 | 17 | intintfptr :: Type 18 | intintfptr = PointerType intintfunc (AddrSpace 0) 19 | 20 | -- | referer tag, refer to an evaled value 21 | -- either a direct literal or an indirect construction 22 | evalLitTag :: Integer 23 | evalLitTag = 0 24 | 25 | -- | referer tag, refer to an evaled construction (directly) 26 | evalConTag :: Integer 27 | evalConTag = 2 28 | 29 | -- | referer tag, refer to an unevaled primitive expression 30 | unevalPrimTag :: Integer 31 | unevalPrimTag = 1 32 | 33 | -- | referer tag, refer to an unevaled function application 34 | unevalFuncTag :: Integer 35 | unevalFuncTag = 3 36 | 37 | -- | referee tag, it's unvaluated, either 38 | -- a function application or a primitive operation. 39 | funcTag :: Integer 40 | funcTag = 1 41 | 42 | -- | referee tag, it's an evaluated literal 43 | litTag :: Integer 44 | litTag = 0 45 | 46 | -- | referee tag, it's an indirect construction pointer 47 | indTag :: Integer 48 | indTag = 2 49 | 50 | -- | encode characters into numbers 51 | encChar :: Char -> Integer 52 | encChar c 53 | | '0' <= c && c <= '9' = fromIntegral $ ord c - ord '0' 54 | encChar c 55 | | 'A' <= c && c <= 'Z' = fromIntegral $ ord c - ord 'A' + 10 56 | encChar c 57 | | 'a' <= c && c <= 'z' = fromIntegral $ ord c - ord 'a' + 36 58 | encChar '_' = 62 59 | encChar '#' = 63 60 | encChar _ = error "Syntax Error: Invalid character" 61 | 62 | -- | encode operations into numbers 63 | encOp :: STG.PrimOp -> Integer 64 | encOp p = 65 | case p of 66 | STG.Add -> 0 67 | STG.Sub -> 1 68 | STG.Mul -> 2 69 | STG.Div -> 3 70 | STG.Mod -> 4 71 | _ -> error "Error: primitive function not supported" 72 | 73 | -- | decode operations from numbers 74 | decOp :: Integer -> STG.PrimOp 75 | decOp n = 76 | case n of 77 | 0 -> STG.Add 78 | 1 -> STG.Sub 79 | 2 -> STG.Mul 80 | 3 -> STG.Div 81 | 4 -> STG.Mod 82 | _ -> error "Error: primitive function not supported" 83 | 84 | -- | encode a constructor into a number 85 | encConstr :: String -> Integer -> Integer 86 | encConstr s l = foldr (\ch i -> encChar ch + i * 64) 0 s * 8 + (fromIntegral l * 2) 87 | -------------------------------------------------------------------------------- /src/Language/MiniStg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | -- | The STG language syntax tree, modeled after the description in the 7 | -- 1992 paper 8 | -- . 9 | -- 10 | -- A 'Program' is typically created using functionality provided by the 11 | -- "Stg.Parser" module, as opposed to manually combining the data types given 12 | -- in this module. 13 | -- 14 | -- For plenty of comparisons of STG language source and generated parse trees, 15 | -- have a look at the "Stg.Parser.QuasiQuoter" module. 16 | module Language.MiniStg ( 17 | Program (..), 18 | Binds (..), 19 | LambdaForm (..), 20 | prettyLambda, 21 | UpdateFlag (..), 22 | Rec (..), 23 | Expr (..), 24 | Alts (..), 25 | NonDefaultAlts (..), 26 | AlgebraicAlt (..), 27 | PrimitiveAlt (..), 28 | DefaultAlt (..), 29 | Literal (..), 30 | PrimOp (..), 31 | Var (..), 32 | Atom (..), 33 | Constr (..), 34 | Pretty (..), 35 | 36 | -- * Meta information 37 | classify, 38 | LambdaType(..), 39 | ) where 40 | 41 | 42 | 43 | import Control.DeepSeq 44 | import Data.List.NonEmpty (NonEmpty (..)) 45 | import qualified Data.List.NonEmpty as NonEmpty 46 | import Data.Map (Map) 47 | import qualified Data.Map as M 48 | import Data.Monoid hiding (Alt) 49 | import qualified Data.Semigroup as Semigroup 50 | import Data.Text (Text) 51 | import qualified Data.Text as T 52 | import GHC.Exts 53 | import GHC.Generics 54 | import Language.Haskell.TH.Lift 55 | import Text.PrettyPrint.ANSI.Leijen hiding ((<>)) 56 | 57 | import Language.MiniStg.Util 58 | 59 | 60 | 61 | -- $setup 62 | -- >>> :set -XQuasiQuotes 63 | -- >>> import Stg.Parser.QuasiQuoter 64 | 65 | 66 | 67 | -- | Package of style definitions used for prettyprinting the STG AST. 68 | data StgAstStyle = StgAstStyle 69 | { keyword :: Doc -> Doc 70 | -- ^ Keyword style 71 | , prim :: Doc -> Doc 72 | -- ^ Primitive style, for literals and functions 73 | , variable :: Doc -> Doc 74 | -- ^ Variable style 75 | , constructor :: Doc -> Doc 76 | -- ^ Constructor style 77 | , semicolon :: Doc -> Doc 78 | -- ^ Semicolons separating lists of bindings and alternatives 79 | } 80 | 81 | -- | Colour definitions used by the STG AST. 82 | style :: StgAstStyle 83 | style = StgAstStyle 84 | { keyword = id 85 | , prim = dullgreen 86 | , variable = dullyellow 87 | , constructor = dullmagenta 88 | , semicolon = dullwhite 89 | } 90 | 91 | 92 | 93 | -- | An STG 'Program' is the unit that can be loaded by the STG machine. It 94 | -- consists of a set of bindings. 95 | newtype Program = Program Binds 96 | deriving (Eq, Ord, Show, Generic) 97 | 98 | -- | __Right-biased union__ of the contained bindings. This makes for a poor man's 99 | -- module system by appending multiple, potentially partially incomplete, 100 | -- 'Programs' to each other. 101 | -- 102 | -- @ 103 | -- 'Stg.Prelude.map' <> 'Stg.Prelude.filter' <> ['Stg.Parser.QuasiQuoter.stg'| … actual source … |] 104 | -- @ 105 | instance Monoid Program where 106 | mempty = Program mempty 107 | mappend = (Semigroup.<>) 108 | 109 | instance Semigroup.Semigroup Program where 110 | Program x <> Program y = Program (x <> y) 111 | 112 | -- | Bindings are collections of lambda forms, indexed over variables. 113 | -- 114 | -- They exist at the top level, or as part of a let(rec) binding. 115 | newtype Binds = Binds (Map Var LambdaForm) 116 | deriving (Eq, Ord, Generic) 117 | 118 | -- | __Right-biased__ union. See 'Monoid' 'Program' for further information. 119 | instance Monoid Binds where 120 | mempty = Binds mempty 121 | mappend = (Semigroup.<>) 122 | 123 | instance Semigroup.Semigroup Binds where 124 | Binds x <> Binds y = Binds (x <> y) 125 | 126 | instance Show Binds where 127 | show (Binds binds) = "(Binds " <> show (M.assocs binds) <> ")" 128 | 129 | -- | A lambda form unifies free and bound variables associated with a function 130 | -- body. The lambda body must not be of primitive type, as this would imply 131 | -- the value is both boxed and unboxed. 132 | -- 133 | -- >>> [stg| \(x) y z -> expr x z |] 134 | -- LambdaForm [Var "x"] NoUpdate [Var "y",Var "z"] (AppF (Var "expr") [AtomVar (Var "x"),AtomVar (Var "z")]) 135 | data LambdaForm = LambdaForm ![Var] !UpdateFlag ![Var] !Expr 136 | -- ^ * Free variables (excluding globals) 137 | -- * Update flag 138 | -- * Bound variables 139 | -- * Body 140 | deriving (Eq, Ord, Show, Generic) 141 | 142 | -- | Possible classification of lambda forms. 143 | data LambdaType = 144 | LambdaCon -- ^ Data constructor ('AppC' as body) 145 | | LambdaFun -- ^ Function (lambda with non-empty argument list) 146 | | LambdaThunk -- ^ Thunk (everything else) 147 | deriving (Eq, Ord, Show) 148 | 149 | instance Pretty LambdaType where 150 | pretty = \case 151 | LambdaCon -> "Con" 152 | LambdaFun -> "Fun" 153 | LambdaThunk -> "Thunk" 154 | 155 | -- | Classify the type of a lambda form based on its shape. 156 | classify :: LambdaForm -> LambdaType 157 | classify = \case 158 | LambdaForm _ _ [] AppC{} -> LambdaCon 159 | LambdaForm _ _ (_:_) _ -> LambdaFun 160 | LambdaForm _ _ [] _ -> LambdaThunk 161 | 162 | -- | The update flag distinguishes updatable from non-updatable lambda forms. 163 | data UpdateFlag = 164 | Update -- ^ Overwrite the heap object in-place with its reduced value 165 | -- once available, making recurring access cheap 166 | | NoUpdate -- ^ Don't touch the heap object after evaluation 167 | deriving (Eq, Ord, Show, Generic, Enum, Bounded) 168 | 169 | -- | Distinguishes @let@ from @letrec@. 170 | data Rec = 171 | NonRecursive -- ^ Binings have no access to each other 172 | | Recursive -- ^ Bindings can be given to each other as free variables 173 | deriving (Eq, Ord, Show, Generic, Enum, Bounded) 174 | 175 | -- | An expression in the STG language. 176 | data Expr = 177 | Let !Rec !Binds !Expr -- ^ Let expression @let(rec) ... in ...@ 178 | | Case !Expr !Alts -- ^ Case expression @case ... of ... x -> y@ 179 | | AppF !Var ![Atom] -- ^ Function application @f x y z@ 180 | | AppC !Constr ![Atom] -- ^ Saturated constructor application @Just a@ 181 | | AppP !PrimOp !Atom !Atom -- ^ Primitive function application @+# 1# 2#@ 182 | | LitE !Literal -- ^ Literal expression @1#@ 183 | deriving (Eq, Ord, Show, Generic) 184 | 185 | -- | List of possible alternatives in a 'Case' expression. 186 | -- 187 | -- The list of alts has to be homogeneous. This is not ensured by the type 188 | -- system, and should be handled by the parser instead. 189 | data Alts = Alts !NonDefaultAlts !DefaultAlt 190 | deriving (Eq, Ord, Show, Generic) 191 | 192 | -- | The part of a 'Case' alternative that's not the default. 193 | data NonDefaultAlts = 194 | NoNonDefaultAlts 195 | -- ^ Used in 'case' statements that consist only of a default 196 | -- alternative. These can be useful to force or unpack values. 197 | 198 | | AlgebraicAlts !(NonEmpty AlgebraicAlt) 199 | -- ^ Algebraic alternative, like @Cons x xs@. 200 | 201 | | PrimitiveAlts !(NonEmpty PrimitiveAlt) 202 | -- ^ Primitive alternative, like @1#@. 203 | deriving (Eq, Ord, Show, Generic) 204 | 205 | -- | As in @True | False@ 206 | data AlgebraicAlt = AlgebraicAlt !Constr ![Var] !Expr 207 | deriving (Eq, Ord, Show, Generic) 208 | 209 | -- | As in @1#@, @2#@, @3#@ 210 | data PrimitiveAlt = PrimitiveAlt !Literal !Expr 211 | deriving (Eq, Ord, Show, Generic) 212 | 213 | -- | If no viable alternative is found in a pattern match, use a 'DefaultAlt' 214 | -- as fallback. 215 | data DefaultAlt = 216 | DefaultNotBound !Expr 217 | | DefaultBound !Var !Expr 218 | deriving (Eq, Ord, Show, Generic) 219 | 220 | -- | Literals are the basis of primitive operations. 221 | newtype Literal = Literal Integer 222 | deriving (Eq, Ord, Show, Generic) 223 | 224 | -- | Primitive operations. 225 | data PrimOp = 226 | Add -- ^ @+@ 227 | | Sub -- ^ @-@ 228 | | Mul -- ^ @*@ 229 | | Div -- ^ @/@ 230 | | Mod -- ^ @%@ 231 | | Eq -- ^ @==@ 232 | | Lt -- ^ @<@ 233 | | Leq -- ^ @<=@ 234 | | Gt -- ^ @>@ 235 | | Geq -- ^ @>=@ 236 | | Neq -- ^ @/=@ 237 | deriving (Eq, Ord, Show, Generic, Bounded, Enum) 238 | 239 | -- | Variable. 240 | newtype Var = Var Text 241 | deriving (Eq, Ord, Show, Generic) 242 | 243 | instance IsString Var where fromString = coerce . T.pack 244 | 245 | -- | Smallest unit of data. Atoms unify variables and literals, and are what 246 | -- functions take as arguments. 247 | data Atom = 248 | AtomVar !Var 249 | | AtomLit !Literal 250 | deriving (Eq, Ord, Show, Generic) 251 | 252 | -- | Constructors of algebraic data types. 253 | newtype Constr = Constr Text 254 | deriving (Eq, Ord, Show, Generic) 255 | 256 | instance IsString Constr where fromString = coerce . T.pack 257 | 258 | 259 | 260 | -------------------------------------------------------------------------------- 261 | -- Lift instances 262 | deriveLiftMany [ ''Program, ''Literal, ''LambdaForm, ''UpdateFlag, ''Rec 263 | , ''Expr, ''Alts, ''AlgebraicAlt, ''PrimitiveAlt, ''DefaultAlt 264 | , ''PrimOp, ''Atom ] 265 | 266 | instance Lift NonDefaultAlts where 267 | lift NoNonDefaultAlts = [| NoNonDefaultAlts |] 268 | lift (AlgebraicAlts alts) = 269 | [| AlgebraicAlts (NonEmpty.fromList $(lift (toList alts))) |] 270 | lift (PrimitiveAlts alts) = 271 | [| PrimitiveAlts (NonEmpty.fromList $(lift (toList alts))) |] 272 | 273 | instance Lift Binds where 274 | lift (Binds binds) = [| Binds (M.fromList $(lift (M.assocs binds))) |] 275 | 276 | instance Lift Constr where 277 | lift (Constr con) = [| Constr (T.pack $(lift (T.unpack con))) |] 278 | 279 | instance Lift Var where 280 | lift (Var var) = [| Var (T.pack $(lift (T.unpack var))) |] 281 | 282 | 283 | 284 | -------------------------------------------------------------------------------- 285 | -- Pretty instances 286 | 287 | semicolonTerminated :: [Doc] -> Doc 288 | semicolonTerminated = align . vsep . punctuate (semicolon style ";") 289 | 290 | instance Pretty Program where 291 | pretty (Program binds) = pretty binds 292 | 293 | instance Pretty Binds where 294 | pretty (Binds bs) = 295 | (semicolonTerminated . map prettyBinding . M.assocs) bs 296 | where 297 | prettyBinding (var, lambda) = 298 | pretty var <+> "=" <+> pretty lambda 299 | 300 | -- | Prettyprint a 'LambdaForm', given prettyprinters for the free variable 301 | -- list. 302 | -- 303 | -- Introduced so 'Stg.Machine.Types.Closure' can hijack it to display 304 | -- the free value list differently. 305 | prettyLambda 306 | :: ([Var] -> Doc) -- ^ Free variable list printer 307 | -> LambdaForm 308 | -> Doc 309 | prettyLambda pprFree (LambdaForm free upd bound expr) = 310 | (prettyExp . prettyUpd . prettyBound . prettyFree) "\\" 311 | where 312 | prettyFree | null free = id 313 | | otherwise = (<> lparen <> pprFree free <> rparen) 314 | prettyUpd = (<+> case upd of Update -> "=>" 315 | NoUpdate -> "->" ) 316 | prettyBound | null bound = id 317 | | null free = (<> prettyList bound) 318 | | otherwise = (<+> prettyList bound) 319 | prettyExp = (<+> pretty expr) 320 | 321 | instance Pretty LambdaForm where 322 | pretty = prettyLambda prettyList 323 | 324 | instance Pretty Rec where 325 | pretty = \case 326 | NonRecursive -> "" 327 | Recursive -> "rec" 328 | 329 | instance Pretty Expr where 330 | pretty = \case 331 | Let rec binds expr -> 332 | let inBlock = indent 4 (keyword style "in" <+> pretty expr) 333 | bindingBlock = line <> indent 4 ( 334 | keyword style ("let" <> pretty rec) <+> pretty binds ) 335 | in vsep [bindingBlock, inBlock] 336 | 337 | Case expr alts -> vsep [ hsep [ keyword style "case" 338 | , pretty expr 339 | , keyword style "of" ] 340 | , indent 4 (align (pretty alts)) ] 341 | 342 | AppF var [] -> pretty var 343 | AppF var args -> pretty var <+> prettyList args 344 | 345 | AppC con [] -> pretty con 346 | AppC con args -> pretty con <+> prettyList args 347 | 348 | AppP op arg1 arg2 -> pretty op <+> pretty arg1 <+> pretty arg2 349 | 350 | LitE lit -> pretty lit 351 | 352 | instance Pretty Alts where 353 | pretty (Alts NoNonDefaultAlts def) = pretty def 354 | pretty (Alts (AlgebraicAlts alts) def) = 355 | semicolonTerminated (map pretty (toList alts) <> [pretty def]) 356 | pretty (Alts (PrimitiveAlts alts) def) = 357 | semicolonTerminated (map pretty (toList alts) <> [pretty def]) 358 | 359 | instance Pretty AlgebraicAlt where 360 | pretty (AlgebraicAlt con [] expr) 361 | = pretty con <+> "->" <+> pretty expr 362 | pretty (AlgebraicAlt con args expr) 363 | = pretty con <+> prettyList args <+> "->" <+> pretty expr 364 | 365 | instance Pretty PrimitiveAlt where 366 | pretty (PrimitiveAlt lit expr) = 367 | pretty lit <+> "->" <+> pretty expr 368 | 369 | instance Pretty DefaultAlt where 370 | pretty = \case 371 | DefaultNotBound expr -> "default" <+> "->" <+> pretty expr 372 | DefaultBound var expr -> pretty var <+> "->" <+> pretty expr 373 | 374 | instance Pretty Literal where 375 | pretty (Literal i) = prim style (integer i <> "#") 376 | 377 | instance Pretty PrimOp where 378 | pretty op = prim style (case op of 379 | Add -> "+#" 380 | Sub -> "-#" 381 | Mul -> "*#" 382 | Div -> "/#" 383 | Mod -> "%#" 384 | Eq -> "==#" 385 | Lt -> "<#" 386 | Leq -> "<=#" 387 | Gt -> ">#" 388 | Geq -> ">=#" 389 | Neq -> "/=#" ) 390 | 391 | instance Pretty Var where 392 | pretty (Var name) = variable style (string (T.unpack name)) 393 | prettyList = spaceSep 394 | 395 | instance Pretty Atom where 396 | pretty = \case 397 | AtomVar var -> pretty var 398 | AtomLit lit -> pretty lit 399 | prettyList = spaceSep 400 | 401 | instance Pretty Constr where 402 | pretty (Constr name) = constructor style (string (T.unpack name)) 403 | 404 | instance NFData Program 405 | instance NFData Binds 406 | instance NFData LambdaForm 407 | instance NFData UpdateFlag 408 | instance NFData Rec 409 | instance NFData Expr 410 | instance NFData Alts 411 | instance NFData NonDefaultAlts 412 | instance NFData AlgebraicAlt 413 | instance NFData PrimitiveAlt 414 | instance NFData DefaultAlt 415 | instance NFData Literal 416 | instance NFData PrimOp 417 | instance NFData Var 418 | instance NFData Atom 419 | instance NFData Constr 420 | -------------------------------------------------------------------------------- /src/Language/MiniStg/Lexer.x: -------------------------------------------------------------------------------- 1 | { 2 | module Language.MiniStg.Lexer 3 | ( lexStg 4 | , StgToken(..) 5 | ) where 6 | 7 | import Data.Text (Text) 8 | import qualified Data.Text as T 9 | } 10 | 11 | %wrapper "basic" 12 | 13 | $digit = 0-9 14 | $alpha = [a-zA-Z] 15 | $upper = A-Z 16 | $lower = a-z 17 | 18 | tokens :- 19 | 20 | $white+ ; 21 | "--".* ; 22 | \= { \_ -> T_Bind } 23 | \; { \_ -> T_Semicolon } 24 | "->" { \_ -> T_To } 25 | \\ { \s -> T_Pi } 26 | let { \_ -> T_Let } 27 | letrec { \_ -> T_Letrec } 28 | in { \_ -> T_In } 29 | case { \_ -> T_Case } 30 | of { \_ -> T_Of } 31 | $digit+"#" { \s -> T_UnboxedInteger (read . init $ s) } 32 | "+#" { \_ -> T_Add } 33 | "-#" { \_ -> T_Sub } 34 | "*#" { \_ -> T_Mul } 35 | "/#" { \_ -> T_Div } 36 | "%#" { \_ -> T_Mod } 37 | "<#" { \_ -> T_Lt } 38 | "<=#" { \_ -> T_Leq } 39 | "==#" { \_ -> T_Eq } 40 | "/=#" { \_ -> T_Neq } 41 | ">=#" { \_ -> T_Gt } 42 | ">#" { \_ -> T_Gt } 43 | default { \_ -> T_Default } 44 | [$lower \_][$alpha $digit \_ \']* { \s -> T_VarId $ T.pack s } 45 | $upper[$alpha $digit \_]*\#? { \s -> T_ConstrId $ T.pack s } 46 | 47 | { 48 | 49 | -- | The token type 50 | data StgToken 51 | = T_Bind 52 | | T_Semicolon 53 | | T_To 54 | | T_Pi 55 | | T_Let 56 | | T_Letrec 57 | | T_In 58 | | T_Case 59 | | T_Of 60 | | T_UnboxedInteger Integer 61 | | T_Add 62 | | T_Sub 63 | | T_Mul 64 | | T_Div 65 | | T_Mod 66 | | T_Lt 67 | | T_Leq 68 | | T_Eq 69 | | T_Neq 70 | | T_Geq 71 | | T_Gt 72 | | T_Default 73 | | T_VarId Text 74 | | T_ConstrId Text 75 | deriving (Show, Eq) 76 | 77 | -- | The lexer of STG 78 | lexStg :: String -> [StgToken] 79 | lexStg = alexScanTokens 80 | } 81 | -------------------------------------------------------------------------------- /src/Language/MiniStg/Parser.y: -------------------------------------------------------------------------------- 1 | { 2 | module Language.MiniStg.Parser 3 | ( parseStg 4 | ) where 5 | 6 | import Language.MiniStg.Lexer (lexStg, StgToken (..)) 7 | import Language.MiniStg 8 | 9 | import Data.Map.Strict (Map) 10 | import qualified Data.Map.Strict as M 11 | import Data.List.NonEmpty (NonEmpty (..)) 12 | import qualified Data.List.NonEmpty as NE 13 | import Data.Text (Text) 14 | import qualified Data.Text as T 15 | 16 | } 17 | 18 | %name parseStgToken prog 19 | %tokentype { StgToken } 20 | %error { parseError } 21 | 22 | %token 23 | '=' { T_Bind } 24 | ';' { T_Semicolon } 25 | to { T_To } 26 | pi { T_Pi } 27 | let { T_Let } 28 | letrec { T_Letrec } 29 | in { T_In } 30 | case { T_Case } 31 | of { T_Of } 32 | integer { T_UnboxedInteger $$ } 33 | add { T_Add } 34 | sub { T_Sub } 35 | mul { T_Mul } 36 | div { T_Div } 37 | mod { T_Mod } 38 | lt { T_Lt } 39 | leq { T_Leq } 40 | eq { T_Eq } 41 | neq { T_Neq } 42 | geq { T_Geq } 43 | gt { T_Gt } 44 | varid { T_VarId $$ } 45 | constrid { T_ConstrId $$ } 46 | default { T_Default } 47 | 48 | %% 49 | 50 | prog :: { Program } 51 | : binds { Program (Binds $1) } 52 | 53 | binds :: { Map Var LambdaForm } 54 | : binds ';' var '=' lf { M.insert $3 $5 $1 } 55 | | var '=' lf { M.singleton $1 $3 } 56 | 57 | lf :: { LambdaForm } 58 | : vars pi vars to expr { LambdaForm $1 Update $3 $5 } 59 | | pi vars to expr { LambdaForm [] Update $2 $4 } 60 | | vars pi to expr { LambdaForm $1 Update [] $4 } 61 | | pi to expr { LambdaForm [] Update [] $3 } 62 | 63 | expr :: { Expr } 64 | : let binds in expr { Let NonRecursive (Binds $2) $4 } 65 | | letrec binds in expr { Let Recursive (Binds $2) $4 } 66 | | case expr of alts { Case $2 $4 } 67 | | var atoms { AppF $1 $2 } 68 | | var { AppF $1 [] } 69 | | constr atoms { AppC $1 $2 } 70 | | constr { AppC $1 [] } 71 | | prim atom atom { AppP $1 $2 $3 } 72 | | literal { LitE $1 } 73 | 74 | alts :: { Alts } 75 | : nondefaultalts defaultalt { Alts $1 $2 } 76 | 77 | nondefaultalts :: { NonDefaultAlts } 78 | : {- empty -} { NoNonDefaultAlts } 79 | | algebraicalts { AlgebraicAlts (NE.reverse $1) } 80 | | primitivealts { PrimitiveAlts (NE.reverse $1) } 81 | 82 | algebraicalts :: { NonEmpty AlgebraicAlt } 83 | : algebraicalts algebraicalt ';' 84 | { NE.cons $2 $1 } 85 | | algebraicalt ';' 86 | { $1 :| [] } 87 | 88 | algebraicalt :: { AlgebraicAlt } 89 | : constr vars to expr { AlgebraicAlt $1 $2 $4 } 90 | 91 | primitivealts :: { NonEmpty PrimitiveAlt } 92 | : primitivealts primitivealt ';' 93 | { NE.cons $2 $1 } 94 | | primitivealt ';' 95 | { $1 :| [] } 96 | 97 | primitivealt :: { PrimitiveAlt } 98 | : literal to expr { PrimitiveAlt $1 $3 } 99 | 100 | defaultalt :: { DefaultAlt } 101 | : default to expr { DefaultNotBound $3 } 102 | | var to expr { DefaultBound $1 $3 } 103 | 104 | literal :: { Literal } 105 | : integer { Literal $1 } 106 | 107 | prim :: { PrimOp } 108 | : add { Add } 109 | | sub { Sub } 110 | | mul { Mul } 111 | | div { Div } 112 | | mod { Mod } 113 | | lt { Lt } 114 | | leq { Leq } 115 | | eq { Eq } 116 | | neq { Neq } 117 | | geq { Geq } 118 | | gt { Gt } 119 | 120 | var :: { Var } 121 | : varid { Var $1 } 122 | 123 | vars :: { [Var] } 124 | : vars var { $1 ++ [$2] } 125 | | var { [$1] } 126 | 127 | atom :: { Atom } 128 | : var { AtomVar $1 } 129 | | literal { AtomLit $1 } 130 | 131 | atoms :: { [Atom] } 132 | : atoms atom { $1 ++ [$2] } 133 | | atom { [$1] } 134 | 135 | constr :: { Constr } 136 | : constrid { Constr $1 } 137 | 138 | { 139 | 140 | parseError :: [StgToken] -> a 141 | parseError _ = error "Parse error" 142 | 143 | -- | The overall STG parser 144 | parseStg :: String -> Program 145 | parseStg = parseStgToken . lexStg 146 | 147 | } 148 | -------------------------------------------------------------------------------- /src/Language/MiniStg/Prettyprint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Prettyprinting STG elements in various formats. 5 | module Language.MiniStg.Prettyprint ( 6 | Pretty(..), 7 | prettyprint, 8 | prettyprintPlain, 9 | ) where 10 | 11 | 12 | 13 | import Data.Text (Text) 14 | import qualified Data.Text as T 15 | import Prelude hiding ((<$>)) 16 | import Text.PrettyPrint.ANSI.Leijen 17 | 18 | 19 | 20 | -- | Prettyprint a value as 'Text', including styles such as colours. 21 | prettyprint :: Pretty a => a -> Text 22 | prettyprint = prettyprintModified id 23 | 24 | -- | Prettyprint a value as 'Text', stripped off all style information such as 25 | -- colours. 26 | prettyprintPlain :: Pretty a => a -> Text 27 | prettyprintPlain = prettyprintModified plain 28 | 29 | prettyprintModified :: Pretty a => (Doc -> Doc) -> a -> Text 30 | prettyprintModified modifier input = 31 | T.pack (displayS (renderPretty 0.4 1000 (modifier (pretty input))) "") 32 | -------------------------------------------------------------------------------- /src/Language/MiniStg/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Useful utilities that don't really fit in a specific location. 4 | module Language.MiniStg.Util ( 5 | show', 6 | Validate(..), 7 | 8 | -- * Prettyprinter extensions 9 | commaSep, 10 | spaceSep, 11 | bulletList, 12 | pluralS, 13 | ) where 14 | 15 | 16 | 17 | import Data.Bifunctor 18 | import Data.Monoid 19 | import Data.String 20 | import Data.Text (Text) 21 | import qualified Data.Text as T 22 | import Text.PrettyPrint.ANSI.Leijen hiding ((<>)) 23 | 24 | 25 | 26 | -- | 'show' with 'Text' as codomain. 27 | -- 28 | -- @ 29 | -- show' = 'T.pack' . 'show' 30 | -- @ 31 | show' :: Show a => a -> Text 32 | show' = T.pack . show 33 | 34 | 35 | 36 | -- | 'Either' with an accumulating 'Applicative' instance 37 | data Validate err a = Failure err | Success a 38 | 39 | instance Functor (Validate a) where 40 | fmap _ (Failure err) = Failure err 41 | fmap f (Success x) = Success (f x) 42 | 43 | instance Bifunctor Validate where 44 | first _ (Success x) = Success x 45 | first f (Failure err) = Failure (f err) 46 | second = fmap 47 | bimap f _ (Failure l) = Failure (f l) 48 | bimap _ g (Success r) = Success (g r) 49 | 50 | -- | Return success or the accumulation of all failures 51 | instance Monoid a => Applicative (Validate a) where 52 | pure = Success 53 | Success f <*> Success x = Success (f x) 54 | Success _ <*> Failure x = Failure x 55 | Failure x <*> Failure y = Failure (x <> y) 56 | Failure x <*> Success _ = Failure x 57 | 58 | -- | @[a,b,c] ==> a, b, c@ 59 | commaSep :: Pretty a => [a] -> Doc 60 | commaSep = encloseSep mempty mempty (comma <> space) . map pretty 61 | 62 | -- | @[a,b,c] ==> a b c@ 63 | spaceSep :: Pretty a => [a] -> Doc 64 | spaceSep = hsep . map pretty 65 | 66 | -- | Prefix all contained documents with a bullet symbol. 67 | bulletList :: Pretty a => [a] -> Doc 68 | bulletList = align . vsep . map ((" - " <>) . align . pretty) 69 | 70 | -- | Add an \'s' for non-singleton lists. 71 | pluralS :: IsString string => [a] -> string 72 | pluralS [_] = "" 73 | pluralS _ = "s" 74 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | packages: 4 | - '.' 5 | extra-deps: 6 | - llvm-hs-4.0.1.0 7 | resolver: lts-8.15 8 | --------------------------------------------------------------------------------