├── hie.yaml ├── stack.yaml ├── Setup.hs ├── module-map.png ├── src-kalyn ├── Stdlib │ ├── Collections.kalyn │ ├── Instances.kalyn │ ├── Booleans.kalyn │ ├── Functions.kalyn │ ├── Tuples.kalyn │ ├── IOs.kalyn │ ├── Maybes.kalyn │ ├── Instances │ │ ├── Eq.kalyn │ │ ├── Read.kalyn │ │ ├── Ord.kalyn │ │ └── Show.kalyn │ ├── DataTypes.kalyn │ ├── FilePaths.kalyn │ ├── States.kalyn │ ├── Collections │ │ ├── Sets.kalyn │ │ └── Maps.kalyn │ └── Lists.kalyn ├── Instances.kalyn ├── OS.kalyn ├── Tokens.kalyn ├── Stdlib.kalyn ├── Instances │ ├── Eq.kalyn │ ├── Ord.kalyn │ └── Show.kalyn ├── Boilerplate.kalyn ├── Reader.kalyn ├── Main.kalyn ├── Util.kalyn ├── AST.kalyn ├── Linker.kalyn ├── Lexer.kalyn ├── Liveness.kalyn ├── Bundler.kalyn ├── MemoryManager.kalyn ├── Subroutines.kalyn ├── Bridge.kalyn ├── Assembly.kalyn ├── Parser.kalyn └── Resolver.kalyn ├── .gitignore ├── src ├── OS.hs ├── Tokens.hs ├── Boilerplate.hs ├── Util.hs ├── Reader.hs ├── MemoryManager.hs ├── Lexer.hs ├── Bundler.hs ├── Liveness.hs ├── Bridge.hs ├── Subroutines.hs ├── Parser.hs ├── Resolver.hs └── RegisterAllocator.hs ├── Makefile ├── scripts ├── pyproject.toml ├── report.zsh ├── plot.py └── poetry.lock ├── stack.yaml.lock ├── package.yaml ├── README.md ├── LICENSE.md ├── app └── Main.hs └── kalyn-mode.el /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | stack: 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.24 2 | packages: 3 | - . 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /module-map.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/radian-software/kalyn/HEAD/module-map.png -------------------------------------------------------------------------------- /src-kalyn/Stdlib/Collections.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (public import "Collections/Maps.kalyn") 4 | (public import "Collections/Sets.kalyn") 5 | -------------------------------------------------------------------------------- /src-kalyn/Instances.kalyn: -------------------------------------------------------------------------------- 1 | (import "Stdlib.kalyn") 2 | 3 | (public import "Instances/Eq.kalyn") 4 | (public import "Instances/Ord.kalyn") 5 | (public import "Instances/Show.kalyn") 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.stack-work 2 | /dist-newstyle 3 | /kalyn.cabal 4 | /out-kalyn 5 | /out-kalyn-rec 6 | /scripts/codefreq.png 7 | /scripts/files.png 8 | /scripts/loc.png 9 | /scripts/report.log 10 | -------------------------------------------------------------------------------- /src-kalyn/OS.kalyn: -------------------------------------------------------------------------------- 1 | (import "Stdlib.kalyn") 2 | 3 | (public def pageSize Word 4 | 0x1000) 5 | 6 | ;; should be large enough to hold filesystem paths 7 | (public def syscallBufferSize Word 8 | 0x1000) 9 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/Instances.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (public import "Instances/Eq.kalyn") 4 | (public import "Instances/Ord.kalyn") 5 | (public import "Instances/Read.kalyn") 6 | (public import "Instances/Show.kalyn") 7 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/Booleans.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (public defn not (Func Bool Bool) 4 | (b) 5 | (if b 6 | False 7 | True)) 8 | 9 | (public defn xor (Func Bool Bool Bool) 10 | (left right) 11 | (if left 12 | (not right) 13 | right)) 14 | -------------------------------------------------------------------------------- /src/OS.hs: -------------------------------------------------------------------------------- 1 | module OS where 2 | 3 | pageSize :: Int 4 | pageSize = 0x1000 5 | 6 | -- Virtual addresses near 0 are reserved, so we need to map the code 7 | -- at a higher virtual address than its byte index in the file. 8 | vaOffset :: Int 9 | vaOffset = 0x10000 10 | 11 | syscallBufferSize :: Int 12 | syscallBufferSize = 0x1000 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | SHELL := bash 2 | 3 | .PHONY: 1 4 | 1: 5 | stack build kalyn 6 | time stack exec kalyn 7 | 8 | .PHONY: 2 9 | 2: 10 | mkdir -p out-kalyn-rec 11 | ulimit -s unlimited && time out-kalyn/Main 12 | 13 | .PHONY: 3 14 | 3: 15 | ulimit -s unlimited && time out-kalyn-rec/Main 16 | 17 | .PHONY: clean 18 | clean: 19 | @git clean -ffdX 20 | -------------------------------------------------------------------------------- /scripts/pyproject.toml: -------------------------------------------------------------------------------- 1 | [tool.poetry] 2 | name = "scripts" 3 | version = "0.1.0" 4 | description = "" 5 | authors = ["Radian LLC "] 6 | 7 | [tool.poetry.dependencies] 8 | python = "^3.8" 9 | matplotlib = "^3.2.1" 10 | 11 | [tool.poetry.dev-dependencies] 12 | 13 | [build-system] 14 | requires = ["poetry>=0.12"] 15 | build-backend = "poetry.masonry.api" 16 | -------------------------------------------------------------------------------- /src-kalyn/Tokens.kalyn: -------------------------------------------------------------------------------- 1 | (import "Stdlib.kalyn") 2 | 3 | (public data Token 4 | LPAREN 5 | RPAREN 6 | LBRACKET 7 | RBRACKET 8 | AT 9 | (SYMBOL String) 10 | (INTEGER Int64) 11 | (CHAR Char) 12 | (STRING String)) 13 | 14 | (public data Form 15 | (RoundList (List Form)) 16 | (SquareList (List Form)) 17 | (At String Form) 18 | (Symbol String) 19 | (IntAtom Int64) 20 | (CharAtom Char) 21 | (StrAtom String)) 22 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib.kalyn: -------------------------------------------------------------------------------- 1 | (public import "Stdlib/Booleans.kalyn") 2 | (public import "Stdlib/Collections.kalyn") 3 | (public import "Stdlib/DataTypes.kalyn") 4 | (public import "Stdlib/FilePaths.kalyn") 5 | (public import "Stdlib/Functions.kalyn") 6 | (public import "Stdlib/IOs.kalyn") 7 | (public import "Stdlib/Instances.kalyn") 8 | (public import "Stdlib/Lists.kalyn") 9 | (public import "Stdlib/Maybes.kalyn") 10 | (public import "Stdlib/States.kalyn") 11 | (public import "Stdlib/Tuples.kalyn") 12 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 587821 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/24.yaml 11 | sha256: 06d844ba51e49907bd29cb58b4a5f86ee7587a4cd7e6cf395eeec16cba619ce8 12 | original: lts-18.24 13 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: kalyn 2 | version: 0 3 | author: "Radian LLC" 4 | maintainer: "contact+kalyn@radian.codes" 5 | 6 | dependencies: 7 | - base 8 | - bytestring 9 | - containers 10 | - deepseq 11 | - directory 12 | - filepath 13 | - mtl 14 | - pretty-simple 15 | - text 16 | - unix 17 | - utf8-string 18 | 19 | library: 20 | source-dirs: src 21 | ghc-options: 22 | - -Wall 23 | 24 | executables: 25 | kalyn: 26 | main: Main.hs 27 | source-dirs: app 28 | ghc-options: 29 | - -Wall 30 | dependencies: 31 | - kalyn 32 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/Functions.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (public defn const (Func a (Func b a)) 4 | (a _) 5 | a) 6 | 7 | (public defn flip (Func (Func a b c) (Func b a c)) 8 | (f b a) 9 | (f a b)) 10 | 11 | (public defn comp (Func (Func b c) (Func a b) (Func a c)) 12 | (f g a) 13 | (f (g a))) 14 | 15 | (public defn curry (Func (Func (Pair a b) c) (Func a b c)) 16 | (f a b) 17 | (f (Pair a b))) 18 | 19 | (public defn uncurry (Func (Func a b c) (Func (Pair a b) c)) 20 | (f (Pair a b)) 21 | (f a b)) 22 | 23 | (public defn id (Func a a) 24 | (a) 25 | a) 26 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/Tuples.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (public defn fst (Func (Pair a b) a) 4 | ((Pair a _)) 5 | a) 6 | 7 | (public defn snd (Func (Pair a b) b) 8 | ((Pair _ b)) 9 | b) 10 | 11 | (public defn first (Func (Func a c) (Func (Pair a b) (Pair c b))) 12 | (func (Pair a b)) 13 | (Pair (func a) b)) 14 | 15 | (public defn second (Func (Func b c) (Func (Pair a b) (Pair a c))) 16 | (func (Pair a b)) 17 | (Pair a (func b))) 18 | 19 | (public defn both (Func (Func a b) (Func (Pair a a) (Pair b b))) 20 | (func (Pair l r)) 21 | (Pair (func l) (func r))) 22 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/IOs.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (public defn fmapIO (Func (Func a b) (IO a) (IO b)) 4 | (func io) 5 | (do IO 6 | (with result io) 7 | (returnIO (func result)))) 8 | 9 | (public defn sequenceIO (Func (List (IO a)) (IO (List a))) 10 | (ios) 11 | (case ios 12 | (Null (returnIO Null)) 13 | ((Cons io ios) 14 | (do IO 15 | (with fst io) 16 | (with rst (sequenceIO ios)) 17 | (returnIO (Cons fst rst)))))) 18 | 19 | (public defn mapMIO (Func (Func a (IO b)) (List a) (IO (List b))) 20 | (func as) 21 | (sequenceIO (map func as))) 22 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/Maybes.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (public defn mapMaybe (Func (Func a (Maybe b)) (List a) (List b)) 4 | (func elts) 5 | (case elts 6 | (Null Null) 7 | ((Cons fst rst) 8 | (case (func fst) 9 | (Nothing (mapMaybe func rst)) 10 | ((Just fst*) 11 | (Cons fst* (mapMaybe func rst))))))) 12 | 13 | (public defn catMaybes (Func (List (Maybe a)) (List a)) 14 | (elts) 15 | (case elts 16 | (Null Null) 17 | ((Cons elt elts) 18 | (case elt 19 | (Nothing (catMaybes elts)) 20 | ((Just elt) (Cons elt (catMaybes elts))))))) 21 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/Instances/Eq.kalyn: -------------------------------------------------------------------------------- 1 | (import "../../Stdlib.kalyn") 2 | 3 | (public defn ==Char (Eq Char) 4 | ((Char c1) (Char c2)) 5 | (==Int c1 c2)) 6 | 7 | (public defn ==List (Func (Eq a) (Eq (List a))) 8 | (== l1 l2) 9 | (case (Pair l1 l2) 10 | ((Pair Null Null) 11 | True) 12 | ((Pair (Cons f1 r1) (Cons f2 r2)) 13 | (and (== f1 f2) 14 | (==List == r1 r2))) 15 | (_ False))) 16 | 17 | (public def ==String (Eq String) 18 | (==List ==Char)) 19 | 20 | (public defn ==Pair (Func (Eq a) (Eq b) (Eq (Pair a b))) 21 | (==l ==r (Pair l1 r1) (Pair l2 r2)) 22 | (and 23 | (==l l1 l2) 24 | (==r r1 r2))) 25 | 26 | (public defn ==Set (Func (Eq a) (Eq (Set a))) 27 | (== s1 s2) 28 | (==List == (setToList s1) (setToList s2))) 29 | -------------------------------------------------------------------------------- /src-kalyn/Instances/Eq.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (import "../Assembly.kalyn") 4 | 5 | (public defn ==Register (Eq Register) 6 | (r1 r2) 7 | (case (Pair r1 r2) 8 | ((Pair RAX RAX) True) 9 | ((Pair RCX RCX) True) 10 | ((Pair RDX RDX) True) 11 | ((Pair RBX RBX) True) 12 | ((Pair RSP RSP) True) 13 | ((Pair RBP RBP) True) 14 | ((Pair RSI RSI) True) 15 | ((Pair RDI RDI) True) 16 | ((Pair R8 R8) True) 17 | ((Pair R9 R9) True) 18 | ((Pair R10 R10) True) 19 | ((Pair R11 R11) True) 20 | ((Pair R12 R12) True) 21 | ((Pair R13 R13) True) 22 | ((Pair R14 R14) True) 23 | ((Pair R15 R15) True) 24 | ((Pair RIP RIP) True) 25 | (_ False))) 26 | 27 | (public defn ==Temporary (Eq Temporary) 28 | ((Temporary t1) (Temporary t2)) 29 | (==Int t1 t2)) 30 | 31 | (public defn ==VR (Eq VR) 32 | (r1 r2) 33 | (case (Pair r1 r2) 34 | ((Pair (Physical p1) (Physical p2)) 35 | (==Register p1 p2)) 36 | ((Pair (Virtual v1) (Virtual v2)) 37 | (==Temporary v1 v2)) 38 | (_ False))) 39 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/Instances/Read.kalyn: -------------------------------------------------------------------------------- 1 | (import "../../Stdlib.kalyn") 2 | 3 | (defn readDecimal (Read Int) 4 | ((Cons (Char c) rest)) 5 | (+ (- c 0x30) 6 | (case rest 7 | (Null 0) 8 | ((Cons _ _) 9 | (* 10 (readDecimal rest)))))) 10 | 11 | (defn readHex (Read Int) 12 | ((Cons (Char c) rest)) 13 | (+ (if (>=Int c 0x61) 14 | (- c 0x57) 15 | (- c 0x30)) 16 | (case rest 17 | (Null 0) 18 | ((Cons _ _) 19 | (* 16 (readHex rest)))))) 20 | 21 | (defn readOctal (Read Int) 22 | ((Cons (Char c) rest)) 23 | (+ (- c 0x30) 24 | (case rest 25 | (Null 0) 26 | ((Cons _ _) 27 | (* 8 (readOctal rest)))))) 28 | 29 | (public defn readInt (Read Int) 30 | (str) 31 | (case str 32 | (Null (error "readInt got empty string\n")) 33 | ((Cons '-' str) 34 | (- 0 (readInt str))) 35 | ((Cons '0' (Cons 'x' rest)) 36 | (readHex (reverse rest))) 37 | ((Cons '0' (Cons 'o' rest)) 38 | (readOctal (reverse rest))) 39 | (_ 40 | (readDecimal (reverse str))))) 41 | -------------------------------------------------------------------------------- /src-kalyn/Instances/Ord.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (import "../Assembly.kalyn") 4 | 5 | (defn registerToInt (Func Register Int) 6 | (reg) 7 | (case reg 8 | (RAX 0) 9 | (RCX 1) 10 | (RDX 2) 11 | (RBX 3) 12 | (RSP 4) 13 | (RBP 5) 14 | (RSI 6) 15 | (RDI 7) 16 | (R8 8) 17 | (R9 9) 18 | (R10 10) 19 | (R11 11) 20 | (R12 12) 21 | (R13 13) 22 | (R14 14) 23 | (R15 15) 24 | (RIP 16))) 25 | 26 | (public defn compareRegister (Ord Register) 27 | (r1 r2) 28 | (compareInt (registerToInt r1) 29 | (registerToInt r2))) 30 | 31 | (public defn compareTemporary (Ord Temporary) 32 | ((Temporary t1) (Temporary t2)) 33 | (compareInt t1 t2)) 34 | 35 | (public defn compareVR (Ord VR) 36 | (r1 r2) 37 | (case (Pair r1 r2) 38 | ((Pair (Physical p1) (Physical p2)) 39 | (compareRegister p1 p2)) 40 | ((Pair (Virtual v1) (Virtual v2)) 41 | (compareTemporary v1 v2)) 42 | ((Pair (Physical _) (Virtual _)) 43 | LT) 44 | ((Pair (Virtual _) (Physical _)) 45 | GT))) 46 | -------------------------------------------------------------------------------- /scripts/report.zsh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env zsh 2 | 3 | set -e 4 | set -o pipefail 5 | 6 | function sum_col { 7 | awk "{SUM += \$$1} END {print SUM}" 8 | } 9 | 10 | function sgrep { 11 | grep "$@" || true 12 | } 13 | 14 | find . -name '*.hs' | xargs cat | wc -l | read haskell_loc 15 | find . -name '*.kalyn' | xargs cat | wc -l | read kalyn_loc 16 | 17 | stat="$(git show --numstat --format=)" 18 | 19 | printf '%s\n' $stat | sgrep '\.hs$' | sum_col 1 | read haskell_loc_added 20 | printf '%s\n' $stat | sgrep '\.hs$' | sum_col 2 | read haskell_loc_removed 21 | printf '%s\n' $stat | sgrep '\.kalyn$' | sum_col 1 | read kalyn_loc_added 22 | printf '%s\n' $stat | sgrep '\.kalyn$' | sum_col 2 | read kalyn_loc_removed 23 | 24 | find . -name '*.hs' | wc -l | read haskell_files 25 | find . -name '*.kalyn' | wc -l | read kalyn_files 26 | 27 | git log -1 -s --format=%ci | read timestamp 28 | 29 | git rev-parse HEAD | read sha 30 | 31 | echo "${haskell_loc},${kalyn_loc},${haskell_loc_added},${haskell_loc_removed},${kalyn_loc_added},${kalyn_loc_removed},${haskell_files},${kalyn_files},${timestamp},${sha}" 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Kalyn 2 | 3 | Self-hosting compiler from a Haskell-like Lisp directly to x86-64, 4 | developed fully from scratch. 5 | 6 |

Kalyn module 7 | map flow chart

