├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── idris2-mlf-bootstrap.ipkg ├── idris2-mlf.ipkg ├── src ├── Main.idr ├── Pretty.idr ├── SortedSet.idr └── StringMap.idr └── support ├── Makefile ├── Rts.ml └── rts_c.c /.gitignore: -------------------------------------------------------------------------------- 1 | /build/ 2 | .ts-* 3 | *.cmi 4 | *.cmx 5 | *.mli 6 | *.o 7 | *.a 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2020, idris2-mlf contributors 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this 7 | list of conditions and the following disclaimer. 8 | 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | 3. Neither the name of the copyright holder nor the names of its contributors 14 | may be used to endorse or promote products derived from this software without 15 | specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # executables 2 | IDRIS2 ?= idris2 3 | IDRIS2_MLF ?= $(shell $(IDRIS2) --prefix)/bin/idris2-mlf 4 | 5 | # paths 6 | PREFIX ?= $(shell $(IDRIS2) --prefix) 7 | export LIBDIR ?= $(shell $(IDRIS2) --libdir) 8 | 9 | .PHONY: all clean build bootstrap install 10 | 11 | all: build 12 | 13 | build: build/exec/idris2-mlf support/.ts-build 14 | 15 | build/exec/idris2-mlf-bootstrap: src/*.idr 16 | $(IDRIS2) --build idris2-mlf-bootstrap.ipkg 17 | 18 | bootstrap: build/exec/idris2-mlf-bootstrap install-support 19 | build/exec/idris2-mlf-bootstrap --build idris2-mlf.ipkg 20 | make install 21 | 22 | rebootstrap: install-support # do not rebuild the bootstrap compiler 23 | build/exec/idris2-mlf-bootstrap --build idris2-mlf.ipkg 24 | make install 25 | 26 | build/exec/idris2-mlf: src/*.idr 27 | @[ -e "$(IDRIS2_MLF)" ] || echo -e "\n !!! idris2-mlf not found, run 'make bootstrap' !!!\n" 28 | $(IDRIS2_MLF) --build idris2-mlf.ipkg 29 | 30 | .PHONY: support/.ts-build 31 | support/.ts-build: 32 | make -C support 33 | 34 | # install a self-compiled, statically linked version 35 | install: build install-support 36 | install -m 755 build/exec/idris2-mlf $(IDRIS2_MLF) 37 | 38 | install-support: support/.ts-build 39 | # install the support code 40 | mkdir -p $(LIBDIR)/support/mlf 41 | install -m 644 support/rts_c.o $(LIBDIR)/support/mlf 42 | install -m 644 support/Rts.{o,cmi,cmx} $(LIBDIR)/support/mlf 43 | 44 | clean: 45 | make -C support clean 46 | -rm -rf build/ 47 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # idris2-mlf 2 | 3 | [Malfunction](https://github.com/stedolan/malfunction) backend 4 | for [Idris 2](https://github.com/idris-lang/Idris2). 5 | 6 | ## Installation 7 | 8 | ### Install Idris2 API 9 | 10 | Get an `idris2` checkout. 11 | In its root directory, run `make install-api`. 12 | 13 | ### Install Malfunction 14 | 15 | Follow [the instructions in the Malfunction README](https://github.com/stedolan/malfunction). 16 | I use `ocaml-4.09.1+flambda`. 17 | 18 | Here's my [patched version](https://github.com/ziman/malfunction/) 19 | that fixes some issues with Dune on my machine. 20 | 21 | ### Build idris2-mlf 22 | 23 | In the root directory of `idris2-mlf`, run `make`. 24 | Then you can use `build/exec/idris2-mlf --codegen mlf` to compile stuff. 25 | 26 | ### Install self-hosted idris2-mlf 27 | 28 | In the root directory of `idris2-mlf`, run `make install`. 29 | This will build `idris2-mlf-mlf` using `--codegen mlf` to obtain a statically 30 | linked native binary that will be installed in `${IDRIS_PREFIX}/bin`. 31 | 32 | ## Usage 33 | 34 | * `idris2-mlf --codegen mlf` builds the whole project with inter-module optimisations. 35 | If a module is changed, all its dependencies have to be rebuilt, even if its 36 | interface stays the same. 37 | 38 | * `idris2-mlf --codegen mlf-incremental` uses `ocamlopt -opaque` to avoid 39 | rebuilding dependencies of a module if its interface did not change. 40 | 41 | ## License 42 | 43 | [BSD-3](https://github.com/ziman/idris2-mlf/blob/master/LICENSE), 44 | same as Idris 2. 45 | 46 | ## Contributors 47 | 48 | * @ziman 49 | * [@markuspf](https://github.com/markuspf) 50 | * This project exchanges patches with [idris2-ocaml](https://github.com/karroffel/Idris2-Ocaml) by @karroffel. 51 | -------------------------------------------------------------------------------- /idris2-mlf-bootstrap.ipkg: -------------------------------------------------------------------------------- 1 | package idris2-mlf-bootstrap 2 | depends = idris2, prelude, base, contrib, network 3 | sourcedir = "src" 4 | main = Main 5 | executable = idris2-mlf-bootstrap 6 | -------------------------------------------------------------------------------- /idris2-mlf.ipkg: -------------------------------------------------------------------------------- 1 | package idris2-mlf 2 | depends = idris2, prelude, base, contrib, network 3 | sourcedir = "src" 4 | -- options = "--codegen mlf" 5 | main = Main 6 | executable = idris2-mlf 7 | -------------------------------------------------------------------------------- /src/Main.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Idris.Driver 4 | 5 | import Pretty 6 | import StringMap 7 | import SortedSet 8 | 9 | import Compiler.Common 10 | import Compiler.CompileExpr 11 | import Compiler.Inline 12 | import Compiler.Scheme.Common 13 | 14 | import Core.Hash 15 | import Core.Context 16 | import Core.Directory 17 | import Core.Name 18 | import Core.Name.Namespace 19 | import Core.Options 20 | import Core.TT 21 | import Libraries.Utils.Hex 22 | import Libraries.Utils.Path 23 | 24 | import Data.List 25 | import Data.List1 26 | import Data.Maybe 27 | import Data.String 28 | import Data.Vect 29 | import Libraries.Data.NameMap 30 | 31 | import System 32 | import System.Directory 33 | import System.File 34 | import System.Info 35 | 36 | %default covering 37 | 38 | -- this will break if the same scheme foreign function is used to implement 39 | -- an operation on, say, different numeric types, as pointed out by @karroffel 40 | -- 41 | -- let's go with this for now, though 42 | -- 43 | emulatedForeigns : StringMap String 44 | emulatedForeigns = StringMap.fromList 45 | -- general 46 | [ ("scheme:string-concat", "Rts.Bytes.concat") 47 | , ("scheme:blodwen-args", "Rts.System.get_args") 48 | , ("scheme:string-pack", "Rts.String.pack") 49 | , ("scheme:string-unpack", "Rts.String.unpack") 50 | , ("scheme:blodwen-string-iterator-new", "Rts.String.Iterator.new_") 51 | , ("scheme:blodwen-string-iterator-next", "Rts.String.Iterator.next") 52 | 53 | -- clock 54 | , ("scheme:blodwen-clock-time-gccpu", "Rts.System.clocktime_gc_cpu") 55 | , ("scheme:blodwen-clock-time-gcreal", "Rts.System.clocktime_gc_real") 56 | , ("scheme:blodwen-clock-time-monotonic", "Rts.System.clocktime_monotonic") 57 | , ("scheme:blodwen-clock-time-process", "Rts.System.clocktime_process") 58 | , ("scheme:blodwen-clock-time-thread", "Rts.System.clocktime_thread") 59 | , ("scheme:blodwen-clock-time-utc", "Rts.System.clocktime_utc") 60 | , ("scheme:blodwen-clock-second", "Rts.System.os_clock_second") 61 | , ("scheme:blodwen-clock-nanosecond", "Rts.System.os_clock_nanosecond") 62 | , ("scheme:blodwen-is-time?", "Rts.System.os_clock_valid") 63 | 64 | -- chez refuses to use foreign C functions for buffers 65 | -- probably as a reminder that the backend-specific versions will be faster 66 | , ("scheme:blodwen-new-buffer", "Rts.C.Lib_libidris2_support.idris2_newBuffer") 67 | , ("scheme:blodwen-buffer-size", "Rts.C.Lib_libidris2_support.idris2_getBufferSize") 68 | , ("scheme:blodwen-buffer-copydata", "Rts.C.Lib_libidris2_support.idris2_copyBuffer") 69 | , ("scheme:blodwen-buffer-getbyte", "Rts.C.Lib_libidris2_support.idris2_getBufferByte") 70 | , ("scheme:blodwen-buffer-getint", "Rts.C.Lib_libidris2_support.idris2_getBufferInt") 71 | , ("scheme:blodwen-buffer-getdouble", "Rts.C.Lib_libidris2_support.idris2_getBufferDouble") 72 | , ("scheme:blodwen-buffer-getstring", "Rts.C.Lib_libidris2_support.idris2_getBufferString") 73 | , ("scheme:blodwen-buffer-setbyte", "Rts.C.Lib_libidris2_support.idris2_setBufferByte") 74 | , ("scheme:blodwen-buffer-setint", "Rts.C.Lib_libidris2_support.idris2_setBufferInt") 75 | , ("scheme:blodwen-buffer-setdouble", "Rts.C.Lib_libidris2_support.idris2_setBufferDouble") 76 | , ("scheme:blodwen-buffer-setstring", "Rts.C.Lib_libidris2_support.idris2_setBufferString") 77 | ] 78 | 79 | heXX : Int -> String 80 | heXX x = hd (x `div` 16) ++ hd (x `mod` 16) 81 | where 82 | hd : Int -> String 83 | hd 10 = "A" 84 | hd 11 = "B" 85 | hd 12 = "C" 86 | hd 13 = "D" 87 | hd 14 = "E" 88 | hd 15 = "F" 89 | hd i = show i 90 | 91 | showChar : Char -> String -> String 92 | showChar '\\' = ("\\\\" ++) 93 | showChar '"' = ("\\\"" ++) 94 | showChar '\n' = ("\\n" ++) 95 | showChar c 96 | = if c < chr 32 97 | then (("\\x" ++ heXX (cast c) ++ "") ++) 98 | else strCons c 99 | 100 | showString : List Char -> String -> String 101 | showString [] = id 102 | showString (c::cs) = showChar c . showString cs 103 | 104 | mlfString : String -> Doc 105 | mlfString cs = text $ strCons '"' (showString (unpack cs) "\"") 106 | 107 | sexp : List Doc -> Doc 108 | sexp = parens . hsep 109 | 110 | mlfGlobal : String -> Doc 111 | mlfGlobal mlName = parens $ 112 | text "global" 113 | <++> hsep 114 | [ text ("$" ++ n) 115 | | n <- toList $ split (== '.') mlName 116 | ] 117 | 118 | mlfApply : Doc -> List Doc -> Doc 119 | mlfApply f [] = f 120 | mlfApply f args = parens $ 121 | text "apply" <++> f 122 | $$ indentBlock args 123 | 124 | mlfLibCall : String -> List Doc -> Doc 125 | mlfLibCall fn args = mlfApply (mlfGlobal fn) args 126 | 127 | mlfError : String -> Doc 128 | mlfError msg = mlfLibCall "Stdlib.failwith" [mlfString msg] 129 | 130 | mlfDebug : Show a => a -> Doc 131 | mlfDebug = mlfError . show 132 | 133 | sanitise : String -> String 134 | sanitise = pack . concatMap sanitise' . unpack 135 | where 136 | san : Char -> Bool 137 | san c = 138 | ('A' <= c && c <= 'Z') 139 | || ('a' <= c && c <= 'z') 140 | || ('0' <= c && c <= '9') 141 | 142 | sanitise' : Char -> List Char 143 | sanitise' c = 144 | if san c 145 | then [c] 146 | else '_' :: unpack (show $ ord c) ++ ['_'] 147 | 148 | mlfName : Name -> Doc 149 | mlfName (MN n i) = text (sanitise n) <+> show i 150 | mlfName n = text . sanitise . schName $ n 151 | 152 | -- ML identifiers can't start with capital letters 153 | mlfGlobalName : Name -> Doc 154 | mlfGlobalName n = text "idr_" <+> mlfName n 155 | 156 | mlfLocalVar : Name -> Doc 157 | mlfLocalVar n = text "$" <+> mlfName n 158 | 159 | mlfGlobalVar : Name -> Doc 160 | mlfGlobalVar n = text "$" <+> mlfGlobalName n 161 | 162 | -- returns MLF module name 163 | mlfNS : Name -> String 164 | mlfNS (NS ns n) = "Mod_" ++ concat (intersperse "_" $ reverse $ unsafeUnfoldNamespace ns) 165 | mlfNS n = "Misc" 166 | 167 | record ModuleName where 168 | constructor MkMN 169 | string : String 170 | 171 | Eq ModuleName where 172 | MkMN x == MkMN y = x == y 173 | 174 | mlfGlobalNS : StringMap ModuleName -> ModuleName -> Name -> Doc 175 | mlfGlobalNS nsMap curModuleName n = 176 | let mns = mlfNS n 177 | in case StringMap.lookup mns nsMap of 178 | Nothing => mlfError $ "mlfGlobalNS: impossible: could not find " ++ show mns 179 | Just targetModName => 180 | if targetModName == curModuleName 181 | then mlfGlobalVar n -- within-module reference 182 | else sexp [text "global", text ("$" ++ targetModName.string), mlfGlobalVar n] 183 | 184 | mlfLet : Name -> Doc -> Doc -> Doc 185 | mlfLet n val rhs = parens $ 186 | text "let" 187 | $$ indentBlock 188 | [ sexp [mlfLocalVar n, val] 189 | , rhs 190 | ] 191 | 192 | mlfLazy : Doc -> Doc 193 | mlfLazy doc = sexp [text "lazy", doc] 194 | 195 | mlfLam : List Name -> Doc -> Doc 196 | mlfLam [] rhs = mlfLazy rhs 197 | mlfLam args rhs = 198 | parens $ 199 | text "lambda" <++> sexp (map mlfLocalVar args) 200 | $$ indent rhs 201 | 202 | mlfForce : Doc -> Doc 203 | mlfForce doc = sexp [text "force", doc] 204 | 205 | mlfBlock : Maybe Int -> List Doc -> Doc 206 | mlfBlock Nothing args = mlfError "no constructor tag (1)" 207 | mlfBlock (Just tag) args = parens $ 208 | text "block" <++> sexp [text "tag", show tag] 209 | $$ indentBlock args 210 | 211 | mlfCmp : String -> String -> String -> List Doc -> Doc 212 | mlfCmp conv cmp zero args = sexp [text cmp, mlfLibCall conv args, text zero] 213 | 214 | mlfOp : PrimFn arr -> Vect arr Doc -> Doc 215 | mlfOp (Add IntType) [x,y] = sexp [text "+.int", x,y] 216 | mlfOp (Sub IntType) [x,y] = sexp [text "-.int", x,y] 217 | mlfOp (Mul IntType) [x,y] = sexp [text "*.int", x,y] 218 | mlfOp (Div IntType) [x,y] = sexp [text "/.int", x,y] 219 | mlfOp (Mod IntType) [x,y] = sexp [text "%.int", x,y] 220 | mlfOp (Neg IntType) [x] = sexp [text "neg.int", x] 221 | mlfOp (ShiftL IntType) [x,y] = sexp [text "<<.int", x, y] 222 | mlfOp (ShiftR IntType) [x,y] = sexp [text ">>.int", x, y] 223 | mlfOp (BAnd IntType) [x,y] = sexp [text "&.int", x, y] 224 | mlfOp (BOr IntType) [x,y] = sexp [text "|.int", x, y] 225 | mlfOp (BXOr IntType) [x,y] = sexp [text "^.int", x, y] 226 | 227 | mlfOp (LT IntType) [x,y] = sexp [text "<.int", x,y] 228 | mlfOp (LTE IntType) [x,y] = sexp [text "<=.int", x,y] 229 | mlfOp (EQ IntType) [x,y] = sexp [text "==.int", x,y] 230 | mlfOp (GTE IntType) [x,y] = sexp [text ">=.int", x,y] 231 | mlfOp (GT IntType) [x,y] = sexp [text ">.int", x,y] 232 | 233 | mlfOp (LT CharType) [x,y] = sexp [text "<.int", x,y] 234 | mlfOp (LTE CharType) [x,y] = sexp [text "<=.int", x,y] 235 | mlfOp (EQ CharType) [x,y] = sexp [text "==.int", x,y] 236 | mlfOp (GTE CharType) [x,y] = sexp [text ">=.int", x,y] 237 | mlfOp (GT CharType) [x,y] = sexp [text ">.int", x,y] 238 | 239 | mlfOp (Add IntegerType) [x,y] = sexp [text "+.ibig", x,y] 240 | mlfOp (Sub IntegerType) [x,y] = sexp [text "-.ibig", x,y] 241 | mlfOp (Mul IntegerType) [x,y] = sexp [text "*.ibig", x,y] 242 | mlfOp (Div IntegerType) [x,y] = sexp [text "/.ibig", x,y] 243 | mlfOp (Mod IntegerType) [x,y] = sexp [text "%.ibig", x,y] 244 | mlfOp (Neg IntegerType) [x] = sexp [text "neg.ibig", x] 245 | mlfOp (ShiftL IntegerType) [x,y] = sexp [text "<<.ibig", x, y] 246 | mlfOp (ShiftR IntegerType) [x,y] = sexp [text ">>.ibig", x, y] 247 | mlfOp (BAnd IntegerType) [x,y] = sexp [text "&.ibig", x, y] 248 | mlfOp (BOr IntegerType) [x,y] = sexp [text "|.ibig", x, y] 249 | mlfOp (BXOr IntegerType) [x,y] = sexp [text "^.ibig", x, y] 250 | 251 | mlfOp (LT IntegerType) [x,y] = sexp [text "<.ibig", x,y] 252 | mlfOp (LTE IntegerType) [x,y] = sexp [text "<=.ibig", x,y] 253 | mlfOp (EQ IntegerType) [x,y] = sexp [text "==.ibig", x,y] 254 | mlfOp (GTE IntegerType) [x,y] = sexp [text ">=.ibig", x,y] 255 | mlfOp (GT IntegerType) [x,y] = sexp [text ">.ibig", x,y] 256 | 257 | mlfOp (Add DoubleType) [x,y] = sexp [text "+.f64", x,y] 258 | mlfOp (Sub DoubleType) [x,y] = sexp [text "-.f64", x,y] 259 | mlfOp (Mul DoubleType) [x,y] = sexp [text "*.f64", x,y] 260 | mlfOp (Div DoubleType) [x,y] = sexp [text "/.f64", x,y] 261 | mlfOp (Mod DoubleType) [x,y] = sexp [text "%.f64", x,y] 262 | mlfOp (Neg DoubleType) [x] = sexp [text "neg.f64", x] 263 | 264 | mlfOp (LT DoubleType) [x,y] = sexp [text "<.f64", x,y] 265 | mlfOp (LTE DoubleType) [x,y] = sexp [text "<=.f64", x,y] 266 | mlfOp (EQ DoubleType) [x,y] = sexp [text "==.f64", x,y] 267 | mlfOp (GTE DoubleType) [x,y] = sexp [text ">=.f64", x,y] 268 | mlfOp (GT DoubleType) [x,y] = sexp [text ">.f64", x,y] 269 | 270 | mlfOp DoubleExp [x] = mlfLibCall "Float.exp" [x] 271 | mlfOp DoubleLog [x] = mlfLibCall "Float.log" [x] -- should this be Float.log10? 272 | mlfOp DoubleSin [x] = mlfLibCall "Float.sin" [x] 273 | mlfOp DoubleCos [x] = mlfLibCall "Float.cos" [x] 274 | mlfOp DoubleTan [x] = mlfLibCall "Float.tan" [x] 275 | mlfOp DoubleASin [x] = mlfLibCall "Float.asin" [x] 276 | mlfOp DoubleACos [x] = mlfLibCall "Float.acos" [x] 277 | mlfOp DoubleATan [x] = mlfLibCall "Float.atan" [x] 278 | mlfOp DoubleSqrt [x] = mlfLibCall "Float.sqrt" [x] 279 | mlfOp DoubleFloor [x] = mlfLibCall "Float.floor" [x] 280 | mlfOp DoubleCeiling [x] = mlfLibCall "Float.ceil" [x] 281 | 282 | mlfOp (Cast IntegerType DoubleType) [x] = sexp [text "convert.ibig.f64", x] 283 | mlfOp (Cast DoubleType IntegerType) [x] = sexp [text "convert.f64.ibig", x] 284 | mlfOp (Cast IntType DoubleType) [x] = sexp [text "convert.int.f64", x] 285 | mlfOp (Cast DoubleType IntType) [x] = sexp [text "convert.f64.int", x] 286 | mlfOp (Cast IntegerType IntType) [x] = sexp [text "convert.ibig.int", x] 287 | mlfOp (Cast IntType IntegerType) [x] = sexp [text "convert.int.ibig", x] 288 | mlfOp (Cast IntegerType CharType) [x] = sexp [text "convert.ibig.int", x] 289 | mlfOp (Cast CharType IntegerType) [x] = sexp [text "convert.int.ibig", x] 290 | mlfOp (Cast CharType IntType) [x] = x 291 | mlfOp (Cast IntType CharType) [x] = x 292 | mlfOp (Cast IntegerType StringType) [x] = mlfLibCall "Z.to_string" [x] 293 | mlfOp (Cast IntType StringType) [x] = mlfLibCall "Stdlib.string_of_int" [x] 294 | mlfOp (Cast StringType IntegerType) [x] = mlfLibCall "Z.of_string" [x] 295 | mlfOp (Cast StringType IntType) [x] = mlfLibCall "Stdlib.int_of_string" [x] 296 | mlfOp (Cast CharType StringType) [x] = mlfLibCall "Rts.String.of_char" [x] 297 | mlfOp (Cast StringType CharType) [x] = mlfLibCall "Rts.String.head" [x] 298 | mlfOp (Cast StringType DoubleType) [x] = mlfLibCall "Float.of_string" [x] 299 | mlfOp (Cast DoubleType StringType) [x] = mlfLibCall "Float.to_string" [x] 300 | 301 | mlfOp (Cast Int8Type IntType) [x] = x 302 | mlfOp (Cast IntType Int8Type) [x] = x 303 | mlfOp (Cast Int8Type IntegerType) [x] = sexp [text "convert.int.ibig", x] 304 | mlfOp (Cast IntegerType Int8Type) [x] = sexp [text "convert.ibig.int", x] 305 | mlfOp (Cast Int8Type StringType) [x] = mlfLibCall "Stdlib.string_of_int" [x] 306 | mlfOp (Cast StringType Int8Type) [x] = mlfLibCall "Stdlib.int_of_string" [x] 307 | 308 | mlfOp (Cast Int16Type IntType) [x] = x 309 | mlfOp (Cast IntType Int16Type) [x] = x 310 | mlfOp (Cast Int16Type IntegerType) [x] = sexp [text "convert.int.ibig", x] 311 | mlfOp (Cast IntegerType Int16Type) [x] = sexp [text "convert.ibig.int", x] 312 | mlfOp (Cast Int16Type StringType) [x] = mlfLibCall "Stdlib.string_of_int" [x] 313 | mlfOp (Cast StringType Int16Type) [x] = mlfLibCall "Stdlib.int_of_string" [x] 314 | 315 | mlfOp (Cast Int32Type IntType) [x] = sexp [text "convert.i32.int", x] 316 | mlfOp (Cast IntType Int32Type) [x] = sexp [text "convert.int.i32", x] 317 | mlfOp (Cast Int32Type IntegerType) [x] = sexp [text "convert.i32.ibig", x] 318 | mlfOp (Cast IntegerType Int32Type) [x] = sexp [text "convert.ibig.i32", x] 319 | mlfOp (Cast Int32Type StringType) [x] = mlfLibCall "Int32.to_string" [x] 320 | mlfOp (Cast StringType Int32Type) [x] = mlfLibCall "Int32.of_string" [x] 321 | 322 | mlfOp (Cast Int64Type IntType) [x] = sexp [text "convert.i64.int", x] 323 | mlfOp (Cast IntType Int64Type) [x] = sexp [text "convert.int.i64", x] 324 | mlfOp (Cast Int64Type IntegerType) [x] = sexp [text "convert.i64.ibig", x] 325 | mlfOp (Cast IntegerType Int64Type) [x] = sexp [text "convert.ibig.i64", x] 326 | mlfOp (Cast Int64Type StringType) [x] = mlfLibCall "Int64.to_string" [x] 327 | mlfOp (Cast StringType Int64Type) [x] = mlfLibCall "Int64.of_string" [x] 328 | 329 | mlfOp (Cast Bits8Type IntType) [x] = x 330 | mlfOp (Cast IntType Bits8Type) [x] = x 331 | mlfOp (Cast Bits8Type IntegerType) [x] = sexp [text "convert.int.ibig", x] 332 | mlfOp (Cast IntegerType Bits8Type) [x] = sexp [text "convert.ibig.int", x] 333 | mlfOp (Cast Bits8Type StringType) [x] = mlfLibCall "Stdlib.string_of_int" [x] 334 | mlfOp (Cast StringType Bits8Type) [x] = mlfLibCall "Stdlib.int_of_string" [x] 335 | 336 | mlfOp (Cast Bits16Type IntType) [x] = x 337 | mlfOp (Cast IntType Bits16Type) [x] = x 338 | mlfOp (Cast Bits16Type IntegerType) [x] = sexp [text "convert.int.ibig", x] 339 | mlfOp (Cast IntegerType Bits16Type) [x] = sexp [text "convert.ibig.int", x] 340 | mlfOp (Cast Bits16Type StringType) [x] = mlfLibCall "Stdlib.string_of_int" [x] 341 | mlfOp (Cast StringType Bits16Type) [x] = mlfLibCall "Stdlib.int_of_string" [x] 342 | 343 | -- mlfOp (Cast Bits32Type IntType) [x] = mlfLibCall "Int32.unsigned_to_int" [x] 344 | mlfOp (Cast IntType Bits32Type) [x] = mlfLibCall "Int32.of_int" [x] 345 | -- mlfOp (Cast Bits32Type IntegerType) [x] = sexp [text "convert.i32.ibig", x] 346 | mlfOp (Cast IntegerType Bits32Type) [x] = sexp [text "convert.ibig.i32", x] 347 | mlfOp (Cast Bits32Type IntegerType) [x] = sexp 348 | [ text "%.ibig" 349 | , sexp 350 | [ text "+.ibig" 351 | , sexp [text "convert.i32.ibig", x] 352 | , text "4294967296.ibig" 353 | ] 354 | , text "4294967296.ibig" 355 | ] 356 | -- mlfOp (Cast Bits32Type StringType) [x] = mlfLibCall "Stdlib.string_of_int" [x] 357 | -- mlfOp (Cast StringType Bits32Type) [x] = mlfLibCall "Stdlib.int_of_string" [x] 358 | 359 | mlfOp (Cast IntType Bits64Type) [x] = mlfLibCall "Int64.of_int" [x] 360 | mlfOp (Cast IntegerType Bits64Type) [x] = sexp [text "convert.ibig.i64", x] 361 | mlfOp (Cast Bits64Type IntegerType) [x] = sexp 362 | [ text "%.ibig" 363 | , sexp 364 | [ text "+.ibig" 365 | , sexp [text "convert.i64.ibig", x] 366 | , text "18446744073709551616.ibig" 367 | ] 368 | , text "18446744073709551616.ibig" 369 | ] 370 | 371 | mlfOp StrLength [x] = mlfLibCall "Rts.String.length" [x] 372 | mlfOp StrHead [x] = mlfLibCall "Rts.String.head" [x] 373 | mlfOp StrTail [x] = mlfLibCall "Rts.String.tail" [x] 374 | mlfOp StrIndex [x, i] = mlfLibCall "Rts.String.get" [x, i] 375 | mlfOp StrCons [x, xs] = mlfLibCall "Rts.String.cons" [x, xs] 376 | mlfOp StrReverse [x] = mlfLibCall "Rts.String.reverse" [x] 377 | mlfOp StrSubstr [off, len, s] = mlfLibCall "Rts.String.substring" [off, len, s] 378 | mlfOp StrAppend [x,y] = mlfLibCall "Bytes.cat" [x, y] 379 | 380 | mlfOp (LT StringType) [x,y] = mlfCmp "String.compare" "<.int" "0" [x,y] 381 | mlfOp (LTE StringType) [x,y] = mlfCmp "String.compare" "<=.int" "0" [x,y] 382 | mlfOp (EQ StringType) [x,y] = mlfCmp "String.compare" "==.int" "0" [x,y] 383 | mlfOp (GTE StringType) [x,y] = mlfCmp "String.compare" ">=.int" "0" [x,y] 384 | mlfOp (GT StringType) [x,y] = mlfCmp "String.compare" ">.int" "0" [x,y] 385 | 386 | mlfOp Crash [_, msg] = mlfLibCall "Stdlib.failwith" [msg] 387 | mlfOp BelieveMe [_, _, x] = x 388 | 389 | mlfOp op args = mlfError $ "unimplemented primop: " ++ show op 390 | 391 | private 392 | un : String -> Name 393 | un = UN . Basic 394 | 395 | mlfExtPrim : Name -> Doc 396 | mlfExtPrim (NS _ (UN (Basic "prim__newArray"))) = 397 | mlfLam [un "_ty", un "n", un "x", un "_world"] $ 398 | sexp [text "makevec", mlfLocalVar (un "n"), mlfLocalVar (un "x")] 399 | mlfExtPrim (NS _ (UN (Basic "prim__arrayGet"))) = 400 | mlfLam [un "_ty", un "arr", un "i", un "_world"] $ 401 | sexp [text "load", mlfLocalVar (un "arr"), mlfLocalVar (un "i")] 402 | mlfExtPrim (NS _ (UN (Basic "prim__arraySet"))) = 403 | mlfLam [un "_ty", un "arr", un "i", un "x", un "_world"] $ 404 | sexp [text "store", mlfLocalVar (un "arr"), mlfLocalVar (un "i"), mlfLocalVar (un "x")] 405 | mlfExtPrim (NS _ (UN (Basic "prim__newIORef"))) = 406 | mlfLam [un "_ty", un "x", un "_world"] $ 407 | sexp [text "makevec", show 1, mlfLocalVar (un "x")] 408 | mlfExtPrim (NS _ (UN (Basic "prim__readIORef"))) = 409 | mlfLam [un "_ty", un "ref", un "_world"] $ 410 | sexp [text "load", mlfLocalVar (un "ref"), show 0] 411 | mlfExtPrim (NS _ (UN (Basic "prim__writeIORef"))) = 412 | mlfLam [un "_ty", un "ref", un "x", un "_world"] $ 413 | sexp [text "store", mlfLocalVar (un "ref"), show 0, mlfLocalVar (un "x")] 414 | mlfExtPrim (NS _ (UN (Basic "prim__schemeCall"))) = 415 | mlfLam [un "_rTy", un "fn", un "_args", un "_world"] $ 416 | mlfLibCall "Stdlib.failwith" [mlfLocalVar (un "fn")] 417 | mlfExtPrim (NS _ (UN (Basic "prim__codegen"))) = mlfString "malfunction" 418 | mlfExtPrim (NS _ (UN (Basic "prim__os"))) = mlfGlobal "Rts.System.os_name" 419 | mlfExtPrim n = mlfError $ "unimplemented external primitive: " ++ show n 420 | 421 | mlfConstant : Constant -> Doc 422 | mlfConstant (I x) = show x 423 | mlfConstant (BI x) = show x <+> text ".ibig" 424 | mlfConstant (Str s) = mlfString s 425 | mlfConstant (Ch x) = show (ord x) 426 | mlfConstant (Db x) = 427 | case filter (== '.') (unpack $ Prelude.show x) of 428 | [] => Pretty.show x <+> text ".0" 429 | _ => Pretty.show x 430 | 431 | mlfConstant (I8 x) = show x 432 | mlfConstant (I16 x) = show x 433 | mlfConstant (I32 x) = show x <+> text ".i32" 434 | mlfConstant (I64 x) = show x <+> text ".i64" 435 | 436 | mlfConstant (B8 x) = show x 437 | mlfConstant (B16 x) = show x 438 | mlfConstant (B32 x) = show x <+> text ".i32" 439 | mlfConstant (B64 x) = show x <+> text ".i64" 440 | 441 | mlfConstant WorldVal = show 0 442 | 443 | mlfConstant IntType = show 0 444 | mlfConstant IntegerType = show 1 445 | mlfConstant StringType = show 2 446 | mlfConstant CharType = show 3 447 | mlfConstant DoubleType = show 4 448 | mlfConstant WorldType = show 5 449 | mlfConstant Bits8Type = show 6 450 | mlfConstant Bits16Type = show 7 451 | mlfConstant Bits32Type = show 8 452 | mlfConstant Bits64Type = show 9 453 | mlfConstant Int8Type = show 10 454 | mlfConstant Int16Type = show 11 455 | mlfConstant Int32Type = show 12 456 | mlfConstant Int64Type = show 13 457 | 458 | mlfConstPat : Constant -> Maybe Doc 459 | -- malfunction cannot switch on these 460 | mlfConstPat (BI x) = Nothing 461 | mlfConstPat (Str s) = Nothing 462 | mlfConstPat (Db x) = Nothing 463 | mlfConstPat (I32 _) = Nothing 464 | mlfConstPat (I64 _) = Nothing 465 | mlfConstPat (B32 _) = Nothing 466 | mlfConstPat (B64 _) = Nothing 467 | mlfConstPat c = Just $ mlfConstant c 468 | 469 | mlfConstEqCheck : Doc -> Constant -> Doc 470 | -- these have special comparison ops 471 | mlfConstEqCheck x (BI y) = sexp [text "==.ibig", x, mlfConstant (BI y)] 472 | mlfConstEqCheck x (I32 y) = sexp [text "==.i32", x, mlfConstant (I32 y)] 473 | mlfConstEqCheck x (I64 y) = sexp [text "==.i64", x, mlfConstant (I64 y)] 474 | mlfConstEqCheck x (B32 y) = sexp [text "==.i32", x, mlfConstant (B32 y)] 475 | mlfConstEqCheck x (B64 y) = sexp [text "==.i64", x, mlfConstant (B64 y)] 476 | mlfConstEqCheck x (Db y) = sexp [text "==.f64", x, mlfConstant (Db y)] 477 | mlfConstEqCheck x (Str y) = mlfLibCall "String.equal" [x, mlfConstant (Str y)] 478 | 479 | -- everything else is represented as ints 480 | mlfConstEqCheck x y = sexp [text "==.int", x, mlfConstant y] 481 | 482 | mlfConDflt : Doc -> Doc 483 | mlfConDflt rhs = sexp [sexp [text "tag", text "_"], text "_", rhs] 484 | 485 | mlfSwitch : Doc -> List Doc -> Maybe Doc -> Doc 486 | mlfSwitch scrut [] Nothing = 487 | mlfError $ "case with no RHS" 488 | mlfSwitch scrut [] (Just dflt) = dflt 489 | mlfSwitch scrut alts (Just dflt) = parens $ 490 | text "switch" <++> scrut 491 | $$ indent (vcat alts $$ dflt) 492 | 493 | mlfSwitch scrut alts Nothing = parens $ 494 | text "switch" <++> scrut 495 | $$ indent (if debug then (vcat alts $$ catchall) else vcat alts) 496 | where 497 | debug : Bool 498 | debug = True 499 | 500 | catchall : Doc 501 | catchall = 502 | mlfConDflt $ 503 | mlfLet (un "_") (mlfLibCall "Rts.Debug.inspect" [show 0, scrut])$ 504 | mlfError "unmatched pattern! (block tree dump above)" 505 | 506 | mlfConstDflt : Doc -> Doc 507 | mlfConstDflt rhs = sexp [text "_", rhs] 508 | 509 | mlfField : Name -> Int -> Doc 510 | mlfField n i = sexp [text "field", show i, mlfLocalVar n] 511 | 512 | number : Int -> List a -> List (Int, a) 513 | number i [] = [] 514 | number i (x :: xs) = (i,x) :: number (i+1) xs 515 | 516 | bindFieldProjs : Name -> List Name -> Doc -> Doc 517 | bindFieldProjs scrutN [] rhs = rhs 518 | bindFieldProjs scrutN ns rhs = parens $ 519 | text "let" 520 | $$ indent ( 521 | vcat [sexp [mlfLocalVar n, mlfField scrutN i] | (i, n) <- number 0 ns] 522 | $$ rhs 523 | ) 524 | 525 | ccLibFun : List String -> Maybe String 526 | ccLibFun [] = Nothing 527 | ccLibFun (cc :: ccs) = 528 | case StringMap.lookup cc emulatedForeigns of 529 | Just result => Just result 530 | Nothing => 531 | if substr 0 3 cc == "ML:" 532 | then Just (substr 3 (length cc) cc) 533 | else if substr 0 2 cc == "C:" 534 | then case split (== ',') (substr 2 (length cc) cc) of 535 | fn ::: libn :: _ => Just ("Rts.C.Lib_" ++ rmSpaces libn ++ "." ++ fn) 536 | _ => ccLibFun ccs -- something strange -> skip 537 | else ccLibFun ccs -- search further 538 | where 539 | rmSpaces : String -> String 540 | rmSpaces = pack . filter (/= ' ') . unpack 541 | 542 | {- 543 | unApp : NamedCExp -> List NamedCExp -> (NamedCExp, List NamedCExp) 544 | unApp (NmApp fc f args) args' = unApp f (args ++ args') 545 | unApp f args = (f, args) 546 | -} 547 | 548 | -- namespaces mentioned within 549 | mutual 550 | nsTm : NamedCExp -> SortedSet String 551 | nsTm (NmLocal fc n) = SortedSet.empty 552 | nsTm (NmRef fc n) = SortedSet.singleton $ mlfNS n 553 | nsTm (NmLam fc n rhs) = nsTm rhs 554 | nsTm (NmLet fc n val rhs) = nsTm val <+> nsTm rhs 555 | nsTm (NmApp fc f args) = nsTm f <+> concatMap nsTm args 556 | nsTm (NmCon fc cn ci tag args) = concatMap nsTm args 557 | nsTm (NmForce fc lr rhs) = nsTm rhs 558 | nsTm (NmDelay fc lr rhs) = nsTm rhs 559 | nsTm (NmErased fc) = SortedSet.empty 560 | nsTm (NmPrimVal ft x) = SortedSet.empty 561 | nsTm (NmOp fc op args) = concatMap nsTm args 562 | nsTm (NmExtPrim fc n args) = concatMap nsTm args 563 | nsTm (NmConCase fc scrut alts mbDflt) = 564 | nsTm scrut <+> concatMap nsConAlt alts <+> concatMap nsTm mbDflt 565 | nsTm (NmConstCase fc scrut alts mbDflt) = 566 | nsTm scrut <+> concatMap nsConstAlt alts <+> concatMap nsTm mbDflt 567 | nsTm (NmCrash fc msg) = SortedSet.empty 568 | 569 | nsConAlt : NamedConAlt -> SortedSet String 570 | nsConAlt (MkNConAlt n ci tag args rhs) = nsTm rhs 571 | 572 | nsConstAlt : NamedConstAlt -> SortedSet String 573 | nsConstAlt (MkNConstAlt c rhs) = nsTm rhs 574 | 575 | nsDef : NamedDef -> SortedSet String 576 | nsDef (MkNmFun argNs rhs) = nsTm rhs 577 | nsDef (MkNmCon tag arity nt) = SortedSet.empty 578 | nsDef (MkNmForeign ccs fargs rty) = SortedSet.empty 579 | nsDef (MkNmError rhs) = nsTm rhs 580 | 581 | parameters (ldefs : SortedSet Name, nsMapping : StringMap ModuleName, curModuleName : ModuleName) 582 | mutual 583 | bindScrut : NamedCExp -> (Name -> Doc) -> Doc 584 | bindScrut (NmLocal _ n) rhs = rhs n 585 | bindScrut scrut rhs = 586 | let scrutN = MN "scrut" 0 587 | in mlfLet scrutN (mlfTm scrut) (rhs scrutN) 588 | 589 | mlfEqChain : Name -> Maybe Doc -> List NamedConstAlt -> Doc 590 | mlfEqChain scrutN Nothing [] = mlfError "impossible eq chain" 591 | mlfEqChain scrutN (Just dflt) [] = dflt 592 | mlfEqChain scrutN mbDflt (MkNConstAlt c rhs :: alts) = parens $ 593 | text "if" <++> mlfConstEqCheck (mlfLocalVar scrutN) c 594 | $$ indent ( 595 | mlfTm rhs 596 | $$ mlfEqChain scrutN mbDflt alts 597 | ) 598 | 599 | mlfConAlt : Name -> NamedConAlt -> Doc 600 | mlfConAlt scrutN (MkNConAlt cn ci Nothing args rhs) = 601 | mlfError $ "no tag for mlfConAlt: " ++ show cn 602 | mlfConAlt scrutN (MkNConAlt cn ci (Just tag) [] rhs) = 603 | -- nullary constructors compile to ints in ocaml 604 | sexp [show tag, mlfTm rhs] 605 | mlfConAlt scrutN (MkNConAlt cn ci (Just tag) args rhs) = parens $ 606 | sexp [text "tag", show tag] 607 | $$ indent (bindFieldProjs scrutN args $ mlfTm rhs) 608 | 609 | mlfConstAlt : NamedConstAlt -> Maybe Doc 610 | mlfConstAlt (MkNConstAlt c rhs) = 611 | case mlfConstPat c of 612 | Just pat => Just $ parens (pat <++> mlfTm rhs) 613 | Nothing => Nothing 614 | 615 | mlfTm : NamedCExp -> Doc 616 | mlfTm (NmLocal fc n) = mlfLocalVar n 617 | mlfTm (NmRef fc n) = 618 | if contains n ldefs 619 | then mlfForce (mlfGlobalNS nsMapping curModuleName n) 620 | else mlfGlobalNS nsMapping curModuleName n 621 | mlfTm (NmLam fc n rhs) = mlfLam [n] (mlfTm rhs) 622 | mlfTm (NmLet fc n val rhs) = mlfLet n (mlfTm val) (mlfTm rhs) 623 | mlfTm (NmApp fc f args) = 624 | mlfApply (mlfTm f) (map mlfTm args) 625 | {- probably unnecessary 626 | let (f', args') = unApp f args 627 | in mlfApply (mlfTm f') (map mlfTm args') 628 | -} 629 | mlfTm (NmCon fc cn ci Nothing []) = mlfString (show cn) -- type constructor 630 | mlfTm (NmCon fc cn ci (Just tag) []) = show tag 631 | mlfTm (NmCon fc cn ci mbTag args) = mlfBlock mbTag (map mlfTm args) 632 | mlfTm (NmCrash fc msg) = mlfError msg 633 | mlfTm (NmForce fc lr rhs) = mlfForce (mlfTm rhs) 634 | mlfTm (NmDelay fc lr rhs) = mlfLazy (mlfTm rhs) 635 | mlfTm (NmErased fc) = mlfString "erased" 636 | mlfTm (NmPrimVal ft x) = mlfConstant x 637 | mlfTm (NmOp fc op args) = mlfOp op (map mlfTm args) 638 | mlfTm (NmExtPrim fc n args) = mlfApply (mlfExtPrim n) (map mlfTm args) 639 | mlfTm (NmConCase fc scrut alts mbDflt) = 640 | bindScrut scrut $ \scrutN => 641 | mlfSwitch 642 | (mlfLocalVar scrutN) 643 | (map (mlfConAlt scrutN) alts) 644 | (mlfConDflt . mlfTm <$> mbDflt) 645 | mlfTm (NmConstCase fc scrut alts mbDflt) = 646 | case the (Maybe (List Doc)) (traverse mlfConstAlt alts) of 647 | -- all patterns can be expressed efficiently 648 | Just alts' => 649 | mlfSwitch (mlfTm scrut) alts' (mlfConstDflt . mlfTm <$> mbDflt) 650 | 651 | -- we need to use a chain of if-equals tests 652 | Nothing => 653 | bindScrut scrut $ \scrutN => 654 | mlfEqChain scrutN (mlfTm <$> mbDflt) alts 655 | 656 | mlfBody : NamedDef -> Doc 657 | mlfBody (MkNmFun args rhs) = 658 | mlfLam args (mlfTm rhs) 659 | 660 | mlfBody (MkNmCon mbTag arity mbNewtype) = 661 | mlfLam args (mlfBlock mbTag $ map mlfLocalVar args) 662 | where 663 | args : List Name 664 | args = [un $ "arg" ++ show i | i <- [0..cast {to = Int} arity-1]] 665 | 666 | mlfBody (MkNmForeign ccs args cty) = 667 | mlfLam (map fst lamArgs) $ 668 | case ccLibFun ccs of 669 | Just fn => mlfLibCall fn (map mlfLocalVar mlArgs) 670 | Nothing => 671 | mlfError $ "unimplemented foreign: " ++ show (MkNmForeign ccs args cty) 672 | where 673 | mkArgs : Int -> List CFType -> List (Name, Bool) 674 | mkArgs i [] = [] 675 | mkArgs i (CFWorld :: cs) = (MN "farg" i, False) :: mkArgs (i + 1) cs 676 | mkArgs i (c :: cs) = (MN "farg" i, True) :: mkArgs (i + 1) cs 677 | 678 | -- arguments of the Malfunction lambda 679 | lamArgs : List (Name, Bool) 680 | lamArgs = mkArgs 0 args 681 | 682 | -- arguments of the foreign ML function 683 | mlArgs : List Name 684 | mlArgs = map fst $ case lamArgs of 685 | -- if we have only one argument, we have to keep it 686 | -- even if it's %World 687 | -- to avoid turning the function into a non-function 688 | [_] => lamArgs 689 | 690 | -- otherwise, attempt to remove %World 691 | _ => filter snd lamArgs 692 | 693 | mlfBody (MkNmError err) = 694 | mlfTm err 695 | 696 | mlfDef : (Name, FC, NamedDef) -> Doc 697 | mlfDef (n, fc, body) = 698 | parens (mlfGlobalVar n $$ indent (mlfBody body)) 699 | $$ text "" 700 | 701 | lazyDefs : List (Name, FC, NamedDef) -> SortedSet Name 702 | lazyDefs [] = empty 703 | lazyDefs ((n,_,MkNmFun [] rhs) :: defs) = insert n $ lazyDefs defs 704 | lazyDefs ((n,_,MkNmCon tag Z nt) :: defs) = insert n $ lazyDefs defs 705 | lazyDefs ((n,_,MkNmForeign ccs [] x) :: defs) = insert n $ lazyDefs defs 706 | lazyDefs ((n,_,MkNmError x) :: defs) = insert n $ lazyDefs defs 707 | lazyDefs (_ :: defs) = lazyDefs defs 708 | 709 | mlfRec : List Doc -> Doc 710 | mlfRec defs = parens $ 711 | text "rec" 712 | $$ indentBlock defs 713 | 714 | splitByNS : List (Name, FC, NamedDef) -> List (String, List (Name, FC, NamedDef)) 715 | splitByNS = StringMap.toList . foldl addOne StringMap.empty 716 | where 717 | addOne 718 | : StringMap (List (Name, FC, NamedDef)) 719 | -> (Name, FC, NamedDef) 720 | -> StringMap (List (Name, FC, NamedDef)) 721 | addOne nss def@(n, fc, nd) = 722 | StringMap.mergeWith 723 | (++) 724 | (StringMap.singleton (mlfNS n) [def]) 725 | nss 726 | 727 | -- https://en.wikipedia.org/wiki/Tarjan%27s_strongly_connected_components_algorithm#The_algorithm_in_pseudocode 728 | record TarjanVertex where 729 | constructor TV 730 | index : Int 731 | lowlink : Int 732 | inStack : Bool 733 | 734 | record TarjanState where 735 | constructor TS 736 | vertices : StringMap TarjanVertex 737 | stack : List String 738 | nextIndex : Int 739 | components : List (List String) 740 | impossibleHappened : Bool 741 | 742 | tarjan : StringMap (SortedSet String) -> List (List String) 743 | tarjan deps = loop initialState (StringMap.keys deps) 744 | where 745 | initialState : TarjanState 746 | initialState = 747 | TS 748 | StringMap.empty 749 | [] 750 | 0 751 | [] 752 | False 753 | 754 | strongConnect : TarjanState -> String -> TarjanState 755 | strongConnect ts v = 756 | let ts'' = case StringMap.lookup v deps of 757 | Nothing => ts' -- no edges 758 | Just edgeSet => loop ts' (SortedSet.toList edgeSet) 759 | in case StringMap.lookup v ts''.vertices of 760 | Nothing => record { impossibleHappened = True } ts'' 761 | Just vtv => 762 | if vtv.index == vtv.lowlink 763 | then createComponent ts'' v [] 764 | else ts'' 765 | where 766 | createComponent : TarjanState -> String -> List String -> TarjanState 767 | createComponent ts v acc = 768 | case ts.stack of 769 | [] => record { impossibleHappened = True } ts 770 | w :: ws => 771 | let ts' = record { 772 | vertices $= StringMap.adjust w record{ inStack = False }, 773 | stack = ws 774 | } ts 775 | in if w == v 776 | then record { components $= ((v :: acc) ::) } ts' -- that's it 777 | else createComponent ts' v (w :: acc) 778 | 779 | loop : TarjanState -> List String -> TarjanState 780 | loop ts [] = ts 781 | loop ts (w :: ws) = 782 | loop ( 783 | case StringMap.lookup w ts.vertices of 784 | Nothing => let ts' = strongConnect ts w in 785 | case StringMap.lookup w ts'.vertices of 786 | Nothing => record { impossibleHappened = True } ts' 787 | Just wtv => record { vertices $= StringMap.adjust v record{ lowlink $= min wtv.lowlink } } ts' 788 | 789 | Just wtv => case wtv.inStack of 790 | False => ts -- nothing to do 791 | True => record { vertices $= StringMap.adjust v record{ lowlink $= min wtv.index } } ts 792 | ) ws 793 | 794 | ts' : TarjanState 795 | ts' = record { 796 | vertices $= StringMap.insert v (TV ts.nextIndex ts.nextIndex True), 797 | stack $= (v ::), 798 | nextIndex $= (1+) 799 | } ts 800 | 801 | loop : TarjanState -> List String -> List (List String) 802 | loop ts [] = 803 | if ts.impossibleHappened 804 | then [] 805 | else ts.components 806 | loop ts (v :: vs) = 807 | case StringMap.lookup v ts.vertices of 808 | Just _ => loop ts vs -- done, skip 809 | Nothing => loop (strongConnect ts v) vs 810 | 811 | coreFor : List a -> (a -> Core b) -> Core (List b) 812 | coreFor xs f = Core.traverse f xs 813 | 814 | record ModuleInfo where 815 | constructor MkMI 816 | name : ModuleName 817 | outdated : Bool 818 | 819 | generateModules : Ref Ctxt Defs -> ClosedTerm -> (outfile : String) -> Core (List ModuleInfo) 820 | generateModules c tm bld = do 821 | cdata <- getCompileData False Cases tm 822 | let ndefs = namedDefs cdata 823 | let ctm = forget (mainExpr cdata) 824 | let ldefs = lazyDefs ndefs 825 | let defsByNS = StringMap.fromList $ splitByNS ndefs 826 | let defDepsRaw = [StringMap.singleton (mlfNS n) (SortedSet.delete (mlfNS n) (nsDef d)) | (n, fc, d) <- ndefs] 827 | let defDeps = foldl (StringMap.mergeWith SortedSet.union) StringMap.empty defDepsRaw 828 | let components = reverse $ tarjan defDeps -- tarjan generates reverse toposort 829 | 830 | -- map each module name / namespace 831 | -- to the representative from its component 832 | let nsMapping = 833 | foldl 834 | (\nm, modNames => case modNames of 835 | [] => nm 836 | mn :: mns => 837 | let mlMod = MkMN (foldl min mn mns) 838 | in foldl (\nm, modName => StringMap.insert modName mlMod nm) 839 | nm 840 | modNames 841 | ) 842 | StringMap.empty 843 | components 844 | 845 | -- generate one module per strongly connected component 846 | -- start with Builtins, work up to modules with many dependencies 847 | outdatedModNames <- coreLift $ newIORef SortedSet.empty 848 | moduleNames <- coreFor components $ \modNames => case modNames of 849 | [] => throw $ InternalError "empty connected component" 850 | mn :: mns => do 851 | let mlModName = MkMN (foldl min mn mns) 852 | let defs = concatMap (\modName => fromMaybe [] $ StringMap.lookup modName defsByNS) modNames 853 | let defsMlf = map (mlfDef ldefs nsMapping mlModName) defs 854 | let code = render " " $ parens ( 855 | text "module" 856 | $$ indent ( 857 | mlfRec defsMlf 858 | $$ text "" 859 | $$ parens ( 860 | text "export" 861 | $$ indent (vcat [mlfGlobalVar n | (n, _, _) <- defs]) 862 | ) 863 | ) 864 | ) 865 | $$ text "" 866 | $$ text "; vim: ft=lisp" 867 | $$ text "" -- end with a newline 868 | 869 | -- check if the files need updating 870 | let codeHashStr = show (hash code) ++ "\n" 871 | mbPrevHash <- coreLift (readFile (bld mlModName.string <.> "hash")) >>= \case 872 | Left err => pure $ Nothing 873 | Right h => pure $ Just h 874 | 875 | isUpToDate <- do 876 | outdatedMNs <- coreLift $ readIORef outdatedModNames 877 | let allDeps = concat 878 | [ fromMaybe SortedSet.empty (StringMap.lookup n defDeps) 879 | | n <- with Prelude.(::) mn :: mns 880 | ] 881 | pure $ 882 | -- hash matches 883 | (mbPrevHash == Just codeHashStr) 884 | -- no deps are outdated 885 | -- we check only direct deps because we're traversing in dep order, anyway 886 | && (null $ SortedSet.intersection allDeps outdatedMNs) 887 | 888 | if isUpToDate 889 | then pure (MkMI mlModName False) -- up to date, nothing to do 890 | else do 891 | -- mark all namespaces in this module as outdated 892 | coreLift $ do 893 | omns <- readIORef outdatedModNames 894 | writeIORef outdatedModNames $ 895 | omns <+> SortedSet.fromList (mn :: mns) 896 | 897 | -- write the MLF file 898 | let fname = bld mlModName.string <.> "mlf" 899 | Right () <- coreLift $ writeFile fname code 900 | | Left err => throw (FileErr fname err) 901 | 902 | -- update the hash file 903 | -- write into .hash.tmp, which will be renamed to .hash 904 | -- once the build succeeds 905 | let fname = bld mlModName.string <.> "hash.tmp" 906 | Right () <- coreLift $ writeFile fname codeHashStr 907 | | Left err => throw (FileErr fname err) 908 | 909 | -- write the MLI file 910 | let mliCode = render " " $ 911 | vcat 912 | [ text "val" <++> mlfGlobalName n <++> text ": 'a" 913 | | (n, _, _) <- defs 914 | ] 915 | let fname = bld mlModName.string <.> "mli" 916 | Right () <- coreLift $ writeFile fname mliCode 917 | | Left err => throw (FileErr fname err) 918 | 919 | pure (MkMI mlModName True) 920 | 921 | -- generate the main module 922 | mainMlf <- pure $ mlfTm ldefs nsMapping (MkMN "Main") ctm 923 | let code = render " " $ parens ( 924 | text "module" 925 | $$ indent ( 926 | parens (text "_" <++> mainMlf) 927 | $$ text "" 928 | $$ parens (text "export") 929 | ) 930 | ) 931 | $$ text "" 932 | $$ text "; vim: ft=lisp" 933 | $$ text "" -- end with a newline 934 | Right () <- coreLift $ writeFile (bld "Main.mlf") code 935 | | Left err => throw (FileErr (bld "Main.mlf") err) 936 | 937 | -- write an empty hash file 938 | Right () <- coreLift $ writeFile (bld "Main.hash.tmp") "" 939 | | Left err => throw (FileErr (bld "Main.hash.tmp") err) 940 | 941 | -- write an empty Main.mli 942 | Right () <- coreLift $ writeFile (bld "Main.mli") "" 943 | | Left err => throw (FileErr (bld "Main.mli") err) 944 | 945 | pure $ moduleNames ++ [MkMI (MkMN "Main") True] 946 | 947 | firstAvailable : List String -> String -> Core (Maybe String) 948 | firstAvailable [] fname = pure Nothing 949 | firstAvailable (dir :: dirs) fname = do 950 | let path = dir fname 951 | case !(coreLift $ openFile path Read) of 952 | Right f => do 953 | coreLift $ closeFile f 954 | pure (Just path) 955 | Left _ => firstAvailable dirs fname 956 | 957 | copy : Dirs -> String -> String -> Core () 958 | copy dirs bld fn = 959 | firstAvailable dirs.data_dirs fn >>= \case 960 | Nothing => throw $ InternalError ("idris2-mlf/copy: could not find " ++ fn) 961 | Just path => do 962 | 0 <- coreLift $ system $ unwords ["cp", path, bld] 963 | | e => throw (FileErr path (GenericFileError 0)) 964 | pure () 965 | 966 | compileExpr : Ref Ctxt Defs 967 | -> (tmpDir : String) -> (outputDir : String) 968 | -> ClosedTerm -> (outfile : String) -> Core (Maybe String) 969 | compileExpr c tmpDir outputDir tm outfile = do 970 | let bld = tmpDir "mlf-" ++ outfile 971 | Right () <- coreLift $ mkdirAll bld 972 | | Left err => throw (FileErr bld err) 973 | 974 | -- malfunction does not support libs in another directory 975 | -- let's just copy all of them 976 | dirs <- getDirs 977 | copy dirs bld ("mlf" "Rts.cmx") 978 | copy dirs bld ("mlf" "Rts.cmi") 979 | copy dirs bld ("mlf" "Rts.o") 980 | copy dirs bld ("mlf" "rts_c.o") 981 | 982 | modules <- generateModules c tm bld 983 | 984 | let cmd = unwords 985 | [ " (cd " ++ bld 986 | -- rebuild only the outdated MLF modules 987 | , unwords 988 | [ " && ocamlfind opt -I +threads -g -c " ++ mod.name.string ++ ".mli " 989 | ++ " && malfunction cmx " ++ mod.name.string ++ ".mlf" 990 | -- mark the module build as successful 991 | ++ " && mv " ++ mod.name.string ++ ".hash.tmp " ++ mod.name.string ++ ".hash" 992 | | mod <- modules 993 | , mod.outdated 994 | ] 995 | -- link it all together 996 | , "&& ocamlfind opt -thread -package zarith -linkpkg -nodynlink -g " 997 | ++ "rts_c.o " 998 | ++ !(findLibraryFile "libidris2_support.a") ++ " " 999 | ++ "Rts.cmx " 1000 | ++ unwords [mod.name.string ++ ".cmx" | mod <- modules] 1001 | ++ " -o ../" ++ outfile 1002 | , ")" 1003 | ] 1004 | 1005 | coreLift $ putStrLn cmd 1006 | ok <- coreLift $ system cmd 1007 | if ok == 0 1008 | then pure (Just (outputDir outfile)) 1009 | else pure Nothing 1010 | 1011 | executeExpr : Ref Ctxt Defs -> (tmpDir : String) -> ClosedTerm -> Core () 1012 | executeExpr c tmpDir tm 1013 | = do outn <- compileExpr c tmpDir tmpDir tm "_tmp_mlf" 1014 | case outn of 1015 | -- TODO: on windows, should add exe extension 1016 | Just outn => map (const ()) $ coreLift $ system outn 1017 | Nothing => pure () 1018 | 1019 | main : IO () 1020 | main = mainWithCodegens 1021 | [ ("mlf", MkCG compileExpr executeExpr Nothing Nothing) 1022 | ] 1023 | -------------------------------------------------------------------------------- /src/Pretty.idr: -------------------------------------------------------------------------------- 1 | module Pretty 2 | 3 | import Data.List 4 | import Data.String 5 | 6 | %default total 7 | 8 | export 9 | data Doc : Type where 10 | Text : String -> Doc 11 | Vcat : List Doc -> Doc 12 | Hang : Doc -> Doc -> Doc 13 | Indent : Doc -> Doc 14 | 15 | public export 16 | interface Pretty a where 17 | pretty : a -> Doc 18 | 19 | export 20 | Semigroup Doc where 21 | (<+>) = Hang 22 | 23 | export 24 | Monoid Doc where 25 | neutral = Text "" 26 | 27 | export 28 | text : String -> Doc 29 | text = Text 30 | 31 | export 32 | show : Show a => a -> Doc 33 | show = Text . show 34 | 35 | infixr 2 $$ 36 | export 37 | ($$) : Doc -> Doc -> Doc 38 | ($$) (Vcat xs) (Vcat ys) = Vcat (xs ++ ys) 39 | ($$) x (Vcat ys) = Vcat (x :: ys) 40 | ($$) (Vcat xs) y = Vcat (xs ++ [y]) 41 | ($$) x y = Vcat [x,y] 42 | 43 | export 44 | vcat : List Doc -> Doc 45 | vcat = Vcat 46 | 47 | export 48 | vsep : List Doc -> Doc 49 | vsep = vcat . intersperse neutral 50 | 51 | export 52 | punctuate : Doc -> List Doc -> Doc 53 | punctuate sep = concat . intersperse sep 54 | 55 | export 56 | hsep : List Doc -> Doc 57 | hsep = punctuate (text " ") 58 | 59 | infixl 6 <++> 60 | export 61 | (<++>) : Doc -> Doc -> Doc 62 | (<++>) x y = x <+> text " " <+> y 63 | 64 | export 65 | indent : Doc -> Doc 66 | indent = Indent 67 | 68 | export 69 | indentBlock : List Doc -> Doc 70 | indentBlock = indent . vcat 71 | 72 | export 73 | parens : Doc -> Doc 74 | parens d = text "(" <+> d <+> text ")" 75 | 76 | export 77 | brackets : Doc -> Doc 78 | brackets d = text "[" <+> d <+> text "]" 79 | 80 | export 81 | braces : Doc -> Doc 82 | braces d = text "{" <+> d <+> text "}" 83 | 84 | private 85 | tcMap : (a -> b) -> List a -> List b 86 | tcMap f = go [] 87 | where 88 | go : List b -> List a -> List b 89 | go acc [] = reverse acc 90 | go acc (x :: xs) = go (f x :: acc) xs 91 | 92 | private 93 | hang : String -> List String -> List String -> List String 94 | hang ind [] ys = ys 95 | hang ind xs [] = xs 96 | hang ind [x] (y :: ys) = (x ++ y) :: tcMap (ind++) ys 97 | hang ind (x :: xs) ys = x :: hang ind xs ys 98 | 99 | private 100 | render' : String -> Doc -> List String 101 | render' ind (Text s) = [s] 102 | render' ind (Vcat ls) = assert_total $ concatMap (render' ind) ls 103 | render' ind (Hang x y) = hang ind (render' ind x) (render' ind y) 104 | render' ind (Indent x) = tcMap (ind++) $ render' ind x 105 | 106 | export 107 | render : String -> Doc -> String 108 | render ind = fastAppend . tcMap (++"\n") . render' ind 109 | 110 | export 111 | Show Doc where 112 | show = render " " 113 | 114 | export 115 | prettyShow : Pretty a => a -> String 116 | prettyShow = render " " . pretty 117 | -------------------------------------------------------------------------------- /src/SortedSet.idr: -------------------------------------------------------------------------------- 1 | module SortedSet 2 | 3 | import Data.Maybe 4 | import Data.SortedMap 5 | 6 | export 7 | data SortedSet k = SetWrapper (SortedMap.SortedMap k ()) 8 | 9 | export 10 | empty : Ord k => SortedSet k 11 | empty = SetWrapper SortedMap.empty 12 | 13 | export 14 | insert : k -> SortedSet k -> SortedSet k 15 | insert k (SetWrapper m) = SetWrapper (SortedMap.insert k () m) 16 | 17 | export 18 | delete : k -> SortedSet k -> SortedSet k 19 | delete k (SetWrapper m) = SetWrapper (SortedMap.delete k m) 20 | 21 | export 22 | contains : k -> SortedSet k -> Bool 23 | contains k (SetWrapper m) = isJust (SortedMap.lookup k m) 24 | 25 | export 26 | fromList : Ord k => List k -> SortedSet k 27 | fromList l = SetWrapper (SortedMap.fromList (map (\i => (i, ())) l)) 28 | 29 | export 30 | toList : SortedSet k -> List k 31 | toList (SetWrapper m) = map (\(i, _) => i) (SortedMap.toList m) 32 | 33 | export 34 | Foldable SortedSet where 35 | foldr f e = foldr f e . SortedSet.toList 36 | foldl f e = foldl f e . SortedSet.toList 37 | null (SetWrapper m) = null m 38 | 39 | ||| Set union. Inserts all elements of x into y 40 | export 41 | union : (x, y : SortedSet k) -> SortedSet k 42 | union x y = foldr insert x y 43 | 44 | ||| Set difference. Delete all elments in y from x 45 | export 46 | difference : (x, y : SortedSet k) -> SortedSet k 47 | difference x y = foldr delete x y 48 | 49 | ||| Set symmetric difference. Uses the union of the differences. 50 | export 51 | symDifference : (x, y : SortedSet k) -> SortedSet k 52 | symDifference x y = union (difference x y) (difference y x) 53 | 54 | ||| Set intersection. Implemented as the difference of the union and the symetric difference. 55 | export 56 | intersection : (x, y : SortedSet k) -> SortedSet k 57 | intersection x y = difference x (difference x y) 58 | 59 | export 60 | Ord k => Semigroup (SortedSet k) where 61 | (<+>) = union 62 | 63 | export 64 | Ord k => Monoid (SortedSet k) where 65 | neutral = empty 66 | 67 | export 68 | keySet : SortedMap k v -> SortedSet k 69 | keySet = SetWrapper . map (const ()) 70 | 71 | export 72 | singleton : Ord k => k -> SortedSet k 73 | singleton k = insert k empty 74 | -------------------------------------------------------------------------------- /src/StringMap.idr: -------------------------------------------------------------------------------- 1 | module StringMap 2 | 3 | -- Hand specialised map, for efficiency... 4 | 5 | %default total 6 | 7 | Key : Type 8 | Key = String 9 | 10 | -- TODO: write split 11 | 12 | private 13 | data Tree : Nat -> Type -> Type where 14 | Leaf : Key -> v -> Tree Z v 15 | Branch2 : Tree n v -> Key -> Tree n v -> Tree (S n) v 16 | Branch3 : Tree n v -> Key -> Tree n v -> Key -> Tree n v -> Tree (S n) v 17 | 18 | branch4 : 19 | Tree n v -> Key -> 20 | Tree n v -> Key -> 21 | Tree n v -> Key -> 22 | Tree n v -> 23 | Tree (S (S n)) v 24 | branch4 a b c d e f g = 25 | Branch2 (Branch2 a b c) d (Branch2 e f g) 26 | 27 | branch5 : 28 | Tree n v -> Key -> 29 | Tree n v -> Key -> 30 | Tree n v -> Key -> 31 | Tree n v -> Key -> 32 | Tree n v -> 33 | Tree (S (S n)) v 34 | branch5 a b c d e f g h i = 35 | Branch2 (Branch2 a b c) d (Branch3 e f g h i) 36 | 37 | branch6 : 38 | Tree n v -> Key -> 39 | Tree n v -> Key -> 40 | Tree n v -> Key -> 41 | Tree n v -> Key -> 42 | Tree n v -> Key -> 43 | Tree n v -> 44 | Tree (S (S n)) v 45 | branch6 a b c d e f g h i j k = 46 | Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k) 47 | 48 | branch7 : 49 | Tree n v -> Key -> 50 | Tree n v -> Key -> 51 | Tree n v -> Key -> 52 | Tree n v -> Key -> 53 | Tree n v -> Key -> 54 | Tree n v -> Key -> 55 | Tree n v -> 56 | Tree (S (S n)) v 57 | branch7 a b c d e f g h i j k l m = 58 | Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m) 59 | 60 | merge1 : Tree n v -> Key -> Tree (S n) v -> Key -> Tree (S n) v -> Tree (S (S n)) v 61 | merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i 62 | merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k 63 | merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k 64 | merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m 65 | 66 | merge2 : Tree (S n) v -> Key -> Tree n v -> Key -> Tree (S n) v -> Tree (S (S n)) v 67 | merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i 68 | merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k 69 | merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k 70 | merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m 71 | 72 | merge3 : Tree (S n) v -> Key -> Tree (S n) v -> Key -> Tree n v -> Tree (S (S n)) v 73 | merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i 74 | merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k 75 | merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k 76 | merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m 77 | 78 | treeLookup : Key -> Tree n v -> Maybe v 79 | treeLookup k (Leaf k' v) = 80 | if k == k' then 81 | Just v 82 | else 83 | Nothing 84 | treeLookup k (Branch2 t1 k' t2) = 85 | if k <= k' then 86 | treeLookup k t1 87 | else 88 | treeLookup k t2 89 | treeLookup k (Branch3 t1 k1 t2 k2 t3) = 90 | if k <= k1 then 91 | treeLookup k t1 92 | else if k <= k2 then 93 | treeLookup k t2 94 | else 95 | treeLookup k t3 96 | 97 | treeInsert' : Key -> v -> Tree n v -> Either (Tree n v) (Tree n v, Key, Tree n v) 98 | treeInsert' k v (Leaf k' v') = 99 | case compare k k' of 100 | LT => Right (Leaf k v, k, Leaf k' v') 101 | EQ => Left (Leaf k v) 102 | GT => Right (Leaf k' v', k', Leaf k v) 103 | treeInsert' k v (Branch2 t1 k' t2) = 104 | if k <= k' then 105 | case treeInsert' k v t1 of 106 | Left t1' => Left (Branch2 t1' k' t2) 107 | Right (a, b, c) => Left (Branch3 a b c k' t2) 108 | else 109 | case treeInsert' k v t2 of 110 | Left t2' => Left (Branch2 t1 k' t2') 111 | Right (a, b, c) => Left (Branch3 t1 k' a b c) 112 | treeInsert' k v (Branch3 t1 k1 t2 k2 t3) = 113 | if k <= k1 then 114 | case treeInsert' k v t1 of 115 | Left t1' => Left (Branch3 t1' k1 t2 k2 t3) 116 | Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3) 117 | else 118 | if k <= k2 then 119 | case treeInsert' k v t2 of 120 | Left t2' => Left (Branch3 t1 k1 t2' k2 t3) 121 | Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3) 122 | else 123 | case treeInsert' k v t3 of 124 | Left t3' => Left (Branch3 t1 k1 t2 k2 t3') 125 | Right (a, b, c) => Right (Branch2 t1 k1 t2, k2, Branch2 a b c) 126 | 127 | treeInsert : Key -> v -> Tree n v -> Either (Tree n v) (Tree (S n) v) 128 | treeInsert k v t = 129 | case treeInsert' k v t of 130 | Left t' => Left t' 131 | Right (a, b, c) => Right (Branch2 a b c) 132 | 133 | delType : Nat -> Type -> Type 134 | delType Z v = () 135 | delType (S n) v = Tree n v 136 | 137 | treeDelete : {n : _} -> Key -> Tree n v -> Either (Tree n v) (delType n v) 138 | treeDelete k (Leaf k' v) = 139 | if k == k' then 140 | Right () 141 | else 142 | Left (Leaf k' v) 143 | treeDelete {n=S Z} k (Branch2 t1 k' t2) = 144 | if k <= k' then 145 | case treeDelete k t1 of 146 | Left t1' => Left (Branch2 t1' k' t2) 147 | Right () => Right t2 148 | else 149 | case treeDelete k t2 of 150 | Left t2' => Left (Branch2 t1 k' t2') 151 | Right () => Right t1 152 | treeDelete {n=S Z} k (Branch3 t1 k1 t2 k2 t3) = 153 | if k <= k1 then 154 | case treeDelete k t1 of 155 | Left t1' => Left (Branch3 t1' k1 t2 k2 t3) 156 | Right () => Left (Branch2 t2 k2 t3) 157 | else if k <= k2 then 158 | case treeDelete k t2 of 159 | Left t2' => Left (Branch3 t1 k1 t2' k2 t3) 160 | Right () => Left (Branch2 t1 k1 t3) 161 | else 162 | case treeDelete k t3 of 163 | Left t3' => Left (Branch3 t1 k1 t2 k2 t3') 164 | Right () => Left (Branch2 t1 k1 t2) 165 | treeDelete {n=S (S _)} k (Branch2 t1 k' t2) = 166 | if k <= k' then 167 | case treeDelete k t1 of 168 | Left t1' => Left (Branch2 t1' k' t2) 169 | Right t1' => 170 | case t2 of 171 | Branch2 a b c => Right (Branch3 t1' k' a b c) 172 | Branch3 a b c d e => Left (branch4 t1' k' a b c d e) 173 | else 174 | case treeDelete k t2 of 175 | Left t2' => Left (Branch2 t1 k' t2') 176 | Right t2' => 177 | case t1 of 178 | Branch2 a b c => Right (Branch3 a b c k' t2') 179 | Branch3 a b c d e => Left (branch4 a b c d e k' t2') 180 | treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) = 181 | if k <= k1 then 182 | case treeDelete k t1 of 183 | Left t1' => Left (Branch3 t1' k1 t2 k2 t3) 184 | Right t1' => Left (merge1 t1' k1 t2 k2 t3) 185 | else if k <= k2 then 186 | case treeDelete k t2 of 187 | Left t2' => Left (Branch3 t1 k1 t2' k2 t3) 188 | Right t2' => Left (merge2 t1 k1 t2' k2 t3) 189 | else 190 | case treeDelete k t3 of 191 | Left t3' => Left (Branch3 t1 k1 t2 k2 t3') 192 | Right t3' => Left (merge3 t1 k1 t2 k2 t3') 193 | 194 | treeToList : Tree n v -> List (Key, v) 195 | treeToList = treeToList' (:: []) 196 | where 197 | treeToList' : forall n . ((Key, v) -> List (Key, v)) -> Tree n v -> List (Key, v) 198 | treeToList' cont (Leaf k v) = cont (k, v) 199 | treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1 200 | treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1 201 | 202 | export 203 | data StringMap : Type -> Type where 204 | Empty : StringMap v 205 | M : (n : Nat) -> Tree n v -> StringMap v 206 | 207 | export 208 | empty : StringMap v 209 | empty = Empty 210 | 211 | export 212 | singleton : String -> v -> StringMap v 213 | singleton k v = M Z (Leaf k v) 214 | 215 | export 216 | lookup : String -> StringMap v -> Maybe v 217 | lookup _ Empty = Nothing 218 | lookup k (M _ t) = treeLookup k t 219 | 220 | export 221 | insert : String -> v -> StringMap v -> StringMap v 222 | insert k v Empty = M Z (Leaf k v) 223 | insert k v (M _ t) = 224 | case treeInsert k v t of 225 | Left t' => (M _ t') 226 | Right t' => (M _ t') 227 | 228 | export 229 | insertFrom : List (String, v) -> StringMap v -> StringMap v 230 | insertFrom = flip $ foldl $ flip $ uncurry insert 231 | 232 | export 233 | delete : String -> StringMap v -> StringMap v 234 | delete _ Empty = Empty 235 | delete k (M Z t) = 236 | case treeDelete k t of 237 | Left t' => (M _ t') 238 | Right () => Empty 239 | delete k (M (S _) t) = 240 | case treeDelete k t of 241 | Left t' => (M _ t') 242 | Right t' => (M _ t') 243 | 244 | export 245 | fromList : List (String, v) -> StringMap v 246 | fromList l = foldl (flip (uncurry insert)) empty l 247 | 248 | export 249 | toList : StringMap v -> List (String, v) 250 | toList Empty = [] 251 | toList (M _ t) = treeToList t 252 | 253 | ||| Gets the Keys of the map. 254 | export 255 | keys : StringMap v -> List String 256 | keys = map fst . toList 257 | 258 | ||| Gets the values of the map. Could contain duplicates. 259 | export 260 | values : StringMap v -> List v 261 | values = map snd . toList 262 | 263 | treeMap : (a -> b) -> Tree n a -> Tree n b 264 | treeMap f (Leaf k v) = Leaf k (f v) 265 | treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2) 266 | treeMap f (Branch3 t1 k1 t2 k2 t3) 267 | = Branch3 (treeMap f t1) k1 (treeMap f t2) k2 (treeMap f t3) 268 | 269 | export 270 | implementation Functor StringMap where 271 | map _ Empty = Empty 272 | map f (M n t) = M _ (treeMap f t) 273 | 274 | ||| Merge two maps. When encountering duplicate keys, using a function to combine the values. 275 | ||| Uses the ordering of the first map given. 276 | export 277 | mergeWith : (v -> v -> v) -> StringMap v -> StringMap v -> StringMap v 278 | mergeWith f x y = insertFrom inserted x where 279 | inserted : List (Key, v) 280 | inserted = do 281 | (k, v) <- toList y 282 | let v' = (maybe id f $ lookup k x) v 283 | pure (k, v') 284 | 285 | ||| Merge two maps using the Semigroup (and by extension, Monoid) operation. 286 | ||| Uses mergeWith internally, so the ordering of the left map is kept. 287 | export 288 | merge : Semigroup v => StringMap v -> StringMap v -> StringMap v 289 | merge = mergeWith (<+>) 290 | 291 | ||| Left-biased merge, also keeps the ordering specified by the left map. 292 | export 293 | mergeLeft : StringMap v -> StringMap v -> StringMap v 294 | mergeLeft x y = mergeWith const x y 295 | 296 | export 297 | adjust : String -> (v -> v) -> StringMap v -> StringMap v 298 | adjust k f m = 299 | case lookup k m of 300 | Nothing => m 301 | Just v => insert k (f v) m 302 | 303 | export 304 | Show v => Show (StringMap v) where 305 | show m = show $ map {b=String} (\(k,v) => k ++ "->" ++ show v) $ StringMap.toList m 306 | 307 | -- TODO: is this the right variant of merge to use for this? I think it is, but 308 | -- I could also see the advantages of using `mergeLeft`. The current approach is 309 | -- strictly more powerful I believe, because `mergeLeft` can be emulated with 310 | -- the `First` monoid. However, this does require more code to do the same 311 | -- thing. 312 | export 313 | Semigroup v => Semigroup (StringMap v) where 314 | (<+>) = merge 315 | 316 | export 317 | (Semigroup v) => Monoid (StringMap v) where 318 | neutral = empty 319 | -------------------------------------------------------------------------------- /support/Makefile: -------------------------------------------------------------------------------- 1 | CC = cc -O2 -g -I $(LIBDIR)/include -I $(shell ocamlc -where) 2 | OCAMLOPT = ocamlfind opt -I +threads -g 3 | 4 | .PHONY: clean 5 | 6 | all: .ts-build 7 | 8 | # order matters; Rts.cmi should be built before Rts.o and Rts.cmx 9 | .ts-build: rts_c.o Rts.cmi Rts.o Rts.cmx 10 | touch .ts-build 11 | 12 | rts_c.o: rts_c.c 13 | $(CC) -o $@ -c $< 14 | 15 | Rts.mli: Rts.ml 16 | $(OCAMLOPT) -i Rts.ml > Rts.mli 17 | 18 | Rts.cmi: Rts.mli 19 | $(OCAMLOPT) -c Rts.mli 20 | 21 | Rts.cmx Rts.o: Rts.ml 22 | $(OCAMLOPT) -c Rts.ml 23 | 24 | clean: 25 | -rm -f Rts.{mli,cmi,cmx} rts_c.o 26 | -------------------------------------------------------------------------------- /support/Rts.ml: -------------------------------------------------------------------------------- 1 | (* These types are made to match the Idris representation *) 2 | module Types = struct 3 | type world = World 4 | 5 | module IdrisList = struct 6 | type 'a idris_list = 7 | | Nil (* int 0 *) 8 | | UNUSED of int (* block, tag 0 *) 9 | | Cons of 'a * 'a idris_list (* block, tag 1 *) 10 | 11 | let rec of_list = function 12 | | [] -> Nil 13 | | x :: xs -> Cons (x, of_list xs) 14 | 15 | let rec to_list = function 16 | | Nil -> [] 17 | | UNUSED _ -> failwith "UNUSED tag in idris list" 18 | | Cons (x, xs) -> x :: to_list xs 19 | 20 | let rec foldl f z = function 21 | | Nil -> z 22 | | UNUSED _ -> failwith "UNUSED tag in idris list" 23 | | Cons (x, xs) -> foldl f (f z x) xs 24 | end 25 | end 26 | open Types 27 | open Types.IdrisList 28 | 29 | let not_implemented msg = failwith ("not implemented yet: " ^ msg) 30 | 31 | module Debug = struct 32 | (* %foreign "ML:Rts.Debug.inspect" 33 | * prim__inspect : {a : Type} -> (x : a) -> (1 w : %World) -> IORes () 34 | * 35 | * inspect : a -> IO () 36 | * inspect x = primIO (prim__inspect x) 37 | *) 38 | external inspect : 'ty -> 'a -> unit = "inspect" 39 | end 40 | 41 | module IORef = struct 42 | let write (r : 'a ref) (x : 'a) : unit = r := x 43 | end 44 | 45 | module System = struct 46 | let get_args (_ : world) : string idris_list = 47 | IdrisList.of_list (Array.to_list Sys.argv) 48 | 49 | let fork_thread (sub : world -> unit) : Thread.t = 50 | Thread.create sub World 51 | 52 | let os_name (_ : world) : string = 53 | match Sys.os_type with 54 | | "Unix" -> "unix" 55 | | "Win32" -> "windows" 56 | | "Cygwin" -> "windows" 57 | | _ -> "unknown" 58 | 59 | type os_clock 60 | external clocktime_gc_cpu : world -> os_clock = "ml_clocktime_gc_cpu" 61 | external clocktime_gc_real : world -> os_clock = "ml_clocktime_gc_real" 62 | external clocktime_monotonic : world -> os_clock = "ml_clocktime_monotonic" 63 | external clocktime_process : world -> os_clock = "ml_clocktime_process" 64 | external clocktime_thread : world -> os_clock = "ml_clocktime_thread" 65 | external clocktime_utc : world -> os_clock = "ml_clocktime_utc" 66 | external os_clock_nanosecond : os_clock -> int64 = "ml_os_clock_nanosecond" 67 | external os_clock_second : os_clock -> int64 = "ml_os_clock_second" 68 | external os_clock_valid : os_clock -> int = "ml_os_clock_valid" 69 | end 70 | 71 | module String = struct 72 | external reverse : string -> string = "ml_string_reverse" 73 | external substring : int -> int -> string -> string = "ml_string_substring" 74 | external cons : char -> string -> string = "ml_string_cons" 75 | external length : string -> int = "ml_string_length" 76 | external head : string -> char = "ml_string_head" 77 | external tail : string -> string = "ml_string_tail" 78 | external get : string -> int -> char = "ml_string_get" 79 | external unpack : string -> char idris_list = "ml_string_unpack" 80 | external pack : char idris_list -> string = "ml_string_pack" 81 | 82 | let of_char (c : char) : string = String.make 1 c 83 | 84 | module Iterator = struct 85 | type t = int (* byte offset in the UTF-8 string *) 86 | type next_result = 87 | | EOF (* int 0 *) 88 | | UNUSED of int (* block, tag 0 *) 89 | | Character of char * t (* block, tag 1 *) 90 | external new_ : string -> t = "ml_string_iterator_new" 91 | external next : string -> t -> next_result = "ml_string_iterator_next" 92 | end 93 | end 94 | 95 | module Bytes = struct 96 | (* pre-allocate a big buffer once and copy all strings in it *) 97 | external concat : string idris_list -> string = "ml_string_concat" 98 | 99 | (* implemented in C for easier debugging 100 | let concat (ssi : bytes idris_list) : bytes = 101 | let ss = IdrisList.to_list ssi in 102 | let total_length = List.fold_left (fun l s -> l + Bytes.length s) 0 ss in 103 | let result = Bytes.create total_length in 104 | let rec write_strings (ofs : int) = function 105 | | IdrisList.Nil -> () 106 | | IdrisList.UNUSED _ -> failwith "UNUSED" 107 | | IdrisList.Cons (src, rest) -> 108 | let len = Bytes.length src in 109 | Bytes.blit src 0 result ofs len; 110 | write_strings (ofs+len) rest 111 | in 112 | write_strings 0 ssi; 113 | result 114 | *) 115 | 116 | let append (x : bytes) (y : bytes) : bytes = 117 | let xlen = Bytes.length x in 118 | let ylen = Bytes.length y in 119 | let result = Bytes.create (xlen + ylen) in 120 | Bytes.blit x 0 result 0 xlen; 121 | Bytes.blit y 0 result xlen ylen; 122 | result 123 | end 124 | 125 | module C = struct 126 | type 'a pointer 127 | (* type 'file file_pointer *) 128 | type filep 129 | 130 | module Lib_libidris2_support = struct 131 | external idris2_putStr : string -> unit = "ml_idris2_putStr" 132 | external idris2_isNull : 'a pointer -> bool = "ml_idris2_isNull" 133 | external idris2_getString : string pointer -> string = "ml_idris2_getString" 134 | external idris2_getStr : world -> string = "ml_idris2_getStr" 135 | external idris2_getEnvPair : int -> string pointer = "ml_idris2_getEnvPair" 136 | external idris2_getErrno : world -> int = "ml_idris2_getErrno" 137 | external idris2_strerror : int -> string = "ml_idris2_strerror" 138 | external idris2_getNull : world -> 'a pointer = "ml_idris2_getNull" 139 | external idris2_sleep : int -> unit = "ml_idris2_sleep" 140 | external idris2_usleep : int -> unit = "ml_idris2_usleep" 141 | external idris2_time : world -> int = "ml_idris2_time" 142 | external idris2_getPID : world -> int = "ml_idris2_getPID" 143 | external idris2_getNProcessors : world -> int = "ml_idris2_getNProcessors" 144 | 145 | (* This is broken in C, let's patch it in OCaml instead. 146 | external idris2_getArgCount : world -> int = "ml_idris2_getArgCount" 147 | external idris2_getArg : int -> string = "ml_idris2_getArg" 148 | *) 149 | 150 | let idris2_getArgCount (_ : world) : int = Array.length Sys.argv 151 | let idris2_getArg (i : int) : string = Array.get Sys.argv i 152 | 153 | (* idris_system.h *) 154 | external idris2_system : string -> int = "ml_idris2_system" 155 | 156 | (* idris_file.h *) 157 | external idris2_openFile : string -> string -> filep = "ml_idris2_openFile" 158 | external idris2_closeFile : filep -> unit = "ml_idris2_closeFile" 159 | external idris2_fileError : filep -> int = "ml_idris2_fileError" 160 | 161 | external idris2_fileErrno : world -> int = "ml_idris2_fileErrno" 162 | 163 | external idris2_chmod : string -> int -> int = "ml_idris2_chmod" 164 | external idris2_removeFile : string -> int = "ml_idris2_removeFile" 165 | external idris2_fileSize : filep -> int = "ml_idris2_fileSize" 166 | 167 | external idris2_fpoll : filep -> int = "ml_idris2_fpoll" 168 | 169 | external idris2_readLine : filep -> string pointer = "ml_idris2_readLine" 170 | external idris2_readChars : int -> filep -> string pointer = "ml_idris2_readChars" 171 | 172 | external idris2_writeLine : filep -> string -> int = "ml_idris2_writeLine" 173 | external idris2_seekLine : filep -> int = "ml_idris2_seekLine" 174 | 175 | external idris2_eof : filep -> int = "ml_idris2_eof" 176 | external idris2_fileAccessTime : filep -> int = "ml_idris2_fileAccessTime" 177 | external idris2_fileModifiedTime : filep -> int = "ml_idris2_fileModifiedTime" 178 | external idris2_fileStatusTime : filep -> int = "ml_idris2_fileStatusTime" 179 | external idris2_fileIsTTY : filep -> int = "ml_idris2_fileIsTTY" 180 | 181 | external idris2_popen : string -> string -> filep = "ml_idris2_popen" 182 | external idris2_pclose : filep -> unit = "ml_idris2_pclose" 183 | 184 | external idris2_stdin_ : unit -> filep = "ml_idris2_stdin" 185 | let idris2_stdin : filep = idris2_stdin_ () 186 | external idris2_stdout_ : unit -> filep = "ml_idris2_stdout" 187 | let idris2_stdout : filep = idris2_stdout_ () 188 | external idris2_stderr_ : unit -> filep = "ml_idris2_stderr" 189 | let idris2_stderr : filep = idris2_stderr_ () 190 | 191 | (* idris_directory.h *) 192 | external idris2_currentDirectory : world -> string = "ml_idris2_currentDirectory" 193 | external idris2_changeDir : string -> int = "ml_idris2_changeDir" 194 | external idris2_createDir : string -> int = "ml_idris2_createDir" 195 | external idris2_openDir : string -> 'a pointer = "ml_idris2_openDir" 196 | external idris2_closeDir : 'a pointer -> unit = "ml_idris2_closeDir" 197 | external idris2_removeDir : string -> int = "ml_idris2_removeDir" 198 | external idris2_nextDirEntry : 'a pointer -> string = "ml_idris2_nextDirEntry" 199 | 200 | (* idris_memory.h *) 201 | external idris2_malloc : int -> 'buf pointer = "ml_idris2_malloc" 202 | external idris2_free : 'buf pointer -> unit = "ml_idris2_free" 203 | 204 | (* idris_buffer.h *) 205 | external idris2_newBuffer : int -> 'buffer pointer = "ml_idris2_newBuffer" 206 | external idris2_freeBuffer : 'buffer pointer -> unit = "ml_idris2_freeBuffer" 207 | external idris2_getBufferSize : 'buffer pointer -> int = "ml_idris2_getBufferSize" 208 | 209 | external idris2_setBufferByte : 'buffer pointer -> int -> int -> unit = "ml_idris2_setBufferByte" 210 | external idris2_setBufferInt : 'buffer pointer -> int -> int -> unit = "ml_idris2_setBufferInt" 211 | external idris2_setBufferDouble : 'buffer pointer -> int -> float -> unit = "ml_idris2_setBufferDouble" 212 | external idris2_setBufferString : 'buffer pointer -> int -> string -> unit = "ml_idris2_setBufferString" 213 | 214 | external idris2_copyBuffer : 'buffer pointer -> int -> int -> 'buffer pointer -> int -> unit = "ml_idris2_copyBuffer" 215 | 216 | external idris2_readBufferData : filep -> 'buffer pointer -> int -> int -> int = "ml_idris2_readBufferData" 217 | external idris2_writeBufferData : filep -> 'buffer pointer -> int -> int -> int = "ml_idris2_writeBufferData" 218 | 219 | external idris2_getBufferByte : 'buffer pointer -> int -> int = "ml_idris2_getBufferByte" 220 | external idris2_getBufferInt : 'buffer pointer -> int -> int = "ml_idris2_getBufferInt" 221 | external idris2_getBufferDouble : 'buffer pointer -> int -> float = "ml_idris2_getBufferDouble" 222 | external idris2_getBufferString : 'buffer pointer -> int -> int -> string = "ml_idris2_getBufferString" 223 | 224 | (* idris_net *) 225 | (* FIXME: this should work with buffers *) 226 | external idrnet_malloc : int -> 'buffer pointer = "ml_idrnet_malloc" 227 | external idrnet_free : 'buffer pointer -> unit = "ml_idrnet_free" 228 | external idrnet_peek : 'buffer pointer -> int -> int = "ml_idrnet_peek" 229 | external idrnet_poke : 'buffer pointer -> int -> int = "ml_idrnet_poke" 230 | 231 | external idrnet_close : int -> int = "ml_idrnet_close" 232 | external idrnet_fdopen : int -> string -> 'file pointer = "ml_idrnet_fdopen" 233 | external idrnet_sockaddr_unix : 'address pointer -> string = "ml_idrnet_sockaddr_unix" 234 | external idrnet_sockaddr_port : int -> int = "ml_idrnet_sockaddr_port" 235 | (* external idrnet_sendto_buf : int -> 'buffer pointer -> int -> string -> int -> int -> int = "ml_idrnet_sendto_buf" *) 236 | let external_idrnet_sendto_buf (_ : int) (_ : 'buffer pointer) (_ : int) (_ : string) (_ : int) (_ : int) = 0 (* TODO *) 237 | external idrnet_getaddrinfo : ('address pointer) pointer -> string -> int -> int -> int = "ml_idrnet_getaddrinfo" 238 | 239 | external idrnet_errno : world -> int = "ml_idrnet_errno" 240 | 241 | external idrnet_socket : int -> int -> int -> int = "ml_idrnet_socket" 242 | 243 | external idrnet_bind : int -> int -> int -> string -> int -> int = "ml_idrnet_bind" 244 | 245 | external idrnet_getsockname : int -> 'address pointer -> 'address pointer -> int = "ml_idrnet_getsockname" 246 | external idrnet_connect : int -> int -> int -> string -> int = "ml_idrnet_connect" 247 | 248 | external idrnet_sockaddr_family : 'sockaddr pointer -> int = "ml_idrnet_sockaddr_family" 249 | external idrnet_sockaddr_ipv4 : 'sockaddr pointer -> string = "ml_idrnet_sockaddr_ipv4" 250 | external idrnet_sockaddr_ipv4_port : 'sockaddr pointer -> int = "ml_idrnet_sockaddr_ipv4_port" 251 | external idrnet_create_sockaddr : world -> 'sockaddr pointer = "ml_idrnet_create_sockaddr" 252 | 253 | external idrnet_listen : int -> int -> int = "ml_idrnet_listen" 254 | external idrnet_accept : int -> 'sockaddr pointer -> int = "ml_idrnet_accept" 255 | 256 | external idrnet_send : int -> string -> int = "ml_idrnet_send" 257 | external idrnet_send_buf : int -> 'buffer pointer -> int -> int = "ml_idrnet_send_buf" 258 | 259 | external idrnet_recv : int -> int -> 'buffer pointer = "ml_idrnet_recv" 260 | external idrnet_recv_buf : int -> 'buffer pointer -> int -> int = "ml_idrnet_recv_buf" 261 | 262 | external idrnet_sendto : int -> string -> string -> int -> int -> int = "ml_idrnet_sendto" 263 | external idrnet_sendto_buf : int -> 'buffer pointer -> int -> string -> int -> int -> int = "ml_idrnet_sendto_buf_bytecode" "ml_idrnet_sendto_buf_native" 264 | 265 | external idrnet_recvfrom : int -> int -> 'buffer pointer = "ml_idrnet_recvfrom" 266 | external idrnet_recvfrom_buf : int -> 'buffer pointer -> int -> 'buffer pointer = "ml_idrnet_recvfrom" 267 | 268 | external idrnet_get_recv_res : 'result pointer -> int = "ml_idrnet_get_recv_res" 269 | external idrnet_get_recv_payload : 'result pointer -> string = "ml_idrnet_get_recv_payload" 270 | external idrnet_free_recv_struct : 'result pointer -> unit = "ml_idrnet_free_recv_struct" 271 | 272 | external idrnet_get_recvfrom_res : 'result pointer -> int = "ml_idrnet_get_recvfrom_res" 273 | external idrnet_get_recvfrom_payload : 'result pointer -> string = "ml_idrnet_get_recvfrom_payload" 274 | external idrnet_get_recvfrom_sockaddr : 'result pointer -> 'buffer pointer = "ml_idrnet_get_recvfrom_sockaddr" 275 | external idrnet_free_recvfrom_struct : 'result pointer -> unit = "ml_idrnet_free_recvfrom_struct" 276 | 277 | external idrnet_geteagain : world -> int = "ml_idrnet_geteagain" 278 | 279 | external idrnet_af_unspec : world -> int = "ml_idrnet_af_unspec" 280 | external idrnet_af_unix : world -> int = "ml_idrnet_af_unix" 281 | external idrnet_af_inet : world -> int = "ml_idrnet_af_inet" 282 | external idrnet_af_inet6 : world -> int = "ml_idrnet_af_inet6" 283 | 284 | (* idris2_term.h *) 285 | external idris2_setupTerm : world -> unit = "ml_idris2_setupTerm" 286 | external idris2_getTermCols : world -> int = "ml_idris2_getTermCols" 287 | external idris2_getTermLines : world -> int = "ml_idris2_getTermLines" 288 | 289 | end 290 | 291 | module Lib_libc6 = struct 292 | 293 | external getenv : string -> string pointer = "ml_getenv" 294 | external system : string -> int = "ml_system" 295 | external exit : int -> unit = "ml_exit" 296 | external fflush : filep -> int = "ml_fflush" 297 | external fdopen : int -> string -> filep = "ml_fdopen" 298 | external chmod : string -> int -> int = "ml_chmod" 299 | 300 | external putchar : char -> int = "ml_putchar" 301 | external getchar : world -> int = "ml_getchar" 302 | external strlen : string -> int = "ml_strlen" 303 | 304 | external fgetc : filep -> int = "ml_fgetc" 305 | external listen : int -> int -> int = "ml_idris2_listen" 306 | end 307 | end 308 | -------------------------------------------------------------------------------- /support/rts_c.c: -------------------------------------------------------------------------------- 1 | // OCaml libraries 2 | #define CAML_NAME_SPACE 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | 10 | // standard C libraries 11 | #include 12 | #include 13 | #include 14 | #include "sys/stat.h" 15 | 16 | // idris2 libraries 17 | #include "getline.h" 18 | #include "idris_memory.h" 19 | #include "idris_directory.h" 20 | #include "idris_file.h" 21 | #include "idris_net.h" 22 | #include "idris_support.h" 23 | #include "idris_system.h" 24 | #include "idris_term.h" 25 | 26 | CAMLprim value c_hello(value i) { 27 | CAMLparam0(); 28 | const char * const msg = "hello from C!"; 29 | printf("this is C; we received %d from OCaml\n", Int_val(i)); 30 | CAMLreturn(caml_alloc_initialized_string(strlen(msg), msg)); 31 | } 32 | 33 | // apparently this could be done using the OCaml Obj module from the stdlib 34 | // but this is already written so let's keep it 35 | void inspect_(int indent, value x) { 36 | for (int i = 0; i < indent; ++i) printf(" "); 37 | if (Is_block(x)) { 38 | switch (Tag_val(x)) { 39 | case Double_tag: 40 | printf("double: %f\n", Double_val(x)); 41 | break; 42 | 43 | case String_tag: 44 | printf("string: %s\n", String_val(x)); 45 | break; 46 | 47 | case Custom_tag: 48 | printf("custom tag\n"); 49 | break; 50 | 51 | default: 52 | printf( 53 | "block(tag = %d, size = %d)\n", 54 | Tag_val(x), 55 | Wosize_val(x) 56 | ); 57 | 58 | if (Tag_val(x) < 16) { 59 | // probably an ADT 60 | for (int i = 0; i < Wosize_val(x); ++i) { 61 | inspect_(indent+1, Field(x, i)); 62 | } 63 | } else { 64 | for (int i = 0; i < indent+1; ++i) printf(" "); 65 | printf("(fields omitted because tag too high)\n"); 66 | } 67 | break; 68 | } 69 | } else { 70 | printf("int %d\n", Int_val(x)); 71 | } 72 | } 73 | 74 | // returns the number of bytes read 75 | // 0 = malformed 76 | static inline size_t utf8_read(const uint8_t * bytes, size_t length, uint32_t * out_cp) 77 | { 78 | if (length < 1) { 79 | return 0; 80 | } 81 | 82 | if (bytes[0] < 0x80) { 83 | // one-byte representation 84 | *out_cp = (uint32_t) bytes[0]; 85 | return 1; 86 | } 87 | 88 | if (bytes[0] < 0xC0) { 89 | // continuation bytes cannot appear here 90 | return 0; 91 | } 92 | 93 | if (bytes[0] < 0xE0) { 94 | // two-byte representation 95 | if (length < 2) { 96 | return 0; 97 | } 98 | 99 | if ((bytes[1] & 0xC0) != 0x80) { 100 | // malformed continuation byte: must be 0b10xx_xxxx 101 | return 0; 102 | } 103 | 104 | *out_cp = 105 | ((uint32_t) (bytes[0] & 0x1F) << 6) 106 | | (uint32_t) (bytes[1] & 0x3F) 107 | ; 108 | return 2; 109 | } 110 | 111 | if (bytes[0] < 0xF0) { 112 | // three-byte representation 113 | if (length < 3) { 114 | return 0; 115 | } 116 | 117 | if ( 118 | (bytes[1] & 0xC0) != 0x80 119 | || (bytes[2] & 0xC0) != 0x80 120 | ) { 121 | // malformed continuation byte: must be 0b10xx_xxxx 122 | return 0; 123 | } 124 | 125 | *out_cp = 126 | ((uint32_t) (bytes[0] & 0x0F) << 12) 127 | | ((uint32_t) (bytes[1] & 0x3F) << 6) 128 | | (uint32_t) (bytes[2] & 0x3F) 129 | ; 130 | return 3; 131 | } 132 | 133 | if (bytes[0] < 0xF8) { 134 | // four-byte representation 135 | if (length < 4) { 136 | return 0; 137 | } 138 | 139 | if ( 140 | (bytes[1] & 0xC0) != 0x80 141 | || (bytes[2] & 0xC0) != 0x80 142 | || (bytes[3] & 0xC0) != 0x80 143 | ) { 144 | // malformed continuation byte: must be 0b10xx_xxxx 145 | return 0; 146 | } 147 | 148 | *out_cp = 149 | ((uint32_t) (bytes[0] & 0x07) << 18) 150 | | ((uint32_t) (bytes[1] & 0x3F) << 12) 151 | | ((uint32_t) (bytes[2] & 0x3F) << 6) 152 | | (uint32_t) (bytes[3] & 0x3F) 153 | ; 154 | return 4; 155 | } 156 | 157 | return 0; 158 | } 159 | 160 | // zero = error 161 | static inline size_t utf8_width(uint32_t cp) 162 | { 163 | if (cp < 0x80) { 164 | return 1; 165 | } 166 | 167 | if (cp < 0x800) { 168 | return 2; 169 | } 170 | 171 | if (cp < 0x10000) { 172 | return 3; 173 | } 174 | 175 | if (cp < 0x110000) { 176 | return 4; 177 | } 178 | 179 | return 0; // code too high 180 | } 181 | 182 | static inline void utf8_write(uint8_t * buf, size_t cp_width, uint32_t cp) 183 | { 184 | switch (cp_width) { 185 | case 1: 186 | buf[0] = cp & 0x7F; 187 | break; 188 | 189 | case 2: 190 | buf[0] = ((cp >> 6) & 0x1F) | 0xC0; 191 | buf[1] = ( cp & 0x3F) | 0x80; 192 | break; 193 | 194 | case 3: 195 | buf[0] = ((cp >> 12) & 0x0F) | 0xE0; 196 | buf[1] = ((cp >> 6) & 0x3F) | 0x80; 197 | buf[2] = ( cp & 0x3F) | 0x80; 198 | break; 199 | 200 | case 4: 201 | buf[0] = ((cp >> 18) & 0x07) | 0xF0; 202 | buf[1] = ((cp >> 12) & 0x3F) | 0x80; 203 | buf[2] = ((cp >> 6) & 0x3F) | 0x80; 204 | buf[3] = ( cp & 0x3F) | 0x80; 205 | break; 206 | 207 | default: 208 | caml_failwith("utf8_write: invalid code point width"); 209 | break; 210 | } 211 | } 212 | 213 | CAMLprim value ml_string_iterator_new(value str) 214 | { 215 | CAMLparam1(str); 216 | CAMLreturn(Val_int(0)); 217 | } 218 | 219 | CAMLprim value ml_string_iterator_next(value str, value ofsv) 220 | { 221 | CAMLparam2(str, ofsv); 222 | CAMLlocal1(result); 223 | 224 | size_t ofs = Int_val(ofsv); 225 | uint32_t cp; 226 | const size_t cp_width = utf8_read( 227 | Bytes_val(str) + ofs, 228 | caml_string_length(str) - ofs, 229 | &cp 230 | ); 231 | 232 | if (cp_width == 0) { 233 | result = Val_int(0); // EOF, int 0 234 | } else { 235 | result = caml_alloc(2, 1); // Character Char Offset, block tag 1 236 | Store_field(result, 0, Val_int(cp)); 237 | Store_field(result, 1, Val_int(ofs + cp_width)); 238 | } 239 | 240 | CAMLreturn(result); 241 | } 242 | 243 | CAMLprim value ml_string_reverse(value src) 244 | { 245 | CAMLparam1(src); 246 | CAMLlocal1(dst); 247 | 248 | const size_t src_length = caml_string_length(src); 249 | dst = caml_alloc_string(src_length); 250 | 251 | // all allocations are done, now we're going to take (char *) pointers 252 | // don't do any allocations anymore because it may invalidate the pointers! 253 | 254 | const uint8_t * src_start = Bytes_val(src); 255 | const uint8_t * src_end = src_start + src_length; 256 | const uint8_t * srcp = src_start; 257 | 258 | uint8_t * dst_start = Bytes_val(dst); 259 | uint8_t * dst_end = dst_start + src_length; 260 | uint8_t * dstp = dst_end; 261 | 262 | size_t bytes_remaining = src_length; 263 | while (srcp < src_end && dstp > dst_start) { 264 | uint32_t cp; 265 | const size_t cp_width = utf8_read(srcp, bytes_remaining, &cp); 266 | if (cp_width == 0) { 267 | caml_failwith("ml_string_reverse: malformed utf8 input"); 268 | } 269 | 270 | utf8_write(dstp-cp_width, cp_width, cp); 271 | 272 | bytes_remaining -= cp_width; 273 | srcp += cp_width; 274 | dstp -= cp_width; 275 | } 276 | 277 | if (srcp != src_end || dstp != dst_start) { 278 | caml_failwith("ml_string_reverse: desynchronised"); 279 | } 280 | 281 | CAMLreturn(dst); 282 | } 283 | 284 | // will return the pointer to the NUL byte if out of bounds 285 | const uint8_t * utf8_skip_chars(const uint8_t * buf, size_t buf_length, size_t n_chars) 286 | { 287 | while (n_chars > 0 && buf_length > 0) 288 | { 289 | uint32_t cp; 290 | const size_t cp_width = utf8_read(buf, buf_length, &cp); 291 | if (cp_width == 0) { 292 | caml_failwith("utf8_skip_chars: out of bounds or malformed string"); 293 | } 294 | 295 | buf += cp_width; 296 | buf_length -= cp_width; 297 | n_chars--; 298 | } 299 | 300 | return buf; 301 | } 302 | 303 | CAMLprim value ml_string_substring(value n_skip, value n_chars, value src) 304 | { 305 | CAMLparam3(n_skip, n_chars, src); 306 | CAMLlocal1(dst); 307 | 308 | const uint8_t * src_start = Bytes_val(src); 309 | const uint8_t * src_end = src_start + caml_string_length(src); 310 | 311 | const uint8_t * substr_start = utf8_skip_chars(src_start, src_end - src_start, Int_val(n_skip)); 312 | const uint8_t * substr_end = utf8_skip_chars(substr_start, src_end - substr_start, Int_val(n_chars)); 313 | const size_t subst_ofs = substr_start - src_start; 314 | const size_t substr_width = substr_end - substr_start; 315 | 316 | // here we allocate so pointers taken above are no longer valid 317 | // hence we need to take Bytes_val() again, and refer only to the length 318 | dst = caml_alloc_string(substr_end - substr_start); 319 | memcpy(Bytes_val(dst), Bytes_val(src) + subst_ofs, substr_width); 320 | 321 | CAMLreturn(dst); 322 | } 323 | 324 | CAMLprim value ml_string_cons(value cpv, value src) 325 | { 326 | CAMLparam2(cpv, src); 327 | CAMLlocal1(dst); 328 | 329 | const size_t src_length = caml_string_length(src); 330 | const uint32_t cp = Int_val(cpv); 331 | const size_t cp_width = utf8_width(cp); 332 | 333 | dst = caml_alloc_string(cp_width + src_length); 334 | 335 | // we take the pointer after allocation so it's fine 336 | uint8_t * dstp = Bytes_val(dst); 337 | 338 | utf8_write(dstp, cp_width, cp); 339 | memcpy(dstp+cp_width, Bytes_val(src), src_length); 340 | 341 | CAMLreturn(dst); 342 | } 343 | 344 | CAMLprim value ml_string_length(value src) 345 | { 346 | CAMLparam1(src); 347 | 348 | const uint8_t * srcp = Bytes_val(src); 349 | size_t bytes_remaining = caml_string_length(src); 350 | 351 | size_t n_chars = 0; 352 | while (bytes_remaining > 0) 353 | { 354 | uint32_t cp; 355 | size_t cp_width = utf8_read(srcp, bytes_remaining, &cp); 356 | if (cp_width == 0) 357 | { 358 | caml_failwith("ml_string_length: malformed string"); 359 | } 360 | 361 | srcp += cp_width; 362 | bytes_remaining -= cp_width; 363 | n_chars += 1; 364 | } 365 | 366 | CAMLreturn(Val_int(n_chars)); 367 | } 368 | 369 | CAMLprim value ml_string_head(value src) 370 | { 371 | CAMLparam1(src); 372 | 373 | uint32_t cp; 374 | const size_t cp_width = utf8_read(Bytes_val(src), caml_string_length(src), &cp); 375 | if (cp_width == 0) { 376 | caml_failwith("ml_string_head: empty or malformed string"); 377 | } 378 | 379 | CAMLreturn(Val_int(cp)); 380 | } 381 | 382 | CAMLprim value ml_string_tail(value src) 383 | { 384 | CAMLparam1(src); 385 | CAMLlocal1(dst); 386 | 387 | const uint8_t * srcp = Bytes_val(src); 388 | const size_t src_length = caml_string_length(src); 389 | 390 | uint32_t cp; 391 | const size_t cp_width = utf8_read(srcp, src_length, &cp); 392 | if (cp_width == 0) { 393 | caml_failwith("ml_string_tail: empty or malformed string"); 394 | } 395 | 396 | // allocation invalidates srcp 397 | dst = caml_alloc_string(src_length - cp_width); 398 | 399 | memcpy(Bytes_val(dst), Bytes_val(src) + cp_width, src_length - cp_width); 400 | 401 | CAMLreturn(dst); 402 | } 403 | 404 | CAMLprim value ml_string_get(value src, value i) 405 | { 406 | CAMLparam2(src, i); 407 | 408 | const uint8_t * src_start = Bytes_val(src); 409 | const uint8_t * src_end = src_start + caml_string_length(src); 410 | 411 | const uint8_t * p = utf8_skip_chars(src_start, src_end - src_start, Int_val(i)); 412 | if (p == src_end) 413 | { 414 | caml_failwith("ml_string_get: index out of bounds"); 415 | } 416 | 417 | uint32_t cp; 418 | const size_t cp_width = utf8_read(p, src_end - p, &cp); 419 | if (cp_width == 0) 420 | { 421 | caml_failwith("ml_string_get: out of bounds or malformed string"); 422 | } 423 | 424 | CAMLreturn(Val_int(cp)); 425 | } 426 | 427 | // useful for debugging UTF8, memory b0rkage and such 428 | void sanity_check(const char * msg, value s) 429 | { 430 | const uint8_t * p = Bytes_val(s); 431 | size_t bytes_remaining = caml_string_length(s); 432 | 433 | printf("validating: %s\n", p); 434 | printf("strlen = %d, caml_string_length = %d\n", strlen(p), bytes_remaining); 435 | printf("---------------------------------------------------\n"); 436 | 437 | while (bytes_remaining > 0) 438 | { 439 | uint32_t cp; 440 | const size_t cp_width = utf8_read(p, bytes_remaining, &cp); 441 | if (cp_width == 0) 442 | { 443 | printf("%p: %s\n", p, p); 444 | printf("%s: sanity check failed\n", msg); 445 | *((int *) 0) = 0; // segfault for gdb 446 | caml_failwith("sanity_check: malformed string"); 447 | } 448 | 449 | p += cp_width; 450 | bytes_remaining -= cp_width; 451 | } 452 | } 453 | 454 | CAMLprim value ml_string_unpack(value src) 455 | { 456 | CAMLparam1(src); 457 | CAMLlocal3(fst, prev, next); 458 | 459 | fst = Val_int(0); // represents idris's Nil 460 | 461 | size_t ofs = 0; 462 | size_t bytes_remaining = caml_string_length(src); 463 | 464 | while (bytes_remaining > 0) 465 | { 466 | uint32_t cp; 467 | const size_t cp_width = utf8_read(Bytes_val(src) + ofs, bytes_remaining, &cp); 468 | if (cp_width == 0) 469 | { 470 | caml_failwith("ml_string_unpack: malformed string"); 471 | } 472 | 473 | // special case for the first cell 474 | if (Is_long(fst)) { 475 | fst = caml_alloc(2, 1); // idris's (::) has tag 1 476 | Store_field(fst, 0, Val_int(cp)); 477 | Store_field(fst, 1, Val_int(0)); // points to Nil 478 | 479 | prev = fst; 480 | } else { 481 | next = caml_alloc(2, 1); 482 | Store_field(next, 0, Val_int(cp)); 483 | Store_field(next, 1, Val_int(0)); // points to Nil 484 | 485 | Store_field(prev, 1, next); // point prev->next to next 486 | prev = next; 487 | } 488 | 489 | bytes_remaining -= cp_width; 490 | ofs += cp_width; 491 | } 492 | 493 | CAMLreturn(fst); 494 | } 495 | 496 | CAMLprim value ml_string_pack(value cps) 497 | { 498 | CAMLparam1(cps); 499 | CAMLlocal2(p, dst); 500 | 501 | // first pass: get the total number of bytes 502 | size_t total_width = 0; 503 | for (p = cps; Is_block(p); p = Field(p, 1)) 504 | { 505 | const uint32_t cp = Int_val(Field(p, 0)); 506 | const size_t cp_width = utf8_width(cp); 507 | if (cp_width == 0) 508 | { 509 | caml_failwith("ml_string_pack: code point out of range"); 510 | } 511 | 512 | total_width += cp_width; 513 | } 514 | 515 | // second pass: encode the characters 516 | dst = caml_alloc_string(total_width); 517 | uint8_t * dstp = Bytes_val(dst); // must come after the allocation 518 | for (p = cps; Is_block(p); p = Field(p, 1)) 519 | { 520 | const uint32_t cp = Int_val(Field(p, 0)); 521 | const size_t cp_width = utf8_width(cp); 522 | if (cp_width == 0) 523 | { 524 | caml_failwith("ml_string_pack: impossible: code point out of range despite previous check"); 525 | } 526 | 527 | utf8_write(dstp, cp_width, cp); 528 | dstp += cp_width; 529 | } 530 | 531 | CAMLreturn(dst); 532 | } 533 | 534 | CAMLprim value ml_string_concat(value ss) 535 | { 536 | CAMLparam1(ss); 537 | CAMLlocal3(p, s, dst); 538 | 539 | // first pass: get the total number of bytes 540 | size_t total_width = 0; 541 | for (p = ss; Is_block(p); p = Field(p, 1)) 542 | { 543 | total_width += caml_string_length(Field(p, 0)); 544 | } 545 | 546 | // second pass: copy the strings 547 | dst = caml_alloc_string(total_width); 548 | uint8_t * dstp = Bytes_val(dst); // must come after the allocation 549 | for (p = ss; Is_block(p); p = Field(p, 1)) 550 | { 551 | s = Field(p, 0); 552 | 553 | const uint8_t * srcp = Bytes_val(s); 554 | const size_t width = caml_string_length(s); 555 | 556 | memcpy(dstp, srcp, width); 557 | 558 | dstp += width; 559 | } 560 | 561 | CAMLreturn(dst); 562 | } 563 | 564 | CAMLprim value inspect(value ty, value x) 565 | { 566 | CAMLparam2(ty, x); 567 | inspect_(0, x); 568 | CAMLreturn(Val_int(0)); // return unit 569 | } 570 | 571 | CAMLprim value ml_idris2_getErrno(value world) 572 | { 573 | CAMLparam1(world); 574 | 575 | int errnum = idris2_getErrno(); 576 | 577 | CAMLreturn(Val_int(errnum)); 578 | } 579 | 580 | CAMLprim value ml_idris2_getArgCount(value world) 581 | { 582 | CAMLparam1(world); 583 | int nargs = idris2_getArgCount(); 584 | CAMLreturn(Val_int(nargs)); 585 | } 586 | 587 | CAMLprim value ml_idris2_getArg(value i) 588 | { 589 | CAMLparam1(i); 590 | const char * arg = idris2_getArg(Int_val(i)); 591 | CAMLreturn(caml_copy_string(arg)); 592 | } 593 | 594 | CAMLprim value ml_idris2_system(value cmd) 595 | { 596 | CAMLparam1(cmd); 597 | int result = idris2_system(String_val(cmd)); 598 | CAMLreturn(Val_int(result)); 599 | } 600 | 601 | CAMLprim value ml_idris2_strerror(value errnum) 602 | { 603 | CAMLparam1(errnum); 604 | const char * str = idris2_strerror(Int_val(errnum)); 605 | CAMLreturn(caml_copy_string(str)); 606 | } 607 | 608 | CAMLprim value ml_idris2_getStr(value unit) 609 | { 610 | CAMLparam1(unit); 611 | CAMLlocal1(result); 612 | 613 | char * rptr = idris2_getStr(); 614 | result = caml_copy_string(rptr); 615 | free(rptr); 616 | 617 | CAMLreturn(result); 618 | } 619 | 620 | CAMLprim value ml_idris2_getString(value sptr) 621 | { 622 | CAMLparam1(sptr); 623 | // sptr represents Ptr String 624 | // 625 | // which is either 0L 626 | // or a caml string 627 | // 628 | // since we always need an is_Null check before calling this function 629 | // the former can never be the case 630 | CAMLreturn(sptr); 631 | } 632 | 633 | CAMLprim value ml_idris2_getEnvPair(value i) 634 | { 635 | CAMLparam1(i); 636 | const char * result = idris2_getEnvPair(Int_val(i)); 637 | CAMLreturn((value) result); 638 | } 639 | 640 | CAMLprim value ml_idris2_isNull(value ptr) 641 | { 642 | CAMLparam1(ptr); 643 | const int result = idris2_isNull((void *) ptr); 644 | CAMLreturn(Val_int(result)); 645 | } 646 | 647 | CAMLprim value ml_idris2_getNull(value unit) 648 | { 649 | CAMLparam1(unit); 650 | void * result = idris2_getNull(); 651 | CAMLreturn((value) result); 652 | } 653 | 654 | CAMLprim value ml_idris2_sleep(value sec) 655 | { 656 | CAMLparam1(sec); 657 | idris2_sleep(Int_val(sec)); 658 | CAMLreturn(Val_int(0)); // unit 659 | } 660 | 661 | CAMLprim value ml_idris2_usleep(value usec) 662 | { 663 | CAMLparam1(usec); 664 | idris2_usleep(Int_val(usec)); 665 | CAMLreturn(Val_int(0)); // unit 666 | } 667 | 668 | CAMLprim value ml_idris2_time(value unit) 669 | { 670 | CAMLparam1(unit); 671 | int result = idris2_time(); 672 | CAMLreturn(Val_int(result)); 673 | } 674 | 675 | CAMLprim value ml_idris2_setArgs(value argc, value argv) 676 | { 677 | CAMLparam2(argc, argv); 678 | caml_failwith("TODO: ml_idris2_setArgs not implemented"); 679 | CAMLreturn(Val_int(0)); // unit 680 | } 681 | 682 | CAMLprim value ml_idris2_getPID(value unit) 683 | { 684 | CAMLparam1(unit); 685 | int result = idris2_getPID(); 686 | CAMLreturn(Val_int(result)); 687 | } 688 | 689 | CAMLprim value ml_idris2_getNProcessors(value unit) 690 | { 691 | CAMLparam1(unit); 692 | int result = idris2_getNProcessors(); 693 | CAMLreturn(Val_int(result)); 694 | } 695 | 696 | // XXX: put this into the idris headers 697 | FILE *idris2_popen(const char * cmd, const char * mode); 698 | void idris2_pclose(FILE * f); 699 | 700 | CAMLprim value ml_idris2_popen(value cmd, value mode) 701 | { 702 | CAMLparam2(cmd, mode); 703 | void * ptr = idris2_popen(String_val(cmd), String_val(mode)); 704 | CAMLreturn((value) ptr); 705 | } 706 | 707 | CAMLprim value ml_idris2_pclose(value stream) 708 | { 709 | CAMLparam1(stream); 710 | idris2_pclose((void *) stream); 711 | CAMLreturn(Val_int(0)); // unit 712 | } 713 | 714 | CAMLprim value ml_idris2_chmod(value path, value mode) 715 | { 716 | CAMLparam2(path, mode); 717 | int result = idris2_chmod(String_val(path), Int_val(mode)); 718 | CAMLreturn(Val_int(result)); 719 | } 720 | 721 | CAMLprim value ml_idris2_putStr(value s) 722 | { 723 | CAMLparam1(s); 724 | idris2_putStr(String_val(s)); 725 | CAMLreturn(Val_int(0)); 726 | } 727 | 728 | CAMLprim value ml_idris2_openFile(value name, value mode) { 729 | CAMLparam2(name, mode); 730 | const FILE* result = idris2_openFile(String_val(name), String_val(mode)); 731 | CAMLreturn((value) result); 732 | } 733 | 734 | CAMLprim value ml_idris2_fileIsTTY(value f) { 735 | CAMLparam1(f); 736 | int result = idris2_fileIsTTY((FILE *) f); 737 | CAMLreturn(Val_int(result)); 738 | } 739 | 740 | CAMLprim value ml_idris2_closeFile(value file) { 741 | CAMLparam1(file); 742 | idris2_closeFile((FILE *) file); 743 | CAMLreturn(Val_int(0)); 744 | } 745 | 746 | CAMLprim value ml_idris2_fileError(value file) { 747 | CAMLparam1(file); 748 | const int result = idris2_fileError((FILE *) file); 749 | CAMLreturn(Val_int(result)); 750 | } 751 | 752 | CAMLprim value ml_idris2_fileErrno(value unit) 753 | { 754 | CAMLparam1(unit); 755 | const int result = idris2_fileErrno(); 756 | CAMLreturn(Val_int(result)); 757 | } 758 | 759 | CAMLprim value ml_idris2_removeFile(value name) { 760 | CAMLparam1(name); 761 | const int result = idris2_removeFile(String_val(name)); 762 | CAMLreturn(Val_int(result)); 763 | } 764 | 765 | CAMLprim value ml_idris2_fileSize(value file) { 766 | CAMLparam1(file); 767 | const int result = idris2_fileSize((FILE *) file); 768 | CAMLreturn(Val_int(result)); 769 | } 770 | 771 | CAMLprim value ml_idris2_fpoll(value file) { 772 | CAMLparam1(file); 773 | const int result = idris2_fpoll((FILE *) file); 774 | CAMLreturn(Val_int(result)); 775 | } 776 | 777 | CAMLprim value ml_idris2_readLine(value file) { 778 | CAMLparam1(file); 779 | CAMLlocal1(result); 780 | 781 | char * rptr = idris2_readLine((FILE *) file); 782 | result = rptr ? caml_copy_string(rptr) : 0; 783 | free(rptr); 784 | 785 | CAMLreturn(result); 786 | } 787 | 788 | CAMLprim value ml_idris2_seekLine(value file) { 789 | CAMLparam1(file); 790 | int result = idris2_seekLine((FILE *) file); 791 | CAMLreturn(Val_int(result)); 792 | } 793 | 794 | CAMLprim value ml_idris2_readChars(value num, value file) { 795 | CAMLparam2(num, file); 796 | CAMLlocal1(result); 797 | 798 | char * rptr = idris2_readChars(Int_val(num), (FILE *) file); 799 | result = rptr ? caml_copy_string(rptr) : 0; 800 | free(rptr); 801 | 802 | CAMLreturn(result); 803 | } 804 | 805 | CAMLprim value ml_idris2_writeLine(value file, value str) { 806 | CAMLparam2(file, str); 807 | const int result = idris2_writeLine((FILE *) file, String_val(str)); 808 | CAMLreturn(Val_int(result)); 809 | } 810 | 811 | CAMLprim value ml_idris2_eof(value file) { 812 | CAMLparam1(file); 813 | const int result = idris2_eof((FILE *)file); 814 | CAMLreturn(Val_int(result)); 815 | } 816 | 817 | CAMLprim value ml_idris2_fileAccessTime(value file) { 818 | CAMLparam1(file); 819 | const int result = idris2_fileAccessTime((FILE *)file); 820 | CAMLreturn(Val_int(result)); 821 | } 822 | 823 | CAMLprim value ml_idris2_fileModifiedTime(value file) { 824 | CAMLparam1(file); 825 | const int result = idris2_fileModifiedTime((FILE *)file); 826 | CAMLreturn(Val_int(result)); 827 | } 828 | 829 | CAMLprim value ml_idris2_fileStatusTime(value file) { 830 | CAMLparam1(file); 831 | const int result = idris2_fileStatusTime((FILE *)file); 832 | CAMLreturn(Val_int(result)); 833 | } 834 | 835 | CAMLprim value ml_idris2_stdin(value unit) { 836 | CAMLparam1(unit); 837 | FILE* result = idris2_stdin(); 838 | CAMLreturn((value) result); 839 | } 840 | 841 | CAMLprim value ml_idris2_stdout(value unit) { 842 | CAMLparam1(unit); 843 | FILE* result = idris2_stdout(); 844 | CAMLreturn((value) result); 845 | } 846 | 847 | CAMLprim value ml_idris2_stderr(value unit) { 848 | CAMLparam1(unit); 849 | FILE* result = idris2_stderr(); 850 | CAMLreturn((value) result); 851 | } 852 | 853 | CAMLprim value ml_idris2_currentDirectory(value unit) { 854 | CAMLparam1(unit); 855 | CAMLlocal1(result); 856 | 857 | char * rptr = idris2_currentDirectory(); 858 | result = rptr ? caml_copy_string(rptr) : 0; 859 | free(rptr); 860 | 861 | CAMLreturn(result); 862 | } 863 | 864 | CAMLprim value ml_idris2_changeDir(value dir) { 865 | CAMLparam1(dir); 866 | const int result = idris2_changeDir(String_val(dir)); 867 | CAMLreturn(Val_int(result)); 868 | } 869 | 870 | CAMLprim value ml_idris2_createDir(value dir) { 871 | CAMLparam1(dir); 872 | const int result = idris2_createDir(String_val(dir)); 873 | CAMLreturn(Val_int(result)); 874 | } 875 | 876 | CAMLprim value ml_idris2_openDir(value dir) { 877 | CAMLparam1(dir); 878 | const void *result = idris2_openDir(String_val(dir)); 879 | CAMLreturn((value) result); 880 | } 881 | 882 | CAMLprim value ml_idris2_closeDir(value dirInfo) { 883 | CAMLparam1(dirInfo); 884 | idris2_closeDir((void *)dirInfo); 885 | CAMLreturn(Val_int(0)); 886 | } 887 | 888 | CAMLprim value ml_idris2_removeDir(value dir) { 889 | CAMLparam1(dir); 890 | const int result = idris2_removeDir(String_val(dir)); 891 | CAMLreturn(Val_int(result)); 892 | } 893 | 894 | CAMLprim value ml_idris2_nextDirEntry(value dirInfo) { 895 | CAMLparam1(dirInfo); 896 | CAMLlocal1(result); 897 | 898 | const char * rptr = idris2_nextDirEntry((void *)dirInfo); 899 | result = rptr ? caml_copy_string(rptr) : 0; 900 | // do NOT free rptr here 901 | 902 | CAMLreturn(result); 903 | } 904 | 905 | /* libc stuff */ 906 | 907 | CAMLprim value ml_getenv(value s) 908 | { 909 | CAMLparam1(s); 910 | CAMLlocal1(result); 911 | 912 | const char * rptr = getenv(String_val(s)); 913 | result = rptr ? caml_copy_string(rptr) : 0; 914 | // do NOT free rptr 915 | 916 | CAMLreturn(result); 917 | } 918 | 919 | CAMLprim value ml_system(value s) 920 | { 921 | CAMLparam1(s); 922 | const int result = system(String_val(s)); 923 | CAMLreturn(Val_int(result)); 924 | } 925 | 926 | CAMLprim value ml_exit(value s) 927 | { 928 | CAMLparam1(s); 929 | exit(Int_val(s)); 930 | CAMLreturn(Val_int(0)); 931 | } 932 | 933 | CAMLprim value ml_fflush(value file) { 934 | CAMLparam1(file); 935 | const int result = fflush((FILE *)file); 936 | CAMLreturn(Val_int(result)); 937 | } 938 | 939 | CAMLprim value ml_fdopen(value fd, value mode) { 940 | CAMLparam2(fd, mode); 941 | FILE * result = fdopen(Int_val(fd), String_val(mode)); 942 | CAMLreturn((value) result); 943 | } 944 | 945 | CAMLprim value ml_chmod(value path, value mode) { 946 | CAMLparam2(path, mode); 947 | const int result = chmod(String_val(path), Int_val(mode)); 948 | CAMLreturn(Val_int(result)); 949 | } 950 | 951 | CAMLprim value ml_putchar(value c) { 952 | CAMLparam1(c); 953 | const int result = putchar(Int_val(c)); 954 | CAMLreturn(Val_int(result)); 955 | } 956 | 957 | CAMLprim value ml_getchar(value unit) { 958 | CAMLparam1(unit); 959 | const int result = getchar(); 960 | CAMLreturn(Val_int(result)); 961 | } 962 | 963 | CAMLprim value ml_strlen(value str) { 964 | CAMLparam1(str); 965 | size_t len = strlen(String_val(str)); 966 | CAMLreturn(Val_int(len)); 967 | } 968 | 969 | CAMLprim value ml_fgetc(value fptr) { 970 | CAMLparam1(fptr); 971 | CAMLreturn(Val_int(fgetc((FILE *)fptr))); 972 | } 973 | 974 | /* buffer stuff */ 975 | 976 | CAMLprim value ml_idris2_newBuffer(value size) { 977 | CAMLparam1(size); 978 | CAMLlocal1(result); 979 | result = caml_alloc_string(Int_val(size)); 980 | CAMLreturn(result); 981 | } 982 | 983 | CAMLprim value ml_idris2_freeBuffer(value buffer) { 984 | CAMLparam1(buffer); 985 | // nothing to do 986 | CAMLreturn(Val_int(0)); 987 | } 988 | 989 | CAMLprim value ml_idris2_getBufferSize(value buffer) { 990 | CAMLparam1(buffer); 991 | const int result = caml_string_length(buffer); 992 | CAMLreturn(Val_int(result)); 993 | } 994 | 995 | CAMLprim value ml_idris2_setBufferByte(value buffer, value loc, value val) { 996 | CAMLparam3(buffer, loc, val); 997 | ((uint8_t *) Bytes_val(buffer))[Int_val(loc)] = (uint8_t) Int_val(val); 998 | CAMLreturn(Val_int(0)); 999 | } 1000 | 1001 | CAMLprim value ml_idris2_setBufferInt(value buffer, value loc, value val) { 1002 | CAMLparam3(buffer, loc, val); 1003 | int64_t iv = Int_val(val); 1004 | memcpy(Bytes_val(buffer) + Int_val(loc), &iv, sizeof(iv)); 1005 | CAMLreturn(Val_int(0)); 1006 | } 1007 | 1008 | CAMLprim value ml_idris2_setBufferDouble(value buffer, value loc, value val) { 1009 | CAMLparam3(buffer, loc, val); 1010 | double dv = Double_val(val); 1011 | memcpy(Bytes_val(buffer) + Int_val(loc), &dv, sizeof(dv)); 1012 | CAMLreturn(Val_int(0)); 1013 | } 1014 | 1015 | CAMLprim value ml_idris2_setBufferString(value buffer, value loc, value val) { 1016 | CAMLparam3(buffer, loc, val); 1017 | memcpy(Bytes_val(buffer) + Int_val(loc), String_val(val), strlen(String_val(val))); 1018 | CAMLreturn(Val_int(0)); 1019 | } 1020 | 1021 | CAMLprim value ml_idris2_copyBuffer(value from, value start, value len, value to, value loc) { 1022 | CAMLparam5(from,start,len,to,loc); 1023 | memcpy(Bytes_val(to) + Int_val(loc), Bytes_val(from) + Int_val(start), Int_val(len)); 1024 | CAMLreturn(Val_int(0)); 1025 | } 1026 | 1027 | CAMLprim value ml_idris2_readBufferData(value file, value buffer, value loc, value max) { 1028 | CAMLparam4(file, buffer, loc, max); 1029 | const size_t result = fread(Bytes_val(buffer) + Int_val(loc), 1, Int_val(max), (FILE *) file); 1030 | CAMLreturn(Val_int(result)); 1031 | } 1032 | 1033 | CAMLprim value ml_idris2_writeBufferData(value file, value buffer, value loc, value len) { 1034 | CAMLparam4(file, buffer, loc, len); 1035 | const size_t result = fwrite(Bytes_val(buffer) + Int_val(loc), 1, Int_val(len), (FILE *) file); 1036 | CAMLreturn(Val_int(result)); 1037 | } 1038 | 1039 | CAMLprim value ml_idris2_getBufferByte(value buffer, value loc) { 1040 | CAMLparam2(buffer, loc); 1041 | const uint8_t result = ((uint8_t *) Bytes_val(buffer))[Int_val(loc)]; 1042 | CAMLreturn(Val_int(result)); 1043 | } 1044 | 1045 | CAMLprim value ml_idris2_getBufferInt(value buffer, value loc) { 1046 | CAMLparam2(buffer, loc); 1047 | int64_t iv; 1048 | memcpy(&iv, Bytes_val(buffer) + Int_val(loc), sizeof(iv)); 1049 | CAMLreturn(Val_int(iv)); 1050 | } 1051 | 1052 | CAMLprim value ml_idris2_getBufferDouble(value buffer, value loc) { 1053 | CAMLparam2(buffer, loc); 1054 | CAMLlocal1(result); 1055 | 1056 | double dv; 1057 | memcpy(&dv, Bytes_val(buffer) + Int_val(loc), sizeof(dv)); 1058 | result = caml_copy_double(dv); 1059 | 1060 | CAMLreturn(result); 1061 | } 1062 | 1063 | CAMLprim value ml_idris2_getBufferString(value src, value ofs, value max_width) { 1064 | CAMLparam3(src, ofs, max_width); 1065 | CAMLlocal1(dst); 1066 | 1067 | // idris2_getBufferString uses strncpy so we have to find where the NUL terminator is 1068 | const size_t nbytes = strnlen(Bytes_val(src) + Int_val(ofs), Int_val(max_width)); 1069 | dst = caml_alloc_string(nbytes); // ocaml null-terminates all strings 1070 | memcpy(Bytes_val(dst), Bytes_val(src) + Int_val(ofs), nbytes); 1071 | 1072 | CAMLreturn(dst); 1073 | } 1074 | 1075 | /* Idrnet */ 1076 | 1077 | CAMLprim value ml_idrnet_close(value fd) { 1078 | CAMLparam1(fd); 1079 | // TODO 1080 | CAMLreturn(Val_int(0)); 1081 | } 1082 | 1083 | CAMLprim value ml_idrnet_fdopen(value fd, value mode) { 1084 | CAMLparam2(fd, mode); 1085 | // TODO 1086 | CAMLreturn((value) NULL); 1087 | } 1088 | 1089 | CAMLprim value ml_idrnet_sockaddr_unix(value sockaddr) { 1090 | CAMLparam1(sockaddr); 1091 | // TODO 1092 | CAMLreturn(caml_copy_string("(TODO)")); 1093 | } 1094 | 1095 | CAMLprim value ml_idrnet_sockaddr_port(value fd) { 1096 | CAMLparam1(fd); 1097 | // TODO 1098 | CAMLreturn(Val_int(0)); 1099 | } 1100 | 1101 | /* 1102 | CAMLprim value ml_idrnet_sendto_buf(value sockfd, value buf, value buf_len, value host, value port, value family) { 1103 | CAMLparam6(sockfd, buf, buf_len, host, port, family); 1104 | // TODO 1105 | CAMLreturn(Val_int(0)); 1106 | } 1107 | */ 1108 | 1109 | CAMLprim value ml_idrnet_getaddrinfo(value address_res, value host, value port, value family, value socket_type) { 1110 | CAMLparam5(address_res, host, port, family, socket_type); 1111 | // TODO 1112 | CAMLreturn(Val_int(0)); 1113 | } 1114 | 1115 | CAMLprim value ml_idrnet_malloc(value size) { 1116 | CAMLparam1(size); 1117 | void * result = idris2_malloc(Val_int(size)); 1118 | CAMLreturn((value) result); 1119 | } 1120 | 1121 | CAMLprim value ml_idrnet_free(value buffer) { 1122 | CAMLparam1(buffer); 1123 | idris2_free((void *) buffer); 1124 | CAMLreturn(Val_int(0)); 1125 | } 1126 | 1127 | CAMLprim value ml_idrnet_peek(value buffer, value loc) { 1128 | CAMLparam2(buffer, loc); 1129 | // TODO 1130 | CAMLreturn(Val_int(0)); 1131 | } 1132 | CAMLprim value ml_idrnet_poke(value buffer, value loc, value val) { 1133 | CAMLparam3(buffer, loc, val); 1134 | // TODO 1135 | CAMLreturn(Val_int(0)); 1136 | } 1137 | 1138 | CAMLprim value ml_idrnet_errno() { 1139 | CAMLparam0(); 1140 | 1141 | const int errno = idrnet_errno(); 1142 | 1143 | CAMLreturn(Val_int(errno)); 1144 | } 1145 | 1146 | CAMLprim value ml_idrnet_socket(value domain, value type, value protocol) { 1147 | CAMLparam3(domain, type, protocol); 1148 | // TODO 1149 | CAMLreturn(Val_int(0)); 1150 | } 1151 | 1152 | CAMLprim value ml_idrnet_bind(value sockfd, value family, value socket_type, value host, value port) { 1153 | CAMLparam5(sockfd, family, socket_type, host, port); 1154 | // TODO 1155 | CAMLreturn(Val_int(0)); 1156 | } 1157 | 1158 | CAMLprim value ml_idrnet_getsockname(value sockfd, value address, value len) { 1159 | CAMLparam3(sockfd, address, len); 1160 | value result = Val_int(0); 1161 | CAMLreturn(result); 1162 | } 1163 | 1164 | CAMLprim value ml_idrnet_connect(value sockfd, value family, value socket_type, value host, value port) { 1165 | CAMLparam5(sockfd, family, socket_type, host, port); 1166 | value result = Val_int(0); 1167 | CAMLreturn(result); 1168 | } 1169 | 1170 | CAMLprim value ml_idrnet_sockaddr_family(value sockaddr) { 1171 | CAMLparam1(sockaddr); 1172 | value result = Val_int(0); 1173 | CAMLreturn(result); 1174 | } 1175 | 1176 | CAMLprim value ml_idrnet_sockaddr_ipv4(value sockaddr) { 1177 | CAMLparam1(sockaddr); 1178 | value result = Val_int(0); 1179 | CAMLreturn(result); 1180 | } 1181 | CAMLprim value ml_idrnet_sockaddr_ipv4_port(value sockaddr) { 1182 | CAMLparam1(sockaddr); 1183 | value result = Val_int(0); 1184 | CAMLreturn(result); 1185 | } 1186 | CAMLprim value ml_idrnet_create_sockaddr() { 1187 | CAMLparam0(); 1188 | value result = Val_int(0); 1189 | CAMLreturn(result); 1190 | } 1191 | 1192 | CAMLprim value ml_idrnet_listen(value fd, value backlog) { 1193 | CAMLparam2(fd, backlog); 1194 | int result = idrnet_listen(Int_val(fd), Int_val(backlog)); 1195 | CAMLreturn(Val_int(result)); 1196 | } 1197 | 1198 | CAMLprim value ml_idrnet_accept(value sockaddr) { 1199 | CAMLparam1(sockaddr); 1200 | value result = Val_int(0); 1201 | CAMLreturn(result); 1202 | } 1203 | 1204 | CAMLprim value ml_idrnet_send(value sockfd, value data) { 1205 | CAMLparam2(sockfd, data); 1206 | value result = Val_int(0); 1207 | CAMLreturn(result); 1208 | } 1209 | 1210 | CAMLprim value ml_idrnet_send_buf(value sockfd, value data, value len) { 1211 | CAMLparam3(sockfd, data, len); 1212 | value result = Val_int(0); 1213 | CAMLreturn(result); 1214 | } 1215 | 1216 | CAMLprim value ml_idrnet_recv(value sockfd, value len) { 1217 | CAMLparam2(sockfd, len); 1218 | value result = Val_int(0); 1219 | CAMLreturn(result); 1220 | } 1221 | 1222 | CAMLprim value ml_idrnet_recv_buf(value sockfd, value buf, value len) { 1223 | CAMLparam3(sockfd, buf, len); 1224 | value result = Val_int(0); 1225 | CAMLreturn(result); 1226 | } 1227 | 1228 | CAMLprim value ml_idrnet_sendto(value sockfd, value data, value host, value port, value family) { 1229 | CAMLparam5(sockfd, data, host, port, family); 1230 | value result = Val_int(0); 1231 | CAMLreturn(result); 1232 | } 1233 | 1234 | CAMLprim value ml_idrnet_sendto_buf_native(value sockfd, value buf, value len, value host, value port, value family) { 1235 | CAMLparam5(sockfd, buf, len, host, port); 1236 | CAMLxparam1(family); 1237 | value result = Val_int(0); 1238 | CAMLreturn(result); 1239 | } 1240 | 1241 | CAMLprim value ml_idrnet_sendto_buf_bytecode(value * argv, int argn ) { 1242 | // TODO: Assert argn == 6? 1243 | return ml_idrnet_sendto_buf_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); 1244 | } 1245 | 1246 | CAMLprim value ml_idrnet_recvfrom(value sockfd, value len) { 1247 | CAMLparam2(sockfd, len); 1248 | value result = Val_int(0); 1249 | CAMLreturn(result); 1250 | } 1251 | CAMLprim value ml_idrnet_recvfrom_buf(value sockfd, value buf, value len) { 1252 | CAMLparam3(sockfd, buf, len); 1253 | value result = Val_int(0); 1254 | CAMLreturn(result); 1255 | } 1256 | 1257 | CAMLprim value ml_idrnet_get_recv_res(value res_struct) { 1258 | CAMLparam1(res_struct); 1259 | value result = Val_int(0); 1260 | CAMLreturn(result); 1261 | } 1262 | CAMLprim value ml_idrnet_get_recv_payload(value res_struct) { 1263 | CAMLparam1(res_struct); 1264 | value result = Val_int(0); 1265 | CAMLreturn(result); 1266 | } 1267 | CAMLprim value ml_idrnet_free_recv_struct(value res_struct) { 1268 | CAMLparam1(res_struct); 1269 | value result = Val_int(0); 1270 | CAMLreturn(result); 1271 | } 1272 | 1273 | CAMLprim value ml_idrnet_get_recvfrom_res(value res_struct) { 1274 | CAMLparam1(res_struct); 1275 | value result = Val_int(0); 1276 | CAMLreturn(result); 1277 | } 1278 | CAMLprim value ml_idrnet_get_recvfrom_payload(value res_struct) { 1279 | CAMLparam1(res_struct); 1280 | value result = Val_int(0); 1281 | CAMLreturn(result); 1282 | } 1283 | CAMLprim value ml_idrnet_get_recvfrom_sockaddr(value res_struct) { 1284 | CAMLparam1(res_struct); 1285 | value result = Val_int(0); 1286 | CAMLreturn(result); 1287 | } 1288 | 1289 | CAMLprim value ml_idrnet_free_recvfrom_struct(value res_struct) { 1290 | CAMLparam1(res_struct); 1291 | value result = Val_int(0); 1292 | CAMLreturn(result); 1293 | } 1294 | 1295 | CAMLprim value ml_idrnet_geteagain() { 1296 | CAMLparam0(); 1297 | value result = Val_int(0); 1298 | CAMLreturn(result); 1299 | } 1300 | 1301 | CAMLprim value ml_idrnet_af_unspec(value world) { 1302 | CAMLparam1(world); 1303 | CAMLreturn(Val_int(idrnet_af_unspec())); 1304 | } 1305 | 1306 | CAMLprim value ml_idrnet_af_unix(value world) { 1307 | CAMLparam1(world); 1308 | CAMLreturn(Val_int(idrnet_af_unix())); 1309 | } 1310 | 1311 | CAMLprim value ml_idrnet_af_inet(value world) { 1312 | CAMLparam1(world); 1313 | CAMLreturn(Val_int(idrnet_af_inet())); 1314 | } 1315 | 1316 | CAMLprim value ml_idrnet_af_inet6(value world) { 1317 | CAMLparam1(world); 1318 | CAMLreturn(Val_int(idrnet_af_inet6())); 1319 | } 1320 | 1321 | CAMLprim value ml_idris2_listen(value socket, value backlog) { 1322 | CAMLparam2(socket, backlog); 1323 | const int result = listen(socket, backlog); 1324 | CAMLreturn(Val_int(result)); 1325 | } 1326 | 1327 | CAMLprim value ml_idris2_setupTerm(value world) { 1328 | CAMLparam1(world); 1329 | idris2_setupTerm(); 1330 | CAMLreturn(Val_int(0)); // unit 1331 | } 1332 | 1333 | CAMLprim value ml_idris2_getTermCols(value world) { 1334 | CAMLparam1(world); 1335 | int ncols = idris2_getTermCols(); 1336 | CAMLreturn(Val_int(ncols)); 1337 | } 1338 | 1339 | CAMLprim value ml_idris2_getTermLines(value world) { 1340 | CAMLparam1(world); 1341 | int nlines = idris2_getTermLines(); 1342 | CAMLreturn(Val_int(nlines)); 1343 | } 1344 | 1345 | // external clocktime_gc_cpu : world -> os_clock = "ml_clocktime_gc_cpu" 1346 | 1347 | CAMLprim value ml_clocktime_gc_cpu(value world) 1348 | { 1349 | CAMLparam1(world); 1350 | CAMLreturn((value) NULL); 1351 | } 1352 | 1353 | // external clocktime_gc_real : world -> os_clock = "ml_clocktime_gc_real" 1354 | 1355 | CAMLprim value ml_clocktime_gc_real(value world) 1356 | { 1357 | CAMLparam1(world); 1358 | CAMLreturn((value) NULL); 1359 | } 1360 | 1361 | // external clocktime_monotonic : world -> os_clock = "ml_clocktime_monotonic" 1362 | 1363 | CAMLprim value ml_clocktime_monotonic(value world) 1364 | { 1365 | CAMLparam1(world); 1366 | struct timespec ts = {}; 1367 | int res = clock_gettime(CLOCK_MONOTONIC, &ts); 1368 | if (res < 0) { 1369 | CAMLreturn((value) NULL); 1370 | } 1371 | 1372 | CAMLlocal1(result); 1373 | result = caml_alloc_string(Int_val(sizeof(ts))); 1374 | 1375 | memcpy(Bytes_val(result), &ts, sizeof(ts)); 1376 | 1377 | CAMLreturn(result); 1378 | } 1379 | 1380 | // external clocktime_process : world -> os_clock = "ml_clocktime_process" 1381 | 1382 | CAMLprim value ml_clocktime_process(value world) 1383 | { 1384 | CAMLparam1(world); 1385 | struct timespec ts = {}; 1386 | int res = clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &ts); 1387 | if (res < 0) { 1388 | CAMLreturn((value) NULL); 1389 | } 1390 | 1391 | CAMLlocal1(result); 1392 | result = caml_alloc_string(Int_val(sizeof(ts))); 1393 | 1394 | memcpy(Bytes_val(result), &ts, sizeof(ts)); 1395 | 1396 | CAMLreturn(result); 1397 | } 1398 | 1399 | // external clocktime_thread : world -> os_clock = "ml_clocktime_thread" 1400 | 1401 | CAMLprim value ml_clocktime_thread(value world) 1402 | { 1403 | CAMLparam1(world); 1404 | struct timespec ts = {}; 1405 | int res = clock_gettime(CLOCK_THREAD_CPUTIME_ID, &ts); 1406 | if (res < 0) { 1407 | CAMLreturn((value) NULL); 1408 | } 1409 | 1410 | CAMLlocal1(result); 1411 | result = caml_alloc_string(Int_val(sizeof(ts))); 1412 | 1413 | memcpy(Bytes_val(result), &ts, sizeof(ts)); 1414 | 1415 | CAMLreturn(result); 1416 | } 1417 | 1418 | 1419 | // external clocktime_utc : world -> os_clock = "ml_clocktime_utc" 1420 | 1421 | CAMLprim value ml_clocktime_utc(value world) 1422 | { 1423 | CAMLparam1(world); 1424 | time_t sec = time(NULL); 1425 | if ((long) sec == 0) { 1426 | CAMLreturn((value) NULL); 1427 | } 1428 | 1429 | struct timespec ts = {}; 1430 | ts.tv_sec = sec; 1431 | ts.tv_nsec = 0; 1432 | 1433 | CAMLlocal1(result); 1434 | result = caml_alloc_string(Int_val(sizeof(ts))); 1435 | 1436 | memcpy(Bytes_val(result), &ts, sizeof(ts)); 1437 | 1438 | CAMLreturn(result); 1439 | } 1440 | 1441 | // external os_clock_nanosecond : os_clock -> world -> int64 = "ml_os_clock_nanosecond" 1442 | 1443 | CAMLprim value ml_os_clock_nanosecond(value clock) 1444 | { 1445 | CAMLparam1(clock); 1446 | 1447 | if ((void *) clock == NULL) { 1448 | CAMLreturn(caml_copy_int64(0)); 1449 | } 1450 | 1451 | struct timespec ts = {}; 1452 | 1453 | memcpy(&ts, Bytes_val(clock), sizeof(ts)); 1454 | 1455 | CAMLreturn(caml_copy_int64(ts.tv_nsec)); 1456 | } 1457 | 1458 | // external os_clock_second : os_clock -> world -> int64 = "ml_os_clock_second" 1459 | 1460 | CAMLprim value ml_os_clock_second(value clock) 1461 | { 1462 | CAMLparam1(clock); 1463 | 1464 | if ((void *) clock == NULL) { 1465 | CAMLreturn(caml_copy_int64(0)); 1466 | } 1467 | 1468 | struct timespec ts = {}; 1469 | 1470 | memcpy(&ts, Bytes_val(clock), sizeof(ts)); 1471 | 1472 | CAMLreturn(caml_copy_int64(ts.tv_sec)); 1473 | } 1474 | 1475 | // external os_clock_valid : os_clock -> world -> int = "ml_os_clock_valid" 1476 | 1477 | CAMLprim value ml_os_clock_valid(value clock) 1478 | { 1479 | CAMLparam1(clock); 1480 | 1481 | if ((void *) clock == NULL) { 1482 | CAMLreturn(Val_int(0)); 1483 | } else { 1484 | CAMLreturn(Val_int(1)); 1485 | } 1486 | } 1487 | 1488 | CAMLprim value ml_idris2_malloc(value size) 1489 | { 1490 | CAMLparam1(size); 1491 | void * result = idris2_malloc(Int_val(size)); 1492 | CAMLreturn((value) result); 1493 | } 1494 | 1495 | CAMLprim value ml_idris2_free(value buf) 1496 | { 1497 | CAMLparam1(buf); 1498 | idris2_free((void *) buf); 1499 | CAMLreturn(Val_int(0)); // unit 1500 | } 1501 | --------------------------------------------------------------------------------