├── .gitignore
├── .travis.yml
├── ChangeLog.md
├── LICENSE
├── README.md
├── Setup.hs
├── docs
├── absint.html
├── baseir.html
├── graph.html
├── index.html
├── ir.html
├── irinterpreter.html
├── language.html
├── main.html
├── mipsasm.html
├── mipsinterpreter.html
├── orderedmap.html
├── pandoc.css
├── parser.html
├── prettyutils.html
├── programtoir.html
├── scev.html
├── transformconstantfolding.html
├── transformirtomips.html
├── transformmem2reg.html
└── transformregisterallocate.html
├── imperative-compiler.cabal
├── make-docs.py
├── pandoc.css
├── programs
├── direct-int-if.c
├── direct-int-return.c
├── force-spill.c
├── if.c
├── nontrivial-dom-frontier.c
├── simple-store.c
├── store-load.c
├── test-constant-folding.c
├── while-2-nest.c
└── while.c
├── reading
├── STOKE-superoptimizer.pdf
└── stochastic-program-optimization.pdf
├── src
├── Absint.lhs
├── BaseIR.lhs
├── Graph.lhs
├── IR.lhs
├── IRInterpreter.lhs
├── ISL
│ ├── Native.hs
│ ├── Native
│ │ ├── C2Hs.chs
│ │ ├── Context.hs
│ │ └── Types.chs
│ └── Types.hs
├── Index.lhs
├── Language.lhs
├── MIPSAsm.lhs
├── MIPSInterpreter.lhs
├── Main.lhs
├── OrderedMap.lhs
├── Parser.lhs
├── PrettyUtils.lhs
├── ProgramToIR.lhs
├── SCEV.lhs
├── TransformConstantFolding.lhs
├── TransformIRToMIPS.lhs
├── TransformMem2Reg.lhs
└── TransformRegisterAllocate.lhs
├── stack.yaml
└── 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 | tags
22 | # emacs ignore
23 | *~
24 |
--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
1 | # This is the simple Travis configuration, which is intended for use
2 | # on applications which do not require cross-platform and
3 | # multiple-GHC-version support. For more information and other
4 | # options, see:
5 | #
6 | # https://docs.haskellstack.org/en/stable/travis_ci/
7 | #
8 | # Copy these contents into the root directory of your Github project in a file
9 | # named .travis.yml
10 |
11 | # Use new container infrastructure to enable caching
12 | sudo: false
13 |
14 | # Do not choose a language; we provide our own build tools.
15 | language: generic
16 |
17 | # Caching so the next build will be fast too.
18 | cache:
19 | directories:
20 | - $HOME/.stack
21 |
22 | # Ensure necessary system libraries are present
23 | addons:
24 | apt:
25 | packages:
26 | - libgmp-dev
27 | - spim
28 |
29 | before_install:
30 | # Download and unpack the stack executable
31 | - mkdir -p ~/.local/bin
32 | - export PATH=$HOME/.local/bin:$PATH
33 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
34 |
35 | install:
36 | # Build dependencies
37 | - stack --no-terminal --install-ghc test --only-dependencies
38 |
39 | script:
40 | # Build the package, its tests, and its docs and run the tests
41 | - stack --no-terminal test --haddock --no-haddock-deps
42 |
--------------------------------------------------------------------------------
/ChangeLog.md:
--------------------------------------------------------------------------------
1 | # Revision history for imperative-compiler
2 |
3 | ## 0.1.0.0 -- YYYY-mm-dd
4 |
5 | * First version. Released on an unsuspecting world.
6 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2017, Siddharth Bhat
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Siddharth Bhat nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # A simple end-to-end compiler for an imperative programming language [](https://travis-ci.org/bollu/tiny-optimising-compiler)
2 |
3 |
4 | Read the docs at [`https://bollu.github.io/tiny-optimising-compiler/`](https://bollu.github.io/tiny-optimising-compiler/)
5 |
--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/docs/graph.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 |
46 |
47 |
48 |
49 |
50 | Graph
51 |
52 |
In this module, we define a simple graph structure that can be used as:
53 |
54 |
an undirected.
55 |
a directed graph.
56 |
a tree.
57 |
58 |
Ideally, we would use some sort of phantom-type mechanism to distinguish between the two, that is Graph Undirected a and Graph Directed a, but oh well :).
59 |
{-# LANGUAGE ViewPatterns #-}
60 |
61 | moduleGraphwhere
62 | import Data.List(nub)
63 | import Data.Text.Prettyprint.DocasPP
64 | import PrettyUtils
65 | import Data.Maybe (maybeToList)
66 | import qualifiedOrderedMapasM
67 | import qualifiedData.SetasS
68 |
69 | -- | Represents a graph with `a` as a vertex ID type
70 | newtypeGraph a =Graph { edges :: [(a, a)] }
71 |
72 | instancePretty a =>Pretty (Graph a) where
73 | pretty graph =
74 | vcat [pretty "BB graph edges",
75 | (vcat . map (indent 4. pretty) . edges $ graph)]
76 |
77 | -- | returns all edges (H -> T) with a given source H
78 | getEdgesFromSource ::Eq a =>Graph a -> a -> [(a, a)]
79 | getEdgesFromSource g src = [(src, b) | (a, b) <- edges g, a == src]
80 |
81 | -- | return predecessors of a node
82 | getPredecessors ::Eq a =>Graph a -> a -> [a]
83 | getPredecessors g bbid = [ src | (src, sink) <- (edges g), sink == bbid]
84 |
85 | -- | Returns the children of an element in a dom tree
86 | -- | This returns only the immediate children.
87 | getImmediateChildren ::Eq a =>Graph a -> a -> [a]
88 | getImmediateChildren (Graph edges) a = [dest | (src, dest) <- edges, src==a]
89 |
90 | -- | Return all the vertices of the subgraph
91 | getAllChildren ::Eq a =>Graph a -> a -> [a]
92 | getAllChildren tree@(Graph edges) a =
93 | a:(curChilds >>= (getAllChildren tree)) where
94 | curChilds = getImmediateChildren tree a
95 |
96 | -- | Return the set of vertices in DomTree
97 | vertices ::Eq a =>Graph a -> [a]
98 | vertices (Graph edges) = nub (map fst edges ++ map snd edges)
99 |
100 | -- | Colors are assigned from [1..NGraphColors]
101 | typeGraphColor=Int
102 | typeNGraphColors=Int
103 |
104 | _greedyColorGraph ::Ord a =>Graph a -- ^ Graph
105 | ->S.Set a -- ^ Set of vertices
106 | ->M.OrderedMap a (MaybeGraphColor) -- ^ Mapping from vertices to colors
107 | ->NGraphColors-- ^ Total number of graph colors available
108 | ->M.OrderedMap a (MaybeGraphColor) -- ^ Final colored graph
109 | _greedyColorGraph _ (null ->True) coloring ncolors = coloring
110 | _greedyColorGraph g vs@(S.elemAt 0-> v) coloring ncolors =
111 | _greedyColorGraph g vs' coloring' ncolors where
112 | -- adjacent vertices
113 | adjvs = (getPredecessors g v)
114 |
115 | -- colors of adjacent vertices
116 | adjColors :: [GraphColor]
117 | adjColors = mconcat $ fmap (\v ->case (v `M.lookup` coloring) of
118 | Just (Just c) -> [c]
119 | _ -> []) adjvs
120 |
121 | -- largest color
122 | largestAdjColor =case adjColors of
123 | [] ->0
124 | xs -> maximum xs
125 |
126 | -- Leave it uncolored it we can't find a color
127 | coloring' =if largestAdjColor == ncolors
128 | then M.insert v Nothing coloring
129 | else M.insert v (Just (largestAdjColor +1)) coloring
130 |
131 | -- remove vertex we currently processed
132 | vs' = S.deleteAt 0 vs
133 |
134 |
135 | -- | Color the graph greedily and return the mapping of colors
136 | greedyColorGraph ::Ord a =>NGraphColors->Graph a ->M.OrderedMap a (MaybeInt)
137 | greedyColorGraph ngraphcolors g =
138 | _greedyColorGraph g (S.fromList (vertices g))
139 | mempty ngraphcolors
I've wanted to write this for a while: a tiny optimising compiler for a small imperative ish language.
30 |
I want to show off modern compiler ideas, such as:
31 |
32 |
SSA.
33 |
optimisations enabled by SSA.
34 |
Scalar evolution.
35 |
Polyhedral compilation
36 |
37 |
I currently have a parser for the source language, conversion to IR, then to SSA, and a semi-broken MIPS backend.
38 |
39 | Goals
40 |
41 |
42 |
Be readable code.
43 |
Be literate code (preferably).
44 |
Show off real world optimisations.
45 |
46 |
47 | Non goals
48 |
49 |
Shows the correct way of doing a lot of things, in the sense of "engineering". I might pick the slower algorithm to compute a dominator tree, because I wish to emphasize the idea of the dominator tree. When a trade off is presented between simplicity and performance, I will pick simplicity.
50 |
51 | Timeline
52 |
53 |
54 |
[x] Parse
55 |
[x] Generate non-SSA IR
56 |
[x] Convert non-SSA to SSA (Mem2Reg is the pass where this happens.)
57 |
[x] generate MIPS assembly from SSA IR (half-done)
58 |
[ ] (Optional) generate LLVM for SSA IR (Can be pulled from simplexhc)
59 |
60 |
At this point, we have a "functioning" compiler. Now, we can extend the compiler or the language. I want to show off optimisations, so I will spend more time implementing optimisations
61 |
62 |
[ ] Loop detection.
63 |
[ ] Scalar evolution.
64 |
[ ] Global value numbering.
65 |
[ ] Dead code elimination.
66 |
[ ] Loop unrolling.
67 |
[ ] invariant load hoisting.
68 |
69 |
Note that we do not yet have functions in the language! let's add that.
70 |
71 |
[ ] extend language with functions.
72 |
[ ] generate MIPS for functions.
73 |
[ ] Inlining.
74 |
75 |
If we get here, we can then add polyhedral abilities to the compiler. For this though, we would need to integrate with isl. Someone will need to write haskell bindings :).
Due to the immutable nature of SSA, we are guaranteed that we can replace all occurences of a variable with it's RHS, and the semantics of the program will remain the same! (AKA equational reasoning).
89 |
This is enormously powerful because it allows to replace values with wild abandon :).
90 |
91 | Key Takeaway of this pass
92 |
93 |
94 |
SSA, due to immutability enables equational reasoning.
95 |
This allows us to perform transformations such as constant folding very easily.
96 |
97 |
{-# LANGUAGE ViewPatterns #-}
98 |
99 | moduleTransformConstantFoldingwhere
100 | import qualifiedOrderedMapasM
101 | import Control.Monad.State.Strict
102 | import Data.Traversable
103 | import Data.Foldable
104 | import Control.Applicative
105 | import qualifiedData.List.NonEmptyasNE
106 | import IR
107 | import BaseIR
108 | import Data.Text.Prettyprint.DocasPP
109 | import PrettyUtils
110 |
111 | boolToInt ::Bool->Int
112 | boolToInt False=0
113 | boolToInt True=1
114 |
115 | -- | Fold all possible arithmetic / boolean ops
116 | tryFoldInst ::Inst->MaybeValue
117 | tryFoldInst (InstAdd (ValueConstInt i) (ValueConstInt j)) =
118 | Just$ValueConstInt (i + j)
119 | tryFoldInst (InstMul (ValueConstInt i) (ValueConstInt j)) =
120 | Just$ValueConstInt (i * j)
121 | tryFoldInst (InstL (ValueConstInt i) (ValueConstInt j)) =
122 | Just$ValueConstInt$ boolToInt (i < j)
123 |
124 | tryFoldInst (InstAnd (ValueConstInt i) (ValueConstInt j)) =
125 | Just$ValueConstInt (i * j)
126 | tryFoldInst i =Nothing
127 |
128 | collectFoldableInsts ::NamedInst-> [(LabelInst, Value)]
129 | collectFoldableInsts (Named name (tryFoldInst ->Just v)) = [(name, v)]
130 | collectFoldableInsts _ = []
131 |
132 | runTillStable ::Eq a => (a -> a) -> a -> a
133 | runTillStable f a =let a' = f a in
134 | if a' == a
135 | then a'
136 | else f a'
137 |
138 | transformConstantFold ::IRProgram->IRProgram
139 | transformConstantFold = dceProgram . (runTillStable foldProgram) where
140 |
141 | -- | Collection of instruction names and values
142 | foldableInsts ::IRProgram-> [(LabelInst, Value)]
143 | foldableInsts p = foldMapProgramBBs (foldMapBB (collectFoldableInsts) (const mempty)) p
144 |
145 | -- | Program after constant folding
146 | foldProgram ::IRProgram->IRProgram
147 | foldProgram program = foldl (\p (name, v) -> replaceUsesOfInst name v p) program (foldableInsts program)
148 |
149 | -- | program after dead code elimination
150 | dceProgram ::IRProgram->IRProgram
151 | dceProgram program =
152 | foldl (\p name -> filterProgramInsts (not . hasName name) p) program (map fst (foldableInsts program))
174 |
175 | \begin{code}
176 | repeatTillFix :: (Eq a) => (a -> a) -> a -> a
177 | repeatTillFix f a =
178 | let a' = f a in
179 | if a == a' then a else repeatTillFix f a'
180 |
181 |
182 | -- repeat till fixpoint, or the max count
183 | repeatTillFixDebug :: Eq a => Int -> (a -> a) -> a -> a
184 | repeatTillFixDebug 0 f a = a
185 | repeatTillFixDebug n f a =
186 | let a' = f a in if a' == a then a else repeatTillFixDebug (n - 1) f a'
187 |
188 |
189 | repeatTillFixDebugTrace :: Eq a => Int -> (a -> a) -> a -> [a]
190 | repeatTillFixDebugTrace 0 f a = [a]
191 | repeatTillFixDebugTrace n f a =
192 | let a' = f a in if a' == a then [a] else a:repeatTillFixDebugTrace (n - 1) f a'
193 |
194 | repeatTillFixDebugTraceM :: (Monad m) => Int -> (a -> a -> Bool) -> (a -> m a) -> a -> m [a]
195 | repeatTillFixDebugTraceM 0 eqf f a = return [a]
196 | repeatTillFixDebugTraceM n eqf f a = do
197 | a' <- f a
198 | if eqf a a'
199 | then return [a]
200 | else do
201 | as <- repeatTillFixDebugTraceM (n - 1) eqf f a'
202 | return (a' : as)
203 | \end{code}
204 |
--------------------------------------------------------------------------------
/src/BaseIR.lhs:
--------------------------------------------------------------------------------
1 |
BaseIR
2 |
3 | This module contains the building blocks that are shared across the `IR` and
4 | the `MIPSAsm` module. They both use ideas of `Program`, `BasicBlock`, etc, but
5 | with slightly different underlying types. Hence, we unify the common code here.
6 | \begin{code}
7 | {-# LANGUAGE StandaloneDeriving #-}
8 | {-# LANGUAGE DeriveAnyClass #-}
9 | {-# LANGUAGE DeriveFunctor #-}
10 | {-# LANGUAGE DeriveFoldable #-}
11 | {-# LANGUAGE DeriveTraversable #-}
12 | module BaseIR where
13 |
14 | import qualified Control.Arrow as A
15 | import Data.Text.Prettyprint.Doc as PP
16 | import qualified OrderedMap as M
17 | import Data.Functor.Identity
18 | import Data.Traversable
19 | import qualified Data.Monoid as M
20 | import Control.Monad
21 | import Data.Bifunctor
22 | import PrettyUtils
23 |
24 | -- | A label that uses the phantom @a as a type based discriminator
25 | data Label a = Label { unLabel :: String } deriving(Eq, Ord, Functor, Foldable, Traversable)
26 | instance Pretty (Label a) where
27 | pretty (Label s) = pretty s
28 |
29 |
30 | -- | Convert from one type of label to another label.
31 | unsafeTransmuteLabel :: Label a -> Label b
32 | unsafeTransmuteLabel (Label lbl) = Label lbl
33 |
34 | -- | A basic block. Single-entry, multiple-exit.
35 | -- | TODO: remove duplication of information about the bbLabel in both
36 | -- | Program and BasicBlock.
37 | data BasicBlock inst ret = BasicBlock {
38 | bbInsts :: [inst],
39 | bbRetInst :: ret ,
40 | bbLabel :: Label (BasicBlock inst ret)
41 | }
42 |
43 | deriving instance (Eq inst, Eq ret) => Eq (BasicBlock inst ret)
44 |
45 | -- | Used to identify basic blocks
46 | type BBId inst retinst = Label (BasicBlock inst retinst)
47 |
48 | -- TODO: replace nest with indent
49 | instance (Pretty inst, Pretty ret) => Pretty (BasicBlock inst ret)where
50 | pretty (BasicBlock insts ret label) =
51 | nest 4 (vsep ([pretty label <> pretty ":"] ++ body)) where
52 | body = map pretty insts ++ [pretty ret]
53 |
54 |
55 | data Program inst ret = Program {
56 | programBBMap :: M.OrderedMap (BBId inst ret) (BasicBlock inst ret),
57 | programEntryBBId :: (BBId inst ret)
58 | }
59 |
60 |
61 | deriving instance (Eq inst, Eq ret) => Eq (Program inst ret)
62 |
63 | instance (Pretty inst, Pretty ret) => Pretty (Program inst ret) where
64 | pretty (Program bbmap entryId) =
65 | vsep $ [pretty "entry: " <+> pretty entryId, pretty "program: "] ++
66 | fmap pretty (M.elems bbmap)
67 |
68 |
69 |
70 | -- | Run an effect at a particular basic block for a program
71 | traverseProgramAt :: Applicative f => BBId inst ret
72 | -> (BasicBlock inst ret -> f (BasicBlock inst ret))
73 | -> Program inst ret ->
74 | f (Program inst ret)
75 | traverseProgramAt bbid f (Program bbmap entryId) = Program <$> bbmap' <*> pure entryId
76 | where
77 | bbmap' = (\curbb' -> M.insert bbid curbb' bbmap) <$> (f curbb)
78 | curbb = case M.lookup bbid bbmap of
79 | Just bb -> bb
80 | Nothing -> error . docToString $ pretty "unable to find bbid in program: " <+> pretty bbid
81 |
82 |
83 | mapProgramAt :: BBId inst ret -> (BasicBlock inst ret -> BasicBlock inst ret)
84 | -> Program inst ret -> Program inst ret
85 | mapProgramAt bbid f p = runIdentity $
86 | traverseProgramAt bbid (Identity . f) p
87 |
88 |
89 | -- | Map an effect over all the BBs of the Program
90 | traverseProgramBBs :: Applicative f =>
91 | (BasicBlock inst ret -> f (BasicBlock inst' ret'))
92 | -> Program inst ret
93 | -> f (Program inst' ret')
94 | traverseProgramBBs fbb (Program bbmap entrybbid) =
95 | (Program <$> bbmap' <*> pure (unsafeTransmuteLabel entrybbid)) where
96 | -- bbmap' :: M.OrderedMap (BBId inst' ret') (BasicBlock inst' ret')
97 | bbmap' = traverse fbb bbmapRekeyed
98 |
99 | -- bbmapRekeyed :: M.OrderedMap (BBId inst' ret') (BasicBlock inst ret)
100 | bbmapRekeyed = M.editKeys unsafeTransmuteLabel bbmap
101 |
102 | -- | Map a pure effect over all BBs of the IRPRogram
103 | mapProgramBBs :: (BasicBlock inst ret -> BasicBlock inst' ret')
104 | -> Program inst ret
105 | -> Program inst' ret'
106 | mapProgramBBs fbb program = runIdentity $ traverseProgramBBs (Identity . fbb) program
107 |
108 | -- | Run a monadic effect over the basic blocks throwing away the results
109 | mapMProgramBBs_ :: Monad m => (BasicBlock inst ret -> m ()) -> Program inst ret -> m ()
110 | mapMProgramBBs_ fbb (Program bbmap _) = forM_ bbmap fbb
111 |
112 |
113 | -- | Collect results from basic blocks which can be monoidally smashed.
114 | foldMapProgramBBs :: Monoid m =>
115 | (BasicBlock inst ret -> m)
116 | -> Program inst ret
117 | -> m
118 | foldMapProgramBBs fbb program = foldMap fbb (programBBMap program)
119 |
120 | -- | Filter instructions in a basic block.
121 | filterBBInsts :: (inst -> Bool) -> BasicBlock inst ret -> BasicBlock inst ret
122 | filterBBInsts pred (BasicBlock insts retinst lbl) =
123 | BasicBlock insts' retinst lbl
124 | where insts' = filter pred insts
125 |
126 | -- | Filter instructions in a Program.
127 | filterProgramInsts :: (inst -> Bool) -> Program inst ret -> Program inst ret
128 | filterProgramInsts pred prog =
129 | mapProgramBBs (filterBBInsts pred) prog
130 |
131 | -- | Run an effect on a basic block.
132 | traverseBB :: Applicative f => (inst -> f inst')
133 | -> (ret -> f ret')
134 | -> BasicBlock inst ret
135 | -> f (BasicBlock inst' ret')
136 | traverseBB finst fretinst (BasicBlock insts retinst lbl) =
137 | BasicBlock <$> insts' <*> retinst' <*> pure (unsafeTransmuteLabel lbl) where
138 | retinst' = fretinst retinst
139 | insts' = for insts finst
140 |
141 | -- | Run an effect over a basic block throwing away the results
142 | mapMBB_ :: Monad f => (inst -> f ()) -> (ret -> f ()) -> BasicBlock inst ret -> f ()
143 | mapMBB_ finst fretinst (BasicBlock insts retinst lbl) = do
144 | for insts finst
145 | fretinst retinst
146 |
147 |
148 | weaveEffect_ :: (Traversable f, Applicative f, Monad t, Traversable t) => (a -> f (t b))
149 | -> t a -> f (t b)
150 | weaveEffect_ f as = join <$> intermediate -- f (t t b)
151 | where
152 | intermediate = for as f
153 | -- join :: t (t b) -> t b
154 | join ttb = ttb >>= (\tb -> tb)
155 |
156 | -- | Run an effect on a basic block, while allowing to create a "locus" around
157 | -- | an instruction. This can be used to delete instructions, or add a sequence
158 | -- | of instructions for one original instruction.
159 | traverseBBInstLocus :: (Applicative f, Traversable f) =>
160 | (inst -> f [inst'])
161 | -> BasicBlock inst ret
162 | -> f (BasicBlock inst' ret)
163 | traverseBBInstLocus finst (BasicBlock insts retinst lbl) =
164 |
165 | BasicBlock <$> insts'<*> pure retinst <*> pure (unsafeTransmuteLabel lbl) where
166 | insts' = weaveEffect_ finst insts
167 |
168 |
169 | mapBBInstLocus :: (inst -> [inst']) -> BasicBlock inst ret -> BasicBlock inst' ret
170 | mapBBInstLocus f bb = runIdentity $ traverseBBInstLocus (Identity . f) bb
171 | -- | Fold from the first instruction to the last one, and then on the
172 | -- | RetInst of a BB.
173 | foldlBB :: collect
174 | -> (collect -> inst -> collect)
175 | -> (collect -> ret -> collect)
176 | -> BasicBlock inst ret
177 | -> collect
178 | foldlBB seed finst fretinst (BasicBlock insts retinst lbl) =
179 | fretinst (foldl finst seed insts) retinst
180 |
181 |
182 | -- | produce results on a BB and smash them together with a monoid instance
183 | foldMapBB :: Monoid m => (inst -> m)
184 | -> (ret -> m)
185 | -> BasicBlock inst ret
186 | -> m
187 | foldMapBB finst fretinst bb =
188 | foldlBB mempty (\c i -> c M.<> finst i) (\c ri -> c M.<> fretinst ri) bb
189 |
190 |
191 | -- | Map over the instructions and return values of a basic block
192 | mapBB :: (inst -> inst')
193 | -> (ret -> ret')
194 | -> BasicBlock inst ret
195 | -> BasicBlock inst' ret'
196 | mapBB finst fretinst bb =
197 | runIdentity $ traverseBB (Identity . finst) (Identity . fretinst) bb
198 |
199 |
200 | -- | Insert instructions before the first instruction in a bb.
201 | insertInstsBeginBB :: [inst] -> BasicBlock inst ret -> BasicBlock inst ret
202 | insertInstsBeginBB pre (BasicBlock insts retinst lbl) =
203 | BasicBlock (pre++insts) retinst lbl
204 |
205 | -- | Insert instructions at the end of the last instruction in a bb.
206 | insertInstsEndBB :: [inst] -> BasicBlock inst ret -> BasicBlock inst ret
207 | insertInstsEndBB post (BasicBlock insts retinst lbl) =
208 | BasicBlock (insts++post) retinst lbl
209 |
210 |
211 | \end{code}
212 |
213 |
--------------------------------------------------------------------------------
/src/Graph.lhs:
--------------------------------------------------------------------------------
1 |
Graph
2 | In this module, we define a simple `graph` structure that can be used
3 | as:
4 |
5 | - an undirected.
6 | - a directed graph.
7 | - a tree.
8 |
9 | Ideally, we would use some sort of phantom-type mechanism to distinguish
10 | between the two, that is `Graph Undirected a` and `Graph Directed a`, but
11 | oh well `:)`.
12 |
13 |
14 |
15 | \begin{code}
16 | {-# LANGUAGE ViewPatterns #-}
17 |
18 | module Graph where
19 | import Data.List(nub)
20 | import Data.Text.Prettyprint.Doc as PP
21 | import PrettyUtils
22 | import Data.Maybe (maybeToList)
23 | import qualified OrderedMap as M
24 | import qualified Data.Set as S
25 |
26 | -- | Represents a graph with `a` as a vertex ID type
27 | newtype Graph a = Graph { edges :: [(a, a)] }
28 |
29 | instance Pretty a => Pretty (Graph a) where
30 | pretty graph =
31 | vcat [pretty "BB graph edges",
32 | (vcat . map (indent 4 . pretty) . edges $ graph)]
33 |
34 | -- | returns all edges (H -> T) with a given source H
35 | getEdgesFromSource :: Eq a => Graph a -> a -> [(a, a)]
36 | getEdgesFromSource g src = [(src, b) | (a, b) <- edges g, a == src]
37 |
38 | -- | return predecessors of a node
39 | getPredecessors :: Eq a => Graph a -> a -> [a]
40 | getPredecessors g bbid = [ src | (src, sink) <- (edges g), sink == bbid]
41 |
42 | -- | Returns the children of an element in a dom tree
43 | -- | This returns only the immediate children.
44 | getImmediateChildren :: Eq a => Graph a -> a -> [a]
45 | getImmediateChildren (Graph edges) a = [dest | (src, dest) <- edges, src==a]
46 |
47 | -- | Return all the vertices of the subgraph
48 | getAllChildren :: Eq a => Graph a -> a -> [a]
49 | getAllChildren tree@(Graph edges) a =
50 | a:(curChilds >>= (getAllChildren tree)) where
51 | curChilds = getImmediateChildren tree a
52 |
53 | -- | Return the set of vertices in DomTree
54 | vertices :: Eq a => Graph a -> [a]
55 | vertices (Graph edges) = nub (map fst edges ++ map snd edges)
56 |
57 | -- | Colors are assigned from [1..NGraphColors]
58 | type GraphColor = Int
59 | type NGraphColors = Int
60 |
61 | _greedyColorGraph :: Ord a => Graph a -- ^ Graph
62 | -> S.Set a -- ^ Set of vertices
63 | -> M.OrderedMap a (Maybe GraphColor) -- ^ Mapping from vertices to colors
64 | -> NGraphColors -- ^ Total number of graph colors available
65 | -> M.OrderedMap a (Maybe GraphColor) -- ^ Final colored graph
66 | _greedyColorGraph _ (null -> True) coloring ncolors = coloring
67 | _greedyColorGraph g vs@(S.elemAt 0 -> v) coloring ncolors =
68 | _greedyColorGraph g vs' coloring' ncolors where
69 | -- adjacent vertices
70 | adjvs = (getPredecessors g v)
71 |
72 | -- colors of adjacent vertices
73 | adjColors :: [GraphColor]
74 | adjColors = mconcat $ fmap (\v -> case (v `M.lookup` coloring) of
75 | Just (Just c) -> [c]
76 | _ -> []) adjvs
77 |
78 | -- largest color
79 | largestAdjColor = case adjColors of
80 | [] -> 0
81 | xs -> maximum xs
82 |
83 | -- Leave it uncolored it we can't find a color
84 | coloring' = if largestAdjColor == ncolors
85 | then M.insert v Nothing coloring
86 | else M.insert v (Just (largestAdjColor + 1)) coloring
87 |
88 | -- remove vertex we currently processed
89 | vs' = S.deleteAt 0 vs
90 |
91 |
92 | -- | Color the graph greedily and return the mapping of colors
93 | greedyColorGraph :: Ord a => NGraphColors -> Graph a -> M.OrderedMap a (Maybe Int)
94 | greedyColorGraph ngraphcolors g =
95 | _greedyColorGraph g (S.fromList (vertices g))
96 | mempty ngraphcolors
97 |
98 | \end{code}
99 |
--------------------------------------------------------------------------------
/src/IR.lhs:
--------------------------------------------------------------------------------
1 |
Internal Representation
2 |
3 | In this module, we define the LLVM-like IR that we compile our
4 | source code to.
5 |
6 | \begin{code}
7 | {-# LANGUAGE GADTs #-}
8 | {-# LANGUAGE DeriveFunctor #-}
9 | {-# LANGUAGE DeriveFoldable #-}
10 | {-# LANGUAGE DeriveTraversable #-}
11 | {-# LANGUAGE ViewPatterns #-}
12 | {-# LANGUAGE ScopedTypeVariables #-}
13 |
14 | module IR where
15 | import Data.Text.Prettyprint.Doc as PP
16 | import PrettyUtils
17 | import qualified Language as L
18 | import qualified Data.List.NonEmpty as NE
19 | import qualified OrderedMap as M
20 | import Data.Functor.Identity
21 | import qualified Data.Monoid as Monoid
22 | import BaseIR
23 | import Data.Traversable(for)
24 | import Control.Applicative(liftA2)
25 | import Control.Monad.State.Strict(State, execState, modify)
26 |
27 | type IRBB = BasicBlock (Named Inst) RetInst
28 | type IRBBId = BBId (Named Inst) (RetInst)
29 |
30 | -- | Default basic block.
31 | defaultIRBB :: IRBB
32 | defaultIRBB = BasicBlock [] (RetInstTerminal) (Label "undefined")
33 |
34 | -- | Given an IRBB, return a list of Phi nodes.
35 | getIRBBPhis :: IRBB -> [Named Inst]
36 | getIRBBPhis bb = bbInsts $
37 | filterBBInsts (\(Named _ i) -> case i of
38 | InstPhi _ -> True
39 | _ -> False) bb
40 |
41 |
42 | -- a Value, which can either be a constant, or a reference to an instruction.
43 | data Value = ValueConstInt Int | ValueInstRef (Label Inst) deriving(Eq)
44 |
45 | instance Pretty Value where
46 | pretty (ValueConstInt i) = pretty i <> pretty "#"
47 | pretty (ValueInstRef name) = pretty "%" <> pretty name
48 |
49 | -- | Instructions that we allow within a basic block.
50 | data Inst = InstAlloc
51 | | InstAdd Value Value
52 | | InstMul Value Value
53 | | InstL Value Value
54 | | InstAnd Value Value
55 | | InstLoad Value
56 | | InstStore Value Value
57 | | InstPhi (NE.NonEmpty (IRBBId, Value)) deriving(Eq)
58 |
59 | -- | Given `Inst` (which is known to be a Phi node), get a `Value` which
60 | -- | corresponds to the given `IRBBId`
61 | getPhiValueForBB :: IRBBId -> Inst -> Maybe Value
62 | getPhiValueForBB bbid phi@(InstPhi valList) =
63 | case NE.filter ((==bbid) . fst) valList of
64 | [] -> Nothing
65 | [(_, v)] -> Just v
66 | xs -> error . docToString $ vcat $
67 | [pretty "Phi node should at most one copy of a predecessor BB, found:",
68 | pretty xs,
69 | pretty "Phi node:",
70 | pretty phi]
71 | getPhiValueForBB _ inst =
72 | error . docToString $ vcat
73 | [pretty "getPhiValueForBB should only be called on Phi. Found:",
74 | pretty inst]
75 | -- | Map over the `Value`s in an Inst
76 | mapInstValue :: (Value -> Value) -> Inst -> Inst
77 | mapInstValue f inst = runIdentity $ forInstValue (Identity . f) inst
78 |
79 | -- | TODO: use Uniplate.
80 | -- | Run an effect `f` over the values of an instruction
81 | forInstValue :: Applicative m => (Value -> m Value) -> Inst -> m Inst
82 | forInstValue _ (InstAlloc) = pure InstAlloc
83 | forInstValue f (InstAdd lhs rhs) = InstAdd <$> (f lhs) <*> (f rhs)
84 | forInstValue f (InstMul lhs rhs) = InstMul <$> (f lhs) <*> (f rhs)
85 | forInstValue f (InstL lhs rhs) = InstL <$> (f lhs) <*> (f rhs)
86 | forInstValue f (InstAnd lhs rhs) = InstAnd <$> (f lhs) <*> (f rhs)
87 | forInstValue f (InstLoad lhs) = InstLoad <$> f lhs
88 | forInstValue f (InstStore lhs rhs) = InstStore <$> (f lhs) <*> (f rhs)
89 | forInstValue f (InstPhi valList) = InstPhi <$> for valList (f' f) where
90 | f' :: Applicative m => (Value -> m Value)
91 | -> (IRBBId, Value)
92 | -> m (IRBBId, Value)
93 | f' f (irbbid, val) = liftA2 (,) (pure irbbid) (f val)
94 |
95 | -- | Collect a monoidal Value over an Inst
96 | foldMapInstValue :: Monoid m => (Value -> m) -> Inst -> m
97 | foldMapInstValue f inst = execState final Monoid.mempty where
98 | -- go :: Value -> State m Value
99 | go v = do
100 | modify (\m -> m Monoid.<> f v)
101 | return v
102 |
103 | -- final :: State m Inst
104 | final = (forInstValue go inst)
105 |
106 |
107 | instance Pretty Inst where
108 | pretty (InstAlloc) = pretty "alloc"
109 | pretty (InstAdd l r) = pretty "add" <+> pretty l <+> pretty r
110 | pretty (InstMul l r) = pretty "mul" <+> pretty l <+> pretty r
111 | pretty (InstL l r) = pretty "lessthan" <+> pretty l <+> pretty r
112 | pretty (InstAnd l r) = pretty "and" <+> pretty l <+> pretty r
113 | pretty (InstLoad op) = pretty "load" <+> pretty op
114 | pretty (InstStore slot val) = pretty "store" <+> pretty val <+>
115 | pretty "in" <+> pretty slot
116 | pretty (InstPhi philist) =
117 | pretty "Phi: " <+> hcat (punctuate comma (NE.toList (fmap (\(bbid, val) ->
118 | brackets (pretty bbid <+> pretty val)) philist)))
119 |
120 | -- | Return instructions are the only ones that can cause control flow
121 | -- | between one basic block to another.
122 | data RetInst =
123 | RetInstConditionalBranch Value IRBBId IRBBId |
124 | RetInstBranch IRBBId |
125 | RetInstTerminal |
126 | RetInstRet Value deriving(Eq)
127 |
128 | instance Pretty RetInst where
129 | pretty (RetInstTerminal) = pretty "TERMINAL"
130 | pretty (RetInstBranch next) = pretty "branch" <+> pretty next
131 | pretty (RetInstConditionalBranch cond then' else') =
132 | pretty "branch if" <+> pretty cond <+>
133 | pretty "then" <+> pretty then' <+>
134 | pretty "else" <+> pretty else'
135 | pretty (RetInstRet val) = pretty "ret" <+> pretty val
136 |
137 | -- | Run an effect `f` over the values of the return instruction
138 | forRetInstValue :: Applicative m => (Value -> m Value) -> RetInst -> m RetInst
139 | forRetInstValue _ RetInstTerminal = pure RetInstTerminal
140 | forRetInstValue _ (RetInstBranch bbid) = pure (RetInstBranch bbid)
141 | forRetInstValue f (RetInstConditionalBranch v t e) =
142 | RetInstConditionalBranch <$> f v <*> pure t <*> pure e
143 | forRetInstValue f (RetInstRet v) = RetInstRet <$> f v
144 |
145 | mapRetInstValue :: (Value -> Value) -> RetInst -> RetInst
146 | mapRetInstValue f ret = runIdentity $ forRetInstValue (Identity . f) ret
147 |
148 | -- | Run an effect `f` over the basic block IDs of the return instruction
149 | forRetInstBBId :: Applicative m => (IRBBId -> m IRBBId) -> RetInst -> m RetInst
150 | forRetInstBBId _ RetInstTerminal = pure RetInstTerminal
151 | forRetInstBBId f (RetInstBranch bbid) = (RetInstBranch <$> f bbid)
152 | forRetInstBBId f (RetInstConditionalBranch v t e) =
153 | RetInstConditionalBranch <$> pure v <*> f t <*> f e
154 | forRetInstBBId _ (RetInstRet v) = pure (RetInstRet v)
155 |
156 | mapRetInstBBId :: (IRBBId -> IRBBId) -> RetInst -> RetInst
157 | mapRetInstBBId f ret = runIdentity $ forRetInstBBId (Identity . f) ret
158 |
159 |
160 | -- | Represents @a that is optionally named by a @Label a
161 | data Named a = Named { namedName :: Label a, namedData :: a } deriving(Functor, Foldable, Traversable, Eq)
162 |
163 | hasName :: (Label a) -> Named a -> Bool
164 | hasName lbl named = namedName named == lbl
165 |
166 |
167 | -- | Infix operator for @Named constructor
168 | (=:=) :: Label a -> a -> Named a
169 | name =:= a = Named name a
170 |
171 | instance Pretty a => Pretty (Named a) where
172 | pretty (Named name data') = pretty name <+> pretty ":=" <+> pretty data'
173 |
174 |
175 | type IRProgram = Program (Named Inst) RetInst
176 |
177 | -- | Replace all uses of an instruction in a program
178 | replaceUsesOfInst :: Label Inst -> Value -> IRProgram -> IRProgram
179 | replaceUsesOfInst instlbl newval program =
180 | mapProgramBBs fbb program where
181 | replaceVal :: Value -> Value
182 | replaceVal (ValueInstRef ((== instlbl) -> True)) = newval
183 | replaceVal v = v
184 |
185 | finst :: Named Inst -> Named Inst
186 | finst = fmap (mapInstValue replaceVal)
187 |
188 | fretinst :: RetInst -> RetInst
189 | fretinst = mapRetInstValue replaceVal
190 |
191 | fbb :: IRBB -> IRBB
192 | fbb = mapBB finst fretinst
193 |
194 | \end{code}
195 |
--------------------------------------------------------------------------------
/src/IRInterpreter.lhs:
--------------------------------------------------------------------------------
1 | \begin{code}
2 | {-# LANGUAGE RecordWildCards #-}
3 | module IRInterpreter(runProgram) where
4 | import qualified OrderedMap as M
5 | import Control.Monad.State.Strict
6 | import Data.Traversable
7 | import Data.Foldable
8 | import Control.Applicative
9 | import qualified Data.List.NonEmpty as NE
10 | import IR
11 | import BaseIR
12 | import Data.Text.Prettyprint.Doc as PP
13 | import PrettyUtils
14 |
15 |
16 | data Evaluator = Evaluator {
17 | program :: IRProgram,
18 | prevbbid :: Maybe IRBBId,
19 | valueMap :: M.OrderedMap (Label Inst) Int,
20 | returnval :: Maybe Int
21 | }
22 | instance Pretty Evaluator where
23 | pretty Evaluator{..} =pretty "Evaluator" <+> (braces . indent 2) (vcat [pretty "program: ",
24 | indent 2 . pretty $ program,
25 | pretty "prevbb: ",
26 | indent 2 . pretty $ prevbbid,
27 | pretty "valueMap: ",
28 | indent 2 . pretty $ valueMap,
29 | pretty "returnval: ",
30 | indent 2 . pretty $ returnval])
31 |
32 | initEvaluator :: IRProgram -> Evaluator
33 | initEvaluator program = Evaluator {
34 | program = program,
35 | prevbbid = Nothing,
36 | valueMap = mempty,
37 | returnval = Nothing
38 | }
39 |
40 | loadName :: Label Inst -> State Evaluator Int
41 | loadName name = gets $ (lookupName name) where
42 | lookupName :: Label Inst -> Evaluator -> Int
43 | lookupName name evaluator@Evaluator{valueMap=vmap} = case M.lookup name vmap of
44 | Just val -> val
45 | Nothing -> error . docToString $
46 | vcat [pretty "unable to find mapping to variable:" <+> pretty name,
47 | pretty "state: ",
48 | pretty evaluator]
49 |
50 |
51 | setValue :: Label Inst -> Int -> State Evaluator ()
52 | setValue name val =
53 | modify (\ctx -> ctx { valueMap=M.insert name val (valueMap ctx) })
54 |
55 | getValue :: Value -> State Evaluator Int
56 | getValue (ValueConstInt i) = return i
57 | getValue (ValueInstRef name) = loadName name
58 |
59 | getPreviousBBId :: State Evaluator IRBBId
60 | getPreviousBBId = do
61 | prevbb <- gets prevbbid
62 | case prevbb of
63 | Just id' -> return id'
64 | Nothing -> error "no previous BB id found."
65 |
66 | evaluateInst :: Named Inst -> State Evaluator ()
67 | evaluateInst namedinst@(Named lhsname inst) = do
68 | case inst of
69 | InstAlloc -> return ()
70 | InstLoad slot -> getValue slot >>= setValue lhsname
71 | InstStore (ValueInstRef slotname) val -> getValue val >>= setValue slotname
72 | InstAdd l r -> liftA2 (+) (getValue l) (getValue r) >>= setValue lhsname
73 | InstMul l r -> liftA2 (*) (getValue l) (getValue r) >>= setValue lhsname
74 | InstL l r -> liftA2 (\l r -> if l < r then 1 else 0) (getValue l) (getValue r) >>= setValue lhsname
75 | InstAnd l r -> liftA2 (\l r -> l * r) (getValue l) (getValue r) >>= setValue lhsname
76 | InstPhi bbidValuePairs -> do
77 | prevbbid <- getPreviousBBId
78 | getValue (snd (getCurrentBBIdValue prevbbid)) >>= setValue lhsname
79 | where
80 | pred :: IRBBId -> (IRBBId, Value) -> Bool
81 | pred prevbbid (bbid, _) = bbid == prevbbid
82 |
83 | getCurrentBBIdValue :: IRBBId -> (IRBBId, Value)
84 | getCurrentBBIdValue prevbbid = head . NE.filter (pred prevbbid) $ bbidValuePairs
85 |
86 |
87 | followRetInst :: RetInst -> State Evaluator (Maybe IRBBId)
88 | followRetInst (RetInstTerminal) = return Nothing
89 | followRetInst (RetInstBranch bbid) = return (Just bbid)
90 | followRetInst (RetInstConditionalBranch val t e) = do
91 | valInt <- getValue val
92 | if valInt == 1
93 | then return (Just t)
94 | else return (Just e)
95 | followRetInst (RetInstRet retval) = do
96 | retvalInt <- getValue retval
97 | modify (\evaluator -> evaluator { returnval=Just retvalInt})
98 | return Nothing
99 |
100 | evaluateBB :: IRBBId -> State Evaluator ()
101 | evaluateBB bbid = do
102 | bb <- gets $ (M.! bbid) . programBBMap . program
103 | for (bbInsts bb) evaluateInst
104 | nextid <- followRetInst (bbRetInst bb)
105 | modify (\evaluator -> evaluator {prevbbid=Just bbid})
106 |
107 | case nextid of
108 | Nothing -> return ()
109 | Just nextid -> evaluateBB nextid
110 |
111 | -- | TODO: convert to Either Error (Maybe Int)
112 | -- | The internal monad transformer would need to become EitherT
113 | runProgram :: IRProgram -> Maybe Int
114 | runProgram program = returnval $ execState (evaluateBB (programEntryBBId program)) (initEvaluator program)
115 | \end{code}
116 |
--------------------------------------------------------------------------------
/src/ISL/Native.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE QuasiQuotes #-}
2 | {-# LANGUAGE TemplateHaskell #-}
3 | {-# LANGUAGE OverloadedStrings #-}
4 |
5 | -- | An inline-c based low-level interface to isl.
6 | module ISL.Native
7 | ( IslCopy(copy)
8 | , IslFree(free)
9 |
10 | , ctxFree
11 |
12 | , basicSetCopy
13 | , basicSetFree
14 |
15 | , unsafeSetIntersect
16 | , setIntersect
17 | , unsafeSetUnion
18 | , setUnion
19 | , unsafeSetSubtract
20 | , setSubtract
21 | , setCopy
22 | , setEmpty
23 | , unsafeSetUniverse
24 | , setUniverse
25 | , setGetSpace
26 | , setFree
27 | , setNBasicSet
28 | , unsafeSetCoalesce
29 | , setCoalesce
30 | , unsafeSetParams
31 | , setParams
32 | , setComplement
33 | , setGetDimId
34 | , unsafeSetProjectOut
35 | , setProjectOut
36 |
37 | , basicMapCopy
38 | , basicMapFree
39 |
40 | , mapCopy
41 | , mapFree
42 |
43 | , localSpaceCopy
44 | , localSpaceFree
45 |
46 | , spaceCopy
47 | , spaceFree
48 |
49 | , constraintCopy
50 | , constraintFree
51 |
52 | , idCopy
53 | , idFree
54 | ) where
55 |
56 | import Control.Monad (void)
57 | import Foreign.Ptr
58 | import Foreign.C
59 | import qualified Language.C.Inline as C
60 |
61 | import ISL.Native.Context (islCtx)
62 | import ISL.Native.Types
63 |
64 | C.context islCtx
65 |
66 | C.include ""
67 | C.include ""
68 | C.include ""
69 | C.include ""
70 | C.include ""
71 | C.include ""
72 | C.include ""
73 |
74 | class IslCopy a where
75 | copy :: Ptr a -> Ptr a
76 |
77 | class IslFree a where
78 | free :: Ptr a -> IO ()
79 |
80 | -- __isl_take: can no longer be used
81 | -- __isl_keep: only used temporarily
82 |
83 | -- * Ctx
84 |
85 | instance IslFree Ctx where free = ctxFree
86 |
87 | ctxFree :: Ptr Ctx -> IO ()
88 | ctxFree ctx = [C.block| void { isl_ctx_free($(isl_ctx* ctx)); } |]
89 |
90 | -- * BasicSet
91 |
92 | instance IslCopy BasicSet where copy = basicSetCopy
93 | instance IslFree BasicSet where free = basicSetFree
94 |
95 | basicSetCopy :: Ptr BasicSet -> Ptr BasicSet
96 | basicSetCopy bset =
97 | [C.pure| isl_basic_set* { isl_basic_set_copy($(isl_basic_set* bset)) } |]
98 |
99 | basicSetFree :: Ptr BasicSet -> IO ()
100 | basicSetFree bset = void
101 | [C.block| isl_basic_set* { isl_basic_set_free($(isl_basic_set* bset)); } |]
102 |
103 | -- * Set
104 |
105 | instance IslCopy Set where copy = setCopy
106 | instance IslFree Set where free = setFree
107 |
108 | setCopy :: Ptr Set -> Ptr Set
109 | setCopy set = [C.pure| isl_set* { isl_set_copy($(isl_set* set)) } |]
110 |
111 | setFree :: Ptr Set -> IO ()
112 | setFree set = void [C.block| isl_set* { isl_set_free($(isl_set* set)); } |]
113 |
114 | unsafeSetIntersect :: Ptr Set -> Ptr Set -> Ptr Set
115 | unsafeSetIntersect set1 set2 = [C.pure| isl_set* {
116 | isl_set_intersect($(isl_set* set1), $(isl_set* set2))
117 | } |]
118 |
119 | setIntersect :: Ptr Set -> Ptr Set -> Ptr Set
120 | setIntersect set1 set2 = unsafeSetIntersect (setCopy set1) (setCopy set2)
121 |
122 | unsafeSetUnion :: Ptr Set -> Ptr Set -> Ptr Set
123 | unsafeSetUnion set1 set2 = [C.pure| isl_set* {
124 | isl_set_union($(isl_set* set1), $(isl_set* set2))
125 | } |]
126 |
127 | setUnion :: Ptr Set -> Ptr Set -> Ptr Set
128 | setUnion set1 set2 = unsafeSetUnion (setCopy set1) (setCopy set2)
129 |
130 | unsafeSetSubtract :: Ptr Set -> Ptr Set -> Ptr Set
131 | unsafeSetSubtract set1 set2 = [C.pure| isl_set* {
132 | isl_set_subtract($(isl_set* set1), $(isl_set* set2))
133 | } |]
134 |
135 | setSubtract :: Ptr Set -> Ptr Set -> Ptr Set
136 | setSubtract set1 set2 = unsafeSetSubtract (setCopy set1) (setCopy set2)
137 |
138 | -- | Create an empty set
139 | setEmpty :: Ptr Space -> Ptr Set
140 | setEmpty space = [C.pure| isl_set* { isl_set_empty($(isl_space* space)) } |]
141 |
142 | -- | Create a universe set
143 | unsafeSetUniverse :: Ptr Space -> Ptr Set
144 | unsafeSetUniverse space = [C.pure| isl_set* {
145 | isl_set_universe($(isl_space* space))
146 | } |]
147 |
148 | setUniverse :: Ptr Space -> Ptr Set
149 | setUniverse = unsafeSetUniverse . spaceCopy
150 |
151 | -- | It is often useful to create objects that live in the same space as some
152 | -- other object. This can be accomplished by creating the new objects based on
153 | -- the space of the original object.
154 | setGetSpace :: Ptr Set -> Ptr Space
155 | setGetSpace set = [C.pure| isl_space* {
156 | isl_set_get_space($(isl_set* set))
157 | } |]
158 |
159 | -- | The number of basic sets in a set can be obtained
160 | setNBasicSet :: Ptr Set -> CInt
161 | setNBasicSet set = [C.pure| int { isl_set_n_basic_set($(isl_set* set)) } |]
162 |
163 | unsafeSetCoalesce :: Ptr Set -> Ptr Set
164 | unsafeSetCoalesce set =
165 | [C.pure| isl_set* { isl_set_coalesce($(isl_set* set)) } |]
166 |
167 | -- | Simplify the representation of a set by trying to combine pairs of basic
168 | -- sets into a single basic set.
169 | setCoalesce :: Ptr Set -> Ptr Set
170 | setCoalesce = unsafeSetCoalesce . setCopy
171 |
172 | -- | Projection
173 | unsafeSetParams :: Ptr Set -> Ptr Set
174 | unsafeSetParams set = [C.pure| isl_set* { isl_set_params($(isl_set* set)) } |]
175 |
176 | setParams :: Ptr Set -> Ptr Set
177 | setParams = unsafeSetParams . setCopy
178 |
179 | unsafeSetComplement :: Ptr Set -> Ptr Set
180 | unsafeSetComplement set =
181 | [C.pure| isl_set* { isl_set_complement($(isl_set* set)) } |]
182 |
183 | -- | Projection
184 | setComplement :: Ptr Set -> Ptr Set
185 | setComplement = unsafeSetComplement . setCopy
186 |
187 | setGetDimId :: Ptr Set -> DimType -> CUInt -> Ptr Id
188 | setGetDimId set ty pos =
189 | let ty' :: CInt
190 | ty' = fromDimType ty
191 | in [C.pure| isl_id* {
192 | isl_set_get_dim_id(
193 | $(isl_set* set),
194 | $(int ty'),
195 | $(unsigned int pos)
196 | )
197 | } |]
198 |
199 | unsafeSetProjectOut :: Ptr Set -> DimType -> CUInt -> CUInt -> Ptr Set
200 | unsafeSetProjectOut set ty first n =
201 | let ty' :: CInt
202 | ty' = fromDimType ty
203 | in [C.pure| isl_set* {
204 | isl_set_project_out(
205 | $(isl_set* set),
206 | $(int ty'),
207 | $(unsigned int first),
208 | $(unsigned int n)
209 | )
210 | } |]
211 |
212 | setProjectOut :: Ptr Set -> DimType -> CUInt -> CUInt -> Ptr Set
213 | setProjectOut set ty first n = unsafeSetProjectOut (setCopy set) ty first n
214 |
215 | -- * BasicMap
216 |
217 | instance IslCopy BasicMap where copy = basicMapCopy
218 | instance IslFree BasicMap where free = basicMapFree
219 |
220 | basicMapCopy :: Ptr BasicMap -> Ptr BasicMap
221 | basicMapCopy bmap =
222 | [C.pure| isl_basic_map* { isl_basic_map_copy($(isl_basic_map* bmap)) } |]
223 |
224 | basicMapFree :: Ptr BasicMap -> IO ()
225 | basicMapFree bmap = void
226 | [C.block| isl_basic_map* { isl_basic_map_free($(isl_basic_map* bmap)); } |]
227 |
228 | -- * Map
229 |
230 | instance IslCopy Map where copy = mapCopy
231 | instance IslFree Map where free = mapFree
232 |
233 | mapCopy :: Ptr Map -> Ptr Map
234 | mapCopy map = [C.pure| isl_map* { isl_map_copy($(isl_map* map)) } |]
235 |
236 | mapFree :: Ptr Map -> IO ()
237 | mapFree map = void [C.block| isl_map* { isl_map_free($(isl_map* map)); } |]
238 |
239 | -- * LocalSpace
240 |
241 | instance IslCopy LocalSpace where copy = localSpaceCopy
242 | instance IslFree LocalSpace where free = localSpaceFree
243 |
244 | localSpaceCopy :: Ptr LocalSpace -> Ptr LocalSpace
245 | localSpaceCopy ls =
246 | [C.pure| isl_local_space* { isl_local_space_copy($(isl_local_space* ls)) } |]
247 |
248 | localSpaceFree :: Ptr LocalSpace -> IO ()
249 | localSpaceFree ls = void
250 | [C.block| isl_local_space* { isl_local_space_free($(isl_local_space* ls)); } |]
251 |
252 | -- * Space
253 |
254 | instance IslCopy Space where copy = spaceCopy
255 | instance IslFree Space where free = spaceFree
256 |
257 | spaceCopy :: Ptr Space -> Ptr Space
258 | spaceCopy space =
259 | [C.pure| isl_space* { isl_space_copy($(isl_space* space)) } |]
260 |
261 | spaceFree :: Ptr Space -> IO ()
262 | spaceFree space = void
263 | [C.block| isl_space* { isl_space_free($(isl_space* space)); } |]
264 |
265 | -- * Constraint
266 |
267 | instance IslCopy Constraint where copy = constraintCopy
268 | instance IslFree Constraint where free = constraintFree
269 |
270 | constraintCopy :: Ptr Constraint -> Ptr Constraint
271 | constraintCopy c =
272 | [C.pure| isl_constraint* { isl_constraint_copy($(isl_constraint* c)) } |]
273 |
274 | constraintFree :: Ptr Constraint -> IO ()
275 | constraintFree c = void
276 | [C.block| isl_constraint* { isl_constraint_free($(isl_constraint* c)); } |]
277 |
278 | -- * Id
279 |
280 | instance IslCopy Id where copy = idCopy
281 | instance IslFree Id where free = idFree
282 |
283 | idCopy :: Ptr Id -> Ptr Id
284 | idCopy i = [C.pure| isl_id* { isl_id_copy($(isl_id* i)) } |]
285 |
286 | idFree :: Ptr Id -> IO ()
287 | idFree i = void [C.block| isl_id* { isl_id_free($(isl_id* i)); } |]
288 |
--------------------------------------------------------------------------------
/src/ISL/Native/Context.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE QuasiQuotes #-}
2 | {-# LANGUAGE TemplateHaskell #-}
3 | {-# LANGUAGE OverloadedStrings #-}
4 |
5 | module ISL.Native.Context (islCtx) where
6 |
7 | import qualified Language.C.Inline as C
8 | import Language.C.Inline.Context
9 | import qualified Language.C.Types as C
10 | import qualified Data.Map as Map
11 | import Data.Monoid ((<>))
12 | import qualified Language.Haskell.TH as TH
13 |
14 | import ISL.Native.Types
15 |
16 | islCtx :: C.Context
17 | islCtx = baseCtx <> bsCtx <> ctx
18 | where
19 | ctx = mempty
20 | { ctxTypesTable = islTypesTable
21 | }
22 |
23 | islTypesTable :: Map.Map C.TypeSpecifier TH.TypeQ
24 | islTypesTable = Map.fromList
25 | [ (C.TypeName "isl_ctx", [t| Ctx |])
26 | , (C.TypeName "isl_map", [t| Map |])
27 | , (C.TypeName "isl_basic_map", [t| BasicMap |])
28 | , (C.TypeName "isl_set", [t| Set |])
29 | , (C.TypeName "isl_basic_set", [t| BasicSet |])
30 | , (C.TypeName "isl_local_space", [t| LocalSpace |])
31 | , (C.TypeName "isl_space", [t| Space |])
32 | , (C.TypeName "isl_constraint", [t| Constraint |])
33 | , (C.TypeName "isl_id", [t| Id |])
34 | , (C.TypeName "isl_dim_type", [t| DimType |])
35 | ]
36 |
--------------------------------------------------------------------------------
/src/ISL/Native/Types.chs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ForeignFunctionInterface #-}
2 |
3 | -- | Types for the low-level interface to isl.
4 | module ISL.Native.Types where
5 |
6 | #include
7 |
8 | import Foreign.C (CInt)
9 |
10 | -- | A given context can only be used within a single thread, and all arguments
11 | -- to a function must be allocated within the same context. All objects
12 | -- allocated within a context should be freed before the context is freed.
13 | data Ctx
14 |
15 | -- | A single-space set of tuples that can be described as a conjunction of
16 | -- affine constraints.
17 | data BasicSet
18 |
19 | -- | A union of 'BasicSet's
20 | data Set
21 |
22 | -- | A single-space relation mapping tuples to tuples that can be described as
23 | -- a conjunction of affine constraints.
24 | data BasicMap
25 |
26 | -- | A union of 'BasicMap's
27 | data Map
28 |
29 | -- | A local space is essentially a space with zero or more existentially
30 | -- quantified variables. The local space of various objects can be obtained
31 | -- using the following functions.
32 | data LocalSpace
33 |
34 | -- | Whenever a new set, relation or similar object is created from scratch,
35 | -- the space in which it lives needs to be specified using an isl_space. Each
36 | -- space involves zero or more parameters and zero, one or two tuples of set or
37 | -- input/output dimensions. The parameters and dimensions are identified by an
38 | -- isl_dim_type and a position. The type isl_dim_param refers to parameters,
39 | -- the type isl_dim_set refers to set dimensions (for spaces with a single
40 | -- tuple of dimensions) and the types isl_dim_in and isl_dim_out refer to input
41 | -- and output dimensions (for spaces with two tuples of dimensions). Local
42 | -- spaces (see §1.4.9) also contain dimensions of type isl_dim_div. Note that
43 | -- parameters are only identified by their position within a given object.
44 | -- Across different objects, parameters are (usually) identified by their names
45 | -- or identifiers. Only unnamed parameters are identified by their positions
46 | -- across objects. The use of unnamed parameters is discouraged.
47 | data Space
48 |
49 | -- | An affine constraint.
50 | data Constraint
51 |
52 | -- | Identifiers are used to identify both individual dimensions and tuples of
53 | -- dimensions. They consist of an optional name and an optional user pointer.
54 | -- The name and the user pointer cannot both be NULL, however. Identifiers with
55 | -- the same name but different pointer values are considered to be distinct.
56 | -- Similarly, identifiers with different names but the same pointer value are
57 | -- also considered to be distinct. Equal identifiers are represented using the
58 | -- same object. Pairs of identifiers can therefore be tested for equality using
59 | -- the == operator. Identifiers can be constructed, copied, freed, inspected
60 | -- and printed using the following functions.
61 | data Id
62 |
63 | -- an ISL List of a's
64 | data List a
65 |
66 | data Val
67 | data Aff
68 | data Pwaff
69 | data Pwmultiaff
70 | data Multipwaff
71 |
72 | {#enum isl_dim_type as DimType {underscoreToCase} deriving(Eq, Show) #}
73 | {#enum isl_bool as IslBool {underscoreToCase} deriving(Eq, Show) #}
74 |
75 | fromDimType :: DimType -> CInt
76 | fromDimType = fromIntegral . fromEnum
77 |
78 | fromRawIslBool :: CInt -> Maybe Bool
79 | fromRawIslBool i =
80 | case (fromIntegral i) of
81 | -1 -> Nothing
82 | 0 -> Just False
83 | 1 -> Just True
84 |
85 |
86 |
--------------------------------------------------------------------------------
/src/ISL/Types.hs:
--------------------------------------------------------------------------------
1 | -- | Types for the high-level interface to isl.
2 | module ISL.Types where
3 |
--------------------------------------------------------------------------------
/src/Index.lhs:
--------------------------------------------------------------------------------
1 |
Tiny optimising compiler
2 |
3 | Welcome to the tutorial series that teaches how to write a tiny optimising
4 | compiler in haskell!
5 |
6 |
7 |
8 | Start from:
9 |
10 | 1. [The source language.](language.html)
11 |
12 | 2. [The parser for the language.](parser.html)
13 |
14 | 3. [The internal representation.](ir.html)
15 |
16 | 4. [The `mem2reg` transform that lands us into `SSA`.](transformmem2reg.html)
17 |
18 | 5. [The `constant folding` transform that exploits `SSA` to "fold away" expressions
19 | which can be evaluated at compile time.](transformconstantfolding.html)
20 |
21 | 6. [The `register allocation` transform which allocates physical registers to
22 | the infinite virtual registers of our SSA form.](transformregisterallocate.html)
23 |
24 | 7. [The MIPS assembly specification](mipsasm.html), and the associated interpreter
25 | which uses [SPIM](mipsinterpreter.hs)
26 |
27 | 7. [The `mipsasm` code generation pass which generates MIPS assembly from our IR.](transformirtomips.html)
28 |
Background
29 |
30 | I've wanted to write this for a while: a tiny *optimising* compiler for
31 | a small imperative ish language.
32 |
33 | I want to show off modern compiler ideas, such as:
34 |
35 | - SSA.
36 | - optimisations enabled by SSA.
37 | - Scalar evolution.
38 | - Polyhedral compilation
39 |
40 | I currently have a parser for the source language, conversion to IR, then
41 | to SSA, and a semi-broken MIPS backend.
42 |
43 |
Goals
44 | - Be readable code.
45 | - Be literate code (preferably).
46 | - Show off real world optimisations.
47 |
48 |
Non goals
49 | Shows the correct way of doing a lot of things, in the sense of "engineering". I
50 | might pick the slower algorithm to compute a dominator tree, because I wish to
51 | emphasize the _idea_ of the dominator tree. When a trade off is presented
52 | between simplicity and performance, I will pick simplicity.
53 |
54 |
55 |
Timeline
56 |
57 | - `[x]` Parse
58 | - `[x]` Generate non-SSA IR
59 | - `[x]` Convert non-SSA to SSA (`Mem2Reg` is the pass where this happens.)
60 | - `[x]` generate MIPS assembly from SSA IR (half-done)
61 | - `[ ]` (Optional) generate LLVM for SSA IR (Can be pulled from [simplexhc](http://github.com/bollu/simplexhc))
62 |
63 | At this point, we have a "functioning" compiler. Now, we can extend the
64 | compiler or the language. I want to show off optimisations, so I will spend
65 | more time implementing optimisations
66 |
67 | - `[ ]` Loop detection.
68 | - `[ ]` Scalar evolution.
69 | - `[ ]` Global value numbering.
70 | - `[ ]` Dead code elimination.
71 | - `[ ]` Loop unrolling.
72 | - `[ ]` invariant load hoisting.
73 |
74 | Note that we do not yet have functions in the language! let's add that.
75 |
76 | - `[ ]` extend language with functions.
77 | - `[ ]` generate MIPS for functions.
78 | - `[ ]` Inlining.
79 |
80 |
81 | If we get here, we can then add polyhedral abilities to the compiler. For
82 | this though, we would need to integrate with `isl`. **Someone** will need to write
83 | haskell bindings `:)`.
84 |
85 |
86 |
--------------------------------------------------------------------------------
/src/Language.lhs:
--------------------------------------------------------------------------------
1 | \begin{code}
2 | module Language where
3 | import Data.Text.Prettyprint.Doc as PP
4 |
5 | newtype Literal = Literal { unLiteral :: String } deriving(Ord, Eq)
6 | instance Pretty Literal where
7 | pretty = pretty . unLiteral
8 |
9 | data BinOp = Plus | Multiply | L | And
10 | instance Pretty BinOp where
11 | pretty Plus = pretty "+"
12 | pretty Multiply = pretty "*"
13 | pretty L = pretty "<"
14 | pretty And = pretty "&&"
15 |
16 | data Expr a = EBinOp a (Expr a) BinOp (Expr a) |
17 | EInt a Int |
18 | ELiteral a Literal
19 |
20 | instance Pretty (Expr a) where
21 | pretty (EBinOp _ l op r) = pretty "(" <+> pretty op <+>
22 | pretty l <+> pretty r <+> pretty ")"
23 | pretty (EInt _ i) = pretty i
24 | pretty (ELiteral _ lit) = pretty lit
25 |
26 | type Expr' = Expr ()
27 |
28 | data Stmt a = If a (Expr a) (Block a) (Block a) |
29 | While a (Expr a) (Block a) |
30 | Assign a Literal (Expr a) |
31 | Define a Literal |
32 | Return a (Expr a)
33 | type Block a = [Stmt a]
34 |
35 |
36 | nestDepth :: Int
37 | nestDepth = 4
38 |
39 | instance Pretty (Stmt a) where
40 | pretty (If _ cond then' else') = pretty "if" <+> pretty cond <+>
41 | PP.braces (nest 4 (pretty then')) <+>
42 | PP.braces (nest 4 (pretty else'))
43 |
44 | pretty (While _ cond body) = pretty "while" <+> pretty cond <+> PP.braces (nest 4 (pretty body))
45 | pretty (Assign _ lhs rhs) = pretty "assign" <+> pretty lhs <+> pretty ":=" <+> pretty rhs
46 | pretty (Define _ lit) = pretty "define" <+> pretty lit
47 | pretty (Return _ expr) = pretty "return" <+> pretty expr
48 |
49 | type Stmt' = Stmt ()
50 |
51 |
52 | newtype Program a = Program [Stmt a]
53 | type Program' = Program ()
54 |
55 | instance Pretty (Program a) where
56 | pretty (Program stmts) = vcat (map pretty stmts)
57 | \end{code}
58 |
--------------------------------------------------------------------------------
/src/MIPSAsm.lhs:
--------------------------------------------------------------------------------
1 | \begin{code}
2 | {-# LANGUAGE DeriveAnyClass #-}
3 | {-# LANGUAGE GADTs #-}
4 | {-# LANGUAGE TypeFamilies #-}
5 |
6 | module MIPSAsm(MReg(..),
7 | MRegLabel,
8 | mkTemporaryReg,
9 | MBBLabel,
10 | MBB,
11 | MProgram,
12 | MInst(..),
13 | mkMov,
14 | regToString,
15 | MTerminatorInst(..),
16 | regZero,
17 | rega0,
18 | regv0,
19 | regsp,
20 | printMIPSAsm,
21 | traverseMInstReg,
22 | mapMInstReg,
23 | foldMapMInstReg,
24 | getMInstRegs,
25 | traverseMTerminatorInstReg,
26 | mapMTerminatorInstReg,
27 | getTerminatorInstSuccessor,
28 | MCFG,
29 | mkMCFG ) where
30 | import qualified OrderedMap as M
31 | import Control.Monad.State.Strict
32 | import Data.Traversable
33 | import Data.Foldable
34 | import Control.Applicative
35 | import qualified Data.List.NonEmpty as NE
36 | import BaseIR
37 | import Data.Text.Prettyprint.Doc as PP
38 | import PrettyUtils
39 | import Data.MonoTraversable
40 | import Data.Functor.Identity(Identity(..), runIdentity)
41 | import qualified Data.Monoid as Monoid
42 | import Graph
43 | import Data.Maybe(maybeToList)
44 |
45 |
46 |
47 | type MRegLabel = Label MReg
48 |
49 | -- A register for our machine instructions.
50 | data MReg = MRegVirtual MRegLabel | MRegReal String deriving(Eq, Ord)
51 |
52 |
53 | -- | Convert from a register to a stringified name.
54 | regToString :: MReg -> String
55 | regToString (MRegVirtual (Label name)) = name
56 | regToString (MRegReal name) = name
57 |
58 | regZero :: MReg
59 | regZero = MRegReal "zero"
60 |
61 | rega0 :: MReg
62 | rega0 = MRegReal "a0"
63 |
64 | regv0 :: MReg
65 | regv0 = MRegReal "v0"
66 |
67 | -- | Stack pointer register
68 | regsp :: MReg
69 | regsp = MRegReal "sp"
70 |
71 |
72 | -- | Count from 0. Make the `n`th temporary register.
73 | -- | There are 8 of these.
74 | mkTemporaryReg :: Int -> MReg
75 | mkTemporaryReg n =
76 | if n > 7 || n < 0
77 | then error . docToString $ pretty "expected 0 <= n <= 7, found:" <+> pretty n
78 | else MRegReal ("t" ++ show n)
79 |
80 |
81 | instance Pretty MReg where
82 | pretty (MRegReal name) = pretty "$" PP.<> pretty name
83 | pretty (MRegVirtual i) = pretty "$virt-" PP.<> pretty i
84 |
85 |
86 | data MInst where
87 | Mli :: MReg -> Int -> MInst
88 | Mmflo :: MReg -> MInst
89 | Madd :: MReg -> MReg -> MReg -> MInst
90 | Maddi :: MReg -> MReg -> Int -> MInst
91 | Mori :: MReg -> MReg -> Int -> MInst
92 | Mslt :: MReg -> MReg -> MReg -> MInst
93 | Mslti :: MReg -> MReg -> Int -> MInst
94 | Mmult :: MReg -> MReg -> MInst
95 | -- | Store a register word with an immediate mode offset and a base register.
96 | Msw :: MReg -> Int -> MReg -> MInst
97 | -- | Load into a register from a base register plus an immediate mode offset
98 | Mlw :: MReg -> Int -> MReg -> MInst
99 | Mcomment :: String -> MInst
100 | Msyscall :: MInst
101 |
102 | -- | Move into `dest` from `src
103 | mkMov :: MReg -- ^ Destination register
104 | -> MReg -- ^ Source register
105 | -> MInst
106 | mkMov dest src = Madd dest regZero src
107 |
108 | type instance Element MInst = MReg
109 |
110 | instance MonoFunctor MInst where
111 | omap f (Mli reg i) = Mli (f reg) i
112 | omap f (Mmflo reg) = Mmflo (f reg)
113 | omap f (Madd r1 r2 r3) = Madd (f r1) (f r2) (f r3)
114 | omap f (Maddi r1 r2 i) = Maddi (f r1) (f r2) i
115 | omap f (Mori r1 r2 i) = Mori (f r1) (f r2) i
116 | omap f (Mslt r1 r2 r3) = Mslt (f r1) (f r2) (f r3)
117 | omap f (Mslti r1 r2 i) = Mori (f r1) (f r2) i
118 | omap f (Mmult r1 r2) = Mmult (f r1) (f r2)
119 | omap f (Msw r1 i r2) = Msw (f r1) i (f r2)
120 | omap f (Mlw r1 i r2) = Mlw (f r1) i (f r2)
121 | omap _ (Mcomment s) = Mcomment s
122 |
123 | omap _ Msyscall = Msyscall
124 |
125 | traverseMInstReg :: Applicative f => (MReg -> f MReg) -> MInst -> f MInst
126 | traverseMInstReg f (Mli reg i) = liftA2 Mli (f reg) (pure i)
127 | traverseMInstReg f (Mmflo reg) = Mmflo <$> (f reg)
128 | traverseMInstReg f (Madd r1 r2 r3) = Madd <$> f r1 <*> f r2 <*> f r3
129 | traverseMInstReg f (Maddi r1 r2 i) = Maddi <$> f r1 <*> f r2 <*> pure i
130 | traverseMInstReg f (Mori r1 r2 i) = Mori <$> f r1 <*> f r2 <*> pure i
131 | traverseMInstReg f (Mslt r1 r2 r3) = Mslt <$> f r1 <*> f r2 <*> f r3
132 | traverseMInstReg f (Mslti r1 r2 i) = Mslti <$> f r1 <*> f r2 <*> pure i
133 | traverseMInstReg f (Mmult r1 r2) = Mmult <$> f r1 <*> f r2
134 | traverseMInstReg f (Msw r1 i r2) = Msw <$> f r1 <*> pure i <*> f r2
135 | traverseMInstReg f (Mlw r1 i r2) = Mlw <$> f r1 <*> pure i <*> f r2
136 | traverseMInstReg _ (Mcomment s) = pure (Mcomment s)
137 | traverseMInstReg f Msyscall = pure Msyscall
138 |
139 | mapMInstReg :: (MReg -> MReg) -> MInst -> MInst
140 | mapMInstReg f inst = runIdentity $ traverseMInstReg (Identity . f) inst
141 |
142 | -- | Collect a monoidal value from MReg over an MInst
143 | foldMapMInstReg :: Monoid m => (MReg -> m) -> MInst -> m
144 | foldMapMInstReg f inst = execState final Monoid.mempty where
145 | -- go :: MReg -> State m MReg
146 | go r = do
147 | modify (\m -> m Monoid.<> f r)
148 | return r
149 |
150 | -- final :: State m Inst
151 | final = (traverseMInstReg go inst)
152 |
153 |
154 | foldlMInstReg :: (seed -> MReg -> seed) -> seed -> MInst -> seed
155 | foldlMInstReg f seed inst = execState final seed where
156 | -- go :: Reg -> State seed Reg
157 | go r = do
158 | modify (\seed -> f seed r)
159 | return r
160 |
161 | -- final :: State m MInst
162 | final = traverseMInstReg go inst
163 |
164 | -- | Get the list of MRegs in a MInst
165 | getMInstRegs :: MInst -> [MReg]
166 | getMInstRegs = foldMapMInstReg (\r -> [r])
167 |
168 | _prettyMBinOp :: (Pretty a, Pretty b, Pretty c) =>
169 | String -> a -> b -> c -> PP.Doc doc
170 | _prettyMBinOp name a b c = pretty name <+> pretty a <+> pretty b <+> pretty c
171 | instance Pretty MInst where
172 | pretty (Mli dest val) = pretty "li" <+> pretty dest <+> pretty val
173 | pretty (Mmflo dest) = pretty "mflo" <+> pretty dest
174 | pretty (Madd dest a b) = _prettyMBinOp "add" dest a b
175 | pretty (Maddi dest a b) = _prettyMBinOp "addi" dest a b
176 | pretty (Mori dest a b) = _prettyMBinOp "ori" dest a b
177 | pretty (Mslt dest a b) = _prettyMBinOp "slt" dest a b
178 | pretty (Mslti dest a b) = _prettyMBinOp "slti" dest a b
179 | pretty (Mmult a b) = pretty "mult" <+> pretty a <+> pretty b
180 | -- | Msw $src 20($s0)
181 | pretty (Msw a i b) = pretty "sw" <+> pretty a <+> pretty i PP.<> parens (pretty b)
182 | -- | Msw $dest 20($s0)
183 | pretty (Mlw a i b) = pretty "lw" <+> pretty a <+> pretty i PP.<> parens (pretty b)
184 | pretty (Mcomment s) = pretty "#" <+> pretty s
185 | pretty (Msyscall) = pretty "syscall"
186 |
187 | data MTerminatorInst =
188 | Mexit |
189 | Mj MBBLabel |
190 | Mbeqz MReg MBBLabel |
191 | Mbgtz MReg MBBLabel deriving (Eq, Ord)
192 |
193 | instance Pretty MTerminatorInst where
194 | pretty (Mexit) = pretty "# "
195 | pretty (Mj dest) = pretty "j" <+> pretty dest
196 | pretty (Mbeqz cond dest) = pretty "beqz" <+> pretty cond <+> pretty dest
197 | pretty (Mbgtz cond dest) = pretty "bgtz" <+> pretty cond <+> pretty dest
198 |
199 | traverseMTerminatorInstReg :: Applicative f => (MReg -> f MReg) ->
200 | MTerminatorInst -> f MTerminatorInst
201 | traverseMTerminatorInstReg f Mexit = pure Mexit
202 | traverseMTerminatorInstReg f (Mj lbl) = pure (Mj lbl)
203 | traverseMTerminatorInstReg f (Mbeqz reg lbl) = Mbeqz <$> f reg <*> pure lbl
204 | traverseMTerminatorInstReg f (Mbgtz reg lbl) = Mbgtz <$> f reg <*> pure lbl
205 |
206 | mapMTerminatorInstReg :: (MReg -> MReg) -> MTerminatorInst -> MTerminatorInst
207 | mapMTerminatorInstReg f t =
208 | runIdentity $ traverseMTerminatorInstReg (Identity . f) t
209 |
210 |
211 | type MBBLabel = Label MBB
212 | type MBB = BasicBlock MInst [MTerminatorInst]
213 | type MProgram = Program MInst [MTerminatorInst]
214 |
215 |
216 | type MLiveRangeBB = BasicBlock (Int, MInst) (Int, MTerminatorInst)
217 |
218 | -- | Get the possible successor this terminator instruction will lead to.
219 | getTerminatorInstSuccessor :: MTerminatorInst -> Maybe MBBLabel
220 | getTerminatorInstSuccessor (Mexit) = Nothing
221 | getTerminatorInstSuccessor (Mj lbl) = Just lbl
222 | getTerminatorInstSuccessor (Mbgtz _ lbl) = Just lbl
223 | getTerminatorInstSuccessor (Mbeqz _ lbl) = Just lbl
224 |
225 | -- | Get the successors of this basic block
226 | getMBBSuccessors :: MBB -> [MBBLabel]
227 | getMBBSuccessors bb = bbRetInst bb >>= maybeToList . getTerminatorInstSuccessor
228 |
229 |
230 | type MCFG = Graph MBBLabel
231 | -- | Make a control flow graph
232 | mkMCFG :: M.OrderedMap MBBLabel MBB -> MCFG
233 | mkMCFG bbMap = Graph (M.foldMapWithKey makeEdges bbMap) where
234 | makeEdges :: MBBLabel -> MBB -> [(MBBLabel, MBBLabel)]
235 | makeEdges bbid bb = map (\succ -> (bbid, succ)) (getMBBSuccessors bb)
236 |
237 |
238 | -- | Print a MIPS program into a Doc. Use this to write it into a file.
239 | -- | **Do not use pretty**, because it prints the entry BB as well.
240 | printMIPSAsm :: MProgram -> Doc ()
241 | printMIPSAsm Program{programBBMap=bbmap} = vsep $ fmap printBB (M.elems bbmap)
242 | where
243 | printBB :: MBB -> Doc ()
244 | printBB (BasicBlock{bbLabel=label, bbInsts=is, bbRetInst=ris}) =
245 | vcat $
246 | [pretty label <> pretty ":", indent 4 $ vcat(map pretty is ++ map pretty ris)]
247 |
248 | \end{code}
249 |
--------------------------------------------------------------------------------
/src/MIPSInterpreter.lhs:
--------------------------------------------------------------------------------
1 | \begin{code}
2 | module MIPSInterpreter (
3 | interpretMIPSWithSPIM) where
4 | import Data.Text.Prettyprint.Doc
5 | import System.IO(hPutStr, hFlush, Handle, FilePath)
6 | import System.IO.Temp(withSystemTempFile)
7 | import System.Process(readProcessWithExitCode)
8 | import System.Exit(ExitCode(..))
9 | import MIPSAsm
10 | import Text.Read(readMaybe)
11 | import PrettyUtils
12 | import Safe(lastMay)
13 | type ErrorDoc = Doc ()
14 |
15 | -- | Allow for interpreters that try to access state.
16 | interpretMIPSWithSPIM :: MProgram -> IO (Either ErrorDoc Int)
17 | interpretMIPSWithSPIM p =
18 | withSystemTempFile "mipsfile" (\filepath handle -> do
19 | _writeMIPSIntoFile p handle
20 | _runMIPSFromFileWithSPIM filepath)
21 |
22 |
23 | -- | Write MIPS code into the file owned by Handle
24 | _writeMIPSIntoFile :: MProgram -> Handle -> IO ()
25 | _writeMIPSIntoFile program handle = do
26 | hPutStr handle (docToString . printMIPSAsm $ program)
27 | hFlush handle
28 |
29 |
30 | -- | Run MIPS code through SPIM with the file.
31 | _runMIPSFromFileWithSPIM :: FilePath -> IO (Either ErrorDoc Int)
32 | _runMIPSFromFileWithSPIM path = do
33 | let stdin = ""
34 |
35 | (exitcode, stdout, stderr) <- readProcessWithExitCode "spim" ["-f", path] stdin
36 | case exitcode of
37 | ExitFailure i ->
38 | return $ Left $
39 | vcat [pretty "exited with failure code: " <+> pretty i,
40 | pretty "stdout:",
41 | pretty stdout,
42 | pretty "stderr: ",
43 | pretty stderr]
44 | ExitSuccess ->
45 | case lastMay (lines stdout) >>= readMaybe of
46 | Just val -> return $ Right val
47 | Nothing -> return $ Left $
48 | vcat [pretty "program returned non-integer output:",
49 | pretty "stderr:",
50 | pretty stderr,
51 | pretty "stdout:",
52 | pretty stdout]
53 | \end{code}
54 |
--------------------------------------------------------------------------------
/src/Main.lhs:
--------------------------------------------------------------------------------
1 | \begin{code}
2 | module Main where
3 | import Parser
4 | import qualified IR as IR
5 | import IRInterpreter
6 | import qualified Language as Lang
7 | import Data.Text.Prettyprint.Doc
8 | import ProgramToIR
9 | import System.IO
10 | import System.Exit (exitSuccess)
11 | import System.Environment
12 | import TransformMem2Reg
13 | import TransformConstantFolding
14 | import SCEV
15 | import TransformIRToMIPS
16 | import PrettyUtils
17 | import MIPSInterpreter
18 | import TransformRegisterAllocate
19 | import qualified OrderedMap as M
20 | import qualified MIPSAsm as MIPS
21 |
22 |
23 | compileProgram :: Lang.Program a -> IR.IRProgram
24 | compileProgram p = undefined
25 |
26 | pipeline :: [(String, IR.IRProgram -> IR.IRProgram)]
27 | pipeline = [("original", id),
28 | ("mem2reg", transformMem2Reg),
29 | ("constant fold", transformConstantFold)]
30 |
31 | runPasses :: [(String, IR.IRProgram -> IR.IRProgram)] -- ^ Pass pipeline
32 | -> IR.IRProgram -- ^ Current program
33 | -> IO IR.IRProgram -- ^ Final program
34 | runPasses [] p = return p
35 | runPasses ((name, pass):passes) p = do
36 | let p' = pass p
37 | putStrLn . docToString $ pretty "# Running pass " <+>
38 | pretty name
39 | putStrLn . prettyableToString $ p'
40 | putStrLn . docToString $ pretty "- Value:" <+> pretty (runProgram p')
41 | runPasses passes p'
42 |
43 |
44 |
45 | main :: IO ()
46 | main = do
47 | args <- getArgs
48 | input <- readFile (args !! 0)
49 | case parseProgram input of
50 | Left err -> putStrLn err
51 | Right program -> do
52 | putStrLn "*** Program:"
53 | putStrLn . prettyableToString $ program
54 |
55 | let irprogram = programToIR program
56 | finalProgram <- runPasses pipeline irprogram
57 |
58 | putStrLn "*** Loops ***"
59 | let loops = detectLoops finalProgram
60 | putStrLn . docToString . vcat . (fmap pretty) $ loops
61 |
62 | exitSuccess
63 |
64 | putStrLn "*** MIPS assembly *** "
65 | let mipsasm = transformRegisterAllocate . transformIRToMIPS $ finalProgram
66 | putStrLn . docToString . MIPS.printMIPSAsm $ mipsasm
67 | -- putStrLn . docToString . MIPS.unASMDoc . MIPS.generateASM $ finalProgram
68 |
69 | putStrLn "*** Output from SPIM *** "
70 | mProgramOutput <- interpretMIPSWithSPIM mipsasm
71 | case mProgramOutput of
72 | Left err -> putStrLn . docToString $ err
73 | Right val -> putStrLn . docToString $ (pretty "final value: " <+> pretty val)
74 | \end{code}
75 |
--------------------------------------------------------------------------------
/src/OrderedMap.lhs:
--------------------------------------------------------------------------------
1 | \begin{code}
2 | {-# LANGUAGE DeriveFunctor #-}
3 | {-# LANGUAGE DeriveFoldable #-}
4 | {-# LANGUAGE DeriveTraversable #-}
5 | {-# LANGUAGE InstanceSigs #-}
6 | {-# LANGUAGE RecordWildCards #-}
7 | module OrderedMap(OrderedMap,
8 | fromList,
9 | size,
10 | adjust,
11 | adjustWithKey,
12 | insert,
13 | insertWith,
14 | elems,
15 | toList,
16 | keys,
17 | editKeys,
18 | (!),
19 | union,
20 | fromListWith,
21 | foldMapWithKey,
22 | foldlWithKey,
23 | mapWithKey,
24 | OrderedMap.lookup,
25 | delete) where
26 | import qualified Data.Map.Strict as M
27 | import Control.Applicative(liftA2)
28 | import qualified Control.Arrow as A
29 | import Data.Monoid
30 | import PrettyUtils
31 | import Data.Text.Prettyprint.Doc
32 | import qualified Data.List as L
33 |
34 | -- At some point, I need this. This is more convenient than overloading the key to store the insertion time.
35 | -- | A dictionary that orders elements by insertion time
36 | data OrderedMap k v = OrderedMap { map' :: M.Map k v, order :: [k] } deriving(Show, Functor, Eq)
37 |
38 | instance (Ord k, Pretty k) => Foldable (OrderedMap k) where
39 | foldMap f omap = foldMap f (map snd . toList $ omap)
40 |
41 | instance (Ord k, Pretty k) => Traversable (OrderedMap k) where
42 | traverse f omap = fmap fromList (traverse ((\(k, v) -> liftA2 (,) (pure k) (f v))) (toList omap))
43 |
44 | instance (Ord k, Pretty k, Pretty v) => Pretty (OrderedMap k v) where
45 | pretty (OrderedMap _ []) = pretty "empty map"
46 | pretty ok = indent 2 (vcat (map pkv (toList ok))) where
47 | pkv :: (Pretty k, Pretty v) => (k, v) -> Doc ann
48 | pkv (k, v) = pretty k <+> pretty " => " <+> pretty v
49 |
50 | instance Ord k => Monoid (OrderedMap k v) where
51 | mempty :: OrderedMap k v
52 | mempty = OrderedMap mempty mempty
53 |
54 | mappend :: OrderedMap k v -> OrderedMap k v -> OrderedMap k v
55 | mappend (OrderedMap m o) (OrderedMap m' o') = OrderedMap (m `mappend` m') (o `mappend` o')
56 |
57 | liftMapEdit_ :: (M.Map k v -> M.Map k v') -> OrderedMap k v -> OrderedMap k v'
58 | liftMapEdit_ f (OrderedMap map' order) = OrderedMap (f map') order
59 |
60 | liftMapExtract_ :: (M.Map k v -> a) -> OrderedMap k v -> a
61 | liftMapExtract_ f (OrderedMap map' _) = f map'
62 |
63 | -- | NOTE: this will maintain the order of insertion. Elements that are inserted
64 | -- | later are returned later in the `keys`, `elems`.
65 | insert :: Ord k => k -> a -> OrderedMap k a -> OrderedMap k a
66 | insert k a om@OrderedMap{..} = case (liftMapExtract_ (M.lookup k)) om of
67 | Nothing -> OrderedMap (M.insert k a map') (order ++ [k])
68 | -- If the key already exists, keep the old order
69 | _ -> OrderedMap (M.insert k a map') (order)
70 |
71 | -- | NOTE: this will maintain the order of insertion. Elements that are inserted
72 | -- | later are returned later in the `keys`, `elems`.
73 | insertWith :: Ord k => (a -> a -> a) -> k -> a -> OrderedMap k a -> OrderedMap k a
74 | insertWith combiner k a om@OrderedMap{..} =
75 | case (liftMapExtract_ (M.lookup k)) om of
76 | Nothing -> OrderedMap (M.insertWith combiner k a map') (order ++ [k])
77 | -- If the key already exists, keep the old order
78 | _ -> OrderedMap (M.insertWith combiner k a map') (order)
79 |
80 | lookup :: Ord k => k -> OrderedMap k a -> Maybe a
81 | lookup k = liftMapExtract_ (M.lookup k)
82 |
83 | fromList :: Ord k => [(k, a)] -> OrderedMap k a
84 | fromList kv = OrderedMap (M.fromList kv) (map fst kv)
85 |
86 | size :: OrderedMap k a -> Int
87 | size = liftMapExtract_ M.size
88 |
89 | keys :: OrderedMap k a -> [k]
90 | keys = order
91 |
92 | index_ :: (Ord k) => OrderedMap k a -> k -> a
93 | index_ omap k = case OrderedMap.lookup k omap of
94 | Just a -> a
95 | Nothing -> error . docToString $
96 | vcat [pretty "Omap is in inconstent state."]
97 |
98 | elems :: (Ord k, Pretty k, Pretty a) => OrderedMap k a -> [a]
99 | elems omap = map (index_ omap) (keys omap) where
100 |
101 | union :: (Eq k, Ord k) => OrderedMap k a -> OrderedMap k a -> OrderedMap k a
102 | union (OrderedMap{order=o1, map'=m1}) (OrderedMap{order=o2, map'=m2}) =
103 | OrderedMap{map'=m1 `M.union` m2, order=L.nub(o1++o2)}
104 |
105 | -- | Return the list of key value pairs in the order of insertion.
106 | toList :: (Ord k) => OrderedMap k a -> [(k, a)]
107 | toList omap = map (\k -> (k, index_ omap k)) (keys omap)
108 |
109 | adjust :: Ord k => (a -> a) -> k -> OrderedMap k a -> OrderedMap k a
110 | adjust f k = liftMapEdit_ (M.adjust f k)
111 |
112 | adjustWithKey :: Ord k => (k -> a -> a) -> k -> OrderedMap k a -> OrderedMap k a
113 | adjustWithKey f k = liftMapEdit_ (M.adjustWithKey f k)
114 |
115 | (!) :: (Ord k, Pretty k, Pretty a) => OrderedMap k a -> k -> a
116 | ok ! k =
117 | case (OrderedMap.lookup k ok) of
118 | Just a -> a
119 | Nothing -> error . docToString $
120 | vcat [pretty "key missing, has no value associated with it: " <+> pretty k,
121 | pretty "map:",
122 | indent 4 (pretty ok),
123 | pretty "---"]
124 |
125 | foldMapWithKey :: Monoid m => (k -> a -> m) -> OrderedMap k a -> m
126 | foldMapWithKey f = liftMapExtract_ (M.foldMapWithKey f)
127 |
128 | fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> OrderedMap k a
129 | fromListWith f kvs = OrderedMap {order=fmap fst kvs, map'=M.fromListWith f kvs}
130 |
131 | foldlWithKey :: (a -> k -> b -> a) -> a -> OrderedMap k b -> a
132 | foldlWithKey f a = liftMapExtract_ (M.foldlWithKey f a)
133 |
134 | mapWithKey :: (k -> a -> b) -> OrderedMap k a -> OrderedMap k b
135 | mapWithKey f = liftMapEdit_ (M.mapWithKey f)
136 |
137 | -- | Change the keys of the map, without changing the order.
138 | editKeys :: (Ord k, Ord k') => (k -> k') -> OrderedMap k a -> OrderedMap k' a
139 | editKeys f = fromList . map (f A.*** id) . toList
140 |
141 |
142 | delete :: Ord k => k -> OrderedMap k a -> OrderedMap k a
143 | delete key omap@OrderedMap{..} = OrderedMap {order=L.delete key order, map'=M.delete key map' }
144 | \end{code}
145 |
--------------------------------------------------------------------------------
/src/Parser.lhs:
--------------------------------------------------------------------------------
1 |
Parser
2 | In this module, we define the parser for our source language. We use
3 | `trifecta` as our parser, and we import all our parser combinators from
4 | the `parsers` package.
5 |
6 | This module can be considered as a quick tutorial to `trifecta`.
7 | \begin{code}
8 | module Parser where
9 |
10 | import Language
11 | import Control.Monad (void)
12 |
13 | import Control.Applicative
14 | import Data.HashSet as HashSet
15 |
16 | import Text.Trifecta as TR
17 | import Text.Parser.Token.Highlight
18 | import Text.Parser.Token.Style
19 | import Text.Trifecta.Delta
20 |
21 | import Text.Parser.Char
22 | import Text.Parser.Combinators
23 | import Text.Parser.Token
24 | import Text.Parser.Expression
25 | import Text.Parser.Token (TokenParsing, natural, parens, reserve)
26 | import Text.Parser.Token.Style (emptyOps)
27 |
28 |
29 | import Data.ByteString.Char8 as BS
30 | import qualified Text.PrettyPrint.ANSI.Leijen as TrifectaPP
31 | \end{code}
32 |
33 |
34 | \begin{code}
35 | -- import Data.Text.Prettyprint.Doc as PP
36 | () = flip ()
37 |
38 | \end{code}
39 |
40 |
Parsing identifiers
41 |
42 | `trifecta` needs us to tell it what the reserved keywords of our
43 | language are so it can skip those strings. To parse identifiers, we need
44 | three main components:
45 |
46 | - `_styleStart`, which is the characters that can act as the starting character
47 | of our identifier.
48 |
49 | - `_styleLetter`, which the parser will consume greedily when it sees a
50 | `_styleStart`
51 |
52 | - `_styleReserved`, which are strings that should *not* be considered identifiers
53 | because these are reserved keywords.
54 |
55 | \begin{code}
56 | -- | Syntax rules for parsing variable-looking like identifiers.
57 | identStyle :: IdentifierStyle Parser
58 | identStyle = IdentifierStyle
59 | { _styleName = "variable"
60 | , _styleStart = lower <|> char '_'
61 | , _styleLetter = alphaNum <|> oneOf "_'#"
62 | , _styleReserved = HashSet.fromList ["define", "assign", "if", "else", "return", "*", "+", "<", "&&"]
63 | , _styleHighlight = Identifier
64 | , _styleReservedHighlight = ReservedIdentifier }
65 | \end{code}
66 |
67 |
Standard parsers
68 |
69 | The only point of interest here is that we choose to name our parsers with the
70 | `` combinator, which is used to provide better error messages.
71 |
72 | \begin{code}
73 | -- | Parse a variable identifier. Variables start with a lower-case letter or
74 | -- @_@, followed by a string consisting of alphanumeric characters or @'@, @_@.
75 | litp :: Parser Literal
76 | litp = "varname" (Literal <$> (ident identStyle))
77 |
78 |
79 | intp :: Parser Int
80 | intp = fromIntegral <$> integer
81 |
82 | boolp :: Parser Bool
83 | boolp = ((const True) <$> symbol "true") <|> ((const False) <$> symbol "false")
84 |
85 | term :: Parser Expr'
86 | term = (Text.Parser.Token.parens exprp
87 | <|> ELiteral () <$> litp <|> EInt () <$> intp) "simple expression"
88 | \end{code}
89 |
90 |
91 |
Expression Parsing
92 |
93 | Expression parsing is also very nice in `trifecta`, as one can create a table
94 | of operators with their priority and associativities and have that "just work".
95 |
96 | \begin{code}
97 | table :: [[Operator Parser Expr']]
98 | table = [[binary "*" Multiply AssocLeft],
99 | [binary "+" Plus AssocLeft],
100 | [binary "<" L AssocLeft],
101 | [binary "&&" And AssocLeft]]
102 |
103 | binary :: String -> BinOp -> Assoc -> Operator Parser Expr'
104 | binary name op assoc = Infix p assoc where
105 | p :: Parser (Expr' -> Expr' -> Expr')
106 | p = do
107 | reserve identStyle name
108 | return $ mkBinopExpr op
109 | mkBinopExpr :: BinOp -> Expr' -> Expr' -> Expr'
110 | mkBinopExpr op lhs rhs = EBinOp () lhs op rhs
111 |
112 | binopp :: Parser Expr'
113 | binopp = buildExpressionParser table term
114 |
115 | exprp :: Parser Expr'
116 | exprp = binopp
117 |
118 | ifp :: Parser Stmt'
119 | ifp = do
120 | symbol "if"
121 | e <- exprp
122 | symbol "{"
123 | thenstmts <- sepEndBy stmtp (symbol ";")
124 | symbol "}"
125 | symbol "else"
126 |
127 | symbol "{"
128 | elsestmts <- sepEndBy stmtp (symbol ";")
129 | symbol "}"
130 | return $ If () e thenstmts elsestmts
131 |
132 | whilep :: Parser Stmt'
133 | whilep = do
134 | symbol "while"
135 | e <- exprp
136 | symbol "{"
137 | stmts <- sepEndBy stmtp (symbol ";")
138 | symbol "}"
139 | return $ While () e stmts
140 |
141 |
142 | assignp :: Parser Stmt'
143 | assignp = do
144 | symbol "assign"
145 | name <- litp
146 | symbol ":="
147 | rhs <- exprp
148 | return $ Assign () name rhs
149 |
150 | definep :: Parser Stmt'
151 | definep = do
152 | symbol "define"
153 | name <- litp
154 | return $ Define () name
155 |
156 | retp :: Parser Stmt'
157 | retp = do
158 | symbol "return"
159 | retexpr <- exprp
160 | return $ Return () retexpr
161 |
162 | stmtp :: Parser Stmt'
163 | stmtp = ifp <|> whilep <|> assignp <|> definep <|> retp
164 |
165 | programp :: Parser Program'
166 | programp = Program <$> sepEndBy1 stmtp (symbol ";")
167 |
168 |
169 | -- vLow level interface to trifecta
170 | parseProgram_ :: String -> Result Program'
171 | parseProgram_ string = TR.parseString (spaces *> programp) (Directed (BS.pack string) 0 0 0 0) string
172 |
173 |
174 |
175 | -- v High level interface
176 | type ErrorString = String
177 | parseProgram :: String -> Either ErrorString Program'
178 | parseProgram str = case parseProgram_ str of
179 | Success a -> Right a
180 | Failure ErrInfo{ _errDoc = e } -> Left (TrifectaPP.displayS (TrifectaPP.renderPretty 0.8 80 e) "")
181 | \end{code}
182 |
--------------------------------------------------------------------------------
/src/PrettyUtils.lhs:
--------------------------------------------------------------------------------
1 | \begin{code}
2 | module PrettyUtils where
3 | import Data.Text.Prettyprint.Doc.Render.Text
4 | import Data.Text.Prettyprint.Doc
5 | import qualified Data.Text.Lazy as L
6 |
7 | docToText :: Doc ann -> L.Text
8 | docToText doc = renderLazy (layoutPretty defaultLayoutOptions doc)
9 |
10 | docToString :: Doc ann -> String
11 | docToString = L.unpack . docToText
12 |
13 | prettyableToText :: Pretty a => a -> L.Text
14 | prettyableToText a = docToText (pretty a)
15 |
16 | prettyableToString :: Pretty a => a -> String
17 | prettyableToString a = docToString (pretty a)
18 | \end{code}
19 |
--------------------------------------------------------------------------------
/src/ProgramToIR.lhs:
--------------------------------------------------------------------------------
1 | \begin{code}
2 | module ProgramToIR where
3 | import Language
4 | import IR
5 | import BaseIR
6 | import qualified OrderedMap as M
7 | import Data.Traversable
8 | import Data.Foldable
9 | import Control.Monad.State.Strict
10 | import qualified Data.Tree as T
11 | import PrettyUtils
12 | import Data.Text.Prettyprint.Doc as PP
13 |
14 | data Builder = Builder {
15 | -- | The first BB that is present in the module
16 | entryBBId :: IRBBId,
17 | -- | The BB the builder is currently focused on
18 | currentBBId :: IRBBId,
19 | -- | Mapping from BBId to IRBB
20 | bbIdToBB :: M.OrderedMap IRBBId IRBB,
21 | -- | counter to generate new instruction name
22 | tmpInstNamesCounter :: Int,
23 | -- | Map from name to count of number of times name has occured
24 | instNameCounter :: M.OrderedMap String Int,
25 | -- | Map from literal name to Value
26 | literalToValue :: M.OrderedMap Literal Value
27 | }
28 |
29 | -- | Create a new builder with an empty basic block
30 | newBuilder :: Builder
31 | newBuilder =
32 | execState mkDefaultBB initbuilder
33 | where
34 | mkDefaultBB = do
35 | bbid <- createNewBB (Label "default")
36 | focusBB bbid
37 | -- Set the "entry" basic block so we can later give it to IRProgram
38 | modify (\b -> b { entryBBId = bbid })
39 |
40 | initbuilder = (Builder {
41 | entryBBId = Label "",
42 | currentBBId = Label "",
43 | bbIdToBB = mempty,
44 | tmpInstNamesCounter=0,
45 | instNameCounter=mempty,
46 | literalToValue=mempty
47 | })
48 |
49 | -- | Get the current Basic block ID
50 | getCurrentBBId :: State Builder IRBBId
51 | getCurrentBBId = gets currentBBId
52 |
53 | -- | Focus the basic block given by the ID
54 | focusBB :: IRBBId -> State Builder ()
55 | focusBB id = modify (\b-> b { currentBBId=id })
56 |
57 | -- | Append a new basic block. DOES NOT switch the currentBBId to the new basic block. For that, see focusBB
58 | createNewBB :: Label Builder -> State Builder IRBBId
59 | createNewBB name = do
60 | idtobbs <- gets bbIdToBB
61 | let nbbs = M.size idtobbs
62 | let nameunique = Label ((unLabel name) ++ "." ++ show nbbs)
63 | let newbb = defaultIRBB { bbLabel=nameunique }
64 | modify (\b -> b { bbIdToBB = M.insert nameunique newbb idtobbs } )
65 | return nameunique
66 |
67 |
68 | -- | Create a temporary instruction name.
69 | getTempInstName :: State Builder (Label Inst)
70 | getTempInstName = do
71 | n <- gets tmpInstNamesCounter
72 | modify (\b -> b { tmpInstNamesCounter=n+1 })
73 | return . Label $ "tmp." ++ show n
74 |
75 | getUniqueInstName :: String -> State Builder (Label Inst)
76 | getUniqueInstName s = do
77 | counts <- gets instNameCounter
78 | let instNameCounter' = M.insertWith (\_ old -> old + 1) s 0 counts
79 | modify (\b -> b {instNameCounter=instNameCounter' })
80 |
81 | let curcount = case M.lookup s instNameCounter' of
82 | Just count -> count
83 | Nothing -> error . docToString $ pretty "no count present for: " <+> pretty s
84 | if curcount == 0
85 | then return (Label s)
86 | else return (Label (s ++ "." ++ show curcount))
87 |
88 |
89 |
90 | -- | Create a temporary name for a return instruction
91 | -- | Note that we cheat in the implementation, by just "relabelling"
92 | -- | an instruction label to a ret instruction label.
93 | getTempRetInstName :: State Builder (Label RetInst)
94 | getTempRetInstName = Label . unLabel <$> getTempInstName
95 |
96 | -- | Add a mapping between literal and value.
97 | mapLiteralToValue :: Literal -> Value -> State Builder ()
98 | mapLiteralToValue l v = do
99 | ltov <- gets literalToValue
100 | -- TODO: check that we do not repeat literals.
101 | modify (\b -> b { literalToValue=M.insert l v ltov })
102 | return ()
103 |
104 | -- | Get the value that the Literal maps to.
105 | getLiteralValueMapping :: Literal -> State Builder Value
106 | getLiteralValueMapping lit = do
107 | ltov <- gets literalToValue
108 | return $ ltov M.! lit
109 |
110 | -- | lift an edit of a basic block to the current basic block focused
111 | -- | in the Builder.
112 | liftBBEdit :: (IRBB -> IRBB) -> Builder -> Builder
113 | liftBBEdit f builder = builder {
114 | bbIdToBB = M.adjust f (currentBBId builder) (bbIdToBB builder)
115 | }
116 |
117 | -- | Set the builder's current basic block to the i'th basic block
118 | setBB :: Builder -> IRBBId -> Builder
119 | setBB builder i = builder {
120 | currentBBId = i
121 | }
122 |
123 |
124 | -- | Append instruction "I" to the builder
125 | appendInst :: Named Inst -> State Builder Value
126 | appendInst i = do
127 | modify . liftBBEdit $ (appendInstToBB i)
128 | return $ ValueInstRef (namedName i)
129 | where
130 | appendInstToBB :: Named Inst -> IRBB -> IRBB
131 | appendInstToBB i bb = bb { bbInsts=bbInsts bb ++ [i] }
132 |
133 | setRetInst :: RetInst -> State Builder ()
134 | setRetInst i = do
135 | modify . liftBBEdit $ (setBBRetInst i)
136 | where
137 | setBBRetInst :: RetInst -> IRBB -> IRBB
138 | setBBRetInst i bb = bb { bbRetInst=i }
139 |
140 |
141 | mkBinOpInst :: Value -> BinOp -> Value -> Inst
142 | mkBinOpInst lhs Plus rhs = InstAdd lhs rhs
143 | mkBinOpInst lhs Multiply rhs = InstMul lhs rhs
144 | mkBinOpInst lhs L rhs = InstL lhs rhs
145 | mkBinOpInst lhs And rhs = InstAnd lhs rhs
146 |
147 | buildExpr :: Expr' -> State Builder Value
148 | buildExpr (EInt _ i) = return $ ValueConstInt i
149 | buildExpr (ELiteral _ lit) = do
150 | name <- getUniqueInstName $ unLiteral lit ++ ".load"
151 | val <- getLiteralValueMapping lit
152 | appendInst $ name =:= InstLoad val
153 |
154 | buildExpr (EBinOp _ lhs op rhs) = do
155 | lhs <- buildExpr lhs
156 | rhs <- buildExpr rhs
157 | let inst = (mkBinOpInst lhs op rhs)
158 | name <- getTempInstName
159 | -- TODO: generate fresh labels
160 | appendInst $ name =:= inst
161 |
162 | -- | Build the IR for the assignment, and return a reference to @InstStore
163 | -- | TODO: technically, store should not return a Value
164 | buildAssign :: Literal -> Expr' -> State Builder Value
165 | buildAssign lit expr = do
166 | exprval <- buildExpr expr
167 | litval <- getLiteralValueMapping lit
168 | name <- getUniqueInstName $ "_"
169 | -- TODO: do not allow Store to be named with type system trickery
170 | appendInst $ name =:= InstStore litval exprval
171 | return $ ValueInstRef name
172 |
173 | -- | Build IR for "define x"
174 | buildDefine :: Literal -> State Builder Value
175 | buildDefine lit = do
176 | name <- getUniqueInstName . unLiteral $ lit
177 | mapLiteralToValue lit (ValueInstRef name)
178 | appendInst $ name =:= InstAlloc
179 |
180 | -- | Build IR for "Return"
181 | buildRet :: Expr' -> State Builder ()
182 | buildRet retexpr = do
183 | retval <- buildExpr retexpr
184 | setRetInst $ RetInstRet retval
185 |
186 | -- | Build IR for "Stmt"
187 | buildStmt :: Stmt' -> State Builder ()
188 | buildStmt (Define _ lit) = buildDefine lit >> return ()
189 | buildStmt (Assign _ lit expr) = buildAssign lit expr >> return ()
190 | buildStmt (If _ cond then' else') = do
191 | condval <- buildExpr cond
192 | currbb <- getCurrentBBId
193 |
194 |
195 | bbthen <- createNewBB (Label "then")
196 | focusBB bbthen
197 | stmtsToInsts then'
198 |
199 | bbelse <- createNewBB (Label "else")
200 | focusBB bbelse
201 | stmtsToInsts else'
202 |
203 | bbjoin <- createNewBB (Label "join")
204 | focusBB bbthen
205 | setRetInst $ RetInstBranch bbjoin
206 |
207 | focusBB bbelse
208 | setRetInst $ RetInstBranch bbjoin
209 |
210 | focusBB currbb
211 | setRetInst $ RetInstConditionalBranch condval bbthen bbelse
212 |
213 | focusBB bbjoin
214 |
215 | buildStmt (While _ cond body) = do
216 | curbb <- getCurrentBBId
217 | condbb <- createNewBB (Label "while.cond")
218 | bodybb <- createNewBB (Label "while.body")
219 | endbb <- createNewBB (Label "while.end")
220 |
221 | focusBB condbb
222 | condval <- buildExpr cond
223 | setRetInst $ RetInstConditionalBranch condval bodybb endbb
224 |
225 | focusBB bodybb
226 | stmtsToInsts body
227 | setRetInst $ RetInstBranch condbb
228 |
229 | focusBB curbb
230 | setRetInst $ RetInstBranch condbb
231 |
232 | focusBB endbb
233 |
234 | buildStmt (Return _ retexpr) = buildRet retexpr
235 |
236 | -- Given a collection of statements, create a State that will create these
237 | -- statements in the builder
238 | stmtsToInsts :: [Stmt'] -> State Builder ()
239 | stmtsToInsts stmts = (for_ stmts buildStmt)
240 |
241 |
242 | programToIR :: Program' -> IRProgram
243 | programToIR (Language.Program stmts) =
244 | BaseIR.Program {
245 | programBBMap = bbIdToBB builder,
246 | programEntryBBId = entryBBId builder
247 | } where
248 | builder = execState (stmtsToInsts stmts) newBuilder
249 | \end{code}
250 |
--------------------------------------------------------------------------------
/src/SCEV.lhs:
--------------------------------------------------------------------------------
1 |
6 |
7 | In this pass, we remove all instructions we can evaluate at compile-time.
8 | This includes arithmetic and boolean operators.
9 |
10 | The idea is really simple: scan basic blocks, and if an instruction can be
11 | immediately evaluated, do so.
12 |
13 | Note that for this pass to be as easy as it is, **SSA is crucial**.
14 |
15 | Consider this snippet of code:
16 |
17 | ```
18 | define x;
19 | assign x := 10;
20 | assign x := x + 42;
21 | assign x := x * 10
22 | return x;
23 | ```
24 |
25 | and the associated `load/store` based IR:
26 |
27 | ```
28 | entry: default.0
29 | program:
30 | default.0:
31 | x := alloc
32 | _ := store 10# in %x
33 | x.load := load %x
34 | tmp.0 := add %x.load 42#
35 | _.1 := store %tmp.0 in %x
36 | x.load.1 := load %x
37 | tmp.1 := mul %x.load.1 10#
38 | _.2 := store %tmp.1 in %x
39 | TERMINAL
40 | ```
41 |
42 | We cannot simply replace `x` with `10` due to the mutation happening on x!
43 |
44 | Now, consider the SSA form of the same computation:
45 |
46 | ```
47 | entry: default.0
48 | program:
49 | default.0:
50 | tmp.0 := add 10# 42#
51 | tmp.1 := mul %tmp.0 10#
52 | TERMINAL
53 | ```
54 |
55 | Due to the *immutable* nature of SSA, we are guaranteed that we can replace all
56 | occurences of a variable with it's RHS, and the semantics of the program will
57 | remain the same! (AKA [equational reasoning](https://wiki.haskell.org/Equational_reasoning_examples)).
58 |
59 | This is enormously powerful because it allows to replace values with wild abandon `:)`.
60 |
61 |
Key Takeaway of this pass
62 |
63 | - SSA, due to immutability enables equational reasoning.
64 | - This allows us to perform transformations such as
65 | constant folding very easily.
66 |
67 |
68 |
69 | \begin{code}
70 | {-# LANGUAGE ViewPatterns #-}
71 |
72 | module TransformConstantFolding where
73 | import qualified OrderedMap as M
74 | import Control.Monad.State.Strict
75 | import Data.Traversable
76 | import Data.Foldable
77 | import Control.Applicative
78 | import qualified Data.List.NonEmpty as NE
79 | import IR
80 | import BaseIR
81 | import Data.Text.Prettyprint.Doc as PP
82 | import PrettyUtils
83 |
84 | boolToInt :: Bool -> Int
85 | boolToInt False = 0
86 | boolToInt True = 1
87 |
88 | -- | Fold all possible arithmetic / boolean ops
89 | tryFoldInst :: Inst -> Maybe Value
90 | tryFoldInst (InstAdd (ValueConstInt i) (ValueConstInt j)) =
91 | Just $ ValueConstInt (i + j)
92 | tryFoldInst (InstMul (ValueConstInt i) (ValueConstInt j)) =
93 | Just $ ValueConstInt (i * j)
94 | tryFoldInst (InstL (ValueConstInt i) (ValueConstInt j)) =
95 | Just $ ValueConstInt $ boolToInt (i < j)
96 |
97 | tryFoldInst (InstAnd (ValueConstInt i) (ValueConstInt j)) =
98 | Just $ ValueConstInt (i * j)
99 | tryFoldInst i = Nothing
100 |
101 | collectFoldableInsts :: Named Inst -> [(Label Inst, Value)]
102 | collectFoldableInsts (Named name (tryFoldInst -> Just v)) = [(name, v)]
103 | collectFoldableInsts _ = []
104 |
105 | runTillStable :: Eq a => (a -> a) -> a -> a
106 | runTillStable f a = let a' = f a in
107 | if a' == a
108 | then a'
109 | else f a'
110 |
111 | transformConstantFold :: IRProgram -> IRProgram
112 | transformConstantFold = dceProgram . (runTillStable foldProgram) where
113 |
114 | -- | Collection of instruction names and values
115 | foldableInsts :: IRProgram -> [(Label Inst, Value)]
116 | foldableInsts p = foldMapProgramBBs (foldMapBB (collectFoldableInsts) (const mempty)) p
117 |
118 | -- | Program after constant folding
119 | foldProgram :: IRProgram -> IRProgram
120 | foldProgram program = foldl (\p (name, v) -> replaceUsesOfInst name v p) program (foldableInsts program)
121 |
122 | -- | program after dead code elimination
123 | dceProgram :: IRProgram -> IRProgram
124 | dceProgram program =
125 | foldl (\p name -> filterProgramInsts (not . hasName name) p) program (map fst (foldableInsts program))
126 |
127 | \end{code}
128 |
--------------------------------------------------------------------------------
/src/TransformIRToMIPS.lhs:
--------------------------------------------------------------------------------
1 |
Transform Pass: IR Canonicalization for MIPS
2 |
3 |
4 |
Introduction
5 |
6 |
In this pass, we rewrite binary instructions of the form: