├── .gitignore ├── LICENSE ├── Main ├── README.md ├── Setup.hs ├── app └── Main.hs ├── generate-haddocks.sh ├── set_llvm_paths.source ├── simplexhc.cabal ├── src ├── ColorUtils.hs ├── IR.hs ├── IRBuilder.hs ├── IRToLLVM.hs ├── OrderedMap.hs ├── Stg.hs ├── StgEvalApplyMachine.hs ├── StgLanguage.hs ├── StgParser.hs ├── StgPushEnterMachine.hs └── StgToIR.hs ├── stack.yaml ├── stg-programs ├── case-constructor.stg ├── case-raw-number.stg ├── id.stg ├── let.stg ├── only-combinators.stg ├── partial-application.stg ├── plus.stg ├── s-k-k-3.stg ├── updatable-constructor.stg └── updatable-fn-calls.stg └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | 22 | *swp 23 | .*.swp 24 | tags* 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Siddharth Bhat 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 | -------------------------------------------------------------------------------- /Main: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bollu/simplexhc/fd210f3455cb41541ebf7ccedef9382e506e6991/Main -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Simplexhc 2 | 3 | ## Note: this codebase is now being developed in C++: [simplexhc-cpp](https://github.com/bollu/simplexhc-cpp). 4 | 5 | This is supposed to be a simple compiler for a lazy functional programming language 6 | like haskell Core (hence "hc" = "haskell compiler"). `simplex` so it is vaguely related to polyhedral compilation. 7 | 8 | I am trying to verify if ideas in polyhedral compilation can be used on lazy 9 | programming languages, by trying to go the `Core` -> `STG` -> `LLVM` route. 10 | 11 | Currently, I'm trying to implement a full STG interpreter with eval/apply semantics (not `push/enter`), since that's what GHC uses. 12 | 13 | The `master` head is `push/enter`, since I wanted to understand this first, and then move on to `eval/apply`. 14 | 15 | I wish to model the sum & product types in `STG` as spaces, perhaps modeled with integer polyhedra, so I can reuse the machinery of [`isl`](http://isl.gforge.inria.fr/). This doesn't really work, since isl needs affine maps, and I don't think there's a reasonable interpretation of "affine" that works to analyse parallelism for lazy languages. Some of the ideas are [written down in my repo: `bollu/dependence-analysis-hask`](https://github.com/bollu/dependence-analysis-hask) 16 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | module Main where 5 | 6 | import StgLanguage 7 | import StgParser 8 | import StgPushEnterMachine 9 | import StgToIR 10 | import IRToLLVM 11 | import Stg 12 | -- import StgLLVMBackend 13 | 14 | import System.IO 15 | import System.Environment 16 | import System.Console.Haskeline 17 | import Control.Monad.Trans.Class 18 | import Control.Lens 19 | import Control.Exception 20 | import Control.Monad 21 | import Data.List 22 | import Data.Monoid 23 | import ColorUtils 24 | 25 | import Data.Foldable(for_) 26 | 27 | 28 | import IR 29 | import IRBuilder 30 | 31 | import Options.Applicative 32 | 33 | data CommandLineOptions = CommandLineOptions { 34 | -- | whether this should emit LLVM or not. 35 | emitLLVM :: Bool, 36 | -- | path to input file with STG. 37 | infilepath :: String, 38 | -- | path to output file to write LLVM IR. 39 | moutfilepath :: Maybe String 40 | } 41 | 42 | infilepathopt :: Parser (String) 43 | infilepathopt = strOption (long "input file" <> short 'f' <> metavar "infilepath") 44 | 45 | outfilepathopt :: Parser (Maybe String) 46 | outfilepathopt = option (Just <$> str) (long "output file" <> 47 | short 'o' <> 48 | metavar "outfilepath" <> 49 | value Nothing) 50 | 51 | emitLLVMOpt :: Parser Bool 52 | emitLLVMOpt = switch (long "emit-llvm") 53 | 54 | commandLineOptionsParser :: Parser CommandLineOptions 55 | commandLineOptionsParser = CommandLineOptions <$> emitLLVMOpt <*> infilepathopt <*> outfilepathopt 56 | 57 | commandLineOptionsParserInfo :: ParserInfo CommandLineOptions 58 | commandLineOptionsParserInfo = info commandLineOptionsParser infomod where 59 | infomod = fullDesc <> progDesc "STG -> LLVM compiler" <> header "simplexhc" 60 | 61 | repl :: InputT IO () 62 | repl = do 63 | lift . putStrLn $ "\n" 64 | line <- getInputLine ">" 65 | case line of 66 | Nothing -> repl 67 | Just (l) -> do 68 | lift . compileAndRun $ l 69 | repl 70 | 71 | where 72 | compileAndRun :: String -> IO () 73 | compileAndRun line = do 74 | 75 | putStrLn "interp: " 76 | let mInitState = tryCompileString line 77 | let mTrace = fmap genMachineTrace mInitState 78 | case mTrace of 79 | (Left err) -> putStrLn err 80 | (Right trace) -> putStr . getTraceString $ trace 81 | 82 | getTraceString :: ([PushEnterMachineState], Maybe StgError) -> String 83 | getTraceString (trace, mErr) = 84 | traceStr ++ "\n\n\nFinal:\n==================================\n" ++ errStr where 85 | errStr = case mErr of 86 | Nothing -> "Success" 87 | Just err -> show err ++ machineFinalStateLogStr 88 | traceStr = intercalate "\n\n==================================\n\n" (fmap show trace) 89 | machineFinalStateLogStr = if length trace == 0 then "" else "\nlog:\n====\n" ++ show ((last trace) ^. currentLog) 90 | 91 | runFileInterp :: String -> IO () 92 | runFileInterp ipath = do 93 | raw <- Prelude.readFile ipath 94 | let mInitState = tryCompileString raw 95 | let trace = fmap genMachineTrace mInitState 96 | case trace of 97 | (Left compileErr) -> do 98 | putStrLn "compile error: " 99 | putStrLn $ compileErr 100 | (Right trace) -> putStr . getTraceString $ trace 101 | 102 | runFileLLVM :: String -- ^Input file path 103 | -> Maybe String -- ^Output file path 104 | -> IO () 105 | runFileLLVM ipath mopath = do 106 | raw <- Prelude.readFile ipath 107 | let mParse = parseString raw 108 | case mParse of 109 | (Left compileErr) -> do 110 | putStrLn "compile error: " 111 | putStrLn $ compileErr 112 | (Right program) -> do 113 | putStrLn "LLVM module: " 114 | putStrLn "*** Internal IR :" 115 | let module' = programToModule program 116 | putStrLn . prettyToString $ module' 117 | putStrLn "*** LLVM IR :" 118 | str <- moduleToLLVMIRString module' 119 | putStr str 120 | for_ mopath (\opath -> writeModuleLLVMIRStringToFile module' opath) 121 | -- Input 122 | main :: IO () 123 | main = do 124 | opts <- execParser commandLineOptionsParserInfo 125 | if infilepath opts == "" 126 | then runInputT defaultSettings repl 127 | else if emitLLVM opts == False 128 | then runFileInterp (infilepath opts) 129 | else runFileLLVM (infilepath opts) (moutfilepath opts) 130 | -------------------------------------------------------------------------------- /generate-haddocks.sh: -------------------------------------------------------------------------------- 1 | # Script configured for my computer. 2 | set -o xtrace 3 | set -e 4 | 5 | stack haddock --no-haddock-deps 6 | mv $(stack path --local-doc-root) ./docs 7 | 8 | git add docs/ 9 | git commit -m "docs update on: $(date)" 10 | git push origin master:docs 11 | -------------------------------------------------------------------------------- /set_llvm_paths.source: -------------------------------------------------------------------------------- 1 | # source this file to setup paths correctly 2 | 3 | export LLVM_40_PATH=/Users/bollu/work/LLVM-all/polly/llvm_40_build 4 | 5 | export PATH=$LLVM_40_PATH/bin:$PATH 6 | export DYLD_LIBRARY_PATH=$LLVM_40_PATH/lib:$DYLD_LIBRARY_PATH 7 | 8 | export SIMPLEXHC_LOWERING_ROOT=/Users/bollu/work/simplexhc-llvm-lowering 9 | 10 | export PATH=$SIMPLEXHC_LOWERING_ROOT:$PATH 11 | export DYLD_LIBRARY_PATH=$SIMPLEXHC_LOWERING_ROOT/out:$DYLD_LIBRARY_PATH 12 | -------------------------------------------------------------------------------- /simplexhc.cabal: -------------------------------------------------------------------------------- 1 | name: simplexhc 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/simplexhc#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2017 Author name here 11 | category: Web 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: StgLanguage, 19 | StgParser, 20 | StgPushEnterMachine, 21 | Stg, 22 | ColorUtils, 23 | StgToIR, 24 | IRToLLVM, 25 | IR, 26 | IRBuilder, 27 | OrderedMap 28 | -- LoweringFFI 29 | 30 | build-depends: base >= 4.7 && <= 5, 31 | lens, 32 | transformers, 33 | containers, 34 | parsec, 35 | megaparsec >= 5.2.0, 36 | MissingH, 37 | bytestring, 38 | mtl, 39 | -- for my own use. 40 | prettyprinter, 41 | -- for trifecta 42 | ansi-wl-pprint, 43 | hoist-error, 44 | ansi-terminal, 45 | parsers, 46 | trifecta, 47 | unordered-containers, 48 | llvm-hs >= 4.1.0, 49 | llvm-hs-pure >= 4.1.0, 50 | text 51 | 52 | extra-lib-dirs: /usr/local/lib 53 | -- extra-libraries: lowering 54 | 55 | 56 | default-language: Haskell2010 57 | 58 | executable simplexhc 59 | hs-source-dirs: app 60 | main-is: Main.hs 61 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 62 | build-depends: base 63 | , simplexhc 64 | , lens 65 | , haskeline 66 | , transformers 67 | , ansi-terminal 68 | , bytestring 69 | , optparse-applicative 70 | default-language: Haskell2010 71 | 72 | extra-lib-dirs: /usr/local/lib 73 | -- extra-libraries: lowering 74 | 75 | test-suite simplexhc-test 76 | type: exitcode-stdio-1.0 77 | hs-source-dirs: test 78 | main-is: Spec.hs 79 | 80 | build-depends: base 81 | , simplexhc 82 | , tasty 83 | , tasty-hunit 84 | , lens 85 | , containers 86 | , megaparsec 87 | , directory 88 | install-includes: constructor.stg 89 | , id.stg 90 | , let.stg 91 | , plus.stg 92 | , raw-number-expr.stg 93 | , s-k-k-3.stg 94 | default-language: Haskell2010 95 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 96 | default-language: Haskell2010 97 | 98 | source-repository head 99 | type: git 100 | location: https://github.com/githubuser/simplexhc 101 | -------------------------------------------------------------------------------- /src/ColorUtils.hs: -------------------------------------------------------------------------------- 1 | module ColorUtils where 2 | 3 | import System.Console.ANSI 4 | import Data.Text.Prettyprint.Doc as PP 5 | -- PI = PrettyprinterInternal 6 | import Data.Text.Prettyprint.Doc.Internal as PI 7 | import Data.Text.Prettyprint.Doc.Render.Text as PP 8 | import qualified Data.Text as T 9 | import qualified Data.Text.Lazy as TL 10 | 11 | 12 | mkNest :: Doc a -> Doc a 13 | mkNest = indent 4 14 | 15 | 16 | docToString :: Doc a -> String 17 | docToString doc = TL.unpack (renderLazy (layoutPretty defaultLayoutOptions doc)) 18 | 19 | prettyToString :: Pretty a => a -> String 20 | prettyToString a = docToString (pretty a) 21 | 22 | -- TODO: this is a hack in GHC as well. Do not do this, use the "ann" in Doc 23 | -- to annotate. 24 | zeroWidthText :: String -> Doc a 25 | zeroWidthText s = PI.Text 0 (T.pack s) 26 | 27 | styleAddr :: Doc a 28 | styleAddr = zeroWidthText (setSGRCode [SetColor Foreground Vivid Green, SetUnderlining SingleUnderline]) 29 | 30 | styleTag :: Doc a 31 | -- styleTag = zeroWidthText (setSGRCode [SetUnderlining SingleUnderline]) 32 | styleTag = zeroWidthText (setSGRCode [SetColor Foreground Dull Yellow]) 33 | 34 | 35 | 36 | -- | use for tags on atoms, etc. 37 | mkStyleTag :: Doc a -> Doc a 38 | mkStyleTag tag = styleTag <> tag <> styleReset 39 | 40 | styleHeading :: Doc a 41 | styleHeading = zeroWidthText (setSGRCode [SetColor Foreground Vivid Blue]) 42 | 43 | styleReset :: Doc a 44 | styleReset = zeroWidthText (setSGRCode [Reset]) 45 | 46 | heading :: Doc a -> Doc a 47 | heading d = styleHeading PP.<> d PP.<> styleReset 48 | 49 | styleError :: Doc a 50 | styleError = zeroWidthText (setSGRCode [SetColor Foreground Vivid Red]) 51 | 52 | -- | use to style errors 53 | mkStyleError :: Doc a -> Doc a 54 | mkStyleError doc = styleError <> doc <> styleReset 55 | 56 | styleAnnotation :: Doc a 57 | styleAnnotation = zeroWidthText (setSGRCode [SetColor Foreground Vivid White]) 58 | 59 | -- | use to style simplexhc annotations that are not part of the source language. 60 | -- | For example, used to number stack arguments 61 | mkStyleAnnotation :: Doc a -> Doc a 62 | mkStyleAnnotation n = styleAnnotation <> n <> styleReset 63 | -------------------------------------------------------------------------------- /src/IR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, RecordWildCards #-} 2 | module IR where 3 | import Data.Text.Prettyprint.Doc as PP 4 | import qualified Data.List.NonEmpty as NE 5 | import qualified OrderedMap as M 6 | 7 | 8 | -- | A phantom type used to refer to function parameter labels 9 | data Param 10 | 11 | -- | Types that IR values can have 12 | data IRType = IRTypeInt Int | -- ^ number of bits 13 | IRTypeVoid | 14 | IRTypePointer IRType | 15 | IRTypeFunction [IRType] IRType | 16 | IRTypeStruct [IRType] deriving(Eq) 17 | 18 | -- | The type of something that points to a block of memory from, say, malloc. 19 | -- | consider this as void*. 20 | irTypeMemoryPtr :: IRType 21 | irTypeMemoryPtr = IRTypePointer (IRTypeInt 8) 22 | 23 | -- | The type of a 32 bit integer. Handy alias to have. 24 | irTypeInt32 :: IRType 25 | irTypeInt32 = IRTypeInt 32 26 | 27 | -- | The type of a boolean. 28 | irTypeBool :: IRType 29 | irTypeBool = IRTypeInt 1 30 | 31 | instance Pretty IRType where 32 | pretty (IRTypeInt i) = pretty "int" <+> pretty i 33 | pretty IRTypeVoid = pretty "void" 34 | pretty (IRTypePointer ty) = hcat [parens (pretty ty), pretty "^"] 35 | pretty (IRTypeFunction params ret) = 36 | parens (hcat . punctuate comma $ pparams) <+> pretty "->" <+> pretty ret where 37 | pparams = map pretty params 38 | pretty (IRTypeStruct tys) = pretty "struct" <+> 39 | parens (hcat (punctuate comma (map pretty tys))) 40 | 41 | -- | A label that uses the phantom @a as a type based discriminator 42 | data Label a = Label { unLabel :: String } deriving(Eq, Ord) 43 | instance Pretty (Label a) where 44 | pretty (Label s) = pretty s 45 | 46 | -- a Value which can be passed as an operand to an instruction 47 | data Value = ValueConstInt Int 48 | | ValueInstRef (Label Inst) 49 | | ValueParamRef (Label Param) 50 | | ValueFnPointer (Label Function) 51 | | ValueGlobalRef (Label GlobalValue) 52 | | ValueSizeOf(IRType) 53 | | ValueUndef (IRType) -- ^An undef value of any chosen type 54 | 55 | -- a GlobalValue, that is a value of a global variable. 56 | data GlobalValue = GlobalValue { gvType :: IRType, gvValue :: Maybe Value } 57 | type GlobalLabel = Label GlobalValue 58 | 59 | instance Pretty GlobalValue where 60 | pretty (GlobalValue{..}) = pretty "@_" <+> pretty gvValue <+> colon <+> pretty gvType 61 | 62 | instance Pretty Value where 63 | pretty (ValueConstInt i) = pretty i <> pretty "#" 64 | pretty (ValueInstRef name) = pretty "%" <> pretty name 65 | pretty (ValueParamRef name) = pretty "%param." <> pretty name 66 | pretty (ValueFnPointer name) = pretty "@fnptr." <> pretty name 67 | pretty (ValueGlobalRef name) = pretty "@" <> pretty name 68 | pretty (ValueSizeOf name) = pretty "sizeof" <> pretty name 69 | pretty (ValueUndef ty) = parens $ pretty "undef:" <> pretty ty 70 | 71 | -- | Instructions that we allow within a basic block. 72 | data Inst where 73 | InstAdd :: Value -> Value -> Inst 74 | InstMul :: Value -> Value -> Inst 75 | InstL :: Value -> Value -> Inst 76 | InstAnd :: Value -> Value -> Inst 77 | -- | Load a value from a memory location 78 | InstLoad :: Value -> Inst 79 | -- | Store a value 80 | InstStore :: Value -- ^Store location 81 | -> Value -- ^Value to store 82 | -> Inst 83 | -- | GetElementPtr 84 | InstGEP :: Value -- ^Root of GEP 85 | -> [Value] -- ^ Indexing expression 86 | -> Inst 87 | InstPhi :: NE.NonEmpty (BBLabel, Value) -> Inst 88 | -- | Call a function 89 | InstCall :: Value -- ^ Function name 90 | -> [Value] -- ^Parameters 91 | -> Inst 92 | -- | Allocate memory. 93 | InstMalloc :: IRType -- ^type to alloc 94 | -> Inst 95 | 96 | instance Pretty Inst where 97 | pretty (InstAdd l r) = pretty "add" <+> pretty l <+> pretty r 98 | pretty (InstMul l r) = pretty "mul" <+> pretty l <+> pretty r 99 | pretty (InstL l r) = pretty "lessthan" <+> pretty l <+> pretty r 100 | pretty (InstAnd l r) = pretty "and" <+> pretty l <+> pretty r 101 | pretty (InstLoad op) = pretty "load" <+> pretty op 102 | pretty (InstGEP base offsets) = 103 | pretty "gep" <+> 104 | parens(pretty "base:" <+> pretty base) <+> 105 | hcat (map (brackets . pretty) offsets) 106 | 107 | pretty (InstStore slot val) = pretty "store" <+> pretty val <+> 108 | pretty "in" <+> pretty slot 109 | pretty (InstPhi philist) = 110 | hcat (punctuate comma (NE.toList (fmap (\(bbid, val) -> 111 | parens (pretty bbid <+> pretty val)) philist))) 112 | 113 | pretty (InstCall fn params) = 114 | pretty "call" <+> pretty fn <+> 115 | parens (hcat (punctuate comma (map pretty params))) 116 | 117 | pretty (InstMalloc mem) = 118 | pretty "malloc" <+> pretty mem 119 | 120 | -- | Represents @a that is optionally named by a @Label a 121 | data Named a = Named { namedName :: Label a, namedData :: a } | UnNamed { namedData :: a} 122 | 123 | instance Pretty a => Pretty (Named a) where 124 | pretty (Named name data') = pretty name <+> pretty ":=" <+> pretty data' 125 | pretty (UnNamed data') = pretty data' 126 | 127 | 128 | -- | Used to identify basic blocks 129 | -- | Note that these are usually *unique* 130 | type BBLabel = Label BasicBlock 131 | -- | A basic block. Single-entry, multiple-exit. 132 | data BasicBlock = BasicBlock { bbInsts :: [Named Inst], bbRetInst :: RetInst , bbLabel :: Label BasicBlock } 133 | 134 | -- | Default basic block. 135 | defaultBB :: BasicBlock 136 | defaultBB = BasicBlock [] (RetInstVoid) (Label "bbundefined") 137 | 138 | -- TODO: replace nest with indent 139 | instance Pretty BasicBlock where 140 | pretty (BasicBlock insts ret label) = 141 | nest 4 (vsep ([pretty label <> pretty ":"] ++ body)) where 142 | body = map pretty insts ++ [pretty ret] 143 | 144 | 145 | -- | Return instructions are the only ones that can cause control flow 146 | -- | between one basic block to another. 147 | data RetInst = 148 | RetInstConditionalBranch Value BBLabel BBLabel | 149 | RetInstBranch BBLabel | 150 | RetInstSwitch { 151 | switchValue :: Value, 152 | switchDefaultBB :: BBLabel, 153 | switchBBs :: [(Value, BBLabel)] 154 | } | 155 | RetInstReturn Value | 156 | RetInstVoid 157 | 158 | instance Pretty RetInst where 159 | pretty (RetInstVoid) = pretty "ret void" 160 | pretty (RetInstBranch next) = pretty "branch" <+> pretty next 161 | pretty (RetInstConditionalBranch cond then' else') = pretty "branch if" <+> pretty cond <+> pretty "then" <+> pretty then' <+> pretty "else" <+> pretty else' 162 | pretty (RetInstSwitch val default' switches ) = 163 | vcat [pretty "switch on" <+> pretty val <+> 164 | brackets (pretty "default:" <+> pretty default'), 165 | indent 4 (vcat (map pretty switches))] 166 | pretty (RetInstReturn value) = pretty "return" <+> pretty value 167 | 168 | -- | Used to order basic blocks 169 | type BBOrder = Int 170 | 171 | -- | A function is a list of basic blocks and parameters, and return type 172 | data Function = Function { 173 | -- A map from the basic block ID to a basic block. 174 | functionBBMap :: M.OrderedMap BBLabel BasicBlock, 175 | -- The ID of the entry basic block. 176 | functionEntryBBLabel :: BBLabel, 177 | -- The map from a BB to the order. 178 | -- The type of the function ([parameter types], return type) 179 | functionType :: ([IRType], IRType), 180 | -- The parameters names of the function 181 | functionParamLabels :: [Label Param], 182 | -- The label of the function 183 | functionLabel :: FunctionLabel 184 | } 185 | 186 | -- | Label for a function 187 | type FunctionLabel = Label Function 188 | 189 | -- TODO: use view patterns to extract only the values of the dict. 190 | -- | Get the functions in the basic block in the order they were created 191 | getBBFunctionsInOrder :: Function -> [BasicBlock] 192 | getBBFunctionsInOrder Function {functionBBMap=bbIdToBBMap} = M.elems bbIdToBBMap 193 | 194 | instance Pretty Function where 195 | pretty (func@Function{functionType=(paramTypes, returnType),..}) = 196 | vcat [funcheader, indent 4 prettyBBS] where 197 | funcheader :: Doc a 198 | funcheader = pretty "fn" <+> pretty functionLabel <+> parens (params) <+> pretty "->" <+> pretty returnType 199 | formatParam :: IRType -> Label Param -> Doc a 200 | formatParam ty lbl = pretty lbl <+> colon <+> pretty ty 201 | params :: Doc a 202 | params = hsep (punctuate comma (zipWith formatParam paramTypes functionParamLabels)) 203 | prettyBBS :: Doc a 204 | prettyBBS = vcat . map pretty . getBBFunctionsInOrder $ func 205 | 206 | 207 | -- A module consists of stuff that is global 208 | data Module = Module { 209 | moduleFunctions :: [Function], 210 | moduleGlobals :: M.OrderedMap GlobalLabel GlobalValue 211 | } 212 | 213 | instance Pretty Module where 214 | pretty (Module funcs globals) = let 215 | mkGlobalPretty :: (GlobalLabel, GlobalValue) -> Doc a 216 | -- TODO: make GlobalLabel a newtype. 217 | mkGlobalPretty (lbl, GlobalValue{..}) = 218 | mkName lbl <+> colon <+> pretty gvType <+> mkRhs gvValue 219 | -- | Pretty name for the label 220 | mkName :: GlobalLabel -> Doc a 221 | mkName name = hcat [pretty "@", pretty name] 222 | -- | Pretty RHS 223 | mkRhs :: Maybe Value -> Doc a 224 | mkRhs Nothing = mempty 225 | mkRhs (Just v) = pretty ":=" <+> pretty v 226 | in vcat $ (map mkGlobalPretty (M.toList globals)) ++ (map pretty funcs) 227 | 228 | -- Add a function to a module 229 | addFunctionToModule :: Function -> Module -> Module 230 | addFunctionToModule fn mod@Module{..} = mod { moduleFunctions = fn:moduleFunctions } 231 | 232 | 233 | 234 | -------------------------------------------------------------------------------- /src/IRBuilder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module IRBuilder( 4 | FunctionBuilder, 5 | ModuleBuilder, 6 | getCurrentBBLabel, 7 | getEntryBBLabel, 8 | focusBB, 9 | createBB, 10 | getTempInstName_, 11 | appendInst, 12 | (=:=), 13 | setRetInst, getParamValue, 14 | runFunctionBuilder, 15 | createFunction, -- NOT STABILISED 16 | runModuleBuilder, 17 | createGlobalVariable 18 | ) where 19 | import IR 20 | -- import qualified Data.Map.Strict as M 21 | import qualified OrderedMap as M 22 | import Data.Traversable 23 | import Data.Foldable 24 | import Control.Monad.State.Strict 25 | import Control.Exception (assert) 26 | import Data.Foldable (length) 27 | import ColorUtils 28 | 29 | type Literal = String 30 | 31 | -- | Make a key unique for a map by using the function f and a function 32 | -- | that takes the key and an ID that is a bump counter. 33 | makeKeyUnique_ :: Ord k => (k -> Int -> k) -> M.OrderedMap k v -> k -> k 34 | makeKeyUnique_ f m k = unique_ f m 0 k where 35 | unique_ :: Ord k => (k -> Int -> k) -> M.OrderedMap k v -> Int -> k -> k 36 | unique_ f m i k = let uniquekey = f k i in 37 | case M.lookup uniquekey m of 38 | Nothing -> uniquekey 39 | (Just _) -> unique_ f m (i + 1) k 40 | 41 | 42 | appendLabelWithId_ :: Label a -> Int -> Label a 43 | appendLabelWithId_ (Label l) i = if i == 0 44 | then Label l 45 | else Label (l ++ "." ++ show i) 46 | 47 | makeLabelUniqueKey_ :: String -> M.OrderedMap (Label a) v -> Label a 48 | makeLabelUniqueKey_ l m = 49 | makeKeyUnique_ appendLabelWithId_ m (Label l) 50 | 51 | data FunctionBuilder = FunctionBuilder { 52 | -- | The first BB that is present in the module 53 | entryBBLabel :: BBLabel, 54 | -- | The BB the builder is currently focused on 55 | currentBBLabel :: BBLabel, 56 | -- | Mapping from BBLabel to BasicBlock 57 | bbLabelToBB :: M.OrderedMap BBLabel BasicBlock, 58 | -- | counter to generate new instruction name 59 | tmpInstNamesCounter :: Int, 60 | -- | Mapping from BBLabel to the order in which it was created 61 | -- bbLabelToOrder :: M.OrderedMap BBLabel BBOrder, 62 | -- | The type of the function 63 | type' :: ([IRType], IRType), 64 | -- | Map between parameters and their corresponding value 65 | paramLabelToParam :: M.OrderedMap (Label Param) Value, 66 | -- | Unique label of the function 67 | fbFunctionLabel :: FunctionLabel 68 | } 69 | 70 | 71 | _getParamName :: Int -> Label Param 72 | _getParamName i = Label ("param." ++ show i) 73 | 74 | -- | Create a new function builder with an empty basic block 75 | _createFunctionBuilder :: [IRType] -- ^ Parameter types 76 | -> IRType -- ^ Return type 77 | -> FunctionLabel -- ^ Function Name 78 | -> FunctionBuilder 79 | _createFunctionBuilder paramsty retty label = 80 | execState mkDefaultBB initbuilder 81 | where 82 | mkDefaultBB = do 83 | bbid <- createBB "entry" 84 | -- Set the "entry" basic block so we can later give it to IRProgram 85 | modify (\b -> b { entryBBLabel = bbid }) 86 | focusBB bbid 87 | initbuilder = (FunctionBuilder { 88 | entryBBLabel=Label "INVALID BB", 89 | currentBBLabel=Label "INVALID BB", 90 | bbLabelToBB=mempty, 91 | tmpInstNamesCounter=0, 92 | paramLabelToParam=M.fromList $ map (\pname -> (pname, ValueParamRef pname)) pnames, 93 | type'=(paramsty, retty), 94 | fbFunctionLabel=label 95 | 96 | }) where 97 | -- | initial list of parameter names 98 | pnames :: [Label Param] 99 | pnames = map _getParamName [0..(length paramsty)] 100 | 101 | getEntryBBLabel :: State FunctionBuilder BBLabel 102 | getEntryBBLabel = gets entryBBLabel 103 | 104 | -- | Get the current Basic block ID 105 | getCurrentBBLabel :: State FunctionBuilder BBLabel 106 | getCurrentBBLabel = gets currentBBLabel 107 | 108 | -- | Focus the basic block given by the ID 109 | focusBB :: BBLabel -> State FunctionBuilder () 110 | focusBB id = modify (\b-> b { currentBBLabel=id }) 111 | 112 | -- | Append a new basic block. DOES NOT switch the currentBBLabel to the new basic block. For that, see focusBB 113 | createBB :: String -> State FunctionBuilder BBLabel 114 | createBB name = do 115 | idtobbs <- gets bbLabelToBB 116 | let nbbs = M.size idtobbs 117 | let bborder = nbbs -- We can use the number of BBs as a unique stamp on this BB that will 118 | -- provide a total order in terms of time of creation. 119 | let newbbid = makeLabelUniqueKey_ name idtobbs :: BBLabel 120 | let newbb = defaultBB { bbLabel=newbbid } 121 | modify (\b -> b { bbLabelToBB = M.insert newbbid newbb idtobbs }) 122 | return newbbid 123 | 124 | 125 | -- | Create a temporary instruction name. 126 | getTempInstName_ :: State FunctionBuilder (Label Inst) 127 | getTempInstName_ = do 128 | n <- gets tmpInstNamesCounter 129 | modify (\b -> b { tmpInstNamesCounter=n+1 }) 130 | return . Label $ "_." ++ show n 131 | 132 | 133 | {- 134 | -- | Create a temporary name for a return instruction 135 | -- | Note that we cheat in the implementation, by just "relabelling" 136 | -- | an instruction label to a ret instruction label. 137 | getTempRetInstName_ :: State FunctionBuilder (Label RetInst) 138 | getTempRetInstName_ = Label . unLabel <$> getTempInstName_ 139 | -} 140 | 141 | 142 | -- | lift an edit of a basic block to the current basic block focused 143 | -- | in the FunctionBuilder. 144 | liftBBEdit :: (BasicBlock -> BasicBlock) -> FunctionBuilder -> FunctionBuilder 145 | liftBBEdit f fbuilder = fbuilder { 146 | bbLabelToBB = M.adjust f k m 147 | } where 148 | -- The key of the BB to adjust. 149 | k = currentBBLabel fbuilder 150 | -- The map where the BBs live. 151 | m = bbLabelToBB fbuilder 152 | 153 | 154 | -- Append inst I with name to the functionBuilder 155 | (=:=) :: String -> Inst -> State FunctionBuilder Value 156 | name =:= inst = appendNamedInst_ $ Named (Label name) inst 157 | 158 | 159 | -- | Append an Instruction that is not named to the BB 160 | appendInst :: Inst -> State FunctionBuilder () 161 | appendInst i = modify . liftBBEdit $ (appendInstToBB (UnNamed i)) 162 | where 163 | appendInstToBB :: Named Inst -> BasicBlock -> BasicBlock 164 | appendInstToBB i bb = bb { bbInsts=bbInsts bb ++ [i] } 165 | 166 | 167 | -- | Append instruction "I" to the FunctionBuilder 168 | appendNamedInst_ :: Named Inst -> State FunctionBuilder Value 169 | appendNamedInst_ i = do 170 | modify . liftBBEdit $ (appendInstToBB i) 171 | return $ ValueInstRef (namedName i) 172 | where 173 | appendInstToBB :: Named Inst -> BasicBlock -> BasicBlock 174 | appendInstToBB i bb = bb { bbInsts=bbInsts bb ++ [i] } 175 | 176 | setRetInst :: RetInst -> State FunctionBuilder () 177 | setRetInst i = do 178 | modify . liftBBEdit $ (setBBRetInst i) 179 | where 180 | setBBRetInst :: RetInst -> BasicBlock -> BasicBlock 181 | setBBRetInst i bb = bb { bbRetInst=i } 182 | 183 | 184 | -- == Module builder == 185 | 186 | data ModuleBuilder = ModuleBuilder { 187 | mbFunctions :: M.OrderedMap FunctionLabel Function, 188 | mbGlobals :: M.OrderedMap GlobalLabel GlobalValue 189 | } 190 | 191 | _mbAppendFunction :: Label Function -> Function -> ModuleBuilder -> ModuleBuilder 192 | _mbAppendFunction label fn (mb@ModuleBuilder{..}) = 193 | mb { 194 | mbFunctions = M.insert label fn mbFunctions 195 | } 196 | 197 | -- | To create a function definition, first call `createFunction`. 198 | -- | Given a function label and a builder, create it in the `ModuleBuilder`. 199 | runFunctionBuilder :: Value -> State FunctionBuilder () -> State ModuleBuilder () 200 | runFunctionBuilder (ValueFnPointer label) fs = do 201 | -- Get the stub function that was created from createFunction 202 | origfn <- gets $ (M.! label) . mbFunctions 203 | let (ptys, retty) = functionType origfn 204 | let finalbuilder = execState fs (_createFunctionBuilder ptys retty label) 205 | 206 | let fn = _createFunctionFromBuilder finalbuilder 207 | modify (_mbAppendFunction label fn) 208 | 209 | runFunctionBuilder v _ = 210 | error $ "called runFunctionBuilder, provided non-function value: " ++ 211 | prettyToString v 212 | 213 | -- | Create a new function . This is more fine grained that runFunctionBuilder. 214 | createFunction :: [IRType] -> IRType -> String -> State ModuleBuilder Value 215 | createFunction ptys retty name = do 216 | label <- gets (makeLabelUniqueKey_ name . mbFunctions) 217 | let defaultfn = _createFunctionFromBuilder (_createFunctionBuilder ptys retty label) 218 | modify (_mbAppendFunction label defaultfn) 219 | return $ ValueFnPointer label 220 | 221 | 222 | 223 | -- | Run a module builder to create a module 224 | runModuleBuilder :: State ModuleBuilder () -> Module 225 | runModuleBuilder s = let final = execState s _createModuleBuilder in 226 | _createModuleFromBuilder final 227 | 228 | 229 | -- | Create an IR.Module from a ModuleBuilder 230 | _createModuleFromBuilder :: ModuleBuilder -> Module 231 | _createModuleFromBuilder ModuleBuilder{..} = 232 | Module (M.elems mbFunctions) mbGlobals 233 | 234 | -- | Default module builder 235 | _createModuleBuilder :: ModuleBuilder 236 | _createModuleBuilder = 237 | ModuleBuilder { 238 | mbFunctions=mempty, 239 | mbGlobals=mempty 240 | } 241 | 242 | 243 | -- | Create an IR.function from a FunctionBuilder 244 | _createFunctionFromBuilder :: FunctionBuilder -> IR.Function 245 | _createFunctionFromBuilder FunctionBuilder{..} = 246 | Function { 247 | functionBBMap=bbLabelToBB, 248 | functionEntryBBLabel=entryBBLabel, 249 | functionType=type', 250 | functionLabel=fbFunctionLabel, 251 | functionParamLabels=map _getParamName [0..(length paramLabelToParam)] 252 | } 253 | 254 | -- | Get the i'th parameter in the function. 0-indexed 255 | getParamValue :: Int -> State FunctionBuilder Value 256 | getParamValue i = do 257 | params' <- gets paramLabelToParam 258 | return (assert (i < length params' && i >= 0) (params' M.! (_getParamName i))) 259 | 260 | -- | Create an IR.GlobalVariable with the given name 261 | createGlobalVariable :: String -> IRType -> State ModuleBuilder Value 262 | createGlobalVariable name ty = do 263 | mglobals <- gets mbGlobals 264 | let label = makeLabelUniqueKey_ name mglobals 265 | let global = GlobalValue { gvType=ty, gvValue = Nothing } 266 | modify (\mb -> mb { mbGlobals=M.insert label global mglobals}) 267 | return $ ValueGlobalRef label 268 | -------------------------------------------------------------------------------- /src/IRToLLVM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | module IRToLLVM where 4 | 5 | -- | L = pure llvm-hs-pure imports 6 | import qualified LLVM.AST as L 7 | import qualified LLVM.AST.Global as L 8 | import qualified LLVM.AST.Constant as LC 9 | -- | RealL = "real world", not haskell pure types 10 | import qualified LLVM.Module as RealL 11 | import qualified LLVM.Context as RealL 12 | import qualified LLVM.AST.CallingConvention as L 13 | 14 | -- | We need this because type' is both in LLVM.AST and LLVM.AST.Global 15 | import qualified LLVM.AST.Global 16 | import qualified LLVM.AST.Attribute as L 17 | import qualified LLVM.AST.Type as L 18 | 19 | import Data.List(findIndex) 20 | 21 | import qualified Data.ByteString.Char8 as C8 (pack) 22 | import qualified Data.ByteString as B 23 | import qualified Data.ByteString.Short as B 24 | (ShortByteString, toShort, fromShort) 25 | import Data.Char (chr) 26 | import Data.Text.Prettyprint.Doc as PP 27 | import ColorUtils 28 | import qualified Data.Word as W 29 | import qualified OrderedMap as M 30 | 31 | import Debug.Trace 32 | 33 | import IRBuilder 34 | import IR 35 | 36 | mapToList :: (Ord k, Pretty k, Pretty v) => (k -> v -> a) -> M.OrderedMap k v -> [a] 37 | mapToList f m = map (uncurry f) (M.toList m) 38 | 39 | data Context = Context { 40 | globalNameToType :: M.OrderedMap GlobalLabel IRType, 41 | functionNameToType :: M.OrderedMap FunctionLabel IRType, 42 | instNameToType :: M.OrderedMap (Label Inst) IRType, 43 | currentFunction :: Maybe Function 44 | } 45 | 46 | -- | Build the Context for the given Module 47 | _buildContextForModule :: Module -> Context 48 | _buildContextForModule (Module{..}) = Context { 49 | globalNameToType=fmap globalToType moduleGlobals, 50 | functionNameToType=M.fromList [(functionLabel f, functionToType f) | f <- moduleFunctions], 51 | instNameToType=mempty, 52 | currentFunction = Nothing 53 | } where 54 | functionToType :: Function -> IRType 55 | functionToType Function{functionType=(paramsty, retty)} = IRTypeFunction paramsty retty 56 | 57 | globalToType :: GlobalValue -> IRType 58 | globalToType = gvType 59 | 60 | 61 | -- | Given the map between instruction names to instructions, 62 | -- | Given an instruction, construct its type. 63 | constructInstType :: Context -> M.OrderedMap (Label Inst) Inst -> Inst -> IRType 64 | constructInstType ctx _ (InstAdd a b) = 65 | if (_constructValueType ctx a) == (_constructValueType ctx b) 66 | then (_constructValueType ctx a) 67 | else error . docToString $ pretty "add has params of two different types:" <+> pretty a <+> pretty "|" <+> pretty b 68 | constructInstType _ _ (InstMul _ _) = irTypeInt32 69 | constructInstType _ _ (InstL _ _) = irTypeBool 70 | constructInstType _ _ (InstAnd _ _) = irTypeBool 71 | constructInstType ctx m gep@(InstGEP root _) = 72 | (_constructValueType ctx root) 73 | 74 | constructInstType ctx _ load@(InstLoad v) = _constructValueType ctx v 75 | constructInstType ctx _ (InstStore _ _) = IRTypeVoid 76 | constructInstType ctx _ call@(InstCall fn _) = 77 | case _constructValueType ctx fn of 78 | IRTypeFunction _ retty -> retty 79 | otherty -> error . docToString $ 80 | pretty "unable to construct type for function call: " <+> pretty call 81 | 82 | constructInstType ctx _ inst = error . docToString $ 83 | pretty "unimplemented constructInstType for: " <+> pretty inst 84 | 85 | 86 | -- | Set the current function in the context 87 | setFunctionInContext :: Function -> Context -> Context 88 | setFunctionInContext f ctx = newctx where 89 | newctx :: Context 90 | newctx = ctx { 91 | currentFunction=Just f, 92 | instNameToType=instNameToType 93 | } 94 | -- | Basic blocks in the function. 95 | bbs :: [BasicBlock] 96 | bbs = M.elems . functionBBMap $ f 97 | 98 | -- | List of instructions in the function. 99 | namedInsts :: [Named Inst] 100 | namedInsts = bbs >>= bbInsts 101 | 102 | -- | given a named inst, try to create a map between a label inst and an inst 103 | mkNamedInstMap :: Named Inst -> M.OrderedMap (Label Inst) Inst 104 | mkNamedInstMap (UnNamed _) = mempty 105 | mkNamedInstMap (Named name inst) = M.fromList [(name, inst)] 106 | 107 | -- | map instruction name to the instruction 108 | instNameToInst :: M.OrderedMap (Label Inst) Inst 109 | instNameToInst = mconcat . map mkNamedInstMap $ namedInsts 110 | 111 | -- | map instruction name to type. We abuse laziness to use newctx 112 | instNameToType :: M.OrderedMap (Label Inst) IRType 113 | instNameToType = fmap (constructInstType newctx instNameToInst) instNameToInst 114 | 115 | -- | Get the parameter type from the parameter name 116 | getParamTypeFromContext :: Context -> Label Param -> IRType 117 | getParamTypeFromContext Context{ 118 | currentFunction=Just (curfn@Function { 119 | functionParamLabels=paramLabels, 120 | functionType=(paramTypes, _) 121 | }) 122 | } lbl = case findIndex (== lbl) paramLabels of 123 | Just i -> paramTypes !! i 124 | Nothing -> 125 | error . docToString $ 126 | vcat [pretty "NO param name: ", 127 | pretty lbl, pretty "in function: ", 128 | pretty curfn] 129 | 130 | 131 | bsToStr :: B.ByteString -> String 132 | bsToStr = map (chr . fromEnum) . B.unpack 133 | 134 | -- | Convert a 'String' to a 'ShortByteString' 135 | strToShort :: String -> B.ShortByteString 136 | strToShort = B.toShort . C8.pack 137 | 138 | -- | Convert a 'String' to a 'AST.Name' 139 | strToName :: String -> L.Name 140 | strToName = L.Name . strToShort 141 | 142 | -- | Convert a `IR.Label` to a `AST.Name` 143 | labelToName :: Label a -> L.Name 144 | labelToName = strToName . unLabel 145 | 146 | -- | Convert an int to an integer 147 | intToInteger :: Int -> Integer 148 | intToInteger = fromIntegral 149 | 150 | intToWord32 :: Int -> W.Word32 151 | intToWord32 = fromIntegral 152 | 153 | 154 | intToWord :: Int -> W.Word 155 | intToWord = fromIntegral 156 | 157 | -- | Convert a `IRType` to a LLVM Type. 158 | irToLLVMType :: IRType -> L.Type 159 | irToLLVMType (IRTypeInt i) = L.IntegerType . intToWord32 $ i 160 | irToLLVMType (IRTypeVoid) = L.VoidType 161 | irToLLVMType (IRTypePointer ty) = L.ptr (irToLLVMType ty) 162 | irToLLVMType (IRTypeFunction params ret) = 163 | -- False for varargs. 164 | L.FunctionType (irToLLVMType ret) (map irToLLVMType params) False 165 | irToLLVMType (IRTypeStruct fields) = 166 | L.StructureType isPacked (map irToLLVMType fields) where 167 | isPacked = False 168 | 169 | 170 | -- | Convert a `RetInst` to a `Terminator` 171 | _materializeRetInst :: Context -> RetInst -> L.Terminator 172 | _materializeRetInst ctx RetInstVoid = L.Ret { 173 | L.returnOperand=Nothing, 174 | L.metadata'=[] 175 | } 176 | 177 | _materializeRetInst ctx (RetInstReturn val) = L.Ret { 178 | L.returnOperand=Just (_materializeValueToOperand ctx val), 179 | L.metadata'=[] 180 | } 181 | -- # hack 182 | _materializeRetInst ctx (RetInstSwitch switchVal defaultBB switchMaps) = L.Switch { 183 | L.operand0'=_materializeValueToOperand ctx switchVal, 184 | L.defaultDest=labelToName defaultBB, 185 | L.dests=map switchToLLVM switchMaps, 186 | L.metadata'=[] 187 | } where 188 | switchToLLVM :: (Value, BBLabel) -> (LC.Constant, L.Name) 189 | switchToLLVM (val, bbname) = 190 | (_materializeValueToConstant ctx val, labelToName bbname) 191 | 192 | _materializeRetInst ctx r = error . docToString $ 193 | pretty "unimplemented _materializeRetInst: " <+> pretty r 194 | 195 | _constructValueType :: Context -> Value -> IRType 196 | _constructValueType ctx (ValueConstInt _) = irTypeInt32 197 | _constructValueType ctx (ValueInstRef name) = (instNameToType ctx) M.! name 198 | _constructValueType ctx (ValueParamRef name) = getParamTypeFromContext ctx name 199 | _constructValueType ctx (ValueFnPointer fnname) = (functionNameToType ctx) M.! fnname 200 | _constructValueType ctx (ValueGlobalRef name) = (globalNameToType ctx) M.! name 201 | 202 | -- | Get Name of the reference where Value is a reference value. 203 | _getValueReferenceName :: Value -> L.Name 204 | _getValueReferenceName (ValueInstRef name) = (labelToName name) 205 | _getValueReferenceName (ValueParamRef name) = (labelToName name) 206 | _getValueReferenceName (ValueFnPointer fnname) = (labelToName fnname) 207 | _getValueReferenceName (ValueGlobalRef name) = (labelToName name) 208 | _getValueReferenceName v = error . docToString $ 209 | pretty "Either _materializeValueToConstant was not implemented, or value is not a reference:" <+> pretty v 210 | 211 | -- | Materialize a value into a local reference. 212 | -- | Used only by _materializeValueToOperand. 213 | -- | TODO: refactor to let-binding 214 | _materializeValueToLocalReference :: Context -> Value -> L.Operand 215 | _materializeValueToLocalReference ctx v = 216 | L.LocalReference (irToLLVMType (_constructValueType ctx v)) 217 | (_getValueReferenceName $ v) 218 | 219 | -- | Materialize a value into a global reference. 220 | -- | Used only by _materializeValueToOperand. 221 | _materializeValueToGlobalReference :: Context -> Value -> L.Operand 222 | _materializeValueToGlobalReference ctx v = 223 | L.ConstantOperand $ LC.GlobalReference 224 | (irToLLVMType (_constructValueType ctx v)) 225 | (_getValueReferenceName $ v) 226 | 227 | -- | Materialize a Value into a Operand 228 | _materializeValueToOperand :: Context -> Value -> L.Operand 229 | _materializeValueToOperand ctx v = 230 | case v of 231 | ValueConstInt _ -> L.ConstantOperand $ _materializeValueToConstant ctx v 232 | ValueUndef ty -> L.ConstantOperand $ _materializeValueToConstant ctx v 233 | ref@(ValueInstRef _) -> _materializeValueToLocalReference ctx ref 234 | ref@(ValueParamRef _) -> _materializeValueToLocalReference ctx ref 235 | fnref@(ValueFnPointer _) -> _materializeValueToGlobalReference ctx fnref 236 | gref@(ValueGlobalRef _) -> _materializeValueToGlobalReference ctx gref 237 | 238 | reference -> L.LocalReference (irToLLVMType (_constructValueType ctx v)) (_getValueReferenceName $ v) 239 | 240 | -- | Materialize a Value to a Constant. 241 | -- | Note: this is partial. 242 | _materializeValueToConstant :: Context -> Value -> LC.Constant 243 | _materializeValueToConstant _ (ValueConstInt i) = LC.Int (intToWord32 32) (intToInteger i) 244 | _materializeValueToConstant _ (ValueUndef ty) = LC.Undef (irToLLVMType ty) 245 | _materializeValueToConstant _ v = error . docToString $ 246 | pretty "unable to materialize value to constant: " <+> pretty v 247 | 248 | -- | make an `Operand` into a `CallableOperand` 249 | _makeOperandCallable :: L.Operand -> L.CallableOperand 250 | _makeOperandCallable = Right 251 | 252 | -- | Materialize an IR instruction 253 | _materializeInst :: Context -> Inst -> L.Instruction 254 | _materializeInst ctx (InstAdd v1 v2) = L.Add { 255 | L.nsw=False, 256 | L.nuw=False, 257 | L.operand0=_materializeValueToOperand ctx v1, 258 | L.operand1=_materializeValueToOperand ctx v2, 259 | L.metadata=[] 260 | } 261 | 262 | _materializeInst ctx (InstLoad addr) = L.Load { 263 | L.volatile=False, 264 | L.address=_materializeValueToOperand ctx addr, 265 | L.maybeAtomicity=Nothing, 266 | L.alignment=intToWord32 4, 267 | L.metadata=[] 268 | } 269 | 270 | _materializeInst ctx s@(InstStore addr val) = L.Store { 271 | L.volatile=False, 272 | L.address=addrop, 273 | L.value=valop, 274 | L.maybeAtomicity=Nothing, 275 | L.alignment=intToWord32 4, 276 | L.metadata=[] 277 | } where 278 | valop =_materializeValueToOperand ctx val 279 | addrop=_materializeValueToOperand ctx addr 280 | 281 | _materializeInst ctx (InstGEP addr indices) = L.GetElementPtr { 282 | L.inBounds=True, 283 | L.address=_materializeValueToOperand ctx addr, 284 | L.indices=map (_materializeValueToOperand ctx) indices, 285 | L.metadata=[] 286 | } 287 | 288 | 289 | 290 | _materializeInst ctx (InstCall fnname fnparams) = L.Call { 291 | L.tailCallKind=Nothing, 292 | L.callingConvention= L.C, 293 | L.returnAttributes=[], 294 | L.function=_makeOperandCallable $ _materializeValueToOperand ctx fnname, 295 | L.arguments=args, 296 | L.functionAttributes=[], 297 | L.metadata=[] 298 | } where 299 | paramAttribs :: [[L.ParameterAttribute]] 300 | paramAttribs = repeat [] 301 | 302 | args :: [(L.Operand, [L.ParameterAttribute])] 303 | args = zip (map (_materializeValueToOperand ctx) fnparams) paramAttribs 304 | 305 | _materializeInst ctx inst = error . docToString $ 306 | pretty "unable to materialize Inst: " <+> pretty inst 307 | 308 | -- | Materialize a `Named a` by using `f` into a `L.Named b` 309 | -- | We choose to not create the more obvious version without the `a -> b` 310 | -- | since it is uncommon for us to use only a `Named a` in a module. 311 | _materializeNamed :: (a -> b) -> Named a -> L.Named b 312 | _materializeNamed f (Named labelName a) = (strToName . unLabel $ labelName) L.:= (f a) 313 | _materializeNamed f (UnNamed a) = L.Do (f a) 314 | 315 | -- | Materialize a BasicBlock given the name and the basic block 316 | materializeBB :: Context -> Label BasicBlock -> BasicBlock -> L.BasicBlock 317 | materializeBB ctx bblabel bb@BasicBlock{..} = let 318 | name :: L.Name 319 | name = labelToName bblabel 320 | 321 | insts :: [L.Named L.Instruction] 322 | insts = map (_materializeNamed (_materializeInst ctx)) bbInsts 323 | 324 | terminator :: L.Named L.Terminator 325 | terminator = (_materializeNamed (_materializeRetInst ctx)) (UnNamed bbRetInst) 326 | in L.BasicBlock name insts terminator 327 | 328 | _materializeFunctionParams :: Function -> [L.Parameter] 329 | _materializeFunctionParams Function{..} = let 330 | paramtys :: [L.Type] 331 | paramtys = map irToLLVMType (fst functionType) 332 | 333 | paramNames :: [L.Name] 334 | paramNames = map labelToName functionParamLabels 335 | 336 | attribs :: [L.ParameterAttribute] 337 | attribs = [] 338 | in 339 | zipWith (\n t -> L.Parameter t n attribs) paramNames paramtys 340 | 341 | _materializeFunction :: Context -> Function -> L.Definition 342 | _materializeFunction ctx f = L.GlobalDefinition (L.functionDefaults { 343 | L.name=labelToName . functionLabel $ f, 344 | L.returnType=retty, 345 | -- False = vararg 346 | 347 | L.parameters=(_materializeFunctionParams f, False), 348 | L.basicBlocks=mapToList (materializeBB fnctx) (functionBBMap f) 349 | }) where 350 | retty :: L.Type 351 | retty = irToLLVMType . snd . functionType $ f 352 | 353 | -- | The updated context that points to the function. 354 | fnctx :: Context 355 | fnctx = setFunctionInContext f ctx 356 | 357 | 358 | -- | Materialize a GlobalValue given its name. It may or may not 359 | -- | contain a value. 360 | _materializeGlobal :: Context -> GlobalLabel -> GlobalValue -> L.Definition 361 | _materializeGlobal ctx label GlobalValue{ gvType=ty, gvValue=mVal} = 362 | L.GlobalDefinition (L.globalVariableDefaults { 363 | L.name=labelToName label, 364 | L.initializer=fmap (_materializeValueToConstant ctx) mVal, 365 | LLVM.AST.Global.type'=irToLLVMType ty 366 | }) 367 | 368 | _irmoduleToDefinitions :: IR.Module -> [L.Definition] 369 | _irmoduleToDefinitions mod@Module {moduleFunctions=fs, 370 | moduleGlobals=globalNameToVal} = 371 | (map (_materializeFunction ctx)fs) ++ mapToList (_materializeGlobal ctx) globalNameToVal 372 | where 373 | ctx = _buildContextForModule mod 374 | 375 | 376 | type IRString = String 377 | -- | Return the LLVM IR string corresponding to the IR.Module 378 | moduleToLLVMIRString :: IR.Module -> IO IRString 379 | moduleToLLVMIRString irmod = let 380 | -- Module from llvm-hs-pure 381 | pureLLVMMod = _definitionsToModule . _irmoduleToDefinitions $ irmod 382 | in RealL.withContext $ \llvmCtx -> 383 | RealL.withModuleFromAST llvmCtx pureLLVMMod $ \llvmMod -> 384 | bsToStr <$> RealL.moduleLLVMAssembly llvmMod 385 | 386 | -- | Write the LLVM IR corresponding to the IR.Module in the file 387 | writeModuleLLVMIRStringToFile :: IR.Module -- | Source module 388 | -> String -- ^File path 389 | -> IO () 390 | writeModuleLLVMIRStringToFile irmod path = let 391 | pureLLVMMod = _definitionsToModule . _irmoduleToDefinitions $ irmod 392 | in RealL.withContext $ \llvmCtx -> 393 | RealL.withModuleFromAST llvmCtx pureLLVMMod $ \llvmMod -> 394 | RealL.writeLLVMAssemblyToFile (RealL.File path) llvmMod 395 | 396 | -- | Create a new module 397 | _definitionsToModule :: [L.Definition] -> L.Module 398 | _definitionsToModule defs = L.Module { 399 | L.moduleName=B.toShort . C8.pack $ "simplexhc", 400 | L.moduleSourceFileName=B.toShort . C8.pack $ "simplexhc-thinair", 401 | L.moduleDataLayout=Nothing, 402 | L.moduleTargetTriple=Nothing, 403 | L.moduleDefinitions=defs 404 | } 405 | 406 | -------------------------------------------------------------------------------- /src/OrderedMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE InstanceSigs #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | module OrderedMap(OrderedMap, 7 | fromList, 8 | size, 9 | adjust, 10 | insert, 11 | elems, 12 | toList, 13 | keys, 14 | (!), 15 | union, 16 | OrderedMap.lookup) where 17 | import qualified Data.Map.Strict as M 18 | import Data.Monoid 19 | import ColorUtils 20 | import Data.Text.Prettyprint.Doc 21 | import qualified Data.List as L 22 | 23 | -- At some point, I need this. This is more convenient than overloading the key to store the insertion time. 24 | -- | A dictionary that orders elements by insertion time 25 | data OrderedMap k v = OrderedMap { map' :: M.Map k v, order :: [k] } deriving(Show, Functor, Foldable, Traversable) 26 | 27 | instance (Ord k, Pretty k, Pretty v) => Pretty (OrderedMap k v) where 28 | pretty (OrderedMap _ []) = pretty "empty map" 29 | pretty ok = vcat (map pkv (toList ok)) where 30 | pkv :: (Pretty k, Pretty v) => (k, v) -> Doc ann 31 | pkv (k, v) = pretty "** key: " <+> pretty k <+> pretty " | value : " <+> pretty v 32 | 33 | instance Ord k => Monoid (OrderedMap k v) where 34 | mempty :: OrderedMap k v 35 | mempty = OrderedMap mempty mempty 36 | 37 | mappend :: OrderedMap k v -> OrderedMap k v -> OrderedMap k v 38 | mappend (OrderedMap m o) (OrderedMap m' o') = OrderedMap (m `mappend` m') (o `mappend` o') 39 | 40 | liftMapEdit_ :: (M.Map k v -> M.Map k v) -> OrderedMap k v -> OrderedMap k v 41 | liftMapEdit_ f (OrderedMap map' order) = OrderedMap (f map') order 42 | 43 | liftMapExtract_ :: (M.Map k v -> a) -> OrderedMap k v -> a 44 | liftMapExtract_ f (OrderedMap map' _) = f map' 45 | 46 | -- | NOTE: this will maintain the order of insertion. Elements that are inserted 47 | -- | later are returned later in the `keys`, `elems`. 48 | insert :: Ord k => k -> a -> OrderedMap k a -> OrderedMap k a 49 | insert k a om@OrderedMap{..} = 50 | case (liftMapExtract_ (M.lookup k)) om of 51 | Nothing -> OrderedMap (M.insert k a map') (order ++ [k]) 52 | -- If the key already exists, keep the old order 53 | _ -> OrderedMap (M.insert k a map') (order) 54 | 55 | lookup :: Ord k => k -> OrderedMap k a -> Maybe a 56 | lookup k = liftMapExtract_ (M.lookup k) 57 | 58 | fromList :: Ord k => [(k, a)] -> OrderedMap k a 59 | fromList kv = OrderedMap (M.fromList kv) (map fst kv) 60 | 61 | size :: OrderedMap k a -> Int 62 | size = liftMapExtract_ M.size 63 | 64 | keys :: OrderedMap k a -> [k] 65 | keys = liftMapExtract_ M.keys 66 | 67 | elems :: Ord k => OrderedMap k a -> [a] 68 | elems = liftMapExtract_ M.elems 69 | 70 | union :: (Eq k, Ord k) => OrderedMap k a -> OrderedMap k a -> OrderedMap k a 71 | union (OrderedMap{order=o1, map'=m1}) (OrderedMap{order=o2, map'=m2}) = 72 | OrderedMap{map'=m1 `M.union` m2, order=L.nub(o1++o2)} 73 | 74 | -- | Return the list of key value pairs in the order of insertion. 75 | toList :: (Ord k, Pretty k, Pretty a) => OrderedMap k a -> [(k, a)] 76 | toList omap = map (\k -> (k, omap OrderedMap.! k)) (keys omap) 77 | 78 | adjust :: Ord k => (a -> a) -> k -> OrderedMap k a -> OrderedMap k a 79 | adjust f k = liftMapEdit_ (M.adjust f k) 80 | 81 | (!) :: (Ord k, Pretty k, Pretty a) => OrderedMap k a -> k -> a 82 | ok ! k = 83 | case (OrderedMap.lookup k ok) of 84 | Just a -> a 85 | Nothing -> error . docToString $ 86 | vcat [pretty "key missing, has no value associated with it: " <+> pretty k, 87 | pretty "map:", 88 | indent 4 (pretty ok), 89 | pretty "---"] 90 | 91 | foldMapWithKey :: Monoid m => (k -> a -> m) -> OrderedMap k a -> m 92 | foldMapWithKey f = liftMapExtract_ (M.foldMapWithKey f) 93 | -------------------------------------------------------------------------------- /src/Stg.hs: -------------------------------------------------------------------------------- 1 | module Stg where 2 | 3 | import StgLanguage 4 | import StgParser 5 | import StgPushEnterMachine 6 | import Text.Trifecta as TR 7 | -- note that this is a trifecta dependency 8 | import qualified Text.PrettyPrint.ANSI.Leijen as PP 9 | -- 10 | 11 | type ErrorString = String 12 | 13 | squashFrontendErrors :: Either ErrorString (Either StgError a) -> Either ErrorString a 14 | squashFrontendErrors val = 15 | case val of 16 | (Left parseErr) -> Left $ "pre-compile error:\n" ++ parseErr 17 | (Right (Left compileErr)) -> Left $ "compile error:\n" ++ show compileErr 18 | (Right (Right a)) -> Right a 19 | 20 | parseString :: String -> Either ErrorString Program 21 | parseString str = case parseStg str of 22 | Success a -> Right a 23 | Failure ErrInfo{ _errDoc = e } -> Left (PP.displayS (PP.renderPretty 0.8 80 e) "") 24 | 25 | tryCompileString :: String -> Either ErrorString PushEnterMachineState 26 | tryCompileString str = squashFrontendErrors $ compileProgram <$> Stg.parseString str 27 | 28 | -------------------------------------------------------------------------------- /src/StgEvalApplyMachine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE InstanceSigs #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# LANGUAGE DeriveTraversable #-} 7 | 8 | module StgEvalApplyMachine where 9 | import StgLanguage 10 | 11 | 12 | import Text.PrettyPrint as PP 13 | import Numeric 14 | import qualified Data.Map as M 15 | import Control.Monad.Trans.Class 16 | import Control.Lens 17 | import Data.Map.Lens 18 | import Control.Applicative 19 | import Data.Either.Utils 20 | import Control.Monad.State 21 | import Control.Monad.Except 22 | import Data.Traversable 23 | import Data.Foldable 24 | 25 | import ColorUtils 26 | 27 | -- for <> 28 | import Data.Monoid 29 | 30 | -- hoistError 31 | import Control.Monad.Error.Hoist 32 | 33 | -- readMaybe 34 | import Data.String.Utils 35 | 36 | 37 | 38 | data Continuation = Continuation { _continuationAlts :: ![CaseAltType], 39 | _continuationEnv :: !LocalEnvironment 40 | } 41 | 42 | instance Pretty Continuation where 43 | pretty Continuation{..} = text "alts:" $$ 44 | (_continuationAlts & map pretty & vcat) 45 | 46 | instance Show Continuation where 47 | show = renderStyle showStyle . pretty 48 | 49 | 50 | data UpdateFrame = UpdateFrame { 51 | -- | the argument stack that was present when the update frame was created. 52 | _updateFrameArgumentStack :: !ArgumentStack, 53 | -- | The return stack that was present when the update frame was created. 54 | _updateFrameReturnStack :: !ReturnStack, 55 | -- | The address of the heap closure to be updated. 56 | _updateFrameAddress :: Addr 57 | } 58 | instance Pretty UpdateFrame where 59 | pretty UpdateFrame{..} = nest 4 (text "Argument Stack: " $$ 60 | pretty _updateFrameArgumentStack $$ 61 | text "Return Stack: " $$ 62 | pretty _updateFrameReturnStack) 63 | 64 | 65 | -- | Represents an STG Address 66 | newtype Addr = Addr { _getAddr :: Int } deriving(Eq, Ord) 67 | instance Pretty Addr where 68 | pretty addr = styleAddr PP.<> (text $ "0x" ++ (addr & _getAddr & (\x -> showHex x ""))) PP.<> styleReset 69 | 70 | instance Show Addr where 71 | show = renderStyle showStyle . pretty 72 | 73 | data Value = ValueAddr Addr | ValuePrimInt Int 74 | deriving (Eq, Ord) 75 | 76 | 77 | instance Pretty Value where 78 | pretty (ValueAddr addr) = mkStyleTag (text "val:") PP.<> pretty addr 79 | pretty (ValuePrimInt int) = mkStyleTag (text "val:") PP.<> text (show int) PP.<> text "#" 80 | 81 | instance Show Value where 82 | show = renderStyle showStyle . pretty 83 | 84 | -- | Stack of 'Value' 85 | newtype Stack a = Stack { _unStack :: [a] } deriving(Functor, Monoid, Foldable, Traversable) 86 | 87 | stackLength :: Stack a -> Int 88 | stackLength = length . _unStack 89 | 90 | stackEmpty :: Stack a 91 | stackEmpty = Stack [] 92 | 93 | instance Pretty a => Prettyable (Stack a) where 94 | pretty (Stack []) = text "EMPTY" 95 | pretty (Stack xs) = text ("count: " ++ show (length xs)) $+$ 96 | mkStyleAnnotation (text "TOP") $+$ 97 | ((zipWith (<+>) (fmap (\i -> mkStyleAnnotation (PP.text "|" PP.<> PP.int i PP.<> text ":")) [1..] ) (fmap pretty xs)) & sep) $+$ 98 | mkStyleAnnotation (text "BOTTOM") 99 | 100 | instance Pretty a => Show (Stack a) where 101 | show = renderStyle showStyle . pretty 102 | 103 | type ArgumentStack = Stack Value 104 | type ReturnStack = Stack Continuation 105 | type UpdateStack = Stack UpdateFrame 106 | type Heap = M.Map Addr Closure 107 | 108 | 109 | -- | Maps VarName names to addresses of the closures 110 | type GlobalEnvironment = M.Map VarName Addr 111 | 112 | -- | has bindings of free variables with a 'LambdaForm' 113 | newtype ClosureFreeVals = ClosureFreeVals { _getFreeVals :: [Value] } deriving(Show) 114 | instance Pretty ClosureFreeVals where 115 | pretty freeVars = _getFreeVals freeVars & map pretty & punctuate (text ",") & hsep 116 | data Closure = Closure { 117 | _closureLambda :: !Lambda, 118 | _closureFreeVals :: !ClosureFreeVals 119 | } deriving (Show) 120 | 121 | instance Pretty Closure where 122 | -- TODO: allow closure to invoke a custom renderer for free variables in the lambdaForm 123 | pretty (Closure{..}) = (mkStyleTag (text "cls:")) <+> text "[" 124 | <+> pretty _closureLambda PP.<> envdoc <+> text "]" where 125 | envdoc = if length ( _getFreeVals ( _closureFreeVals)) == 0 126 | then text "" 127 | else text " | Free variable vals: " <+> pretty _closureFreeVals 128 | 129 | 130 | 131 | type LocalEnvironment = M.Map VarName Value 132 | 133 | instance (Pretty k, Prettyable v) => Prettyable (M.Map k v) where 134 | pretty m = (fmap (uncurry mkKvDoc) (M.toList m)) & punctuate (text ";") & vcat where 135 | mkKvDoc key val = pretty key <+> text "->" <+> pretty val 136 | 137 | data Code = CodeEval ExprNode LocalEnvironment | 138 | CodeEnter Addr | 139 | CodeUninitialized | 140 | CodeReturnConstructor Constructor [Value] | 141 | CodeReturnInt StgInt deriving(Show) 142 | 143 | instance Pretty Code where 144 | pretty (CodeEval expr env) = text "Eval" <+> braces (pretty expr) <+> text "|Local:" <+> braces(pretty env) 145 | pretty (CodeEnter addr) = text "Enter" <+> pretty addr 146 | pretty (CodeReturnConstructor cons values) = 147 | text "ReturnConstructor" <+> 148 | (pretty (cons ^. constructorName) <+> 149 | (values & map pretty & punctuate comma & hsep & braces) & parens) 150 | pretty (CodeReturnInt i) = text "ReturnInt" <+> text (show i) 151 | 152 | 153 | newtype Log = Log { unLog :: [Doc] } deriving(Monoid) 154 | 155 | instance Pretty Log where 156 | pretty (Log ls) = fmap (\l -> text (">>") <+> l) ls & vcat 157 | 158 | instance Show Log where 159 | show = renderStyle showStyle . pretty 160 | 161 | data EvalApplyMachineState = PushEnterMachineState { 162 | _argumentStack :: !ArgumentStack, 163 | _returnStack :: !ReturnStack, 164 | _updateStack :: !UpdateStack, 165 | _heap :: !Heap, 166 | _globalEnvironment :: !GlobalEnvironment, 167 | _code :: !Code, 168 | _currentLog :: !Log, 169 | _oldLog :: !Log 170 | } 171 | 172 | 173 | instance Pretty EvalApplyMachineState where 174 | pretty EvalApplyMachineState{..} = 175 | heading (text "@@@ Steps to reach state:") $$ currentLogDoc $+$ 176 | heading (text "@@@ Code:") $$ code $+$ 177 | heading (text "@@@ Args:") $$ argsDoc $+$ 178 | heading (text "@@@ Return:") $$ returnDoc $+$ 179 | heading (text "@@@ Update:") $$ updateDoc $+$ 180 | heading (text "@@@ Heap:") $$ heapDoc $+$ 181 | heading (text "@@@ Env:") $$ globalEnvDoc $+$ 182 | heading (text "---") where 183 | argsDoc = _argumentStack & pretty 184 | returnDoc = _returnStack & pretty 185 | updateDoc = _updateStack & pretty 186 | heapDoc = _heap & pretty 187 | globalEnvDoc = _globalEnvironment & pretty 188 | code = _code & pretty 189 | currentLogDoc = _currentLog & pretty 190 | 191 | instance Show EvalApplyMachineState where 192 | show = renderStyle showStyle . pretty 193 | 194 | data MachineProgress = MachineStepped | MachineHalted deriving(Show, Eq) 195 | 196 | newtype MachineT a = MachineT { unMachineT :: ExceptT StgError (State EvalApplyMachineState) a } 197 | deriving (Functor, Applicative, Monad 198 | , MonadState EvalApplyMachineState 199 | , MonadError StgError) 200 | 201 | -- | All possible errors when interpreting STG code. 202 | data StgError = 203 | -- | 'compileProgram' could not find main 204 | StgErrorUnableToFindMain | 205 | -- | 'lookupVariable' failed 206 | StgErrorEnvLookupFailed !VarName !LocalEnvironment !GlobalEnvironment | 207 | -- | 'lookupAddrInHeap' failed 208 | StgErrorHeapLookupFailed !Addr !Heap | 209 | -- | 'rawNumberToValue' failed 210 | StgErrorUnableToMkPrimInt !RawNumber | 211 | -- | 'takeNArgs' failed 212 | StgErrorNotEnoughArgsOnStack !Int !ArgumentStack | 213 | -- | 'continuationGetVariable' found no variable 214 | StgErrorCaseAltsHasNoVariable !Continuation | 215 | -- | 'continuationGetVariable' found too many variables 216 | StgErrorCaseAltsHasMoreThanOneVariable !Continuation ![CaseAlt VarName] | 217 | -- | 'caseAltsGetUniqueMatch' found overlapping patterns 218 | -- | FIXME: find a better repr for the CaseAlt. currently cumbersome 219 | StgErrorCaseAltsOverlappingPatterns | 220 | -- | `returnStackPop` finds no continuation to return to 221 | StgErrorReturnStackEmpty | 222 | -- | `unwrapAlts` failed, unable to unwrap raw number 223 | StgErrorExpectedCaseAltInt !CaseAltType | 224 | -- | `unwrapAlts` failed, unable to unwrap Constructor 225 | StgErrorExpectedCaseAltConstructor Constructor !CaseAltType | 226 | -- | 'xxx' failed, no matching pattern match found 227 | StgErrorNoMatchingAltPatternInt StgInt [CaseAlt StgInt] | 228 | -- | 'xxx' failed, no matching pattern match found 229 | StgErrorNoMatchingAltPatternConstructor Constructor [CaseAlt ConstructorPatternMatch] | 230 | -- | tried to pop empty update frame 231 | StgErrorUpdateStackEmpty | 232 | -- | tried to update an address where no previous value exists 233 | StgErrorHeapUpdateHasNoPreviousValue Addr deriving(Show) 234 | 235 | makeLenses ''ClosureFreeVals 236 | makePrisms ''Value 237 | makeLenses ''Closure 238 | makePrisms ''Code 239 | makeLenses ''PushEnterMachineState 240 | makeLenses ''Addr 241 | makeLenses ''Continuation 242 | makeLenses ''Stack 243 | makeLenses ''UpdateFrame 244 | 245 | uninitializedPushEnterMachineState :: EvalApplyMachineState 246 | uninitializedPushEnterMachineState = EvalApplyMachineState { 247 | _argumentStack=stackEmpty, 248 | _returnStack = stackEmpty, 249 | _updateStack = stackEmpty, 250 | _heap=M.empty, 251 | _globalEnvironment=M.empty, 252 | _code=CodeUninitialized, 253 | _oldLog=mempty, 254 | _currentLog=mempty 255 | } 256 | 257 | maybeToMachineT :: Maybe a -> StgError -> MachineT a 258 | maybeToMachineT (Nothing) err = throwError err 259 | maybeToMachineT (Just a) err = return a 260 | 261 | runMachineT :: MachineT a -> EvalApplyMachineState -> Either StgError (a, PushEnterMachineState) 262 | runMachineT machineT state = let (mVal, machineState) = runState (runExceptT . unMachineT $ machineT) state in 263 | -- TODO: refactor with fmap 264 | case mVal of 265 | Left err -> Left err 266 | Right val -> Right (val, machineState) 267 | 268 | 269 | allocateBinding :: LocalEnvironment -> Binding -> MachineT (VarName, Addr) 270 | allocateBinding localenv binding = do 271 | let lambda = binding ^. bindingLambda 272 | let name = binding ^. bindingName 273 | addr <- (mkClosureFromLambda lambda localenv) >>= allocateClosureOnHeap 274 | return (name, addr) 275 | 276 | gVarNamesToIntIntrinsics :: M.Map VarName (Int -> Int -> Int) 277 | gVarNamesToIntIntrinsics = M.fromList $ [(VarName "plus#", (+))] 278 | 279 | -- HACK: I'm mapping intrinsics to negative addresses. 280 | -- Ideally, this should be cleaner but I really don't care right now 281 | -- mapIntrinsicsToAddrs :: MachineT () 282 | -- mapIntrinsicsToAddrs = do 283 | -- for_ zip ([-1, -2,..](M.keys gVarNamesToIntIntrinsics) (\(i, name) -> globalEnvironment %= (at name) .~ Just i) 284 | 285 | 286 | -- allocate the bindings on the heap, and return the mapping 287 | -- between variable names to addresses 288 | compileProgram :: Program -> Either StgError EvalApplyMachineState 289 | compileProgram prog = snd <$> (runMachineT setupBindings uninitializedPushEnterMachineState) 290 | where 291 | setupBindings :: MachineT () 292 | setupBindings = do 293 | let localenv = M.empty -- when machine starts, no local env. 294 | nameAddrPairs <- for prog (allocateBinding localenv) :: MachineT [(VarName, Addr)] 295 | globalEnvironment .= M.fromList nameAddrPairs 296 | -- Do I actually need this? mapIntrinsicsToAddrs 297 | 298 | mainAddr <- use globalEnvironment >>= (\x -> maybeToMachineT (x ^. at (VarName "main")) StgErrorUnableToFindMain) :: MachineT Addr 299 | -- NOTE: this is different from STG paper. Does this even work? 300 | setCode $ CodeEnter mainAddr 301 | 302 | isExprPrimitive :: ExprNode -> Bool 303 | isExprPrimitive (ExprNodeInt _) = True 304 | isExprPrimitive _ = False 305 | 306 | isPushEnterMachineStateFinal :: EvalApplyMachineState -> Bool 307 | isPushEnterMachineStateFinal m = case m ^. code of 308 | (CodeEval expr _) -> isExprPrimitive expr 309 | _ -> False 310 | 311 | -- | Try to lookup 'VarName' in the local & global environments. Fail if unable to lookup. 312 | lookupVariable :: LocalEnvironment -> VarName -> MachineT Value 313 | lookupVariable localEnv ident = do 314 | globalEnv <- use globalEnvironment 315 | let localLookup = (localEnv ^. at ident) 316 | let globalLookup = (ValueAddr <$> (globalEnv ^. at ident)) 317 | 318 | let errormsg = StgErrorEnvLookupFailed ident localEnv globalEnv 319 | maybeToEither errormsg (localLookup <|> globalLookup) 320 | 321 | 322 | stgIntToValue :: StgInt -> Value 323 | stgIntToValue si = ValuePrimInt (unStgInt si) 324 | 325 | lookupAtom :: LocalEnvironment -> Atom -> MachineT Value 326 | lookupAtom _ (AtomInt r) = return $ stgIntToValue r 327 | lookupAtom localEnv (AtomVarName ident) = lookupVariable localEnv ident 328 | 329 | 330 | 331 | 332 | mkClosureFromLambda :: Lambda -> LocalEnvironment -> MachineT Closure 333 | mkClosureFromLambda lambda localenv = 334 | do 335 | freeVarVals <- for (lambda ^. lambdaFreeVarIdentifiers) (lookupVariable localenv) 336 | let cls = Closure { 337 | _closureLambda = lambda, 338 | _closureFreeVals = ClosureFreeVals (freeVarVals) 339 | } 340 | return cls 341 | 342 | allocateClosureOnHeap :: Closure -> MachineT Addr 343 | allocateClosureOnHeap cls = do 344 | count <- use (heap . to (M.size)) 345 | heap %= (at (Addr count) .~ Just cls) 346 | return (Addr count) 347 | 348 | 349 | lookupAddrInHeap :: Addr -> MachineT Closure 350 | lookupAddrInHeap addr = do 351 | machineHeap <- use heap 352 | let mclosure = machineHeap ^. at addr :: Maybe Closure 353 | let errormsg = StgErrorHeapLookupFailed addr machineHeap :: StgError 354 | mclosure `maybeToMachineT` errormsg 355 | 356 | -- pop n values off the argument stack 357 | takeNArgs :: Int -> MachineT [Value] 358 | takeNArgs n = do 359 | appendLog $ text "popping" <+> text (show n) <+> text "off of the argument stack" 360 | 361 | argStackList <- use (argumentStack . unStack) 362 | if length argStackList < n 363 | then do 364 | appendLog $ text "length of argument stack:" <+> text (show (length argStackList)) <+> text "< n:" <+> text (show n) 365 | throwError $ StgErrorNotEnoughArgsOnStack n (Stack argStackList) 366 | else do 367 | let args = take n argStackList 368 | argumentStack .= Stack (drop n argStackList) 369 | return args 370 | 371 | 372 | stepMachine :: MachineT MachineProgress 373 | stepMachine = do 374 | code <- use code 375 | 376 | nowOldLog <- use currentLog 377 | oldLog <>= nowOldLog 378 | currentLog .= mempty 379 | appendLog $ text "evaluating code:" <+> pretty code 380 | 381 | case code of 382 | CodeEval f local -> stepCodeEval local f 383 | CodeEnter addr -> stepCodeEnter addr 384 | CodeReturnInt i -> stepCodeReturnInt i 385 | CodeReturnConstructor cons consvals -> stepCodeReturnConstructor cons consvals 386 | 387 | 388 | setCode :: Code -> MachineT () 389 | setCode c = do 390 | appendLog $ text "setting code to: " <+> pretty c 391 | code .= c 392 | 393 | updateStackPop :: MachineT UpdateFrame 394 | updateStackPop = stackPop updateStack StgErrorUpdateStackEmpty 395 | 396 | 397 | -- TODO: find out how to make this look nicer 398 | heapUpdateAddress :: Addr -> Closure -> MachineT () 399 | heapUpdateAddress addr cls = do 400 | appendLog $ text "updating heap at address:" <+> pretty addr <+> text "with closure:" $$ 401 | nest 4 (text "new closure:" <+> pretty cls) 402 | h <- use heap 403 | case h ^. at addr of 404 | Nothing -> do 405 | appendError $ text "heap does not contain address:" <+> pretty addr 406 | throwError $ StgErrorHeapUpdateHasNoPreviousValue addr 407 | Just oldcls -> do 408 | let h' = at addr .~ Just cls $ h 409 | heap .= h' 410 | return () 411 | 412 | -- | create the standard closure for a constructor 413 | -- | << (freeVarIds \n {} -> c freeVarIds), consVals >> 414 | _mkConstructorClosure :: Constructor -> [Value] -> Closure 415 | _mkConstructorClosure c consVals = Closure { 416 | _closureLambda = Lambda { 417 | _lambdaShouldUpdate = False, 418 | _lambdaBoundVarIdentifiers = [], 419 | _lambdaFreeVarIdentifiers = freeVarIds, 420 | _lambdaExprNode = ExprNodeConstructor cons 421 | }, 422 | _closureFreeVals = ClosureFreeVals consVals 423 | } 424 | where 425 | freeVarIds = map (VarName . (\x -> "id" ++ show x)) [1..(length consVals)] 426 | cons = Constructor (c ^. constructorName) (map AtomVarName freeVarIds) 427 | 428 | stepCodeUpdatableReturnConstructor :: Constructor -> [Value] -> MachineT MachineProgress 429 | stepCodeUpdatableReturnConstructor cons values = do 430 | appendLog $ text "using updatable return constructor." 431 | frame <- updateStackPop 432 | 433 | let as = frame ^. updateFrameArgumentStack 434 | let rs = frame ^. updateFrameReturnStack 435 | let addr = frame ^. updateFrameAddress 436 | 437 | returnStack .= rs 438 | argumentStack .= as 439 | 440 | let consClosure = _mkConstructorClosure cons values 441 | heapUpdateAddress addr (consClosure) 442 | 443 | return $ MachineStepped 444 | 445 | 446 | stepCodeNonUpdatableReturnConstructor :: Constructor -> [Value] -> MachineT MachineProgress 447 | stepCodeNonUpdatableReturnConstructor cons values = do 448 | appendLog $ text "using non-updatable return constructor." 449 | returnStackEmpty <- use $ returnStack . to null 450 | if returnStackEmpty then 451 | return MachineHalted 452 | else do 453 | cont <- returnStackPop 454 | 455 | let unwrapErr = StgErrorExpectedCaseAltConstructor cons 456 | unwrapped_alts <- unwrapAlts (cont ^. continuationAlts) _CaseAltConstructor unwrapErr 457 | 458 | let filterErr = StgErrorNoMatchingAltPatternConstructor cons unwrapped_alts 459 | let consname = cons ^. constructorName 460 | let pred (ConstructorPatternMatch name _) = name == consname 461 | 462 | matchingAlt <- (filterEarliestAlt unwrapped_alts pred) `maybeToMachineT` filterErr 463 | let (ConstructorPatternMatch _ varnames) = matchingAlt ^. caseAltLHS 464 | 465 | -- assert ((length varnames) == (length values)) 466 | let newValuesMap = M.fromList (zip varnames values) 467 | let modifiedEnv = newValuesMap `M.union` (cont ^. continuationEnv) 468 | setCode $ CodeEval (matchingAlt ^. caseAltRHS) modifiedEnv 469 | return MachineStepped 470 | 471 | 472 | shouldUseUpdatableStepForReturnConstructor :: EvalApplyMachineState -> Bool 473 | shouldUseUpdatableStepForReturnConstructor EvalApplyMachineState {..} = length _argumentStack == 0 && 474 | length _returnStack == 0 && 475 | length _updateStack > 0 476 | 477 | stepCodeReturnConstructor :: Constructor -> [Value] -> MachineT MachineProgress 478 | stepCodeReturnConstructor cons values = do 479 | useUpdate <- gets shouldUseUpdatableStepForReturnConstructor 480 | if useUpdate then 481 | stepCodeUpdatableReturnConstructor cons values 482 | else 483 | stepCodeNonUpdatableReturnConstructor cons values 484 | 485 | 486 | 487 | appendError :: Doc -> MachineT () 488 | appendError = appendLog . mkStyleError 489 | 490 | appendLog :: Doc -> MachineT () 491 | appendLog s = currentLog <>= Log [s] 492 | 493 | -- | 'CodeEval' execution 494 | stepCodeEval :: LocalEnvironment -> ExprNode -> MachineT MachineProgress 495 | stepCodeEval local expr = do 496 | appendLog $ text "stepCodeEval called" 497 | case expr of 498 | ExprNodeFnApplication f xs -> stepCodeEvalFnApplication local f xs 499 | ExprNodeLet isReucursive bindings inExpr -> stepCodeEvalLet local isReucursive bindings inExpr 500 | ExprNodeCase expr alts -> stepCodeEvalCase local expr alts 501 | ExprNodeInt i -> stepCodeEvalInt i 502 | ExprNodeConstructor cons -> stepCodeEvalConstructor local cons 503 | 504 | 505 | 506 | stepCodeEvalConstructor :: LocalEnvironment -> Constructor -> MachineT MachineProgress 507 | stepCodeEvalConstructor local (cons @ (Constructor consname consAtoms)) = do 508 | consVals <- for consAtoms (lookupAtom local) 509 | setCode $ CodeReturnConstructor cons consVals 510 | return MachineStepped 511 | 512 | 513 | stepIntIntrinsic :: (Int -> Int -> Int) -> [Atom] -> MachineT MachineProgress 514 | stepIntIntrinsic f atoms = do 515 | -- TODO: make this a lens match that can fail make sure the function call looks like this 516 | let [AtomInt (StgInt x1), AtomInt (StgInt x2)] = atoms 517 | setCode $ CodeReturnInt $ StgInt (f x1 x2) 518 | return MachineStepped 519 | 520 | 521 | stepCodeEvalFnApplication :: LocalEnvironment -> VarName -> [Atom] -> MachineT MachineProgress 522 | stepCodeEvalFnApplication local lhsName vars = do 523 | case (M.lookup lhsName gVarNamesToIntIntrinsics) of 524 | Just f -> stepIntIntrinsic f vars 525 | -- we have no intrinsic, so do the usual lookup stuff 526 | Nothing -> do 527 | lhsValue <- lookupVariable local lhsName 528 | -- it doesn't have the address of a function, don't continue 529 | case lhsValue ^? _ValueAddr of 530 | Nothing -> return MachineHalted 531 | Just fnAddr -> do 532 | localVals <- for vars (lookupAtom local) 533 | argumentStack `stackPushN` localVals 534 | setCode $ CodeEnter fnAddr 535 | return MachineStepped 536 | 537 | 538 | _updateEnvWithBinding :: LocalEnvironment -> Binding -> MachineT LocalEnvironment 539 | _updateEnvWithBinding l b = do 540 | (name, addr) <- allocateBinding l b 541 | let l' = l & at name .~ Just (ValueAddr addr) 542 | return l' 543 | 544 | stepCodeEvalLet :: LocalEnvironment -> IsLetRecursive -> [Binding] -> ExprNode -> MachineT MachineProgress 545 | stepCodeEvalLet locals isLetRecursive bindings inExpr = do 546 | newLocals <- foldlM _updateEnvWithBinding locals bindings 547 | let updatedLocals = newLocals `M.union` locals 548 | setCode $ CodeEval inExpr updatedLocals 549 | return MachineStepped 550 | 551 | 552 | stackPushN :: Lens' EvalApplyMachineState (Stack a) -> [a] -> MachineT () 553 | stackPushN stackLens as' = do 554 | as <- use (stackLens . unStack) 555 | stackLens .= Stack (as' ++ as) 556 | 557 | 558 | returnStackPush :: Continuation -> MachineT () 559 | returnStackPush cont = do 560 | returnStack %= (\(Stack rs) -> Stack (cont:rs)) 561 | 562 | 563 | stepCodeEvalCase :: LocalEnvironment -> ExprNode -> [CaseAltType] -> MachineT MachineProgress 564 | stepCodeEvalCase local expr alts = do 565 | returnStackPush (Continuation alts local) 566 | setCode $ CodeEval expr local 567 | return MachineStepped 568 | 569 | stepCodeEvalInt :: StgInt -> MachineT MachineProgress 570 | stepCodeEvalInt i = do 571 | setCode $ CodeReturnInt i 572 | return MachineStepped 573 | 574 | isClosureUpdatable :: Closure -> Bool 575 | isClosureUpdatable cls = cls ^. closureLambda ^. lambdaShouldUpdate 576 | 577 | -- | codeEnter execution 578 | stepCodeEnter :: Addr -> MachineT MachineProgress 579 | stepCodeEnter addr = 580 | do 581 | closure <- lookupAddrInHeap addr 582 | if isClosureUpdatable closure 583 | then stepCodeEnterIntoUpdatableClosure addr closure 584 | else stepCodeEnterIntoNonupdatableClosure addr closure 585 | 586 | -- Enter a as rs where heap[ a -> (vs \u {} -> e) ws_f] 587 | -- Eval e local {} {} (as, rs, a):us heap where 588 | -- local = [vs -> ws_f] 589 | -- | Addr is the address of the closure 590 | -- | Closure is the closure 591 | stepCodeEnterIntoUpdatableClosure :: Addr -> Closure -> MachineT MachineProgress 592 | stepCodeEnterIntoUpdatableClosure addr closure = do 593 | appendLog $ pretty closure <+> text "is updatable." 594 | let l = closure ^. closureLambda 595 | let boundVars = l ^. lambdaBoundVarIdentifiers 596 | let freeVarIds = l ^. lambdaFreeVarIdentifiers 597 | let evalExpr = l ^. lambdaExprNode 598 | 599 | -- is there a better way to format this? 600 | if (length boundVars /= 0) then do 601 | appendLog $ text "updatable closure has bound variables:" <+> pretty boundVars 602 | error "updatable closure has bound variables" 603 | else do 604 | let localFreeVars = M.fromList (zip freeVarIds 605 | (closure ^. closureFreeVals . getFreeVals)) 606 | let localEnv = localFreeVars 607 | 608 | -- push an update frame 609 | as <- use argumentStack 610 | rs <- use returnStack 611 | stackPushN updateStack [(UpdateFrame as rs addr)] 612 | appendLog $ text "pushed update frame" 613 | 614 | -- empty argument and return stack so that them being deref'd will trigger an update 615 | argumentStack .= stackEmpty 616 | returnStack .= stackEmpty 617 | 618 | setCode $ CodeEval evalExpr localEnv 619 | return MachineStepped 620 | 621 | 622 | 623 | -- | old closure, new closure, current argument stack 624 | -- | we are trying to update the old closure to capture the stuff the new closure 625 | -- | does. So, we create a closure which executes the new closure's code from the 626 | -- | old closure's context. Yes this is mind bending. 627 | -- | rule 17 in the STG paper. 628 | -- heap[addr] = old (vs \n xs -> e) ws_f 629 | -- length (as) < length (xs) 630 | -- new (vs ++ xs1 \n xs2 -> e) (ws_f ++ as) 631 | -- I now understand what this does: this replaces a partially applied function 632 | -- with an equivalent function that doesn't need to evaluate the application 633 | -- That is, write: 634 | -- f = \x y 635 | -- h = f g 636 | -- as 637 | -- h = \y where "x" is replaced by "g" in f's body 638 | -- some form of "partial eta-reduction" 639 | -- 640 | -- 0x2 -> cls: [ {} \u {} -> var:flip {var:tuple} ]; 641 | -- 0x2 -> cls: [ {var:f} \n {var:x, var:y} -> var:f {var:y, var:x} | Free variable vals: val:0x0 ]; 642 | -- Notice how we expanded flip tuple out, and the "tuple" parameter became 643 | -- a free variable. 644 | mkEnterUpdateNewClosure :: Closure -> Closure -> [Value] -> MachineT Closure 645 | mkEnterUpdateNewClosure toUpdate cur as = do 646 | appendLog $ text "updating old closure:" <+> pretty toUpdate $$ 647 | text "with information from closure:" <+> pretty cur 648 | let nStackArgs = length as 649 | let curFreeIds = cur ^. closureLambda ^. lambdaFreeVarIdentifiers 650 | -- xs1 ++ xs2 = xs 651 | let curBoundIds = cur ^. closureLambda . lambdaBoundVarIdentifiers 652 | let (boundToFree, stillBound) = (take nStackArgs curBoundIds, drop nStackArgs curBoundIds) 653 | 654 | appendLog $ text "current all bound variables:" $$ nest 4 ((fmap pretty curBoundIds) & sep) 655 | appendLog $ text "new bound variables to free:" $$ nest 4 ((fmap pretty boundToFree) & sep) 656 | appendLog $ text "new free variable values: " $$ nest 4 ((fmap pretty as) & sep) 657 | appendLog $ text "new bound variables still bound:" $$ nest 4 ((fmap pretty stillBound) & sep) 658 | 659 | return $ cur { 660 | _closureFreeVals = ClosureFreeVals (cur ^. closureFreeVals . getFreeVals ++ as), 661 | _closureLambda = (cur ^. closureLambda) { 662 | _lambdaFreeVarIdentifiers = curFreeIds ++ boundToFree, 663 | _lambdaBoundVarIdentifiers = stillBound 664 | } 665 | } 666 | 667 | -- provide the lambda and the list of free variables for binding 668 | stepCodeEnterIntoNonupdatableClosure :: Addr -> Closure -> MachineT MachineProgress 669 | stepCodeEnterIntoNonupdatableClosure addr closure = do 670 | appendLog $ pretty closure <+> text "is not updatable." 671 | let l = closure ^. closureLambda 672 | let boundVars = l ^. lambdaBoundVarIdentifiers 673 | let freeVars = l ^. lambdaFreeVarIdentifiers 674 | let evalExpr = l ^. lambdaExprNode 675 | 676 | argStack <- use argumentStack 677 | let argStackLength = length argStack 678 | 679 | -- we don't have enough arguments to feed the closure, so we pop the update stack 680 | -- and pull values out 681 | if argStackLength < length boundVars 682 | -- we need to pop the update stack 683 | then do 684 | appendLog $ text "insufficient number of arguments on argument stack." $$ ( 685 | nest 4 (text "needed:" <+> PP.int (length boundVars) <+> text "bound values") $$ 686 | nest 4 (text "had:" <+> PP.int argStackLength <+> text "on argument stack.") $$ 687 | nest 4 (pretty argStack)) 688 | appendLog $ text "looking for update frame to satisfy arguments..." 689 | uf@UpdateFrame { 690 | _updateFrameAddress=addru, 691 | _updateFrameArgumentStack=argStacku, 692 | _updateFrameReturnStack=rsu 693 | } <- updateStackPop 694 | appendLog $ text "found update frame: " $$ pretty uf 695 | 696 | let argStackList = argStack ^. unStack 697 | 698 | toUpdateClosure <- lookupAddrInHeap addru 699 | newClosure <- (mkEnterUpdateNewClosure toUpdateClosure closure argStackList) 700 | heapUpdateAddress addru newClosure 701 | 702 | returnStack .= rsu 703 | argumentStack <>= argStacku 704 | 705 | code .= CodeEnter addr 706 | return MachineStepped 707 | 708 | else do 709 | boundVarVals <- boundVars & length & takeNArgs 710 | let localFreeVals = M.fromList (zip freeVars 711 | (closure ^. closureFreeVals . getFreeVals)) 712 | let localBoundVals = M.fromList (zip boundVars 713 | boundVarVals) 714 | let localEnv = localFreeVals `M.union` localBoundVals 715 | setCode $ CodeEval evalExpr localEnv 716 | return MachineStepped 717 | 718 | 719 | -- | Return the variable if the continuation contains an alternative 720 | -- for it. 721 | continuationGetVariableAlt :: Continuation -> Either StgError (CaseAlt VarName) 722 | continuationGetVariableAlt cont = 723 | let vars = cont ^.. continuationAlts . each . _CaseAltVariable 724 | in 725 | case vars of 726 | [] -> Left (StgErrorCaseAltsHasNoVariable cont) 727 | [v] -> Right v 728 | vs -> Left (StgErrorCaseAltsHasMoreThanOneVariable cont vs) 729 | 730 | caseAltsGetUniqueMatch :: Eq a => [CaseAlt a] -> a -> Maybe (Either StgError (CaseAlt a)) 731 | caseAltsGetUniqueMatch pats val = 732 | let matches = pats ^.. each . filtered (\alt -> alt ^. caseAltLHS == val) 733 | in 734 | case matches of 735 | [] -> Nothing 736 | [alt] -> Just (Right alt) 737 | alts -> Just (Left (StgErrorCaseAltsOverlappingPatterns)) 738 | 739 | stackPop :: Lens' EvalApplyMachineState (Stack a) -> StgError -> MachineT a 740 | stackPop stacklens err = do 741 | isempty <- use (stacklens . to null) 742 | if isempty 743 | then 744 | throwError err 745 | else do 746 | top <- stacklens %%= (\(Stack (x:xs)) -> (x, Stack xs)) 747 | return top 748 | 749 | returnStackPop :: MachineT Continuation 750 | returnStackPop = stackPop returnStack StgErrorReturnStackEmpty 751 | 752 | unwrapAlts :: [CaseAltType] -> Prism' CaseAltType a -> (CaseAltType -> StgError) -> MachineT [a] 753 | unwrapAlts [] p err = return [] 754 | unwrapAlts (a:as) p err = case a ^? p of 755 | Just a -> do 756 | as' <- unwrapAlts as p err 757 | return $ (a:as') 758 | Nothing -> throwError (err a) 759 | 760 | filterEarliestAlt :: Eq a => [CaseAlt a] -> (a -> Bool) -> Maybe (CaseAlt a) 761 | filterEarliestAlt [] _ = Nothing 762 | filterEarliestAlt (c:cs) pred = if pred (c ^. caseAltLHS) 763 | then Just c 764 | else filterEarliestAlt cs pred 765 | 766 | -- | codeReturnInt execution 767 | stepCodeReturnInt :: StgInt -> MachineT MachineProgress 768 | stepCodeReturnInt i = do 769 | cont <- returnStackPop 770 | unwrapped_alts <- unwrapAlts (cont ^. continuationAlts) _CaseAltInt StgErrorExpectedCaseAltInt 771 | let err = StgErrorNoMatchingAltPatternInt i unwrapped_alts 772 | alt <- (filterEarliestAlt unwrapped_alts (== i )) `maybeToMachineT` err 773 | setCode $ CodeEval (alt ^. caseAltRHS) (cont ^. continuationEnv) 774 | return MachineStepped 775 | 776 | genMachineTrace :: EvalApplyMachineState -> ([PushEnterMachineState], Maybe StgError) 777 | genMachineTrace state = 778 | case runMachineT stepMachine state of 779 | Left err -> ([], Just err) 780 | Right (progress, state') -> if progress == MachineHalted 781 | then ([state], Nothing) 782 | else let (traceNext, err) = genMachineTrace state' in 783 | (state':traceNext, err) 784 | 785 | genFinalPushEnterMachineState :: EvalApplyMachineState -> Either StgError PushEnterMachineState 786 | genFinalPushEnterMachineState state = 787 | case runMachineT stepMachine state of 788 | Left err -> Left err 789 | Right (progress, state') -> if progress == MachineHalted 790 | then Right state' 791 | else genFinalPushEnterMachineState state' 792 | -------------------------------------------------------------------------------- /src/StgLanguage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | 5 | module StgLanguage where 6 | 7 | import Control.Monad.Trans.Class 8 | import Control.Lens 9 | -- import Text.PrettyPrint as PP 10 | import ColorUtils 11 | import qualified Data.List.NonEmpty as NE 12 | import Data.Text.Prettyprint.Doc as PP 13 | 14 | 15 | newtype ConstructorName = ConstructorName { _getConstructorName :: String } deriving (Eq, Ord) 16 | makeLenses ''ConstructorName 17 | 18 | instance Show ConstructorName where 19 | show cons = _getConstructorName cons 20 | 21 | instance Pretty ConstructorName where 22 | pretty = pretty . show 23 | 24 | newtype VarName = VarName { _unVarName :: String } deriving(Ord, Eq) 25 | 26 | instance Pretty VarName where 27 | pretty var = mkStyleTag (pretty "var:") <+> (pretty (_unVarName var)) 28 | 29 | instance Show VarName where 30 | show = prettyToString 31 | 32 | newtype RawNumber = RawNumber { _getRawNumber :: String } deriving(Eq, Ord) 33 | makeLenses ''RawNumber 34 | 35 | 36 | instance Pretty RawNumber where 37 | pretty (RawNumber num) = mkStyleTag (pretty "rawnum:") PP.<> pretty num PP.<> pretty "#" 38 | 39 | instance Show RawNumber where 40 | show = prettyToString 41 | 42 | newtype StgInt = StgInt { unStgInt :: Int } deriving(Show, Eq) 43 | 44 | instance Pretty StgInt where 45 | pretty (StgInt i) = pretty . show $ i 46 | 47 | data Atom = AtomInt !StgInt | AtomVarName !VarName deriving(Show) 48 | 49 | instance Pretty Atom where 50 | pretty (AtomInt n) = pretty n 51 | pretty (AtomVarName var) = pretty var 52 | 53 | data Binding = Binding { 54 | _bindingName :: !VarName, 55 | _bindingLambda :: !Lambda 56 | } 57 | type Program = [Binding] 58 | 59 | 60 | 61 | -- | collect `Binding` in the expression 62 | collectBindingsInExpr :: ExprNode -> [Binding] 63 | collectBindingsInExpr (ExprNodeBinop l _ r) = collectBindingsInExpr l ++ collectBindingsInExpr r 64 | collectBindingsInExpr (ExprNodeFnApplication _ _) = [] 65 | collectBindingsInExpr (ExprNodeConstructor _) = [] 66 | collectBindingsInExpr (ExprNodeLet _ bindings expr) = 67 | (bindings >>= collectBindingsInBinding) ++ collectBindingsInExpr expr 68 | collectBindingsInExpr (ExprNodeCase case' alts) = collectBindingsInExpr case' 69 | collectBindingsInExpr (ExprNodeInt _ ) = [] 70 | 71 | -- | collect bindings in a binding 72 | collectBindingsInBinding :: Binding -> [Binding] 73 | collectBindingsInBinding b@(Binding _ lambda) = b:(collectBindingsInExpr . _lambdaExprNode $ lambda) 74 | 75 | 76 | 77 | -- | collect constructors in case alts 78 | collectConstructorNamesInCaseAlt :: CaseAltType -> [ConstructorName] 79 | collectConstructorNamesInCaseAlt 80 | (CaseAltConstructor 81 | (CaseAlt{ 82 | _caseAltLHS=ConstructorPatternMatch c _ 83 | })) = [c] 84 | collectConstructorNamesInCaseAlt _ = [] 85 | 86 | 87 | -- | collect constructors in an expression 88 | collectConstructorNamesInExpr :: ExprNode -> [ConstructorName] 89 | collectConstructorNamesInExpr (ExprNodeBinop l _ r) = 90 | collectConstructorNamesInExpr l ++ collectConstructorNamesInExpr r 91 | collectConstructorNamesInExpr (ExprNodeFnApplication _ _) = [] 92 | collectConstructorNamesInExpr (ExprNodeConstructor (Constructor name _)) = [name] 93 | collectConstructorNamesInExpr (ExprNodeLet _ bindings expr) = 94 | (bindings >>= collectConstructorNamesInBinding) ++ collectConstructorNamesInExpr expr 95 | collectConstructorNamesInExpr (ExprNodeCase case' alts) = 96 | collectConstructorNamesInExpr case' ++ (alts >>= collectConstructorNamesInCaseAlt) 97 | collectConstructorNamesInExpr (ExprNodeInt _ ) = [] 98 | 99 | -- | collect constructors in the binding 100 | collectConstructorNamesInBinding :: Binding -> [ConstructorName] 101 | collectConstructorNamesInBinding (Binding _ lambda) = 102 | collectConstructorNamesInExpr . _lambdaExprNode $ lambda 103 | 104 | data Constructor = Constructor { _constructorName :: !ConstructorName, 105 | _constructorAtoms :: ![Atom] 106 | } 107 | 108 | instance Pretty Constructor where 109 | pretty (Constructor name idents) = pretty name <+> (idents & map pretty & hsep) 110 | 111 | instance Show Constructor where 112 | show = prettyToString 113 | 114 | 115 | data IsLetRecursive = LetRecursive | LetNonRecursive deriving(Show, Eq) 116 | 117 | 118 | data BinaryOperator = Plus | Minus | Multiply | Divide deriving(Eq) 119 | instance Show BinaryOperator where 120 | show Plus = "+" 121 | show Minus = "-" 122 | show Multiply = "*" 123 | show Divide = "/" 124 | 125 | instance Pretty BinaryOperator where 126 | pretty = pretty . show 127 | 128 | data ExprNode = ExprNodeBinop !ExprNode !BinaryOperator !ExprNode | 129 | ExprNodeFnApplication !VarName ![Atom] | 130 | ExprNodeConstructor !Constructor | 131 | ExprNodeLet !IsLetRecursive ![Binding] !ExprNode | 132 | ExprNodeCase !ExprNode ![CaseAltType] | 133 | ExprNodeInt !StgInt 134 | 135 | 136 | 137 | data CaseAlt lhs = CaseAlt { 138 | _caseAltLHS :: !lhs, 139 | _caseAltRHS :: !ExprNode 140 | } 141 | 142 | 143 | instance Pretty lhs => Pretty (CaseAlt lhs) where 144 | pretty CaseAlt{..} = pretty _caseAltLHS <+> 145 | pretty "->" <+> 146 | pretty _caseAltRHS 147 | 148 | instance Pretty lhs => Show (CaseAlt lhs) where 149 | show = prettyToString 150 | 151 | data ConstructorPatternMatch = ConstructorPatternMatch ConstructorName [VarName] deriving(Eq) 152 | 153 | instance Pretty ConstructorPatternMatch where 154 | pretty (ConstructorPatternMatch consName vars) = 155 | pretty consName <+> (fmap pretty vars & punctuate comma & hsep & braces) 156 | 157 | data CaseAltType = -- | match with a constructor: ConstructorName bindNames* 158 | CaseAltConstructor !(CaseAlt ConstructorPatternMatch) | 159 | -- | match with a number: 10 -> e 160 | CaseAltInt !(CaseAlt StgInt) | 161 | -- | match with a variable: x -> e 162 | CaseAltVariable !(CaseAlt VarName) 163 | 164 | 165 | 166 | instance Pretty CaseAltType where 167 | pretty (CaseAltConstructor a) = 168 | pretty (_caseAltLHS a) <+> 169 | pretty "->" <+> 170 | pretty (_caseAltRHS a) 171 | 172 | pretty (CaseAltInt a) = pretty a 173 | pretty (CaseAltVariable a) = pretty a 174 | 175 | instance Show CaseAltType where 176 | show = prettyToString 177 | 178 | data Lambda = Lambda { 179 | _lambdaShouldUpdate :: !Bool, 180 | _lambdaFreeVarIdentifiers :: ![VarName], 181 | _lambdaBoundVarIdentifiers :: ![VarName], 182 | _lambdaExprNode :: !ExprNode 183 | } 184 | 185 | 186 | 187 | instance Pretty Lambda where 188 | pretty (Lambda{..}) = 189 | freedoc <+> updatedoc <+> 190 | bounddoc <+> pretty "->" <+> 191 | (pretty _lambdaExprNode) where 192 | freedoc = (map pretty _lambdaFreeVarIdentifiers) & punctuate comma & hsep & braces 193 | bounddoc = (map pretty _lambdaBoundVarIdentifiers) & punctuate comma & hsep & braces 194 | updatedoc = pretty '\\' <> (if _lambdaShouldUpdate then pretty 'u' else pretty 'n') 195 | 196 | instance Show Lambda where 197 | show = prettyToString 198 | 199 | 200 | makeLenses ''Binding 201 | makeLenses ''Lambda 202 | makeLenses ''CaseAlt 203 | makeLenses ''Atom 204 | makePrisms ''ExprNode 205 | makePrisms ''CaseAltType 206 | makeLenses ''VarName 207 | makeLenses ''Constructor 208 | 209 | 210 | instance Pretty ExprNode where 211 | pretty (ExprNodeFnApplication fnName atoms) = 212 | (pretty fnName) <+> 213 | (map pretty atoms & punctuate comma & hsep & braces) 214 | 215 | pretty (ExprNodeBinop eleft tok eright) = (pretty tok) <+> 216 | (pretty eleft) <+> 217 | (pretty eright) 218 | pretty (ExprNodeLet isrecursive bindings expr) = 219 | letname <+> 220 | vcat [bindingsstr, 221 | (pretty "in"), 222 | (expr & pretty)] 223 | where 224 | letname = pretty (if isrecursive == LetNonRecursive then "let" else "letrec") 225 | bindingsstr = map pretty bindings & vcat 226 | 227 | 228 | pretty (ExprNodeConstructor constructor) = pretty constructor 229 | 230 | pretty (ExprNodeInt n) = pretty n 231 | pretty (ExprNodeCase e alts) = 232 | pretty "case" <+> pretty e <+> pretty "of" <+> 233 | pretty "{" <+> (mkNest altsDoc) <+> pretty "}" where 234 | altsDoc = fmap pretty alts & vcat 235 | 236 | instance Show ExprNode where 237 | show = prettyToString 238 | 239 | 240 | instance Pretty Binding where 241 | pretty (Binding{..}) = 242 | (pretty _bindingName) <+> equals <+> 243 | (_bindingLambda & pretty) 244 | 245 | 246 | instance Show Binding where 247 | show = prettyToString 248 | -------------------------------------------------------------------------------- /src/StgParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | -- http://lpaste.net/355742 7 | -- c_wraith's notes on how to use custom token types. 8 | 9 | module StgParser where 10 | import StgLanguage 11 | 12 | import Control.Monad (void) 13 | 14 | import Data.Set as Set 15 | import Data.List.NonEmpty 16 | 17 | import Control.Applicative 18 | 19 | import Control.Lens 20 | 21 | import Text.Trifecta as TR 22 | import Text.Parser.Token.Highlight 23 | import Text.Parser.Token.Style 24 | import Text.Trifecta.Delta 25 | 26 | 27 | 28 | import Text.Parser.Char 29 | import Text.Parser.Combinators 30 | import Text.Parser.Token 31 | 32 | import Data.ByteString.Char8 as BS 33 | 34 | import qualified Data.HashSet as HashSet 35 | 36 | () = flip () 37 | 38 | -- | Syntax rules for parsing variable-looking like identifiers. 39 | varId :: IdentifierStyle Parser 40 | varId = IdentifierStyle 41 | { _styleName = "variable" 42 | , _styleStart = lower <|> char '_' 43 | , _styleLetter = alphaNum <|> oneOf "_'#" 44 | , _styleReserved = HashSet.fromList ["let", "letrec", "in", "case", "of", "default"] 45 | , _styleHighlight = Identifier 46 | , _styleReservedHighlight = ReservedIdentifier } 47 | 48 | -- | Parse a variable identifier. Variables start with a lower-case letter or 49 | -- @_@, followed by a string consisting of alphanumeric characters or @'@, @_@. 50 | varNamep :: Parser VarName 51 | varNamep = "varname" (VarName <$> (ident varId)) 52 | 53 | 54 | stgIntp :: Parser StgInt 55 | stgIntp = "int" do 56 | number <- integer 57 | char '#' 58 | spaces 59 | return $ StgInt (fromIntegral number) 60 | 61 | constructorNamep :: Parser ConstructorName 62 | constructorNamep = "constructor name" do 63 | c <- upper 64 | rest <- many (alphaNum <|> oneOf ['_', '-', '?']) 65 | spaces 66 | return $ ConstructorName (c:rest) 67 | 68 | 69 | updatep :: Parser Bool 70 | updatep = "update token" do 71 | isUpdatable <- (try (const True <$> symbol "\\u")) <|> (const False <$> symbol "\\n") 72 | return isUpdatable 73 | 74 | 75 | atomp :: Parser Atom 76 | atomp = "atom" (identp <|> numberp) 77 | where 78 | identp = AtomVarName <$> varNamep 79 | numberp = AtomInt <$> stgIntp 80 | 81 | 82 | 83 | 84 | -- "{" atom1, atom2 .. atomn "}" | {} 85 | atomListp :: Parser [Atom] 86 | atomListp = "atom list" do 87 | atoms <- braces (sepBy atomp (symbol ",")) 88 | return atoms 89 | 90 | -- Function application: fn_name "{" atom1 "," atom2 ... "}" | {} 91 | applicationp :: Parser ExprNode 92 | applicationp = "application" do 93 | fn_name <- varNamep 94 | atoms <- atomListp 95 | return $ ExprNodeFnApplication fn_name atoms 96 | 97 | 98 | 99 | -- let(rec) parser: ("let" | "letrec") ( ";")+ "in" 100 | letp :: Parser ExprNode 101 | letp = "let" do 102 | -- isLetRecursive <- (const LetNonRecursive <$> symbol "let" ) <|> (const LetRecursive <$> symbol "letrec") 103 | symbol "let" 104 | let isLetRecursive = LetNonRecursive 105 | bindings <- sepEndBy1 bindingp (symbol ";") 106 | symbol "in" 107 | inExpr <- exprp 108 | return $ ExprNodeLet isLetRecursive bindings inExpr 109 | 110 | 111 | 112 | caseConstructorAltp :: Parser CaseAltType 113 | caseConstructorAltp = "constructor alt" do 114 | consname <- constructorNamep 115 | consvars <- variableListp 116 | symbol "->" 117 | rhs <- exprp 118 | let patternMatch = ConstructorPatternMatch consname consvars 119 | 120 | return $ CaseAltConstructor (CaseAlt patternMatch rhs) 121 | 122 | caseStgIntAltp :: Parser CaseAltType 123 | caseStgIntAltp = "int alt" do 124 | num <- stgIntp 125 | symbol "->" 126 | rhs <- exprp 127 | return $ CaseAltInt (CaseAlt num rhs) 128 | 129 | 130 | caseAltp :: Parser CaseAltType 131 | caseAltp = "case alt" (caseConstructorAltp <|> caseStgIntAltp) 132 | 133 | casep :: Parser ExprNode 134 | casep = "case" do 135 | symbol "case" 136 | e <- exprp 137 | symbol "of" 138 | alts <- sepEndBy1 caseAltp (symbol ";") 139 | return $ ExprNodeCase e alts 140 | 141 | 142 | parenExprp :: Parser ExprNode 143 | parenExprp = "parenthesised expression" do 144 | symbol "(" 145 | expr <- exprp 146 | symbol ")" 147 | return expr 148 | 149 | constructorp :: Parser ExprNode 150 | constructorp = "constructor" do 151 | consName <- constructorNamep 152 | params <- atomListp 153 | 154 | return $ ExprNodeConstructor (StgLanguage.Constructor consName params) 155 | 156 | 157 | exprp :: Parser ExprNode 158 | exprp = "expression" 159 | (try letp <|> 160 | try applicationp <|> 161 | try constructorp <|> 162 | -- FIXME: factor out "try" into a separate thing 163 | try casep <|> 164 | try (ExprNodeInt <$> stgIntp) <|> 165 | try parenExprp) 166 | 167 | 168 | -- VarName list: {" id1 "," id2 "," .. idn "} | "{}" 169 | variableListp ::Parser [VarName] 170 | variableListp = "variable name list" do 171 | braces (sepEndBy varNamep (symbol ",")) 172 | 173 | 174 | -- Lambda form 175 | -- "->" 176 | -- {x y} \n {z} -> f x y z 177 | lambdap :: Parser Lambda 178 | lambdap = "lambda form" do 179 | freeVars <- variableListp 180 | shouldUpdate <- updatep 181 | boundVars <- variableListp 182 | symbol "->" 183 | rhs <- exprp 184 | return Lambda { 185 | _lambdaShouldUpdate = shouldUpdate, 186 | _lambdaFreeVarIdentifiers = freeVars, 187 | _lambdaBoundVarIdentifiers = boundVars, 188 | _lambdaExprNode = rhs 189 | } 190 | 191 | 192 | -- = 193 | bindingp :: Parser Binding 194 | bindingp = "binding" do 195 | name <- varNamep 196 | symbol "=" 197 | lambda <- lambdap 198 | return $ Binding name lambda 199 | 200 | 201 | 202 | stgp :: Parser Program 203 | stgp = sepEndBy1 definep (symbol ";") where 204 | definep = do 205 | symbol "define" 206 | bindingp 207 | 208 | parseStg :: String -> Result Program 209 | parseStg string = TR.parseString (spaces *> stgp) (Directed (BS.pack string) 0 0 0 0) string 210 | 211 | parseExpr :: String -> Result ExprNode 212 | parseExpr string = TR.parseString (spaces *> exprp) (Directed (BS.pack string) 0 0 0 0) string 213 | -------------------------------------------------------------------------------- /src/StgPushEnterMachine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE InstanceSigs #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# LANGUAGE DeriveTraversable #-} 7 | 8 | module StgPushEnterMachine where 9 | import StgLanguage 10 | 11 | 12 | import Data.Text.Prettyprint.Doc as PP 13 | import Numeric 14 | import qualified Data.Map as M 15 | import Control.Monad.Trans.Class 16 | import Control.Lens 17 | import Data.Map.Lens 18 | import Control.Applicative 19 | import Data.Either.Utils 20 | import Control.Monad.State 21 | import Control.Monad.Except 22 | import Data.Traversable 23 | import Data.Foldable 24 | 25 | import ColorUtils 26 | 27 | -- for <> 28 | import Data.Monoid 29 | 30 | -- hoistError 31 | import Control.Monad.Error.Hoist 32 | 33 | -- readMaybe 34 | import Data.String.Utils 35 | 36 | 37 | 38 | data Continuation = Continuation { _continuationAlts :: ![CaseAltType], 39 | _continuationEnv :: !LocalEnvironment 40 | } 41 | 42 | instance Pretty Continuation where 43 | pretty Continuation{..} = vsep [pretty "alts:", 44 | _continuationAlts & map pretty & vcat] 45 | 46 | instance Show Continuation where 47 | show = prettyToString 48 | 49 | 50 | data UpdateFrame = UpdateFrame { 51 | -- | the argument stack that was present when the update frame was created. 52 | _updateFrameArgumentStack :: !ArgumentStack, 53 | -- | The return stack that was present when the update frame was created. 54 | _updateFrameReturnStack :: !ReturnStack, 55 | -- | The address of the heap closure to be updated. 56 | _updateFrameAddress :: Addr 57 | } 58 | instance Pretty UpdateFrame where 59 | pretty UpdateFrame{..} = 60 | indent 4 (vsep [pretty "Argument Stack: " 61 | , pretty _updateFrameArgumentStack 62 | , pretty "Return Stack: " 63 | , pretty _updateFrameReturnStack]) 64 | 65 | 66 | -- | Represents an STG Address 67 | newtype Addr = Addr { _getAddr :: Int } deriving(Eq, Ord) 68 | instance Pretty Addr where 69 | pretty addr = styleAddr PP.<> (pretty $ "0x" ++ (addr & _getAddr & (\x -> showHex x ""))) PP.<> styleReset 70 | 71 | instance Show Addr where 72 | show = prettyToString 73 | 74 | data Value = ValueAddr Addr | ValuePrimInt Int 75 | deriving (Eq, Ord) 76 | 77 | 78 | instance Pretty Value where 79 | pretty (ValueAddr addr) = mkStyleTag (pretty "val:") PP.<> pretty addr 80 | pretty (ValuePrimInt int) = mkStyleTag (pretty "val:") PP.<> pretty int PP.<> pretty "#" 81 | 82 | instance Show Value where 83 | show = prettyToString 84 | 85 | -- | Stack of 'Value' 86 | newtype Stack a = Stack { _unStack :: [a] } deriving(Functor, Monoid, Foldable, Traversable) 87 | 88 | stackLength :: Stack a -> Int 89 | stackLength = length . _unStack 90 | 91 | stackEmpty :: Stack a 92 | stackEmpty = Stack [] 93 | 94 | instance Pretty a => Pretty (Stack a) where 95 | pretty (Stack []) = pretty "EMPTY" 96 | pretty (Stack xs) = 97 | vsep 98 | [pretty "count: " <+> pretty (length xs), 99 | mkStyleAnnotation (pretty "TOP"), 100 | zipWith (<+>) (fmap intlabel [1..]) (fmap pretty xs) & vsep, 101 | mkStyleAnnotation (pretty "BOTTOM")] 102 | where 103 | intlabel :: Int -> Doc ann 104 | intlabel i = mkStyleAnnotation (pretty "|" <+> pretty i <+> colon) 105 | 106 | instance Pretty a => Show (Stack a) where 107 | show = prettyToString 108 | 109 | type ArgumentStack = Stack Value 110 | type ReturnStack = Stack Continuation 111 | type UpdateStack = Stack UpdateFrame 112 | type Heap = M.Map Addr Closure 113 | 114 | 115 | -- | Maps VarName names to addresses of the closures 116 | type GlobalEnvironment = M.Map VarName Addr 117 | 118 | -- | has bindings of free variables with a 'LambdaForm' 119 | newtype ClosureFreeVals = ClosureFreeVals { _getFreeVals :: [Value] } deriving(Show) 120 | instance Pretty ClosureFreeVals where 121 | pretty freeVars = _getFreeVals freeVars & map pretty & punctuate comma & hsep 122 | data Closure = Closure { 123 | _closureLambda :: !Lambda, 124 | _closureFreeVals :: !ClosureFreeVals 125 | } deriving (Show) 126 | 127 | instance Pretty Closure where 128 | -- TODO: allow closure to invoke a custom renderer for free variables in the lambdaForm 129 | pretty (Closure{..}) = (mkStyleTag (pretty "cls:")) <+> pretty "[" 130 | <+> pretty _closureLambda PP.<> envdoc <+> pretty "]" where 131 | envdoc = if length ( _getFreeVals ( _closureFreeVals)) == 0 132 | then pretty "" 133 | else pretty " | Free variable vals: " <+> pretty _closureFreeVals 134 | 135 | 136 | 137 | type LocalEnvironment = M.Map VarName Value 138 | 139 | instance (Pretty k, Pretty v) => Pretty (M.Map k v) where 140 | pretty m = 141 | fmap (uncurry mkKvDoc) (M.toList m) & punctuate semi & vsep where 142 | mkKvDoc key val = pretty key <+> pretty "->" <+> pretty val 143 | 144 | data Code = CodeEval ExprNode LocalEnvironment | 145 | CodeEnter Addr | 146 | CodeUninitialized | 147 | CodeReturnConstructor Constructor [Value] | 148 | CodeReturnInt StgInt deriving(Show) 149 | 150 | instance Pretty Code where 151 | pretty (CodeEval expr env) = pretty "Eval" <+> braces (pretty expr) <+> pretty "|Local:" <+> braces(pretty env) 152 | pretty (CodeEnter addr) = pretty "Enter" <+> pretty addr 153 | pretty (CodeReturnConstructor cons values) = 154 | pretty "ReturnConstructor" <+> 155 | (pretty (cons ^. constructorName) <+> 156 | (values & map pretty & punctuate comma & hsep & braces) & parens) 157 | pretty (CodeReturnInt i) = pretty "ReturnInt" <+> pretty i 158 | 159 | 160 | newtype Log = Log { unLog :: [Doc ()] } deriving(Monoid) 161 | 162 | instance Show Log where 163 | show l = unLog l & vsep & docToString 164 | 165 | data PushEnterMachineState = PushEnterMachineState { 166 | _argumentStack :: !ArgumentStack, 167 | _returnStack :: !ReturnStack, 168 | _updateStack :: !UpdateStack, 169 | _heap :: !Heap, 170 | _globalEnvironment :: !GlobalEnvironment, 171 | _code :: !Code, 172 | _currentLog :: !Log, 173 | _oldLog :: !Log 174 | } 175 | 176 | 177 | instance Pretty PushEnterMachineState where 178 | pretty PushEnterMachineState{..} = 179 | vsep [ 180 | heading (pretty "@@@ Code:"), code, line, 181 | heading (pretty "@@@ Args:"), argsDoc, line, 182 | heading (pretty "@@@ Return:"), returnDoc, line, 183 | heading (pretty "@@@ Update:"), updateDoc, line, 184 | heading (pretty "@@@ Heap:"), heapDoc, line, 185 | heading (pretty "@@@ Env:"), globalEnvDoc, line, 186 | heading (pretty "---")] where 187 | argsDoc = _argumentStack & pretty 188 | returnDoc = _returnStack & pretty 189 | updateDoc = _updateStack & pretty 190 | heapDoc = _heap & pretty 191 | globalEnvDoc = _globalEnvironment & pretty 192 | code = _code & pretty 193 | currentLogDoc = _currentLog & unLog & vsep 194 | 195 | instance Show PushEnterMachineState where 196 | show = prettyToString 197 | 198 | data MachineProgress = MachineStepped | MachineHalted deriving(Show, Eq) 199 | 200 | newtype MachineT a = MachineT { unMachineT :: ExceptT StgError (State PushEnterMachineState) a } 201 | deriving (Functor, Applicative, Monad 202 | , MonadState PushEnterMachineState 203 | , MonadError StgError) 204 | 205 | -- | All possible errors when interpreting STG code. 206 | data StgError = 207 | -- | 'compileProgram' could not find main 208 | StgErrorUnableToFindMain | 209 | -- | 'lookupVariable' failed 210 | StgErrorEnvLookupFailed !VarName !LocalEnvironment !GlobalEnvironment | 211 | -- | 'lookupAddrInHeap' failed 212 | StgErrorHeapLookupFailed !Addr !Heap | 213 | -- | 'rawNumberToValue' failed 214 | StgErrorUnableToMkPrimInt !RawNumber | 215 | -- | 'takeNArgs' failed 216 | StgErrorNotEnoughArgsOnStack !Int !ArgumentStack | 217 | -- | 'continuationGetVariable' found no variable 218 | StgErrorCaseAltsHasNoVariable !Continuation | 219 | -- | 'continuationGetVariable' found too many variables 220 | StgErrorCaseAltsHasMoreThanOneVariable !Continuation ![CaseAlt VarName] | 221 | -- | 'caseAltsGetUniqueMatch' found overlapping patterns 222 | -- | FIXME: find a better repr for the CaseAlt. currently cumbersome 223 | StgErrorCaseAltsOverlappingPatterns | 224 | -- | `returnStackPop` finds no continuation to return to 225 | StgErrorReturnStackEmpty | 226 | -- | `unwrapAlts` failed, unable to unwrap raw number 227 | StgErrorExpectedCaseAltInt !CaseAltType | 228 | -- | `unwrapAlts` failed, unable to unwrap Constructor 229 | StgErrorExpectedCaseAltConstructor Constructor !CaseAltType | 230 | -- | 'xxx' failed, no matching pattern match found 231 | StgErrorNoMatchingAltPatternInt StgInt [CaseAlt StgInt] | 232 | -- | 'xxx' failed, no matching pattern match found 233 | StgErrorNoMatchingAltPatternConstructor Constructor [CaseAlt ConstructorPatternMatch] | 234 | -- | tried to pop empty update frame 235 | StgErrorUpdateStackEmpty | 236 | -- | tried to update an address where no previous value exists 237 | StgErrorHeapUpdateHasNoPreviousValue Addr deriving(Show) 238 | 239 | makeLenses ''ClosureFreeVals 240 | makePrisms ''Value 241 | makeLenses ''Closure 242 | makePrisms ''Code 243 | makeLenses ''PushEnterMachineState 244 | makeLenses ''Addr 245 | makeLenses ''Continuation 246 | makeLenses ''Stack 247 | makeLenses ''UpdateFrame 248 | 249 | uninitializedPushEnterMachineState :: PushEnterMachineState 250 | uninitializedPushEnterMachineState = PushEnterMachineState { 251 | _argumentStack=stackEmpty, 252 | _returnStack = stackEmpty, 253 | _updateStack = stackEmpty, 254 | _heap=M.empty, 255 | _globalEnvironment=M.empty, 256 | _code=CodeUninitialized, 257 | _oldLog=mempty, 258 | _currentLog=mempty 259 | } 260 | 261 | maybeToMachineT :: Maybe a -> StgError -> MachineT a 262 | maybeToMachineT (Nothing) err = throwError err 263 | maybeToMachineT (Just a) err = return a 264 | 265 | runMachineT :: MachineT a -> PushEnterMachineState -> Either StgError (a, PushEnterMachineState) 266 | runMachineT machineT state = let (mVal, machineState) = runState (runExceptT . unMachineT $ machineT) state in 267 | -- TODO: refactor with fmap 268 | case mVal of 269 | Left err -> Left err 270 | Right val -> Right (val, machineState) 271 | 272 | 273 | allocateBinding :: LocalEnvironment -> Binding -> MachineT (VarName, Addr) 274 | allocateBinding localenv binding = do 275 | let lambda = binding ^. bindingLambda 276 | let name = binding ^. bindingName 277 | addr <- (mkClosureFromLambda lambda localenv) >>= allocateClosureOnHeap 278 | return (name, addr) 279 | 280 | gVarNamesToIntIntrinsics :: M.Map VarName (Int -> Int -> Int) 281 | gVarNamesToIntIntrinsics = M.fromList $ [(VarName "plus#", (+))] 282 | 283 | -- HACK: I'm mapping intrinsics to negative addresses. 284 | -- Ideally, this should be cleaner but I really don't care right now 285 | -- mapIntrinsicsToAddrs :: MachineT () 286 | -- mapIntrinsicsToAddrs = do 287 | -- for_ zip ([-1, -2,..](M.keys gVarNamesToIntIntrinsics) (\(i, name) -> globalEnvironment %= (at name) .~ Just i) 288 | 289 | 290 | -- allocate the bindings on the heap, and return the mapping 291 | -- between variable names to addresses 292 | compileProgram :: Program -> Either StgError PushEnterMachineState 293 | compileProgram prog = snd <$> (runMachineT setupBindings uninitializedPushEnterMachineState) 294 | where 295 | setupBindings :: MachineT () 296 | setupBindings = do 297 | let localenv = M.empty -- when machine starts, no local env. 298 | nameAddrPairs <- for prog (allocateBinding localenv) :: MachineT [(VarName, Addr)] 299 | globalEnvironment .= M.fromList nameAddrPairs 300 | -- Do I actually need this? mapIntrinsicsToAddrs 301 | 302 | mainAddr <- use globalEnvironment >>= (\x -> maybeToMachineT (x ^. at (VarName "main")) StgErrorUnableToFindMain) :: MachineT Addr 303 | -- NOTE: this is different from STG paper. Does this even work? 304 | setCode $ CodeEnter mainAddr 305 | 306 | isExprPrimitive :: ExprNode -> Bool 307 | isExprPrimitive (ExprNodeInt _) = True 308 | isExprPrimitive _ = False 309 | 310 | isPushEnterMachineStateFinal :: PushEnterMachineState -> Bool 311 | isPushEnterMachineStateFinal m = case m ^. code of 312 | (CodeEval expr _) -> isExprPrimitive expr 313 | _ -> False 314 | 315 | -- | Try to lookup 'VarName' in the local & global environments. Fail if unable to lookup. 316 | lookupVariable :: LocalEnvironment -> VarName -> MachineT Value 317 | lookupVariable localEnv ident = do 318 | globalEnv <- use globalEnvironment 319 | let localLookup = (localEnv ^. at ident) 320 | let globalLookup = (ValueAddr <$> (globalEnv ^. at ident)) 321 | 322 | let errormsg = StgErrorEnvLookupFailed ident localEnv globalEnv 323 | maybeToEither errormsg (localLookup <|> globalLookup) 324 | 325 | 326 | stgIntToValue :: StgInt -> Value 327 | stgIntToValue si = ValuePrimInt (unStgInt si) 328 | 329 | lookupAtom :: LocalEnvironment -> Atom -> MachineT Value 330 | lookupAtom _ (AtomInt r) = return $ stgIntToValue r 331 | lookupAtom localEnv (AtomVarName ident) = lookupVariable localEnv ident 332 | 333 | 334 | 335 | 336 | mkClosureFromLambda :: Lambda -> LocalEnvironment -> MachineT Closure 337 | mkClosureFromLambda lambda localenv = 338 | do 339 | freeVarVals <- for (lambda ^. lambdaFreeVarIdentifiers) (lookupVariable localenv) 340 | let cls = Closure { 341 | _closureLambda = lambda, 342 | _closureFreeVals = ClosureFreeVals (freeVarVals) 343 | } 344 | return cls 345 | 346 | allocateClosureOnHeap :: Closure -> MachineT Addr 347 | allocateClosureOnHeap cls = do 348 | count <- use (heap . to (M.size)) 349 | heap %= (at (Addr count) .~ Just cls) 350 | return (Addr count) 351 | 352 | 353 | lookupAddrInHeap :: Addr -> MachineT Closure 354 | lookupAddrInHeap addr = do 355 | machineHeap <- use heap 356 | let mclosure = machineHeap ^. at addr :: Maybe Closure 357 | let errormsg = StgErrorHeapLookupFailed addr machineHeap :: StgError 358 | mclosure `maybeToMachineT` errormsg 359 | 360 | -- pop n values off the argument stack 361 | takeNArgs :: Int -> MachineT [Value] 362 | takeNArgs n = do 363 | appendLog $ pretty "popping" <+> pretty n <+> pretty "off of the argument stack" 364 | 365 | argStackList <- use (argumentStack . unStack) 366 | if length argStackList < n 367 | then do 368 | appendLog $ pretty "length of argument stack:" <+> pretty (length argStackList) <+> pretty "< n:" <+> pretty n 369 | throwError $ StgErrorNotEnoughArgsOnStack n (Stack argStackList) 370 | else do 371 | let args = take n argStackList 372 | argumentStack .= Stack (drop n argStackList) 373 | return args 374 | 375 | 376 | stepMachine :: MachineT MachineProgress 377 | stepMachine = do 378 | code <- use code 379 | 380 | nowOldLog <- use currentLog 381 | oldLog <>= nowOldLog 382 | currentLog .= mempty 383 | appendLog $ pretty "evaluating code:" <+> pretty code 384 | 385 | case code of 386 | CodeEval f local -> stepCodeEval local f 387 | CodeEnter addr -> stepCodeEnter addr 388 | CodeReturnInt i -> stepCodeReturnInt i 389 | CodeReturnConstructor cons consvals -> stepCodeReturnConstructor cons consvals 390 | 391 | 392 | setCode :: Code -> MachineT () 393 | setCode c = do 394 | appendLog $ pretty "setting code to: " <+> pretty c 395 | code .= c 396 | 397 | updateStackPop :: MachineT UpdateFrame 398 | updateStackPop = stackPop updateStack StgErrorUpdateStackEmpty 399 | 400 | 401 | -- TODO: find out how to make this look nicer 402 | heapUpdateAddress :: Addr -> Closure -> MachineT () 403 | heapUpdateAddress addr cls = do 404 | appendLog $ vsep [pretty "updating heap at address:" <+> pretty addr <+> pretty "with closure:", 405 | indent 4 (pretty "new closure:" <+> pretty cls)] 406 | h <- use heap 407 | case h ^. at addr of 408 | Nothing -> do 409 | appendError $ pretty "heap does not contain address:" <+> pretty addr 410 | throwError $ StgErrorHeapUpdateHasNoPreviousValue addr 411 | Just oldcls -> do 412 | let h' = at addr .~ Just cls $ h 413 | heap .= h' 414 | return () 415 | 416 | -- | create the standard closure for a constructor 417 | -- | << (freeVarIds \n {} -> c freeVarIds), consVals >> 418 | _mkConstructorClosure :: Constructor -> [Value] -> Closure 419 | _mkConstructorClosure c consVals = Closure { 420 | _closureLambda = Lambda { 421 | _lambdaShouldUpdate = False, 422 | _lambdaBoundVarIdentifiers = [], 423 | _lambdaFreeVarIdentifiers = freeVarIds, 424 | _lambdaExprNode = ExprNodeConstructor cons 425 | }, 426 | _closureFreeVals = ClosureFreeVals consVals 427 | } 428 | where 429 | freeVarIds = map (VarName . (\x -> "id" ++ show x)) [1..(length consVals)] 430 | cons = Constructor (c ^. constructorName) (map AtomVarName freeVarIds) 431 | 432 | stepCodeUpdatableReturnConstructor :: Constructor -> [Value] -> MachineT MachineProgress 433 | stepCodeUpdatableReturnConstructor cons values = do 434 | appendLog $ pretty "using updatable return constructor." 435 | frame <- updateStackPop 436 | 437 | let as = frame ^. updateFrameArgumentStack 438 | let rs = frame ^. updateFrameReturnStack 439 | let addr = frame ^. updateFrameAddress 440 | 441 | returnStack .= rs 442 | argumentStack .= as 443 | 444 | let consClosure = _mkConstructorClosure cons values 445 | heapUpdateAddress addr (consClosure) 446 | 447 | return $ MachineStepped 448 | 449 | 450 | stepCodeNonUpdatableReturnConstructor :: Constructor -> [Value] -> MachineT MachineProgress 451 | stepCodeNonUpdatableReturnConstructor cons values = do 452 | appendLog $ pretty "using non-updatable return constructor." 453 | returnStackEmpty <- use $ returnStack . to null 454 | if returnStackEmpty then 455 | return MachineHalted 456 | else do 457 | cont <- returnStackPop 458 | 459 | let unwrapErr = StgErrorExpectedCaseAltConstructor cons 460 | unwrapped_alts <- unwrapAlts (cont ^. continuationAlts) _CaseAltConstructor unwrapErr 461 | 462 | let filterErr = StgErrorNoMatchingAltPatternConstructor cons unwrapped_alts 463 | let consname = cons ^. constructorName 464 | let pred (ConstructorPatternMatch name _) = name == consname 465 | 466 | matchingAlt <- (filterEarliestAlt unwrapped_alts pred) `maybeToMachineT` filterErr 467 | let (ConstructorPatternMatch _ varnames) = matchingAlt ^. caseAltLHS 468 | 469 | -- assert ((length varnames) == (length values)) 470 | let newValuesMap = M.fromList (zip varnames values) 471 | let modifiedEnv = newValuesMap `M.union` (cont ^. continuationEnv) 472 | setCode $ CodeEval (matchingAlt ^. caseAltRHS) modifiedEnv 473 | return MachineStepped 474 | 475 | 476 | shouldUseUpdatableStepForReturnConstructor :: PushEnterMachineState -> Bool 477 | shouldUseUpdatableStepForReturnConstructor PushEnterMachineState {..} = length _argumentStack == 0 && 478 | length _returnStack == 0 && 479 | length _updateStack > 0 480 | 481 | stepCodeReturnConstructor :: Constructor -> [Value] -> MachineT MachineProgress 482 | stepCodeReturnConstructor cons values = do 483 | useUpdate <- gets shouldUseUpdatableStepForReturnConstructor 484 | if useUpdate then 485 | stepCodeUpdatableReturnConstructor cons values 486 | else 487 | stepCodeNonUpdatableReturnConstructor cons values 488 | 489 | 490 | 491 | appendError :: Doc () -> MachineT () 492 | appendError = appendLog . mkStyleError 493 | 494 | appendLog :: Doc () -> MachineT () 495 | appendLog s = currentLog <>= Log [s] 496 | 497 | -- | 'CodeEval' execution 498 | stepCodeEval :: LocalEnvironment -> ExprNode -> MachineT MachineProgress 499 | stepCodeEval local expr = do 500 | appendLog $ pretty "stepCodeEval called" 501 | case expr of 502 | ExprNodeFnApplication f xs -> stepCodeEvalFnApplication local f xs 503 | ExprNodeLet isReucursive bindings inExpr -> stepCodeEvalLet local isReucursive bindings inExpr 504 | ExprNodeCase expr alts -> stepCodeEvalCase local expr alts 505 | ExprNodeInt i -> stepCodeEvalInt i 506 | ExprNodeConstructor cons -> stepCodeEvalConstructor local cons 507 | 508 | 509 | 510 | stepCodeEvalConstructor :: LocalEnvironment -> Constructor -> MachineT MachineProgress 511 | stepCodeEvalConstructor local (cons @ (Constructor consname consAtoms)) = do 512 | consVals <- for consAtoms (lookupAtom local) 513 | setCode $ CodeReturnConstructor cons consVals 514 | return MachineStepped 515 | 516 | 517 | stepIntIntrinsic :: (Int -> Int -> Int) -> [Atom] -> MachineT MachineProgress 518 | stepIntIntrinsic f atoms = do 519 | -- TODO: make this a lens match that can fail make sure the function call looks like this 520 | let [AtomInt (StgInt x1), AtomInt (StgInt x2)] = atoms 521 | setCode $ CodeReturnInt $ StgInt (f x1 x2) 522 | return MachineStepped 523 | 524 | 525 | stepCodeEvalFnApplication :: LocalEnvironment -> VarName -> [Atom] -> MachineT MachineProgress 526 | stepCodeEvalFnApplication local lhsName vars = do 527 | case (M.lookup lhsName gVarNamesToIntIntrinsics) of 528 | Just f -> stepIntIntrinsic f vars 529 | -- we have no intrinsic, so do the usual lookup stuff 530 | Nothing -> do 531 | lhsValue <- lookupVariable local lhsName 532 | -- it doesn't have the address of a function, don't continue 533 | case lhsValue ^? _ValueAddr of 534 | Nothing -> return MachineHalted 535 | Just fnAddr -> do 536 | localVals <- for vars (lookupAtom local) 537 | argumentStack `stackPushN` localVals 538 | setCode $ CodeEnter fnAddr 539 | return MachineStepped 540 | 541 | 542 | _updateEnvWithBinding :: LocalEnvironment -> Binding -> MachineT LocalEnvironment 543 | _updateEnvWithBinding l b = do 544 | (name, addr) <- allocateBinding l b 545 | let l' = l & at name .~ Just (ValueAddr addr) 546 | return l' 547 | 548 | stepCodeEvalLet :: LocalEnvironment -> IsLetRecursive -> [Binding] -> ExprNode -> MachineT MachineProgress 549 | stepCodeEvalLet locals isLetRecursive bindings inExpr = do 550 | newLocals <- foldlM _updateEnvWithBinding locals bindings 551 | let updatedLocals = newLocals `M.union` locals 552 | setCode $ CodeEval inExpr updatedLocals 553 | return MachineStepped 554 | 555 | 556 | stackPushN :: Lens' PushEnterMachineState (Stack a) -> [a] -> MachineT () 557 | stackPushN stackLens as' = do 558 | as <- use (stackLens . unStack) 559 | stackLens .= Stack (as' ++ as) 560 | 561 | 562 | returnStackPush :: Continuation -> MachineT () 563 | returnStackPush cont = do 564 | returnStack %= (\(Stack rs) -> Stack (cont:rs)) 565 | 566 | 567 | stepCodeEvalCase :: LocalEnvironment -> ExprNode -> [CaseAltType] -> MachineT MachineProgress 568 | stepCodeEvalCase local expr alts = do 569 | returnStackPush (Continuation alts local) 570 | setCode $ CodeEval expr local 571 | return MachineStepped 572 | 573 | stepCodeEvalInt :: StgInt -> MachineT MachineProgress 574 | stepCodeEvalInt i = do 575 | setCode $ CodeReturnInt i 576 | return MachineStepped 577 | 578 | isClosureUpdatable :: Closure -> Bool 579 | isClosureUpdatable cls = cls ^. closureLambda ^. lambdaShouldUpdate 580 | 581 | -- | codeEnter execution 582 | stepCodeEnter :: Addr -> MachineT MachineProgress 583 | stepCodeEnter addr = 584 | do 585 | closure <- lookupAddrInHeap addr 586 | if isClosureUpdatable closure 587 | then stepCodeEnterIntoUpdatableClosure addr closure 588 | else stepCodeEnterIntoNonupdatableClosure addr closure 589 | 590 | -- Enter a as rs where heap[ a -> (vs \u {} -> e) ws_f] 591 | -- Eval e local {} {} (as, rs, a):us heap where 592 | -- local = [vs -> ws_f] 593 | -- | Addr is the address of the closure 594 | -- | Closure is the closure 595 | stepCodeEnterIntoUpdatableClosure :: Addr -> Closure -> MachineT MachineProgress 596 | stepCodeEnterIntoUpdatableClosure addr closure = do 597 | appendLog $ pretty closure <+> pretty "is updatable." 598 | let l = closure ^. closureLambda 599 | let boundVars = l ^. lambdaBoundVarIdentifiers 600 | let freeVarIds = l ^. lambdaFreeVarIdentifiers 601 | let evalExpr = l ^. lambdaExprNode 602 | 603 | -- is there a better way to format this? 604 | if (length boundVars /= 0) then do 605 | appendLog $ pretty "updatable closure has bound variables:" <+> pretty boundVars 606 | error "updatable closure has bound variables" 607 | else do 608 | let localFreeVars = M.fromList (zip freeVarIds 609 | (closure ^. closureFreeVals . getFreeVals)) 610 | let localEnv = localFreeVars 611 | 612 | -- push an update frame 613 | as <- use argumentStack 614 | rs <- use returnStack 615 | stackPushN updateStack [(UpdateFrame as rs addr)] 616 | appendLog $ pretty "pushed update frame" 617 | 618 | -- empty argument and return stack so that them being deref'd will trigger an update 619 | argumentStack .= stackEmpty 620 | returnStack .= stackEmpty 621 | 622 | setCode $ CodeEval evalExpr localEnv 623 | return MachineStepped 624 | 625 | 626 | 627 | -- | old closure, new closure, current argument stack 628 | -- | we are trying to update the old closure to capture the stuff the new closure 629 | -- | does. So, we create a closure which executes the new closure's code from the 630 | -- | old closure's context. Yes this is mind bending. 631 | -- | rule 17 in the STG paper. 632 | -- heap[addr] = old (vs \n xs -> e) ws_f 633 | -- length (as) < length (xs) 634 | -- new (vs ++ xs1 \n xs2 -> e) (ws_f ++ as) 635 | -- I now understand what this does: this replaces a partially applied function 636 | -- with an equivalent function that doesn't need to evaluate the application 637 | -- That is, write: 638 | -- f = \x y 639 | -- h = f g 640 | -- as 641 | -- h = \y where "x" is replaced by "g" in f's body 642 | -- some form of "partial eta-reduction" 643 | -- 644 | -- 0x2 -> cls: [ {} \u {} -> var:flip {var:tuple} ]; 645 | -- 0x2 -> cls: [ {var:f} \n {var:x, var:y} -> var:f {var:y, var:x} | Free variable vals: val:0x0 ]; 646 | -- Notice how we expanded flip tuple out, and the "tuple" parameter became 647 | -- a free variable. 648 | mkEnterUpdateNewClosure :: Closure -> Closure -> [Value] -> MachineT Closure 649 | mkEnterUpdateNewClosure toUpdate cur as = do 650 | appendLog $ vsep [ pretty "updating old closure:" <+> pretty toUpdate 651 | ,pretty "with information from closure:" <+> pretty cur] 652 | let nStackArgs = length as 653 | let curFreeIds = cur ^. closureLambda ^. lambdaFreeVarIdentifiers 654 | -- xs1 ++ xs2 = xs 655 | let curBoundIds = cur ^. closureLambda . lambdaBoundVarIdentifiers 656 | let (boundToFree, stillBound) = (take nStackArgs curBoundIds, drop nStackArgs curBoundIds) 657 | 658 | appendLog $ vsep [pretty "current all bound variables:", nest 4 ((fmap pretty curBoundIds) & sep)] 659 | appendLog $ vsep [pretty "new bound variables to free:", nest 4 ((fmap pretty boundToFree) & sep)] 660 | appendLog $ vsep [pretty "new free variable values: ", nest 4 ((fmap pretty as) & sep)] 661 | appendLog $ vsep [pretty "new bound variables still bound:", nest 4 ((fmap pretty stillBound) & sep)] 662 | 663 | return $ cur { 664 | _closureFreeVals = ClosureFreeVals (cur ^. closureFreeVals . getFreeVals ++ as), 665 | _closureLambda = (cur ^. closureLambda) { 666 | _lambdaFreeVarIdentifiers = curFreeIds ++ boundToFree, 667 | _lambdaBoundVarIdentifiers = stillBound 668 | } 669 | } 670 | 671 | -- provide the lambda and the list of free variables for binding 672 | stepCodeEnterIntoNonupdatableClosure :: Addr -> Closure -> MachineT MachineProgress 673 | stepCodeEnterIntoNonupdatableClosure addr closure = do 674 | appendLog $ pretty closure <+> pretty "is not updatable." 675 | let l = closure ^. closureLambda 676 | let boundVars = l ^. lambdaBoundVarIdentifiers 677 | let freeVars = l ^. lambdaFreeVarIdentifiers 678 | let evalExpr = l ^. lambdaExprNode 679 | 680 | argStack <- use argumentStack 681 | let argStackLength = length argStack 682 | 683 | -- we don't have enough arguments to feed the closure, so we pop the update stack 684 | -- and pull values out 685 | if argStackLength < length boundVars 686 | -- we need to pop the update stack 687 | then do 688 | appendLog $ vsep [pretty "insufficient number of arguments on argument stack.", 689 | nest 4 (vsep [pretty "needed:" <+> pretty (length boundVars) <+> pretty "bound values", 690 | pretty "had:" <+> pretty argStackLength <+> pretty "on argument stack.", 691 | pretty argStack])] 692 | appendLog $ pretty "looking for update frame to satisfy arguments..." 693 | uf@UpdateFrame { 694 | _updateFrameAddress=addru, 695 | _updateFrameArgumentStack=argStacku, 696 | _updateFrameReturnStack=rsu 697 | } <- updateStackPop 698 | appendLog $ vsep [pretty "found update frame: ", pretty uf] 699 | 700 | let argStackList = argStack ^. unStack 701 | 702 | toUpdateClosure <- lookupAddrInHeap addru 703 | newClosure <- (mkEnterUpdateNewClosure toUpdateClosure closure argStackList) 704 | heapUpdateAddress addru newClosure 705 | 706 | returnStack .= rsu 707 | argumentStack <>= argStacku 708 | 709 | code .= CodeEnter addr 710 | return MachineStepped 711 | 712 | else do 713 | boundVarVals <- boundVars & length & takeNArgs 714 | let localFreeVals = M.fromList (zip freeVars 715 | (closure ^. closureFreeVals . getFreeVals)) 716 | let localBoundVals = M.fromList (zip boundVars 717 | boundVarVals) 718 | let localEnv = localFreeVals `M.union` localBoundVals 719 | setCode $ CodeEval evalExpr localEnv 720 | return MachineStepped 721 | 722 | 723 | -- | Return the variable if the continuation contains an alternative 724 | -- for it. 725 | continuationGetVariableAlt :: Continuation -> Either StgError (CaseAlt VarName) 726 | continuationGetVariableAlt cont = 727 | let vars = cont ^.. continuationAlts . each . _CaseAltVariable 728 | in 729 | case vars of 730 | [] -> Left (StgErrorCaseAltsHasNoVariable cont) 731 | [v] -> Right v 732 | vs -> Left (StgErrorCaseAltsHasMoreThanOneVariable cont vs) 733 | 734 | caseAltsGetUniqueMatch :: Eq a => [CaseAlt a] -> a -> Maybe (Either StgError (CaseAlt a)) 735 | caseAltsGetUniqueMatch pats val = 736 | let matches = pats ^.. each . filtered (\alt -> alt ^. caseAltLHS == val) 737 | in 738 | case matches of 739 | [] -> Nothing 740 | [alt] -> Just (Right alt) 741 | alts -> Just (Left (StgErrorCaseAltsOverlappingPatterns)) 742 | 743 | stackPop :: Lens' PushEnterMachineState (Stack a) -> StgError -> MachineT a 744 | stackPop stacklens err = do 745 | isempty <- use (stacklens . to null) 746 | if isempty 747 | then 748 | throwError err 749 | else do 750 | top <- stacklens %%= (\(Stack (x:xs)) -> (x, Stack xs)) 751 | return top 752 | 753 | returnStackPop :: MachineT Continuation 754 | returnStackPop = stackPop returnStack StgErrorReturnStackEmpty 755 | 756 | unwrapAlts :: [CaseAltType] -> Prism' CaseAltType a -> (CaseAltType -> StgError) -> MachineT [a] 757 | unwrapAlts [] p err = return [] 758 | unwrapAlts (a:as) p err = case a ^? p of 759 | Just a -> do 760 | as' <- unwrapAlts as p err 761 | return $ (a:as') 762 | Nothing -> throwError (err a) 763 | 764 | filterEarliestAlt :: Eq a => [CaseAlt a] -> (a -> Bool) -> Maybe (CaseAlt a) 765 | filterEarliestAlt [] _ = Nothing 766 | filterEarliestAlt (c:cs) pred = if pred (c ^. caseAltLHS) 767 | then Just c 768 | else filterEarliestAlt cs pred 769 | 770 | -- | codeReturnInt execution 771 | stepCodeReturnInt :: StgInt -> MachineT MachineProgress 772 | stepCodeReturnInt i = do 773 | cont <- returnStackPop 774 | unwrapped_alts <- unwrapAlts (cont ^. continuationAlts) _CaseAltInt StgErrorExpectedCaseAltInt 775 | let err = StgErrorNoMatchingAltPatternInt i unwrapped_alts 776 | alt <- (filterEarliestAlt unwrapped_alts (== i )) `maybeToMachineT` err 777 | setCode $ CodeEval (alt ^. caseAltRHS) (cont ^. continuationEnv) 778 | return MachineStepped 779 | 780 | genMachineTrace :: PushEnterMachineState -> ([PushEnterMachineState], Maybe StgError) 781 | genMachineTrace state = 782 | case runMachineT stepMachine state of 783 | Left err -> ([], Just err) 784 | Right (progress, state') -> if progress == MachineHalted 785 | then ([state], Nothing) 786 | else let (traceNext, err) = genMachineTrace state' in 787 | (state':traceNext, err) 788 | 789 | genFinalPushEnterMachineState :: PushEnterMachineState -> Either StgError PushEnterMachineState 790 | genFinalPushEnterMachineState state = 791 | case runMachineT stepMachine state of 792 | Left err -> Left err 793 | Right (progress, state') -> if progress == MachineHalted 794 | then Right state' 795 | else genFinalPushEnterMachineState state' 796 | -------------------------------------------------------------------------------- /src/StgToIR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE ParallelListComp #-} 3 | module StgToIR where 4 | import StgLanguage hiding (constructorName) 5 | import qualified StgLanguage as StgL 6 | import ColorUtils 7 | 8 | import Debug.Trace 9 | import IR 10 | import IRBuilder 11 | import Control.Monad.Except 12 | import Data.Traversable 13 | import Data.Foldable 14 | import Control.Monad.State.Strict 15 | import Data.Text.Prettyprint.Doc as PP 16 | import qualified OrderedMap as M 17 | import qualified Data.List as L 18 | import qualified Data.Set as S 19 | 20 | (&) :: a -> (a -> b) -> b 21 | (&) = flip ($) 22 | 23 | -- | The type of an entry function. 24 | -- | () -> void 25 | irTypeEntryFn :: IRType 26 | irTypeEntryFn = IRTypeFunction [] IRTypeVoid 27 | 28 | 29 | -- | The type of a continuation given by alts 30 | -- | () -> void 31 | irTypeContinuation :: IRType 32 | irTypeContinuation = IRTypePointer irTypeEntryFn 33 | 34 | -- | The type of the ID of a heap object 35 | irTypeHeapObjId :: IRType 36 | irTypeHeapObjId = irTypeInt32 37 | 38 | 39 | -- | The type of an entry function we need to tail call into. 40 | -- remember, "boxed value" is a lie, they're just functions. 41 | irTypeEntryFnPtr :: IRType 42 | irTypeEntryFnPtr = IRTypePointer irTypeEntryFn 43 | 44 | -- | Type of the info struct 45 | -- struct {} 46 | irTypeInfoStruct :: IRType 47 | irTypeInfoStruct = IRTypeStruct [ irTypeEntryFnPtr, -- pointer to function to call, 48 | irTypeHeapObjId -- ID of this object 49 | ] 50 | 51 | -- | Type of the constructor tag 52 | irTypeConstructorTag :: IRType 53 | irTypeConstructorTag = irTypeInt32 54 | 55 | -- | Type of a heap object 56 | -- TODO: keep a pointer to the info table. Right now, just store a copy of the 57 | -- info table, since it is way easier to do this. 58 | -- struct { info, void *mem } 59 | irTypeHeapObject :: IRType 60 | irTypeHeapObject = IRTypeStruct [irTypeInfoStruct, -- info table, 61 | irTypeMemoryPtr -- data payload 62 | ] 63 | 64 | -- | A pointer to a heap object 65 | irTypeHeapObjectPtr :: IRType 66 | irTypeHeapObjectPtr = IRTypePointer irTypeHeapObject 67 | 68 | -- | Int value corresponding to binding 69 | type BindingId = Int 70 | -- | Data associated to a binding 71 | data BindingData = BindingData { 72 | binding :: Binding, 73 | bindingId :: BindingId, 74 | bindingFn :: Value 75 | } 76 | 77 | instance Pretty BindingData where 78 | pretty BindingData{..}= 79 | vcat [pretty "BindingData {", 80 | indent 4 (vcat $ [pretty "binding :=" <+> pretty binding, 81 | pretty "id := " <+> pretty bindingId, 82 | pretty "bindingFn :=" <+> pretty bindingFn]), pretty "}"] 83 | 84 | 85 | -- | Int val corresponding to to constructor 86 | type ConstructorId = Int 87 | 88 | data ConstructorData = ConstructorData { 89 | constructorName :: ConstructorName, 90 | constructorId :: ConstructorId 91 | } 92 | 93 | -- | TODO: create an IRStack object to represent a stack in LLVM IR 94 | -- | G = global, P = pointer. General Context that we need throughout. 95 | data Context = Context { 96 | -- | Stack pointer to continuation values. 97 | contstackGP:: Value, 98 | -- | Number of continuation values on the stack. 99 | contstacknG :: Value, 100 | -- | Register for the tag of a constructor 101 | rtagG :: Value, 102 | -- | Binding name to binding data 103 | bindingNameToData :: M.OrderedMap VarName BindingData, 104 | -- | constructor name to constructor data 105 | constructorNameToData :: M.OrderedMap ConstructorName ConstructorData, 106 | -- | Matcher function 107 | fnmatcher :: Value, 108 | -- | function to push continuation value to stack 109 | fnpushcont :: Value, 110 | -- | function to pop continuation value on stack 111 | fnpopcont :: Value, 112 | -- | function that traps 113 | fntrap :: Value 114 | } 115 | 116 | 117 | -- | Get all bindings in a program 118 | getBindsInProgram :: Program -> [Binding] 119 | getBindsInProgram prog = prog >>= collectBindingsInBinding 120 | 121 | 122 | -- | Get all constructors in a program 123 | getConstructorNamesInProgram :: Program -> [ConstructorName] 124 | getConstructorNamesInProgram prog = prog >>= collectConstructorNamesInBinding 125 | 126 | 127 | -- | Build the function stubs that corresponds to the binding. 128 | -- We first build all the stubs to populate the Context. Then, we can build 129 | -- the indivisual bindings. 130 | buildFnStubForBind :: Binding -> State ModuleBuilder Value 131 | buildFnStubForBind Binding{..} = let 132 | paramsty = [] 133 | retty = IRTypeVoid 134 | fnname = (_unVarName _bindingName) 135 | in 136 | createFunction paramsty retty fnname 137 | 138 | 139 | -- | Create a function that allocates a constructor heap object. 140 | _createAllocConstructorFn :: State ModuleBuilder Value 141 | _createAllocConstructorFn = do 142 | lbl <- createFunction [irTypeHeapObjId] irTypeHeapObjectPtr "alloc_constructor" 143 | runFunctionBuilder lbl $ do 144 | mem <- "mem" =:= InstMalloc irTypeHeapObject 145 | heapObjIdLoc <- "heapObjIdLoc" =:= InstGEP mem [ValueConstInt 0, ValueConstInt 0, ValueConstInt 1] 146 | idval <- getParamValue 0 147 | appendInst $ InstStore heapObjIdLoc idval 148 | return () 149 | return lbl 150 | 151 | -- | Create a function that pushes values on the stack 152 | _createStackPushFn :: String -- ^function name 153 | -> IRType -- ^type of stack elements 154 | -> Value-- ^count global 155 | -> Value -- ^stack pointer global 156 | -> State ModuleBuilder Value 157 | _createStackPushFn fnname elemty nG stackGP = do 158 | lbl <- createFunction [elemty] IRTypeVoid fnname 159 | runFunctionBuilder lbl $ do 160 | n <- "nooo" =:= InstLoad nG 161 | -- Load the pointer 162 | -- stackP <- "stackp" =:= InstLoad stackGP 163 | -- compute store addr 164 | -- storeaddr <- "storeaddr" =:= InstGEP stackP [n] 165 | -- val <- getParamValue 0 166 | -- appendInst $ InstStore storeaddr val 167 | -- TODO: this should be (n + 1) 168 | -- | Understand why this fails..? 169 | ninc <- "ninc" =:= InstAdd n (ValueConstInt 1) 170 | appendInst $ InstStore nG ninc 171 | return () 172 | return lbl 173 | 174 | 175 | -- | Create a function that pops values off the stack 176 | _createStackPopFn :: String -- ^Function name 177 | -> IRType -- ^type of stack elements 178 | -> Value -- ^count global 179 | -> Value -- ^stack pointer global 180 | -> State ModuleBuilder Value 181 | _createStackPopFn fnname elemty nG stackGP = do 182 | lbl <- createFunction [] elemty fnname 183 | runFunctionBuilder lbl $ do 184 | n <- "n" =:= InstLoad nG 185 | -- Load the pointer 186 | stackP <- "stackp" =:= InstLoad stackGP 187 | -- compute store addr 188 | loadaddr <- "loadaddr" =:= InstGEP stackP [n] 189 | loadval <- "loadval" =:= InstLoad loadaddr 190 | n' <- "ndec" =:= InstAdd n (ValueConstInt (-1)) 191 | appendInst $ InstStore nG n' 192 | setRetInst $ RetInstReturn loadval 193 | return () 194 | return lbl 195 | 196 | 197 | -- | Create the `Context` object that is contains data needed to build all of the 198 | -- LLVM Module for our program. 199 | createContext :: [Binding] -> [ConstructorName] -> State ModuleBuilder Context 200 | createContext bs cnames = do 201 | -- NOTE: the pointer in the global is implicit, in the sense of GEP 202 | contstack <- createGlobalVariable "stackcont" (IRTypePointer irTypeContinuation) 203 | contn <- createGlobalVariable "contn" irTypeInt32 204 | bfns <- for bs buildFnStubForBind 205 | 206 | rtag <- createGlobalVariable "rtag" (IRTypePointer irTypeConstructorTag) 207 | 208 | fnmatcher <- createFunction [irTypeConstructorTag] irTypeContinuation "matcher" 209 | 210 | trap <- createFunction [] IRTypeVoid "llvm.trap" 211 | 212 | let bdatas = [BindingData { 213 | bindingId=bid, 214 | bindingFn=fn, 215 | binding=b} | bid <- [1..] | fn <- bfns | b <- bs] 216 | let bnames = map (_bindingName . binding) bdatas 217 | 218 | 219 | let cdatas = [ConstructorData { 220 | constructorId=cid, 221 | constructorName=cname 222 | } | cid <- [1..] | cname <- cnames] 223 | 224 | 225 | 226 | pushcont <- _createStackPushFn "pushcont" irTypeContinuation contn contstack 227 | popcont <- _createStackPopFn "popcont" irTypeContinuation contn contstack 228 | 229 | -- allocContructor <- _createAllocConstructorFn 230 | 231 | return $ Context { 232 | contstackGP=contstack, 233 | contstacknG=contn, 234 | rtagG=rtag, 235 | bindingNameToData=M.fromList (zip bnames bdatas), 236 | constructorNameToData=M.fromList (zip cnames cdatas), 237 | fnmatcher=fnmatcher, 238 | fnpushcont=pushcont, 239 | fnpopcont=popcont, 240 | fntrap=trap 241 | } 242 | 243 | -- | Push a continuation into the stack. Used by alts 244 | pushCont :: Context -> Value -> State FunctionBuilder () 245 | pushCont ctx val = do 246 | let f = fnpushcont ctx 247 | appendInst $ InstCall f [val] 248 | return () 249 | 250 | -- | Create the instruction to pop a continuation from the stack. 251 | -- Used by alts. 252 | -- Note that return value needs to be named with (=:=) 253 | popCont :: Context -> Inst 254 | popCont ctx = InstCall (fnpopcont ctx) [] 255 | 256 | 257 | 258 | createMatcher :: Context -> State ModuleBuilder () 259 | createMatcher ctx = do 260 | runFunctionBuilder (fnmatcher ctx) (_createMatcherFn (bindingNameToData ctx)) 261 | where 262 | -- | Build a BB of the matcher that mathes with the ID and returns the 263 | -- actual function. 264 | -- Return the IR::Value of the switch case needed, and the label of the BB 265 | -- to jump to. 266 | buildMatchBBForBind_ :: M.OrderedMap VarName BindingData -> VarName -> State FunctionBuilder (Value, BBLabel) 267 | buildMatchBBForBind_ bdata bname = do 268 | bbid <- createBB ("switch." ++ (_unVarName bname)) 269 | focusBB bbid 270 | let bfn = (bdata M.! bname) & bindingFn :: Value 271 | let bid = (bdata M.! bname) & bindingId :: BindingId 272 | setRetInst (RetInstReturn bfn) 273 | return ((ValueConstInt bid), bbid) 274 | 275 | -- | Build the matcher function, that takes a function ID and returns the 276 | -- function corresponding to the ID. 277 | _createMatcherFn :: M.OrderedMap VarName BindingData -> 278 | State FunctionBuilder () 279 | _createMatcherFn bdata = do 280 | entrybb <- getEntryBBLabel 281 | let bnames = M.keys bdata 282 | switchValAndBBs <- for bnames (buildMatchBBForBind_ bdata) 283 | param <- getParamValue 0 284 | -- create error block 285 | errBB <- createBB "switch.fail" 286 | focusBB errBB 287 | setRetInst (RetInstReturn (ValueUndef (irTypeContinuation))) 288 | 289 | -- create entry block 290 | focusBB entrybb 291 | setRetInst (RetInstSwitch param errBB switchValAndBBs) 292 | 293 | 294 | -- | Create a call to the matcher to return the function with name VarName 295 | createMatcherCallWithName :: Context -> VarName -> Inst 296 | createMatcherCallWithName ctx bname = let 297 | bid = bindingId $ (bindingNameToData ctx) M.! bname 298 | in InstCall (fnmatcher ctx) [(ValueConstInt bid)] 299 | 300 | 301 | -- | push an STG atom to the correct stack 302 | pushAtomToStack :: Context -> M.OrderedMap VarName Value -> Atom -> State FunctionBuilder () 303 | pushAtomToStack ctx _ (AtomInt (StgInt i)) = 304 | pushInt ctx (ValueConstInt i) where 305 | pushInt _ _ = error "Unimplemented pushInt" 306 | pushAtomToStack ctx nametoval (AtomVarName v) = pushCont ctx (nametoval M.! v) 307 | 308 | 309 | -- | Generate code for an expression node in the IR 310 | codegenExprNode :: Context 311 | -> M.OrderedMap VarName Value -- ^mapping between variable name and which value to use to access this 312 | -> ExprNode -- ^expression node 313 | -> State FunctionBuilder () 314 | -- | Function appplication codegen 315 | codegenExprNode ctx nametoval (ExprNodeFnApplication fnname atoms) = do 316 | fn <- case fnname `M.lookup` nametoval of 317 | Just fn_ -> return $ fn_ 318 | Nothing -> "fn" =:= createMatcherCallWithName ctx fnname 319 | for atoms (pushAtomToStack ctx nametoval) 320 | appendInst $ InstCall fn [] 321 | 322 | return () 323 | 324 | -- | Constructor codegen 325 | {- 326 | codegenExprNode ctx nametoval (ExprNodeConstructor (Constructor name atoms)) = do 327 | jumpfn <- "jumpfn" =:= popCont ctx 328 | for atoms (pushAtomToStack ctx nametoval) 329 | appendInst $ InstCall jumpfn [] 330 | return () 331 | -} 332 | 333 | 334 | codegenExprNode _ nametoval e = error . docToString $ 335 | vcat [pretty " Unimplemented codegen for exprnode: ", indent 4 (pretty e)] 336 | 337 | -- | Setup a binding with name VarName 338 | setupTopLevelBinding :: Context -> VarName -> State FunctionBuilder () 339 | setupTopLevelBinding ctx name = do 340 | let b = binding $ (bindingNameToData ctx) M.! name :: Binding 341 | let Lambda{_lambdaFreeVarIdentifiers=free, 342 | _lambdaBoundVarIdentifiers=bound, 343 | _lambdaExprNode=e} = _bindingLambda b 344 | 345 | -- if bound = A B C, stack will have 346 | -- C 347 | -- B 348 | -- A 349 | -- So we need to reverse the stack 350 | boundvals <- for (reverse bound) (\b -> (_unVarName b) =:= (popCont ctx)) 351 | let boundNameToVal = M.fromList $ zip bound boundvals :: M.OrderedMap VarName Value 352 | let toplevelNameToVal = fmap bindingFn (bindingNameToData ctx) :: M.OrderedMap VarName Value 353 | 354 | let nameToVal = boundNameToVal `M.union` toplevelNameToVal 355 | 356 | codegenExprNode ctx nameToVal e 357 | 358 | 359 | programToModule :: Program -> Module 360 | programToModule p = runModuleBuilder $ do 361 | let bs = getBindsInProgram p 362 | let cs = getConstructorNamesInProgram p 363 | ctx <- createContext bs cs 364 | createMatcher ctx 365 | for_ (M.toList . bindingNameToData $ ctx) 366 | (\(bname, bdata) -> runFunctionBuilder 367 | (bindingFn bdata) 368 | (setupTopLevelBinding ctx bname)) 369 | return () 370 | 371 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | # This file was automatically generated by 'stack init' 4 | # 5 | # Some commonly used options have been documented as comments in this file. 6 | # For advanced use and comprehensive documentation of the format, please see: 7 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 8 | 9 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 10 | # A snapshot resolver dictates the compiler version and the set of packages 11 | # to be used for project dependencies. For example: 12 | # 13 | # resolver: lts-3.5 14 | # resolver: nightly-2015-09-21 15 | # resolver: ghc-7.10.2 16 | # resolver: ghcjs-0.1.0_ghc-7.10.2 17 | # resolver: 18 | # name: custom-snapshot 19 | # location: "./custom-snapshot.yaml" 20 | resolver: lts-8.15 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # extra-dep: true 33 | # subdirs: 34 | # - auto-update 35 | # - wai 36 | # 37 | # A package marked 'extra-dep: true' will only be built if demanded by a 38 | # non-dependency (i.e. a user package), and its test suites and benchmarks 39 | # will not be run. This is useful for tweaking upstream packages. 40 | packages: 41 | - '.' 42 | # - '/Users/bollu/work/llvm-hs/llvm-hs' 43 | # - '/Users/bollu/work/llvm-hs/llvm-hs-pure' 44 | extra-deps: 45 | - hoist-error-0.1.0.2 46 | - llvm-hs-4.1.0.0 47 | - llvm-hs-pure-4.1.0.0 48 | - prettyprinter-1.1 49 | 50 | resolver: lts-8.15 51 | 52 | # flags: 53 | # llvm-hs: 54 | # shared-llvm: true 55 | -------------------------------------------------------------------------------- /stg-programs/case-constructor.stg: -------------------------------------------------------------------------------- 1 | define main = {} \n {} -> case (Nil {}) of 2 | Cons {x} -> Int {2#}; 3 | Nil {} -> Int {3#}; 4 | -------------------------------------------------------------------------------- /stg-programs/case-raw-number.stg: -------------------------------------------------------------------------------- 1 | define id = {} \n {x} -> x {}; 2 | 3 | define main = {} \n {} -> case 10# of 4 | 4# -> id {5#}; 5 | 10# -> id {11#}; 6 | -------------------------------------------------------------------------------- /stg-programs/id.stg: -------------------------------------------------------------------------------- 1 | define main = {} \n {} -> let 2 | id = {} \n {x} -> x {} 3 | in id { 1# }; 4 | -------------------------------------------------------------------------------- /stg-programs/let.stg: -------------------------------------------------------------------------------- 1 | define main = {} \n {} -> let s = {} \n {f, g, x} -> 2 | let y = {g, x} \n {} -> g {x} 3 | in f {x, y}; 4 | k = {} \n {x, y} -> x {}; 5 | three = {} \n {} -> Int { 3# } 6 | in s {k, k, three}; -------------------------------------------------------------------------------- /stg-programs/only-combinators.stg: -------------------------------------------------------------------------------- 1 | define k = {} \n {x, y} -> x {}; 2 | define main = {} \n {} -> k {k, k}; 3 | 4 | -------------------------------------------------------------------------------- /stg-programs/partial-application.stg: -------------------------------------------------------------------------------- 1 | 2 | define k = {} \n {x, y} -> x {}; 3 | define ap2 = {} \n {f} -> let two = {} \n {} -> Two {} 4 | in f { two }; 5 | 6 | define one = {} \n {} -> One {}; 7 | define pap = {} \n {} -> let k1 = {} \n {} -> k {one} 8 | in ap2 {k1}; 9 | 10 | define main = {} \n {} -> case (pap {}) of 11 | One {} -> Found {}; 12 | -------------------------------------------------------------------------------- /stg-programs/plus.stg: -------------------------------------------------------------------------------- 1 | define check = {} \n {x} -> case x {} of 2 | 3# -> Found {};; 3 | 4 | define main = {} \n {} -> let sum = {} \n {} -> plus# { 1#, 2# } 5 | in case (Int { sum }) of 6 | Int { x } -> check { x }; 7 | 8 | -------------------------------------------------------------------------------- /stg-programs/s-k-k-3.stg: -------------------------------------------------------------------------------- 1 | define k = {} \n {x, y} -> x {}; 2 | define s = {} \n {f, g, x} -> let 3 | y = {} \n {} -> g {x} in 4 | f {x, y}; 5 | 6 | define main = {} \n {} -> s {k, k, 3#}; 7 | 8 | -------------------------------------------------------------------------------- /stg-programs/updatable-constructor.stg: -------------------------------------------------------------------------------- 1 | define sum = {} \n {} -> plus# { 1#, 2# }; 2 | define updatablesum = {} \u {} -> Int { sum }; 3 | define main = {} \n {} -> case updatablesum {} of 4 | Int {x} -> Done {} 5 | -------------------------------------------------------------------------------- /stg-programs/updatable-fn-calls.stg: -------------------------------------------------------------------------------- 1 | define tuple = {} \n {x, y} -> Tuple {x, y}; 2 | define flip = {} \n {f, x, y} -> f {y, x}; 3 | define flipTuple = {} \u {} -> flip { tuple }; 4 | define main = {} \u {} -> case (flipTuple {1#, 2#}) of 5 | Tuple {a, b} -> Success {}; 6 | 7 | //case a of 8 | // 2# -> case b of 9 | // 1# -> Success {}; 10 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Test.Tasty 2 | import Control.Monad 3 | -- import Test.Tasty.QuickCheck as QC 4 | import Test.Tasty.HUnit 5 | import Test.Tasty.Runners 6 | 7 | 8 | import Data.Ord 9 | import qualified Data.Map as M 10 | 11 | import System.IO 12 | 13 | 14 | import Control.Lens 15 | import Data.Map.Lens 16 | 17 | import StgLanguage 18 | import StgParser 19 | import StgPushEnterMachine 20 | import Stg 21 | 22 | import System.Directory 23 | import Data.Either 24 | 25 | 26 | 27 | 28 | mkBoxedNumberString :: Int -> String 29 | mkBoxedNumberString i = "Int { " ++ (show i) ++ "#" ++ " }" 30 | 31 | extractBoxedNumber :: PushEnterMachineState -> Maybe Int 32 | extractBoxedNumber state = (state ^. code ^? _CodeEval) >>= getFnApplication where 33 | -- Eval (x {}) ({ x -> #3 }) 34 | getFnApplication :: (ExprNode, LocalEnvironment) -> Maybe Int 35 | getFnApplication ((ExprNodeFnApplication varname []), localEnv) = (varname `M.lookup` localEnv) >>= (^? _ValuePrimInt) 36 | getFnApplication _ = Nothing 37 | 38 | 39 | -- main = defaultMain tests 40 | 41 | 42 | stgProgramsResource :: IO [(FilePath, String)] 43 | stgProgramsResource = do 44 | programFiles <- listDirectory "./stg-programs/" 45 | forM programFiles $ \f -> do 46 | contents <- readFile $ "./stg-programs/" ++ f 47 | return (f, contents) 48 | 49 | mkTestFromFileData :: FilePath -> String -> TestTree 50 | mkTestFromFileData filepath contents = testCase ("running " ++ filepath) $ do 51 | let mState = doesStgProgramSucceedRun contents 52 | case mState of 53 | Left e -> do 54 | assertFailure $ "error: " ++ e 55 | Right _ -> return () 56 | 57 | main :: IO () 58 | main = do 59 | filesWithContents <- stgProgramsResource 60 | let tests = fmap (uncurry mkTestFromFileData) filesWithContents 61 | let group = testGroup "example programs" tests 62 | defaultMain group 63 | 64 | 65 | doesStgProgramSucceedRun :: String -> Either ErrorString PushEnterMachineState 66 | doesStgProgramSucceedRun s = 67 | case tryCompileString s of 68 | Left err -> Left err 69 | Right init -> case genMachineTrace init of 70 | (states, Nothing) -> Right (last states) 71 | (_, Just err) -> Left (show err) 72 | 73 | --------------------------------------------------------------------------------