├── .gitignore ├── .travis.yml ├── LICENSE ├── README.rst ├── Setup.hs ├── examples ├── echo.idr ├── hello.idr └── pythag.idr ├── idris-go.cabal ├── libs ├── Go.idr ├── Makefile └── go.ipkg ├── src ├── IRTS │ └── CodegenGo.hs └── Main.hs ├── stack.yaml └── test ├── TestRun.hs ├── ffi ├── expected ├── ffi.idr └── run ├── hello ├── expected ├── hello.idr └── run ├── pythag ├── expected ├── pythag.idr └── run └── tailrec ├── expected ├── run └── tailrec.idr /.gitignore: -------------------------------------------------------------------------------- 1 | cabal.sandbox.config 2 | dist/ 3 | *.ibc 4 | *.pyc 5 | .stack-work 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: go 3 | go: 4 | - stable 5 | - tip 6 | cache: 7 | directories: 8 | - $HOME/.stack 9 | 10 | before_install: 11 | # Download and unpack the stack executable 12 | - mkdir -p ~/.local/bin 13 | - export PATH=$HOME/.local/bin:$PATH 14 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 15 | 16 | install: 17 | # Unfortunately, travis_wait doesn't pass arguments along correctly (see 18 | # https://github.com/travis-ci/travis-ci/issues/7020), hence we use sleep 19 | # instead of the real command 20 | - travis_wait 60 sleep 3600 & 21 | - stack --no-terminal --install-ghc test --only-dependencies --ghc-options="+RTS -M1g -A16M -RTS -j1 -O0 -H64M" -j3 22 | 23 | script: 24 | - stack --no-terminal test 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Andreas Stührk 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. -------------------------------------------------------------------------------- /README.rst: -------------------------------------------------------------------------------- 1 | ======== 2 | idris-go 3 | ======== 4 | 5 | A `Go `_ backend for `Idris `_. 6 | 7 | 8 | What is working 9 | =============== 10 | 11 | * Calling Go from Idris (see ``examples/echo.idr`` for an echo server) 12 | * Tail calls are implemented with ``goto`` if self-recursive and with a 13 | trampoline otherwise, hence arbitrary deep tail calls should work. 14 | 15 | See the ``examples`` directory for some examples. 16 | 17 | What is not working 18 | =================== 19 | 20 | * Calling Idris from Go 21 | * Not every of Idris `primitive functions` is implemented. The use of an 22 | unimplemented primitive function will result in a panic at runtime. 23 | 24 | 25 | Building from source 26 | ==================== 27 | 28 | Easiest with `Stack `_. `See 29 | their documentation for details how to install it 30 | `_. 31 | 32 | Assuming you have stack installed, then you can simply do:: 33 | 34 | stack build 35 | 36 | To run the tests, execute:: 37 | 38 | stack test 39 | 40 | 41 | Translating Idris programs to Go 42 | ================================ 43 | 44 | :: 45 | 46 | stack exec idris -- -p go --codegen go examples/hello.idr -o hello.go 47 | 48 | 49 | License 50 | ======= 51 | 52 | MIT/Expat. See ``LICENSE`` for details. 53 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import qualified Distribution.Simple.Program as P 2 | import qualified Distribution.Simple.Setup as S 3 | 4 | import Distribution.Simple 5 | 6 | make verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "make" 7 | buildGoLibs _ flags _ _ = do 8 | let verbosity = S.fromFlag $ S.buildVerbosity flags 9 | putStrLn "Building libraries..." 10 | make verbosity ["-C", "libs", "build" ] 11 | installGoLibs verbosity = do 12 | putStrLn "Installing libraries..." 13 | make verbosity ["-C", "libs", "install" ] 14 | 15 | main = defaultMainWithHooks $ simpleUserHooks 16 | { postBuild = buildGoLibs 17 | , postCopy = \_ flags pkg local -> 18 | installGoLibs (S.fromFlag $ S.copyVerbosity flags) 19 | , postInst = \_ flags pkg local -> 20 | installGoLibs (S.fromFlag $ S.installVerbosity flags) 21 | } 22 | -------------------------------------------------------------------------------- /examples/echo.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Go 4 | 5 | -- XXX make it total 6 | 7 | %include Go "bufio" 8 | %include Go "net" 9 | 10 | go : GIO () -> GIO () 11 | go action = gocall (Function "Go") (Raw (GIO ()) -> GIO ()) (MkRaw action) 12 | 13 | Listener : Type 14 | Listener = GoInterface "net.Listener" 15 | 16 | Conn : Type 17 | Conn = GoInterface "net.Conn" 18 | 19 | Addr : Type 20 | Addr = GoInterface "net.Addr" 21 | 22 | implementation Show Addr where 23 | show addr = unsafePerformIO $ gocall (Method addr "String") (Addr -> GIO String) addr 24 | 25 | GoError : Type 26 | GoError = GoInterface "error" 27 | 28 | toEither : (a, Maybe GoError) -> Either GoError a 29 | toEither (_, Just e) = Left e 30 | toEither (x, Nothing) = Right x 31 | 32 | errorDesc : GoError -> String 33 | errorDesc error = unsafePerformIO $ gocall (Method error "Error") (GoError -> GIO String) error 34 | 35 | accept : Listener -> GIO (Either GoError Conn) 36 | accept listener = 37 | map toEither $ gocall (Method listener "Accept") (Listener -> GIO (Conn, Maybe GoError)) listener 38 | 39 | listen : String -> String -> GIO (Either GoError Listener) 40 | listen net laddr = 41 | map toEither $ gocall (Function "net.Listen") 42 | (String -> String -> GIO (Listener, Maybe GoError)) 43 | net laddr 44 | 45 | remoteAddr : Conn -> Addr 46 | remoteAddr conn = 47 | unsafePerformIO $ gocall (Method conn "RemoteAddr") (Conn -> GIO Addr) conn 48 | 49 | Reader : Type 50 | Reader = GoInterface "bufio.Reader" 51 | 52 | Writer : Type 53 | Writer = GoInterface "bufio.Writer" 54 | 55 | -- XXX should be a reader, not a Conn 56 | newReader : Conn -> GIO Reader 57 | newReader conn = do 58 | (MkGoPtr val) <- gocall (Function "bufio.NewReader") (Conn -> GIO (GoPtr Reader)) conn 59 | pure val 60 | 61 | newWriter : Conn -> GIO Writer 62 | newWriter conn = do 63 | (MkGoPtr val) <- gocall (Function "bufio.NewWriter") (Conn -> GIO (GoPtr Writer)) conn 64 | pure val 65 | 66 | readString : Reader -> Byte -> GIO (Either GoError String) 67 | readString reader delim = map toEither $ 68 | gocall (Method reader "ReadString") (Reader -> Byte -> GIO (String, Maybe GoError)) reader delim 69 | 70 | writeString : Writer -> String -> GIO (Int, Maybe GoError) 71 | writeString writer s = 72 | gocall (Method writer "WriteString") (Writer -> String -> GIO (Int, Maybe GoError)) writer s 73 | 74 | flush : Writer -> GIO (Maybe GoError) 75 | flush writer = gocall (Method writer "Flush") (Writer -> GIO (Maybe GoError)) writer 76 | 77 | echoServer : Listener -> GIO () 78 | echoServer listener = 79 | do Right conn <- accept listener 80 | | Left e => putStrLn' ("Accepting went wrong: " ++ errorDesc e) 81 | putStrLn' $ "Got a client! It's " ++ show (remoteAddr conn) 82 | go $ do 83 | reader <- newReader conn 84 | writer <- newWriter conn 85 | handleLine reader writer 86 | echoServer listener 87 | where 88 | handleLine : Reader -> Writer -> GIO () 89 | handleLine reader writer = do 90 | Right line <- readString reader (MkByte '\n') 91 | | Left e => putStrLn' ("Could not read line: " ++ errorDesc e) 92 | (_, Nothing) <- writeString writer line 93 | | (_, Just e) => putStrLn' ("Could not send line back: " ++ errorDesc e) 94 | flush writer 95 | handleLine reader writer 96 | 97 | 98 | main : GIO () 99 | main = do 100 | Right listener <- listen "tcp" ":1234" 101 | | Left e => putStrLn' ("Could not create listener: " ++ errorDesc e) 102 | echoServer listener 103 | -------------------------------------------------------------------------------- /examples/hello.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Data.Vect 4 | import Go 5 | 6 | %default total 7 | 8 | -- XXX why is that required 9 | partial 10 | go : GIO () -> GIO () 11 | go action = gocall (Function "Go") (Raw (GIO ()) -> GIO ()) (MkRaw action) 12 | 13 | -- Some easy string functions to test the FFI 14 | 15 | out : String -> GIO () 16 | out s = gocall (Function "print") (String -> GIO ()) s 17 | 18 | -- %include will be translated to imports 19 | %include Go "strings" 20 | upper : String -> String 21 | upper s = unsafePerformIO $ 22 | gocall (Function "strings.ToUpper") (String -> GIO String) s 23 | 24 | trim : String -> String -> String 25 | trim s cutset = unsafePerformIO $ 26 | gocall (Function "strings.Trim") (String -> String -> GIO String) s cutset 27 | 28 | 29 | -- Some other Idris niceties 30 | 31 | fourInts : Vect 4 Int 32 | fourInts = [428, 1, 2, 3] 33 | 34 | isEven : Nat -> Bool 35 | isEven Z = True 36 | isEven (S k) = not (isEven k) 37 | 38 | forLoop : List a -> (a -> GIO ()) -> GIO () 39 | forLoop [] f = pure () 40 | forLoop (x :: xs) f = do 41 | f x 42 | forLoop xs f 43 | 44 | syntax for {x} "in" [xs] ":" [body] = forLoop xs (\x => body) 45 | 46 | 47 | partial 48 | main : GIO () 49 | main = do 50 | go $ for x in [1..10]: 51 | putStrLn' $ "Hello from goroutine " ++ show x 52 | out "foo\n" 53 | print' (isEven 4) 54 | putStrLn' "" 55 | print' fourInts 56 | 57 | for x in [1..20]: 58 | putStrLn' $ "Hello from main " ++ show x 59 | 60 | putStrLn' $ upper "foo" 61 | putStrLn' $ trim "foobar" "fr" 62 | -------------------------------------------------------------------------------- /examples/pythag.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | pythag : Int -> List (Int, Int, Int) 4 | pythag max = [ 5 | (x, y, z) 6 | | z <- [1..max] 7 | , y <- [1..z] 8 | , x <- [1..y] 9 | , x * x + y *y == z * z 10 | ] 11 | 12 | main : IO () 13 | main = printLn $ pythag 500 14 | -------------------------------------------------------------------------------- /idris-go.cabal: -------------------------------------------------------------------------------- 1 | Name: idris-go 2 | Version: 0.0.0.1 3 | License: MIT 4 | License-file: LICENSE 5 | Author: Andreas Stührk 6 | Maintainer: Andreas Stührk 7 | Build-Type: Custom 8 | Cabal-Version: >= 1.8 9 | 10 | custom-setup 11 | setup-depends: base, Cabal 12 | 13 | Executable idris-codegen-go 14 | Main-is: Main.hs 15 | hs-source-dirs: src 16 | 17 | Build-depends: idris 18 | , base 19 | , containers 20 | , directory 21 | , filepath 22 | , formatting 23 | , haskeline >= 0.7 24 | , mtl 25 | , process 26 | , transformers 27 | , text 28 | 29 | other-modules: IRTS.CodegenGo 30 | , Paths_idris_go 31 | 32 | if os(linux) 33 | cpp-options: -DLINUX 34 | build-depends: unix < 2.8 35 | if os(freebsd) 36 | cpp-options: -DFREEBSD 37 | build-depends: unix < 2.8 38 | if os(dragonfly) 39 | cpp-options: -DDRAGONFLY 40 | build-depends: unix < 2.8 41 | if os(darwin) 42 | cpp-options: -DMACOSX 43 | build-depends: unix < 2.8 44 | if os(windows) 45 | cpp-options: -DWINDOWS 46 | build-depends: Win32 < 2.4 47 | 48 | ghc-prof-options: -auto-all -caf-all 49 | ghc-options: -threaded -rtsopts -funbox-strict-fields 50 | 51 | Test-suite end-to-end-tests 52 | Type: exitcode-stdio-1.0 53 | Main-is: TestRun.hs 54 | hs-source-dirs: test 55 | 56 | Build-depends: base 57 | , bytestring 58 | , directory 59 | , filepath 60 | , process 61 | , tasty 62 | , tasty-golden >= 2.0 63 | , utf8-string 64 | 65 | ghc-prof-options: -auto-all -caf-all 66 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -funbox-strict-fields -------------------------------------------------------------------------------- /libs/Go.idr: -------------------------------------------------------------------------------- 1 | module Go 2 | 3 | public export 4 | data GoInterface : String -> Type where 5 | MkInterface : (iface : String) -> GoInterface iface 6 | 7 | public export 8 | data Go_FFI_Call = Function String 9 | | Method (GoInterface iface) String 10 | 11 | public export 12 | data GoPtr : (a : Type) -> Type where -- XXX limit to Go_Types? 13 | MkGoPtr : (x : a) -> GoPtr a 14 | 15 | ||| A byte 16 | public export 17 | data Byte : Type where 18 | MkByte : (ch : Char) -> Byte 19 | 20 | %used MkByte ch 21 | 22 | mutual 23 | 24 | ||| Go foreign types 25 | public export 26 | data Go_Types : Type -> Type where 27 | Go_Byte : Go_Types Byte 28 | Go_Int : Go_Types Int 29 | Go_Str : Go_Types String 30 | Go_Unit : Go_Types () 31 | Go_Interface : Go_Types (GoInterface a) 32 | Go_Nilable : Go_Types a -> Go_Types (Maybe a) 33 | Go_Ptr : Go_Types a -> Go_Types (GoPtr a) 34 | Go_Any : Go_Types (FFI_C.Raw a) 35 | -- Note that this is actually only valid as return value 36 | Go_MultiVal : (Go_Types a, Go_Types b) -> Go_Types (a, b) 37 | 38 | public export 39 | FFI_Go : FFI 40 | FFI_Go = MkFFI Go_Types Go_FFI_Call String 41 | 42 | public export 43 | GIO : Type -> Type 44 | GIO = IO' FFI_Go 45 | 46 | public export 47 | %inline 48 | gocall : (f : Go_FFI_Call) -> (ty : Type) -> {auto fty : FTy FFI_Go [] ty} -> ty 49 | gocall f ty = foreign FFI_Go f ty 50 | -------------------------------------------------------------------------------- /libs/Makefile: -------------------------------------------------------------------------------- 1 | build: 2 | idris --build go.ipkg 3 | 4 | install: 5 | idris --install go.ipkg 6 | 7 | .PHONY: build install 8 | -------------------------------------------------------------------------------- /libs/go.ipkg: -------------------------------------------------------------------------------- 1 | package go 2 | 3 | modules = Go 4 | -------------------------------------------------------------------------------- /src/IRTS/CodegenGo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module IRTS.CodegenGo (codegenGo) where 4 | 5 | import Control.Monad.Trans.State.Strict (State, evalState, gets) 6 | import Data.Char (isAlphaNum, ord) 7 | import Data.Int (Int64) 8 | import qualified Data.Map.Strict as M 9 | import Data.Maybe (fromMaybe, mapMaybe) 10 | import qualified Data.Set as S 11 | import qualified Data.Text as T 12 | import qualified Data.Text.IO as TIO 13 | import Formatting (int, sformat, stext, string, 14 | (%)) 15 | import System.IO (IOMode (..), withFile) 16 | import System.Process (CreateProcess (..), 17 | StdStream (..), 18 | createProcess, proc, 19 | waitForProcess) 20 | 21 | import Idris.Core.TT hiding (V, arity) 22 | import IRTS.CodegenCommon 23 | import IRTS.Lang (FDesc (..), FType (..), 24 | LVar (..), PrimFn (..)) 25 | import IRTS.Simplified 26 | 27 | 28 | data Line = Line (Maybe Var) [Var] T.Text 29 | deriving (Show) 30 | 31 | data Var = RVal | V Int 32 | deriving (Show, Eq, Ord) 33 | 34 | newtype CGState = CGState { requiresTrampoline :: Name -> Bool 35 | } 36 | 37 | type CG a = State CGState a 38 | 39 | createCgState :: (Name -> Bool) -> CGState 40 | createCgState trampolineLookup = CGState { requiresTrampoline = trampolineLookup } 41 | 42 | goPreamble :: [T.Text] -> T.Text 43 | goPreamble imports = T.unlines $ 44 | [ "// THIS FILE IS AUTOGENERATED! DO NOT EDIT" 45 | , "" 46 | , "package main" 47 | , "" 48 | , "import (" 49 | , " \"flag\"" 50 | , " \"log\"" 51 | , " \"math/big\"" 52 | , " \"os\"" 53 | , " \"strconv\"" 54 | , " \"unicode/utf8\"" 55 | , " \"unsafe\"" 56 | , " \"runtime\"" 57 | , " \"runtime/pprof\"" 58 | , ")" 59 | , "" 60 | ] ++ map ("import " `T.append`) imports ++ 61 | [ "" 62 | , "func BigIntFromString(s string) *big.Int {" 63 | , " value, _ := big.NewInt(0).SetString(s, 10)" 64 | , " return value" 65 | , "}" 66 | , "" 67 | , "type Con0 struct {" 68 | , " tag int" 69 | , "}" 70 | , "" 71 | , "type Con1 struct {" 72 | , " tag int" 73 | , " _0 unsafe.Pointer" 74 | , "}" 75 | , "" 76 | , "type Con2 struct {" 77 | , " tag int" 78 | , " _0, _1 unsafe.Pointer" 79 | , "}" 80 | , "" 81 | , "type Con3 struct {" 82 | , " tag int" 83 | , " _0, _1, _2 unsafe.Pointer" 84 | , "}" 85 | , "" 86 | , "type Con4 struct {" 87 | , " tag int" 88 | , " _0, _1, _2, _3 unsafe.Pointer" 89 | , "}" 90 | , "" 91 | , "type Con5 struct {" 92 | , " tag int" 93 | , " _0, _1, _2, _3, _4 unsafe.Pointer" 94 | , "}" 95 | , "" 96 | , "type Con6 struct {" 97 | , " tag int" 98 | , " _0, _1, _2, _3, _4, _5 unsafe.Pointer" 99 | , "}" 100 | , "" 101 | , "var nullCons [256]Con0" 102 | , "" 103 | , "func GetTag(con unsafe.Pointer) int {" 104 | , " return (*Con0)(con).tag" 105 | , "}" 106 | , "" 107 | , "func MkCon0(tag int) unsafe.Pointer {" 108 | , " return unsafe.Pointer(&Con0{tag})" 109 | , "}" 110 | , "" 111 | , "func MkCon1(tag int, _0 unsafe.Pointer) unsafe.Pointer {" 112 | , " return unsafe.Pointer(&Con1{tag, _0})" 113 | , "}" 114 | , "" 115 | , "func MkCon2(tag int, _0, _1 unsafe.Pointer) unsafe.Pointer {" 116 | , " return unsafe.Pointer(&Con2{tag, _0, _1})" 117 | , "}" 118 | , "" 119 | , "func MkCon3(tag int, _0, _1, _2 unsafe.Pointer) unsafe.Pointer {" 120 | , " return unsafe.Pointer(&Con3{tag, _0, _1, _2})" 121 | , "}" 122 | , "" 123 | , "func MkCon4(tag int, _0, _1, _2, _3 unsafe.Pointer) unsafe.Pointer {" 124 | , " return unsafe.Pointer(&Con4{tag, _0, _1, _2, _3})" 125 | , "}" 126 | , "" 127 | , "func MkCon5(tag int, _0, _1, _2, _3, _4 unsafe.Pointer) unsafe.Pointer {" 128 | , " return unsafe.Pointer(&Con5{tag, _0, _1, _2, _3, _4})" 129 | , "}" 130 | , "" 131 | , "func MkCon6(tag int, _0, _1, _2, _3, _4, _5 unsafe.Pointer) unsafe.Pointer {" 132 | , " return unsafe.Pointer(&Con6{tag, _0, _1, _2, _3, _4, _5})" 133 | , "}" 134 | , "" 135 | , "func MkIntFromBool(value bool) unsafe.Pointer {" 136 | , " if value {" 137 | , " return intOne" 138 | , " } else {" 139 | , " return intZero" 140 | , " }" 141 | , "}" 142 | , "" 143 | , "func MkInt(value int64) unsafe.Pointer {" 144 | , " var retVal *int64 = new(int64)" 145 | , " *retVal = value" 146 | , " return unsafe.Pointer(retVal)" 147 | , "}" 148 | , "" 149 | , "func MkRune(value rune) unsafe.Pointer {" 150 | , " var retVal *rune = new(rune)" 151 | , " *retVal = value" 152 | , " return unsafe.Pointer(retVal)" 153 | , "}" 154 | , "" 155 | , "func MkString(value string) unsafe.Pointer {" 156 | , " var retVal *string = new(string)" 157 | , " *retVal = value" 158 | , " return unsafe.Pointer(retVal)" 159 | , "}" 160 | , "" 161 | , "func RuneAtIndex(s string, index int) rune {" 162 | , " if index == 0 {" 163 | , " chr, _ := utf8.DecodeRuneInString(s)" 164 | , " return chr" 165 | , " } else {" 166 | , " i := 0" 167 | , " for _, chr := range s {" 168 | , " if i == index {" 169 | , " return chr" 170 | , " }" 171 | , " i++" 172 | , " }" 173 | , " }" 174 | , "panic(\"Illegal index: \" + string(index))" 175 | , "}" 176 | , "" 177 | , "func StrTail(s string) string {" 178 | , " _, offset := utf8.DecodeRuneInString(s)" 179 | , " return s[offset:]" 180 | , "}" 181 | , "" 182 | , "func WriteStr(str unsafe.Pointer) unsafe.Pointer {" 183 | , " _, err := os.Stdout.WriteString(*(*string)(str))" 184 | , " if (err != nil) {" 185 | , " return intZero" 186 | , " } else {" 187 | , " return intMinusOne" 188 | , " }" 189 | , "}" 190 | , "" 191 | , "func Go(action unsafe.Pointer) {" 192 | , " var th Thunk" 193 | , " go Trampoline(MkThunk2(&th, APPLY0, action, nil))" 194 | , "}" 195 | , "" 196 | , "func MkMaybe(value unsafe.Pointer, present bool) unsafe.Pointer {" 197 | , " if present {" 198 | , " return MkCon1(1, value)" 199 | , " } else {" 200 | , " return unsafe.Pointer(&nullCons[0])" 201 | , " }" 202 | , "}" 203 | , "" 204 | , "type Thunk0 func(*Thunk) unsafe.Pointer" 205 | , "type Thunk1 func(*Thunk, unsafe.Pointer) unsafe.Pointer" 206 | , "type Thunk2 func(*Thunk, unsafe.Pointer, unsafe.Pointer) unsafe.Pointer" 207 | , "type Thunk3 func(*Thunk, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer) unsafe.Pointer" 208 | , "type Thunk4 func(*Thunk, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer) unsafe.Pointer" 209 | , "type Thunk5 func(*Thunk, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer) unsafe.Pointer" 210 | , "type Thunk6 func(*Thunk, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer) unsafe.Pointer" 211 | , "type Thunk7 func(*Thunk, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer, unsafe.Pointer) unsafe.Pointer" 212 | , "" 213 | , "type Thunk struct {" 214 | , " arity int8" 215 | , " f0 Thunk0" 216 | , " f1 Thunk1" 217 | , " f2 Thunk2" 218 | , " f3 Thunk3" 219 | , " f4 Thunk4" 220 | , " f5 Thunk5" 221 | , " f6 Thunk6" 222 | , " f7 Thunk7" 223 | , " _0, _1, _2, _3, _4, _5, _6 unsafe.Pointer" 224 | , "}" 225 | , "" 226 | , "func (t *Thunk) Run() unsafe.Pointer {" 227 | , " switch t.arity {" 228 | , " case 0:" 229 | , " return t.f0(t)" 230 | , " case 1:" 231 | , " return t.f1(t, t._0)" 232 | , " case 2:" 233 | , " return t.f2(t, t._0, t._1)" 234 | , " case 3:" 235 | , " return t.f3(t, t._0, t._1, t._2)" 236 | , " case 4:" 237 | , " return t.f4(t, t._0, t._1, t._2, t._3)" 238 | , " case 5:" 239 | , " return t.f5(t, t._0, t._1, t._2, t._3, t._4,)" 240 | , " case 6:" 241 | , " return t.f6(t, t._0, t._1, t._2, t._3, t._4, t._5)" 242 | , " case 7:" 243 | , " return t.f7(t, t._0, t._1, t._2, t._3, t._4, t._5, t._6)" 244 | , " }" 245 | , " panic(\"Invalid arity: \" + string(t.arity))" 246 | , "}" 247 | , "" 248 | , "func MkThunk0(th *Thunk, f Thunk0) *Thunk {" 249 | , " th.arity = 0" 250 | , " th.f0 = f" 251 | , " return th" 252 | , "}" 253 | , "" 254 | , "func MkThunk1(th *Thunk, f Thunk1, _0 unsafe.Pointer) *Thunk {" 255 | , " th.arity = 1" 256 | , " th.f1 = f" 257 | , " th._0 = _0" 258 | , " return th" 259 | , "}" 260 | , "" 261 | , "func MkThunk2(th *Thunk, f Thunk2, _0, _1 unsafe.Pointer) *Thunk {" 262 | , " th.arity = 2" 263 | , " th.f2 = f" 264 | , " th._0 = _0" 265 | , " th._1 = _1" 266 | , " return th" 267 | , "}" 268 | , "" 269 | , "func MkThunk3(th *Thunk, f Thunk3, _0, _1, _2 unsafe.Pointer) *Thunk {" 270 | , " th.arity = 3" 271 | , " th.f3 = f" 272 | , " th._0 = _0" 273 | , " th._1 = _1" 274 | , " th._2 = _2" 275 | , " return th" 276 | , "}" 277 | , "" 278 | , "func MkThunk4(th *Thunk, f Thunk4, _0, _1, _2, _3 unsafe.Pointer) *Thunk {" 279 | , " th.arity = 4" 280 | , " th.f4 = f" 281 | , " th._0 = _0" 282 | , " th._1 = _1" 283 | , " th._2 = _2" 284 | , " th._3 = _3" 285 | , " return th" 286 | , "}" 287 | , "" 288 | , "func MkThunk5(th *Thunk, f Thunk5, _0, _1, _2, _3, _4 unsafe.Pointer) *Thunk {" 289 | , " th.arity = 5" 290 | , " th.f5 = f" 291 | , " th._0 = _0" 292 | , " th._1 = _1" 293 | , " th._2 = _2" 294 | , " th._3 = _3" 295 | , " th._4 = _4" 296 | , " return th" 297 | , "}" 298 | , "" 299 | , "func MkThunk6(th *Thunk, f Thunk6, _0, _1, _2, _3, _4, _5 unsafe.Pointer) *Thunk {" 300 | , " th.arity = 6" 301 | , " th.f6 = f" 302 | , " th._0 = _0" 303 | , " th._1 = _1" 304 | , " th._2 = _2" 305 | , " th._3 = _3" 306 | , " th._4 = _4" 307 | , " th._5 = _5" 308 | , " return th" 309 | , "}" 310 | , "" 311 | , "func MkThunk7(th *Thunk, f Thunk7, _0, _1, _2, _3, _4, _5, _6 unsafe.Pointer) *Thunk {" 312 | , " th.arity = 7" 313 | , " th.f7 = f" 314 | , " th._0 = _0" 315 | , " th._1 = _1" 316 | , " th._2 = _2" 317 | , " th._3 = _3" 318 | , " th._4 = _4" 319 | , " th._5 = _5" 320 | , " th._6 = _6" 321 | , " return th" 322 | , "}" 323 | , "" 324 | , "func Trampoline(th *Thunk) unsafe.Pointer {" 325 | , " var result unsafe.Pointer" 326 | , " for th.arity >= 0 {" 327 | , " result = th.Run()" 328 | , " }" 329 | , " return result" 330 | , "}" 331 | , "" 332 | , "func initNullCons() {" 333 | , " for i := 0; i < 256; i++ {" 334 | , " nullCons[i] = Con0{i}" 335 | , " }" 336 | , "}" 337 | , "" 338 | , "var bigZero *big.Int = big.NewInt(0)" 339 | , "var bigOne *big.Int = big.NewInt(1)" 340 | , "var intMinusOne unsafe.Pointer = MkInt(-1)" 341 | , "var intZero unsafe.Pointer = MkInt(0)" 342 | , "var intOne unsafe.Pointer = MkInt(1)" 343 | , "" 344 | -- This solely exists so the strconv import is used even if the program 345 | -- doesn't use the LIntStr primitive. 346 | , "func __useStrconvImport() string {" 347 | , " return strconv.Itoa(-42)" 348 | , "}" 349 | , "" 350 | ] 351 | 352 | 353 | mangleName :: Name -> T.Text 354 | mangleName name = T.concat $ map mangleChar (showCG name) 355 | where 356 | mangleChar x 357 | | isAlphaNum x = T.singleton x 358 | | otherwise = sformat ("_" % int % "_") (ord x) 359 | 360 | nameToGo :: Name -> T.Text 361 | nameToGo (MN i n) | T.all (\x -> isAlphaNum x || x == '_') n = 362 | n `T.append` T.pack (show i) 363 | nameToGo n = mangleName n 364 | 365 | lVarToGo :: LVar -> T.Text 366 | lVarToGo (Loc i) = sformat ("_" % int) i 367 | lVarToGo (Glob n) = nameToGo n 368 | 369 | lVarToVar :: LVar -> Var 370 | lVarToVar (Loc i) = V i 371 | lVarToVar v = error $ "LVar not convertible to var: " ++ show v 372 | 373 | varToGo :: Var -> T.Text 374 | varToGo RVal = "__rval" 375 | varToGo (V i) = sformat ("_" % int) i 376 | 377 | assign :: Var -> T.Text -> T.Text 378 | assign RVal x = "__thunk.arity = -1; " `T.append` varToGo RVal `T.append` " = " `T.append` x 379 | assign var x = varToGo var `T.append` " = " `T.append` x 380 | 381 | exprToGo :: Name -> Var -> SExp -> CG [Line] 382 | 383 | exprToGo f var SNothing = return . return $ Line (Just var) [] (assign var "nil") 384 | 385 | exprToGo _ var (SConst i@BI{}) 386 | | i == BI 0 = return [ Line (Just var) [] (assign var "unsafe.Pointer(bigZero)") ] 387 | | i == BI 1 = return [ Line (Just var) [] (assign var "unsafe.Pointer(bigOne)") ] 388 | | otherwise = return 389 | [ Line (Just var) [] (assign var (sformat ("unsafe.Pointer(" % stext % ")") (constToGo i))) ] 390 | exprToGo f var (SConst c@Ch{}) = return . return $ mkVal var c (sformat ("MkRune(" % stext % ")")) 391 | exprToGo _ var (SConst i@I{}) 392 | | i == I (-1) = return . return $ Line (Just var) [] (assign var "intMinusOne") 393 | | i == I 0 = return . return $ Line (Just var) [] (assign var "intZero") 394 | | i == I 1 = return . return $ Line (Just var) [] (assign var "intOne") 395 | | otherwise = return . return $ mkVal var i (sformat ("MkInt(" % stext % ")")) 396 | exprToGo f var (SConst s@Str{}) = return . return $ mkVal var s (sformat ("MkString(" % stext % ")")) 397 | 398 | exprToGo _ (V i) (SV (Loc j)) 399 | | i == j = return [] 400 | exprToGo _ var (SV (Loc i)) = return [ Line (Just var) [V i] (assign var (lVarToGo (Loc i))) ] 401 | 402 | exprToGo f var (SLet (Loc i) e sc) = do 403 | a <- exprToGo f (V i) e 404 | b <- exprToGo f var sc 405 | return $ a ++ b 406 | 407 | exprToGo f var (SApp True name vs) 408 | -- self call, simply goto to the entry again 409 | | f == name = return $ 410 | [ Line (Just (V i)) [ V a ] (sformat ("_" % int % " = _" % int) i a) | (i, Loc a) <- zip [0..] vs, i /= a ] ++ 411 | [ Line Nothing [ ] "goto entry" ] 412 | exprToGo f RVal (SApp True name vs) = do 413 | trampolined <- fmap ($ name) (gets requiresTrampoline) 414 | let args = T.intercalate ", " ("__thunk" : map lVarToGo vs) 415 | code = if trampolined 416 | then mkThunk name vs 417 | else assign RVal (nameToGo name `T.append` "(" `T.append` args `T.append` ")") 418 | return [ Line (Just RVal) [ V i | (Loc i) <- vs ] code ] 419 | exprToGo _ var (SApp True _ _) = error $ "Tail-recursive call, but should be assigned to " ++ show var 420 | exprToGo _ var (SApp False name vs) = do 421 | -- Not a tail call, but we might call a function that needs to be trampolined 422 | trampolined <- fmap ($ name) (gets requiresTrampoline) 423 | let code = if trampolined 424 | then assign var (sformat ("Trampoline(" % stext % ")") (mkThunk name vs)) 425 | else assign var (sformat (stext % "(" % stext % ")") (nameToGo name) args) 426 | return [ Line (Just var) [ V i | (Loc i) <- vs ] code ] 427 | where 428 | args = T.intercalate ", " ("__thunk" : map lVarToGo vs) 429 | 430 | exprToGo f var (SCase up (Loc l) alts) 431 | | isBigIntConst alts = constBigIntCase f var (V l) (dedupDefaults alts) 432 | | isConst alts = constCase f var (V l) alts 433 | | otherwise = conCase f var (V l) alts 434 | where 435 | isBigIntConst (SConstCase (BI _) _ : _) = True 436 | isBigIntConst _ = False 437 | 438 | isConst [] = False 439 | isConst (SConstCase _ _ : _) = True 440 | isConst (SConCase{} : _) = False 441 | isConst (_ : _) = False 442 | 443 | dedupDefaults (d@SDefaultCase{} : [SDefaultCase{}]) = [d] 444 | dedupDefaults (x : xs) = x : dedupDefaults xs 445 | dedupDefaults [] = [] 446 | 447 | exprToGo f var (SChkCase (Loc l) alts) = conCase f var (V l) alts 448 | 449 | exprToGo f var (SCon _ tag name args) = return . return $ 450 | Line (Just var) [ V i | (Loc i) <- args] (comment `T.append` assign var mkCon) 451 | where 452 | comment = "// " `T.append` (T.pack . show) name `T.append` "\n" 453 | mkCon 454 | | tag < 256 && null args = sformat ("unsafe.Pointer(&nullCons[" % int % "])") tag 455 | | otherwise = 456 | let argsCode = case args of 457 | [] -> T.empty 458 | _ -> ", " `T.append` T.intercalate ", " (map lVarToGo args) 459 | in sformat ("MkCon" % int % "(" % int % stext % ")") (length args) tag argsCode 460 | 461 | exprToGo f var (SOp prim args) = return . return $ primToGo var prim args 462 | 463 | exprToGo f var (SForeign ty (FApp callType callTypeArgs) args) = 464 | let call = toCall callType callTypeArgs 465 | in return . return $ Line Nothing [] (retVal (fDescToGoType ty) call) 466 | where 467 | convertedArgs = [ toArg (fDescToGoType t) (lVarToGo l) | (t, l) <- args] 468 | 469 | toCall ct [ FStr fname ] 470 | | ct == sUN "Function" = T.pack fname `T.append` "(" `T.append` T.intercalate ", " convertedArgs `T.append` ")" 471 | toCall ct [ FStr _, _, FStr methodName ] 472 | | ct == sUN "Method" = 473 | let obj : args = convertedArgs in 474 | sformat (stext % "." % string % "(" % stext % ")") 475 | obj methodName (T.intercalate ", " args) 476 | toCall ct a = error $ show ct ++ " " ++ show a 477 | 478 | toArg (GoInterface name) x = sformat ("(*(*" % string % ")(" % stext % "))") name x 479 | toArg GoByte x = "byte(*(*rune)(" `T.append` x `T.append` "))" 480 | toArg GoString x = "*(*string)(" `T.append` x `T.append` ")" 481 | toArg GoAny x = x 482 | toArg f _ = error $ "Not implemented yet: toArg " ++ show f 483 | 484 | ptrFromRef x = "unsafe.Pointer(&" `T.append` x `T.append` ")" 485 | toPtr (GoInterface _) x = ptrFromRef x 486 | toPtr GoInt x = ptrFromRef x 487 | toPtr GoString x = ptrFromRef x 488 | toPtr (GoNilable valueType) x = 489 | sformat ("MkMaybe(" % stext % ", " % stext % " != nil)" ) 490 | (toPtr valueType x) x 491 | retRef ty x = 492 | sformat ("{ __tmp := " % stext % "\n " % stext % " = " % stext % " }") 493 | x (varToGo var) (toPtr ty "__tmp") 494 | 495 | retVal GoUnit x = x 496 | retVal GoString x = retRef GoString x 497 | retVal (i@GoInterface{}) x = retRef i x 498 | retVal (n@GoNilable{}) x = retRef n x 499 | retVal (GoMultiVal varTypes) x = 500 | -- XXX assumes exactly two vars 501 | sformat ("{ " % stext % " := " % stext % "\n " % stext % " = MkCon" % int % "(0, " % stext % ") }") 502 | (T.intercalate ", " [ sformat ("__tmp" % int) i | i <- [1..length varTypes]]) 503 | x 504 | (varToGo var) 505 | (length varTypes) 506 | (T.intercalate ", " [ toPtr varTy (sformat ("__tmp" % int) i) | (i, varTy) <- zip [1 :: Int ..] varTypes ]) 507 | retVal (GoPtr _) x = sformat (stext % " = unsafe.Pointer(" % stext % ")") (varToGo var) x 508 | retVal t _ = error $ "Not implemented yet: retVal " ++ show t 509 | 510 | exprToGo _ _ expr = error $ "Not implemented yet: " ++ show expr 511 | 512 | 513 | data GoType = GoByte 514 | | GoInt 515 | | GoString 516 | | GoNilable GoType 517 | | GoInterface String 518 | | GoUnit 519 | | GoMultiVal [GoType] 520 | | GoPtr GoType 521 | | GoAny 522 | deriving (Show) 523 | 524 | fDescToGoType :: FDesc -> GoType 525 | fDescToGoType (FCon c) 526 | | c == sUN "Go_Byte" = GoByte 527 | | c == sUN "Go_Int" = GoInt 528 | | c == sUN "Go_Str" = GoString 529 | | c == sUN "Go_Unit" = GoUnit 530 | fDescToGoType (FApp c [ FStr name ]) 531 | | c == sUN "Go_Interface" = GoInterface name 532 | fDescToGoType (FApp c [ _ ]) 533 | | c == sUN "Go_Any" = GoAny 534 | fDescToGoType (FApp c [ _, ty ]) 535 | | c == sUN "Go_Nilable" = GoNilable (fDescToGoType ty) 536 | fDescToGoType (FApp c [ _, _, FApp c2 [ _, _, a, b ] ]) 537 | | c == sUN "Go_MultiVal" && c2 == sUN "MkPair" = GoMultiVal [ fDescToGoType a, fDescToGoType b ] 538 | fDescToGoType (FApp c [ _, ty ]) 539 | | c == sUN "Go_Ptr" = GoPtr (fDescToGoType ty) 540 | fDescToGoType f = error $ "Not implemented yet: fDescToGoType " ++ show f 541 | 542 | 543 | toFunType :: FDesc -> FType 544 | toFunType (FApp c [ _, _ ]) 545 | | c == sUN "Go_FnBase" = FFunction 546 | | c == sUN "Go_FnIO" = FFunctionIO 547 | toFunType desc = error $ "Not implemented yet: toFunType " ++ show desc 548 | 549 | mkThunk :: Name -> [LVar] -> T.Text 550 | mkThunk f [] = 551 | sformat ("MkThunk0(__thunk, " % stext % ")") (nameToGo f) 552 | mkThunk f args = 553 | sformat ("MkThunk" % int % "(__thunk, " % stext % ", " % stext % ")") 554 | (length args) (nameToGo f) (T.intercalate "," (map lVarToGo args)) 555 | 556 | mkVal :: Var -> Const -> (T.Text -> T.Text) -> Line 557 | mkVal var c factory = 558 | Line (Just var) [] (assign var (factory (constToGo c))) 559 | 560 | constToGo :: Const -> T.Text 561 | constToGo (BI i) 562 | | i == 0 = "bigZero" 563 | | i == 1 = "bigOne" 564 | | i < toInteger (maxBound :: Int64) && i > toInteger (minBound :: Int64) = 565 | "big.NewInt(" `T.append` T.pack (show i) `T.append` ")" 566 | | otherwise = 567 | "BigIntFromString(\"" `T.append` T.pack (show i) `T.append` "\")" 568 | constToGo (Ch '\DEL') = "'\\x7F'" 569 | constToGo (Ch '\SO') = "'\\x0e'" 570 | constToGo (Str s) = T.pack (show s) 571 | constToGo constVal = T.pack (show constVal) 572 | 573 | -- Special case for big.Ints, as we need to compare with Cmp there 574 | constBigIntCase :: Name -> Var -> Var -> [SAlt] -> CG [Line] 575 | constBigIntCase f var v alts = do 576 | cases <- traverse case_ alts 577 | return $ 578 | [ Line Nothing [] "switch {" ] ++ concat cases ++ [ Line Nothing [] "}" ] 579 | where 580 | valueCmp other = sformat ("(*big.Int)(" % stext % ").Cmp(" % stext % ") == 0") (varToGo v) (constToGo other) 581 | case_ (SConstCase constVal expr) = do 582 | code <- exprToGo f var expr 583 | return $ Line Nothing [v] (sformat ("case " % stext % ":") (valueCmp constVal)) : code 584 | case_ (SDefaultCase expr) = do 585 | code <- exprToGo f var expr 586 | return $ Line Nothing [] "default:" : code 587 | case_ c = error $ "Unexpected big int case: " ++ show c 588 | 589 | constCase :: Name -> Var -> Var -> [SAlt] -> CG [Line] 590 | constCase f var v alts = do 591 | cases <- traverse case_ alts 592 | return $ [ Line Nothing [v] (T.concat [ "switch " , castValue alts , " {" ]) 593 | ] ++ concat cases ++ [ Line Nothing [] "}" ] 594 | where 595 | castValue (SConstCase (Ch _) _ : _) = "*(*rune)(" `T.append` varToGo v `T.append` ")" 596 | castValue (SConstCase (I _) _ : _) = "*(*int64)(" `T.append` varToGo v `T.append` ")" 597 | castValue (SConstCase constVal _ : _) = error $ "Not implemented: cast for " ++ show constVal 598 | castValue _ = error "First alt not a SConstCase!" 599 | 600 | case_ (SDefaultCase expr) = do 601 | code <- exprToGo f var expr 602 | return $ Line Nothing [] "default:" : code 603 | case_ (SConstCase constVal expr) = do 604 | code <- exprToGo f var expr 605 | return $ 606 | Line Nothing [] (T.concat [ "case " , constToGo constVal , ":" ]) : code 607 | case_ c = error $ "Unexpected const case: " ++ show c 608 | 609 | 610 | conCase :: Name -> Var -> Var -> [SAlt] -> CG [Line] 611 | conCase f var v [ SDefaultCase expr ] = exprToGo f var expr 612 | conCase f var v alts = do 613 | cases <- traverse case_ alts 614 | return $ [ Line Nothing [v] (T.concat [ "switch GetTag(" , varToGo v , ") {" ]) 615 | ] ++ concat cases ++ [ Line Nothing [] "}" ] 616 | where 617 | project left i = 618 | Line (Just left) [v] 619 | (assign left (sformat ("(*Con" % int % ")(" % stext % ")._" % int) (i+1) (varToGo v) i)) 620 | case_ (SConCase base tag name args expr) = do 621 | let locals = [base .. base + length args - 1] 622 | projections = [ project (V i) (i - base) | i <- locals ] 623 | code <- exprToGo f var expr 624 | return $ [ Line Nothing [] (sformat ("case " % int % ":\n // Projection of " % stext) tag (nameToGo name)) 625 | ] ++ projections ++ code 626 | case_ (SDefaultCase expr) = do 627 | code <- exprToGo f var expr 628 | return $ Line Nothing [] "default:" : code 629 | case_ c = error $ "Unexpected con case: " ++ show c 630 | 631 | 632 | primToGo :: Var -> PrimFn -> [LVar] -> Line 633 | primToGo var (LChInt ITNative) [ch] = 634 | let code = "MkInt(int64(*(*rune)(" `T.append` lVarToGo ch `T.append` ")))" 635 | in Line (Just var) [ lVarToVar ch ] (assign var code) 636 | primToGo var (LEq (ATInt ITChar)) [left, right] = 637 | let code = T.concat [ "MkIntFromBool(*(*rune)(" 638 | , lVarToGo left 639 | , ") == *(*rune)(" 640 | , lVarToGo right 641 | , "))" 642 | ] 643 | in Line (Just var) [ lVarToVar left, lVarToVar right ] (assign var code) 644 | primToGo var (LEq (ATInt ITNative)) [left, right] = 645 | let code = T.concat [ "MkIntFromBool(*(*int64)(" 646 | , lVarToGo left 647 | , ") == *(*int64)(" 648 | , lVarToGo right 649 | , "))" 650 | ] 651 | in Line (Just var) [ lVarToVar left, lVarToVar right ] (assign var code) 652 | primToGo var (LEq (ATInt ITBig)) [left, right] = 653 | let code = T.concat [ "MkIntFromBool((*big.Int)(" 654 | , lVarToGo left 655 | , ").Cmp((*big.Int)(" 656 | , lVarToGo right 657 | , ")) == 0)" 658 | ] 659 | in Line (Just var) [ lVarToVar left, lVarToVar right ] (assign var code) 660 | primToGo var (LSLt (ATInt ITChar)) [left, right] = 661 | let code = T.concat [ "MkIntFromBool(*(*rune)(" 662 | , lVarToGo left 663 | , ") < *(*rune)(" 664 | , lVarToGo right 665 | , "))" 666 | ] 667 | in Line (Just var) [ lVarToVar left, lVarToVar right ] (assign var code) 668 | primToGo var (LSLt (ATInt ITNative)) [left, right] = 669 | let code = T.concat [ varToGo var 670 | , " = MkIntFromBool(*(*int64)(" 671 | , lVarToGo left 672 | , ") < *(*int64)(" 673 | , lVarToGo right 674 | , "))" 675 | ] 676 | in Line (Just var) [ lVarToVar left, lVarToVar right ] code 677 | primToGo var (LSLt (ATInt ITBig)) [left, right] = 678 | let code = T.concat [ "MkIntFromBool((*big.Int)(" 679 | , lVarToGo left 680 | , ").Cmp((*big.Int)(" 681 | , lVarToGo right 682 | , ")) < 0)" 683 | ] 684 | in Line (Just var) [ lVarToVar left, lVarToVar right ] (assign var code) 685 | primToGo var (LMinus (ATInt ITNative)) [left, right] = nativeIntBinOp var left right "-" 686 | primToGo var (LMinus (ATInt ITBig)) [left, right] = bigIntBigOp var left right "Sub" 687 | primToGo var (LPlus (ATInt ITNative)) [left, right] = nativeIntBinOp var left right "+" 688 | primToGo var (LPlus (ATInt ITBig)) [left, right] = bigIntBigOp var left right "Add" 689 | primToGo var (LSExt ITNative ITBig) [i] = 690 | let code = "unsafe.Pointer(big.NewInt(*(*int64)(" `T.append` lVarToGo i `T.append` ")))" 691 | in Line (Just var) [ lVarToVar i ] (assign var code) 692 | primToGo var (LIntStr ITBig) [i] = 693 | let code = "MkString((*big.Int)(" `T.append` lVarToGo i `T.append` ").String())" 694 | in Line (Just var) [ lVarToVar i ] (assign var code) 695 | primToGo var (LIntStr ITNative) [i] = 696 | let code = "MkString(strconv.FormatInt(*(*int64)(" `T.append` lVarToGo i `T.append` "), 10))" 697 | in Line (Just var) [ lVarToVar i ] (assign var code) 698 | primToGo var LStrEq [left, right] = 699 | let code = T.concat [ "MkIntFromBool(*(*string)(" 700 | , lVarToGo left 701 | , ") == *(*string)(" 702 | , lVarToGo right 703 | , "))" 704 | ] 705 | in Line (Just var) [ lVarToVar left, lVarToVar right ] (assign var code) 706 | primToGo var LStrCons [c, s] = 707 | let code = T.concat [ "MkString(string(*(*rune)(" 708 | , lVarToGo c 709 | , ")) + *(*string)(" 710 | , lVarToGo s 711 | , "))" 712 | ] 713 | in Line (Just var) [ lVarToVar c, lVarToVar s ] (assign var code) 714 | primToGo var LStrHead [s] = 715 | let code = "MkRune(RuneAtIndex(*(*string)(" `T.append` lVarToGo s `T.append` "), 0))" 716 | in Line (Just var) [ lVarToVar s ] (assign var code) 717 | primToGo var LStrTail [s] = 718 | let code = "MkString(StrTail(*(*string)(" `T.append` lVarToGo s `T.append` ")))" 719 | in Line (Just var) [ lVarToVar s ] (assign var code) 720 | primToGo var LStrConcat [left, right] = 721 | let code = T.concat [ "MkString(*(*string)(" 722 | , lVarToGo left 723 | , ") + *(*string)(" 724 | , lVarToGo right 725 | , "))" 726 | ] 727 | in Line (Just var) [ lVarToVar left, lVarToVar right ] (assign var code) 728 | primToGo var LWriteStr [world, s] = 729 | let code = "WriteStr(" `T.append` lVarToGo s `T.append` ")" 730 | in Line (Just var) [ lVarToVar world, lVarToVar s ] (assign var code) 731 | primToGo var (LTimes (ATInt ITNative)) [left, right] = nativeIntBinOp var left right "*" 732 | primToGo var (LTimes (ATInt ITBig)) [left, right] = bigIntBigOp var left right "Mul" 733 | primToGo _ fn _ = Line Nothing [] (sformat ("panic(\"Unimplemented PrimFn: " % string % "\")") (show fn)) 734 | 735 | bigIntBigOp :: Var -> LVar -> LVar -> T.Text -> Line 736 | bigIntBigOp var left right op = 737 | let code = T.concat [ "unsafe.Pointer(new(big.Int)." 738 | , op 739 | , "((*big.Int)(" 740 | , lVarToGo left 741 | , "), (*big.Int)(" 742 | , lVarToGo right 743 | , ")))" 744 | ] 745 | in Line (Just var) [ lVarToVar left, lVarToVar right ] (assign var code) 746 | 747 | nativeIntBinOp :: Var -> LVar -> LVar -> T.Text -> Line 748 | nativeIntBinOp var left right op = 749 | let code = T.concat [ "MkInt(*(*int64)(" 750 | , lVarToGo left 751 | , ") " 752 | , op 753 | , " *(*int64)(" 754 | , lVarToGo right 755 | , "))" 756 | ] 757 | in Line (Just var) [ lVarToVar left, lVarToVar right ] (assign var code) 758 | 759 | 760 | data TailCall = Self 761 | | Other 762 | deriving (Eq, Show) 763 | 764 | containsTailCall :: Name -> SExp -> [TailCall] 765 | containsTailCall self (SApp True n _) = if self == n 766 | then [ Self ] 767 | else [ Other ] 768 | containsTailCall self (SLet _ a b) = containsTailCall self a ++ containsTailCall self b 769 | containsTailCall self (SUpdate _ e) = containsTailCall self e 770 | containsTailCall self (SCase _ _ alts) = concatMap (altContainsTailCall self) alts 771 | containsTailCall self (SChkCase _ alts) = concatMap (altContainsTailCall self) alts 772 | containsTailCall _ _ = [] 773 | 774 | altContainsTailCall :: Name -> SAlt -> [TailCall] 775 | altContainsTailCall self (SConCase _ _ _ _ e) = containsTailCall self e 776 | altContainsTailCall self (SConstCase _ e) = containsTailCall self e 777 | altContainsTailCall self (SDefaultCase e) = containsTailCall self e 778 | 779 | 780 | extractUsedVars :: [Line] -> S.Set Var 781 | extractUsedVars lines = S.fromList (concat [used | Line _ used _ <- lines]) 782 | 783 | filterUnusedLines :: [Line] -> [Line] 784 | filterUnusedLines lines = 785 | let usedVars = extractUsedVars lines 786 | requiredLines = mapMaybe (required usedVars) lines 787 | in if length lines /= length requiredLines 788 | -- the filtered lines might have made some other lines obsolete, filter again 789 | then filterUnusedLines requiredLines 790 | else lines 791 | where 792 | required _ l@(Line Nothing _ _) = Just l 793 | required _ l@(Line (Just RVal) _ _) = Just l 794 | required usedVars l@(Line (Just v) _ _) = 795 | if S.member v usedVars 796 | then Just l 797 | else Nothing 798 | 799 | 800 | funToGo :: (Name, SDecl, [TailCall]) -> CG T.Text 801 | funToGo (name, SFun _ args locs expr, tailCalls) = do 802 | bodyLines <- filterUnusedLines <$> exprToGo name RVal expr 803 | let usedVars = extractUsedVars bodyLines 804 | pure . T.concat $ 805 | [ "// " 806 | , T.pack $ show name 807 | , "\nfunc " 808 | , nameToGo name 809 | , "(" 810 | , "__thunk *Thunk" `T.append` if (not . null) args then ", " else T.empty 811 | , T.intercalate ", " [ sformat ("_" % int % " unsafe.Pointer") i | i <- [0..length args-1]] 812 | , ") unsafe.Pointer {\n var __rval unsafe.Pointer\n" 813 | , reserve usedVars locs 814 | , tailCallEntry 815 | , T.unlines [ line | Line _ _ line <- bodyLines ] 816 | , "return __rval\n}\n\n" 817 | ] 818 | where 819 | tailCallEntry = if Self `elem` tailCalls 820 | then "entry:" 821 | else T.empty 822 | loc usedVars i = 823 | let i' = length args + i in 824 | if S.member (V i') usedVars 825 | then Just $ sformat ("_" % int) i' 826 | else Nothing 827 | reserve usedVars locs = case mapMaybe (loc usedVars) [0..locs] of 828 | [] -> T.empty 829 | usedLocs -> " var " `T.append` T.intercalate ", " usedLocs `T.append` " unsafe.Pointer\n" 830 | 831 | genMain :: T.Text 832 | genMain = T.unlines 833 | [ "var cpuprofile = flag.String(\"cpuprofile\", \"\", \"write cpu profile `file`\")" 834 | , "var memprofile = flag.String(\"memprofile\", \"\", \"write memory profile to `file`\")" 835 | , "" 836 | , "func main() {" 837 | , " flag.Parse()" 838 | , " initNullCons()" 839 | , " if *cpuprofile != \"\" {" 840 | , " f, err := os.Create(*cpuprofile)" 841 | , " if err != nil {" 842 | , " log.Fatal(\"Could not create CPU profile: \", err)" 843 | , " }" 844 | , " if err := pprof.StartCPUProfile(f); err != nil {" 845 | , " log.Fatal(\"Could not start CPU profile: \", err)" 846 | , " }" 847 | , " defer pprof.StopCPUProfile()" 848 | , " }" 849 | , " var thunk Thunk" 850 | , " runMain0(&thunk)" 851 | , " if *memprofile != \"\" {" 852 | , " f, err := os.Create(*memprofile)" 853 | , " if err != nil {" 854 | , " log.Fatal(\"Could not create memory profile: \", err)" 855 | , " }" 856 | , " runtime.GC()" 857 | , " if err := pprof.WriteHeapProfile(f); err != nil {" 858 | , " log.Fatal(\"Could not write memory profile: \", err)" 859 | , " }" 860 | , " f.Close()" 861 | , " }" 862 | , "}" 863 | ] 864 | 865 | codegenGo :: CodeGenerator 866 | codegenGo ci = do 867 | let funs = [ (name, fun, containsTailCall name expr) 868 | | (name, fun@(SFun _ _ _ expr)) <- simpleDecls ci 869 | ] 870 | needsTrampolineByName = M.fromList [ (name, Other `elem` tailCalls) 871 | | (name, _, tailCalls) <- funs 872 | ] 873 | trampolineLookup = fromMaybe False . (`M.lookup` needsTrampolineByName) 874 | funCodes = evalState (traverse funToGo funs) (createCgState trampolineLookup) 875 | code = T.concat [ goPreamble (map (T.pack . show) (includes ci)) 876 | , T.concat funCodes 877 | , genMain 878 | ] 879 | withFile (outputFile ci) WriteMode $ \hOut -> do 880 | (Just hIn, _, _, p) <- 881 | createProcess (proc "gofmt" [ "-s" ]){ std_in = CreatePipe, std_out = UseHandle hOut } 882 | TIO.hPutStr hIn code 883 | _ <- waitForProcess p 884 | return () 885 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Idris.AbsSyntax 4 | import Idris.Core.TT 5 | import Idris.ElabDecls 6 | import Idris.Main 7 | import Idris.Options 8 | import IRTS.CodegenGo 9 | import IRTS.Compiler 10 | 11 | import Util.System 12 | 13 | import Paths_idris_go 14 | 15 | import Control.Monad 16 | import System.Environment 17 | import System.Exit 18 | 19 | 20 | 21 | data Opts = Opts { inputs :: [FilePath], 22 | output :: FilePath } 23 | 24 | showUsage = do putStrLn "A code generator which is intended to be called by the compiler, not by a user." 25 | putStrLn "Usage: idris-codegen-c [-o ]" 26 | exitSuccess 27 | 28 | getOpts :: IO Opts 29 | getOpts = do xs <- getArgs 30 | return $ process (Opts [] "a.out") xs 31 | where 32 | process opts ("-o":o:xs) = process (opts { output = o }) xs 33 | process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs 34 | process opts [] = opts 35 | 36 | c_main :: Opts -> Idris () 37 | c_main opts = do runIO setupBundledCC 38 | elabPrims 39 | loadInputs (inputs opts) Nothing 40 | mainProg <- elabMain 41 | ir <- compile (Via IBCFormat "go") (output opts) (Just mainProg) 42 | runIO $ codegenGo ir 43 | 44 | main :: IO () 45 | main = do opts <- getOpts 46 | if (null (inputs opts)) 47 | then showUsage 48 | else runMain (c_main opts) 49 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.18 2 | 3 | packages: 4 | - location: . 5 | - location: 6 | git: https://github.com/idris-lang/Idris-dev.git 7 | commit: master 8 | extra-dep: true 9 | flags: 10 | idris: 11 | FFI: false 12 | GMP: true 13 | 14 | nix: 15 | enable: false 16 | shell-file: stack-shell.nix 17 | -------------------------------------------------------------------------------- /test/TestRun.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad (filterM, when) 4 | import qualified Data.ByteString.Lazy as BS 5 | import qualified Data.ByteString.Lazy.UTF8 as BSU 6 | import System.Directory (doesDirectoryExist, listDirectory) 7 | import System.FilePath (FilePath (..), takeBaseName, ()) 8 | import System.IO (hPutStrLn, stderr) 9 | import System.Process (CreateProcess (..), proc, 10 | readCreateProcessWithExitCode) 11 | import Test.Tasty (TestTree (..), defaultMain, testGroup) 12 | import qualified Test.Tasty.Golden as G 13 | 14 | testDirectory :: FilePath 15 | testDirectory = "test" 16 | 17 | listTests :: IO [FilePath] 18 | listTests = do 19 | contents <- map (testDirectory ) <$> listDirectory testDirectory 20 | filterM doesDirectoryExist contents 21 | 22 | mkGoldenTest :: FilePath -> IO TestTree 23 | mkGoldenTest path = do 24 | let testName = takeBaseName path 25 | expected = path "expected" 26 | return $ G.goldenVsString testName expected action 27 | where 28 | action :: IO BS.ByteString 29 | action = do 30 | let testRun = (proc "./run" []) { cwd = Just path } 31 | (_, output, errorOut) <- readCreateProcessWithExitCode testRun "" 32 | when (errorOut /= "") $ hPutStrLn stderr ("\nError: " ++ path ++ "\n" ++ errorOut) 33 | return $ BSU.fromString output 34 | 35 | main :: IO () 36 | main = do 37 | paths <- listTests 38 | goldens <- mapM mkGoldenTest paths 39 | defaultMain (testGroup "End to end tests" goldens) 40 | -------------------------------------------------------------------------------- /test/ffi/expected: -------------------------------------------------------------------------------- 1 | FOO 2 | ooba 3 | -------------------------------------------------------------------------------- /test/ffi/ffi.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Go 4 | 5 | %include Go "strings" 6 | upper : String -> String 7 | upper s = unsafePerformIO $ 8 | gocall (Function "strings.ToUpper") (String -> GIO String) s 9 | 10 | trim : String -> String -> String 11 | trim s cutset = unsafePerformIO $ 12 | gocall (Function "strings.Trim") (String -> String -> GIO String) s cutset 13 | 14 | 15 | main : GIO () 16 | main = do 17 | putStrLn' $ upper "foo" 18 | putStrLn' $ trim "foobar" "fr" 19 | -------------------------------------------------------------------------------- /test/ffi/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | idris --codegen go -p go ffi.idr -o ffi.go 6 | go build ffi.go 7 | rm ffi.go ffi.ibc 8 | ./ffi 9 | rm ffi 10 | -------------------------------------------------------------------------------- /test/hello/expected: -------------------------------------------------------------------------------- 1 | Hello, world! 2 | -------------------------------------------------------------------------------- /test/hello/hello.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | main : IO () 4 | main = putStrLn "Hello, world!" 5 | -------------------------------------------------------------------------------- /test/hello/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | idris --codegen go hello.idr -o hello.go 6 | go build hello.go 7 | rm hello.go hello.ibc 8 | ./hello 9 | rm hello -------------------------------------------------------------------------------- /test/pythag/expected: -------------------------------------------------------------------------------- 1 | [(3, (4, 5)), (6, (8, 10)), (5, (12, 13)), (9, (12, 15)), (8, (15, 17)), (12, (16, 20)), (15, (20, 25)), (7, (24, 25)), (10, (24, 26)), (20, (21, 29)), (18, (24, 30)), (16, (30, 34)), (21, (28, 35)), (12, (35, 37)), (15, (36, 39)), (24, (32, 40)), (9, (40, 41)), (27, (36, 45)), (30, (40, 50)), (14, (48, 50)), (24, (45, 51)), (20, (48, 52)), (28, (45, 53)), (33, (44, 55)), (40, (42, 58)), (36, (48, 60)), (11, (60, 61)), (39, (52, 65)), (33, (56, 65)), (25, (60, 65)), (16, (63, 65)), (32, (60, 68)), (42, (56, 70)), (48, (55, 73)), (24, (70, 74)), (45, (60, 75)), (21, (72, 75)), (30, (72, 78)), (48, (64, 80)), (18, (80, 82)), (51, (68, 85)), (40, (75, 85)), (36, (77, 85)), (13, (84, 85)), (60, (63, 87)), (39, (80, 89)), (54, (72, 90)), (35, (84, 91)), (57, (76, 95)), (65, (72, 97)), (60, (80, 100)), (28, (96, 100))] 2 | -------------------------------------------------------------------------------- /test/pythag/pythag.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | pythag : Int -> List (Int, Int, Int) 4 | pythag max = [ 5 | (x, y, z) 6 | | z <- [1..max] 7 | , y <- [1..z] 8 | , x <- [1..y] 9 | , x * x + y *y == z * z 10 | ] 11 | 12 | main : IO () 13 | main = printLn $ pythag 100 14 | -------------------------------------------------------------------------------- /test/pythag/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | idris --codegen go pythag.idr -o pythag.go 6 | go build pythag.go 7 | rm pythag.go pythag.ibc 8 | ./pythag 9 | rm pythag 10 | -------------------------------------------------------------------------------- /test/tailrec/expected: -------------------------------------------------------------------------------- 1 | True 2 | 1250025000 3 | -------------------------------------------------------------------------------- /test/tailrec/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | idris --codegen go tailrec.idr -o tailrec.go 6 | go build tailrec.go 7 | rm tailrec.go tailrec.ibc 8 | ./tailrec 9 | rm tailrec 10 | -------------------------------------------------------------------------------- /test/tailrec/tailrec.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | mutual 4 | -- N.B. isOdd call gets inlined and the resulting self-recursive 5 | -- tailcall will result in a goto 6 | isEven : Nat -> Bool 7 | isEven Z = True 8 | isEven (S k) = isOdd k 9 | 10 | isOdd : Nat -> Bool 11 | isOdd Z = False 12 | isOdd (S k) = isEven k 13 | 14 | main : IO () 15 | main = do 16 | printLn (isOdd 1234567) 17 | printLn (sum [1..50000]) 18 | --------------------------------------------------------------------------------