8 | 9 | Read all about it [on my 10 | blog](https://intuitiveexplanations.com/tech/kalyn)! 11 | 12 | ## Build instructions 13 | 14 | Install [Stack](https://docs.haskellstack.org/en/stable/README/). Keep 15 | in mind on Arch-based Linux distributions that all the Haskell 16 | packages in the official repos are totally unusable for development, 17 | so you need to install Stack using the upstream binaries. (See [this 18 | HIE 19 | issue](https://github.com/haskell/haskell-ide-engine/issues/1721#issuecomment-609847125).) 20 | 21 | To compile the Haskell implementation (provide `VERBOSE=1` to write 22 | intermediate log files into `out-kalyn`): 23 | 24 | $ make 1 [VERBOSE=1] 25 | 26 | To use the Haskell implementation to compile the Kalyn implementation: 27 | 28 | $ make 2 29 | 30 | To use the Kalyn implementation to compile itself: 31 | 32 | $ make 3 33 | -------------------------------------------------------------------------------- /src/Tokens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass, DeriveGeneric #-} 2 | 3 | module Tokens where 4 | 5 | import Control.DeepSeq 6 | import Data.Int 7 | import GHC.Generics 8 | 9 | import Util 10 | 11 | data Token = LPAREN 12 | | RPAREN 13 | | LBRACKET 14 | | RBRACKET 15 | | AT 16 | | SYMBOL String 17 | | INTEGER Int64 18 | | CHAR Char 19 | | STRING String 20 | deriving (Eq, Generic, NFData, Show) 21 | 22 | data Form = RoundList [Form] 23 | | SquareList [Form] 24 | | At String Form 25 | | Symbol String 26 | | IntAtom Int64 27 | | CharAtom Char 28 | | StrAtom String 29 | deriving (Generic, NFData, Show) 30 | 31 | instance Pretty Form where 32 | pretty (RoundList forms) = "(" ++ unwords (map pretty forms) ++ ")" 33 | pretty (SquareList forms) = "[" ++ unwords (map pretty forms) ++ "]" 34 | pretty (At name form ) = name ++ "@" ++ show form 35 | pretty (Symbol s ) = s 36 | pretty (IntAtom i ) = show i 37 | pretty (CharAtom c ) = show c 38 | pretty (StrAtom s ) = show s 39 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2020–2022 [Radian LLC](https://radian.codes) and 4 | contributors 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in all 14 | copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 22 | SOFTWARE. 23 | -------------------------------------------------------------------------------- /src/Boilerplate.hs: -------------------------------------------------------------------------------- 1 | module Boilerplate 2 | ( addProgramBoilerplate 3 | ) where 4 | 5 | import Data.List 6 | import qualified Data.Set as Set 7 | 8 | import Assembly 9 | 10 | addFnBoilerplate :: PhysicalFunction -> PhysicalFunction 11 | addFnBoilerplate (Function stackSpace name instrs) = 12 | let clobberedRegs = 13 | nub 14 | $ filter (\reg -> reg `Set.member` dataRegisters && reg /= RAX) 15 | $ concatMap (snd . getRegisters) instrs 16 | in function name 17 | $ [UN PUSH $ R RBP, OP MOV $ RR RSP RBP] 18 | ++ [ OP SUB $ IR (fromIntegral stackSpace) RSP | stackSpace /= 0 ] 19 | ++ map (UN PUSH . R) clobberedRegs 20 | ++ concatMap 21 | (\instr -> case instr of 22 | RET -> 23 | map (UN POP . R) (reverse clobberedRegs) 24 | ++ [ OP ADD $ IR (fromIntegral stackSpace) RSP 25 | | stackSpace /= 0 26 | ] 27 | ++ [UN POP $ R RBP, instr] 28 | _ -> [instr] 29 | ) 30 | instrs 31 | 32 | addProgramBoilerplate :: Program Register -> Program Register 33 | addProgramBoilerplate (Program mainFn fns datums) = 34 | Program mainFn (map addFnBoilerplate fns) datums 35 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/DataTypes.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (public data Empty 4 | Empty) 5 | 6 | (public data Bool 7 | False True) 8 | 9 | (public data (Maybe a) 10 | Nothing (Just a)) 11 | 12 | (public data (Either l r) 13 | (Left l) (Right r)) 14 | 15 | (public data (Pair a b) 16 | (Pair a b)) 17 | 18 | (public data (Triplet a b c) 19 | (Triplet a b c)) 20 | 21 | (public data (Quad a b c d) 22 | (Quad a b c d)) 23 | 24 | (public data (List a) 25 | Null (Cons a (List a))) 26 | 27 | (public data Char (Char Word8)) 28 | 29 | (public alias String (List Char)) 30 | 31 | (public data Ordering 32 | LT EQ GT) 33 | 34 | (public data (State s a) 35 | (State (Func s (Pair s a)))) 36 | 37 | (public alias (Eq a) (Func a a Bool)) 38 | (public alias (Ord a) (Func a a Ordering)) 39 | (public alias (Read a) (Func String a)) 40 | (public alias (Show a) (Func a String)) 41 | 42 | ;; We only have one size of integer really, but specifying the 43 | ;; intended width is nice for documentary purposes. 44 | 45 | (public alias Int8 Int) 46 | (public alias Int16 Int) 47 | (public alias Int32 Int) 48 | (public alias Int64 Int) 49 | 50 | (public alias Word Int) 51 | (public alias Word8 Int) 52 | (public alias Word16 Int) 53 | (public alias Word32 Int) 54 | (public alias Word64 Int) 55 | 56 | ;; Same for strings... 57 | 58 | (public alias Bytes String) 59 | (public alias FilePath String) 60 | -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | module Util where 2 | 3 | import Control.Arrow 4 | import Data.Char 5 | import Data.List 6 | import qualified Data.Map as Map 7 | 8 | class Pretty a where 9 | pretty :: a -> String 10 | 11 | fixedPoint :: Eq a => a -> (a -> a) -> a 12 | fixedPoint x f = let fx = f x in if x == fx then x else fixedPoint fx f 13 | 14 | fixedPointN :: Eq a => Int -> a -> (a -> a) -> (Int, a) 15 | fixedPointN n x f = 16 | let fx = f x in if x == fx then (n, x) else fixedPointN (n + 1) fx f 17 | 18 | leftover :: Integral n => n -> n -> n 19 | leftover f x = (f - x) `mod` f 20 | 21 | roundUp :: Integral n => n -> n -> n 22 | roundUp f x = x + leftover f x 23 | 24 | groupBy :: Ord k => (v -> k) -> [v] -> Map.Map k [v] 25 | groupBy k = Map.fromListWith (++) . map (k &&& pure) 26 | 27 | listUnique :: Eq k => [k] -> Bool 28 | listUnique ks = nub ks == ks 29 | 30 | mapUnionsWithKey :: Ord k => (k -> v -> v -> v) -> [Map.Map k v] -> Map.Map k v 31 | mapUnionsWithKey f = foldl' (Map.unionWithKey f) Map.empty 32 | 33 | userAllowedChars :: String 34 | userAllowedChars = ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] 35 | 36 | -- important properties: deterministic, stateless, and injective 37 | sanitize :: String -> String 38 | sanitize = concatMap 39 | $ \c -> if c `elem` userAllowedChars then [c] else "_u" ++ show (ord c) 40 | 41 | both :: (a -> b) -> (a, a) -> (b, b) 42 | both f (a1, a2) = (f a1, f a2) 43 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/Instances/Ord.kalyn: -------------------------------------------------------------------------------- 1 | (import "../../Stdlib.kalyn") 2 | 3 | (public defn compareBool (Ord Bool) 4 | (x y) 5 | (case (Pair x y) 6 | ((Pair False True) 7 | LT) 8 | ((Pair True False) 9 | GT) 10 | (_ EQ))) 11 | 12 | (public defn compareInt (Ord Int) 13 | (x y) 14 | (if (Int x y) 17 | GT 18 | EQ))) 19 | 20 | (public defn compareList (Func (Ord a) (Ord (List a))) 21 | (compare s1 s2) 22 | (case (Pair s1 s2) 23 | ((Pair Null Null) 24 | EQ) 25 | ((Pair Null (Cons _ _)) 26 | LT) 27 | ((Pair (Cons _ _) Null) 28 | GT) 29 | ((Pair (Cons f1 r1) (Cons f2 r2)) 30 | (case (compare f1 f2) 31 | (LT LT) 32 | (GT GT) 33 | (EQ (compareList compare r1 r2)))))) 34 | 35 | (public defn compareChar (Ord Char) 36 | ((Char c1) (Char c2)) 37 | (compareInt c1 c2)) 38 | 39 | (public def compareString (Ord String) 40 | (compareList compareChar)) 41 | 42 | (public defn comparePair (Func (Ord a) (Ord b) (Ord (Pair a b))) 43 | (cmpA cmpB (Pair a1 b1) (Pair a2 b2)) 44 | (case (cmpA a1 a2) 45 | (EQ (cmpB b1 b2)) 46 | (res res))) 47 | 48 | (public defn compareTriplet (Func (Ord a) (Ord b) (Ord c) (Ord (Triplet a b c))) 49 | (cmpA cmpB cmpC (Triplet a1 b1 c1) (Triplet a2 b2 c2)) 50 | (case (cmpA a1 a2) 51 | (EQ (case (cmpB b1 b2) 52 | (EQ (cmpC c1 c2)) 53 | (res res))) 54 | (res res))) 55 | -------------------------------------------------------------------------------- /src-kalyn/Boilerplate.kalyn: -------------------------------------------------------------------------------- 1 | (import "Assembly.kalyn") 2 | (import "Stdlib.kalyn") 3 | 4 | (defn addFnBoilerplate (Func PFunction PFunction) 5 | ((Function stackSpace name instrs)) 6 | (let ((clobberedRegs 7 | (nub compareRegister 8 | (filter 9 | (lambda (reg) 10 | (and 11 | (setMember reg dataRegisters) 12 | (not (==Register reg RAX)))) 13 | (concatMap 14 | (comp snd (getRegisters fromP)) 15 | instrs))))) 16 | (function 17 | name 18 | (concat 19 | [[(UN PUSH (R RBP)) 20 | (OP MOV (RR RSP RBP))] 21 | (if (/=Int stackSpace 0) 22 | [(OP SUB (IR stackSpace RSP))] 23 | []) 24 | (map (comp (UN PUSH) R) clobberedRegs) 25 | (concatMap 26 | (lambda (instr) 27 | (case instr 28 | (RET 29 | (concat 30 | [(map (comp (UN POP) R) (reverse clobberedRegs)) 31 | (if (/=Int stackSpace 0) 32 | [(OP ADD (IR stackSpace RSP))] 33 | []) 34 | [(UN POP (R RBP)) 35 | instr]])) 36 | (_ [instr]))) 37 | instrs)])))) 38 | 39 | (public defn addProgramBoilerplate (Func PProgram PProgram) 40 | ((Program mainFn fns datums)) 41 | (Program mainFn (map addFnBoilerplate fns) datums)) 42 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/Instances/Show.kalyn: -------------------------------------------------------------------------------- 1 | (import "../../Stdlib.kalyn") 2 | 3 | (public defn showInt (Show Int) 4 | (i) 5 | (case (compareInt i 0) 6 | (LT (Cons '-' (showInt (- 0 i)))) 7 | (EQ "0") 8 | (GT (let ((showInt* 9 | (lambda (i str) 10 | (if (==Int i 0) 11 | str 12 | (showInt* 13 | (/ i 10) 14 | (Cons 15 | (Char (+ 0x30 (% i 10))) 16 | str)))))) 17 | (showInt* i ""))))) 18 | 19 | (public defn showList (Func (Show a) (Show (List a))) 20 | (show elts) 21 | (concat 22 | ["[" 23 | (intercalate ", " (map show elts)) 24 | "]"])) 25 | 26 | (public defn showPair (Func (Show a) (Show b) (Show (Pair a b))) 27 | (showA showB (Pair a b)) 28 | (concat 29 | ["(" 30 | (showA a) 31 | ", " 32 | (showB b) 33 | ")"])) 34 | 35 | (public defn showBool (Show Bool) 36 | (bool) 37 | (if bool 38 | "True" 39 | "False")) 40 | 41 | (public defn showMap (Func (Show k) (Show v) (Show (Map k v))) 42 | (showK showV) 43 | (comp (showList (showPair showK showV)) mapToList)) 44 | 45 | (public defn showSet (Func (Show a) (Show (Set a))) 46 | (show) 47 | (comp (showList show) setToList)) 48 | 49 | (public defn showMaybe (Func (Show a) (Show (Maybe a))) 50 | (show elt) 51 | (case elt 52 | (Nothing "Nothing") 53 | ((Just a) (append "Just " (show a))))) 54 | -------------------------------------------------------------------------------- /src/Reader.hs: -------------------------------------------------------------------------------- 1 | module Reader 2 | ( readModule 3 | ) where 4 | 5 | import Tokens 6 | 7 | -- Simple recursive descent parser for Lisp syntax. 8 | 9 | parseForm :: [Token] -> (Form, [Token]) 10 | parseForm (SYMBOL name : AT : rest) = 11 | let (aliased, rest') = parseForm rest in (At name aliased, rest') 12 | parseForm (SYMBOL s : rest) = (Symbol s, rest) 13 | parseForm (INTEGER i : rest) = (IntAtom i, rest) 14 | parseForm (CHAR c : rest) = (CharAtom c, rest) 15 | parseForm (STRING s : rest) = (StrAtom s, rest) 16 | parseForm (LPAREN : rest) = 17 | let (forms, rest') = parseForms rest 18 | in case rest' of 19 | RPAREN : rest'' -> (RoundList forms, rest'') 20 | token -> error $ "unexpected " ++ show token ++ " when parsing ( ... )" 21 | parseForm (LBRACKET : rest) = 22 | let (forms, rest') = parseForms rest 23 | in case rest' of 24 | RBRACKET : rest'' -> (SquareList forms, rest'') 25 | token -> error $ "unexpected " ++ show token ++ " when parsing ( ... )" 26 | parseForm tokens = error $ "failed to parse: " ++ show tokens 27 | 28 | parseForms :: [Token] -> ([Form], [Token]) 29 | parseForms [] = ([], []) 30 | parseForms (token : rest) | token `elem` [RPAREN, RBRACKET] = ([], token : rest) 31 | parseForms tokens = 32 | let (form , rest ) = parseForm tokens 33 | (forms, rest') = parseForms rest 34 | in (form : forms, rest') 35 | 36 | readModule :: [Token] -> [Form] 37 | readModule tokens = 38 | let (forms, rest) = parseForms tokens 39 | in if null rest 40 | then forms 41 | else error $ "trailing garbage following program: " ++ show rest 42 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/FilePaths.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (public defn takeDirectory (Func FilePath FilePath) 4 | "Given an absolute path, strip off the last component. Don't leave a 5 | trailing slash." 6 | (path) 7 | (reverse 8 | (tail 9 | (dropWhile 10 | (comp not (==Char '/')) 11 | (reverse path))))) 12 | 13 | (public defn takeFileName (Func FilePath FilePath) 14 | "Given a path, return only the last component. This will be empty if 15 | the given path ends in a slash." 16 | (path) 17 | (reverse 18 | (takeWhile 19 | (comp not (==Char '/')) 20 | (reverse path)))) 21 | 22 | (public defn expandPath (Func (Maybe FilePath) FilePath (IO FilePath)) 23 | "Expand a relative or absolute path to be absolute, relative to 24 | either the current working directory or a provided working 25 | directory (which must be absolute)." 26 | (workdir relpath) 27 | (case relpath 28 | ((Cons '/' _) (returnIO relpath)) 29 | (_ (do IO 30 | (with workdir 31 | (case workdir 32 | (Nothing getWorkingDirectory) 33 | ((Just workdir) (returnIO workdir)))) 34 | (let workdirParts 35 | (reverse (filter notNull (split ==Char '/' workdir)))) 36 | (let relpathParts 37 | (filter notNull (split ==Char '/' relpath))) 38 | (let workdirParts* 39 | (foldl 40 | (lambda (workdirParts relpathPart) 41 | (case relpathPart 42 | ("." workdirParts) 43 | (".." (tail workdirParts)) 44 | (_ (Cons relpathPart workdirParts)))) 45 | workdirParts 46 | relpathParts)) 47 | (returnIO 48 | (Cons '/' (intercalate "/" (reverse workdirParts*)))))))) 49 | -------------------------------------------------------------------------------- /src-kalyn/Reader.kalyn: -------------------------------------------------------------------------------- 1 | (import "Stdlib.kalyn") 2 | (import "Tokens.kalyn") 3 | 4 | ;; Simple recursive descent parser for Lisp syntax. 5 | 6 | (defn parseForm (Func (List Token) (Pair Form (List Token))) 7 | (tokens) 8 | (case tokens 9 | ((Cons (SYMBOL name) (Cons AT rest)) 10 | (let (((Pair aliased rest*) (parseForm rest))) 11 | (Pair (At name aliased) rest*))) 12 | ((Cons (SYMBOL s) rest) 13 | (Pair (Symbol s) rest)) 14 | ((Cons (INTEGER i) rest) 15 | (Pair (IntAtom i) rest)) 16 | ((Cons (CHAR c) rest) 17 | (Pair (CharAtom c) rest)) 18 | ((Cons (STRING s) rest) 19 | (Pair (StrAtom s) rest)) 20 | ((Cons LPAREN rest) 21 | (let (((Pair forms rest*) (parseForms rest))) 22 | (case rest* 23 | ((Cons RPAREN rest**) (Pair (RoundList forms) rest**)) 24 | (token (error "reader error inside round list \n"))))) 25 | ((Cons LBRACKET rest) 26 | (let (((Pair forms rest*) (parseForms rest))) 27 | (case rest* 28 | ((Cons RBRACKET rest**) (Pair (SquareList forms) rest**)) 29 | (token (error "reader error inside square list \n"))))) 30 | (tokens (error "reader error\n")))) 31 | 32 | (defn parseForms (Func (List Token) (Pair (List Form) (List Token))) 33 | (tokens) 34 | (case tokens 35 | (Null (Pair [] [])) 36 | ((Cons RPAREN rest) (Pair [] (Cons RPAREN rest))) 37 | ((Cons RBRACKET rest) (Pair [] (Cons RBRACKET rest))) 38 | (tokens 39 | (let (((Pair form rest) (parseForm tokens)) 40 | ((Pair forms rest*) (parseForms rest))) 41 | (Pair (Cons form forms) rest*))))) 42 | 43 | (public defn readModule (Func (List Token) (List Form)) 44 | (tokens) 45 | (let (((Pair forms rest) (parseForms tokens))) 46 | (case rest 47 | (Null forms) 48 | (_ (error "reader found trailing garbage\n"))))) 49 | -------------------------------------------------------------------------------- /src-kalyn/Main.kalyn: -------------------------------------------------------------------------------- 1 | (import "AST.kalyn") 2 | (import "Assembly.kalyn") 3 | (import "Stdlib.kalyn") 4 | 5 | (import "Lexer.kalyn") 6 | (import "Reader.kalyn") 7 | (import "Parser.kalyn") 8 | (import "Bundler.kalyn") 9 | (import "Resolver.kalyn") 10 | (import "Translator.kalyn") 11 | (import "Liveness.kalyn") 12 | (import "RegisterAllocator.kalyn") 13 | (import "Boilerplate.kalyn") 14 | (import "Assembler.kalyn") 15 | (import "Linker.kalyn") 16 | 17 | (defn bundlerRead (Func String (IO (List Decl))) 18 | (inputFilename) 19 | (do IO 20 | (let inputBasename (takeFileName inputFilename)) 21 | (with str (readFile inputFilename)) 22 | (print (concat ["Lexer (" inputBasename ")\n"])) 23 | (let tokens (tokenize str)) 24 | (print (concat ["Reader (" inputBasename ")\n"])) 25 | (let forms (readModule tokens)) 26 | (print (concat ["Parser (" inputBasename ")\n"])) 27 | (let decls (parseModule forms)) 28 | (returnIO decls))) 29 | 30 | (public def main (IO Empty) 31 | (do IO 32 | (with bundle 33 | (readBundle (print "Bundler\n") bundlerRead "./src-kalyn/Main.kalyn")) 34 | (print "Resolver\n") 35 | (let resolver (resolveBundle bundle)) 36 | (print "Translator\n") 37 | (let (Pair state prog) 38 | ((runState 0) 39 | (translateBundle resolver bundle))) 40 | ;; (writeFile "out-kalyn-rec/MainVirtual.S" (showProgram showVR prog)) 41 | (print "Liveness\n") 42 | (let liveness (computeProgramLiveness prog)) 43 | (print "RegisterAllocator\n") 44 | (let physical 45 | ((evalState state) 46 | (allocateProgramRegs prog liveness))) 47 | ;; (writeFile "out-kalyn-rec/MainRaw.S" (showProgram showRegister physical)) 48 | (print "Boilerplate\n") 49 | (let physical* (addProgramBoilerplate physical)) 50 | ;; (writeFile "out-kalyn-rec/Main.S" (showProgram showRegister physical*)) 51 | (print "Assembler\n") 52 | (let assembled (assemble physical*)) 53 | (print "Linker\n") 54 | (let bin (link assembled)) 55 | (writeFile "out-kalyn-rec/Main" bin) 56 | (setFileMode "out-kalyn-rec/Main" 0o755))) 57 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/States.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (public defn fmapState (Func (Func a b) (State s a) (State s b)) 4 | (f (State go)) 5 | (State (lambda (s) 6 | (let (((Pair s* a) (go s))) 7 | (Pair s* (f a)))))) 8 | 9 | (public defn returnState (Func a (State s a)) 10 | (a) 11 | (State (lambda (s) (Pair s a)))) 12 | 13 | (public defn >>=State (Func (State s a) (Func a (State s b)) (State s b)) 14 | ((State go) f) 15 | (State (lambda (s) 16 | (let (((Pair s* a) (go s)) 17 | ((State go) (f a))) 18 | (go s*))))) 19 | 20 | (public def get (State s s) 21 | (State (lambda (s) (Pair s s)))) 22 | 23 | (public defn put (Func s (State s Empty)) 24 | (s) 25 | (State (const (Pair s Empty)))) 26 | 27 | (public defn runState (Func s (State s a) (Pair s a)) 28 | (s (State go)) 29 | (go s)) 30 | 31 | (public defn evalState (Func s (State s a) a) 32 | (s (State go)) 33 | (snd (go s))) 34 | 35 | (public defn sequenceState (Func (List (State s a)) (State s (List a))) 36 | (states) 37 | (case states 38 | (Null (returnState Null)) 39 | ((Cons state states) 40 | (do State 41 | (with fst state) 42 | (with rst (sequenceState states)) 43 | (returnState (Cons fst rst)))))) 44 | 45 | (public defn mapMState (Func (Func a (State s b)) (List a) (State s (List b))) 46 | (func as) 47 | (sequenceState (map func as))) 48 | 49 | (public defn zipWithMState (Func 50 | (Func a b (State s c)) 51 | (List a) 52 | (List b) 53 | (State s (List c))) 54 | (func as bs) 55 | (sequenceState (zipWith func as bs))) 56 | 57 | (public defn replicateMState (Func Int (State s a) (State s (List a))) 58 | (n m) 59 | (sequenceState (replicate n m))) 60 | 61 | (public defn foldMState (Func (Func b a (State s b)) b (List a) (State s b)) 62 | (func init elts) 63 | (case elts 64 | (Null (returnState init)) 65 | ((Cons elt elts) 66 | (do State 67 | (with val (func init elt)) 68 | (foldMState func val elts))))) 69 | -------------------------------------------------------------------------------- /src/MemoryManager.hs: -------------------------------------------------------------------------------- 1 | module MemoryManager where 2 | 3 | import Data.ByteString.Builder 4 | 5 | import Assembly 6 | import OS 7 | import Subroutines 8 | 9 | memoryFirstFree :: Datum 10 | memoryFirstFree = ("mmFirstFree", toLazyByteString $ word64LE 0) 11 | 12 | memoryProgramBreak :: Datum 13 | memoryProgramBreak = ("mmProgramBreak", toLazyByteString $ word64LE 0) 14 | 15 | memoryInit :: Stateful VirtualFunction 16 | memoryInit = return $ function 17 | "memoryInit" 18 | [ OP MOV $ IR 12 rax 19 | , OP MOV $ IR 0 rdi 20 | , SYSCALL 1 -- brk 21 | , OP MOV $ RM rax (memLabel $ fst memoryProgramBreak) 22 | , OP MOV $ RM rax (memLabel $ fst memoryFirstFree) 23 | , RET 24 | ] 25 | 26 | memoryAlloc :: Stateful VirtualFunction 27 | memoryAlloc = do 28 | firstFree <- newTemp 29 | ptr <- newTemp 30 | brk <- newLabel 31 | done <- newLabel 32 | crash <- newLabel 33 | msg <- newTemp 34 | return $ function 35 | "memoryAlloc" 36 | [ OP MOV $ MR (memLabel "mmFirstFree") firstFree 37 | -- round up to nearest multiple of eight, see 38 | -- 39 | , OP ADD $ IR 7 firstFree 40 | , OP AND $ IR (-8) firstFree 41 | -- now to proceed 42 | , OP MOV $ RR firstFree ptr 43 | , OP ADD $ MR (getArg 1) firstFree 44 | , OP MOV $ RM firstFree (memLabel "mmFirstFree") 45 | , OP CMP $ MR (memLabel "mmProgramBreak") firstFree 46 | , JUMP JG brk 47 | , LABEL done 48 | , OP MOV $ RR ptr rax 49 | , RET 50 | , LABEL brk 51 | -- round up to next page boundary 52 | , OP ADD $ IR (fromIntegral $ pageSize - 1) firstFree 53 | , OP AND $ IR (fromIntegral $ -pageSize) firstFree 54 | -- reserve 1000 more pages while we're at it 55 | , OP ADD $ IR (fromIntegral $ pageSize * 1000) firstFree 56 | , OP MOV $ IR 12 rax 57 | , OP MOV $ RR firstFree rdi 58 | , SYSCALL 1 -- brk 59 | , OP CMP $ RR firstFree rax 60 | , JUMP JL crash 61 | , OP MOV $ RM rax (memLabel "mmProgramBreak") 62 | , JUMP JMP done 63 | , LABEL crash 64 | , LEA (memLabel "msgMemoryAllocFailed") msg 65 | , UN PUSH $ R msg 66 | , JUMP CALL "crash" 67 | ] 68 | -------------------------------------------------------------------------------- /src-kalyn/Util.kalyn: -------------------------------------------------------------------------------- 1 | (import "Stdlib.kalyn") 2 | 3 | (public defn word8 (Func Word8 Bytes) 4 | (v) 5 | [(Char v)]) 6 | 7 | (public defn word16 (Func Word16 Bytes) 8 | (v) 9 | [(Char v ) 10 | (Char (shr v 8))]) 11 | 12 | (public defn word32 (Func Word32 Bytes) 13 | (v) 14 | [(Char v ) 15 | (Char (shr v 8) ) 16 | (Char (shr v 16)) 17 | (Char (shr v 24))]) 18 | 19 | (public defn word64 (Func Word64 Bytes) 20 | (v) 21 | [(Char v ) 22 | (Char (shr v 8) ) 23 | (Char (shr v 16)) 24 | (Char (shr v 24)) 25 | (Char (shr v 32)) 26 | (Char (shr v 40)) 27 | (Char (shr v 48)) 28 | (Char (shr v 56))]) 29 | 30 | (public def int8 (Func Int8 Bytes) 31 | word8) 32 | 33 | (public def int16 (Func Int16 Bytes) 34 | word16) 35 | 36 | (public def int32 (Func Int32 Bytes) 37 | word32) 38 | 39 | (public def int64 (Func Int64 Bytes) 40 | word64) 41 | 42 | (public defn fixedPoint (Func (Eq a) a (Func a a) a) 43 | "Compute the least fixed point of a function. Given an equality 44 | test, repeatedly apply the function to its argument until two 45 | successive values are the same, then return the first of them." 46 | (eq x f) 47 | (let ((fx (f x))) 48 | (if (eq x fx) 49 | x 50 | (fixedPoint eq fx f)))) 51 | 52 | (public defn isAlphaNum (Func Char Bool) 53 | ((Char c)) 54 | (or 55 | (and 56 | (>=Int c 0x30) 57 | (<=Int c 0x39)) 58 | (and 59 | (>=Int c 0x41) 60 | (<=Int c 0x5a)) 61 | (and 62 | (>=Int c 0x61) 63 | (<=Int c 0x7a)))) 64 | 65 | (public defn isLower (Func Char Bool) 66 | ((Char c)) 67 | (and 68 | (>=Int c 0x61) 69 | (<=Int c 0x7a))) 70 | 71 | (public defn isDigit (Func Char Bool) 72 | ((Char c)) 73 | (and 74 | (>=Int c 0x30) 75 | (<=Int c 0x39))) 76 | 77 | (public defn isSpace (Func Char Bool) 78 | (c) 79 | (case c 80 | (' ' True) 81 | ('\t' True) 82 | ('\n' True) 83 | ('\r' True) 84 | ('\v' True) 85 | ('\f' True) 86 | (_ False))) 87 | 88 | ;; important properties: deterministic, stateless, and injective 89 | (public def sanitize (Func String String) 90 | (concatMap (lambda (c@(Char i)) 91 | (if (isAlphaNum c) 92 | [c] 93 | (append "_u" (showInt i)))))) 94 | 95 | (public defn listUnique (Func (Ord k) (List k) Bool) 96 | (cmp ks) 97 | (==Int (length ks) (setSize (setFromList cmp ks)))) 98 | -------------------------------------------------------------------------------- /src/Lexer.hs: -------------------------------------------------------------------------------- 1 | module Lexer 2 | ( tokenize 3 | ) where 4 | 5 | import Data.Char 6 | import Data.Maybe 7 | 8 | import Tokens 9 | 10 | disallowedChars :: String 11 | disallowedChars = ";()[]@" 12 | 13 | getStringChar :: String -> (Char, String, Bool) 14 | getStringChar [] = error "unexpected end of string literal" 15 | getStringChar ('\\' : 'x' : a : b : s) = (read $ "0x" ++ [a, b], s, True) 16 | getStringChar ('\\' : c : s) = 17 | ( case c of 18 | '0' -> '\0' 19 | 'a' -> '\a' 20 | 'b' -> '\b' 21 | 'f' -> '\f' 22 | 'n' -> '\n' 23 | 'r' -> '\r' 24 | 't' -> '\t' 25 | 'v' -> '\v' 26 | _ -> c 27 | , s 28 | , True 29 | ) 30 | getStringChar (c : s) = (c, s, False) 31 | 32 | readString :: Char -> String -> (String, String) 33 | readString delim str = 34 | let (char, rest, escaped) = getStringChar str 35 | in if char == delim && not escaped 36 | then ("", rest) 37 | else 38 | let (parsed, rest') = readString delim rest in (char : parsed, rest') 39 | 40 | -- hand-roll instead of using regexes for two reasons: 41 | -- 1. because that's what we have to do in Kalyn 42 | -- 2. https://github.com/haskell-hvr/regex-tdfa/issues/12 43 | getToken :: String -> (Maybe Token, String) 44 | getToken [] = error "shouldn't be getting a token from an empty string" 45 | getToken (c : s) | isSpace c = (Nothing, s) 46 | getToken (';' : s) = (Nothing, tail . dropWhile (/= '\n') $ s) 47 | getToken ('(' : s) = (Just LPAREN, s) 48 | getToken (')' : s) = (Just RPAREN, s) 49 | getToken ('[' : s) = (Just LBRACKET, s) 50 | getToken (']' : s) = (Just RBRACKET, s) 51 | getToken ('@' : s) = (Just AT, s) 52 | getToken ('"' : s) = 53 | let (parsed, rest) = readString '"' s in (Just . STRING $ parsed, rest) 54 | getToken full@('\'' : s) = 55 | let (parsed, rest) = readString '\'' s 56 | in if length parsed == 1 57 | then (Just . CHAR $ head parsed, rest) 58 | else error $ "character literal had more than one character: " ++ full 59 | getToken s@(c : _) | isDigit c = 60 | let (d, s') = span isAlphaNum s in (Just . INTEGER . read $ d, s') 61 | getToken ('-' : s@(c : _)) | isDigit c = 62 | let (d, s') = span isAlphaNum s in (Just . INTEGER . read $ '-' : d, s') 63 | getToken s = 64 | let (v, s') = 65 | span (\c -> (not . isSpace $ c) && c `notElem` disallowedChars) s 66 | in (Just . SYMBOL $ v, s') 67 | 68 | tokenize :: String -> [Token] 69 | tokenize str = catMaybes $ getTokens str 70 | where 71 | getTokens [] = [] 72 | getTokens s = let (t, s') = getToken s in t : getTokens s' 73 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/Collections/Sets.kalyn: -------------------------------------------------------------------------------- 1 | (import "../../Stdlib.kalyn") 2 | 3 | (public alias (Set k) 4 | "Ordered set. Embeds a comparison function." 5 | (Map k Empty)) 6 | 7 | (public def setEmpty (Func (Ord k) (Set k)) 8 | "Create an empty set with the given comparison function." 9 | mapEmpty) 10 | 11 | (public def setNull (Func (Set k) Bool) 12 | "Check if the set is empty (has no elements)." 13 | mapNull) 14 | 15 | (public def setSize (Func (Set k) Int) 16 | "Return the number of elements in the set." 17 | mapSize) 18 | 19 | (public defn setInsert (Func k (Set k) (Set k)) 20 | "Insert a key into the set, replacing any existing value that 21 | compares equal." 22 | (k) 23 | (mapInsert k Empty)) 24 | 25 | (public def setDelete (Func k (Set k) (Set k)) 26 | "Delete a key from the set if it's present, returning a new set." 27 | mapDelete) 28 | 29 | (public defn setFromList (Func (Ord k) (List k) (Set k)) 30 | "Given an unordered list of keys, create a set with the provided 31 | comparison function." 32 | (cmp) 33 | (comp (mapFromList cmp) (map (lambda (k) (Pair k Empty))))) 34 | 35 | (public def setToList (Func (Set k) (List k)) 36 | "Convert a set to a list of its keys in ascending order." 37 | mapKeys) 38 | 39 | (public def setUnion (Func (Set k) (Set k) (Set k)) 40 | "Left-biased set union." 41 | mapUnion) 42 | 43 | (public def setUnions (Func (Ord k) (List (Set k)) (Set k)) 44 | "Left-biased union of a list of sets." 45 | mapUnions) 46 | 47 | (public def set\\ (Func (Set k) (Set k) (Set k)) 48 | "Set difference. Remove all the elements of the right-hand set from 49 | the left-hand set." 50 | map\\) 51 | 52 | (public defn setFoldr (Func (Func k a a) a (Set k) a) 53 | "Right fold over a set." 54 | (func init) 55 | (comp (foldr func init) setToList)) 56 | 57 | (public def setFilter (Func (Func k Bool) (Set k) (Set k)) 58 | "Filter a set by the given predicate." 59 | mapFilter) 60 | 61 | (public def setMember (Func k (Set k) Bool) 62 | "Check if the given element is in the set." 63 | mapMember) 64 | 65 | (public defn setHead (Func (Set k) (Maybe k)) 66 | "Get an arbitrary key from the set." 67 | (set) 68 | (case (mapHead set) 69 | (Nothing Nothing) 70 | ((Just (Pair k _)) (Just k)))) 71 | 72 | (public def setNotMember (Func k (Set k) Bool) 73 | "Check if the given element is NOT in the set." 74 | mapNotMember) 75 | 76 | (public defn setMap (Func (Ord b) (Func a b) (Set a) (Set b)) 77 | "Map a function over a set." 78 | (cmp func set) 79 | (setFromList cmp (map func (setToList set)))) 80 | 81 | (public defn setSingleton (Func (Ord k) k (Set k)) 82 | "Make a set with just one element." 83 | (cmp k) 84 | (mapSingleton cmp k Empty)) 85 | -------------------------------------------------------------------------------- /src/Bundler.hs: -------------------------------------------------------------------------------- 1 | module Bundler 2 | ( readBundle 3 | ) where 4 | 5 | import qualified Data.Map.Strict as Map 6 | import qualified Data.Set as Set 7 | import System.Directory 8 | import System.FilePath 9 | 10 | import AST 11 | 12 | extractImports :: [Decl] -> ([(FilePath, Bool)], [Decl]) 13 | extractImports [] = ([], []) 14 | extractImports (Import pub file : decls) = 15 | let (files, decls') = extractImports decls in ((file, pub) : files, decls') 16 | extractImports (decl : decls) = 17 | let (files, decls') = extractImports decls in (files, decl : decls') 18 | 19 | readBundle' 20 | :: (String -> IO [Decl]) 21 | -> [FilePath] 22 | -> [FilePath] 23 | -> Map.Map FilePath ([Decl], [(FilePath, Bool)]) 24 | -> IO (Map.Map FilePath ([Decl], [(FilePath, Bool)])) 25 | readBundle' _ _ [] declsSoFar = return declsSoFar 26 | readBundle' readDecls alreadyRead (curToRead : restToRead) declsSoFar = 27 | if curToRead `elem` alreadyRead 28 | then readBundle' readDecls alreadyRead restToRead declsSoFar 29 | else do 30 | (newToRead, newDecls) <- extractImports <$> readDecls curToRead 31 | absNewToRead <- withCurrentDirectory (takeDirectory curToRead) $ mapM 32 | (\(path, pub) -> do 33 | absPath <- canonicalizePath path 34 | return (absPath, pub) 35 | ) 36 | newToRead 37 | readBundle' readDecls 38 | (curToRead : alreadyRead) 39 | (map fst absNewToRead ++ restToRead) 40 | (Map.insert curToRead (newDecls, absNewToRead) declsSoFar) 41 | 42 | transitiveImports 43 | :: Map.Map FilePath ([Decl], [(FilePath, Bool)]) 44 | -> Set.Set FilePath 45 | -> Set.Set FilePath 46 | -> Set.Set FilePath 47 | -> Set.Set FilePath 48 | transitiveImports modules seen queue result = case Set.minView queue of 49 | Nothing -> result 50 | Just (cur, next) -> if Set.member cur seen 51 | then transitiveImports modules seen next result 52 | else 53 | let (_, deps) = modules Map.! cur 54 | new = map fst $ filter snd deps 55 | in transitiveImports modules 56 | (Set.insert cur seen) 57 | (foldr Set.insert next new) 58 | (Set.insert cur result) 59 | 60 | readBundle :: IO () -> (String -> IO [Decl]) -> FilePath -> IO Bundle 61 | readBundle onReadFinished readDecls filename = do 62 | absFilename <- canonicalizePath filename 63 | modules <- readBundle' readDecls [] [absFilename] Map.empty 64 | onReadFinished 65 | return $ Bundle absFilename $ Map.mapWithKey 66 | (\name (decls, _) -> 67 | ( decls 68 | , Set.toList $ transitiveImports 69 | modules 70 | (Set.singleton name) 71 | (Set.fromList . map fst . snd $ modules Map.! name) 72 | Set.empty 73 | ) 74 | ) 75 | modules 76 | -------------------------------------------------------------------------------- /src-kalyn/AST.kalyn: -------------------------------------------------------------------------------- 1 | (import "Stdlib.kalyn") 2 | 3 | (public alias ClassName String) 4 | (public alias TypeName String) 5 | (public alias VarName String) 6 | (public alias ModuleAbbr String) 7 | 8 | (public data ClassSpec 9 | (ClassSpec ClassName TypeName)) 10 | 11 | (public data TypeSpec 12 | (TypeSpec TypeName (List TypeName))) 13 | 14 | (public data Type 15 | (Type (List ClassSpec) TypeName (List Type))) 16 | 17 | (public data Expr 18 | (Variable VarName) 19 | (Const Int64) 20 | (Call Expr Expr) 21 | (Case Expr (List (Pair Expr Expr))) 22 | (Lambda VarName Expr) 23 | (Let VarName Expr Expr) 24 | (As VarName Expr)) 25 | 26 | (public data Decl 27 | (Alias Bool TypeSpec Type) 28 | (Class Bool (List ClassSpec) ClassSpec (List (Pair VarName Type))) 29 | (Data Bool TypeSpec (List (Pair VarName (List Type)))) 30 | (Def Bool VarName Type Expr) 31 | (Derive Bool ClassSpec) 32 | (Import Bool String) 33 | (Instance Bool (List ClassSpec) ClassSpec (List (Pair VarName Expr)))) 34 | 35 | (public data Symbol 36 | (SymDef String Type Int) 37 | (SymData String Int Int Int Bool TypeSpec (List Type))) 38 | 39 | (public defn sdName (Func Symbol String) 40 | ((SymData sdName _ _ _ _ _ _)) 41 | sdName) 42 | 43 | (public defn sdCtorIdx (Func Symbol Int) 44 | ((SymData _ sdCtorIdx _ _ _ _ _)) 45 | sdCtorIdx) 46 | 47 | (public defn sdNumFields (Func Symbol Int) 48 | ((SymData _ _ sdNumFields _ _ _ _)) 49 | sdNumFields) 50 | 51 | (public defn sdNumCtors (Func Symbol Int) 52 | ((SymData _ _ _ sdNumCtors _ _ _)) 53 | sdNumCtors) 54 | 55 | (public defn sdBoxed (Func Symbol Bool) 56 | ((SymData _ _ _ _ sdBoxed _ _)) 57 | sdBoxed) 58 | 59 | (public defn sdTypeSpec (Func Symbol TypeSpec) 60 | ((SymData _ _ _ _ _ sdTypeSpec _)) 61 | sdTypeSpec) 62 | 63 | (public defn sdTypes (Func Symbol (List Type)) 64 | ((SymData _ _ _ _ _ _ sdTypes)) 65 | sdTypes) 66 | 67 | (public defn shouldBox (Func (List (Pair VarName (List Type))) Bool) 68 | (ctors) 69 | (let ((multipleCtors (>Int (length ctors) 1)) 70 | (multipleFields (any (lambda ((Pair _ fields)) 71 | (>Int (length fields) 1)) 72 | ctors)) 73 | (anyFields (any (lambda ((Pair _ fields)) 74 | (notNull fields)) 75 | ctors))) 76 | (or 77 | multipleFields 78 | (and 79 | multipleCtors 80 | anyFields)))) 81 | 82 | (public defn sdHasHeader (Func Symbol Bool) 83 | (sd) 84 | (>Int (sdNumCtors sd) 1)) 85 | 86 | (public defn symName (Func Symbol String) 87 | (sym) 88 | (case sym 89 | ((SymDef name _ _) name) 90 | ((SymData name _ _ _ _ _ _) name))) 91 | 92 | (public data Bundle 93 | (Bundle String (Map String (Pair (List Decl) (List String))))) 94 | 95 | (public alias ModAliasResolver (Map TypeName (Pair (List TypeName) Type))) 96 | (public alias ModSymResolver (Map String Symbol)) 97 | (public alias ModResolver (Pair ModSymResolver ModAliasResolver)) 98 | 99 | (public data Resolver 100 | (Resolver (Map String ModResolver))) 101 | -------------------------------------------------------------------------------- /src-kalyn/Linker.kalyn: -------------------------------------------------------------------------------- 1 | (import "Stdlib.kalyn") 2 | (import "Util.kalyn") 3 | 4 | ;; https://refspecs.linuxfoundation.org/elf/elf.pdf 5 | ;; see page 20 6 | 7 | (def elfIdent Bytes 8 | "The ELF magic header." 9 | (concat 10 | [(word8 0x7f) ; magic bytes 11 | "ELF" 12 | (word8 2) ; address size, 64-bit 13 | (word8 1) ; endianness, little-endian 14 | (word8 1) ; version of ELF specification 15 | (replicate 9 (Char 0))])) ; padding to 16 bytes 16 | 17 | ;; see page 18; for architecture codes see 18 | ;; 19 | (defn elfHeader (Func Int Int Bytes) 20 | "Given meta-information about the ELF header, compute the main ELF 21 | header." 22 | (elfHeaderLength programHeaderLength) 23 | (let ((totalLength (+ elfHeaderLength programHeaderLength))) 24 | (concat 25 | [elfIdent 26 | (word16 3) ; file type, relocatable executable 27 | (word16 62) ; architecture, x86_64 28 | (word32 1) ; object file version 29 | (word64 totalLength) ; entry point in virtual memory 30 | (word64 elfHeaderLength) ; program header offset 31 | (word64 0) ; section header offset, unused 32 | (word32 0) ; processor-specific flags, none needed 33 | (word16 elfHeaderLength) ; ELF header size 34 | (word16 programHeaderLength) ; program header entry length 35 | (word16 1) ; program header entry count 36 | (word16 0) ; section header entry size, unused 37 | (word16 0) ; section header entry count, unused 38 | (word16 0)]))) ; index of string table in section header, unused 39 | 40 | ;; see page 40 41 | (defn programHeader (Func Int Int Int Bytes) 42 | "Given meta-information about the ELF header, compute the program 43 | header. It only has a code section." 44 | (elfHeaderLength programHeaderLength imageSize) 45 | (let ((totalLength (+ elfHeaderLength programHeaderLength))) 46 | (concat 47 | [(word32 1) ; segment type, loadable code/data 48 | (word32 0x7) ; permissions, allow all (see page 73) 49 | (word64 totalLength) ; offset from beginning of file 50 | (word64 totalLength) ; virtual address at which to map code/data 51 | (word64 0) ; physical address at which to map, unused 52 | (word64 imageSize) ; number of bytes listed in file image 53 | (word64 imageSize) ; number of bytes to reserve in memory 54 | (word64 0)]))) ; alignment, none needed 55 | 56 | (public defn link (Func Bytes Bytes) 57 | "Given the combined code and data sections, wrap them in an ELF 58 | header." 59 | (code) 60 | (let (((Pair ehdr phdr) 61 | (fixedPoint 62 | (==Pair ==String ==String) 63 | (Pair [] []) 64 | (lambda ((Pair ehdr phdr)) 65 | (let ((elen (length ehdr)) 66 | (plen (length phdr)) 67 | (imageSize (length code))) 68 | (Pair 69 | (elfHeader elen plen) 70 | (programHeader elen plen imageSize))))))) 71 | (concat [ehdr phdr code]))) 72 | -------------------------------------------------------------------------------- /src-kalyn/Lexer.kalyn: -------------------------------------------------------------------------------- 1 | (import "Stdlib.kalyn") 2 | (import "Tokens.kalyn") 3 | (import "Util.kalyn") 4 | 5 | (def disallowedChars String 6 | ";()[]@") 7 | 8 | (defn getStringChar (Func String (Triplet Char String Bool)) 9 | (str) 10 | (case str 11 | (Null (error "unexpected end of string literal\n")) 12 | ((Cons '\\' (Cons 'x' (Cons a (Cons b s)))) 13 | (Triplet (Char (readInt ['0' 'x' a b])) s True)) 14 | ((Cons '\\' (Cons c s)) 15 | (Triplet 16 | (case c 17 | ('0' '\0') 18 | ('a' '\a') 19 | ('b' '\b') 20 | ('f' '\f') 21 | ('n' '\n') 22 | ('r' '\r') 23 | ('t' '\t') 24 | ('v' '\v') 25 | ( _ c )) 26 | s 27 | True)) 28 | ((Cons c s) 29 | (Triplet c s False)))) 30 | 31 | (defn readString (Func Char String (Pair String String)) 32 | (delim str) 33 | (let (((Triplet char rest escaped) (getStringChar str))) 34 | (if (and (==Char char delim) (not escaped)) 35 | (Pair "" rest) 36 | (let (((Pair parsed rest*) (readString delim rest))) 37 | (Pair (Cons char parsed) rest*))))) 38 | 39 | (defn getSymbolToken (Func String (Pair (Maybe Token) String)) 40 | (s) 41 | (let (((Pair v s*) (span (lambda (c) 42 | (and 43 | (not (isSpace c)) 44 | (notElem ==Char c disallowedChars))) 45 | s))) 46 | (Pair (Just (SYMBOL v)) s*))) 47 | 48 | (defn getToken (Func String (Pair (Maybe Token) String)) 49 | (str) 50 | (case str 51 | (Null (error "shouldn't be getting a token from an empty string\n")) 52 | (full@(Cons c s) 53 | (if (isSpace c) 54 | (Pair Nothing s) 55 | (case c 56 | (';' (Pair Nothing (tail (dropWhile (comp not (==Char '\n')) s)))) 57 | ('(' (Pair (Just LPAREN) s)) 58 | (')' (Pair (Just RPAREN) s)) 59 | ('[' (Pair (Just LBRACKET) s)) 60 | (']' (Pair (Just RBRACKET) s)) 61 | ('@' (Pair (Just AT) s)) 62 | ('"' (let (((Pair parsed rest) (readString '"' s))) 63 | (Pair (Just (STRING parsed)) rest))) 64 | ('\'' (let (((Pair parsed rest) (readString '\'' s))) 65 | (if (==Int (length parsed) 1) 66 | (Pair (Just (CHAR (head parsed))) rest) 67 | (error (concat ["character literal " 68 | full 69 | " had more than one character\n"]))))) 70 | ('-' (case s 71 | ((Cons c _) 72 | (if (isDigit c) 73 | (let (((Pair d s*) (span isAlphaNum s))) 74 | (Pair (Just (INTEGER (readInt (Cons '-' d)))) s*)) 75 | (getSymbolToken full))) 76 | (_ (getSymbolToken full)))) 77 | (_ (if (isDigit c) 78 | (let (((Pair d s*) (span isAlphaNum full))) 79 | (Pair (Just (INTEGER (readInt d))) s*)) 80 | (getSymbolToken full)))))))) 81 | 82 | (public defn tokenize (Func String (List Token)) 83 | (str) 84 | (let ((getTokens 85 | (lambda (str) 86 | (case str 87 | (Null Null) 88 | (s (let (((Pair t s*) (getToken s))) 89 | (Cons t (getTokens s*)))))))) 90 | (catMaybes (getTokens str)))) 91 | -------------------------------------------------------------------------------- /scripts/plot.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | 3 | import datetime 4 | import os 5 | import pathlib 6 | 7 | from matplotlib.dates import DateFormatter, date2num 8 | from matplotlib.ticker import FixedLocator 9 | import matplotlib.pyplot as plt 10 | 11 | os.chdir(pathlib.Path(__file__).parent) 12 | 13 | points = [] 14 | 15 | 16 | def read(num): 17 | if num: 18 | return int(num) 19 | else: 20 | # thanks awk 21 | return 0 22 | 23 | 24 | with open("report.log") as f: 25 | for line in f: 26 | ( 27 | haskell_loc, 28 | kalyn_loc, 29 | haskell_loc_added, 30 | haskell_loc_removed, 31 | kalyn_loc_added, 32 | kalyn_loc_removed, 33 | haskell_files, 34 | kalyn_files, 35 | timestamp, 36 | sha, 37 | ) = line.split(",") 38 | points.append( 39 | { 40 | "haskell_loc": read(haskell_loc), 41 | "kalyn_loc": read(kalyn_loc), 42 | "haskell_loc_added": read(haskell_loc_added), 43 | "haskell_loc_removed": read(haskell_loc_removed), 44 | "kalyn_loc_added": read(kalyn_loc_added), 45 | "kalyn_loc_removed": read(kalyn_loc_removed), 46 | "haskell_files": read(haskell_files), 47 | "kalyn_files": read(kalyn_files), 48 | "timestamp": datetime.datetime.strptime( 49 | timestamp, "%Y-%m-%d %H:%M:%S %z" 50 | ), 51 | "sha": sha.strip(), 52 | } 53 | ) 54 | 55 | 56 | def combine(k1, k2, k3): 57 | for point in points: 58 | point[k3] = point[k1] + point[k2] 59 | 60 | 61 | def accumulate(key): 62 | total = 0 63 | for point in points: 64 | total += point[key] 65 | point[key + "_total"] = total 66 | 67 | 68 | combine("haskell_loc_added", "kalyn_loc_added", "loc_added") 69 | combine("haskell_loc_removed", "kalyn_loc_removed", "loc_removed") 70 | 71 | 72 | accumulate("loc_added") 73 | accumulate("loc_removed") 74 | 75 | 76 | months = [datetime.date(year=2020, month=n, day=1) for n in range(3, 6)] 77 | midmonths = [datetime.date(year=2020, month=n, day=16) for n in range(3, 6)] 78 | 79 | 80 | def plot(series, title, png): 81 | # https://matplotlib.org/3.1.1/gallery/text_labels_and_annotations/date.html 82 | fig, ax = plt.subplots(figsize=(24, 18)) 83 | t = [p["timestamp"] for p in points] 84 | for key, label, color in series: 85 | y = [p[key] for p in points] 86 | (line,) = ax.plot(t, y, label=label, linewidth=10) 87 | if color: 88 | line.set_color(color) 89 | ax.tick_params(labelsize=40) 90 | ax.xaxis.set_major_formatter(DateFormatter("%b %-d")) 91 | ax.xaxis.set_minor_locator(FixedLocator(list(map(date2num, midmonths)))) 92 | plt.xticks(months) 93 | plt.rc("font", size=40) 94 | plt.legend() 95 | plt.title(title) 96 | plt.grid(True, "both") 97 | plt.savefig(png, transparent=True) 98 | 99 | 100 | plot( 101 | [("haskell_loc", "Haskell", "orange"), ("kalyn_loc", "Kalyn", "purple")], 102 | "Total lines of code", 103 | "loc.png", 104 | ) 105 | plot( 106 | [("haskell_files", "Haskell", "orange"), ("kalyn_files", "Kalyn", "purple")], 107 | "Number of modules", 108 | "files.png", 109 | ) 110 | plot( 111 | [("loc_added_total", "Added", "green"), ("loc_removed_total", "Removed", "red")], 112 | "Added and removed lines of code", 113 | "codefreq.png", 114 | ) 115 | -------------------------------------------------------------------------------- /src-kalyn/Liveness.kalyn: -------------------------------------------------------------------------------- 1 | (import "Assembly.kalyn") 2 | (import "Stdlib.kalyn") 3 | (import "Util.kalyn") 4 | 5 | (public data FnLiveness 6 | (FnLiveness (Set VR) (List (Set VR)))) 7 | 8 | (public alias ProgLiveness 9 | (List (Pair VFunction FnLiveness))) 10 | 11 | (public defn assertNoFreeVariablesF (Func String FnLiveness FnLiveness) 12 | (name analysis@(FnLiveness freeVariables _)) 13 | (if (setNull freeVariables) 14 | analysis 15 | (error (concat 16 | ["in function " 17 | name 18 | ", liveness analysis found free variables: " 19 | (showSet showVR freeVariables) 20 | "\n"])))) 21 | 22 | (public def assertNoFreeVariablesP (Func ProgLiveness ProgLiveness) 23 | (map (lambda ((Pair fn@(Function _ name _) analysis)) 24 | (Pair fn (assertNoFreeVariablesF name analysis))))) 25 | 26 | (public defn computeLiveness (Func (List VInstruction) FnLiveness) 27 | (instrs) 28 | (let ((special (setFromList 29 | compareVR 30 | (map 31 | fromV 32 | specialRegisters))) 33 | (useDefs (map 34 | (comp (both (setFromList compareVR)) 35 | (getRegisters fromV)) 36 | instrs)) 37 | (propagate 38 | (lambda ((Pair _ origLabelLivenesses)) 39 | (foldr 40 | (lambda ((Pair instr (Pair used defined)) 41 | (Pair newLivenesses labelLivenesses)) 42 | (let ((getNextLiveness 43 | (case newLivenesses 44 | (Null Null) 45 | ((Cons liveness _) [liveness]))) 46 | (getLabelLiveness 47 | (lambda (label) 48 | (case (mapLookup label labelLivenesses) 49 | (Nothing []) 50 | ((Just liveness) [liveness])))) 51 | (succLivenesses 52 | (case (getJumpType instr) 53 | (Straightline getNextLiveness) 54 | ((Jump label) (getLabelLiveness label)) 55 | ((Branch label) (append 56 | getNextLiveness 57 | (getLabelLiveness label))) 58 | (Return []))) 59 | (liveOut (setUnions compareVR (map fst succLivenesses))) 60 | (liveIn (set\\ 61 | (setUnion 62 | (set\\ 63 | liveOut 64 | defined) 65 | used) 66 | special)) 67 | (newLiveness (Pair liveIn liveOut))) 68 | (case instr 69 | ((LABEL name) 70 | (Pair 71 | (Cons newLiveness newLivenesses) 72 | (mapInsert name newLiveness labelLivenesses))) 73 | (_ 74 | (Pair 75 | (Cons newLiveness newLivenesses) 76 | labelLivenesses))))) 77 | (Pair [] origLabelLivenesses) 78 | (zip instrs useDefs)))) 79 | ((Pair livenesses _) 80 | (fixedPoint 81 | (lambda ((Pair l1 _) (Pair l2 _)) 82 | (==List 83 | (==Pair 84 | (==Set ==VR) 85 | (==Set ==VR)) 86 | l1 l2)) 87 | (Pair Null (mapEmpty compareString)) 88 | propagate))) 89 | (FnLiveness 90 | (fst (head livenesses)) 91 | (zipWith 92 | (lambda ((Pair liveIn _) (Pair _ defined)) 93 | (setUnion liveIn defined)) 94 | livenesses 95 | useDefs)))) 96 | 97 | (public defn computeProgramLiveness (Func VProgram ProgLiveness) 98 | ((Program mainFn fns _)) 99 | (map 100 | (lambda (fn@(Function _ _ instrs)) 101 | (Pair fn (computeLiveness instrs))) 102 | (Cons mainFn fns))) 103 | -------------------------------------------------------------------------------- /src-kalyn/Bundler.kalyn: -------------------------------------------------------------------------------- 1 | (import "AST.kalyn") 2 | (import "Stdlib.kalyn") 3 | 4 | (defn extractImports (Func 5 | (List Decl) 6 | (Pair 7 | (List (Pair FilePath Bool)) 8 | (List Decl))) 9 | (decls) 10 | (case decls 11 | (Null (Pair Null Null)) 12 | ((Cons (Import pub file) decls) 13 | (let (((Pair files decls*) (extractImports decls))) 14 | (Pair 15 | (Cons (Pair file pub) files) 16 | decls*))) 17 | ((Cons decl decls) 18 | (let (((Pair files decls*) (extractImports decls))) 19 | (Pair 20 | files 21 | (Cons decl decls*)))))) 22 | 23 | (defn readBundle* (Func 24 | (Func String (IO (List Decl))) 25 | (List FilePath) 26 | (List FilePath) 27 | (Map 28 | FilePath 29 | (Pair 30 | (List Decl) 31 | (List (Pair FilePath Bool)))) 32 | (IO (Map 33 | FilePath 34 | (Pair 35 | (List Decl) 36 | (List (Pair FilePath Bool)))))) 37 | (readDecls alreadyRead toRead declsSoFar) 38 | (case toRead 39 | (Null (returnIO declsSoFar)) 40 | ((Cons curToRead restToRead) 41 | (if (elem ==String curToRead alreadyRead) 42 | (readBundle* readDecls alreadyRead restToRead declsSoFar) 43 | (do IO 44 | (with (Pair newToRead newDecls) 45 | (fmapIO extractImports (readDecls curToRead))) 46 | (with absNewToRead 47 | (mapMIO 48 | (lambda ((Pair path pub)) 49 | (do IO 50 | (with curAbsPath (expandPath Nothing curToRead)) 51 | (let workdir (takeDirectory curAbsPath)) 52 | (with absPath (expandPath (Just workdir) path)) 53 | (returnIO (Pair absPath pub)))) 54 | newToRead)) 55 | (readBundle* 56 | readDecls 57 | (Cons curToRead alreadyRead) 58 | (append (map fst absNewToRead) restToRead) 59 | (mapInsert curToRead (Pair newDecls absNewToRead) declsSoFar))))))) 60 | 61 | (defn transitiveImports (Func 62 | (Map 63 | FilePath 64 | (Pair 65 | (List Decl) 66 | (List (Pair FilePath Bool)))) 67 | (Set FilePath) 68 | (Set FilePath) 69 | (Set FilePath) 70 | (Set FilePath)) 71 | (modules seen queue result) 72 | (case (setHead queue) 73 | (Nothing result) 74 | ((Just cur) 75 | (let ((next (setDelete cur queue))) 76 | (if (setMember cur seen) 77 | (transitiveImports modules seen next result) 78 | (let (((Pair _ deps) (map! cur modules)) 79 | (new (map fst (filter snd deps)))) 80 | (transitiveImports 81 | modules 82 | (setInsert cur seen) 83 | (foldr setInsert next new) 84 | (setInsert cur result)))))))) 85 | 86 | (public defn readBundle (Func 87 | (IO Empty) 88 | (Func String (IO (List Decl))) 89 | FilePath 90 | (IO Bundle)) 91 | (onReadFinished readDecls filename) 92 | (do IO 93 | (with absFilename (expandPath Nothing filename)) 94 | (with modules (readBundle* 95 | readDecls [] [absFilename] 96 | (mapEmpty compareString))) 97 | onReadFinished 98 | (returnIO 99 | (Bundle 100 | absFilename 101 | (mapMapWithKey 102 | (lambda (name (Pair decls _)) 103 | (Pair 104 | decls 105 | (setToList 106 | (transitiveImports 107 | modules 108 | (setSingleton compareString name) 109 | (setFromList 110 | compareString 111 | (map fst (snd (map! name modules)))) 112 | (setEmpty compareString))))) 113 | modules))))) 114 | -------------------------------------------------------------------------------- /src/Liveness.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass, DeriveGeneric #-} 2 | 3 | module Liveness 4 | ( InstrLiveness 5 | , Liveness 6 | , ProgramLiveness 7 | , assertNoFreeVariables 8 | , assertNoFreeVariablesP 9 | , computeLiveness 10 | , computeProgramLiveness 11 | , instrDefined 12 | , instrLiveIn 13 | , instrLiveOut 14 | , instrUsed 15 | , showLiveness 16 | ) where 17 | 18 | import Control.DeepSeq 19 | import Data.List 20 | import qualified Data.Map.Strict as Map 21 | import qualified Data.Set as Set 22 | import GHC.Generics 23 | 24 | import Assembly 25 | import Util 26 | 27 | {-# ANN module "HLint: ignore Use tuple-section" #-} 28 | 29 | data InstrLiveness reg = InstrLiveness 30 | { instrLiveIn :: Set.Set reg 31 | , instrLiveOut :: Set.Set reg 32 | , instrUsed :: Set.Set reg 33 | , instrDefined :: Set.Set reg 34 | } 35 | deriving (Eq, Generic, NFData) 36 | 37 | type Liveness reg = [InstrLiveness reg] 38 | type ProgramLiveness reg = [(Function reg, Liveness reg)] 39 | 40 | assertNoFreeVariables :: Show reg => String -> Liveness reg -> Liveness reg 41 | assertNoFreeVariables name analysis = 42 | if Set.null . instrLiveIn . head $ analysis 43 | then analysis 44 | else 45 | error 46 | $ "in function " 47 | ++ show name 48 | ++ ", free variables: " 49 | ++ (show . Set.toList . instrLiveIn . head $ analysis) 50 | 51 | assertNoFreeVariablesP 52 | :: Show reg => ProgramLiveness reg -> ProgramLiveness reg 53 | assertNoFreeVariablesP = map 54 | (\(fn@(Function _ name _), liveness) -> 55 | (fn, assertNoFreeVariables name liveness) 56 | ) 57 | 58 | computeLiveness 59 | :: (Eq reg, Ord reg, RegisterLike reg, Show reg) 60 | => [Instruction reg] 61 | -> Liveness reg 62 | computeLiveness instrs = 63 | let (livenesses, _) = fixedPoint ([], Map.empty) propagate 64 | in zipWith 65 | (\(liveIn, liveOut) (used, defined) -> InstrLiveness 66 | { instrLiveIn = liveIn 67 | , instrLiveOut = liveOut 68 | , instrUsed = used 69 | , instrDefined = defined 70 | } 71 | ) 72 | livenesses 73 | useDefs 74 | where 75 | special = Set.fromList (map fromRegister specialRegisters) 76 | useDefs = map (both Set.fromList . getRegisters) instrs 77 | propagate (_, origLabelLivenesses) = foldr 78 | (\(instr, (used, defined)) (newLivenesses, labelLivenesses) -> 79 | let getNextLiveness = case newLivenesses of 80 | [] -> [] 81 | (liveness : _) -> [liveness] 82 | getLabelLiveness label = case Map.lookup label labelLivenesses of 83 | Nothing -> [] 84 | Just liveness -> [liveness] 85 | succLivenesses = case getJumpType instr of 86 | Straightline -> getNextLiveness 87 | Jump label -> getLabelLiveness label 88 | Branch label -> getNextLiveness ++ getLabelLiveness label 89 | Return -> [] 90 | liveOut = Set.unions (map fst succLivenesses) 91 | liveIn = ((liveOut Set.\\ defined) `Set.union` used) Set.\\ special 92 | newLiveness = (liveIn, liveOut) 93 | in case instr of 94 | LABEL name -> 95 | ( newLiveness : newLivenesses 96 | , Map.insert name newLiveness labelLivenesses 97 | ) 98 | _ -> (newLiveness : newLivenesses, labelLivenesses) 99 | ) 100 | ([], origLabelLivenesses) 101 | (zip instrs useDefs) 102 | 103 | computeProgramLiveness 104 | :: (Eq reg, Ord reg, RegisterLike reg, Show reg) 105 | => Program reg 106 | -> ProgramLiveness reg 107 | computeProgramLiveness (Program mainFn fns _) = 108 | map (\fn@(Function _ _ instrs) -> (fn, computeLiveness instrs)) (mainFn : fns) 109 | 110 | orNone :: String -> String 111 | orNone "" = "(none)" 112 | orNone str = str 113 | 114 | showLiveness 115 | :: (Eq reg, Ord reg, RegisterLike reg, Show reg) 116 | => ProgramLiveness reg 117 | -> String 118 | showLiveness = intercalate "\n" . map 119 | (\((Function _ name instrs), livenesses) -> 120 | ".globl " ++ name ++ "\n" ++ name ++ ":\n" ++ concat 121 | (zipWith 122 | (\instr il -> 123 | "\n;; live IN: " 124 | ++ orNone 125 | (intercalate ", " . map show . Set.toList . instrLiveIn $ il) 126 | ++ "\n;; used: " 127 | ++ orNone 128 | (intercalate ", " . map show . Set.toList . instrUsed $ il) 129 | ++ "\n" 130 | ++ (case instr of 131 | LABEL lname -> lname ++ ":" 132 | _ -> "\t" ++ show instr 133 | ) 134 | ++ "\n;; defined: " 135 | ++ orNone 136 | (intercalate ", " . map show . Set.toList . instrDefined $ il) 137 | ++ "\n;; live OUT: " 138 | ++ orNone 139 | (intercalate ", " . map show . Set.toList . instrLiveOut $ il) 140 | ++ "\n" 141 | ) 142 | instrs 143 | livenesses 144 | ) 145 | ) 146 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.DeepSeq 4 | import Control.Exception 5 | import Control.Monad 6 | import Control.Monad.State 7 | import qualified Data.ByteString.Lazy as B 8 | import Data.List 9 | import Data.Maybe 10 | import qualified Data.Text.Lazy as T 11 | import System.Directory 12 | import System.Environment 13 | import System.FilePath 14 | import System.IO.Error 15 | import System.Posix.Files 16 | import Text.Pretty.Simple ( pShowNoColor ) 17 | 18 | import AST 19 | import OS 20 | import Util 21 | 22 | import Assembler 23 | import Boilerplate 24 | import Bundler 25 | import Lexer 26 | import Linker 27 | import Liveness 28 | import Parser 29 | import Reader 30 | import RegisterAllocator 31 | import Resolver 32 | import Translator 33 | import TypeChecker 34 | 35 | {-# ANN module "HLint: ignore Use tuple-section" #-} 36 | 37 | ignoringDoesNotExist :: IO () -> IO () 38 | ignoringDoesNotExist m = do 39 | res <- try m 40 | case res of 41 | Left err | not . isDoesNotExistError $ err -> ioError err 42 | _ -> return () 43 | 44 | overwriteFile :: FilePath -> String -> IO () 45 | overwriteFile filename str = do 46 | createDirectoryIfMissing True . dropFileName $ filename 47 | ignoringDoesNotExist $ removeLink filename 48 | writeFile filename str 49 | 50 | overwriteBinary :: FilePath -> B.ByteString -> IO () 51 | overwriteBinary filename bin = do 52 | createDirectoryIfMissing True . dropFileName $ filename 53 | ignoringDoesNotExist $ removeLink filename 54 | B.writeFile filename bin 55 | 56 | getPrefix :: String -> String 57 | getPrefix inputFilename = if "/src-kalyn/" `isInfixOf` inputFilename 58 | then dropExtension . T.unpack $ T.replace (T.pack "/src-kalyn/") 59 | (T.pack "/out-kalyn/") 60 | (T.pack inputFilename) 61 | else error $ "Kalyn source file outside src-kalyn: " ++ inputFilename 62 | 63 | readIncrementally :: Bool -> String -> IO [Decl] 64 | readIncrementally verbose inputFilename = do 65 | let prefix = getPrefix inputFilename 66 | str <- readFile inputFilename 67 | putStrLn $ "Lexer (" ++ takeFileName inputFilename ++ ")" 68 | let tokens = tokenize str 69 | when verbose $ overwriteFile (prefix ++ "Tokens") $ concatMap 70 | (\t -> show t ++ "\n") 71 | tokens 72 | tokens `deepseq` putStrLn $ "Reader (" ++ takeFileName inputFilename ++ ")" 73 | let forms = readModule tokens 74 | when verbose $ do 75 | overwriteFile (prefix ++ "Forms") 76 | $ concatMap (\f -> (T.unpack . pShowNoColor $ f) ++ "\n") forms 77 | overwriteFile (prefix ++ "Forms.kalyn") 78 | $ concatMap (\f -> pretty f ++ "\n") forms 79 | forms `deepseq` putStrLn $ "Parser (" ++ takeFileName inputFilename ++ ")" 80 | let decls = parseModule forms 81 | when verbose $ do 82 | overwriteFile (prefix ++ "AST") 83 | $ concatMap (\d -> (T.unpack . pShowNoColor $ d) ++ "\n") decls 84 | overwriteFile (prefix ++ "AST.kalyn") 85 | $ concatMap (\d -> pretty d ++ "\n") decls 86 | decls `deepseq` return decls 87 | 88 | compileIncrementally :: Bool -> String -> IO () 89 | compileIncrementally verbose inputFilename = do 90 | let prefix = getPrefix inputFilename 91 | bundle <- readBundle (putStrLn "Bundler") 92 | (readIncrementally verbose) 93 | inputFilename 94 | when verbose $ do 95 | overwriteFile (prefix ++ "Bundle") $ T.unpack . pShowNoColor $ bundle 96 | overwriteFile (prefix ++ "Bundle.kalyn") $ pretty bundle 97 | bundle `deepseq` putStrLn "Resolver" 98 | let resolver = resolveBundle bundle 99 | when verbose $ overwriteFile (prefix ++ "Resolver") $ pretty resolver 100 | resolver `deepseq` putStrLn "TypeChecker" 101 | let typeChecked = typeCheckBundle resolver bundle 102 | typeChecked `deepseq` putStrLn "Translator" 103 | let (virtualProgram, translatorState) = 104 | flip runState 0 $ translateBundle resolver bundle 105 | when verbose $ overwriteFile (prefix ++ "Virtual.S") $ show virtualProgram 106 | virtualProgram `deepseq` putStrLn "Liveness" 107 | let liveness = computeProgramLiveness virtualProgram 108 | when verbose $ overwriteFile (prefix ++ "Liveness.S") $ showLiveness liveness 109 | liveness `deepseq` putStrLn "RegisterAllocator" 110 | let info@(physicalProgram, allocation, spilled) = 111 | flip evalState translatorState 112 | $ allocateProgramRegs virtualProgram (assertNoFreeVariablesP liveness) 113 | when verbose $ do 114 | overwriteFile (prefix ++ "Raw.S") $ show physicalProgram 115 | overwriteFile (prefix ++ "Allocation") $ showAllocation allocation spilled 116 | info `deepseq` putStrLn "Boilerplate" 117 | let physicalProgram' = addProgramBoilerplate physicalProgram 118 | when verbose $ overwriteFile (prefix ++ ".S") $ show physicalProgram' 119 | physicalProgram' `deepseq` putStrLn "Assembler" 120 | let assembled@(codeB, dataB, _, _) = assemble physicalProgram' 121 | when verbose $ overwriteBinary 122 | (prefix ++ ".o") 123 | ( codeB 124 | <> B.pack 125 | (replicate (leftover pageSize (fromIntegral $ B.length codeB)) 0) 126 | <> dataB 127 | ) 128 | assembled `deepseq` putStrLn "Linker" 129 | let binary = link assembled 130 | overwriteBinary prefix binary 131 | setFileMode prefix 0o755 132 | 133 | main :: IO () 134 | main = do 135 | args <- getArgs 136 | env <- lookupEnv "VERBOSE" 137 | let verbose = "-v" `elem` args || "--verbose" `elem` args || isJust 138 | (not . null <$> env) 139 | compileIncrementally verbose "./src-kalyn/Main.kalyn" 140 | -------------------------------------------------------------------------------- /src/Bridge.hs: -------------------------------------------------------------------------------- 1 | module Bridge 2 | ( stdlibPublic 3 | , stdlibFns 4 | , stdlibData 5 | ) where 6 | 7 | import qualified Data.Map as Map 8 | import qualified Data.Set as Set 9 | 10 | import AST 11 | import Assembly 12 | import MemoryManager 13 | import Primitives 14 | import Subroutines 15 | 16 | {-# ANN module "HLint: ignore Use lambda-case" #-} 17 | 18 | handleCurried 19 | :: Int 20 | -> String 21 | -> Stateful VirtualFunction 22 | -> Type 23 | -> (String, Stateful [VirtualFunction], Type, Int) 24 | handleCurried n name fn ty = (name, (:) <$> fn <*> curryify n name, ty, n) 25 | 26 | handleM 27 | :: String 28 | -> Stateful VirtualFunction 29 | -> Type 30 | -> (String, Stateful [VirtualFunction], Type, Int) 31 | handleM name fn ty = 32 | ( name 33 | , do 34 | core <- fn 35 | monadified <- monadify 0 name 36 | return [core, monadified] 37 | , ty 38 | , 0 39 | ) 40 | 41 | handleCurriedM 42 | :: Int 43 | -> String 44 | -> Stateful VirtualFunction 45 | -> Type 46 | -> (String, Stateful [VirtualFunction], Type, Int) 47 | handleCurriedM n name fn ty = 48 | ( name 49 | , do 50 | core <- fn 51 | monadified <- monadify n (name ++ "__uncurried") 52 | curried <- curryify n name 53 | return ([core, monadified] ++ curried) 54 | , ty 55 | , n 56 | ) 57 | 58 | baseType :: TypeName -> Type 59 | baseType name = Type [] name [] 60 | 61 | funcType' :: [Type] -> Type 62 | funcType' [] = error "can't construct empty function type" 63 | funcType' [ty ] = ty 64 | funcType' (ty : tys) = Type [] "Func" [ty, funcType' tys] 65 | 66 | funcType :: [TypeName] -> Type 67 | funcType = funcType' . map baseType 68 | 69 | ioType :: TypeName -> Type 70 | ioType name = Type [] "IO" [Type [] name []] 71 | 72 | stdlibPublic :: Map.Map String (String, Stateful [VirtualFunction], Type, Int) 73 | stdlibPublic = Map.fromList 74 | [ ("+" , handleCurried 2 "plus" plus $ funcType ["Int", "Int", "Int"]) 75 | , ("-" , handleCurried 2 "minus" minus $ funcType ["Int", "Int", "Int"]) 76 | , ("*" , handleCurried 2 "times" times $ funcType ["Int", "Int", "Int"]) 77 | , ("/" , handleCurried 2 "divide" divide $ funcType ["Int", "Int", "Int"]) 78 | , ("%" , handleCurried 2 "modulo" modulo $ funcType ["Int", "Int", "Int"]) 79 | , ("&" , handleCurried 2 "and" bitAnd $ funcType ["Int", "Int", "Int"]) 80 | , ("|" , handleCurried 2 "or" bitOr $ funcType ["Int", "Int", "Int"]) 81 | , ("^" , handleCurried 2 "xor" xor $ funcType ["Int", "Int", "Int"]) 82 | , ("~" , handleCurried 1 "not" bitNot $ funcType ["Int", "Int"]) 83 | , ("shl", handleCurried 2 "shl" shl $ funcType ["Int", "Int", "Int"]) 84 | , ("shr", handleCurried 2 "shr" shr $ funcType ["Int", "Int", "Int"]) 85 | , ("sal", handleCurried 2 "sal" sal $ funcType ["Int", "Int", "Int"]) 86 | , ("sar", handleCurried 2 "sar" sar $ funcType ["Int", "Int", "Int"]) 87 | , ( "print" 88 | , handleCurriedM 1 "print" monadPrint 89 | $ funcType' [baseType "String", ioType "Empty"] 90 | ) 91 | , ( "writeFile" 92 | , handleCurriedM 2 "writeFile" monadWriteFile 93 | $ funcType' [baseType "FilePath", baseType "String", ioType "Empty"] 94 | ) 95 | , ( "setFileMode" 96 | , handleCurriedM 2 "setFileMode" setFileMode 97 | $ funcType' [baseType "FilePath", baseType "Int", ioType "Empty"] 98 | ) 99 | , ( "getWorkingDirectory" 100 | , handleM "getWorkingDirectory" monadGetWorkingDirectory (ioType "FilePath") 101 | ) 102 | , ( "readFile" 103 | , handleCurriedM 1 104 | "readFile" 105 | monadReadFile 106 | (funcType' [baseType "FilePath", ioType "String"]) 107 | ) 108 | , ("error", handleCurried 1 "error" primitiveError $ funcType ["String", "a"]) 109 | , ("==Int", handleCurried 2 "equal" equal $ funcType ["Int", "Int", "Bool"]) 110 | , ( "/=Int" 111 | , handleCurried 2 "notEqual" notEqual $ funcType ["Int", "Int", "Bool"] 112 | ) 113 | , ( "Int" 121 | , handleCurried 2 "greaterThan" greaterThan 122 | $ funcType ["Int", "Int", "Bool"] 123 | ) 124 | , ( ">=Int" 125 | , handleCurried 2 "greaterThanEqual" greaterThanEqual 126 | $ funcType ["Int", "Int", "Bool"] 127 | ) 128 | , ( "returnIO" 129 | , handleCurriedM 1 "return" monadReturn 130 | $ funcType' [baseType "a", ioType "a"] 131 | ) 132 | , ( ">>=IO" 133 | , handleCurriedM 2 "bind" monadBind 134 | $ funcType' [ioType "a", funcType' [baseType "a", ioType "b"], ioType "b"] 135 | ) 136 | , ( "trace" 137 | , handleCurried 2 "trace" primitiveTrace $ funcType ["String", "a", "a"] 138 | ) 139 | ] 140 | 141 | stdlibPrivate :: [Stateful VirtualFunction] 142 | stdlibPrivate = 143 | [memoryInit, memoryAlloc, packString, unpackString, primitiveCrash] 144 | 145 | getCalls :: VirtualFunction -> Set.Set String 146 | getCalls (Function _ _ instrs) = Set.fromList $ concatMap 147 | (\instr -> case instr of 148 | JUMP CALL label -> [label] 149 | _ -> [] 150 | ) 151 | instrs 152 | 153 | stdlibFns :: [VirtualFunction] -> Stateful [VirtualFunction] 154 | stdlibFns userFns = do 155 | let calls = Set.unions . map getCalls $ userFns 156 | allPublic <- mapM (\(_, fns, _, _) -> fns) . Map.elems $ stdlibPublic 157 | let public = 158 | concat 159 | . filter (any (\(Function _ fnName _) -> Set.member fnName calls)) 160 | $ allPublic 161 | private <- sequence stdlibPrivate 162 | return $ public ++ private 163 | 164 | stdlibData :: [Datum] 165 | stdlibData = [memoryFirstFree, memoryProgramBreak, syscallBuffer] ++ msgDatums 166 | -------------------------------------------------------------------------------- /src-kalyn/MemoryManager.kalyn: -------------------------------------------------------------------------------- 1 | (import "Assembly.kalyn") 2 | (import "OS.kalyn") 3 | (import "Stdlib.kalyn") 4 | (import "Subroutines.kalyn") 5 | (import "Util.kalyn") 6 | 7 | (public def memoryFirstFree Datum 8 | (Pair "mmFirstFree" (word64 0))) 9 | 10 | (public def memoryProgramBreak Datum 11 | (Pair "mmProgramBreak" (word64 0))) 12 | 13 | (public def memoryInit (Stateful VFunction) 14 | (returnState 15 | (function 16 | "memoryInit" 17 | [(OP MOV (IR 12 rax)) 18 | (OP MOV (IR 0 rdi)) 19 | (SYSCALL 1) ; brk 20 | (OP MOV (RM rax (memLabelV (fst memoryProgramBreak)))) 21 | (OP MOV (RM rax (memLabelV (fst memoryFirstFree)))) 22 | RET]))) 23 | 24 | (public def memoryAlloc (Stateful VFunction) 25 | (do State 26 | (with firstFree newTemp) 27 | (with ptr newTemp) 28 | (with brk newLabel) 29 | (with done newLabel) 30 | (with crash newLabel) 31 | (with msg newTemp) 32 | (returnState 33 | (function 34 | "memoryAlloc" 35 | [(OP MOV (MR (memLabelV "mmFirstFree") firstFree)) 36 | ;; round up to nearest multiple of eight (see) 37 | ;; 38 | (OP ADD (IR 7 firstFree)) 39 | (OP AND (IR (-8) firstFree)) 40 | ;; now to proceed 41 | (OP MOV (RR firstFree ptr)) 42 | (OP ADD (MR (getArg 1) firstFree)) 43 | (OP MOV (RM firstFree (memLabelV "mmFirstFree"))) 44 | (OP CMP (MR (memLabelV "mmProgramBreak") firstFree)) 45 | (JUMP JG brk) 46 | (LABEL done) 47 | (OP MOV (RR ptr rax)) 48 | RET 49 | (LABEL brk) 50 | ;; round up to next page boundary 51 | (OP ADD (IR (- pageSize 1) firstFree)) 52 | (OP AND (IR (- 0 pageSize) firstFree)) 53 | ;; reserve 1000 more pages while we're at it 54 | (OP ADD (IR (* pageSize 1000) firstFree)) 55 | (OP MOV (IR 12 rax)) 56 | (OP MOV (RR firstFree rdi)) 57 | (SYSCALL 1) ; brk 58 | (OP CMP (RR firstFree rax)) 59 | (JUMP JL crash) 60 | (OP MOV (RM rax (memLabelV "mmProgramBreak"))) 61 | (JUMP JMP done) 62 | (LABEL crash) 63 | (LEA (memLabelV "msgMemoryAllocFailed") msg) 64 | (UN PUSH (R msg)) 65 | (JUMP CALL "crash")])))) 66 | 67 | (public def packString (Stateful VFunction) 68 | (do State 69 | (with arg newTemp) 70 | (with ptr newTemp) 71 | (with strLength newTemp) 72 | (with allocLength newTemp) 73 | (with result newTemp) 74 | (with mptr newTemp) 75 | (with temp newTemp) 76 | (with zero newTemp) 77 | (with lengthStart newLabel) 78 | (with lengthDone newLabel) 79 | (with copyStart newLabel) 80 | (with copyDone newLabel) 81 | (returnState 82 | (function 83 | "packString" 84 | [(OP MOV (MR (getArg 1) arg)) 85 | (OP MOV (IR 0 strLength)) 86 | (OP MOV (RR arg ptr)) 87 | (LABEL lengthStart) 88 | (OP CMP (IM 0 (getField 0 ptr))) 89 | (JUMP JE lengthDone) 90 | (UN INC (R strLength)) 91 | (OP MOV (MR (getField 2 ptr) ptr)) 92 | (JUMP JMP lengthStart) 93 | (LABEL lengthDone) 94 | (LEA (Mem (Right 9) strLength Nothing) allocLength) 95 | (UN PUSH (R allocLength)) 96 | (JUMP CALL "memoryAlloc") 97 | (unpush 1) 98 | (OP MOV (RR rax result)) 99 | (OP MOV (RM strLength (deref rax))) 100 | (LEA (getField 1 rax) mptr) 101 | (OP MOV (RR arg ptr)) 102 | (LABEL copyStart) 103 | (OP CMP (IM 0 (getField 0 ptr))) 104 | (JUMP JE copyDone) 105 | (OP MOV (MR (getField 1 ptr) temp)) 106 | (MOVBRM temp (deref mptr)) 107 | (OP MOV (MR (getField 2 ptr) ptr)) 108 | (UN INC (R mptr)) 109 | (JUMP JMP copyStart) 110 | (LABEL copyDone) 111 | (OP MOV (IR 0 zero)) 112 | (MOVBRM zero (deref mptr)) 113 | (OP MOV (RR result rax)) 114 | RET])))) 115 | 116 | (public def unpackString (Stateful VFunction) 117 | (do State 118 | (with str newTemp) 119 | (with strptr newTemp) 120 | (with allocSize newTemp) 121 | (with retval newTemp) 122 | (with bufPtr newTemp) 123 | (with lstPtr newTemp) 124 | (with lstEnd newTemp) 125 | (with char newTemp) 126 | (with next newTemp) 127 | (with lenStart newLabel) 128 | (with lenDone newLabel) 129 | (with copyStart newLabel) 130 | (with copyDone newLabel) 131 | (returnState 132 | (function 133 | "unpackString" 134 | [(OP MOV (MR (getArg 2) str)) 135 | (OP MOV (MR (getArg 1) allocSize)) 136 | (OP CMP (IR 0 allocSize)) 137 | (JUMP JGE lenDone) 138 | (OP MOV (RR str strptr)) 139 | (OP MOV (IR 0 allocSize)) 140 | (LABEL lenStart) 141 | (OP CMP (IM 0 (deref strptr))) 142 | (JUMP JE lenDone) 143 | (UN INC (R allocSize)) 144 | (UN INC (R strptr)) 145 | (LABEL lenDone) 146 | (OP IMUL (IR 24 allocSize)) 147 | (OP ADD (IR 8 allocSize)) 148 | (UN PUSH (R allocSize)) 149 | (JUMP CALL "memoryAlloc") 150 | (unpush 1) 151 | (OP MOV (RR rax retval)) 152 | (OP MOV (RR str bufPtr)) 153 | (OP MOV (RR rax lstPtr)) 154 | (LEA (Mem (Right -8) lstPtr 155 | (Just (Pair Scale1 allocSize))) 156 | lstEnd) 157 | (LABEL copyStart) 158 | (OP CMP (RR lstEnd lstPtr)) 159 | (JUMP JGE copyDone) 160 | (OP MOV (IM 1 (getField 0 lstPtr))) 161 | (OP MOV (IR 0 char)) 162 | (MOVBMR (deref bufPtr) char) 163 | (OP MOV (RM char (getField 1 lstPtr))) 164 | (LEA (getField 3 lstPtr) next) 165 | (OP MOV (RM next (getField 2 lstPtr))) 166 | (UN INC (R bufPtr)) 167 | (OP ADD (IR 24 lstPtr)) 168 | (JUMP JMP copyStart) 169 | (LABEL copyDone) 170 | (OP MOV (IM 0 (deref lstPtr))) 171 | (OP MOV (RR retval rax)) 172 | RET])))) 173 | -------------------------------------------------------------------------------- /src-kalyn/Subroutines.kalyn: -------------------------------------------------------------------------------- 1 | (import "Assembly.kalyn") 2 | (import "OS.kalyn") 3 | (import "Stdlib.kalyn") 4 | (import "Util.kalyn") 5 | 6 | (public defn getOffset (Func Int reg (Mem reg)) 7 | (n reg) 8 | (Mem (Right n) reg Nothing)) 9 | 10 | (public defn getField (Func Int reg (Mem reg)) 11 | (n) 12 | (getOffset (* 8 n))) 13 | 14 | (public def deref (Func reg (Mem reg)) 15 | (getField 0)) 16 | 17 | (public defn getSum (Func reg reg (Mem reg)) 18 | (reg1 reg2) 19 | (Mem (Right 0) reg1 (Just (Pair Scale1 reg2)))) 20 | 21 | (public defn unpush (Func Int VInstruction) 22 | (n) 23 | (OP ADD (IR (* 8 n) rsp))) 24 | 25 | (public defn getArg (Func Int (Mem VR)) 26 | (n) 27 | (getField (+ n 1) rbp)) 28 | 29 | (public defn translateCall (Func VR (Maybe VR) (Stateful (List VInstruction))) 30 | (lhsTemp rhsTemp) 31 | (do State 32 | (with argPtr newTemp ) 33 | (with argsLeft newTemp ) 34 | (with popAmt newTemp ) 35 | (with pushStart newLabel) 36 | (with pushDone newLabel) 37 | (returnState 38 | (concat 39 | [[(OP MOV (MR (getField 1 lhsTemp) argsLeft)) 40 | (LEA (getField 2 lhsTemp) argPtr) 41 | (LABEL pushStart) 42 | (OP CMP (IR 0 argsLeft)) 43 | (JUMP JLE pushDone) 44 | (UN PUSH (M (deref argPtr))) 45 | (OP ADD (IR 8 argPtr)) 46 | (UN DEC (R argsLeft)) 47 | (JUMP JMP pushStart) 48 | (LABEL pushDone)] 49 | (case rhsTemp 50 | (Nothing []) 51 | ((Just temp) [(UN PUSH (R temp))])) 52 | [(UN ICALL (M (getField 0 lhsTemp))) 53 | (OP MOV (MR (getField 1 lhsTemp) popAmt)) 54 | (LEA 55 | (Mem 56 | (Right (case rhsTemp 57 | (Nothing 0) 58 | ((Just _) 8))) 59 | rsp 60 | (Just (Pair Scale8 popAmt))) 61 | rsp)]])))) 62 | 63 | (public defn curryify (Func Int String (Stateful (List VFunction))) 64 | (numArgs fnName) 65 | (do State 66 | (if (>=Int numArgs 1) 67 | (returnState Empty) 68 | (error "can't curry a function with no arguments")) 69 | (with topFn 70 | (do State 71 | (with fnPtr newTemp) 72 | (with nextFnPtr newTemp) 73 | (returnState 74 | (function 75 | fnName 76 | [(PUSHI 16) 77 | (JUMP CALL "memoryAlloc") 78 | (unpush 1) 79 | (OP MOV (RR rax fnPtr)) 80 | (LEA 81 | (memLabelV 82 | (append fnName 83 | (if (>=Int numArgs 2) 84 | "__curried0" 85 | "__uncurried"))) 86 | nextFnPtr) 87 | (OP MOV (RM nextFnPtr (getField 0 fnPtr))) 88 | (OP MOV (IM 0 (getField 1 fnPtr))) 89 | (OP MOV (RR fnPtr rax)) 90 | RET])))) 91 | (with subFns 92 | (mapMState 93 | (lambda (numCurried) 94 | (do State 95 | (with fnPtr (newTemp)) 96 | (with nextFnPtr (newTemp)) 97 | (with arg (newTemp)) 98 | (let curFnName (concat 99 | [fnName 100 | "__curried" 101 | (showInt numCurried)])) 102 | (let nextFnName (if (==Int numCurried (- numArgs 2)) 103 | (append fnName "__uncurried") 104 | (concat [fnName 105 | "__curried" 106 | (showInt (+ numCurried 1))]))) 107 | (returnState (function 108 | curFnName 109 | (concat [[(PUSHI (* 8 (+ 3 numCurried))) 110 | (JUMP CALL "memoryAlloc") 111 | (unpush 1) 112 | (OP MOV (RR rax fnPtr)) 113 | (LEA (memLabelV nextFnName) nextFnPtr) 114 | (OP MOV (RM nextFnPtr (getField 0 fnPtr))) 115 | (OP MOV (IM (+ 1 numCurried) (getField 1 fnPtr)))] 116 | (concatMap 117 | (lambda (i) 118 | [(OP MOV (MR (getArg (- (+ numCurried 2) i)) arg)) 119 | (OP MOV (RM arg (getField (+ i 1) fnPtr)))]) 120 | (iterate (+ 1) 1 (+ numCurried 1))) 121 | [(OP MOV (RR fnPtr rax)) RET]]))))) 122 | (iterate (+ 1) 0 (- numArgs 1)))) 123 | (returnState (reverse (Cons topFn subFns))))) 124 | 125 | (public defn monadify (Func Int String (Stateful VFunction)) 126 | (numArgs fnName) 127 | (do State 128 | (with fnPtr newTemp) 129 | (with arg newTemp) 130 | (returnState 131 | (function 132 | fnName 133 | (concat 134 | [[(PUSHI (* 8 (+ 2 numArgs))) 135 | (JUMP CALL "memoryAlloc") 136 | (unpush 1) 137 | (LEA (memLabelV (append fnName "__unmonadified")) fnPtr) 138 | (OP MOV (RM fnPtr (getField 0 rax))) 139 | (OP MOV (IM numArgs (getField 1 rax)))] 140 | (concatMap 141 | (lambda (i) 142 | [(OP MOV (MR (getArg (- (+ numArgs 1) i)) arg)) 143 | (OP MOV (RM arg (getField (+ i 1) rax)))]) 144 | (iterate (+ 1) 1 numArgs)) 145 | [RET]]))))) 146 | 147 | (defn packMsg (Func String Bytes) 148 | (str) 149 | (append (word64 (length str)) str)) 150 | 151 | (public def msgDatums (List Datum) 152 | [(Pair "msgPatternMatchFailed" (packMsg "pattern match failed\n")) 153 | (Pair "msgMemoryAllocFailed" (packMsg "memoryAlloc failed\n")) 154 | (Pair "msgWriteFileFailed" (packMsg "writeFile failed\n")) 155 | (Pair "msgSetFileModeFailed" (packMsg "setFileMode failed\n")) 156 | (Pair "msgReadFileFailed" (packMsg "readFile failed\n")) 157 | (Pair "msgGetWorkingDirectoryFailed" (packMsg "getWorkingDirectory failed\n"))]) 158 | 159 | (public def syscallBuffer Datum 160 | (Pair "syscallBuffer" (replicate syscallBufferSize (Char 0)))) 161 | -------------------------------------------------------------------------------- /src-kalyn/Instances/Show.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (import "../Assembly.kalyn") 4 | (import "../Tokens.kalyn") 5 | 6 | (public defn showRegister (Show Register) 7 | (reg) 8 | (case reg 9 | (RAX "%rax") 10 | (RCX "%rcx") 11 | (RDX "%rdx") 12 | (RBX "%rbx") 13 | (RSP "%rsp") 14 | (RBP "%rbp") 15 | (RSI "%rsi") 16 | (RDI "%rdi") 17 | (R8 "%r8") 18 | (R9 "%r9") 19 | (R10 "%r10") 20 | (R11 "%r11") 21 | (R12 "%r12") 22 | (R13 "%r13") 23 | (R14 "%r14") 24 | (R15 "%r15") 25 | (RIP "%rip"))) 26 | 27 | (public defn showTemporary (Show Temporary) 28 | ((Temporary num)) 29 | (append "%t" (showInt num))) 30 | 31 | (public defn showVR (Show VR) 32 | (reg) 33 | (case reg 34 | ((Physical phys) (showRegister phys)) 35 | ((Virtual temp) (showTemporary temp)))) 36 | 37 | (public defn showScale (Show Scale) 38 | (scale) 39 | (case scale 40 | (Scale1 "1") 41 | (Scale2 "2") 42 | (Scale4 "4") 43 | (Scale8 "8"))) 44 | 45 | (public defn showMem (Func (Show reg) (Show (Mem reg))) 46 | (showReg (Mem disp base msi)) 47 | (concat 48 | [(case disp 49 | ((Left label) label) 50 | ((Right 0) "") 51 | ((Right imm) (showInt imm))) 52 | "(" 53 | (showReg base) 54 | (case msi 55 | (Nothing "") 56 | ((Just (Pair Scale1 index)) (append ", " (showReg index))) 57 | ((Just (Pair scale index)) (concat [", " (showReg index) ", " (showScale scale)]))) 58 | ")"])) 59 | 60 | (public defn showArgs (Func (Show reg) (Show (Args reg))) 61 | (showReg args) 62 | (case args 63 | ((IR imm reg) (concat ["$" (showInt imm) ", " (showReg reg)])) 64 | ((IM imm mem) (concat ["$" (showInt imm) ", " (showMem showReg mem)])) 65 | ((RR src dst) (concat [(showReg src) ", " (showReg dst)])) 66 | ((MR mem reg) (concat [(showMem showReg mem) ", " (showReg reg)])) 67 | ((RM reg mem) (concat [(showReg reg) ", " (showMem showReg mem)])))) 68 | 69 | (public defn showArg (Func (Show reg) (Show (Arg reg))) 70 | (showReg arg) 71 | (case arg 72 | ((R reg) (showReg reg)) 73 | ((M mem) (showMem showReg mem)))) 74 | 75 | (public defn showBinOp (Show BinOp) 76 | (op) 77 | (case op 78 | (MOV "movq") 79 | (ADD "addq") 80 | (SUB "subq") 81 | (IMUL "imulq") 82 | (AND "andq") 83 | (OR "orq") 84 | (XOR "xorq") 85 | (CMP "cmpq"))) 86 | 87 | (public defn showUnOp (Show UnOp) 88 | (op) 89 | (case op 90 | (NOT "not") 91 | (NEG "neg") 92 | (INC "inc") 93 | (DEC "dec") 94 | (PUSH "pushq") 95 | (POP "popq") 96 | (ICALL "callq"))) 97 | 98 | (public defn showJump (Show Jump) 99 | (op) 100 | (case op 101 | (JMP "jmp") 102 | (JE "je") 103 | (JNE "jne") 104 | (JL "jl") 105 | (JLE "jle") 106 | (JG "jg") 107 | (JGE "jge") 108 | (JB "jb") 109 | (JBE "jbe") 110 | (JA "ja") 111 | (JAE "jae") 112 | (CALL "callq"))) 113 | 114 | (public defn showShift (Show Shift) 115 | (op) 116 | (case op 117 | (SHL "shl") 118 | (SAL "sal") 119 | (SHR "shr") 120 | (SAR "sar"))) 121 | 122 | (public defn showInstruction (Func (Show reg) (Show (Instruction reg))) 123 | (showReg instr) 124 | (case instr 125 | ((OP op args) (concat [(showBinOp op) " " (showArgs showReg args)])) 126 | ((UN ICALL arg) (concat [(showUnOp ICALL) " *" (showArg showReg arg)])) 127 | ((UN op arg) (concat [(showUnOp op) " " (showArg showReg arg)])) 128 | ((JUMP op label) (concat [(showJump op) " " label])) 129 | ((MOVBRM src mem) (concat ["movb " (showReg src) ", " (showMem showReg mem)])) 130 | ((MOVBMR mem dst) (concat ["movb " (showMem showReg mem) ", " (showReg dst)])) 131 | ((MOV64 imm dst) (concat ["movq $" (showInt imm) ", " (showReg dst)])) 132 | ((SHIFT amt shift dst) (concat 133 | [(showShift shift) 134 | " " 135 | (case amt 136 | (Nothing "%cx") 137 | ((Just val) 138 | (append "$" (showInt val)))) 139 | ", " 140 | (showReg dst)])) 141 | ((LEA src dst) (concat ["leaq " (showMem showReg src) ", " (showReg dst)])) 142 | ((IDIV src) (append "idivq " (showReg src))) 143 | (CQTO "cqto") 144 | ((PUSHI imm) (append "pushq $" (showInt imm))) 145 | (RET "retq") 146 | ((SYSCALL _) "syscall") 147 | ((LABEL name) (append name ":")) 148 | ((GLOBAL name) (append name ":")))) 149 | 150 | (public defn showFunction (Func (Show reg) (Show (Function reg))) 151 | (showReg fn) 152 | (concatMap 153 | (lambda (instr) 154 | (append 155 | (case instr 156 | ((LABEL lname) (append lname ":")) 157 | ((GLOBAL sname) 158 | (concat 159 | [".globl " 160 | sname 161 | "\n" 162 | sname 163 | ":"])) 164 | (_ (append "\t" (showInstruction showReg instr)))) 165 | "\n")) 166 | (fnInstrs fn))) 167 | 168 | (public defn showProgram (Func (Show reg) (Show (Program reg))) 169 | (showReg (Program mainFn fns datums)) 170 | (concat 171 | [".text\n" 172 | (showFunction showReg mainFn) 173 | (concatMap (showFunction showReg) fns) 174 | ".data\n" 175 | (concat 176 | (map 177 | (lambda ((Pair label datum)) 178 | (concat 179 | [label 180 | ":\n" 181 | (concatMap 182 | (lambda ((Char c)) 183 | (concat 184 | ["\t.byte " 185 | (showInt c) 186 | "\n"])) 187 | datum)])) 188 | datums))])) 189 | 190 | (public defn showForm (Show Form) 191 | (form) 192 | (case form 193 | ((RoundList args) 194 | (concat ["(" (intercalate " " (map showForm args)) ")"])) 195 | ((SquareList args) 196 | (concat ["[" (intercalate " " (map showForm args)) "]"])) 197 | ((At name arg) 198 | (concat [name "@" (showForm arg)])) 199 | ((Symbol name) 200 | name) 201 | ((IntAtom val) 202 | (showInt val)) 203 | ((CharAtom c) 204 | ['\'' c '\'']) 205 | ((StrAtom str) 206 | (concat ["|" str "|"])))) 207 | -------------------------------------------------------------------------------- /kalyn-mode.el: -------------------------------------------------------------------------------- 1 | ;;; kalyn-mode.el --- Major mode for Kalyn -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (C) 2020-2022 Radian LLC and contributors 4 | 5 | ;; Author: Radian LLC 6 | ;; Created: 25 Feb 2020 7 | ;; Keywords: languages 8 | ;; Package-Requires: ((emacs "27")) 9 | ;; Version: 0 10 | 11 | ;;; Commentary: 12 | 13 | ;; Major mode for editing Kalyn source code. 14 | 15 | ;;; Code: 16 | 17 | (defvar kalyn--declaration-builtins 18 | '("alias" "class" "data" "defn" "def" "derive" "import" "instance" "public" "with")) 19 | 20 | (defvar kalyn--special-form-builtins 21 | '("and" "case" "do" "if" "lambda" "let" "or")) 22 | 23 | (defvar kalyn--functionlike-builtins 24 | '("and" "or")) 25 | 26 | (defun kalyn--builtins () 27 | (append kalyn--declaration-builtins kalyn--special-form-builtins)) 28 | 29 | (defun kalyn--column-at (pos) 30 | (save-excursion 31 | (goto-char pos) 32 | (current-column))) 33 | 34 | (defun kalyn--next-sexp (pos &optional n) 35 | (when-let ((end (condition-case _ 36 | (scan-sexps pos (or n 1)) 37 | (scan-error)))) 38 | (let ((start (scan-sexps end -1))) 39 | (buffer-substring start end)))) 40 | 41 | (defun kalyn--on-same-line-p (start end) 42 | (= (save-excursion 43 | (goto-char start) 44 | (point-at-bol)) 45 | (save-excursion 46 | (goto-char end) 47 | (point-at-bol)))) 48 | 49 | (defun kalyn--index-from (start) 50 | (let (;; indexed from 1 because of how the counting works 51 | (index 0) 52 | (cur start)) 53 | (condition-case _ 54 | (while (< cur (point)) 55 | (setq cur (scan-sexps cur 1)) 56 | (cl-incf index)) 57 | (scan-error)) 58 | index)) 59 | 60 | (defun kalyn--indent-function (indent-point state) 61 | (cl-block nil 62 | (unless (nth 1 state) 63 | (cl-return 0)) 64 | (let* ((list-start (1+ (nth 1 state))) 65 | (first-sexp-end 66 | (condition-case _ 67 | (scan-sexps list-start 1) 68 | (scan-error))) 69 | (second-sexp-end 70 | (condition-case _ 71 | (scan-sexps list-start 2) 72 | (scan-error))) 73 | (second-sexp-start 74 | (when second-sexp-end 75 | (scan-sexps second-sexp-end -1))) 76 | (first-sexp (kalyn--next-sexp list-start)) 77 | (second-sexp-on-same-line-p 78 | (and first-sexp-end 79 | second-sexp-start 80 | (kalyn--on-same-line-p first-sexp-end second-sexp-start))) 81 | (square-p (= (char-before list-start) ?\[)) 82 | (starting-column (kalyn--column-at list-start)) 83 | (outer-list-start 84 | (when-let ((pos (car (last (nth 9 state) 2)))) 85 | (1+ pos))) 86 | (next-outer-list-start 87 | (when-let ((pos (car (last (nth 9 state) 3)))) 88 | (1+ pos))) 89 | (first-outer-sexp (kalyn--next-sexp outer-list-start)) 90 | (next-first-outer-sexp (kalyn--next-sexp next-outer-list-start)) 91 | (index (when next-outer-list-start 92 | (kalyn--index-from next-outer-list-start)))) 93 | (cond 94 | ;; [foo 95 | ;; bar] 96 | (square-p 97 | starting-column) 98 | ;; (case (foo 99 | ;; bar)) 100 | ((equal first-outer-sexp "case") 101 | starting-column) 102 | ;; (let ((foo 103 | ;; bar))) 104 | ((and (equal next-first-outer-sexp "let") 105 | (eq index 2)) 106 | starting-column) 107 | ;; ((foo) 108 | ;; bar) 109 | ;; 110 | ;; ( foo 111 | ;; bar) 112 | ((not (memq (car (syntax-after list-start)) '(2 3))) 113 | starting-column) 114 | ;; (let bar 115 | ;; baz) 116 | ((and (member first-sexp (kalyn--builtins)) 117 | (not (member first-sexp kalyn--functionlike-builtins))) 118 | (1+ starting-column)) 119 | ;; (foo bar 120 | ;; baz) 121 | (second-sexp-on-same-line-p 122 | (kalyn--column-at second-sexp-start)) 123 | ;; (foo 124 | ;; bar) 125 | (t 126 | (1+ starting-column)))))) 127 | 128 | (defun kalyn--font-lock-syntactic-face-function (state) 129 | (if (not (nth 3 state)) 130 | 'font-lock-comment-face 131 | (let* ((outer-list-start 132 | (when-let ((pos (car (last (nth 9 state) 1)))) 133 | (1+ pos))) 134 | (first-sexp 135 | (when outer-list-start 136 | (kalyn--next-sexp outer-list-start))) 137 | (second-sexp 138 | (when outer-list-start 139 | (kalyn--next-sexp outer-list-start 2))) 140 | (index (when outer-list-start 141 | (kalyn--index-from outer-list-start)))) 142 | (when outer-list-start 143 | (when (equal first-sexp "public") 144 | (cl-decf index) 145 | (setq first-sexp second-sexp))) 146 | (if (or 147 | (and (equal first-sexp "alias") (eq index 3)) 148 | (and (equal first-sexp "data") (eq index 3)) 149 | (and (equal first-sexp "def") (eq index 4)) 150 | (and (equal first-sexp "defn") (eq index 4))) 151 | 'font-lock-doc-face 152 | 'font-lock-string-face)))) 153 | 154 | (defun kalyn--font-lock-keywords () 155 | (list (list (format "\\_<\\(%s\\)\\_>" 156 | (mapconcat 157 | #'regexp-quote 158 | (kalyn--builtins) 159 | "\\|")) 160 | (list 0 'font-lock-keyword-face)) 161 | (list "\\_<[A-Z].*?\\_>" 162 | (list 0 'font-lock-type-face)))) 163 | 164 | ;; XXX: just setting `fill-prefix' in these two functions is not 165 | ;; sufficient to account for corner cases. 166 | 167 | (defun kalyn--fill-paragraph (&optional justify) 168 | (let ((paragraph-start 169 | (concat paragraph-start 170 | "\\|\\s-*\\([(;\"]\\|\\s-:\\|`(\\|#'(\\)")) 171 | (fill-prefix " ")) 172 | (fill-paragraph justify))) 173 | 174 | (defun kalyn--do-auto-fill () 175 | (let ((fill-prefix " ")) 176 | (do-auto-fill))) 177 | 178 | ;;;###autoload 179 | (define-derived-mode kalyn-mode prog-mode "Kalyn" 180 | "Major mode for editing Kalyn code." 181 | (modify-syntax-entry ?\; "<" (syntax-table)) 182 | (modify-syntax-entry ?\n ">" (syntax-table)) 183 | (modify-syntax-entry ?\' "\"" (syntax-table)) 184 | (setq-local comment-start ";;") 185 | (setq-local comment-use-syntax t) 186 | (setq-local font-lock-defaults 187 | (list 188 | #'kalyn--font-lock-keywords 189 | nil nil nil 190 | (cons #'font-lock-syntactic-face-function 191 | #'kalyn--font-lock-syntactic-face-function))) 192 | (setq-local indent-line-function #'lisp-indent-line) 193 | (setq-local lisp-indent-function #'kalyn--indent-function) 194 | (setq-local fill-paragraph-function #'kalyn--fill-paragraph) 195 | (setq-local normal-auto-fill-function #'kalyn--do-auto-fill)) 196 | 197 | ;;;###autoload 198 | (add-to-list 'auto-mode-alist '("\\.kalyn\\'" . kalyn-mode)) 199 | 200 | (provide 'kalyn-mode) 201 | 202 | ;; Local Variables: 203 | ;; indent-tabs-mode: nil 204 | ;; outline-regexp: ";;;;* " 205 | ;; End: 206 | 207 | ;;; kalyn-mode.el ends here 208 | -------------------------------------------------------------------------------- /src-kalyn/Bridge.kalyn: -------------------------------------------------------------------------------- 1 | (import "AST.kalyn") 2 | (import "Assembly.kalyn") 3 | (import "MemoryManager.kalyn") 4 | (import "Primitives.kalyn") 5 | (import "Stdlib.kalyn") 6 | (import "Subroutines.kalyn") 7 | 8 | (defn handleCurried 9 | (Func 10 | Int String (Stateful VFunction) Type 11 | (Quad String (Stateful (List VFunction)) Type Int)) 12 | (n name fn ty) 13 | (Quad 14 | name 15 | (do State 16 | (with mainFn fn) 17 | (with curried (curryify n name)) 18 | (returnState (Cons mainFn curried))) 19 | ty 20 | n)) 21 | 22 | (defn handleM 23 | (Func 24 | String (Stateful VFunction) Type 25 | (Quad String (Stateful (List VFunction)) Type Int)) 26 | (name fn ty) 27 | (Quad 28 | name 29 | (do State 30 | (with core fn) 31 | (with monadified (monadify 0 name)) 32 | (returnState [core monadified])) 33 | ty 34 | 0)) 35 | 36 | (defn handleCurriedM 37 | (Func 38 | Int String (Stateful VFunction) Type 39 | (Quad String (Stateful (List VFunction)) Type Int)) 40 | (n name fn ty) 41 | (Quad 42 | name 43 | (do State 44 | (with core fn) 45 | (with monadified (monadify n (append name "__uncurried"))) 46 | (with curried (curryify n name)) 47 | (returnState (append [core monadified] curried))) 48 | ty 49 | n)) 50 | 51 | (defn baseType (Func TypeName Type) 52 | (name) 53 | (Type [] name [])) 54 | 55 | (defn funcType* (Func (List Type) Type) 56 | (tys) 57 | (case tys 58 | ([] (error "can't construct empty function type\n")) 59 | ([ty] ty) 60 | ((Cons ty tys) (Type [] "Func" [ty (funcType* tys)])))) 61 | 62 | (def funcType (Func (List TypeName) Type) 63 | (comp funcType* (map baseType))) 64 | 65 | (defn ioType (Func TypeName Type) 66 | (name) 67 | (Type [] "IO" [(Type [] name [])])) 68 | 69 | (public def stdlibPublic 70 | (Map String (Quad String (Stateful (List VFunction)) Type Int)) 71 | (mapFromList 72 | compareString 73 | [(Pair "+" (handleCurried 74 | 2 "plus" plus 75 | (funcType ["Int" "Int" "Int"]))) 76 | (Pair "-" (handleCurried 77 | 2 "minus" minus 78 | (funcType ["Int" "Int" "Int"]))) 79 | (Pair "*" (handleCurried 80 | 2 "times" times 81 | (funcType ["Int" "Int" "Int"]))) 82 | (Pair "/" (handleCurried 83 | 2 "divide" divide 84 | (funcType ["Int" "Int" "Int"]))) 85 | (Pair "%" (handleCurried 86 | 2 "modulo" modulo 87 | (funcType ["Int" "Int" "Int"]))) 88 | (Pair "&" (handleCurried 89 | 2 "and" bitAnd 90 | (funcType ["Int" "Int" "Int"]))) 91 | (Pair "|" (handleCurried 92 | 2 "or" bitOr 93 | (funcType ["Int" "Int" "Int"]))) 94 | (Pair "^" (handleCurried 95 | 2 "xor" bitXor 96 | (funcType ["Int" "Int" "Int"]))) 97 | (Pair "~" (handleCurried 98 | 1 "not" bitNot 99 | (funcType ["Int" "Int"]))) 100 | (Pair "shl" (handleCurried 101 | 2 "shl" bitSHL 102 | (funcType ["Int" "Int" "Int"]))) 103 | (Pair "shr" (handleCurried 104 | 2 "shr" bitSHR 105 | (funcType ["Int" "Int" "Int"]))) 106 | (Pair "sal" (handleCurried 107 | 2 "sal" bitSAL 108 | (funcType ["Int" "Int" "Int"]))) 109 | (Pair "sar" (handleCurried 110 | 2 "sar" bitSAR 111 | (funcType ["Int" "Int" "Int"]))) 112 | (Pair "print" (handleCurriedM 113 | 1 "print" monadPrint 114 | (funcType* [(baseType "String") (ioType "Empty")]))) 115 | (Pair "writeFile" (handleCurriedM 116 | 2 "writeFile" monadWriteFile 117 | (funcType* [(baseType "FilePath") 118 | (baseType "String") 119 | (ioType "Empty")]))) 120 | (Pair "setFileMode" (handleCurriedM 121 | 2 "setFileMode" monadSetFileMode 122 | (funcType* [(baseType "FilePath") 123 | (baseType "Int") 124 | (ioType "Empty")]))) 125 | (Pair "getWorkingDirectory" (handleM 126 | "getWorkingDirectory" 127 | monadGetWorkingDirectory 128 | (ioType "FilePath"))) 129 | (Pair "readFile" (handleCurriedM 130 | 1 "readFile" monadReadFile 131 | (funcType* [(baseType "FilePath") 132 | (ioType "String")]))) 133 | (Pair "error" (handleCurried 134 | 1 "error" primitiveError 135 | (funcType ["String" "a"]))) 136 | (Pair "==Int" (handleCurried 137 | 2 "equal" equal 138 | (funcType ["Int" "Int" "Bool"]))) 139 | (Pair "/=Int" (handleCurried 140 | 2 "notEqual" notEqual 141 | (funcType ["Int" "Int" "Bool"]))) 142 | (Pair "Int" (handleCurried 149 | 2 "greaterThan" greaterThan 150 | (funcType ["Int" "Int" "Bool"]))) 151 | (Pair ">=Int" (handleCurried 152 | 2 "greaterThanEqual" greaterThanEqual 153 | (funcType ["Int" "Int" "Bool"]))) 154 | (Pair "returnIO" (handleCurriedM 155 | 1 "return" monadReturn 156 | (funcType* [(baseType "a") 157 | (ioType "a")]))) 158 | (Pair ">>=IO" (handleCurriedM 159 | 2 "bind" monadBind 160 | (funcType* [(ioType "a") 161 | (funcType* 162 | [(baseType "a") 163 | (ioType "b")]) 164 | (ioType "b")]))) 165 | (Pair "trace" (handleCurried 166 | 2 "trace" primitiveTrace 167 | (funcType ["String" "a" "a"])))])) 168 | 169 | (def stdlibPrivate (List (Stateful VFunction)) 170 | [memoryInit 171 | memoryAlloc 172 | packString 173 | unpackString 174 | primitiveCrash]) 175 | 176 | (defn getCalls (Func VFunction (Set String)) 177 | ((Function _ _ instrs)) 178 | (setFromList 179 | compareString 180 | (concatMap 181 | (lambda (instr) 182 | (case instr 183 | ((JUMP CALL label) [label]) 184 | (_ []))) 185 | instrs))) 186 | 187 | (public defn stdlibFns (Func (List VFunction) (Stateful (List VFunction))) 188 | (userFns) 189 | (do State 190 | (let calls (setUnions compareString (map getCalls userFns))) 191 | (with allPublic (mapMState (lambda ((Quad _ fns _ _)) 192 | fns) 193 | (mapElems stdlibPublic))) 194 | (let usedPublic (concat (filter (any (lambda ((Function _ fnName _)) 195 | (setMember fnName calls))) 196 | allPublic))) 197 | (with private (sequenceState stdlibPrivate)) 198 | (returnState (append usedPublic private)))) 199 | 200 | (public def stdlibData (List Datum) 201 | (append [memoryFirstFree memoryProgramBreak syscallBuffer] msgDatums)) 202 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/Lists.kalyn: -------------------------------------------------------------------------------- 1 | (import "../Stdlib.kalyn") 2 | 3 | (public defn foldr (Func (Func a b b) b (List a) b) 4 | (func init elts) 5 | (case elts 6 | (Null init) 7 | ((Cons fst rst) 8 | (func fst (foldr func init rst))))) 9 | 10 | (public defn foldl (Func (Func b a b) b (List a) b) 11 | (func init elts) 12 | (case elts 13 | (Null init) 14 | ((Cons fst rst) 15 | (foldl func (func init fst) rst)))) 16 | 17 | (public defn map (Func (Func a b) (List a) (List b)) 18 | (func) 19 | (foldr (lambda (elt rst) 20 | (Cons (func elt) rst)) 21 | Null)) 22 | 23 | (public defn filter (Func (Func a Bool) (List a) (List a)) 24 | (pred) 25 | (foldr (lambda (elt rst) 26 | (case (pred elt) 27 | (False rst) 28 | (True (Cons elt rst)))) 29 | Null)) 30 | 31 | (public def length (Func (List a) Int) 32 | (foldr (const (+ 1)) 0)) 33 | 34 | (public defn join (Func (List a) (List a) (List a)) 35 | (left right) 36 | (foldr Cons right left)) 37 | 38 | (public defn replicate (Func Int a (List a)) 39 | (n elt) 40 | (case (<=Int n 0) 41 | (False (Cons elt (replicate (- n 1) elt))) 42 | (True Null))) 43 | 44 | (public def reverse (Func (List a) (List a)) 45 | (foldl (flip Cons) [])) 46 | 47 | (public defn append (Func (List a) (List a) (List a)) 48 | (left right) 49 | (foldr Cons right left)) 50 | 51 | (public def concat (Func (List (List a)) (List a)) 52 | (foldr append [])) 53 | 54 | (public defn concatMap (Func (Func a (List b)) (List a) (List b)) 55 | (func) 56 | (comp concat (map func))) 57 | 58 | (public defn intersperse (Func a (List a) (List a)) 59 | (elt list) 60 | (case list 61 | ([] []) 62 | ([x] [x]) 63 | ((Cons x xs) 64 | (Cons x (Cons elt (intersperse elt xs)))))) 65 | 66 | (public defn intercalate (Func (List a) (List (List a)) (List a)) 67 | (xs xss) 68 | (concat (intersperse xs xss))) 69 | 70 | (public defn head (Func (List a) a) 71 | ((Cons fst _)) 72 | fst) 73 | 74 | (public defn tail (Func (List a) (List a)) 75 | ((Cons _ rst)) 76 | rst) 77 | 78 | (public defn iterate (Func (Func a a) a Int (List a)) 79 | (func start num) 80 | (if (<=Int num 0) 81 | [] 82 | (Cons start (iterate func (func start) (- num 1))))) 83 | 84 | (public defn findIndices (Func (Func a Bool) (List a) (List Int)) 85 | (pred) 86 | (let ((findIndices (lambda (idx elts) 87 | (case elts 88 | (Null Null) 89 | ((Cons elt elts) 90 | (if (pred elt) 91 | (Cons idx (findIndices (+ idx 1) elts)) 92 | (findIndices (+ idx 1) elts))))))) 93 | (findIndices 0))) 94 | 95 | (public defn findIndex (Func (Func a Bool) (List a) Int) 96 | (pred) 97 | (comp head (findIndices pred))) 98 | 99 | (public defn take (Func Int (List a) (List a)) 100 | (n elts) 101 | (if (<=Int n 0) 102 | Null 103 | (case elts 104 | (Null Null) 105 | ((Cons fst rst) 106 | (Cons fst (take (- n 1) rst)))))) 107 | 108 | (public defn drop (Func Int (List a) (List a)) 109 | (n elts) 110 | (if (<=Int n 0) 111 | elts 112 | (case elts 113 | (Null Null) 114 | ((Cons fst rst) 115 | (drop (- n 1) rst))))) 116 | 117 | (public defn scanl (Func (Func b a b) b (List a) (List b)) 118 | (f q ls) 119 | (Cons q (case ls 120 | (Null Null) 121 | ((Cons x xs) 122 | (scanl f (f q x) xs))))) 123 | 124 | (public defn zipWith (Func (Func a b c) (List a) (List b) (List c)) 125 | (func as bs) 126 | (case (Pair as bs) 127 | ((Pair (Cons a as) (Cons b bs)) 128 | (Cons (func a b) (zipWith func as bs))) 129 | (_ Null))) 130 | 131 | (public def zip (Func (List a) (List b) (List (Pair a b))) 132 | (zipWith Pair)) 133 | 134 | (public defn last (Func (List a) a) 135 | (elts) 136 | (case elts 137 | ((Cons elt Null) elt) 138 | ((Cons _ rst) (last rst)))) 139 | 140 | ;; caution: does not preserve order!! 141 | (public defn nub (Func (Ord a) (List a) (List a)) 142 | (cmp) 143 | (comp setToList (setFromList cmp))) 144 | 145 | (public defn foldr1 (Func (Func a a a) (List a) a) 146 | (func elts) 147 | (case elts 148 | ([init] init) 149 | ((Cons elt elts) 150 | (func elt (foldr1 func elts))))) 151 | 152 | (public defn foldl1 (Func (Func a a a) (List a) a) 153 | (func (Cons init elts)) 154 | (foldl func init elts)) 155 | 156 | ;; caution: deletes duplicates!! 157 | (public defn sort (Func (Ord a) (List a) (List a)) 158 | (cmp elts) 159 | (setToList (setFromList cmp elts))) 160 | 161 | (public defn sortOn (Func (Func a b) (Ord b) (List a) (List a)) 162 | (key cmp) 163 | (sort (lambda (e1 e2) 164 | (cmp (key e1) (key e2))))) 165 | 166 | (public defn null (Func (List a) Bool) 167 | (elts) 168 | (case elts 169 | (Null True) 170 | (_ False))) 171 | 172 | (public def notNull (Func (List a) Bool) 173 | (comp not null)) 174 | 175 | (public defn elem (Func (Eq a) a (List a) Bool) 176 | (== elt elts) 177 | (notNull (findIndices (== elt) elts))) 178 | 179 | (public defn notElem (Func (Eq a) a (List a) Bool) 180 | (== elt elts) 181 | (null (findIndices (== elt) elts))) 182 | 183 | (public defn unzip (Func (List (Pair a b)) (Pair (List a) (List b))) 184 | (pairs) 185 | (case pairs 186 | (Null (Pair Null Null)) 187 | ((Cons (Pair left right) pairs) 188 | (let (((Pair lefts rights) 189 | (unzip pairs))) 190 | (Pair (Cons left lefts) 191 | (Cons right rights)))))) 192 | 193 | (public defn any (Func (Func a Bool) (List a) Bool) 194 | (func elts) 195 | (case elts 196 | (Null False) 197 | ((Cons elt elts) 198 | (if (func elt) 199 | True 200 | (any func elts))))) 201 | 202 | (public defn all (Func (Func a Bool) (List a) Bool) 203 | (func elts) 204 | (case elts 205 | (Null True) 206 | ((Cons elt elts) 207 | (if (func elt) 208 | (all func elts) 209 | False)))) 210 | 211 | (public defn splitAt (Func Int (List a) (Pair (List a) (List a))) 212 | (n elts) 213 | (if (<=Int n 0) 214 | (Pair Null elts) 215 | (case elts 216 | (Null (Pair Null Null)) 217 | ((Cons elt elts) 218 | (let (((Pair left right) 219 | (splitAt (- n 1) elts))) 220 | (Pair (Cons elt left) right)))))) 221 | 222 | (public defn zipWith3 (Func (Func a b c d) (List a) (List b) (List c) (List d)) 223 | (func as bs cs) 224 | (case (Triplet as bs cs) 225 | ((Triplet (Cons a as) (Cons b bs) (Cons c cs)) 226 | (Cons (func a b c) (zipWith3 func as bs cs))) 227 | (_ Null))) 228 | 229 | (public defn init (Func (List a) (List a)) 230 | ((Cons elt elts)) 231 | (case elts 232 | (Null Null) 233 | ((Cons _ _) (Cons elt (init elts))))) 234 | 235 | (public defn span (Func (Func a Bool) (List a) (Pair (List a) (List a))) 236 | (pred elts) 237 | (case elts 238 | (Null (Pair Null Null)) 239 | (all@(Cons elt elts) 240 | (if (pred elt) 241 | (let (((Pair left right) 242 | (span pred elts))) 243 | (Pair (Cons elt left) right)) 244 | (Pair Null all))))) 245 | 246 | (public defn split (Func (Eq a) a (List a) (List (List a))) 247 | (== sep elts) 248 | (case elts 249 | (Null [Null]) 250 | ((Cons elt elts) 251 | (if (== elt sep) 252 | (Cons Null (split == sep elts)) 253 | (let (((Cons part parts) 254 | (split == sep elts))) 255 | (Cons (Cons elt part) parts)))))) 256 | 257 | (public defn maximum (Func (Ord a) (List a) a) 258 | (cmp (Cons elt elts)) 259 | (case elts 260 | (Null elt) 261 | ((Cons _ _) 262 | (let ((max (maximum cmp elts))) 263 | (case (cmp max elt) 264 | (GT max) 265 | (_ elt)))))) 266 | 267 | (public defn minimum (Func (Ord a) (List a) a) 268 | (cmp (Cons elt elts)) 269 | (case elts 270 | (Null elt) 271 | ((Cons _ _) 272 | (let ((min (minimum cmp elts))) 273 | (case (cmp min elt) 274 | (GT min) 275 | (_ elt)))))) 276 | 277 | (public defn takeWhile (Func (Func a Bool) (List a) (List a)) 278 | (pred elts) 279 | (case elts 280 | (Null Null) 281 | ((Cons elt elts) 282 | (if (pred elt) 283 | (Cons elt (takeWhile pred elts)) 284 | Null)))) 285 | 286 | (public defn dropWhile (Func (Func a Bool) (List a) (List a)) 287 | (pred elts) 288 | (case elts 289 | (Null Null) 290 | (all@(Cons elt elts) 291 | (if (pred elt) 292 | (dropWhile pred elts) 293 | all)))) 294 | -------------------------------------------------------------------------------- /src/Subroutines.hs: -------------------------------------------------------------------------------- 1 | module Subroutines where 2 | 3 | import Data.ByteString.Builder 4 | import qualified Data.ByteString.Lazy as B 5 | import Data.Maybe 6 | 7 | import Assembly 8 | import OS 9 | 10 | getField :: Int -> VirtualRegister -> Mem VirtualRegister 11 | getField n reg = Mem (Right $ fromIntegral $ 8 * n) reg Nothing 12 | 13 | deref :: VirtualRegister -> Mem VirtualRegister 14 | deref = getField 0 15 | 16 | unpush :: Int -> VirtualInstruction 17 | unpush n = OP ADD $ IR (fromIntegral $ 8 * n) rsp 18 | 19 | -- warning: gets arguments in reverse order! indexed from 1 20 | getArg :: Int -> Mem VirtualRegister 21 | getArg n = getField (n + 1) rbp 22 | 23 | translateCall 24 | :: VirtualRegister -> Maybe VirtualRegister -> Stateful [VirtualInstruction] 25 | translateCall lhsTemp rhsTemp = do 26 | argPtr <- newTemp 27 | argsLeft <- newTemp 28 | popAmt <- newTemp 29 | pushStart <- newLabel 30 | pushDone <- newLabel 31 | return 32 | $ [ OP MOV $ MR (getField 1 lhsTemp) argsLeft 33 | , LEA (getField 2 lhsTemp) argPtr 34 | , LABEL pushStart 35 | , OP CMP $ IR 0 argsLeft 36 | , JUMP JLE pushDone 37 | , UN PUSH $ M (deref argPtr) 38 | , OP ADD $ IR 8 argPtr 39 | , UN DEC $ R argsLeft 40 | , JUMP JMP pushStart 41 | , LABEL pushDone 42 | ] 43 | ++ (case rhsTemp of 44 | Nothing -> [] 45 | Just temp -> [UN PUSH $ R temp] 46 | ) 47 | ++ [ UN ICALL $ M (getField 0 lhsTemp) 48 | , OP MOV $ MR (getField 1 lhsTemp) popAmt 49 | ] 50 | ++ [ LEA 51 | (Mem (Right (if isJust rhsTemp then 8 else 0)) 52 | rsp 53 | (Just (Scale8, popAmt)) 54 | ) 55 | rsp 56 | ] 57 | 58 | curryify :: Int -> String -> Stateful [VirtualFunction] 59 | curryify numArgs fnName = do 60 | if numArgs >= 1 61 | then return () 62 | else error "can't curry a function with no arguments" 63 | topFn <- do 64 | fnPtr <- newTemp 65 | nextFnPtr <- newTemp 66 | return $ function 67 | fnName 68 | [ PUSHI 16 69 | , JUMP CALL "memoryAlloc" 70 | , unpush 1 71 | , OP MOV $ RR rax fnPtr 72 | , LEA 73 | ( memLabel 74 | $ fnName 75 | ++ (if numArgs >= 2 then "__curried0" else "__uncurried") 76 | ) 77 | nextFnPtr 78 | , OP MOV $ RM nextFnPtr (getField 0 fnPtr) 79 | , OP MOV $ IM 0 (getField 1 fnPtr) 80 | , OP MOV $ RR fnPtr rax 81 | , RET 82 | ] 83 | subFns <- mapM 84 | (\numCurried -> do 85 | fnPtr <- newTemp 86 | nextFnPtr <- newTemp 87 | arg <- newTemp 88 | let curFnName = fnName ++ "__curried" ++ show numCurried 89 | let nextFnName = if numCurried == numArgs - 2 90 | then fnName ++ "__uncurried" 91 | else fnName ++ "__curried" ++ show (numCurried + 1) 92 | return $ function 93 | curFnName 94 | ( [ PUSHI (fromIntegral $ (numCurried + 3) * 8) 95 | , JUMP CALL "memoryAlloc" 96 | , unpush 1 97 | , OP MOV $ RR rax fnPtr 98 | , LEA (memLabel nextFnName) nextFnPtr 99 | , OP MOV $ RM nextFnPtr (getField 0 fnPtr) 100 | , OP MOV $ IM (fromIntegral $ numCurried + 1) (getField 1 fnPtr) 101 | ] 102 | ++ concatMap 103 | (\i -> 104 | [ OP MOV $ MR (getArg $ numCurried + 2 - i) arg 105 | , OP MOV $ RM arg (getField (i + 1) fnPtr) 106 | ] 107 | ) 108 | [1 .. numCurried + 1] 109 | ++ [OP MOV $ RR fnPtr rax, RET] 110 | ) 111 | ) 112 | [0 .. numArgs - 2] 113 | return . reverse $ topFn : subFns 114 | 115 | monadify :: Int -> String -> Stateful VirtualFunction 116 | monadify numArgs fnName = do 117 | fnPtr <- newTemp 118 | arg <- newTemp 119 | return $ function 120 | fnName 121 | ( [ PUSHI (fromIntegral $ (numArgs + 2) * 8) 122 | , JUMP CALL "memoryAlloc" 123 | , unpush 1 124 | , LEA (memLabel $ fnName ++ "__unmonadified") fnPtr 125 | , OP MOV $ RM fnPtr (getField 0 rax) 126 | , OP MOV $ IM (fromIntegral numArgs) (getField 1 rax) 127 | ] 128 | ++ concatMap 129 | (\i -> 130 | [ OP MOV $ MR (getArg $ numArgs + 1 - i) arg 131 | , OP MOV $ RM arg (getField (i + 1) rax) 132 | ] 133 | ) 134 | [1 .. numArgs] 135 | ++ [RET] 136 | ) 137 | 138 | packString :: Stateful VirtualFunction 139 | packString = do 140 | arg <- newTemp 141 | ptr <- newTemp 142 | strLength <- newTemp 143 | allocLength <- newTemp 144 | result <- newTemp 145 | mptr <- newTemp 146 | temp <- newTemp 147 | zero <- newTemp 148 | lengthStart <- newLabel 149 | lengthDone <- newLabel 150 | copyStart <- newLabel 151 | copyDone <- newLabel 152 | return $ function 153 | "packString" 154 | [ OP MOV $ MR (getArg 1) arg 155 | , OP MOV $ IR 0 strLength 156 | , OP MOV $ RR arg ptr 157 | , LABEL lengthStart 158 | , OP CMP $ IM 0 (getField 0 ptr) 159 | , JUMP JE lengthDone 160 | , UN INC $ R strLength 161 | , OP MOV $ MR (getField 2 ptr) ptr 162 | , JUMP JMP lengthStart 163 | , LABEL lengthDone 164 | , LEA (Mem (Right 9) strLength Nothing) allocLength 165 | , UN PUSH $ R allocLength 166 | , JUMP CALL "memoryAlloc" 167 | , unpush 1 168 | , OP MOV $ RR rax result 169 | , OP MOV $ RM strLength (deref rax) 170 | , LEA (getField 1 rax) mptr 171 | , OP MOV $ RR arg ptr 172 | , LABEL copyStart 173 | , OP CMP $ IM 0 (getField 0 ptr) 174 | , JUMP JE copyDone 175 | , OP MOV $ MR (getField 1 ptr) temp 176 | , MOVBRM temp (deref mptr) 177 | , OP MOV $ MR (getField 2 ptr) ptr 178 | , UN INC $ R mptr 179 | , JUMP JMP copyStart 180 | , LABEL copyDone 181 | , OP MOV $ IR 0 zero 182 | , MOVBRM zero (deref mptr) 183 | , OP MOV $ RR result rax 184 | , RET 185 | ] 186 | 187 | unpackString :: Stateful VirtualFunction 188 | unpackString = do 189 | str <- newTemp 190 | strptr <- newTemp 191 | allocSize <- newTemp 192 | retval <- newTemp 193 | bufPtr <- newTemp 194 | lstPtr <- newTemp 195 | lstEnd <- newTemp 196 | char <- newTemp 197 | next <- newTemp 198 | lenStart <- newLabel 199 | lenDone <- newLabel 200 | copyStart <- newLabel 201 | copyDone <- newLabel 202 | return $ function 203 | "unpackString" 204 | [ OP MOV $ MR (getArg 2) str 205 | , OP MOV $ MR (getArg 1) allocSize 206 | , OP CMP $ IR 0 allocSize 207 | , JUMP JGE lenDone 208 | , OP MOV $ RR str strptr 209 | , OP MOV $ IR 0 allocSize 210 | , LABEL lenStart 211 | , OP CMP $ IM 0 (deref strptr) 212 | , JUMP JE lenDone 213 | , UN INC $ R allocSize 214 | , UN INC $ R strptr 215 | , LABEL lenDone 216 | , OP IMUL $ IR 24 allocSize 217 | , OP ADD $ IR 8 allocSize 218 | , UN PUSH (R allocSize) 219 | , JUMP CALL "memoryAlloc" 220 | , unpush 1 221 | , OP MOV $ RR rax retval 222 | , OP MOV $ RR str bufPtr 223 | , OP MOV $ RR rax lstPtr 224 | , LEA (Mem (Right $ -8) lstPtr (Just (Scale1, allocSize))) lstEnd 225 | , LABEL copyStart 226 | , OP CMP $ RR lstEnd lstPtr 227 | , JUMP JGE copyDone 228 | , OP MOV $ IM 1 (getField 0 lstPtr) 229 | , OP MOV $ IR 0 char 230 | , MOVBMR (deref bufPtr) char 231 | , OP MOV $ RM char (getField 1 lstPtr) 232 | , LEA (getField 3 lstPtr) next 233 | , OP MOV $ RM next (getField 2 lstPtr) 234 | , UN INC (R bufPtr) 235 | , OP ADD $ IR 24 lstPtr 236 | , JUMP JMP copyStart 237 | , LABEL copyDone 238 | , OP MOV $ IM 0 (deref lstPtr) 239 | , OP MOV $ RR retval rax 240 | , RET 241 | ] 242 | 243 | packMsg :: String -> B.ByteString 244 | packMsg str = 245 | toLazyByteString $ int64LE (fromIntegral $ length str) <> stringUtf8 str 246 | 247 | msgDatums :: [Datum] 248 | msgDatums = 249 | [ ("msgPatternMatchFailed" , packMsg "pattern match failed\n") 250 | , ("msgMemoryAllocFailed" , packMsg "memoryAlloc failed\n") 251 | , ("msgWriteFileFailed" , packMsg "writeFile failed\n") 252 | , ("msgSetFileModeFailed" , packMsg "setFileMode failed\n") 253 | , ("msgReadFileFailed" , packMsg "readFile failed\n") 254 | , ("msgGetWorkingDirectoryFailed", packMsg "getWorkingDirectory failed\n") 255 | ] 256 | 257 | syscallBuffer :: Datum 258 | syscallBuffer = ("syscallBuffer", B.pack (replicate syscallBufferSize 0)) 259 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser 2 | ( parseModule 3 | ) where 4 | 5 | import Codec.Binary.UTF8.String 6 | import Data.List 7 | 8 | import AST 9 | import Tokens 10 | import Util 11 | 12 | withConstraints :: (Form -> a) -> Form -> ([ClassSpec], a) 13 | withConstraints parseBody (RoundList [Symbol "with", RoundList specs, body]) = 14 | (map parseClassSpec specs, parseBody body) 15 | withConstraints _ form@(RoundList (Symbol "with" : _)) = 16 | error $ "failed to parse constraint list: " ++ pretty form 17 | withConstraints parseBody form = ([], parseBody form) 18 | 19 | parseTypeSpec :: Form -> TypeSpec 20 | parseTypeSpec (RoundList ((Symbol name) : args)) = TypeSpec 21 | name 22 | (flip map args $ \arg -> case arg of 23 | Symbol argName -> argName 24 | _ -> error $ "failed to parse type spec argument: " ++ pretty arg 25 | ) 26 | parseTypeSpec (Symbol name) = TypeSpec name [] 27 | parseTypeSpec form = error $ "failed to parse type spec: " ++ pretty form 28 | 29 | parseType :: Form -> Type 30 | parseType form@(RoundList (Symbol "with" : _)) = 31 | let (specs, Type moreSpecs name args) = withConstraints parseType form 32 | in Type (specs ++ moreSpecs) name args 33 | parseType (RoundList (Symbol "Func" : args)) = 34 | foldr1 (\lhs rhs -> Type [] "Func" [lhs, rhs]) (map parseType args) 35 | parseType (RoundList (Symbol name : args)) = Type [] name (map parseType args) 36 | parseType (Symbol name) = Type [] name [] 37 | parseType form = error $ "failed to parse type: " ++ pretty form 38 | 39 | parseClassSpec :: Form -> ClassSpec 40 | parseClassSpec (RoundList [Symbol name, Symbol typ]) = ClassSpec name typ 41 | parseClassSpec form = error $ "failed to parse class spec: " ++ pretty form 42 | 43 | scrubGensym :: String -> String 44 | scrubGensym name = if "gensym" `isPrefixOf` name then name ++ "_" else name 45 | 46 | parseExpr :: Form -> Expr 47 | parseExpr (RoundList []) = error "round list can't be empty" 48 | parseExpr (RoundList (Symbol "case" : expr : branches)) = Case 49 | (parseExpr expr) 50 | (flip map branches $ \br -> case br of 51 | RoundList [pat, res] -> (parseExpr pat, parseExpr res) 52 | _ -> error $ "failed to parse case branch: " ++ pretty br 53 | ) 54 | parseExpr (RoundList (Symbol "do" : Symbol monadName : items)) = if null items 55 | then error "empty do" 56 | else parseExpr $ foldr1 57 | (\item dbody -> case item of 58 | RoundList [Symbol "let", binding, value] -> RoundList 59 | [ Symbol $ ">>=" ++ monadName 60 | , RoundList [Symbol $ "return" ++ monadName, value] 61 | , RoundList [Symbol "lambda", RoundList [binding], dbody] 62 | ] 63 | RoundList [Symbol "with", binding, value] -> RoundList 64 | [ Symbol $ ">>=" ++ monadName 65 | , value 66 | , RoundList [Symbol "lambda", RoundList [binding], dbody] 67 | ] 68 | value -> RoundList 69 | [ Symbol $ ">>=" ++ monadName 70 | , value 71 | , RoundList [Symbol "lambda", RoundList [Symbol "_"], dbody] 72 | ] 73 | ) 74 | items 75 | parseExpr (RoundList [Symbol "if", cond, true, false]) = Case 76 | (parseExpr cond) 77 | [(Variable "True", parseExpr true), (Variable "False", parseExpr false)] 78 | parseExpr form@(RoundList [Symbol "lambda", RoundList _, _]) = 79 | -- translate 'em like this to maximize the number of sublambdas we 80 | -- can call through in code generation 81 | let (args, body) = uncurryLambdas form 82 | gensyms = 83 | take (length args) 84 | . map (("gensym" ++) . show) 85 | . iterate (+ 1) 86 | $ (0 :: Int) 87 | in foldr 88 | (\(arg, gensym) lbody -> case arg of 89 | Symbol name -> Lambda (scrubGensym name) lbody 90 | _ -> Lambda gensym lbody 91 | ) 92 | (foldr 93 | (\(arg, gensym) lbody -> case arg of 94 | Symbol _ -> lbody 95 | _ -> Case (Variable gensym) [(parseExpr arg, lbody)] 96 | ) 97 | (parseExpr body) 98 | (zip args gensyms) 99 | ) 100 | (zip args gensyms) 101 | where 102 | uncurryLambdas (RoundList [Symbol "lambda", RoundList args, body]) = 103 | let (restArgs, innerBody) = uncurryLambdas body 104 | in (args ++ restArgs, innerBody) 105 | uncurryLambdas body = ([], body) 106 | parseExpr (RoundList [Symbol "let", RoundList bindings, body]) = foldr 107 | (\binding lbody -> case binding of 108 | RoundList [Symbol name, val] -> 109 | Let (scrubGensym name) (parseExpr val) lbody 110 | RoundList [pat, val] -> Let 111 | "gensym" 112 | (parseExpr val) 113 | (Case (Variable "gensym") [(parseExpr pat, lbody)]) 114 | _ -> error $ "failed to parse let binding: " ++ pretty binding 115 | ) 116 | (parseExpr body) 117 | bindings 118 | parseExpr (RoundList (Symbol "and" : lhs : rhs : more@(_ : _))) = parseExpr 119 | (RoundList [Symbol "and", lhs, RoundList (Symbol "and" : rhs : more)]) 120 | parseExpr (RoundList (Symbol "or" : lhs : rhs : more@(_ : _))) = 121 | parseExpr (RoundList [Symbol "or", lhs, RoundList (Symbol "or" : rhs : more)]) 122 | parseExpr (RoundList [Symbol "and", lhs, rhs]) = Let 123 | "gensym" 124 | (parseExpr lhs) 125 | (Case 126 | (Variable "gensym") 127 | [(Variable "False", Variable "False"), (Variable "True", parseExpr rhs)] 128 | ) 129 | parseExpr (RoundList [Symbol "or", lhs, rhs]) = Let 130 | "gensym" 131 | (parseExpr lhs) 132 | (Case 133 | (Variable "gensym") 134 | [(Variable "True", Variable "True"), (Variable "False", parseExpr rhs)] 135 | ) 136 | parseExpr (RoundList elts) = foldl1 Call (map parseExpr elts) 137 | parseExpr (SquareList elts) = parseExpr $ foldr 138 | (\char rest -> RoundList [Symbol "Cons", char, rest]) 139 | (Symbol "Null") 140 | elts 141 | parseExpr (Symbol name) = Variable $ scrubGensym name 142 | parseExpr (IntAtom i ) = Const i 143 | parseExpr (CharAtom c ) = case encodeChar c of 144 | [b] -> parseExpr $ RoundList [Symbol "Char", IntAtom (fromIntegral b)] 145 | _ -> error "multibyte character literals are not supported" 146 | parseExpr (StrAtom s) = parseExpr $ SquareList 147 | (map (\c -> RoundList [Symbol "Char", IntAtom (fromIntegral c)]) $ encode s) 148 | parseExpr (At name elt) = As (scrubGensym name) (parseExpr elt) 149 | 150 | parseDecl :: Form -> Decl 151 | parseDecl form = case form of 152 | (RoundList (Symbol "public" : rest)) -> parseDecl' True (RoundList rest) 153 | _ -> parseDecl' False form 154 | where 155 | parseDecl' pub (RoundList [Symbol "alias", spec, typ]) = 156 | Alias pub (parseTypeSpec spec) (parseType typ) 157 | parseDecl' pub (RoundList [Symbol "alias", spec, StrAtom _, typ]) = 158 | Alias pub (parseTypeSpec spec) (parseType typ) 159 | parseDecl' pub (RoundList (Symbol "class" : spec : members)) = 160 | let (constraints, innerSpec) = withConstraints parseClassSpec spec 161 | in Class 162 | pub 163 | constraints 164 | innerSpec 165 | (flip map members $ \m -> case m of 166 | RoundList [Symbol name, typ] -> (name, parseType typ) 167 | _ -> error $ "failed to parse class member: " ++ pretty m 168 | ) 169 | parseDecl' pub (RoundList (Symbol "data" : spec : members)) = 170 | let members' = case members of 171 | (StrAtom _ : rest) -> rest 172 | _ -> members 173 | in Data 174 | pub 175 | (parseTypeSpec spec) 176 | (flip map members' $ \m -> case m of 177 | Symbol name -> (name, []) 178 | RoundList (Symbol name : args) -> (name, map parseType args) 179 | _ -> error $ "failed to parse data constructor: " ++ pretty m 180 | ) 181 | parseDecl' pub (RoundList [Symbol "def", Symbol name, typ, StrAtom _, expr]) 182 | = Def pub name (parseType typ) (parseExpr expr) 183 | parseDecl' pub (RoundList [Symbol "def", Symbol name, typ, expr]) = 184 | Def pub name (parseType typ) (parseExpr expr) 185 | parseDecl' pub (RoundList [Symbol "defn", name, typ, StrAtom _, args, body]) 186 | = parseDecl' 187 | pub 188 | (RoundList 189 | [Symbol "def", name, typ, RoundList [Symbol "lambda", args, body]] 190 | ) 191 | parseDecl' pub (RoundList [Symbol "defn", name, typ, args, body]) = 192 | parseDecl' 193 | pub 194 | (RoundList 195 | [Symbol "def", name, typ, RoundList [Symbol "lambda", args, body]] 196 | ) 197 | parseDecl' pub (RoundList [Symbol "derive", spec]) = 198 | Derive pub (parseClassSpec spec) 199 | parseDecl' pub (RoundList [Symbol "import", StrAtom file]) = Import pub file 200 | parseDecl' pub (RoundList (Symbol "instance" : spec : members)) = 201 | let (constraints, innerSpec) = withConstraints parseClassSpec spec 202 | in Instance 203 | pub 204 | constraints 205 | innerSpec 206 | (flip map members $ \m -> case m of 207 | RoundList [Symbol name, expr] -> (name, parseExpr expr) 208 | _ -> error $ "failed to parse instance member: " ++ pretty m 209 | ) 210 | parseDecl' _ _ = error $ "failed to parse declaration: " ++ pretty form 211 | 212 | parseModule :: [Form] -> [Decl] 213 | parseModule = map parseDecl 214 | -------------------------------------------------------------------------------- /src-kalyn/Assembly.kalyn: -------------------------------------------------------------------------------- 1 | (import "Stdlib.kalyn") 2 | 3 | (public import "Instances.kalyn") 4 | 5 | (public data Register 6 | RAX RCX RDX RBX 7 | RSP RBP RSI RDI 8 | R8 R9 R10 R11 9 | R12 R13 R14 R15 10 | RIP) 11 | 12 | (public data Temporary 13 | (Temporary Int)) 14 | 15 | (public data VirtualRegister 16 | (Physical Register) 17 | (Virtual Temporary)) 18 | 19 | (public alias VR VirtualRegister) 20 | 21 | (public alias (RegisterLike reg) (Func Register reg)) 22 | 23 | (public def fromP (RegisterLike Register) 24 | id) 25 | 26 | (public def fromV (RegisterLike VR) 27 | Physical) 28 | 29 | (public def rax VR (Physical RAX)) 30 | (public def rcx VR (Physical RCX)) 31 | (public def rdx VR (Physical RDX)) 32 | (public def rbx VR (Physical RBX)) 33 | (public def rsp VR (Physical RSP)) 34 | (public def rbp VR (Physical RBP)) 35 | (public def rsi VR (Physical RSI)) 36 | (public def rdi VR (Physical RDI)) 37 | (public def r8 VR (Physical R8 )) 38 | (public def r9 VR (Physical R9 )) 39 | (public def r10 VR (Physical R10)) 40 | (public def r11 VR (Physical R11)) 41 | (public def r12 VR (Physical R12)) 42 | (public def r13 VR (Physical R13)) 43 | (public def r14 VR (Physical R14)) 44 | (public def r15 VR (Physical R15)) 45 | (public def rip VR (Physical RIP)) 46 | 47 | (public alias Label String) 48 | 49 | (public data Scale 50 | Scale1 51 | Scale2 52 | Scale4 53 | Scale8) 54 | 55 | (public data (Mem reg) 56 | (Mem (Either Label Int32) reg (Maybe (Pair Scale reg)))) 57 | 58 | (public data (Args reg) 59 | (IR Int32 reg) 60 | (IM Int32 (Mem reg)) 61 | (RR reg reg) 62 | (MR (Mem reg) reg) 63 | (RM reg (Mem reg))) 64 | 65 | (public data (Arg reg) 66 | (R reg) 67 | (M (Mem reg))) 68 | 69 | (public data BinOp 70 | MOV ADD SUB IMUL AND OR XOR CMP) 71 | 72 | (public data UnOp 73 | NOT NEG INC DEC PUSH POP ICALL) 74 | 75 | (public data Jump 76 | JMP JE JNE JL JLE JG JGE JB JBE JA JAE CALL) 77 | 78 | (public data Shift 79 | SHL SAL SHR SAR) 80 | 81 | ;; reg is either Register or VirtualRegister. We use AT&T syntax. 82 | ;; !!! when adding new instr, update spillInstr in RegisterAllocator !!! 83 | (public data (Instruction reg) 84 | (OP BinOp (Args reg)) 85 | (UN UnOp (Arg reg)) 86 | (JUMP Jump Label) 87 | (MOVBRM reg (Mem reg)) 88 | (MOVBMR (Mem reg) reg) 89 | (MOV64 Int64 reg) 90 | (SHIFT (Maybe Word8) Shift reg) 91 | (LEA (Mem reg) reg) 92 | (IDIV reg) 93 | CQTO 94 | (PUSHI Int32) 95 | RET 96 | (SYSCALL Word) 97 | (LABEL Label) 98 | (GLOBAL Label)) 99 | 100 | (public alias VInstruction (Instruction VR)) 101 | (public alias PInstruction (Instruction Register)) 102 | 103 | (public defn memLabel (Func (RegisterLike reg) Label (Mem reg)) 104 | (from name) 105 | (Mem (Left name) (from RIP) Nothing)) 106 | 107 | (public def memLabelP (Func Label (Mem Register)) 108 | (memLabel fromP)) 109 | 110 | (public def memLabelV (Func Label (Mem VR)) 111 | (memLabel fromV)) 112 | 113 | (public def dataRegisters (Set Register) 114 | (setFromList 115 | compareRegister 116 | [RAX RCX RDX RBX 117 | RSI RDI R8 R9 118 | R10 R11 R12 R13 119 | R14 R15])) 120 | 121 | (public def syscallRegisters (List Register) 122 | [RAX RDI RSI RDX RCX R8 R9]) 123 | 124 | (public def callerSavedRegisters (List Register) 125 | [RAX RCX RDX RSI RDI 126 | R8 R9 R10 R11]) 127 | 128 | (public def specialRegisters (List Register) 129 | [RSP RBP RIP]) 130 | 131 | (public alias (UseDef reg) (Pair (List reg) (List reg))) 132 | 133 | (defn getMemRegisters (Func (Mem reg) (List reg)) 134 | (mem) 135 | (case mem 136 | ((Mem _ base Nothing) [base]) 137 | ((Mem _ base (Just (Pair _ index))) [base index]))) 138 | 139 | (defn getArgsRegisters (Func BinOp (Args reg) (UseDef reg)) 140 | (op args) 141 | (case (Pair op args) 142 | ((Pair CMP (IR _ dst)) (Pair [dst] [])) 143 | ((Pair _ (IR _ dst)) (Pair [] [dst])) 144 | ((Pair _ (IM _ mem)) (Pair (getMemRegisters mem) [])) 145 | ((Pair MOV (RR src dst)) (Pair [src] [dst])) 146 | ((Pair CMP (RR src dst)) (Pair [src dst] [])) 147 | ((Pair _ (RR src dst)) (Pair [src dst] [dst])) 148 | ((Pair MOV (MR mem dst)) (Pair (getMemRegisters mem) [dst])) 149 | ((Pair CMP (MR mem _ )) (Pair (getMemRegisters mem) [])) 150 | ((Pair _ (MR mem dst)) (Pair (Cons dst (getMemRegisters mem)) [dst])) 151 | ((Pair _ (RM src mem)) (Pair (Cons src (getMemRegisters mem)) [])))) 152 | 153 | (defn getArgRegisters (Func (RegisterLike reg) UnOp (Arg reg) (UseDef reg)) 154 | (from op arg) 155 | (case (Pair op arg) 156 | ((Pair PUSH (R reg)) (Pair [reg] [])) 157 | ((Pair ICALL (R reg)) (Pair [reg] [(from RAX)])) 158 | ((Pair POP (R reg)) (Pair [] [reg])) 159 | ((Pair _ (R reg)) (Pair [reg] [reg])) 160 | ((Pair ICALL (M mem)) (Pair (getMemRegisters mem) [(from RAX)])) 161 | ((Pair _ (M mem)) (Pair (getMemRegisters mem) [])))) 162 | 163 | (public defn getRegisters (Func (RegisterLike reg) (Instruction reg) (UseDef reg)) 164 | (from instr) 165 | (case instr 166 | ((OP op args) (getArgsRegisters op args)) 167 | ((UN op arg) (getArgRegisters from op arg)) 168 | ((JUMP CALL _) (Pair [] [(from RAX)])) 169 | ((JUMP _ _) (Pair [] [])) 170 | ((MOVBRM src mem) (Pair (Cons src (getMemRegisters mem)) [])) 171 | ((MOVBMR mem dst) (Pair (getMemRegisters mem) [dst])) 172 | ((MOV64 _ dst) (Pair [] [dst])) 173 | ((SHIFT Nothing _ dst) (Pair [dst (from RCX)] [dst])) 174 | ((SHIFT (Just _) _ dst) (Pair [dst] [dst])) 175 | ((LEA mem dst) (Pair (getMemRegisters mem) [dst])) 176 | ((IDIV src) (Pair [src (from RAX) (from RDX)] 177 | [(from RAX) (from RDX)])) 178 | (CQTO (Pair [(from RAX)] [(from RDX)])) 179 | ((PUSHI _) (Pair [] [])) 180 | (RET (Pair [(from RAX)] [])) 181 | ((SYSCALL n) 182 | (if (>=Int (+ n 1) (length syscallRegisters)) 183 | (error "too many arguments for system call\n") 184 | (Pair (map from (take (+ n 1) syscallRegisters)) 185 | (map from callerSavedRegisters)))) 186 | ((LABEL _) (Pair [] [])) 187 | ((GLOBAL _) (Pair [] [])))) 188 | 189 | (public data JumpType 190 | Straightline 191 | (Jump Label) 192 | (Branch Label) 193 | Return) 194 | 195 | (public defn getJumpType (Func (Instruction reg) JumpType) 196 | (instr) 197 | (case instr 198 | ((JUMP JMP label) (Jump label)) 199 | ((JUMP CALL "crash") Return) 200 | ((JUMP CALL _) Straightline) 201 | ((JUMP _ label) (Branch label)) 202 | (RET Return) 203 | (_ Straightline))) 204 | 205 | (defn mapMem (Func (Func reg1 reg2) (Mem reg1) (Mem reg2)) 206 | (func (Mem disp base msi)) 207 | (Mem 208 | disp 209 | (func base) 210 | (case msi 211 | (Nothing Nothing) 212 | ((Just (Pair scale index)) 213 | (Just (Pair scale (func index))))))) 214 | 215 | (defn mapArgs (Func (Func reg1 reg2) (Args reg1) (Args reg2)) 216 | (func args) 217 | (case args 218 | ((IR imm reg) (IR imm (func reg))) 219 | ((IM imm mem) (IM imm (mapMem func mem))) 220 | ((RR src dst) (RR (func src) (func dst))) 221 | ((MR mem reg) (MR (mapMem func mem) (func reg))) 222 | ((RM reg mem) (RM (func reg) (mapMem func mem))))) 223 | 224 | (defn mapArg (Func (Func reg1 reg2) (Arg reg1) (Arg reg2)) 225 | (func arg) 226 | (case arg 227 | ((R reg) (R (func reg))) 228 | ((M mem) (M (mapMem func mem))))) 229 | 230 | (public defn mapInstr (Func (Func reg1 reg2) (Instruction reg1) (Instruction reg2)) 231 | (func instr) 232 | (case instr 233 | ((OP op args) (OP op (mapArgs func args))) 234 | ((UN op arg) (UN op (mapArg func arg))) 235 | ((JUMP op label) (JUMP op label)) 236 | ((MOVBRM reg mem) (MOVBRM (func reg) (mapMem func mem))) 237 | ((MOVBMR mem reg) (MOVBMR (mapMem func mem) (func reg))) 238 | ((MOV64 imm reg) (MOV64 imm (func reg))) 239 | ((SHIFT amt shift reg) (SHIFT amt shift (func reg))) 240 | ((LEA mem reg) (LEA (mapMem func mem) (func reg))) 241 | ((IDIV reg) (IDIV (func reg))) 242 | (CQTO CQTO) 243 | ((PUSHI imm) (PUSHI imm)) 244 | (RET RET) 245 | ((SYSCALL n) (SYSCALL n)) 246 | ((LABEL name) (LABEL name)) 247 | ((GLOBAL name) (GLOBAL name)))) 248 | 249 | (public data (Function reg) 250 | (Function Int Label (List (Instruction reg)))) 251 | 252 | (public def function (Func Label (List (Instruction reg)) (Function reg)) 253 | (Function 0)) 254 | 255 | (public alias VFunction (Function VR)) 256 | (public alias PFunction (Function Register)) 257 | 258 | (public defn fnInstrs (Func (Function reg) (List (Instruction reg))) 259 | ((Function _ name instrs)) 260 | (Cons (GLOBAL name) instrs)) 261 | 262 | (public alias Datum (Pair Label Bytes)) 263 | 264 | (public data (Program reg) 265 | (Program (Function reg) (List (Function reg)) (List Datum))) 266 | 267 | (public alias VProgram (Program VR)) 268 | (public alias PProgram (Program Register)) 269 | 270 | (public alias Stateful (State Int)) 271 | 272 | (public def newTemp (Stateful VR) 273 | (do State 274 | (with count get) 275 | (put (+ count 1)) 276 | (returnState (Virtual (Temporary count))))) 277 | 278 | (public def newLabel (Stateful Label) 279 | (do State 280 | (with count get) 281 | (put (+ count 1)) 282 | (returnState (Cons 'l' (showInt count))))) 283 | 284 | (public defn newLambda (Func String (Stateful Label)) 285 | (fnName) 286 | (do State 287 | (with count get) 288 | (put (+ count 1)) 289 | (returnState (concat [fnName "__lambda" (showInt count)])))) 290 | -------------------------------------------------------------------------------- /src/Resolver.hs: -------------------------------------------------------------------------------- 1 | module Resolver 2 | ( resolveBundle 3 | ) where 4 | 5 | import Data.Char 6 | import Data.Int 7 | import qualified Data.Map.Strict as Map 8 | import qualified Data.Set as Set 9 | import Prelude hiding ( mod ) 10 | import System.FilePath 11 | 12 | import AST 13 | import Bridge 14 | import Util 15 | 16 | {-# ANN module "HLint: ignore Use record patterns" #-} 17 | {-# ANN module "HLint: ignore Use tuple-section" #-} 18 | 19 | mapTypeName :: (String -> String) -> String -> String 20 | mapTypeName _ "IO" = "IO" 21 | mapTypeName _ "Int" = "Int" 22 | mapTypeName _ "Func" = "Func" 23 | mapTypeName _ name@(c : _) | isLower c = name 24 | mapTypeName func name = func name 25 | 26 | mapTypeSpec :: (String -> String) -> TypeSpec -> TypeSpec 27 | mapTypeSpec func (TypeSpec typeName params) = 28 | TypeSpec (mapTypeName func typeName) params 29 | 30 | mapType :: (String -> String) -> Type -> Type 31 | mapType func (Type classSpecs typeName typeArgs) = 32 | Type classSpecs (mapTypeName func typeName) (map (mapType func) typeArgs) 33 | 34 | mapSymbol :: (String -> String) -> (String -> String) -> Symbol -> Symbol 35 | mapSymbol func tfunc (SymDef name t num) = 36 | SymDef (func name) (mapType tfunc t) num 37 | mapSymbol func tfunc (SymData name ctorIdx numFields numCtors boxed typeSpec types) 38 | = SymData (func name) 39 | ctorIdx 40 | numFields 41 | numCtors 42 | boxed 43 | (mapTypeSpec tfunc typeSpec) 44 | (map (mapType tfunc) types) 45 | 46 | uniquify :: [String] -> [String] 47 | uniquify = uniquify' Set.empty 48 | where 49 | uniquify' _ [] = [] 50 | uniquify' seen (str : strs) = 51 | let str' = findUnused str seen 52 | in (str' : uniquify' (Set.insert str' seen) strs) 53 | findUnused str seen = head $ filter (`Set.notMember` seen) $ str : map 54 | (\num -> str ++ show num) 55 | (iterate (+ 1) (1 :: Int)) 56 | 57 | getComponents :: FilePath -> [String] 58 | getComponents = reverse . tail . splitDirectories 59 | 60 | sanitizeModuleName :: Int -> FilePath -> FilePath 61 | sanitizeModuleName n path = 62 | sanitize $ concat (reverse . take n $ getComponents path) 63 | 64 | sanitizeModuleNames :: [String] -> Map.Map String String 65 | sanitizeModuleNames fullNames = 66 | let maxComponents = maximum $ (map $ length . getComponents) fullNames 67 | xforms = 68 | map (\n names -> map (sanitizeModuleName n) names) [1 .. maxComponents] 69 | ++ [uniquify . map (sanitizeModuleName maxComponents)] 70 | bestXForm = head $ filter (\xform -> listUnique $ xform fullNames) xforms 71 | in Map.fromList $ zip fullNames (bestXForm fullNames) 72 | 73 | countSublambdas :: Expr -> Int 74 | countSublambdas (Lambda _ body) = 1 + countSublambdas body 75 | countSublambdas _ = 0 76 | 77 | -- for now, doesn't handle Derive or Instance 78 | getDeclSymbols :: Bool -> Decl -> [Symbol] 79 | getDeclSymbols isMain (Data pub typeSpec ctors) = if isMain || pub 80 | then zipWith 81 | (\(name, types) idx -> SymData { sdName = name 82 | , sdCtorIdx = idx 83 | , sdNumFields = length types 84 | , sdNumCtors = length ctors 85 | , sdBoxed = shouldBox ctors 86 | , sdTypeSpec = typeSpec 87 | , sdTypes = types 88 | } 89 | ) 90 | ctors 91 | (iterate (+ 1) 0) 92 | else [] 93 | getDeclSymbols isMain (Def pub name t expr) = 94 | [ SymDef name t (countSublambdas expr) | isMain || pub ] 95 | getDeclSymbols _ _ = [] 96 | 97 | getDeclTypes :: Bool -> Decl -> [TypeName] 98 | getDeclTypes isMain (Data pub (TypeSpec name _) _) = [ name | isMain || pub ] 99 | getDeclTypes _ _ = [] 100 | 101 | getDeclAliases :: Bool -> Decl -> [(TypeSpec, Type)] 102 | getDeclAliases isMain (Alias pub typeSpec t) = 103 | [ (typeSpec, t) | isMain || pub ] 104 | getDeclAliases _ _ = [] 105 | 106 | mangleWith :: String -> String -> String 107 | mangleWith modAbbr name = "__" ++ modAbbr ++ "__" ++ sanitize name 108 | 109 | resolveBundle :: Bundle -> Resolver 110 | resolveBundle (Bundle _ mmap) = 111 | let 112 | modNames = sanitizeModuleNames (map fst $ Map.toList mmap) 113 | gTypeMap = Map.mapWithKey 114 | (\mainMod info -> 115 | let mods = mainMod : snd info 116 | in Map.fromListWithKey 117 | (\name _ -> 118 | error $ "more than one definition for type " ++ show name 119 | ) 120 | $ concatMap 121 | (\mod -> 122 | let modAbbr = modNames Map.! mod 123 | decls = fst . (mmap Map.!) $ mod 124 | in map (\name -> (name, mangleWith modAbbr name)) 125 | $ concatMap (getDeclTypes (mod == mainMod)) decls 126 | ++ ( map (\(TypeSpec name _, _) -> name) 127 | . concatMap (getDeclAliases (mod == mainMod)) 128 | $ decls 129 | ) 130 | ) 131 | mods 132 | ) 133 | mmap 134 | gAliasMap = 135 | Map.fromListWithKey 136 | (\name _ -> error $ "more than one alias for " ++ show name) 137 | . concatMap 138 | (\(mod, info) -> 139 | let modAbbr = modNames Map.! mod 140 | in 141 | map 142 | (\(TypeSpec aliasName params, aliasDefn) -> 143 | ( mangleWith modAbbr aliasName 144 | , ( params 145 | , mapType 146 | (\name -> case name `Map.lookup` (gTypeMap Map.! mod) of 147 | Nothing -> 148 | error $ "no such type in alias: " ++ show name 149 | Just name' -> name' 150 | ) 151 | aliasDefn 152 | ) 153 | ) 154 | ) 155 | . concatMap (getDeclAliases True) 156 | . fst 157 | $ info 158 | ) 159 | . Map.toList 160 | $ mmap 161 | in 162 | Resolver $ Map.mapWithKey 163 | (\mainMod info -> 164 | let 165 | mods = mainMod : snd info 166 | symbolMap = 167 | Map.fromListWithKey 168 | (\name _ -> 169 | error $ "more than one definition for symbol " ++ show name 170 | ) 171 | $ concatMap 172 | (\mod -> 173 | let modAbbr = modNames Map.! mod 174 | in 175 | map 176 | (\sym -> 177 | ( symName sym 178 | , mapSymbol 179 | (mangleWith modAbbr) 180 | (\name -> 181 | case name `Map.lookup` (gTypeMap Map.! mod) of 182 | Nothing -> 183 | error 184 | $ "in module " 185 | ++ show mod 186 | ++ ": no such type " 187 | ++ show name 188 | Just name' -> name' 189 | ) 190 | sym 191 | ) 192 | ) 193 | . concatMap (getDeclSymbols (mod == mainMod)) 194 | . fst 195 | . (mmap Map.!) 196 | $ mod 197 | ) 198 | mods 199 | ++ map 200 | (\(publicName, (privateName, _, ty, numSublambdas)) -> 201 | let sym = SymDef privateName ty numSublambdas 202 | in 203 | ( publicName 204 | , mapSymbol 205 | id 206 | (\name -> 207 | case name `Map.lookup` (gTypeMap Map.! mainMod) of 208 | Nothing -> 209 | error 210 | $ "no such type " 211 | ++ show name 212 | ++ " in module: " 213 | ++ mainMod 214 | Just name' -> name' 215 | ) 216 | sym 217 | ) 218 | ) 219 | (Map.toList stdlibPublic) 220 | in 221 | ( symbolMap 222 | , Map.restrictKeys 223 | gAliasMap 224 | ( Set.fromList 225 | . concatMap 226 | (\mod -> 227 | let modAbbr = modNames Map.! mod 228 | in ( map (\(TypeSpec name _, _) -> mangleWith modAbbr name) 229 | . concatMap (getDeclAliases (mod == mainMod)) 230 | . fst 231 | . (mmap Map.!) 232 | $ mod 233 | ) 234 | ) 235 | $ mods 236 | ) 237 | ) 238 | ) 239 | mmap 240 | -------------------------------------------------------------------------------- /src/RegisterAllocator.hs: -------------------------------------------------------------------------------- 1 | module RegisterAllocator 2 | ( Allocation 3 | , allocateProgramRegs 4 | , showAllocation 5 | ) where 6 | 7 | import Control.Monad 8 | import Data.List 9 | import qualified Data.Map as Map 10 | import Data.Maybe 11 | import qualified Data.Set as Set 12 | 13 | import Assembly 14 | import Liveness 15 | 16 | {-# ANN module "HLint: ignore Use lambda-case" #-} 17 | 18 | -- http://web.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf 19 | 20 | type Allocation = Map.Map VirtualRegister Register 21 | 22 | computeLivenessIntervals :: Ord reg => Liveness reg -> Map.Map reg (Int, Int) 23 | computeLivenessIntervals livenesses = 24 | let alter idx = Map.alter 25 | (\interval -> case interval of 26 | Nothing -> Just (idx, idx + 1) 27 | Just (start, _) -> Just (start, idx + 1) 28 | ) 29 | in foldl' 30 | (\intervals (liveness, idx) -> Set.foldr 31 | (alter idx) 32 | (Set.foldr (alter idx) intervals (instrDefined liveness)) 33 | (instrLiveIn liveness) 34 | ) 35 | Map.empty 36 | (zip livenesses (iterate (+ 1) 0)) 37 | 38 | intervalsIntersect :: (Int, Int) -> (Int, Int) -> Bool 39 | intervalsIntersect (a, b) (c, d) = not (b <= c || d <= a) 40 | 41 | -- arguably should use Temporary internally instead of 42 | -- VirtualRegister. fix later! 43 | tryAllocateFunctionRegs 44 | :: Liveness VirtualRegister -> Either [Temporary] Allocation 45 | tryAllocateFunctionRegs liveness = 46 | let intervalMap = computeLivenessIntervals liveness 47 | disallowed = Map.mapWithKey 48 | (\reg _ -> Set.filter 49 | (\dataReg -> 50 | Physical dataReg `Map.member` intervalMap && intervalsIntersect 51 | (intervalMap Map.! reg) 52 | (intervalMap Map.! Physical dataReg) 53 | ) 54 | dataRegisters 55 | ) 56 | intervalMap 57 | (spilled, allocation) = allocate 58 | [] 59 | (Map.fromList (map (\reg -> (fromRegister reg, reg)) specialRegisters)) 60 | -- allocate to smaller live intervals first, hopefully meaning 61 | -- we spill less. also allocate to already-spilled registers 62 | -- first, so we don't spill the same register repeatedly and 63 | -- fall into an infinite loop. 64 | (sortOn 65 | (\reg -> let (start, end) = intervalMap Map.! reg in end - start) 66 | (Map.keys intervalMap) 67 | ) 68 | where 69 | allocate spills allocs [] = (spills, allocs) 70 | allocate spills allocs (cur@(Physical phys) : rst) = 71 | allocate spills (Map.insert cur phys allocs) rst 72 | allocate spills allocs (cur@(Virtual temp) : rst) = 73 | case 74 | let curInterval = intervalMap Map.! cur 75 | conflictingTemps = mapMaybe 76 | (\(otherTemp, otherInterval) -> 77 | if intervalsIntersect curInterval otherInterval 78 | then Just otherTemp 79 | else Nothing 80 | ) 81 | (Map.toList intervalMap) 82 | curDisallowed = foldr 83 | (\conflictingTemp set -> 84 | case Map.lookup conflictingTemp allocs of 85 | Just phys -> Set.insert phys set 86 | Nothing -> set 87 | ) 88 | (disallowed Map.! cur) 89 | conflictingTemps 90 | in Set.lookupMin (dataRegisters Set.\\ curDisallowed) 91 | of 92 | Nothing -> allocate (temp : spills) allocs rst 93 | Just free -> allocate spills (Map.insert cur free allocs) rst 94 | in case spilled of 95 | [] -> Right allocation 96 | _ -> Left spilled 97 | 98 | shouldSpillMem :: Eq reg => reg -> Mem reg -> Bool 99 | shouldSpillMem reg (Mem _ base msi) = 100 | base 101 | == reg 102 | || (case msi of 103 | Nothing -> False 104 | Just (_, idx) -> idx == reg 105 | ) 106 | 107 | spillMem :: Eq reg => reg -> reg -> Mem reg -> Mem reg 108 | spillMem old new (Mem disp base msi) = Mem 109 | disp 110 | (if base == old then new else base) 111 | (((\index -> if index == old then new else index) <$>) <$> msi) 112 | 113 | -- FIXME: spillMem needs to be able to substitute 114 | 115 | spillInstr 116 | :: VirtualRegister 117 | -> Mem VirtualRegister 118 | -> VirtualInstruction 119 | -> Stateful [VirtualInstruction] 120 | spillInstr orig ind (OP op (IR imm reg)) | reg == orig = 121 | return [OP op (IM imm ind)] 122 | spillInstr orig ind (OP op (IM imm mem)) | shouldSpillMem orig mem = do 123 | dir <- newTemp 124 | return [OP MOV $ MR ind dir, OP op (IM imm (spillMem orig dir mem))] 125 | spillInstr orig ind (OP op (RR src dst)) 126 | | src == orig && dst == orig = do 127 | dir <- newTemp 128 | return [OP MOV $ MR ind dir, OP op $ RM dir ind] 129 | | src == orig = return [OP MOV $ MR ind dst] 130 | | dst == orig = return [OP MOV $ RM src ind] 131 | spillInstr orig ind (OP op (MR mem dst)) 132 | | shouldSpillMem orig mem && dst == orig = do 133 | dir <- newTemp 134 | return 135 | [ OP MOV $ MR ind dir 136 | , OP op $ MR (spillMem orig dir mem) dir 137 | , OP MOV $ RM dir ind 138 | ] 139 | | shouldSpillMem orig mem = do 140 | dir <- newTemp 141 | return [OP MOV $ MR ind dir, OP op $ MR (spillMem orig dir mem) dst] 142 | | dst == orig = do 143 | dir <- newTemp 144 | return [OP MOV $ MR (spillMem orig dir mem) dir, OP op $ RM dir ind] 145 | spillInstr orig ind (OP op (RM src mem)) 146 | | shouldSpillMem orig mem = do 147 | dir <- newTemp 148 | return [OP MOV $ MR ind dir, OP op $ RM src (spillMem orig dir mem)] 149 | | src == orig = do 150 | dir <- newTemp 151 | return [OP MOV $ MR ind dir, OP op $ RM dir mem] 152 | spillInstr orig ind (UN op (R dst)) | dst == orig = return [UN op (M ind)] 153 | spillInstr orig ind (UN op (M mem)) | shouldSpillMem orig mem = do 154 | dir <- newTemp 155 | return [OP MOV $ MR ind dir, UN op (M (spillMem orig dir mem))] 156 | spillInstr orig ind (MOVBRM src mem) 157 | | shouldSpillMem orig mem = do 158 | dir <- newTemp 159 | return [OP MOV $ MR ind dir, MOVBRM src (spillMem orig dir mem)] 160 | | src == orig = do 161 | dir <- newTemp 162 | return [OP MOV $ MR ind dir, MOVBRM dir (spillMem orig dir mem)] 163 | spillInstr orig ind (MOVBMR mem dst) 164 | | shouldSpillMem orig mem && dst == orig = do 165 | dir <- newTemp 166 | return 167 | [ OP MOV $ MR ind dir 168 | , MOVBMR (spillMem orig dir mem) dir 169 | , OP MOV $ RM dir ind 170 | ] 171 | | shouldSpillMem orig mem = do 172 | dir <- newTemp 173 | return [OP MOV $ MR ind dir, MOVBMR (spillMem orig dir mem) dst] 174 | | dst == orig = do 175 | dir <- newTemp 176 | return [OP MOV $ MR (spillMem orig dir mem) dir, MOVBRM dir ind] 177 | spillInstr orig ind (MOV64 imm dst) | dst == orig = do 178 | dir <- newTemp 179 | return [MOV64 imm dir, OP MOV $ RM dir ind] 180 | spillInstr orig ind (SHIFT amt op dst) | dst == orig = do 181 | dir <- newTemp 182 | return [OP MOV $ MR ind dir, SHIFT amt op dir, OP MOV $ RM dir ind] 183 | spillInstr orig ind (LEA mem dst) | shouldSpillMem orig mem && dst == orig = do 184 | dir <- newTemp 185 | return 186 | [OP MOV $ MR ind dir, LEA (spillMem orig dir mem) dst, OP MOV $ RM dir ind] 187 | spillInstr orig ind (LEA mem dst) | shouldSpillMem orig mem = do 188 | dir <- newTemp 189 | return [OP MOV $ MR ind dir, LEA (spillMem orig dir mem) dst] 190 | spillInstr orig ind (LEA mem dst) | dst == orig = do 191 | dir <- newTemp 192 | return [LEA (spillMem orig dir mem) dir, OP MOV $ RM dir ind] 193 | spillInstr orig ind (IDIV src) | src == orig = do 194 | dir <- newTemp 195 | return [OP MOV $ MR ind dir, IDIV dir] 196 | spillInstr _ _ instr = return [instr] 197 | 198 | spillFunction 199 | :: VirtualRegister 200 | -> Mem VirtualRegister 201 | -> VirtualFunction 202 | -> Stateful VirtualFunction 203 | spillFunction dir ind (Function name stackSpace instrs) = 204 | Function name stackSpace . concat <$> mapM (spillInstr dir ind) instrs 205 | 206 | spillTemporary 207 | :: Int -> Temporary -> VirtualFunction -> Stateful VirtualFunction 208 | spillTemporary spillIdx temp = spillFunction 209 | (Virtual temp) 210 | (Mem (Right . fromIntegral $ -(spillIdx + 1) * 8) rbp Nothing) 211 | 212 | -- step 1: only do max of 2 passes for liveness analysis 213 | -- step 2: only collect jump-target instructions into the map 214 | -- (otherwise operate on lists in linear time) 215 | 216 | allocateFunctionRegs 217 | :: Set.Set Temporary 218 | -> Liveness VirtualRegister 219 | -> VirtualFunction 220 | -> Stateful (PhysicalFunction, Allocation, Set.Set Temporary) 221 | allocateFunctionRegs allSpilled liveness fn@(Function stackSpace name instrs) = 222 | case tryAllocateFunctionRegs liveness of 223 | Right allocation -> return 224 | ( Function 225 | (stackSpace + length allSpilled * 8) 226 | name 227 | (map 228 | (mapInstr 229 | (\reg -> case reg `Map.lookup` allocation of 230 | Nothing -> error $ "register " ++ show reg ++ " was never live" 231 | Just reg' -> reg' 232 | ) 233 | ) 234 | instrs 235 | ) 236 | , allocation 237 | , allSpilled 238 | ) 239 | Left spilled -> do 240 | fn'@(Function _ fnName instrs') <- foldM 241 | (flip $ uncurry spillTemporary) 242 | fn 243 | (zip (iterate (+ 1) (Set.size allSpilled)) spilled) 244 | let liveness' = assertNoFreeVariables fnName . computeLiveness $ instrs' 245 | allocateFunctionRegs (allSpilled `Set.union` Set.fromList spilled) 246 | liveness' 247 | fn' 248 | 249 | allocateProgramRegs 250 | :: Program VirtualRegister 251 | -> ProgramLiveness VirtualRegister 252 | -> Stateful (Program Register, Allocation, Set.Set Temporary) 253 | allocateProgramRegs (Program main fns datums) liveness = do 254 | let allocate = allocateFunctionRegs Set.empty 255 | (main', mainAllocation, mainSpilled) <- allocate (snd . head $ liveness) main 256 | (fns' , restAllocation, restSpilled) <- 257 | unzip3 <$> zipWithM allocate (map snd . tail $ liveness) fns 258 | let allocation = Map.unions (mainAllocation : restAllocation) 259 | let spilled = Set.unions (mainSpilled : restSpilled) 260 | return (Program main' fns' datums, allocation, spilled) 261 | 262 | showAllocation :: Allocation -> Set.Set Temporary -> String 263 | showAllocation allocation spilled = concatMap 264 | (\(virt, phys) -> 265 | show virt 266 | ++ " -> " 267 | ++ show phys 268 | ++ (case virt of 269 | Virtual temp | temp `Set.member` spilled -> " (spilled)" 270 | _ -> "" 271 | ) 272 | ++ "\n" 273 | ) 274 | (Map.toList allocation) 275 | -------------------------------------------------------------------------------- /src-kalyn/Parser.kalyn: -------------------------------------------------------------------------------- 1 | (import "AST.kalyn") 2 | (import "Instances.kalyn") 3 | (import "Stdlib.kalyn") 4 | (import "Tokens.kalyn") 5 | 6 | (defn withConstraints (Func (Func Form a) Form (Pair (List ClassSpec) a)) 7 | (parseBody form) 8 | (case form 9 | ((RoundList [(Symbol "with") (RoundList specs) body]) 10 | (Pair (map parseClassSpec specs) (parseBody body))) 11 | ((RoundList (Cons (Symbol "with") _)) 12 | (error "failed to parse constraint list\n")) 13 | (_ (Pair [] (parseBody form))))) 14 | 15 | (defn parseTypeSpec (Func Form TypeSpec) 16 | (form) 17 | (case form 18 | ((RoundList (Cons (Symbol name) args)) 19 | (TypeSpec 20 | name 21 | (map 22 | (lambda (arg) 23 | (case arg 24 | ((Symbol argName) argName) 25 | (_ (error "failed to parse type spec argument\n")))) 26 | args))) 27 | ((Symbol name) (TypeSpec name [])) 28 | (_ (error "failed to parse type spec\n")))) 29 | 30 | (defn parseType (Func Form Type) 31 | (form) 32 | (case form 33 | ((RoundList (Cons (Symbol "with") _)) 34 | (let (((Pair specs (Type moreSpecs name args)) 35 | (withConstraints parseType form))) 36 | (Type (append specs moreSpecs) name args))) 37 | ((RoundList (Cons (Symbol "Func") args)) 38 | (foldr1 (lambda (lhs rhs) 39 | (Type [] "Func" [lhs rhs])) 40 | (map parseType args))) 41 | ((RoundList (Cons (Symbol name) args)) 42 | (Type [] name (map parseType args))) 43 | ((Symbol name) 44 | (Type [] name [])) 45 | (_ (error "failed to parse type\n")))) 46 | 47 | (defn parseClassSpec (Func Form ClassSpec) 48 | (form) 49 | (case form 50 | ((RoundList [(Symbol name) (Symbol typ)]) 51 | (ClassSpec name typ)) 52 | (_ (error "failed to parse class spec\n")))) 53 | 54 | (defn scrubGensym (Func String String) 55 | (name) 56 | (case name 57 | ;; hey it works don't judge 58 | ((Cons 'g' (Cons 'e' (Cons 'n' (Cons 's' (Cons 'y' (Cons 'm' _)))))) 59 | (append name "_")) 60 | (_ name))) 61 | 62 | (defn parseExpr (Func Form Expr) 63 | (form) 64 | (case form 65 | ((RoundList []) 66 | (error "round list can't be empty\n")) 67 | ((RoundList (Cons (Symbol "case") (Cons expr branches))) 68 | (Case 69 | (parseExpr expr) 70 | (map 71 | (lambda (br) 72 | (case br 73 | ((RoundList [pat res]) 74 | (Pair (parseExpr pat) (parseExpr res))) 75 | (_ (error "failed to parse case branch\n")))) 76 | branches))) 77 | ((RoundList (Cons (Symbol "do") (Cons (Symbol monadName) items))) 78 | (case items 79 | (Null (error "empty do\n")) 80 | (_ (parseExpr 81 | (foldr1 82 | (lambda (item dbody) 83 | (case item 84 | ((RoundList [(Symbol "let") binding value]) 85 | (RoundList 86 | [(Symbol (append ">>=" monadName)) 87 | (RoundList 88 | [(Symbol (append "return" monadName)) 89 | value]) 90 | (RoundList 91 | [(Symbol "lambda") 92 | (RoundList [binding]) 93 | dbody])])) 94 | ((RoundList [(Symbol "with") binding value]) 95 | (RoundList 96 | [(Symbol (append ">>=" monadName)) 97 | value 98 | (RoundList 99 | [(Symbol "lambda") 100 | (RoundList [binding]) 101 | dbody])])) 102 | (value 103 | (RoundList 104 | [(Symbol (append ">>=" monadName)) 105 | value 106 | (RoundList 107 | [(Symbol "lambda") 108 | (RoundList [(Symbol "_")]) 109 | dbody])])))) 110 | items))))) 111 | ((RoundList [(Symbol "if") cond true false]) 112 | (Case 113 | (parseExpr cond) 114 | [(Pair (Variable "True") (parseExpr true)) 115 | (Pair (Variable "False") (parseExpr false))])) 116 | ((RoundList [(Symbol "lambda") (RoundList _) _]) 117 | ;; translate 'em like this to maximize the number of sublambdas we 118 | ;; can call through in code generation 119 | (let ((uncurryLambdas 120 | (lambda (form) 121 | (case form 122 | ((RoundList [(Symbol "lambda") (RoundList args) body]) 123 | (let (((Pair restArgs innerBody) (uncurryLambdas body))) 124 | (Pair (append args restArgs) innerBody))) 125 | (body (Pair [] body))))) 126 | ((Pair args body) (uncurryLambdas form)) 127 | (gensyms 128 | (map 129 | (lambda (idx) 130 | (append "gensym" (showInt idx))) 131 | (iterate (+ 1) 0 (length args))))) 132 | (foldr 133 | (lambda ((Pair arg gensym) lbody) 134 | (case arg 135 | ((Symbol name) (Lambda (scrubGensym name) lbody)) 136 | (_ (Lambda gensym lbody)))) 137 | (foldr 138 | (lambda ((Pair arg gensym) lbody) 139 | (case arg 140 | ((Symbol _) lbody) 141 | (_ (Case 142 | (Variable gensym) 143 | [(Pair (parseExpr arg) lbody)])))) 144 | (parseExpr body) 145 | (zip args gensyms)) 146 | (zip args gensyms)))) 147 | ((RoundList [(Symbol "let") (RoundList bindings) body]) 148 | (foldr 149 | (lambda (binding lbody) 150 | (case binding 151 | ((RoundList [(Symbol name) val]) 152 | (Let (scrubGensym name) (parseExpr val) lbody)) 153 | ((RoundList [pat val]) 154 | (Let 155 | "gensym" 156 | (parseExpr val) 157 | (Case 158 | (Variable "gensym") 159 | [(Pair (parseExpr pat) lbody)]))))) 160 | (parseExpr body) 161 | bindings)) 162 | ((RoundList (Cons (Symbol "and") (Cons lhs (Cons rhs more@(Cons _ _))))) 163 | (parseExpr 164 | (RoundList [(Symbol "and") lhs 165 | (RoundList (Cons (Symbol "and") (Cons rhs more)))]))) 166 | ((RoundList (Cons (Symbol "or") (Cons lhs (Cons rhs more@(Cons _ _))))) 167 | (parseExpr 168 | (RoundList [(Symbol "or") lhs 169 | (RoundList (Cons (Symbol "or") (Cons rhs more)))]))) 170 | ((RoundList [(Symbol "and") lhs rhs]) 171 | (Let 172 | "gensym" 173 | (parseExpr lhs) 174 | (Case 175 | (Variable "gensym") 176 | [(Pair (Variable "False") (Variable "False")) 177 | (Pair (Variable "True") (parseExpr rhs))]))) 178 | ((RoundList [(Symbol "or") lhs rhs]) 179 | (Let 180 | "gensym" 181 | (parseExpr lhs) 182 | (Case 183 | (Variable "gensym") 184 | [(Pair (Variable "True") (Variable "True")) 185 | (Pair (Variable "False") (parseExpr rhs))]))) 186 | ((RoundList elts) 187 | (foldl1 Call (map parseExpr elts))) 188 | ((SquareList elts) 189 | (parseExpr 190 | (foldr 191 | (lambda (char rest) 192 | (RoundList [(Symbol "Cons") char rest])) 193 | (Symbol "Null") 194 | elts))) 195 | ((Symbol name) 196 | (Variable (scrubGensym name))) 197 | ((IntAtom i) 198 | (Const i)) 199 | ((CharAtom (Char c)) 200 | (parseExpr 201 | (RoundList [(Symbol "Char") (IntAtom c)]))) 202 | ((StrAtom s) 203 | (parseExpr 204 | (SquareList 205 | (map 206 | (lambda (c) 207 | (CharAtom c)) 208 | s)))) 209 | ((At name elt) 210 | (As (scrubGensym name) (parseExpr elt))))) 211 | 212 | (defn parseDecl* (Func Bool Form Decl) 213 | (pub form) 214 | (case form 215 | ((RoundList [(Symbol "alias") spec typ]) 216 | (Alias pub (parseTypeSpec spec) (parseType typ))) 217 | ((RoundList [(Symbol "alias") spec (StrAtom _) typ]) 218 | (Alias pub (parseTypeSpec spec) (parseType typ))) 219 | ((RoundList (Cons (Symbol "class") (Cons spec members))) 220 | (let (((Pair constraints innerSpec) 221 | (withConstraints parseClassSpec spec))) 222 | (Class 223 | pub 224 | constraints 225 | innerSpec 226 | (map 227 | (lambda (m) 228 | (case m 229 | ((RoundList [(Symbol name) typ]) 230 | (Pair name (parseType typ))) 231 | (_ (error "failed to parse class member\n")))) 232 | members)))) 233 | ((RoundList (Cons (Symbol "data") (Cons spec members))) 234 | (let ((members* (case members 235 | ((Cons (StrAtom _) rest) rest) 236 | (_ members)))) 237 | (Data 238 | pub 239 | (parseTypeSpec spec) 240 | (map 241 | (lambda (m) 242 | (case m 243 | ((Symbol name) (Pair name [])) 244 | ((RoundList (Cons (Symbol name) args)) 245 | (Pair name (map parseType args))) 246 | (_ (error "failed to parse data constructor\n")))) 247 | members*)))) 248 | ((RoundList [(Symbol "def") (Symbol name) typ (StrAtom _) expr]) 249 | (Def pub name (parseType typ) (parseExpr expr))) 250 | ((RoundList [(Symbol "def") (Symbol name) typ expr]) 251 | (Def pub name (parseType typ) (parseExpr expr))) 252 | ((RoundList [(Symbol "defn") name typ (StrAtom _) args body]) 253 | (parseDecl* 254 | pub 255 | (RoundList 256 | [(Symbol "def") 257 | name 258 | typ 259 | (RoundList 260 | [(Symbol "lambda") args body])]))) 261 | ((RoundList [(Symbol "defn") name typ args body]) 262 | (parseDecl* 263 | pub 264 | (RoundList 265 | [(Symbol "def") 266 | name 267 | typ 268 | (RoundList 269 | [(Symbol "lambda") args body])]))) 270 | ((RoundList [(Symbol "derive") spec]) 271 | (Derive pub (parseClassSpec spec))) 272 | ((RoundList [(Symbol "import") (StrAtom file)]) 273 | (Import pub file)) 274 | ((RoundList (Cons (Symbol "instance") (Cons spec members))) 275 | (let (((Pair constraints innerSpec) 276 | (withConstraints parseClassSpec spec))) 277 | (Instance 278 | pub 279 | constraints 280 | innerSpec 281 | (map 282 | (lambda (m) 283 | (case m 284 | ((RoundList [(Symbol name) expr]) 285 | (Pair name (parseExpr expr))) 286 | (_ (error "failed to parse instance member\n")))) 287 | members)))) 288 | (_ (error "failed to parse declaration\n")))) 289 | 290 | (defn parseDecl (Func Form Decl) 291 | (form) 292 | (case form 293 | ((RoundList (Cons (Symbol "public") rest)) 294 | (parseDecl* True (RoundList rest))) 295 | (_ (parseDecl* False form)))) 296 | 297 | (public def parseModule (Func (List Form) (List Decl)) 298 | (map parseDecl)) 299 | -------------------------------------------------------------------------------- /scripts/poetry.lock: -------------------------------------------------------------------------------- 1 | [[package]] 2 | name = "cycler" 3 | version = "0.10.0" 4 | description = "Composable style cycles" 5 | category = "main" 6 | optional = false 7 | python-versions = "*" 8 | 9 | [package.dependencies] 10 | six = "*" 11 | 12 | [[package]] 13 | name = "kiwisolver" 14 | version = "1.2.0" 15 | description = "A fast implementation of the Cassowary constraint solver" 16 | category = "main" 17 | optional = false 18 | python-versions = ">=3.6" 19 | 20 | [[package]] 21 | name = "matplotlib" 22 | version = "3.2.1" 23 | description = "Python plotting package" 24 | category = "main" 25 | optional = false 26 | python-versions = ">=3.6" 27 | 28 | [package.dependencies] 29 | cycler = ">=0.10" 30 | kiwisolver = ">=1.0.1" 31 | numpy = ">=1.11" 32 | pyparsing = ">=2.0.1,<2.0.4 || >2.0.4,<2.1.2 || >2.1.2,<2.1.6 || >2.1.6" 33 | python-dateutil = ">=2.1" 34 | 35 | [[package]] 36 | name = "numpy" 37 | version = "1.22.0" 38 | description = "NumPy is the fundamental package for array computing with Python." 39 | category = "main" 40 | optional = false 41 | python-versions = ">=3.8" 42 | 43 | [[package]] 44 | name = "pyparsing" 45 | version = "2.4.7" 46 | description = "Python parsing module" 47 | category = "main" 48 | optional = false 49 | python-versions = ">=2.6, !=3.0.*, !=3.1.*, !=3.2.*" 50 | 51 | [[package]] 52 | name = "python-dateutil" 53 | version = "2.8.1" 54 | description = "Extensions to the standard Python datetime module" 55 | category = "main" 56 | optional = false 57 | python-versions = "!=3.0.*,!=3.1.*,!=3.2.*,>=2.7" 58 | 59 | [package.dependencies] 60 | six = ">=1.5" 61 | 62 | [[package]] 63 | name = "six" 64 | version = "1.14.0" 65 | description = "Python 2 and 3 compatibility utilities" 66 | category = "main" 67 | optional = false 68 | python-versions = ">=2.7, !=3.0.*, !=3.1.*, !=3.2.*" 69 | 70 | [metadata] 71 | lock-version = "1.1" 72 | python-versions = "^3.8" 73 | content-hash = "1fe1adfb6d4aa217278082ae4e36b953b42458b43d83e0b262418e013cf60727" 74 | 75 | [metadata.files] 76 | cycler = [ 77 | {file = "cycler-0.10.0-py2.py3-none-any.whl", hash = "sha256:1d8a5ae1ff6c5cf9b93e8811e581232ad8920aeec647c37316ceac982b08cb2d"}, 78 | {file = "cycler-0.10.0.tar.gz", hash = "sha256:cd7b2d1018258d7247a71425e9f26463dfb444d411c39569972f4ce586b0c9d8"}, 79 | ] 80 | kiwisolver = [ 81 | {file = "kiwisolver-1.2.0-cp36-cp36m-macosx_10_9_x86_64.whl", hash = "sha256:443c2320520eda0a5b930b2725b26f6175ca4453c61f739fef7a5847bd262f74"}, 82 | {file = "kiwisolver-1.2.0-cp36-cp36m-manylinux1_i686.whl", hash = "sha256:efcf3397ae1e3c3a4a0a0636542bcad5adad3b1dd3e8e629d0b6e201347176c8"}, 83 | {file = "kiwisolver-1.2.0-cp36-cp36m-manylinux1_x86_64.whl", hash = "sha256:fccefc0d36a38c57b7bd233a9b485e2f1eb71903ca7ad7adacad6c28a56d62d2"}, 84 | {file = "kiwisolver-1.2.0-cp36-cp36m-manylinux2014_aarch64.whl", hash = "sha256:be046da49fbc3aa9491cc7296db7e8d27bcf0c3d5d1a40259c10471b014e4e0c"}, 85 | {file = "kiwisolver-1.2.0-cp36-none-win32.whl", hash = "sha256:60a78858580761fe611d22127868f3dc9f98871e6fdf0a15cc4203ed9ba6179b"}, 86 | {file = "kiwisolver-1.2.0-cp36-none-win_amd64.whl", hash = "sha256:556da0a5f60f6486ec4969abbc1dd83cf9b5c2deadc8288508e55c0f5f87d29c"}, 87 | {file = "kiwisolver-1.2.0-cp37-cp37m-macosx_10_9_x86_64.whl", hash = "sha256:7cc095a4661bdd8a5742aaf7c10ea9fac142d76ff1770a0f84394038126d8fc7"}, 88 | {file = "kiwisolver-1.2.0-cp37-cp37m-manylinux1_i686.whl", hash = "sha256:c955791d80e464da3b471ab41eb65cf5a40c15ce9b001fdc5bbc241170de58ec"}, 89 | {file = "kiwisolver-1.2.0-cp37-cp37m-manylinux1_x86_64.whl", hash = "sha256:603162139684ee56bcd57acc74035fceed7dd8d732f38c0959c8bd157f913fec"}, 90 | {file = "kiwisolver-1.2.0-cp37-cp37m-manylinux2014_aarch64.whl", hash = "sha256:63f55f490b958b6299e4e5bdac66ac988c3d11b7fafa522800359075d4fa56d1"}, 91 | {file = "kiwisolver-1.2.0-cp37-none-win32.whl", hash = "sha256:03662cbd3e6729f341a97dd2690b271e51a67a68322affab12a5b011344b973c"}, 92 | {file = "kiwisolver-1.2.0-cp37-none-win_amd64.whl", hash = "sha256:4eadb361baf3069f278b055e3bb53fa189cea2fd02cb2c353b7a99ebb4477ef1"}, 93 | {file = "kiwisolver-1.2.0-cp38-cp38-macosx_10_9_x86_64.whl", hash = "sha256:c31bc3c8e903d60a1ea31a754c72559398d91b5929fcb329b1c3a3d3f6e72113"}, 94 | {file = "kiwisolver-1.2.0-cp38-cp38-manylinux1_i686.whl", hash = "sha256:d52b989dc23cdaa92582ceb4af8d5bcc94d74b2c3e64cd6785558ec6a879793e"}, 95 | {file = "kiwisolver-1.2.0-cp38-cp38-manylinux1_x86_64.whl", hash = "sha256:e586b28354d7b6584d8973656a7954b1c69c93f708c0c07b77884f91640b7657"}, 96 | {file = "kiwisolver-1.2.0-cp38-cp38-manylinux2014_aarch64.whl", hash = "sha256:38d05c9ecb24eee1246391820ed7137ac42a50209c203c908154782fced90e44"}, 97 | {file = "kiwisolver-1.2.0-cp38-none-win32.whl", hash = "sha256:d069ef4b20b1e6b19f790d00097a5d5d2c50871b66d10075dab78938dc2ee2cf"}, 98 | {file = "kiwisolver-1.2.0-cp38-none-win_amd64.whl", hash = "sha256:18d749f3e56c0480dccd1714230da0f328e6e4accf188dd4e6884bdd06bf02dd"}, 99 | {file = "kiwisolver-1.2.0.tar.gz", hash = "sha256:247800260cd38160c362d211dcaf4ed0f7816afb5efe56544748b21d6ad6d17f"}, 100 | ] 101 | matplotlib = [ 102 | {file = "matplotlib-3.2.1-cp36-cp36m-macosx_10_9_x86_64.whl", hash = "sha256:e06304686209331f99640642dee08781a9d55c6e32abb45ed54f021f46ccae47"}, 103 | {file = "matplotlib-3.2.1-cp36-cp36m-manylinux1_x86_64.whl", hash = "sha256:ce378047902b7a05546b6485b14df77b2ff207a0054e60c10b5680132090c8ee"}, 104 | {file = "matplotlib-3.2.1-cp36-cp36m-win32.whl", hash = "sha256:2466d4dddeb0f5666fd1e6736cc5287a4f9f7ae6c1a9e0779deff798b28e1d35"}, 105 | {file = "matplotlib-3.2.1-cp36-cp36m-win_amd64.whl", hash = "sha256:f4412241e32d0f8d3713b68d3ca6430190a5e8a7c070f1c07d7833d8c5264398"}, 106 | {file = "matplotlib-3.2.1-cp37-cp37m-macosx_10_9_x86_64.whl", hash = "sha256:e20ba7fb37d4647ac38f3c6d8672dd8b62451ee16173a0711b37ba0ce42bf37d"}, 107 | {file = "matplotlib-3.2.1-cp37-cp37m-manylinux1_x86_64.whl", hash = "sha256:282b3fc8023c4365bad924d1bb442ddc565c2d1635f210b700722776da466ca3"}, 108 | {file = "matplotlib-3.2.1-cp37-cp37m-win32.whl", hash = "sha256:c1cf735970b7cd424502719b44288b21089863aaaab099f55e0283a721aaf781"}, 109 | {file = "matplotlib-3.2.1-cp37-cp37m-win_amd64.whl", hash = "sha256:56d3147714da5c7ac4bc452d041e70e0e0b07c763f604110bd4e2527f320b86d"}, 110 | {file = "matplotlib-3.2.1-cp38-cp38-macosx_10_9_x86_64.whl", hash = "sha256:af14e77829c5b5d5be11858d042d6f2459878f8e296228c7ea13ec1fd308eb68"}, 111 | {file = "matplotlib-3.2.1-cp38-cp38-manylinux1_x86_64.whl", hash = "sha256:aae7d107dc37b4bb72dcc45f70394e6df2e5e92ac4079761aacd0e2ad1d3b1f7"}, 112 | {file = "matplotlib-3.2.1-cp38-cp38-win32.whl", hash = "sha256:d35891a86a4388b6965c2d527b9a9f9e657d9e110b0575ca8a24ba0d4e34b8fc"}, 113 | {file = "matplotlib-3.2.1-cp38-cp38-win_amd64.whl", hash = "sha256:4bb50ee4755271a2017b070984bcb788d483a8ce3132fab68393d1555b62d4ba"}, 114 | {file = "matplotlib-3.2.1-pp373-pypy36_pp73-win32.whl", hash = "sha256:7a9baefad265907c6f0b037c8c35a10cf437f7708c27415a5513cf09ac6d6ddd"}, 115 | {file = "matplotlib-3.2.1.tar.gz", hash = "sha256:ffe2f9cdcea1086fc414e82f42271ecf1976700b8edd16ca9d376189c6d93aee"}, 116 | ] 117 | numpy = [ 118 | {file = "numpy-1.22.0-cp310-cp310-macosx_10_9_universal2.whl", hash = "sha256:3d22662b4b10112c545c91a0741f2436f8ca979ab3d69d03d19322aa970f9695"}, 119 | {file = "numpy-1.22.0-cp310-cp310-macosx_10_9_x86_64.whl", hash = "sha256:11a1f3816ea82eed4178102c56281782690ab5993251fdfd75039aad4d20385f"}, 120 | {file = "numpy-1.22.0-cp310-cp310-macosx_11_0_arm64.whl", hash = "sha256:5dc65644f75a4c2970f21394ad8bea1a844104f0fe01f278631be1c7eae27226"}, 121 | {file = "numpy-1.22.0-cp310-cp310-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:42c16cec1c8cf2728f1d539bd55aaa9d6bb48a7de2f41eb944697293ef65a559"}, 122 | {file = "numpy-1.22.0-cp310-cp310-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:a97e82c39d9856fe7d4f9b86d8a1e66eff99cf3a8b7ba48202f659703d27c46f"}, 123 | {file = "numpy-1.22.0-cp310-cp310-win_amd64.whl", hash = "sha256:e41e8951749c4b5c9a2dc5fdbc1a4eec6ab2a140fdae9b460b0f557eed870f4d"}, 124 | {file = "numpy-1.22.0-cp38-cp38-macosx_10_9_universal2.whl", hash = "sha256:bece0a4a49e60e472a6d1f70ac6cdea00f9ab80ff01132f96bd970cdd8a9e5a9"}, 125 | {file = "numpy-1.22.0-cp38-cp38-macosx_10_9_x86_64.whl", hash = "sha256:818b9be7900e8dc23e013a92779135623476f44a0de58b40c32a15368c01d471"}, 126 | {file = "numpy-1.22.0-cp38-cp38-macosx_11_0_arm64.whl", hash = "sha256:47ee7a839f5885bc0c63a74aabb91f6f40d7d7b639253768c4199b37aede7982"}, 127 | {file = "numpy-1.22.0-cp38-cp38-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:a024181d7aef0004d76fb3bce2a4c9f2e67a609a9e2a6ff2571d30e9976aa383"}, 128 | {file = "numpy-1.22.0-cp38-cp38-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:f71d57cc8645f14816ae249407d309be250ad8de93ef61d9709b45a0ddf4050c"}, 129 | {file = "numpy-1.22.0-cp38-cp38-win32.whl", hash = "sha256:283d9de87c0133ef98f93dfc09fad3fb382f2a15580de75c02b5bb36a5a159a5"}, 130 | {file = "numpy-1.22.0-cp38-cp38-win_amd64.whl", hash = "sha256:2762331de395739c91f1abb88041f94a080cb1143aeec791b3b223976228af3f"}, 131 | {file = "numpy-1.22.0-cp39-cp39-macosx_10_9_universal2.whl", hash = "sha256:76ba7c40e80f9dc815c5e896330700fd6e20814e69da9c1267d65a4d051080f1"}, 132 | {file = "numpy-1.22.0-cp39-cp39-macosx_10_9_x86_64.whl", hash = "sha256:0cfe07133fd00b27edee5e6385e333e9eeb010607e8a46e1cd673f05f8596595"}, 133 | {file = "numpy-1.22.0-cp39-cp39-macosx_11_0_arm64.whl", hash = "sha256:6ed0d073a9c54ac40c41a9c2d53fcc3d4d4ed607670b9e7b0de1ba13b4cbfe6f"}, 134 | {file = "numpy-1.22.0-cp39-cp39-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:41388e32e40b41dd56eb37fcaa7488b2b47b0adf77c66154d6b89622c110dfe9"}, 135 | {file = "numpy-1.22.0-cp39-cp39-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:b55b953a1bdb465f4dc181758570d321db4ac23005f90ffd2b434cc6609a63dd"}, 136 | {file = "numpy-1.22.0-cp39-cp39-win32.whl", hash = "sha256:5a311ee4d983c487a0ab546708edbdd759393a3dc9cd30305170149fedd23c88"}, 137 | {file = "numpy-1.22.0-cp39-cp39-win_amd64.whl", hash = "sha256:a97a954a8c2f046d3817c2bce16e3c7e9a9c2afffaf0400f5c16df5172a67c9c"}, 138 | {file = "numpy-1.22.0-pp38-pypy38_pp73-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:bb02929b0d6bfab4c48a79bd805bd7419114606947ec8284476167415171f55b"}, 139 | {file = "numpy-1.22.0.zip", hash = "sha256:a955e4128ac36797aaffd49ab44ec74a71c11d6938df83b1285492d277db5397"}, 140 | ] 141 | pyparsing = [ 142 | {file = "pyparsing-2.4.7-py2.py3-none-any.whl", hash = "sha256:ef9d7589ef3c200abe66653d3f1ab1033c3c419ae9b9bdb1240a85b024efc88b"}, 143 | {file = "pyparsing-2.4.7.tar.gz", hash = "sha256:c203ec8783bf771a155b207279b9bccb8dea02d8f0c9e5f8ead507bc3246ecc1"}, 144 | ] 145 | python-dateutil = [ 146 | {file = "python-dateutil-2.8.1.tar.gz", hash = "sha256:73ebfe9dbf22e832286dafa60473e4cd239f8592f699aa5adaf10050e6e1823c"}, 147 | {file = "python_dateutil-2.8.1-py2.py3-none-any.whl", hash = "sha256:75bb3f31ea686f1197762692a9ee6a7550b59fc6ca3a1f4b5d7e32fb98e2da2a"}, 148 | ] 149 | six = [ 150 | {file = "six-1.14.0-py2.py3-none-any.whl", hash = "sha256:8f3cd2e254d8f793e7f3d6d9df77b92252b52637291d0f0da013c76ea2724b6c"}, 151 | {file = "six-1.14.0.tar.gz", hash = "sha256:236bdbdce46e6e6a3d61a337c0f8b763ca1e8717c03b369e87a7ec7ce1319c0a"}, 152 | ] 153 | -------------------------------------------------------------------------------- /src-kalyn/Stdlib/Collections/Maps.kalyn: -------------------------------------------------------------------------------- 1 | ;; http://hackage.haskell.org/package/TreeStructures-0.0.2/docs/src/Data-Tree-Splay.html 2 | ;; with bugfix for insert 3 | 4 | (import "../../Stdlib.kalyn") 5 | 6 | (public data (Map k v) 7 | "Key-value map using self-balancing tree. Embeds a comparison 8 | function for the keys. Kept in sorted order by key value." 9 | (Map (Ord k) (Node k v))) 10 | 11 | (data (Node k v) 12 | "Internal tree node." 13 | Leaf (Branch k v Int (Node k v) (Node k v))) 14 | 15 | (public defn mapEmpty (Func (Ord k) (Map k v)) 16 | "Create an empty map with the given comparison function." 17 | (cmp) 18 | (Map cmp Leaf)) 19 | 20 | (public defn mapNull (Func (Map k v) Bool) 21 | "Check if the map is empty (has no elements)." 22 | ((Map _ root)) 23 | (case root 24 | (Leaf True) 25 | ((Branch _ _ _ _ _) False))) 26 | 27 | (defn size (Func (Node k v) Int) 28 | "Return the number of elements in an internal tree node." 29 | (node) 30 | (case node 31 | (Leaf 0) 32 | ((Branch _ _ d _ _) d))) 33 | 34 | (public defn mapSize (Func (Map k v) Int) 35 | "Return the number of elements in the map." 36 | ((Map _ root)) 37 | (size root)) 38 | 39 | (defn lookup (Func (Ord k) k (Node k v) (Node k v)) 40 | "Do a splay lookup on an internal tree node. The provided key will 41 | be splayed to the root of the tree if it's present, otherwise the 42 | nearest node is splayed. Return the new root." 43 | (cmp k* t) 44 | (case t 45 | (Leaf Leaf) 46 | (t@(Branch k _ _ l r) 47 | (case (cmp k k*) 48 | (EQ t) 49 | (GT (case (lookup cmp k* l) 50 | (Leaf t) 51 | (lt (zig lt t)))) 52 | (LT (case (lookup cmp k* r) 53 | (Leaf t) 54 | (rt (zag t rt)))))))) 55 | 56 | (defn zig (Func (Node k v) (Node k v) (Node k v)) 57 | "Do a zig rotation. The first argument is rotated up and the new 58 | root returned." 59 | (left right) 60 | (case (Pair left right) 61 | ((Pair (Branch k1 v1 _ l1 r1) (Branch k v d _ r)) 62 | (Branch k1 v1 d l1 (Branch k v (- (- d (size l1)) 1) r1 r))) 63 | (_ (error "tree corruption\n")))) 64 | 65 | (defn zag (Func (Node k v) (Node k v) (Node k v)) 66 | "Do a zag rotation. The second argument is rotated up and the new 67 | root returned." 68 | (left right) 69 | (case (Pair left right) 70 | ((Pair (Branch k v d l _) (Branch k1 v1 _ l1 r1)) 71 | (Branch k1 v1 d (Branch k v (- (- d (size r1)) 1) l l1) r1)) 72 | (_ (error "tree corruption\n")))) 73 | 74 | ;; XXX: Splay trees are really not appropriate for the implementation 75 | ;; because we need to be able to do a lookup without modifying the 76 | ;; tree. Workaround for now is to just not splay on a lookup and hope 77 | ;; the amortized analysis doesn't break too badly in practice. 78 | (public defn mapLookup (Func k (Map k v) (Maybe v)) 79 | "Try to look up the value for a key. Return Nothing if the key is 80 | not present." 81 | (k (Map cmp t)) 82 | (case (lookup cmp k t) 83 | (Leaf Nothing) 84 | ((Branch k* v _ _ _) 85 | (case (cmp k k*) 86 | (EQ (Just v)) 87 | (_ Nothing))))) 88 | 89 | (defn insert (Func (Ord k) k v (Node k v) (Node k v)) 90 | "Insert a key-value pair into the map, replacing the existing 91 | mapping if one exists. Assume that the key was already splayed to 92 | the top." 93 | (cmp k v t) 94 | (case t 95 | (Leaf (Branch k v 1 Leaf Leaf)) 96 | ((Branch k1 v1 d l r) 97 | (case (cmp k1 k) 98 | (LT (Branch k v (+ d 1) (Branch k1 v1 (+ (- d (size r)) 1) l Leaf) r)) 99 | (GT (Branch k v (+ d 1) l (Branch k1 v1 (+ (- d (size l)) 1) Leaf r))) 100 | (EQ (Branch k v d l r)))))) 101 | 102 | (public defn mapInsert (Func k v (Map k v) (Map k v)) 103 | "Insert a key-value pair into the map, replacing the existing 104 | mapping if one exists." 105 | (k v (Map cmp t)) 106 | (Map 107 | cmp 108 | (insert cmp k v (lookup cmp k t)))) 109 | 110 | (defn nodeHead (Func (Node k v) (Pair k v)) 111 | "Get the key-value pair of the root." 112 | (t) 113 | (case t 114 | (Leaf (error "tree corruption\n")) 115 | ((Branch k v _ _ _) (Pair k v)))) 116 | 117 | (public defn mapHead (Func (Map k v) (Maybe (Pair k v))) 118 | "Get an arbitrary key-value pair from the map." 119 | ((Map _ t)) 120 | (case t 121 | (Leaf Nothing) 122 | ((Branch k v _ _ _) 123 | (Just (Pair k v))))) 124 | 125 | (defn nodeTail (Func (Node k v) (Node k v)) 126 | "Remove the root of the tree and merge its subtrees." 127 | (t) 128 | (case t 129 | (Leaf (error "tree corruption\n")) 130 | ((Branch _ _ _ Leaf r) r) 131 | ((Branch _ _ _ l Leaf) l) 132 | ((Branch _ _ _ l r) 133 | (case (splayRight l) 134 | ((Branch k v d l1 Leaf) 135 | (Branch k v (+ d (size r)) l1 r)) 136 | (_ (error "tree corruption\n")))))) 137 | 138 | (public defn mapDelete (Func k (Map k v) (Map k v)) 139 | "Delete a key from the map if it's present, returning a new map." 140 | (k (Map cmp t)) 141 | (Map 142 | cmp 143 | (case t 144 | (Leaf Leaf) 145 | (_ (case (lookup cmp k t) 146 | (t*@(Branch k1 _ _ _ _) 147 | (case (cmp k k1) 148 | (EQ (nodeTail t*)) 149 | (_ t*))) 150 | (Leaf (error "tree corruption\n"))))))) 151 | 152 | (defn splayRight (Func (Node k v) (Node k v)) 153 | (t) 154 | (case t 155 | (Leaf Leaf) 156 | (h@(Branch _ _ _ _ Leaf) h) 157 | ((Branch k1 v1 d1 l1 (Branch k2 v2 _ l2 r2)) 158 | (splayRight (Branch k2 v2 d1 (Branch k1 v1 (- d1 (size r2)) l1 l2) r2))))) 159 | 160 | (defn splayLeft (Func (Node k v) (Node k v)) 161 | (t) 162 | (case t 163 | (Leaf Leaf) 164 | (h@(Branch _ _ _ Leaf _) h) 165 | ((Branch k1 v1 d1 (Branch k2 v2 _ l2 r2) r1) 166 | (splayLeft (Branch k2 v2 d1 l2 (Branch k1 v1 (- d1 (size l2)) r2 r1)))))) 167 | 168 | (public defn mapFromList (Func (Ord k) (List (Pair k v)) (Map k v)) 169 | "Given an unordered list of key-value pairs, create a map with the 170 | provided comparison function. If the same key appears more than 171 | once then the later one wins." 172 | (cmp) 173 | (foldr (uncurry mapInsert) (mapEmpty cmp))) 174 | 175 | (public defn mapToList (Func (Map k v) (List (Pair k v))) 176 | "Convert a map to a list of its key-value pairs in ascending order." 177 | ((Map _ t)) 178 | (let ((toList (lambda (t) 179 | (case t 180 | (Leaf []) 181 | (h@(Branch _ _ _ Leaf _) 182 | (Cons (nodeHead h) (toList (nodeTail h)))) 183 | (h (toList (splayLeft h))))))) 184 | (toList t))) 185 | 186 | (public defn mapAlter (Func 187 | (Func (Maybe v) (Maybe v)) 188 | k (Map k v) (Map k v)) 189 | (func k (Map cmp t)) 190 | (Map 191 | cmp 192 | (case (lookup cmp k t) 193 | (Leaf 194 | (case (func Nothing) 195 | (Nothing Leaf) 196 | ((Just v) 197 | (Branch k v 1 Leaf Leaf)))) 198 | (br@(Branch k* v* d l r) 199 | (case (cmp k k*) 200 | (EQ (case (func (Just v*)) 201 | (Nothing (nodeTail br)) 202 | ((Just v) (Branch k* v d l r)))) 203 | (_ (case (func Nothing) 204 | (Nothing br) 205 | ((Just v) 206 | (insert cmp k v br))))))))) 207 | 208 | (defn mapWithKey (Func (Func k a b) (Node k a) (Node k b)) 209 | "Map a function over an internal node to produce a new one." 210 | (func node) 211 | (case node 212 | (Leaf Leaf) 213 | ((Branch k a d l r) 214 | (Branch k (func k a) d (mapWithKey func l) (mapWithKey func r))))) 215 | 216 | (public defn mapFromListWithKey 217 | (Func (Ord k) (Func k v v v) (List (Pair k v)) (Map k v)) 218 | "Given an unordered list of key-value pairs, create a map with the 219 | provided comparison function. If the same key appears more than 220 | once then the given combining function is used." 221 | (cmp comb pairs) 222 | (foldr 223 | (lambda ((Pair k v) m) 224 | (mapAlter 225 | (lambda (existing) 226 | (case existing 227 | (Nothing (Just v)) 228 | ((Just v*) (Just (comb k v* v))))) 229 | k m)) 230 | (mapEmpty cmp) 231 | pairs)) 232 | 233 | (public defn mapMapWithKey (Func (Func k a b) (Map k a) (Map k b)) 234 | "Map a function over the values of a map to produce a new map with 235 | the same keys. The mapping function also gets the keys but can't 236 | change them." 237 | (func (Map cmp t)) 238 | (Map cmp (mapWithKey func t))) 239 | 240 | (public defn mapMap (Func (Func a b) (Map k a) (Map k b)) 241 | "Map a function over the values of a map to produce a new map with 242 | the same keys." 243 | (func m) 244 | (mapMapWithKey (const func) m)) 245 | 246 | (public defn mapUnionWithKey 247 | (Func (Func k v v v) (Map k v) (Map k v) (Map k v)) 248 | "Merge two maps with a combining function. The combined map uses the 249 | comparison function from the left-hand map." 250 | (comb left right) 251 | (foldr (lambda ((Pair k rv)) 252 | (mapAlter 253 | (lambda (existing) 254 | (case existing 255 | (Nothing (Just rv)) 256 | ((Just lv) (Just (comb k lv rv))))) 257 | k)) 258 | left 259 | (mapToList right))) 260 | 261 | (public def mapUnion 262 | (Func (Map k v) (Map k v) (Map k v)) 263 | "Left-biased union of two maps. The combined map uses the comparison 264 | function from the left-hand map." 265 | (mapUnionWithKey 266 | (lambda (_ lv _) 267 | lv))) 268 | 269 | (public defn mapUnions 270 | (Func (Ord k) (List (Map k v)) (Map k v)) 271 | "Left-biased union of a list of maps. The provided comparison 272 | function replaces the ones used in the constituent maps." 273 | (cmp) 274 | (foldl mapUnion (mapEmpty cmp))) 275 | 276 | (public def mapKeys (Func (Map k v) (List k)) 277 | "Return the list of keys in a map." 278 | (comp (map fst) mapToList)) 279 | 280 | (public def mapElems (Func (Map k v) (List v)) 281 | "Return the list of values in a map." 282 | (comp (map snd) mapToList)) 283 | 284 | (public defn map\\ (Func (Map k v) (Map k v) (Map k v)) 285 | "Map difference. Remove all the elements of the right-hand map from 286 | the left-hand map." 287 | (left right) 288 | (foldr mapDelete left (mapKeys right))) 289 | 290 | (public defn mapFilter (Func (Func k Bool) (Map k v) (Map k v)) 291 | "Filter a map to only the keys that pass the given predicate." 292 | (pred m@(Map cmp _)) 293 | (mapFromList cmp (filter (comp pred fst) (mapToList m)))) 294 | 295 | (public defn mapMember (Func k (Map k v) Bool) 296 | "Check if the given key is in the map." 297 | (k m) 298 | (case (mapLookup k m) 299 | (Nothing False) 300 | ((Just _) True))) 301 | 302 | (public defn map! (Func k (Map k v) v) 303 | "Get the value for the given key, or throw an error if it's not 304 | present." 305 | (k m) 306 | (case (mapLookup k m) 307 | (Nothing (error "no such key in map\n")) 308 | ((Just v) v))) 309 | 310 | (public defn mapNotMember (Func k (Map k v) Bool) 311 | "Check if the given key is NOT in the map." 312 | (k) 313 | (comp not (mapMember k))) 314 | 315 | (public defn mapSingleton (Func (Ord k) k v (Map k v)) 316 | "Make a map with just one key-value mapping." 317 | (cmp k v) 318 | (mapInsert k v (mapEmpty cmp))) 319 | -------------------------------------------------------------------------------- /src-kalyn/Resolver.kalyn: -------------------------------------------------------------------------------- 1 | (import "AST.kalyn") 2 | (import "Bridge.kalyn") 3 | (import "Stdlib.kalyn") 4 | (import "Util.kalyn") 5 | 6 | (defn mapTypeName (Func (Func TypeName TypeName) TypeName TypeName) 7 | (func name) 8 | (case name 9 | ("IO" "IO") 10 | ("Int" "Int") 11 | ("Func" "Func") 12 | (name@(Cons c _) 13 | (if (isLower c) 14 | name 15 | (func name))) 16 | (_ (func name)))) 17 | 18 | (defn mapTypeSpec (Func (Func TypeName TypeName) TypeSpec TypeSpec) 19 | (func (TypeSpec typeName params)) 20 | (TypeSpec (mapTypeName func typeName) params)) 21 | 22 | (defn mapType (Func (Func TypeName TypeName) Type Type) 23 | (func (Type classSpecs typeName typeArgs)) 24 | (Type classSpecs (mapTypeName func typeName) (map (mapType func) typeArgs))) 25 | 26 | (defn mapSymbol (Func 27 | (Func VarName VarName) 28 | (Func TypeName TypeName) 29 | Symbol 30 | Symbol) 31 | (func tfunc sym) 32 | (case sym 33 | ((SymDef name t num) 34 | (SymDef (func name) (mapType tfunc t) num)) 35 | ((SymData name ctorIdx numFields numCtors boxed typeSpec types) 36 | (SymData 37 | (func name) 38 | ctorIdx 39 | numFields 40 | numCtors 41 | boxed 42 | (mapTypeSpec tfunc typeSpec) 43 | (map (mapType tfunc) types))))) 44 | 45 | (def uniquify (Func (List String) (List String)) 46 | (let ((findUnused* 47 | (lambda (str seen num) 48 | (let ((try (append str (showInt num)))) 49 | (if (setNotMember try seen) 50 | try 51 | (findUnused* str seen (+ num 1)))))) 52 | (findUnused 53 | (lambda (str seen) 54 | (if (setNotMember str seen) 55 | str 56 | (findUnused* str seen 1)))) 57 | (uniquify* 58 | (lambda (seen strs) 59 | (case strs 60 | (Null Null) 61 | ((Cons str strs) 62 | (let ((str* (findUnused str seen))) 63 | (Cons str* (uniquify* (setInsert str* seen) strs)))))))) 64 | (uniquify* (setEmpty compareString)))) 65 | 66 | (defn getComponents (Func FilePath (List String)) 67 | (path) 68 | (reverse (filter notNull (split ==Char '/' path)))) 69 | 70 | (defn sanitizeModuleName (Func Int FilePath FilePath) 71 | (n path) 72 | (sanitize (concat (reverse (take n (getComponents path)))))) 73 | 74 | (defn sanitizeModuleNames (Func (List FilePath) (Map FilePath ModuleAbbr)) 75 | (fullNames) 76 | (let ((maxComponents 77 | (maximum 78 | compareInt 79 | (map 80 | (comp length getComponents) 81 | fullNames))) 82 | (xforms 83 | (append 84 | (map 85 | (lambda (n names) 86 | (map (sanitizeModuleName n) names)) 87 | (iterate (+ 1) 1 maxComponents)) 88 | [(comp uniquify (map (sanitizeModuleName maxComponents)))])) 89 | (bestXForm 90 | (head 91 | (filter 92 | (lambda (xform) 93 | (listUnique 94 | compareString 95 | (xform fullNames))) 96 | xforms)))) 97 | (mapFromList 98 | compareString 99 | (zip fullNames (bestXForm fullNames))))) 100 | 101 | (defn countSublambdas (Func Expr Int) 102 | (expr) 103 | (case expr 104 | ((Lambda _ body) (+ 1 (countSublambdas body))) 105 | (_ 0))) 106 | 107 | ;; for now, doesn't handle Derive or Instance 108 | (defn getDeclSymbols (Func Bool Decl (List Symbol)) 109 | (isMain decl) 110 | (case decl 111 | ((Data pub typeSpec ctors) 112 | (if (or isMain pub) 113 | (zipWith 114 | (lambda ((Pair name types) idx) 115 | (SymData 116 | name 117 | idx 118 | (length types) 119 | (length ctors) 120 | (shouldBox ctors) 121 | typeSpec 122 | types)) 123 | ctors 124 | (iterate (+ 1) 0 (length ctors))) 125 | [])) 126 | ((Def pub name t expr) 127 | (if (or isMain pub) 128 | [(SymDef name t (countSublambdas expr))] 129 | [])) 130 | (_ []))) 131 | 132 | (defn getDeclTypes (Func Bool Decl (List TypeName)) 133 | (isMain decl) 134 | (case decl 135 | ((Data pub (TypeSpec name _) _) 136 | (if (or isMain pub) 137 | [name] 138 | [])) 139 | (_ []))) 140 | 141 | (defn getDeclAliases (Func Bool Decl (List (Pair TypeSpec Type))) 142 | (isMain decl) 143 | (case decl 144 | ((Alias pub typeSpec t) 145 | (if (or isMain pub) 146 | [(Pair typeSpec t)] 147 | [])) 148 | (_ []))) 149 | 150 | (defn mangleWith (Func ModuleAbbr String String) 151 | (modAbbr name) 152 | (concat ["__" modAbbr "__" (sanitize name)])) 153 | 154 | (public defn resolveBundle (Func Bundle Resolver) 155 | ((Bundle _ mmap)) 156 | (let ((modNames 157 | (sanitizeModuleNames (map fst (mapToList mmap)))) 158 | (gTypeMap 159 | (mapMapWithKey 160 | (lambda (mainMod info) 161 | (let ((mods (Cons mainMod (snd info)))) 162 | (mapFromListWithKey 163 | compareString 164 | (lambda (name _) 165 | (error (concat ["more than one definition for type " 166 | name 167 | "\n"]))) 168 | (concatMap 169 | (lambda (mod) 170 | (let ((modAbbr (map! mod modNames)) 171 | (decls (fst (map! mod mmap)))) 172 | (map 173 | (lambda (name) 174 | (Pair name (mangleWith modAbbr name))) 175 | (append 176 | (concatMap 177 | (getDeclTypes (==String mod mainMod)) 178 | decls) 179 | (map (lambda ((Pair (TypeSpec name _) _)) 180 | name) 181 | (concatMap 182 | (getDeclAliases (==String mod mainMod)) 183 | decls)))))) 184 | mods)))) 185 | mmap)) 186 | (gAliasMap 187 | (mapFromListWithKey 188 | compareString 189 | (lambda (name _) 190 | (error (concat ["more than one alias for " 191 | name 192 | "\n"]))) 193 | (concatMap 194 | (lambda ((Pair mod info)) 195 | (let ((modAbbr (map! mod modNames))) 196 | (map 197 | (lambda ((Pair (TypeSpec aliasName params) aliasDefn)) 198 | (Pair 199 | (mangleWith modAbbr aliasName) 200 | (Pair 201 | params 202 | (mapType 203 | (lambda (name) 204 | (case (mapLookup name (map! mod gTypeMap)) 205 | (Nothing 206 | (error (concat ["no such type in alias " 207 | name 208 | "\n"]))) 209 | ((Just name) name))) 210 | aliasDefn)))) 211 | (concatMap 212 | (getDeclAliases True) 213 | (fst info))))) 214 | (mapToList mmap))))) 215 | (Resolver 216 | (mapMapWithKey 217 | (lambda (mainMod info) 218 | (let ((mods (Cons mainMod (snd info))) 219 | (symbolMap 220 | (mapFromListWithKey 221 | compareString 222 | (lambda (name _) 223 | (error (concat ["more than one definition for symbol " 224 | name 225 | "\n"]))) 226 | (append 227 | (concatMap 228 | (lambda (mod) 229 | (let ((modAbbr (map! mod modNames))) 230 | (map 231 | (lambda (sym) 232 | (Pair 233 | (symName sym) 234 | (mapSymbol 235 | (mangleWith modAbbr) 236 | (lambda (name) 237 | (case (mapLookup 238 | name 239 | (map! mod gTypeMap)) 240 | (Nothing 241 | (error (concat ["in module " 242 | mod 243 | ": no such type " 244 | name]))) 245 | ((Just name) name))) 246 | sym))) 247 | (concatMap 248 | (getDeclSymbols (==String mod mainMod)) 249 | (fst (map! mod mmap)))))) 250 | mods) 251 | (map 252 | (lambda ((Pair 253 | publicName 254 | (Quad 255 | privateName 256 | _ ty 257 | numSublambdas))) 258 | (let ((sym (SymDef privateName ty numSublambdas))) 259 | (Pair 260 | publicName 261 | (mapSymbol 262 | id 263 | (lambda (name) 264 | (case (mapLookup name (map! mainMod gTypeMap)) 265 | (Nothing 266 | (error (concat ["in module " 267 | mainMod 268 | ": no such type " 269 | name]))) 270 | ((Just name) name))) 271 | sym)))) 272 | (mapToList stdlibPublic))))) 273 | (visibleAliases 274 | (setFromList 275 | compareString 276 | (concatMap 277 | (lambda (mod) 278 | (let ((modAbbr (map! mod modNames))) 279 | (map 280 | (lambda ((Pair (TypeSpec name _) _)) 281 | (mangleWith modAbbr name)) 282 | (concatMap 283 | (getDeclAliases (==String mod mainMod)) 284 | (fst (map! mod mmap)))))) 285 | mods)))) 286 | (Pair 287 | symbolMap 288 | (mapFilter 289 | (flip setMember visibleAliases) 290 | gAliasMap)))) 291 | mmap)))) 292 | --------------------------------------------------------------------------------