├── .gitignore ├── .gitmodules ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── config.mk ├── gorts ├── Makefile ├── bin │ └── .gitignore ├── pkg │ └── .gitignore └── src │ └── idris_runtime │ ├── constructor.go │ ├── conversions.go │ ├── ffi.go │ ├── io.go │ ├── utf8.go │ └── vm.go ├── idris-cplusplus.cabal └── src ├── IRTS └── CodegenGo.hs └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev/ 3 | .cabal-sandbox 4 | cabal.sandbox.config 5 | *.ibc 6 | *.o 7 | *.a 8 | *.so 9 | *.dll 10 | *.dylib 11 | *.swp 12 | *~ 13 | .DS_Store 14 | .hpc 15 | *.tix 16 | custom.mk 17 | test/output 18 | test/*[0-9][0-9][0-9]/output 19 | test/*[0-9][0-9][0-9]/*.exe 20 | tutorial/*.aux 21 | tutorial/*.bbl 22 | tutorial/*.blg 23 | tutorial/*.log 24 | tutorial/*.out 25 | tutorial/*.toc 26 | tutorial/*.fdb_latexmk 27 | tutorial/*.fls 28 | tags 29 | TAGS 30 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "src/IRTS/Generic"] 2 | path = src/IRTS/Generic 3 | url = git@github.com:andyarvanitis/idris-generic.git 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Andy Arvanitis 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 15 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | 25 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build configure install lib_clean test 2 | 3 | include config.mk 4 | -include custom.mk 5 | 6 | install: 7 | git submodule update --init 8 | $(CABAL) install $(CABALFLAGS) 9 | 10 | build: dist/setup-config 11 | git submodule update --init 12 | $(CABAL) build $(CABALFLAGS) 13 | 14 | test: test_go 15 | 16 | test_go: 17 | cd ../Idris-dev/test && ./runtest.pl without io003 reg031 effects002 --codegen go 18 | 19 | 20 | lib_clean: 21 | clean: 22 | $(MAKE) -C gorts clean 23 | 24 | dist/setup-config: 25 | $(CABAL) configure $(CABALFLAGS) 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ### Experimental Google Go backend for Idris 2 | 3 | ### Motivations for this 4 | * I felt like improving my Haskell and Idris, and learning Go 5 | * ??? 6 | 7 | ### Some features/benefits 8 | * Easy interop with Go, as well as with C via cgo 9 | * UTF-8 support 10 | * Callbacks from Go (into Idris) support 11 | * With no tweaking yet, performance seems quite good -- almost as fast as C backend 12 | 13 | ### Niceties/notes 14 | * Go compiles pretty fast, which is nice when using it for a language backend 15 | * Go has a reasonably-well-performing GC (which is continually being improved) 16 | * Go has built-in unicode support (used by this backend) 17 | * Go has standard lib big int support (used by this backend) 18 | * Go has nice reflection features (used by this backend, made things pretty easy) 19 | * No Go third-party libraries needed or used by this backend 20 | * Most of the official Idris tests run successfully -- see the [Makefile](https://github.com/andyarvanitis/idris-golang/blob/master/Makefile) 21 | 22 | ### Some code examples 23 | * UTF-8 support, so this works and produces "βγδ" as output (the C backend doesn't yet) 24 | ```Idris 25 | module Main 26 | 27 | greek : String 28 | greek = "αβγδ" 29 | 30 | main : IO () 31 | main = do 32 | putStrLn "Running Idris main" 33 | putStrLn $ "Greek: " ++ (strTail greek) 34 | ``` 35 | 36 | * Calling a Go function via the FFI 37 | ```Idris 38 | module Main 39 | 40 | %include go "fmt" 41 | 42 | goprint : String -> IO () 43 | goprint s = mkForeign (FFun "fmt.Println(%0)" [FString] FUnit) s 44 | 45 | main : IO () 46 | main = do 47 | goprint "Hello, world!" 48 | ``` 49 | 50 | * Calling a C function via the FFI (via cgo) 51 | ```Idris 52 | module Main 53 | 54 | %include go "// #include " 55 | %include go "C" 56 | 57 | c_putchar : Char -> IO Int 58 | c_putchar c = mkForeign (FFun "C.putchar(C.int(%0))" [FChar] FInt) c 59 | 60 | main : IO () 61 | main = do 62 | 63 | _ <- c_putchar('B') 64 | _ <- c_putchar('\n') 65 | 66 | return () 67 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | import Distribution.Simple 4 | import Distribution.Simple.BuildPaths (autogenModulesDir) 5 | import Distribution.Simple.InstallDirs as I 6 | import Distribution.Simple.LocalBuildInfo as L 7 | import qualified Distribution.Simple.Setup as S 8 | import qualified Distribution.Simple.Program as P 9 | import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, rewriteFile) 10 | import Distribution.PackageDescription 11 | import Distribution.Text 12 | 13 | import System.FilePath ((), splitDirectories,isAbsolute) 14 | 15 | -- ----------------------------------------------------------------------------- 16 | -- Make Commands 17 | 18 | -- use GNU make on FreeBSD 19 | #if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) 20 | mymake = "gmake" 21 | #else 22 | mymake = "make" 23 | #endif 24 | make verbosity = 25 | P.runProgramInvocation verbosity . P.simpleProgramInvocation mymake 26 | 27 | 28 | idrisRuntimeClean _ flags _ _ = do 29 | make verbosity [ "-C", "gorts", "clean", "IDRIS=idris" ] 30 | where 31 | verbosity = S.fromFlag $ S.cleanVerbosity flags 32 | 33 | idrisRuntimeInstall verbosity copy pkg local = do 34 | installRTS 35 | where 36 | target = datadir $ L.absoluteInstallDirs pkg local copy 37 | installRTS = do 38 | putStrLn $ "Installing c++ runtime in " ++ target 39 | makeInstall "gorts" target 40 | makeInstall src target = 41 | make verbosity [ "-C", src, "install", "TARGET=" ++ target ] 42 | 43 | idrisRuntimeBuild _ flags _ local = do 44 | buildGo 45 | where 46 | verbosity = S.fromFlag $ S.buildVerbosity flags 47 | buildGo = make verbosity ["-C", "gorts", "build"] 48 | 49 | main = defaultMainWithHooks $ simpleUserHooks 50 | { postClean = idrisRuntimeClean 51 | , postBuild = idrisRuntimeBuild 52 | , postCopy = \_ flags pkg local -> 53 | idrisRuntimeInstall (S.fromFlag $ S.copyVerbosity flags) 54 | (S.fromFlag $ S.copyDest flags) pkg local 55 | , postInst = \_ flags pkg local -> 56 | idrisRuntimeInstall (S.fromFlag $ S.installVerbosity flags) 57 | NoCopyDest pkg local 58 | } 59 | -------------------------------------------------------------------------------- /config.mk: -------------------------------------------------------------------------------- 1 | CC ?=cc 2 | CABAL :=cabal 3 | CFLAGS :=-O2 -Wall -DHAS_PTHREAD $(CFLAGS) 4 | #CABALFLAGS := 5 | ## Disable building of Effects 6 | #CABALFLAGS :=-f NoEffects 7 | 8 | ifneq (, $(findstring bsd, $(MACHINE))) 9 | GMP_INCLUDE_DIR := 10 | else 11 | GMP_INCLUDE_DIR :=-I/usr/local/include 12 | endif 13 | 14 | MACHINE := $(shell $(CC) -dumpmachine) 15 | ifneq (, $(findstring darwin, $(MACHINE))) 16 | OS :=darwin 17 | else 18 | ifneq (, $(findstring cygwin, $(MACHINE))) 19 | OS :=windows 20 | else 21 | ifneq (, $(findstring mingw, $(MACHINE))) 22 | OS :=windows 23 | else 24 | OS :=unix 25 | endif 26 | endif 27 | endif 28 | 29 | ifeq ($(OS),darwin) 30 | SHLIB_SUFFIX :=.dylib 31 | else 32 | ifeq ($(OS),windows) 33 | SHLIB_SUFFIX :=.DLL 34 | else 35 | SHLIB_SUFFIX :=.so 36 | endif 37 | endif 38 | -------------------------------------------------------------------------------- /gorts/Makefile: -------------------------------------------------------------------------------- 1 | include ../config.mk 2 | 3 | .PHONY: build install test 4 | 5 | GOPATH := ${GOPATH}:${PWD}:${PWD}/gorts 6 | 7 | ifdef TARGET 8 | INSTALLGOSTRUCTURE=rsync -rupE src pkg bin $(TARGET) 9 | endif 10 | 11 | 12 | install: 13 | go install idris_runtime 14 | $(INSTALLGOSTRUCTURE) 15 | 16 | build: 17 | go build idris_runtime 18 | 19 | clean: 20 | go clean idris_runtime 21 | -------------------------------------------------------------------------------- /gorts/bin/.gitignore: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andyarvanitis/idris-golang/dd08e7e940933eba4a40d4136f2e39f3870c80da/gorts/bin/.gitignore -------------------------------------------------------------------------------- /gorts/pkg/.gitignore: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andyarvanitis/idris-golang/dd08e7e940933eba4a40d4136f2e39f3870c80da/gorts/pkg/.gitignore -------------------------------------------------------------------------------- /gorts/src/idris_runtime/constructor.go: -------------------------------------------------------------------------------- 1 | package idris_runtime 2 | 3 | import . "reflect" 4 | 5 | //------------------------------------------------------------------------------------------------- 6 | // Data structures 7 | //------------------------------------------------------------------------------------------------- 8 | 9 | type Con struct { 10 | tag uintptr 11 | args []interface{} 12 | } 13 | 14 | //------------------------------------------------------------------------------------------------- 15 | // Constants 16 | //------------------------------------------------------------------------------------------------- 17 | 18 | const invalidTag = ^uintptr(0) 19 | 20 | //------------------------------------------------------------------------------------------------- 21 | // Creation/accessor functions 22 | //------------------------------------------------------------------------------------------------- 23 | 24 | func MakeCon(tag uintptr, args ...interface{}) Con { 25 | return Con{tag, args} 26 | } 27 | 28 | func GetTag(con interface{}) uintptr { 29 | if con != nil { 30 | return ValueOf(con).Interface().(Con).tag 31 | } else { 32 | return invalidTag 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /gorts/src/idris_runtime/conversions.go: -------------------------------------------------------------------------------- 1 | package idris_runtime 2 | 3 | import . "strconv" 4 | import "math/big" 5 | 6 | //------------------------------------------------------------------------------------------------- 7 | // Constant-like data used frequently 8 | //------------------------------------------------------------------------------------------------- 9 | var ConstBigZero = big.NewInt(0) 10 | var ConstBigOne = big.NewInt(1) 11 | 12 | //------------------------------------------------------------------------------------------------- 13 | // Data conversion functions 14 | //------------------------------------------------------------------------------------------------- 15 | 16 | func BoolToInt(isTrue bool) int { 17 | if isTrue { 18 | return 1 19 | } else { 20 | return 0 21 | } 22 | } 23 | 24 | func StringToInt(s string) int64 { 25 | value, _ := ParseInt(s, 0, 64) 26 | return value 27 | } 28 | 29 | func StringToFloat(s string) float64 { 30 | value, _ := ParseFloat(s, 64) 31 | return value 32 | } 33 | 34 | func BigIntFromString(n string) *big.Int { 35 | intResult, _ := big.NewInt(0).SetString(n, 0) 36 | return intResult 37 | } 38 | -------------------------------------------------------------------------------- /gorts/src/idris_runtime/ffi.go: -------------------------------------------------------------------------------- 1 | package idris_runtime 2 | 3 | import . "reflect" 4 | 5 | //------------------------------------------------------------------------------------------------- 6 | // Function used for calls from go into Idris 7 | //------------------------------------------------------------------------------------------------- 8 | 9 | func ProxyFunction(vm *VirtualMachine, 10 | applyFn vmFunction, 11 | con interface{}, 12 | args ...interface{}) { 13 | 14 | // Create (empty) private stack and use it for this context. 15 | var savedCallStack []CallPair 16 | copy(savedCallStack, (*vm).CallStack) 17 | (*vm).CallStack = make([]CallPair, 0) 18 | 19 | conType := ValueOf(con).Type() 20 | res := con 21 | 22 | apply := func(arg interface{}) { 23 | if ValueOf(res).Type() == conType { 24 | Reserve(vm, (*vm).ValueStackTop + 2) 25 | (*vm).ValueStack[(*vm).ValueStackTop] = res 26 | (*vm).ValueStack[(*vm).ValueStackTop + 1] = arg 27 | oldbase := (*vm).ValueStackBase 28 | (*vm).ValueStackBase = (*vm).ValueStackTop 29 | (*vm).ValueStackTop += 2 30 | Call(vm, applyFn, oldbase) 31 | res = (*vm).ReturnValue 32 | } 33 | } 34 | 35 | for _, arg := range args { 36 | apply(arg) 37 | } 38 | 39 | // Specifically for cases of IO functions 40 | apply(res) 41 | 42 | // Restore the original stack 43 | copy((*vm).CallStack, savedCallStack) 44 | } 45 | -------------------------------------------------------------------------------- /gorts/src/idris_runtime/io.go: -------------------------------------------------------------------------------- 1 | package idris_runtime 2 | 3 | import . "os" 4 | import . "bufio" 5 | 6 | //------------------------------------------------------------------------------------------------- 7 | // Various IO functions 8 | //------------------------------------------------------------------------------------------------- 9 | 10 | func FileOpen(name string, mode string) *File { 11 | flags := 0 12 | for _, char := range mode { // TODO: these need some work 13 | switch char { 14 | case 'r': flags |= O_RDONLY 15 | case 'w': flags |= O_RDWR|O_TRUNC|O_CREATE 16 | case 'a': flags |= O_APPEND|O_CREATE 17 | case '+': flags |= O_RDWR 18 | } 19 | if flags & (O_RDWR|O_APPEND) != 0 { 20 | flags &^= O_RDONLY 21 | } 22 | } 23 | file, _ := OpenFile(name, flags, 0644) 24 | return file 25 | } 26 | 27 | func FileReadLine(file *File) string { 28 | // Save off current seek position 29 | offset, error := file.Seek(0, SEEK_CUR) 30 | if error == nil { 31 | reader := NewReader(file) 32 | line, error := reader.ReadString('\n') 33 | if error == nil { 34 | // Set seek position, since it's no longer correct 35 | file.Seek(offset + int64(len(line)), SEEK_SET) 36 | return line 37 | } 38 | } 39 | return "" 40 | } 41 | 42 | func FileEOF(file *File) int { 43 | info, error := file.Stat() 44 | if error == nil { 45 | size := info.Size() 46 | offset, error := file.Seek(0, SEEK_CUR) 47 | if error == nil { 48 | if offset == size { 49 | file.Seek(offset + 1, SEEK_SET) 50 | } else if offset > size { 51 | return 1 52 | } 53 | } 54 | } 55 | return 0 56 | } 57 | -------------------------------------------------------------------------------- /gorts/src/idris_runtime/utf8.go: -------------------------------------------------------------------------------- 1 | package idris_runtime 2 | 3 | import . "unicode/utf8" 4 | 5 | //------------------------------------------------------------------------------------------------- 6 | // Functions for UTF-8 string operations 7 | //------------------------------------------------------------------------------------------------- 8 | 9 | func Utf8Head(s string) rune { 10 | if len(s) > 0 { 11 | chr, _ := DecodeRuneInString(s) 12 | return chr 13 | } else { 14 | return 0 15 | } 16 | } 17 | 18 | func Utf8Tail(s string) string { 19 | _, offset := DecodeRuneInString(s) 20 | return s[offset:] 21 | } 22 | 23 | func Utf8AtIndex(s string, index int) rune { 24 | if len(s) > 0 { 25 | if index == 0 { 26 | chr, _ := DecodeRuneInString(s) 27 | return chr 28 | } else { 29 | i := 0 30 | for _, chr := range s { 31 | if i == index { 32 | return chr 33 | } 34 | i++ 35 | } 36 | } 37 | } 38 | return 0 39 | } 40 | 41 | func Utf8Reverse(s string) string { 42 | offset := len(s) 43 | if offset == 0 { 44 | return "" 45 | } 46 | buf := make([]rune, offset) 47 | for _, chr := range s { 48 | offset-- 49 | buf[offset] = chr 50 | } 51 | return string(buf[offset:]) 52 | } 53 | 54 | -------------------------------------------------------------------------------- /gorts/src/idris_runtime/vm.go: -------------------------------------------------------------------------------- 1 | package idris_runtime 2 | 3 | import . "reflect" 4 | 5 | //------------------------------------------------------------------------------------------------- 6 | // Data structures/types 7 | //------------------------------------------------------------------------------------------------- 8 | 9 | type VirtualMachine struct { 10 | ValueStack []interface{} 11 | ValueStackTop uintptr 12 | ValueStackBase uintptr 13 | ReturnValue interface{} 14 | CallStack []CallPair 15 | } 16 | 17 | type vmFunction func(vm *VirtualMachine, oldbase uintptr) 18 | 19 | type CallPair struct { 20 | fn vmFunction 21 | base uintptr 22 | } 23 | 24 | //------------------------------------------------------------------------------------------------- 25 | // Virtual machine functions 26 | //------------------------------------------------------------------------------------------------- 27 | 28 | func Slide(vm *VirtualMachine, num_args uintptr) { 29 | for i := uintptr(0); i < num_args; i++ { 30 | (*vm).ValueStack[(*vm).ValueStackBase + i] = (*vm).ValueStack[(*vm).ValueStackTop + i] 31 | } 32 | } 33 | 34 | func Project(vm *VirtualMachine, value interface{}, loc uintptr, arity uintptr) { 35 | args := ValueOf(value).Interface().(Con).args 36 | for i := uintptr(0); i < arity; i++ { 37 | (*vm).ValueStack[(*vm).ValueStackBase + i + loc] = args[i] 38 | } 39 | } 40 | 41 | func Reserve(vm *VirtualMachine, size uintptr) { 42 | for i := uintptr(len((*vm).ValueStack)); i < size + 2; i++ { // TODO: why +2 now? 43 | (*vm).ValueStack = append((*vm).ValueStack, nil) 44 | } 45 | } 46 | 47 | func Call(vm *VirtualMachine, fn vmFunction, base uintptr) { 48 | fn(vm, base) 49 | for length := len((*vm).CallStack); length > 0; length = len((*vm).CallStack) { 50 | top := (*vm).CallStack[length - 1] 51 | function := top.fn 52 | base := top.base 53 | (*vm).CallStack = (*vm).CallStack[:length-1] 54 | function(vm, base) 55 | } 56 | } 57 | 58 | func TailCall(vm *VirtualMachine, fn vmFunction, base uintptr) { 59 | (*vm).CallStack = append((*vm).CallStack, CallPair{fn, base}) 60 | } 61 | -------------------------------------------------------------------------------- /idris-cplusplus.cabal: -------------------------------------------------------------------------------- 1 | Name: idris-go 2 | Version: 0.0.0.1 3 | License: BSD3 4 | License-file: LICENSE 5 | Author: Andy Arvanitis 6 | 7 | Build-Type: Custom 8 | Cabal-Version: >= 1.8 9 | 10 | Executable idris-go 11 | Main-is: Main.hs 12 | hs-source-dirs: src 13 | 14 | Build-depends: idris 15 | , base 16 | , containers 17 | , directory 18 | , filepath 19 | , haskeline >= 0.7 20 | , mtl 21 | , process 22 | , text 23 | , transformers 24 | , vector 25 | 26 | other-modules: IRTS.CodegenGo 27 | , IRTS.Generic.AST 28 | , IRTS.Generic.CodegenGeneric 29 | 30 | ghc-prof-options: -auto-all -caf-all 31 | ghc-options: -threaded -rtsopts -funbox-strict-fields 32 | 33 | -------------------------------------------------------------------------------- /src/IRTS/CodegenGo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module IRTS.CodegenGo (codegenGo) where 4 | 5 | import IRTS.Bytecode 6 | import IRTS.Lang 7 | import IRTS.Simplified 8 | import IRTS.CodegenCommon 9 | import IRTS.Generic.AST 10 | import IRTS.Generic.CodegenGeneric 11 | import IRTS.Generic.CodegenFFI 12 | import Idris.Core.TT 13 | import Util.System hiding (tempfile) 14 | 15 | import Numeric 16 | import Data.Char 17 | import Data.Int 18 | import Data.Word 19 | import Data.List (intercalate) 20 | import System.Process 21 | import System.Exit 22 | import System.IO 23 | import System.Directory 24 | import System.FilePath ((), normalise) 25 | import Control.Monad.State 26 | import Control.Arrow 27 | 28 | import Debug.Trace 29 | 30 | import qualified Data.Text as T 31 | import qualified Data.Text.IO as TIO 32 | import qualified Text.Printf as PF 33 | 34 | import Paths_idris_go 35 | 36 | data CompileGo = CompileGo Bool -- TODO: just a placeholder 37 | 38 | codegenGo :: CodeGenerator 39 | codegenGo ci = 40 | codegenGo_all (simpleDecls ci) 41 | (outputType ci) 42 | (outputFile ci) 43 | (includes ci) 44 | [] -- objc (currently unused) 45 | [] -- libs (currently unused) 46 | [] -- compiler flags (currently unused) 47 | (debugLevel ci) -- (currently unused) 48 | codegenGo_all :: 49 | [(Name, SDecl)] -> -- declarations/definitions 50 | OutputType -> -- output type 51 | FilePath -> -- output file name 52 | [FilePath] -> -- include files 53 | String -> -- extra object files`as 54 | String -> -- libraries 55 | String -> -- extra compiler flags 56 | DbgLevel -> -- debug level 57 | IO () 58 | 59 | codegenGo_all definitions outputType filename includes objs libs flags dbg = do 60 | let info = CompileGo True 61 | let bytecode = map toBC definitions 62 | let go = concatMap (toGo info) bytecode 63 | path <- getDataDir 64 | let goOut = ( T.pack "package main\n\n" 65 | `T.append` mkImport ". reflect" 66 | `T.append` mkImport ". os" 67 | `T.append` mkImport ". unicode/utf8" 68 | `T.append` mkImport ". fmt" 69 | `T.append` mkImport ". math" 70 | `T.append` mkImport " math/big" 71 | `T.append` mkImport ". idris_runtime" 72 | `T.append` "\n" 73 | `T.append` imports includes 74 | `T.append` "\n" 75 | `T.append` T.concat (map (compile info) go) 76 | `T.append` mkIgnoreUnusedImports 77 | `T.append` "\n" 78 | `T.append` mkMain 79 | `T.append` "\n" 80 | ) 81 | case outputType of 82 | Raw -> TIO.writeFile filename goOut 83 | _ -> do (tmpn, tmph) <- tempfile 84 | hPutStr tmph (T.unpack goOut) 85 | hFlush tmph 86 | hClose tmph 87 | let cc = 88 | "GOPATH=${GOPATH}:" ++ path ++ "; " ++ 89 | "go build -o " ++ filename ++ " " ++ tmpn 90 | exit <- system cc 91 | when (exit /= ExitSuccess) $ 92 | putStrLn ("FAILURE: " ++ cc) 93 | where 94 | mkImport s = case qual of "//" -> s `T.append` "\n" 95 | _ -> "import " `T.append` imp 96 | where 97 | ws = T.words s 98 | qual = case ws of (w:_:_) -> w 99 | [w] -> " " 100 | pkg = last ws 101 | imp = qual `T.append` " \"" `T.append` pkg `T.append` "\"\n" 102 | 103 | mkIgnoreUnusedImports = T.pack (foldr (++) "\n" (map ("\nconst _ = " ++) consts)) `T.append` 104 | T.pack (foldr (++) "\n" (map ("\nvar _ " ++) types)) 105 | where consts = ["SelectDefault", "UTFMax", "Pi", "big.MaxBase", "DevNull"] 106 | types = ["State"] 107 | 108 | imports xs = T.concat (map (mkImport . T.pack) (reverse xs)) 109 | 110 | mkMain = T.pack $ "func main() {\n" ++ 111 | " " ++ vm ++ " := " ++ vmType ++ "{}\n" ++ 112 | " Call(&" ++ vm ++ ", " ++ vmMainFn ++ ", 0)\n" ++ 113 | "}\n" 114 | toGo info (name, bc) = 115 | [ ASTIdent $ "func " ++ translateName name, 116 | ASTFunction fnParams ( 117 | ASTSeq $ ASTAlloc (Just baseType) myoldbase Nothing 118 | : ASTAssign (ASTIdent "_") mkMyOldbase 119 | : map (translateBC info)bc 120 | ) 121 | ] 122 | 123 | tempfile :: IO (FilePath, Handle) 124 | tempfile = do dir <- getTemporaryDirectory 125 | openTempFile (normalise dir) "idris.go" 126 | 127 | translateReg :: Reg -> ASTNode 128 | translateReg reg = 129 | case reg of 130 | RVal -> mkRet 131 | Tmp -> ASTRaw "//TMPREG" 132 | L n -> mkLoc n 133 | T n -> mkTop n 134 | 135 | --------------------------------------------------------------------------------------------------- 136 | instance CompileInfo CompileGo where 137 | --------------------------------------------------------------------------------------------------- 138 | mkAssign _ r1 r2 = ASTAssign (translateReg r1) (translateReg r2) 139 | 140 | mkAssignConst _ r c = 141 | case value of 142 | ASTNum (ASTInteger (ASTBigInt i)) -> assignBigValue i 143 | _ -> ASTAssign (translateReg r) (mkCast (translatedType value) value) 144 | where 145 | value = translateConstant c 146 | assignBigValue i 147 | | i > (toInteger (maxBound::Word64)) || 148 | i < (toInteger (minBound::Int64)) = ASTAssign (translateReg r) (mkStringToBigInt (ASTString $ show i)) 149 | | i > (toInteger (maxBound::Int64)) = ASTAssign (translateReg r) (mkNewBigUInt i) 150 | | otherwise = ASTAssign (translateReg r) (mkNewBigInt i) 151 | 152 | mkAddTop info n = case n of 153 | 0 -> ASTNoop 154 | _ -> ASTBinOp "+=" mkStacktop (ASTNum (ASTInt n)) 155 | 156 | mkNullAssign _ r = ASTAssign (translateReg r) mkNull 157 | 158 | mkVmCall _ n = mkCall "Call" [mkVm, ASTIdent (translateName n), mkMyOldbase] 159 | 160 | mkVmTailCall _ n = mkCall "TailCall" [mkVm, ASTIdent (translateName n), mkOldbase] 161 | 162 | mkForeign info reg n args ret = 163 | case n of 164 | "putStr" -> let [(_, str)] = args in 165 | ASTAssign (translateReg reg) 166 | (ASTBinOp ";" mkNull (mkCall "Print" [asType stringTy $ translateReg str])) 167 | 168 | "putchar" -> let [(_, ch)] = args in 169 | ASTAssign (translateReg reg) 170 | (ASTBinOp ";" mkNull (mkCall "Printf" [ASTString "%c", 171 | asType charTy $ translateReg ch])) 172 | 173 | "getchar" -> mkCall "Scanf" [ASTString "%c", asType charTy $ translateReg reg] 174 | 175 | "fileOpen" -> let [(_, name),(_, mode)] = args in 176 | ASTAssign (translateReg reg) 177 | (mkCall "FileOpen" [asType stringTy $ translateReg name, 178 | asType stringTy $ translateReg mode]) 179 | "fileClose" -> let [(_, fh)] = args in 180 | ASTAssign (translateReg reg) (mkMeth (asType fileTy $ translateReg fh) "Close" []) 181 | 182 | "fputStr" -> let [(_, fh),(_, str)] = args in 183 | mkAssignFirst (translateReg reg) 184 | (mkMeth (asType fileTy $ translateReg fh) 185 | "WriteString" 186 | [asType stringTy $ translateReg str]) 187 | "fileEOF" -> let [(_, fh)] = args in 188 | ASTAssign (translateReg reg) (mkCall "FileEOF" [asType fileTy $ translateReg fh]) 189 | 190 | "fileError" -> let [(_, fh)] = args in error "fileError not supported yet" 191 | 192 | "isNull" -> let [(_, arg)] = args in 193 | ASTAssign (translateReg reg) (mkBoolToInt $ mkEq (translateReg arg) mkNull) 194 | 195 | "idris_eqPtr" -> let [(_, lhs),(_, rhs)] = args in 196 | ASTAssign (translateReg reg) (mkBoolToInt $ mkEq (translateReg lhs) (translateReg rhs)) 197 | 198 | "getenv" -> ASTCond [(ASTIdent "true", ASTSeq [getEnv, getEnvResults])] 199 | where 200 | [(_, arg)] = args 201 | getEnv = ASTAssign (translateReg reg) (mkCall "Getenv" [asType stringTy $ translateReg arg]) 202 | getEnvResults = ASTCond [(mkEq (asType stringTy $ translateReg reg) (ASTIdent "\"\""), 203 | ASTSeq [ ASTAssign (translateReg reg) mkNull])] 204 | 205 | "exit" -> mkCall "Exit" [asType intTy $ translateReg reg] 206 | 207 | "idris_numArgs" -> ASTAssign (translateReg reg) (mkCall "len" [ASTIdent "Args"]) 208 | "idris_getArg" -> let [(_, arg)] = args in 209 | ASTAssign (translateReg reg) (ASTIndex (ASTIdent "Args") 210 | (asType intTy $ translateReg arg)) 211 | 212 | _ -> ASTAssign (translateReg reg) (let callexpr = ASTFFI n (map generateWrapper args) in 213 | case ret of 214 | FUnit -> ASTBinOp ";" mkNull callexpr 215 | _ -> callexpr) 216 | where 217 | generateWrapper :: (FType, Reg) -> ASTNode 218 | generateWrapper (ty, reg) = 219 | case ty of 220 | FFunction aty rty -> ffunc aty rty 221 | FFunctionIO aty rty -> ffunc aty rty 222 | _ -> asType (head $ goType ty) (translateReg reg) 223 | 224 | where ffunc aty rty = let rs = goType rty in 225 | genClosure reg (genArgs (goType aty ++ init rs)) (last $ rs) 226 | 227 | goType :: FType -> [String] 228 | goType (FArith (ATInt ITNative)) = [intTy] 229 | goType (FArith (ATInt ITChar)) = [charTy] 230 | goType (FArith (ATInt ITBig)) = [bigIntTy] 231 | goType (FArith (ATInt (ITFixed IT8))) = [wordTy 8] 232 | goType (FArith (ATInt (ITFixed IT16))) = [wordTy 16] 233 | goType (FArith (ATInt (ITFixed IT32))) = [wordTy 32] 234 | goType (FArith (ATInt (ITFixed IT64))) = [wordTy 64] 235 | goType FString = [stringTy] 236 | goType FUnit = [""] 237 | goType FPtr = ["interface{}"] 238 | goType FManagedPtr = ["interface{}"] -- TODO: placeholder 239 | goType (FArith ATFloat) = [floatTy] 240 | goType (FAny (Constant c)) = [translatedType (translateConstant c)] 241 | goType (FAny a) = ["interface{}"] 242 | goType (FFunction a b) = concat [goType a, goType b] 243 | 244 | genArgs :: [String] -> [(String, String)] 245 | genArgs typs = zip ((map (\n -> "arg" ++ show n)) [1..]) typs 246 | 247 | genClosure :: Reg -> [(String, String)] -> String -> ASTNode 248 | genClosure con xs r = ASTRaw $ "func(" ++ intercalate ", " (map (genDecl) xs) ++ ") " ++ r ++ " " ++ 249 | "{" ++ 250 | "ProxyFunction(" ++ 251 | vm ++ ", " ++ 252 | vmApplyFn ++ ", " ++ 253 | T.unpack (compile' info 0 $ translateReg con) ++ ", " ++ 254 | (intercalate "," (map fst xs)) ++ "); " ++ 255 | retIfNeeded ++ 256 | "}" 257 | where retIfNeeded = if r == "" then "" else T.unpack (compile' info 0 (ASTReturn (asType r mkRet))) 258 | 259 | genDecl :: (String, String) -> String 260 | genDecl (v,t) = v ++ " " ++ t 261 | 262 | mkTopBase _ 0 = ASTAssign mkStacktop mkStackbase 263 | mkTopBase _ n = ASTAssign mkStacktop (mkAdd mkStackbase (ASTNum (ASTInt n))) 264 | 265 | mkBaseTop _ 0 = ASTAssign mkStackbase mkStacktop 266 | mkBaseTop _ n = ASTAssign mkStackbase (mkAdd mkStacktop (ASTNum (ASTInt n))) 267 | 268 | mkStoreOld _ = ASTAssign mkMyOldbase mkStackbase 269 | 270 | mkSlide _ n = mkCall "Slide" [mkVm, ASTNum (ASTInt n)] 271 | 272 | mkRebase _ = ASTAssign mkStackbase mkOldbase 273 | 274 | mkReserve _ n = mkCall "Reserve" [mkVm, mkAdd mkStacktop (ASTNum $ ASTInt n)] 275 | 276 | mkMakeCon info r t rs = 277 | ASTAssign (translateReg r) (mkCall "MakeCon" [ASTList $ ASTNum (ASTInt t) : args rs]) 278 | where 279 | args [] = [] 280 | args xs = [ASTList (map translateReg xs)] 281 | 282 | mkConstCase info reg cases def = 283 | ASTCond $ ( 284 | map (binOp (mkEq) (translateReg reg) . translateConstant *** prepBranch) cases 285 | ) ++ (maybe [] ((:[]) . ((,) ASTNoop) . prepBranch) def) 286 | where 287 | prepBranch :: [BC] -> ASTNode 288 | prepBranch bc = ASTSeq $ map (translateBC info) bc 289 | 290 | binOp :: (ASTNode -> ASTNode -> ASTNode) -> ASTNode -> ASTNode -> ASTNode 291 | binOp f l r = case r of 292 | (ASTNum (ASTInteger (ASTBigInt i))) -> eqCheck (asType bigIntTy l) (mkBig i) 293 | _ -> f (asType (translatedType r) l) r 294 | where 295 | eqCheck lhs rhs = mkEq (mkMeth lhs "Cmp" [rhs]) mkZero 296 | mkBig i 297 | | i == 0 = ASTRaw "ConstBigZero" 298 | | i == 1 = ASTRaw "ConstBigOne" 299 | | i > (toInteger (maxBound::Word64)) || 300 | i < (toInteger (minBound::Int64)) = mkStringToBigInt (ASTString $ show i) 301 | | i > (toInteger (maxBound::Int64)) = mkNewBigUInt i 302 | | otherwise = mkNewBigInt i 303 | 304 | mkCase info safe reg cases def = 305 | ASTSwitch (tag safe $ translateReg reg) ( 306 | map ((ASTNum . ASTInt) *** prepBranch) cases 307 | ) (fmap prepBranch def) 308 | where 309 | tag :: Bool -> ASTNode -> ASTNode 310 | tag True = mkCTag 311 | tag False = mkTag 312 | 313 | prepBranch :: [BC] -> ASTNode 314 | prepBranch bc = ASTSeq $ map (translateBC info) bc 315 | 316 | mkTag expr = mkCall "GetTag" [expr] 317 | 318 | mkCTag :: ASTNode -> ASTNode 319 | mkCTag expr = mkCall "GetTag" [expr] 320 | 321 | mkProject _ reg loc 0 = ASTNoop 322 | mkProject _ reg loc ar = mkCall "Project" [mkVm, translateReg reg, ASTNum (ASTInt loc), ASTNum (ASTInt ar)] 323 | 324 | mkOp _ reg (LTrunc ITBig (ITFixed IT64)) (arg:_) = 325 | ASTCond [(ASTIdent "true", ASTSeq [ 326 | ASTAlloc Nothing tmpVarName (Just (mkNewBigUIntStr "0xFFFFFFFFFFFFFFFF")), 327 | ASTAssign (translateReg reg) 328 | (mkMeth (mkMeth tmpVar "And" [tmpVar, asBig arg]) "Uint64" [])])] 329 | where tmpVarName = "tmpBig" 330 | tmpVar = ASTIdent tmpVarName 331 | 332 | mkOp _ reg oper args = ASTAssign (translateReg reg) (mkOp' oper) 333 | where 334 | mkOp' :: PrimFn -> ASTNode 335 | mkOp' op = 336 | case op of 337 | LNoOp -> translateReg (last args) 338 | 339 | (LZExt sty ITBig) -> mkNewBigInt' (mkAsInt . translateReg $ last args) 340 | (LZExt sty dty) -> mkIntCast dty $ asInt sty (last args) 341 | (LSExt sty dty) -> mkOp' (LZExt sty dty) 342 | 343 | (LPlus (ATInt ITBig)) -> mkMeth mkAllocBigInt "Add" [asBig lhs, asBig rhs] 344 | (LMinus (ATInt ITBig)) -> mkMeth mkAllocBigInt "Sub" [asBig lhs, asBig rhs] 345 | (LTimes (ATInt ITBig)) -> mkMeth mkAllocBigInt "Mul" [asBig lhs, asBig rhs] 346 | (LSDiv (ATInt ITBig)) -> mkMeth mkAllocBigInt "Div" [asBig lhs, asBig rhs] 347 | (LSRem (ATInt ITBig)) -> mkMeth mkAllocBigInt "Rem" [asBig lhs, asBig rhs] 348 | 349 | (LPlus ty) -> mkAdd (asNum ty lhs) (asNum ty rhs) 350 | (LMinus ty) -> mkSubtract (asNum ty lhs) (asNum ty rhs) 351 | (LTimes ty) -> mkMultiply (asNum ty lhs) (asNum ty rhs) 352 | (LSDiv ty) -> mkDivide (asNum ty lhs) (asNum ty rhs) 353 | (LSRem ty) -> mkModulo (asNum ty lhs) (asNum ty rhs) 354 | 355 | (LEq (ATInt ITBig)) -> mkBitXor (mkBitAnd (mkMeth (asBig lhs) "Cmp" [asBig rhs]) mkOne) mkOne 356 | (LSLt (ATInt ITBig)) -> mkBoolToInt $ mkLessThan (mkMeth (asBig lhs) "Cmp" [asBig rhs]) mkZero 357 | (LSLe (ATInt ITBig)) -> mkBoolToInt $ mkLessThanEq (mkMeth (asBig lhs) "Cmp" [asBig rhs]) mkZero 358 | (LSGt (ATInt ITBig)) -> mkBoolToInt $ mkGreaterThan (mkMeth (asBig lhs) "Cmp" [asBig rhs]) mkZero 359 | (LSGe (ATInt ITBig)) -> mkBoolToInt $ mkGreaterThanEq (mkMeth (asBig lhs) "Cmp" [asBig rhs]) mkZero 360 | 361 | (LEq ty) -> mkBoolToInt $ mkEq (asNum ty lhs) (asNum ty rhs) 362 | (LSLt ty) -> mkBoolToInt $ mkLessThan (asNum ty lhs) (asNum ty rhs) 363 | (LSLe ty) -> mkBoolToInt $ mkLessThanEq (asNum ty lhs) (asNum ty rhs) 364 | (LSGt ty) -> mkBoolToInt $ mkGreaterThan (asNum ty lhs) (asNum ty rhs) 365 | (LSGe ty) -> mkBoolToInt $ mkGreaterThanEq (asNum ty lhs) (asNum ty rhs) 366 | 367 | (LTrunc ITNative (ITFixed IT8)) -> mkTrunc intTy 8 "0xFF" 368 | (LTrunc (ITFixed IT16) (ITFixed IT8)) -> mkTrunc (wordTy 16) 8 "0xFF" 369 | (LTrunc (ITFixed IT32) (ITFixed IT16)) -> mkTrunc (wordTy 32) 16 "0xFFFF" 370 | (LTrunc (ITFixed IT64) (ITFixed IT32)) -> mkTrunc (wordTy 64) 32 "0xFFFFFFFF" 371 | 372 | (LTrunc ITBig ITNative) -> mkCast (intTy) (mkMeth (asBig arg) "Int64" []) 373 | 374 | (LLSHR ty@(ITFixed _)) -> mkOp' (LASHR ty) 375 | (LLt ty@(ITFixed _)) -> mkOp' (LSLt (ATInt ty)) 376 | (LLe ty@(ITFixed _)) -> mkOp' (LSLe (ATInt ty)) 377 | (LGt ty@(ITFixed _)) -> mkOp' (LSGt (ATInt ty)) 378 | (LGe ty@(ITFixed _)) -> mkOp' (LSGe (ATInt ty)) 379 | (LUDiv ty@(ITFixed _)) -> mkOp' (LSDiv (ATInt ty)) 380 | 381 | (LAnd ty) -> mkIntCast ty $ mkBitAnd (asInt ty lhs) (asInt ty rhs) 382 | (LOr ty) -> mkIntCast ty $ mkBitOr (asInt ty lhs) (asInt ty rhs) 383 | (LXOr ty) -> mkIntCast ty $ mkBitXor (asInt ty lhs) (asInt ty rhs) 384 | (LSHL ty) -> mkIntCast ty $ mkBitShl (asInt ty lhs) (mkAsUInt $ translateReg rhs) 385 | (LASHR ty) -> mkIntCast ty $ mkBitShr (asInt ty lhs) (mkAsUInt $ translateReg rhs) 386 | (LCompl ty) -> mkIntCast ty $ mkBitCompl (asInt ty arg) 387 | 388 | LStrConcat -> mkAdd (asString lhs) (asString rhs) 389 | LStrEq -> mkBoolToInt $ mkEq (asString lhs) (asString rhs) 390 | LStrLt -> mkBoolToInt $ mkLessThan (asString lhs) (asString rhs) 391 | LStrLen -> mkCall "RuneCountInString" [asString arg] 392 | 393 | (LStrInt ITNative) -> mkCast intTy $ mkCall "StringToInt" [asString arg] 394 | (LIntStr ITNative) -> mkToString $ translateReg arg 395 | (LIntStr ITBig) -> mkMeth (asBig arg) "String" [] 396 | (LStrInt ITBig) -> mkStringToBigInt (asString arg) 397 | LFloatStr -> mkToString $ translateReg arg 398 | LStrFloat -> mkCall "StringToFloat" [asString arg] 399 | 400 | (LIntFloat ITNative) -> mkCast floatTy (asType intTy $ translateReg arg) 401 | (LFloatInt ITNative) -> mkCast intTy (asType floatTy $ translateReg arg) 402 | (LChInt ITNative) -> mkCast intTy (asType charTy $ translateReg arg) 403 | (LIntCh ITNative) -> mkCast charTy (asType intTy $ translateReg arg) 404 | 405 | LFExp -> floatfn "Exp" arg 406 | LFLog -> floatfn "Log" arg 407 | LFSin -> floatfn "Sin" arg 408 | LFCos -> floatfn "Cos" arg 409 | LFTan -> floatfn "Tan" arg 410 | LFASin -> floatfn "Asin" arg 411 | LFACos -> floatfn "Acos" arg 412 | LFATan -> floatfn "Atan" arg 413 | LFSqrt -> floatfn "Sqrt" arg 414 | LFFloor -> floatfn "Floor" arg 415 | LFCeil -> floatfn "Ceil" arg 416 | 417 | LStrCons -> mkCall "Sprintf" [ASTString "%c%s", asType charTy $ translateReg lhs, asString rhs] 418 | 419 | LStrHead -> mkCall "Utf8Head" [asString arg] 420 | 421 | LStrRev -> mkCall "Utf8Reverse" [asString arg] 422 | 423 | LStrIndex -> mkCall "Utf8AtIndex" [asString lhs, asType intTy $ translateReg rhs] 424 | 425 | LStrTail -> mkCall "Utf8Tail" [asString arg] 426 | 427 | LReadStr -> mkCall "FileReadLine" [asType fileTy $ translateReg arg] 428 | LSystemInfo -> ASTString "golang backend (stub version info)" 429 | LNullPtr -> mkNull 430 | 431 | LStdIn -> ASTIdent "Stdin" 432 | LStdOut -> ASTIdent "Stdout" 433 | LStdErr -> ASTIdent "Stderr" 434 | 435 | _ -> error ("Not implemented: " ++ show op) 436 | 437 | where 438 | (lhs:rhs:_) = args 439 | (arg:_) = args 440 | 441 | mkTrunc src dst mask = 442 | mkCast (wordTy dst) (mkBitAnd (asType src $ translateReg arg) (ASTRaw mask)) 443 | 444 | mkIntCast ty expr = mkCast (arithTy (ATInt ty)) expr 445 | 446 | asString reg = asType stringTy (translateReg reg) 447 | asNum ty reg = asType (arithTy ty) (translateReg reg) 448 | asInt ty reg = asType (arithTy (ATInt ty)) (translateReg reg) 449 | 450 | arithTy (ATInt ITNative) = intTy 451 | arithTy (ATInt ITChar) = charTy 452 | arithTy (ATFloat) = floatTy 453 | arithTy (ATInt (ITFixed IT8)) = wordTy 8 454 | arithTy (ATInt (ITFixed IT16)) = wordTy 16 455 | arithTy (ATInt (ITFixed IT32)) = wordTy 32 456 | arithTy (ATInt (ITFixed IT64)) = wordTy 64 457 | arithTy (ty) = error ("UNKNOWN TYPE: " ++ show ty) 458 | 459 | floatfn fn r = mkCall fn [asType floatTy $ translateReg r] 460 | 461 | mkError _ = ASTError 462 | 463 | mkBigLit _ i = show i 464 | 465 | lineTerminator _ = "" 466 | condBraces _ = ("","") 467 | 468 | compileAlloc info indent (ASTAlloc typename name val) = 469 | case val of Nothing -> decl 470 | Just expr -> decl `T.append` " = " `T.append` compile' info indent expr 471 | where 472 | decl = case typename of Nothing -> T.pack ("var " ++ name) 473 | Just t -> T.pack ("var " ++ name ++ " " ++ t) 474 | 475 | compileError info indent (ASTError exc) = compile info (mkCall "Println" [ASTString exc]) 476 | 477 | --------------------------------------------------------------------------------------------------- 478 | 479 | vm = "vm" 480 | baseType = "uintptr" 481 | oldbase = "oldbase" 482 | myoldbase = "myoldbase" 483 | 484 | vmType ="VirtualMachine" 485 | vmApplyFn = "_idris__123_APPLY0_125_" 486 | vmMainFn = "_idris__123_runMain0_125_" 487 | 488 | mkVm = ASTIdent vm 489 | mkStack = ASTPtrProj mkVm "ValueStack" 490 | mkCallstack = ASTPtrProj mkVm "CallStack" 491 | mkStackbase = ASTPtrProj mkVm "ValueStackBase" 492 | mkStacktop = ASTPtrProj mkVm "ValueStackTop" 493 | mkRet = ASTPtrProj mkVm "ReturnValue" 494 | mkOldbase = ASTIdent oldbase 495 | mkMyOldbase = ASTIdent myoldbase 496 | mkNull = ASTIdent nullptr 497 | 498 | mkLoc 0 = ASTIndex mkStack mkStackbase 499 | mkLoc n = ASTIndex mkStack (mkAdd mkStackbase (ASTNum (ASTInt n))) 500 | 501 | mkTop 0 = ASTIndex mkStack mkStacktop 502 | mkTop n = ASTIndex mkStack (mkAdd mkStacktop (ASTNum (ASTInt n))) 503 | 504 | mkPush args = ASTApp (ASTProj mkCallstack "push") args 505 | mkPop = ASTBinOp ";" (mkMeth mkCallstack "top" []) (mkMeth mkCallstack "pop" []) 506 | 507 | fnParams :: [String] 508 | fnParams = [vm ++ " *" ++ vmType ++ ", " ++ oldbase ++ " " ++ baseType] 509 | 510 | asType :: String -> ASTNode -> ASTNode 511 | asType typ obj = ASTProj obj ("(" ++ typ ++ ")") 512 | 513 | translatedType :: ASTNode -> String 514 | translatedType e = case e of 515 | (ASTString _) -> stringTy 516 | (ASTNum (ASTFloat _)) -> floatTy 517 | (ASTNum _) -> intTy 518 | (ASTChar _) -> charTy 519 | (ASTWord (ASTWord8 _)) -> wordTy 8 520 | (ASTWord (ASTWord16 _)) -> wordTy 16 521 | (ASTWord (ASTWord32 _)) -> wordTy 32 522 | (ASTWord (ASTWord64 _)) -> wordTy 64 523 | (ASTType ASTIntTy) -> intTy 524 | (ASTType ASTStringTy) -> stringTy 525 | (ASTType ASTIntegerTy) -> bigIntTy 526 | (ASTType ASTFloatTy) -> floatTy 527 | (ASTType ASTCharTy) -> charTy 528 | (ASTType ASTPtrTy) -> ptrTy 529 | _ -> "" 530 | 531 | mkToString :: ASTNode -> ASTNode 532 | mkToString value = mkCall "Sprint" [value] 533 | 534 | mkAsInt :: ASTNode -> ASTNode 535 | mkAsInt obj = mkMeth (mkCall "ValueOf" [obj]) "Int" [] 536 | 537 | mkAsUInt :: ASTNode -> ASTNode 538 | mkAsUInt obj = mkMeth (mkCall "ValueOf" [obj]) "Uint" [] 539 | 540 | mkCast :: String -> ASTNode -> ASTNode 541 | mkCast typ expr = mkCall typ [expr] 542 | 543 | mkBoolToInt :: ASTNode -> ASTNode 544 | mkBoolToInt b = mkCall "BoolToInt" [b] 545 | 546 | ignoreSecond :: ASTNode -> ASTNode 547 | ignoreSecond arg = ASTBinOp "," arg (ASTIdent "_") 548 | 549 | mkAssignFirst :: ASTNode -> ASTNode -> ASTNode 550 | mkAssignFirst lhs rhs = ASTAssign (ignoreSecond lhs) rhs 551 | 552 | mkAllocBigInt :: ASTNode 553 | mkAllocBigInt = mkCall "new" [ASTIdent "big.Int"] 554 | 555 | mkNewBigInt' :: ASTNode -> ASTNode 556 | mkNewBigInt' n = mkCall "big.NewInt" [n] 557 | 558 | mkNewBigInt :: Integer -> ASTNode 559 | mkNewBigInt n = mkNewBigInt' (mkBigInt n) 560 | 561 | mkNewBigUInt' :: ASTNode -> ASTNode 562 | mkNewBigUInt' n = mkMeth mkAllocBigInt "SetUint64" [n] 563 | 564 | mkNewBigUInt :: Integer -> ASTNode 565 | mkNewBigUInt n = mkNewBigUInt' (mkBigInt n) 566 | 567 | mkNewBigUIntStr :: String -> ASTNode 568 | mkNewBigUIntStr n = mkNewBigUInt' (ASTRaw n) 569 | 570 | mkStringToBigInt :: ASTNode -> ASTNode 571 | mkStringToBigInt n = mkCall "StringToBigInt" [n] 572 | 573 | asBig :: Reg -> ASTNode 574 | asBig r = asType bigIntTy $ translateReg r 575 | 576 | nullptr = "nil" 577 | intTy = "int" 578 | bigIntTy = "*big.Int" 579 | floatTy = "float64" 580 | stringTy = "string" 581 | charTy = "rune" 582 | ptrTy = "Ptr" 583 | conTy = "Con" 584 | fileTy = "*File" 585 | 586 | wordTy :: Int -> String 587 | wordTy n = PF.printf "uint%d" n 588 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Idris.Core.TT 4 | import Idris.AbsSyntax 5 | import Idris.ElabDecls 6 | import Idris.REPL 7 | 8 | import IRTS.Compiler 9 | import IRTS.CodegenCommon 10 | import IRTS.CodegenGo 11 | 12 | import Data.List 13 | import System.Environment 14 | import System.Exit 15 | 16 | data Opts = Opts { inputs :: [FilePath], 17 | output :: FilePath } 18 | 19 | showUsage = do putStrLn "Usage: idris-go [-o ]" 20 | exitWith ExitSuccess 21 | 22 | getOpts :: IO Opts 23 | getOpts = do xs <- getArgs 24 | return $ process (Opts [] "a.out") xs 25 | where 26 | process opts ("-o":o:xs) = process (opts { output = o }) xs 27 | process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs 28 | process opts [] = opts 29 | 30 | go_main :: Opts -> Idris () 31 | go_main opts = do elabPrims 32 | loadInputs (inputs opts) Nothing 33 | mainProg <- elabMain 34 | ir <- compile (Via "go") outputFilename mainProg 35 | let ir' = if ".go" `isSuffixOf` outputFilename then ir {outputType=Raw} 36 | else ir 37 | runIO $ codegenGo ir' 38 | where outputFilename = output opts 39 | 40 | main :: IO () 41 | main = do opts <- getOpts 42 | if (null (inputs opts)) 43 | then showUsage 44 | else runMain (go_main opts) 45 | 46 | --------------------------------------------------------------------------------