├── .gitignore ├── LICENSE.txt ├── Makefile ├── README.md ├── idris2-ocaml.ipkg ├── repl.sh ├── src └── Ocaml │ ├── CompileCommands.idr │ ├── Expr.idr │ ├── Foreign.idr │ ├── Modules.idr │ ├── Ocaml.idr │ ├── PrimFns.idr │ └── Utils.idr └── support ├── OcamlRts.ml └── ocaml_rts.c /.gitignore: -------------------------------------------------------------------------------- 1 | build/ 2 | *.o 3 | *.cmi 4 | *.cmx 5 | *.mli 6 | *.geany 7 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | License 2 | 3 | THE WORK (AS DEFINED BELOW) IS PROVIDED UNDER THE TERMS OF THIS COPYFARLEFT PUBLIC LICENSE ("LICENSE"). THE WORK IS PROTECTED BY COPYRIGHT AND ALL OTHER APPLICABLE LAWS. ANY USE OF THE WORK OTHER THAN AS AUTHORIZED UNDER THIS LICENSE OR COPYRIGHT LAW IS PROHIBITED. 4 | 5 | BY EXERCISING ANY RIGHTS TO THE WORK PROVIDED IN THIS LICENSE, YOU AGREE TO BE BOUND BY THE TERMS OF THIS LICENSE. TO THE EXTENT THIS LICENSE MAY BE CONSIDERED TO BE A CONTRACT, THE LICENSOR GRANTS YOU THE RIGHTS CONTAINED HERE IN AS CONSIDERATION FOR ACCEPTING THE TERMS AND CONDITIONS OF THIS LICENSE AND FOR AGREEING TO BE BOUND BY THE TERMS AND CONDITIONS OF THIS LICENSE. 6 | 7 | 1. Definitions 8 | 9 | a. "Adaptation" means a Work based upon the Work, or upon the Work and other pre-existing Works, such as a translation, adaptation, derivative Work, arrangement of music or other alterations of a literary or artistic Work, or phonogram or performance and includes cinematographic Adaptations or any other form in which the Work may be recast, transformed, or adapted including in any form recognizably derived from the original, except that a Work that constitutes a Collection will not be considered an adaptation for the purpose of this license. For the avoidance of doubt, where the Work is a musical Work, performance or phonogram, the synchronization of the Work in timed-relation with a moving image ("synching") will be considered an adaptation for the purpose of this license. 10 | 11 | b. "Collection" means a Collection of literary or artistic Works, such as encyclopedias and anthologies, or performances, phonograms or broadcasts, or other Works or subject matter other than Works listed in Section 1(f) below, which, by reason of the selection and arrangement of their contents, constitute intellectual creations, in which the Work is included in its entirety in unmodified form along with one or more other contributions, each constituting separate and independent Works in themselves, which together are assembled into a collective whole. A Work that constitutes a Collection will not be considered an adaptation (as defined above) for the purposes of this license. 12 | 13 | c. "Distribute" means to make available to the public the original and copies of the Work or adaptation, as appropriate, through sale, gift or any other transfer of possession or ownership. 14 | 15 | d. "Licensor" means the individual, individuals, entity or entities that offer(s) the Work under the terms of this license. 16 | 17 | e. "Original Author" means, in the case of a literary or artistic Work, the individual, in dividuals, entity or entities who created the Work or if no individual or entity can be identified, the publisher; and in addition (i) in the case of a performance the actors, singers, musicians, dancers, and other persons who act, sing, deliver, declaim, play in, interpret or otherwise perform literary or artistic Works or expressions of folklore; (ii) in the case of a phonogram the producer being the person or legal entity who first fixes the sounds of a performance or other sounds; and, (iii) in the case of broadcasts, the organization that transmits the broadcast. 18 | 19 | f. "Work" means the literary and/or artistic Work offered under the terms of this license including without limitation any production in the literary, scientific and artistic domain, whatever may be the mode or form of its expression including digital form, such as a book, pamphlet and other writing; a lecture, address, sermon or other Work of the same nature; a dramatic or dramatico-musical Work; a choreographic Work or entertainment in dumb show; a musical composition with or without words; a cinematographic Work to which are assimilated Works expressed by a process analogous to cinematography; a Work of drawing, painting, architecture, sculpture, engraving or lithography; a photographic Work to which are assimilated Works expressed by a pro cess analogous to photography; a Work of applied art; an illustration, map, plan, sketch or three-dimensional Work relative to geography, topography, architecture or science; a performance; a broadcast; a phonogram; a compilation of data to the extent it is protected as a copyrightable Work; or a Work performed by a variety or circus performer to the extent it is not otherwise considered a literary or artistic Work. 20 | 21 | g. "You" means an individual or entity exercising rights under this license who has not previously violated the terms of this license with respect to the Work, or who has received express permission from the Licensor to exercise rights under this license despite a previous violation. 22 | 23 | h. "Publicly Perform" means to perform public recitations of the Work and to communicate to the public those public recitations, by any means or process, including by wire or wireless means or public digital performances; to make available to the public Works in such a way that members of the public may access these Works from a place and at a place individually chosen by them; to perform the Work to the public by any means or process and the communication to the public of the performances of the Work, including by public digital performance; to broadcast and rebroadcast the Work by any means including signs, sounds or images. 24 | 25 | i. "Reproduce" means to make copies of the Work by any means including without limitation by sound or visual recordings and the right of fixation and reproducing fixations of the Work, including storage of a protected performance or phonogram in digital form or other electronic medium. 26 | 27 | 2. FAIR DEALING RIGHTS 28 | 29 | Nothing in this license is intended to reduce, limit, or restrict any uses free from copyright or rights arising from limitations or exceptions that are provided for in connection with the copyright protection under copyright law or other applicable laws. 30 | 31 | 3. LICENSE GRANT 32 | 33 | Subject to the terms and conditions of this license, Licensor hereby grants You a worldwide, royalty-free, non-exclusive, perpetual (for the duration of the applicable copyright) license to exercise the rights in the Work as stated below: 34 | 35 | a. To Reproduce the Work, to incorporate the Work into one or more Collections, and to Reproduce the Work as incorporated in the Collections; 36 | 37 | b. To create and Reproduce Adaptations provided that any such adaptation, including any translation in any medium, takes reasonable steps to clearly label, demarcate or otherwise identify that changes were made to the original Work. For example, a translation could be marked "the original Work was translated from English to Spanish," or a modification could indicate "the original Work has been modified."; 38 | 39 | c. To Distribute and Publicly Perform the Work including as incorporated in Collections; and, 40 | 41 | d. To Distribute and Publicly Perform Adaptations. The above rights may be exercised in all media and formats whether now known or hereafter devised. The above rights include the right to make such modifications as are technically necessary to exercise the rights in other media and formats. Subject to Section 8(f), all rights not expressly granted by Licensor are hereby reserved, including but not limited to the rights set forth in Section 4(f). 42 | 43 | 4. RESTRICTIONS 44 | 45 | The license granted in Section 3 above is expressly made subject to and limited by the following restrictions: 46 | 47 | a. You may distribute or publicly perform the Work only under the terms of this license. You must include a copy of, or the uniform resource identifier (uri) for, this license with every copy of the Work You distribute or publicly perform. You may not offer or impose any terms on the Work that restrict the terms of this license or the ability of the recipient of the Work to exercise the rights granted to that recipient under the terms of the license. You may not sublicense the Work. You must keep intact all notices that refer to this license and to the disclaimer of warranties with every copy of the Work You distribute or publicly perform. When You distribute or publicly perform the Work, You may not impose any effective technological measures on the Work that restrict the ability of a recipient of the Work from You to exercise the rights granted to that recipient under the terms of the license. This Section 4(a) applies to the Work as incorporated in a Collection, but this does not require the Collection apart from the Work itself to be made subject to the terms of this license. If You create a Collection, upon notice from any Licensor You must, to the extent practicable, remove from the Collection any credit as required by Section 4(d), as requested. If You create an adaptation, upon notice from any Licensor You must, to the extent practicable, remove from the adaptation any credit as required by Section 4(d), as requested. 48 | 49 | b. Subject to the exception in Section 4(c), You may not exercise any of the rights granted to You in Section 3 above in any manner that is primarily intended for or directed to ward commercial advantage or private monetary compensation. The exchange of the Work for other copyrighted Works by means of digital filesharing or otherwise shall not be considered to be intended for or directed toward commercial advantage or private monetary compensation, provided there is no payment of any monetary compensation in connection with the exchange of copyrighted Works. 50 | 51 | c. You may exercise the rights granted in Section 3 for commercial purposes only if: 52 | 53 | i. You are a Worker-owned business or Worker-owned collective; and 54 | 55 | ii. All financial gain, surplus, profits and benefits produced by the business or collective are distributed among the Workerowners 56 | 57 | d. Any use by a business that is privately owned and managed, and that seeks to generate profit from the labor of employees paid by salary or other wages, is not permitted under this license. 58 | 59 | e. If You distribute, or publicly perform the Work or any Adaptations or Collections, You must, unless a request has been made pursuant to Section 4(a), keep intact all copyright notices for the Work and provide, reasonable to the medium or means You are utilizing: (i) the name of the Original Author (or pseudonym, if applicable) if supplied, and/or if the Original Author and/or Licensor designate another party or parties (e.g., a sponsor institute, publishing entity, journal) for attribution ("attribution parties") in Licensor's copyright notice, terms of service or by other reasonable means, the name of such party or parties; (ii) the title of the Work if supplied; (iii) to the extent reason ably practicable, the uri, if any, that Licensor specifies to be associated with the Work, unless such uri does not refer to the copyright notice or licensing information for the Work; and, (iv) consistent with Section 3(b), in the case of an adaptation, a credit identifying the use of the Work in the adaptation (e.g., "french translation of the Work by Original Author," or "Screenplay based on original Work by Original Author"). The credit required by this Section 4(d) may be implemented in any reasonable manner; provided, however, that in the case of a adaptation or Collection, at a minimum such credit will appear, if a credit for all contributing authors of the adaptation or Collection appears, then as part of these credits and in a manner at least as prominent as the credits for the other contributing authors. For the avoidance of doubt, You may only use the credit required by this Section for the purpose of attribution in the manner set out above and, by exercising Your rights under this license, You may not implicitly or explicitly assert or imply any connection with, sponsorship or endorsement by the Original Author, Licensor and/or attribution parties, as appropriate, of You or Your use of the Work, without the separate, express prior written permission of the Original Author, Licensor and/or attribution parties. 60 | 61 | f. For the avoidance of doubt: 62 | 63 | i. Non-waivable Compulsory License Schemes. In those jurisdictions in which the right to collect royalties through any statutory or compulsory licensing scheme can not be waived, the Licensor reserves the exclusive right to collect such royalties for any exercise by You of the rights granted under this license; 64 | 65 | ii. Waivable Compulsory License Schemes. In those jurisdictions in which the right to collect royalties through any statutory or compulsory licensing scheme can be waived, the Licensor reserves the exclusive right to collect such royalties for any exercise by You of the rights granted under this license if Your exercise of such rights is for a purpose or use which is otherwise than noncommercial as permitted under Section 4(b) and otherwise waives the right to collect royalties through any statutory or compulsory licensing scheme; and, 66 | 67 | iii. Voluntary License Schemes. The Licensor reserves the right to collect royalties, whether individually or, in the event that the Licensor is a member of a collecting society that administers voluntary licensing schemes, via that society, from any exercise by You of the rights granted under this license that is for a purpose or use which is otherwise than noncommercial as permitted under Section 4(b). 68 | 69 | g. Except as otherwise agreed in writing by the Licensor or as may be otherwise permitted by applicable law, if You Reproduce, distribute or publicly perform the Work either by itself or as part of any Adaptations or Collections, You must not distort, mutilate, modify or take other derogatory action in relation to the Work which would be prejudicial to the Original Author's honor or reputation. Licensor agrees that in those jurisdictions (e.g. Japan), in which any exercise of the right granted in Section 3(b) of this license (the right to make Adaptations) would be deemed to be a distortion, mutilation, modification or other derogatory action prejudicial to the Original Author's honor and reputation, the Licensor will waive or not assert, as appropriate, this Section, to the fullest extent permitted by the applicable national law, to enable You to reasonably exercise Your right under Section 3(b) of this license (right to make Adaptations) but not otherwise. 70 | 71 | 5. REPRESENTATIONS, WARRANTIES AND DISCLAIMER 72 | 73 | UNLESS OTHERWISE MUTUALLY AGREED TO BY THE PARTIES IN WRITING, LICENSOR OFFERS THE WORK AS IS AND MAKES NO REPRESENTATIONS OR WARRANTIES OF ANY KIND CONCERNING THE WORK, EXPRESS, IMPLIED, STATUTORY OR OTHERWISE, INCLUDING, WITHOUT LIMITATION, WARRANTIES OF TITLE, MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, NONINFRINGEMENT, OR THE ABSENCE OF LATENT OR OTHER DEFECTS, ACCURACY, OR THE PRESENCE OF ABSENCE OF ERRORS, WHETHER OR NOT DISCOVERABLE. SOME JURISDICTIONS DO NOT ALLOW THE EXCLUSION OF IMPLIED WARRANTIES, SO SUCH EXCLUSION MAY NOT APPLY TO YOU. 74 | 75 | 6. LIMITATION ON LIABILITY 76 | 77 | EXCEPT TO THE EXTENT REQUIRED BY APPLICABLE LAW, IN NO EVENT WILL LICENSOR BE LIABLE TO YOU ON ANY LEGAL THEORY FOR ANY SPECIAL, INCIDENTAL, CONSEQUENTIAL, PUNITIVE OR EXEMPLARY DAMAGES ARISING OUT OF THIS LICENSE OR THE USE OF THE WORK, EVEN IF LICENSOR HAS BEEN ADVISED OF THE POS SIBILITY OF SUCH DAMAGES. 78 | 79 | 7. TERMINATION 80 | 81 | a. This license and the rights granted hereunder will terminate automatically upon any breach by You of the terms of this license. Individuals or entities who have received Adaptations or Collections from You under this license, however, will not have their licenses terminated provided such individuals or entities remain in full compliance with those licenses. Sections 1, 2, 5, 6, 7, and 8 will survive any termination of this license. 82 | 83 | b. Subject to the above terms and conditions, the license granted here is perpetual (for the duration of the applicable copyright in the Work). Notwithstanding the above, Licensor reserves the right to release the Work under different license terms or to stop distributing the Work at any time; provided, however that any such election will not serve to withdraw this license (or any other license that has been, or is required to be, granted under the terms of this license), and this license will continue in full force and effect unless terminated as stated above. 84 | 85 | 8. MISCELLANEOUS 86 | 87 | a. Each time You distribute or publicly perform the Work or a Collection, the Licensor offers to the recipient a license to the Work on the same terms and conditions as the license granted to You under this license. 88 | 89 | b. Each time You distribute or publicly perform an adaptation, Licensor offers to the recipient a license to the original Work on the same terms and conditions as the license granted to You under this license. 90 | 91 | c. If any provision of this license is invalid or unenforceable under applicable law, it shall not affect the validity or enforceability of the remainder of the terms of this license, and without further action by the parties to this agreement, such provision shall be reformed to the minimum extent necessary to make such provision valid and enforceable. 92 | 93 | d. No term or provision of this license shall be deemed waived and no breach consented to unless such waiver or consent shall be in writing and signed by the party to be charged with such waiver or consent. 94 | 95 | e. This license constitutes the entire agreement between the parties with respect to the Work licensed here. There are no understandings, agreements or representations with respect to the Work not specified here. Licensor shall not be bound by any additional provisions that may appear in any communication from You. This license may not be modified without the mutual written agreement of the Licensor and You. 96 | 97 | f. The rights granted under, and the subject matter referenced, in this license were draft ed utilizing the terminology of the berne convention for the protection of literary and artistic Works (as amended on september 28, 1979), the rome convention of 1961, the wipo copyright treaty of 1996, the wipo performances and phonograms treaty of 1996 and the universal copyright convention (as revised on july 24, 1971). These rights and subject matter take effect in the relevant jurisdiction in which the license terms are sought to be enforced according to the corresponding provisions of the implemen tation of those treaty provisions in the applicable national law. If the standard suite of rights granted under applicable copyright law includes additional rights not granted under this license, such additional rights are deemed to be included in the license; this license is not intended to restrict the license of any rights under applicable law 98 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PREFIX ?= $(HOME)/.idris2 2 | IDRIS2 ?= idris2 3 | 4 | # IDRIS2_SOURCE_PATH = 5 | 6 | MAJOR=0 7 | MINOR=2 8 | PATCH=1 9 | 10 | CFLAGS = -fPIE -Wno-pointer-sign -Wno-discarded-qualifiers 11 | 12 | export IDRIS2_VERSION := ${MAJOR}.${MINOR}.${PATCH} 13 | 14 | .PHONY: all 15 | all: build install-support 16 | 17 | .PHONY: support 18 | support: 19 | cd support/ && cc $(CFLAGS) -O2 -c ocaml_rts.c -I `ocamlc -where` -I ../$(IDRIS2_SOURCE_PATH)/support/c/ 20 | 21 | .PHONY: install-support 22 | install-support: support 23 | mkdir -p ${PREFIX}/idris2-${IDRIS2_VERSION}/support/ocaml 24 | install support/ocaml_rts.o ${PREFIX}/idris2-${IDRIS2_VERSION}/support/ocaml 25 | install support/OcamlRts.ml ${PREFIX}/idris2-${IDRIS2_VERSION}/support/ocaml 26 | 27 | .PHONY: stop-instances 28 | stop-instances: 29 | killall -q scheme || true 30 | killall -q idris2.so || true 31 | killall -q idris2 || true 32 | 33 | .PHONY: build 34 | build: stop-instances 35 | $(IDRIS2) --build idris2-ocaml.ipkg 36 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Idris2-Ocaml 2 | 3 | An OCaml backend for [Idris2](https://github.com/idris-lang/Idris2). 4 | 5 | ## Requirements 6 | 7 | - recent Idris 2 compiler, known to work with 0.2.1-56209de4c 8 | - OCaml, known to work with 4.10.0 9 | - [Zarith](https://github.com/ocaml/Zarith) findable by `ocamlfind` and usable with `ocamlopt` (needs `.cmxa` file, it seems like `*-devel` versions in Linux package managers work fine) 10 | - installed `idris2api` package for the appropriate Idris2 version 11 | 12 | ## Building 13 | 14 | The following command will build the backend and install the support files in the Idris2 "home" directory. Check the [`Makefile`](Makefile) for the location. 15 | 16 | (**NOTE**: I am using VScode and the IDE mode process spawned often causes my RAM to fill and use up swap, so the build command kills all open Idris processes before building) 17 | 18 | ```bash 19 | make IDRIS2_SOURCE_PATH=path/to/idris2/source all 20 | ``` 21 | 22 | The `IDRIS2_SOURCE_PATH` is needed because the runtime C library headers are needed for foreign functions to work. 23 | 24 | ## Attribution 25 | 26 | The files `OcamlRts.ml`, `ocaml_rts.c` are directly taken from the [malfunction backend by ziman and makx](https://github.com/ziman/idris2-mlf). 27 | 28 | The Idris module `Ocaml.Modules` uses some adapted code from the same malfunction backend. 29 | 30 | ## License 31 | 32 | Right now this code is licensed under the [Peer Production License](https://wiki.p2pfoundation.net/Peer_Production_License). 33 | 34 | Eventually when this code is good enough for inclusion in or endorsement by the Idris2 compiler, the license will change to MIT. 35 | -------------------------------------------------------------------------------- /idris2-ocaml.ipkg: -------------------------------------------------------------------------------- 1 | -- SPDX-FileCopyrightText: Thomas Herzog 2 | -- 3 | -- SPDX-License-Identifier: CC0-1.0 4 | 5 | package idris2-ocaml 6 | 7 | depends = idris2, base, contrib, network 8 | 9 | sourcedir = "src" 10 | 11 | --modules = Ocaml.Ocaml 12 | -- , Ocaml.SpecialiseTypes 13 | 14 | main = Ocaml.Ocaml 15 | executable = idris2-ocaml 16 | -------------------------------------------------------------------------------- /repl.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # remove src/ from the path 4 | path=$1 5 | relPath=`echo ${path#src/}` 6 | 7 | cd src && rlwrap idris2 $relPath -p idris2 -p contrib -p network 8 | -------------------------------------------------------------------------------- /src/Ocaml/CompileCommands.idr: -------------------------------------------------------------------------------- 1 | module Ocaml.CompileCommands 2 | 3 | import Utils.Path 4 | 5 | import Data.List 6 | import Data.Maybe 7 | import Data.Strings 8 | 9 | 10 | public export 11 | interface CompilerCommands a where 12 | compileRTSCmd : a -> (name : String) -> List String 13 | compileModuleCmd : a -> (name : String) -> List String 14 | linkCmd : a -> (modules, nativeObjs : List String) -> (rtsName, output : String) -> List String 15 | 16 | export 17 | record NativeOptions where 18 | constructor MkNativeOptions 19 | flags : String 20 | command : String 21 | 22 | export 23 | nativeCompiler : (compilerCmd : Maybe String) -> (debug : Bool) -> NativeOptions 24 | nativeCompiler compilerCmd debug = 25 | let f = if debug then "-g" else "-unsafe -O2" 26 | cmd = fromMaybe "ocamlfind ocamlopt" compilerCmd 27 | in MkNativeOptions f cmd 28 | 29 | 30 | public export 31 | implementation CompilerCommands NativeOptions where 32 | compileRTSCmd o name = 33 | let ml = name <.> "ml" 34 | mli = name <.> "mli" 35 | f = " -I +threads " ++ o.flags ++ " -package zarith" 36 | in [ 37 | o.command ++ f ++ " -w -8 -i " ++ ml ++ " > " ++ mli, 38 | o.command ++ f ++ " -c " ++ mli, 39 | o.command ++ f ++ " -w -8 -c " ++ ml 40 | ] 41 | 42 | compileModuleCmd o name = 43 | [ 44 | o.command ++ " -I +threads " ++ o.flags ++ 45 | " -package zarith -c -w -20-24-26-8 " ++ (name <.> "ml") 46 | ] 47 | 48 | linkCmd o modules nativeObjs rtsName output = [unwords cmdParts] 49 | where 50 | cmdParts : List String 51 | cmdParts = 52 | [ 53 | o.command ++ " -thread -package zarith -linkpkg -nodynlink " ++ o.flags, 54 | unwords nativeObjs ++ " " ++ (rtsName <.> "cmx"), 55 | "-w -20-24-26-8" 56 | ] ++ 57 | [m <.> "cmx" | m <- modules] ++ 58 | ["-o " ++ output] 59 | 60 | 61 | export 62 | record BytecodeOptions where 63 | constructor MkBytecodeOptions 64 | flags : String 65 | command : String 66 | 67 | export 68 | bytecodeCompiler : (compilerCmd : Maybe String) -> (debug : Bool) -> BytecodeOptions 69 | bytecodeCompiler compilerCmd debug = 70 | let f = if debug then "-g" else "" 71 | cmd = fromMaybe "ocamlfind ocamlc" compilerCmd 72 | in MkBytecodeOptions f cmd 73 | 74 | 75 | public export 76 | implementation CompilerCommands BytecodeOptions where 77 | compileRTSCmd o name = 78 | let ml = name <.> "ml" 79 | mli = name <.> "mli" 80 | f = " -I +threads " ++ o.flags ++ " -package zarith" 81 | in [ 82 | o.command ++ f ++ " -w -8 -i " ++ ml ++ " > " ++ mli, 83 | o.command ++ f ++ " -c " ++ mli, 84 | o.command ++ f ++ " -w -8 -c " ++ ml 85 | ] 86 | 87 | compileModuleCmd o name = 88 | [ 89 | o.command ++ " -I +threads " ++ o.flags ++ 90 | " -package zarith -c -w -20-24-26-8 " ++ (name <.> "ml") 91 | ] 92 | 93 | linkCmd o modules nativeObjs rtsName output = [unwords cmdParts] 94 | where 95 | cmdParts : List String 96 | cmdParts = 97 | [ 98 | o.command ++ " -thread -package zarith -linkpkg -custom " ++ o.flags, 99 | (rtsName <.> "cmo"), 100 | "-w -20-24-26-8" 101 | ] ++ 102 | [m <.> "cmo" | m <- modules] ++ 103 | nativeObjs ++ 104 | ["-o " ++ output] 105 | -------------------------------------------------------------------------------- /src/Ocaml/Expr.idr: -------------------------------------------------------------------------------- 1 | ||| Compiling of expressions 2 | ||| 3 | ||| Expressions track their type along with the generated OCaml code. 4 | ||| Because OCaml is a statically typed language and some primitive types in 5 | ||| Idris map nicely to OCaml it makes sense to keep this information around to 6 | ||| only insert the casts that are necessary. 7 | module Ocaml.Expr 8 | 9 | import Compiler.Common 10 | import Compiler.CompileExpr 11 | 12 | import Core.Context 13 | 14 | import Data.List 15 | import Data.Maybe 16 | import Data.NameMap 17 | import Data.Vect 18 | 19 | import Utils.Hex 20 | 21 | import Ocaml.PrimFns 22 | import Ocaml.Utils 23 | import Ocaml.Foreign 24 | 25 | 26 | ocamlKeywords : List String 27 | ocamlKeywords = [ 28 | "and", "as", "asr", "assert", "begin", "class", 29 | "constraint", "do", "done", "downto", "else", "end", 30 | "exception", "external", "false", "for", "fun", "function", 31 | "functor", "if", "in", "include", "inherit", "initializer", "land", 32 | "lazy", "let", "lor", "lsl", "lsr", "lxor", "match", "method", 33 | "mod", "module", "mutable", "new", "nonrec", "object", "of", "open", 34 | -- "open!", This should not be a valid Idris identifier 35 | "or", "private", "rec", "sig", "struct", "then", "to", "true", 36 | "try", "type", "val", "virtual", "when", "while", "with" 37 | ] 38 | 39 | export 40 | mlIdent : String -> String 41 | mlIdent s = 42 | if s `elem` ocamlKeywords 43 | then s ++ "_'" 44 | else concatMap okchar (unpack s) 45 | where 46 | okchar : Char -> String 47 | okchar c = if isAlphaNum c 48 | then cast c 49 | else "_" ++ the (String) (asHex (cast {to=Int} c)) ++ "_" 50 | 51 | export 52 | mlName : Name -> String 53 | mlName (NS ns x) = "ns__" ++ showNSWithSep "'" ns ++ "_" ++ mlName x 54 | mlName (UN x) = "un__" ++ mlIdent x 55 | mlName (MN x y) = "mn__" ++ mlIdent x ++ "_" ++ show y 56 | mlName (PV x y) = "pat__" ++ mlName x ++ "_" ++ show y 57 | mlName (DN x y) = mlName y 58 | mlName (RF n) = "rf__" ++ mlIdent n 59 | mlName (Nested (i, x) n) = "n__" ++ show i ++ "_" ++ show x ++ "_" ++ mlName n 60 | mlName (CaseBlock x y) = "case__" ++ mlIdent x ++ "_" ++ show y 61 | mlName (WithBlock x y) = "with__" ++ mlIdent x ++ "_" ++ show y 62 | mlName (Resolved x) = "fn__" ++ show x 63 | 64 | 65 | mlChar : Char -> String 66 | mlChar c = "\'" ++ (okchar c) ++ "\'" 67 | where 68 | okchar : Char -> String 69 | okchar c = if (c >= ' ') && (c /= '\\') && (c /= '"') && (c /= '\'') && (c <= '~') 70 | then cast c 71 | else case c of 72 | '\0' => "\\x00" 73 | '\'' => "\\'" 74 | '"' => "\\\"" 75 | '\r' => "\\r" 76 | '\n' => "\\n" 77 | '\t' => "\\t" 78 | '\b' => "\\b" 79 | other => "\\x" ++ leftPad '0' 2 (asHex (cast {to=Int} c)) 80 | 81 | mlString : String -> String 82 | mlString s = "\"" ++ (concatMap okchar (unpack s)) ++ "\"" 83 | where 84 | okchar : Char -> String 85 | okchar c = if (c >= ' ') && (c /= '\\') && (c /= '"') && (c /= '\'') && (c <= '~') 86 | then cast c 87 | else case c of 88 | '\0' => "\\0" 89 | '\'' => "\\'" 90 | '"' => "\\\"" 91 | '\r' => "\\r" 92 | '\n' => "\\n" 93 | '\t' => "\\t" 94 | '\b' => "\\b" 95 | other => "\\u{" ++ asHex (cast {to=Int} c) ++ "}" 96 | 97 | 98 | ||| Generate OCaml code for constant values 99 | mlPrimVal : Constant -> Core String 100 | mlPrimVal (I x) = pure . mlRepr $ (show x) 101 | mlPrimVal (BI x) = pure . mlRepr $ fnCall "Z.of_string" [mlString (show x)] 102 | mlPrimVal (B8 x) = pure . mlRepr $ show x 103 | mlPrimVal (B16 x) = pure . mlRepr $ show x 104 | mlPrimVal (B32 x) = pure . mlRepr $ show x 105 | mlPrimVal (B64 x) = pure . mlRepr $ show x ++ "L" 106 | mlPrimVal (Str x) = pure . mlRepr $ mlString x 107 | mlPrimVal (Ch x) = pure . mlRepr $ mlChar x 108 | mlPrimVal (Db x) = pure . mlRepr $ show x 109 | mlPrimVal WorldVal = pure $ mlRepr "()" 110 | mlPrimVal val = throw . InternalError $ "Unsupported primitive value: " ++ show val 111 | 112 | ||| Generate patterns for constant values 113 | ||| 114 | ||| Patterns can differ from "value" expressions for some types. 115 | ||| The type is also tracked so that the expression to be matched on can be 116 | ||| casted accordingly. 117 | mlPrimValPattern : Constant -> Core String 118 | mlPrimValPattern (I x) = pure (show x) 119 | mlPrimValPattern (BI x) = pure (mlString (show x)) 120 | mlPrimValPattern (B8 x) = pure (show x) 121 | mlPrimValPattern (B16 x) = pure (show x) 122 | mlPrimValPattern (B32 x) = pure (show x) 123 | mlPrimValPattern (B64 x) = pure (show x ++ "L") 124 | mlPrimValPattern (Str x) = pure (mlString x) 125 | mlPrimValPattern (Ch x) = pure (mlChar x) 126 | mlPrimValPattern (Db x) = pure (show x) 127 | mlPrimValPattern WorldVal = pure ("()") 128 | mlPrimValPattern val = throw . InternalError $ "Unsupported primitive in pattern: " ++ show val 129 | 130 | 131 | mlBlock : (tag : Int) -> (args : List String) -> String 132 | mlBlock tag args = 133 | let numArgs = length args 134 | block = "let block = Obj.new_block " ++ show tag ++ " " ++ show numArgs ++ " in " 135 | fieldSets = flap ([0..numArgs] `zip` args) \(i, arg) => 136 | "Obj.set_field block " ++ show i ++ " " ++ arg ++ ";" 137 | in "(" ++ block ++ showSep " " fieldSets ++ " block)" 138 | 139 | 140 | mutual 141 | 142 | ||| Generate code for an expression 143 | export 144 | mlExpr : NamedCExp -> Core String 145 | mlExpr (NmLocal fc name) = pure $ mlName name 146 | mlExpr (NmRef fc name) = pure $ mlName name 147 | mlExpr (NmLam fc name rhs) = do 148 | let name' = mlName name 149 | rhs' <- mlExpr rhs 150 | 151 | pure . mlRepr . parens $ "fun (" ++ name' ++ " : Obj.t) : Obj.t -> " ++ rhs' 152 | 153 | mlExpr (NmLet fc name rhs expr) = do 154 | rhs' <- mlExpr rhs 155 | expr' <- mlExpr expr 156 | 157 | let header = "let " ++ mlName name ++ " : Obj.t = " ++ rhs' ++ " in " 158 | let src = header ++ expr' 159 | pure $ parens src 160 | 161 | mlExpr (NmApp fc (NmRef _ name) []) = pure $ fnCall "Lazy.force" [mlName name] 162 | mlExpr (NmApp fc (NmRef _ name) args) = do 163 | args' <- traverse mlExpr args 164 | pure $ fnCall (mlName name) args' 165 | 166 | mlExpr (NmApp fc base []) = do 167 | base' <- mlExpr base 168 | pure $ fnCall "Lazy.force" [fnCall "as_lazy" [base']] 169 | 170 | mlExpr (NmApp fc base args) = do 171 | base' <- mlExpr base 172 | args' <- traverse mlExpr args 173 | let call = fnCall (fnCall "Obj.magic" [base']) args' 174 | pure $ call 175 | 176 | mlExpr (NmCon fc name Nothing args) = do 177 | let name' = mlRepr . mlString $ show name 178 | args' <- traverse mlExpr args 179 | 180 | pure $ mlBlock 0 (name' :: args') 181 | 182 | mlExpr (NmCon fc name (Just tag) []) = pure . mlRepr $ show tag 183 | mlExpr (NmCon fc name (Just tag) args) = do 184 | args' <- traverse mlExpr args 185 | pure $ mlBlock tag args' 186 | 187 | mlExpr (NmOp fc fn args) = do 188 | args' <- traverse mlExpr args 189 | mlPrimFn fn args' 190 | 191 | mlExpr (NmExtPrim fc name args) = do 192 | args' <- traverse mlExpr args 193 | case !(exPrim name args') of 194 | Just exp => pure exp 195 | 196 | Nothing => do 197 | coreLift $ putStrLn $ "Unimplemented ExtPrim!" 198 | coreLift $ putStrLn $ "ExtPrim: " ++ show name 199 | coreLift $ putStrLn $ " args: " ++ show args 200 | pure $ mlRepr "()" 201 | 202 | mlExpr (NmForce fc expr) = do 203 | expr' <- mlExpr expr 204 | pure $ fnCall "Lazy.force" [fnCall "as_lazy" [expr']] 205 | 206 | mlExpr (NmDelay fc expr) = do 207 | expr' <- mlExpr expr 208 | pure . mlRepr $ fnCall "lazy" [expr'] 209 | 210 | mlExpr (NmConCase fc expr alts def) = do 211 | 212 | expr' <- mlExpr expr 213 | let matchVal = "let match_val' : Obj.t = " ++ expr' ++ " in " 214 | 215 | def' <- the (Core String) $ case def of 216 | Nothing => pure "" 217 | Just e => do 218 | e' <- mlExpr e 219 | pure $ "| _ -> " ++ e' 220 | 221 | let (matchEx, pats, fieldOffset) = case alts of 222 | (MkNConAlt name Nothing _ _)::_ => 223 | let matchEx = fnCall "as_string" [fnCall "Obj.field" ["match_val'", "0"]] in 224 | let pats = flap alts \(MkNConAlt name _ _ _) => mlString (show name) in 225 | (matchEx, pats, the Nat 1) 226 | _ => 227 | let matchEx = fnCall "get_tag" ["match_val'"] in 228 | let pats = flap alts \(MkNConAlt _ tag _ _) => show $ fromMaybe 0 tag in 229 | (matchEx, pats, the Nat 0) 230 | 231 | let header = "match " ++ matchEx ++ " with " 232 | 233 | arms <- for (pats `zip` alts) \(pat, MkNConAlt name tag names e) => do 234 | 235 | let numNames = length names 236 | 237 | let binders = flap ([0..numNames] `zip` names) \(i, name) => 238 | "let " ++ mlName name ++ " : Obj.t = " 239 | ++ fnCall "Obj.field" ["match_val'", show (i + fieldOffset)] ++ " in " 240 | 241 | e' <- mlExpr e 242 | 243 | pure $ "| " ++ pat ++ " -> " ++ concat binders ++ parens e' 244 | 245 | pure . parens $ matchVal ++ header ++ showSep " " arms ++ def' 246 | 247 | mlExpr (NmConstCase fc expr alts def) = do 248 | let isBigInt = case alts of 249 | MkNConstAlt (BI _) _ :: _ => True 250 | _ => False 251 | 252 | let matchExpr = fnCall "Obj.obj" [!(mlExpr expr)] 253 | let matchExpr' = if isBigInt 254 | then fnCall "Z.to_string" [matchExpr] 255 | else matchExpr 256 | 257 | let header = "match " ++ matchExpr' ++ " with " 258 | 259 | def' <- case def of 260 | Nothing => pure "" 261 | Just e => do 262 | e' <- mlExpr e 263 | pure $ "| _ -> " ++ e' 264 | 265 | arms <- for alts \(MkNConstAlt c exp) => do 266 | pat <- mlPrimValPattern c 267 | exp' <- mlExpr exp 268 | pure $ "| " ++ pat ++ " -> (" ++ exp' ++ ")" 269 | 270 | pure $ "(" ++ header ++ showSep " " arms ++ def' ++ ")" 271 | 272 | mlExpr (NmPrimVal fc const) = mlPrimVal const 273 | mlExpr (NmErased fc) = pure $ mlRepr "()" 274 | mlExpr (NmCrash fc msg) = 275 | pure $ fnCall "raise" [fnCall "Idris2_Exception" [mlString msg]] 276 | 277 | ||| Generate code for external functions 278 | exPrim : Name -> 279 | List String -> 280 | Core (Maybe String) 281 | exPrim name args = 282 | case (show name, args) of 283 | ("System.Info.prim__codegen", []) => pure . Just $ mlString "ocaml" 284 | ("System.Info.prim__os", []) => do 285 | let call = fnCall "OcamlRts.System.os_name" ["(Obj.magic ())"] 286 | pure . Just $ mlRepr call 287 | 288 | -- IORef 289 | ("Data.IORef.prim__newIORef", [_, val, world]) => do 290 | pure . Just . mlRepr $ fnCall "ref" [val] 291 | 292 | ("Data.IORef.prim__writeIORef", [_, ref, val, world]) => do 293 | let ref' = fnCall "as_ref" [ref] 294 | let src = "(" ++ ref' ++ " := " ++ val ++ "; Obj.repr ())"; 295 | pure $ Just src 296 | 297 | ("Data.IORef.prim__readIORef", [_, ref, world]) => do 298 | let ref' = fnCall "as_ref" [ref] 299 | let src = mlRepr $ "(!" ++ ref' ++ ")" 300 | pure $ Just src 301 | 302 | -- IOArray 303 | ("Data.IOArray.Prims.prim__newArray", [_, len, val, world]) => do 304 | let src = fnCall "Array.make" [asInt len, val] 305 | pure . Just . mlRepr $ src 306 | 307 | ("Data.IOArray.Prims.prim__arraySet", [_, arr, idx, val, world]) => do 308 | let call = fnCall "Array.set" [fnCall "as_array" [arr], asInt idx, val] 309 | pure . Just $ "(" ++ call ++ "; Obj.repr ())" 310 | 311 | ("Data.IOArray.Prims.prim__arrayGet", [_, arr, idx, world]) => do 312 | let call = fnCall "Array.get" [fnCall "as_array" [arr], asInt idx] 313 | pure . Just . mlRepr $ call 314 | 315 | ("Prelude.Uninhabited.void", [_, _]) => do 316 | pure . Just . mlRepr $ "()" 317 | 318 | _ => pure Nothing 319 | -------------------------------------------------------------------------------- /src/Ocaml/Foreign.idr: -------------------------------------------------------------------------------- 1 | ||| Foreign function definitions 2 | ||| 3 | ||| These are hardcoded and matched against the name for now. 4 | ||| If this backend ever gets included in the compiler then all those 5 | ||| mappings can be added to the functions in `libs/` instead. 6 | module Ocaml.Foreign 7 | 8 | import Compiler.Common 9 | import Compiler.CompileExpr 10 | 11 | import Core.Context 12 | 13 | import Debug.Trace 14 | 15 | import Data.NameMap 16 | import Data.Vect 17 | import Data.List 18 | import Data.List1 19 | import Data.Strings 20 | 21 | idrisSupport : String -> String 22 | idrisSupport s = "OcamlRts.C.Lib_libidris2_support." ++ s 23 | 24 | systemFn : String -> String 25 | systemFn s = "OcamlRts.System." ++ s 26 | 27 | implNames : List (String, String) 28 | implNames = [ 29 | ("Data.Strings.fastConcat", "OcamlRts.Bytes.concat"), 30 | ("Prelude.Types.fastPack", "OcamlRts.String.pack"), 31 | 32 | ("Data.Buffer.prim__newBuffer", idrisSupport "idris2_newBuffer"), 33 | ("Data.Buffer.prim__bufferSize", idrisSupport "idris2_getBufferSize"), 34 | ("Data.Buffer.prim__copyData", idrisSupport "idris2_copyBuffer"), 35 | ("Data.Buffer.prim__getByte", idrisSupport "idris2_getBufferByte"), 36 | ("Data.Buffer.prim__getDouble", idrisSupport "idris2_getBufferDouble"), 37 | ("Data.Buffer.prim__getInt", idrisSupport "idris2_getBufferInt"), 38 | ("Data.Buffer.prim__getBits8", idrisSupport "idris2_getBufferBits8"), 39 | ("Data.Buffer.prim__getBits16", idrisSupport "idris2_getBufferBits16"), 40 | ("Data.Buffer.prim__getBits32", idrisSupport "idris2_getBufferBits32"), 41 | ("Data.Buffer.prim__getBits64", idrisSupport "idris2_getBufferBits64"), 42 | ("Data.Buffer.prim__getString", idrisSupport "idris2_getBufferString"), 43 | ("Data.Buffer.prim__setByte", idrisSupport "idris2_setBufferByte"), 44 | ("Data.Buffer.prim__setDouble", idrisSupport "idris2_setBufferDouble"), 45 | ("Data.Buffer.prim__setInt", idrisSupport "idris2_setBufferInt"), 46 | ("Data.Buffer.prim__setBits8", idrisSupport "idris2_setBufferBits8"), 47 | ("Data.Buffer.prim__setBits16", idrisSupport "idris2_setBufferBits16"), 48 | ("Data.Buffer.prim__setBits32", idrisSupport "idris2_setBufferBits32"), 49 | ("Data.Buffer.prim__setBits64", idrisSupport "idris2_setBufferBits64"), 50 | ("Data.Buffer.prim__setString", idrisSupport "idris2_setBufferString"), 51 | 52 | ("System.Clock.prim__clockTimeGcCpu", systemFn "clocktime_gc_cpu"), 53 | ("System.Clock.prim__clockTimeGcReal", systemFn "clocktime_gc_real"), 54 | ("System.Clock.prim__clockTimeMonotonic", systemFn "clocktime_monotonic"), 55 | ("System.Clock.prim__clockTimeProcess", systemFn "clocktime_process"), 56 | ("System.Clock.prim__clockTimeThread", systemFn "clocktime_thread"), 57 | ("System.Clock.prim__clockTimeUtc", systemFn "clocktime_utc"), 58 | ("System.Clock.prim__osClockNanosecond", systemFn "os_clock_nanosecond"), 59 | ("System.Clock.prim__osClockSecond", systemFn "os_clock_second"), 60 | ("System.Clock.prim__osClockValid", systemFn "os_clock_valid"), 61 | 62 | ("System.prim__getArgs", systemFn "get_args") 63 | ] 64 | 65 | ccLibFun : List String -> Maybe String 66 | ccLibFun [] = Nothing 67 | ccLibFun (cc :: ccs) = 68 | if substr 0 3 cc == "ML:" 69 | then Just (substr 3 (length cc) cc) 70 | else if substr 0 2 cc == "C:" 71 | then case split (== ',') (substr 2 (length cc) cc) of 72 | fn ::: [libn] => Just ("OcamlRts.C.Lib_" ++ rmSpaces libn ++ "." ++ fn) 73 | _ => ccLibFun ccs -- something strange -> skip 74 | else ccLibFun ccs -- search further 75 | where 76 | rmSpaces : String -> String 77 | rmSpaces = pack . filter (/= ' ') . unpack 78 | 79 | 80 | 81 | export 82 | foreignFun : Name -> List String -> List CFType -> CFType -> String 83 | foreignFun name ccs args ret = 84 | case ccLibFun ccs of 85 | Just name => name 86 | Nothing => case lookup (show name) implNames of 87 | Just fn => fn 88 | Nothing => 89 | let msg = "Unsupported foreign function " ++ show name ++ " : " ++ show args ++ " -> " ++ show ret ++ " | ccs : " ++ show ccs in 90 | let src = "raise (Idris2_Exception \"Unsupported foreign function " ++ show name ++ " : " ++ show args ++ " -> " ++ show ret ++ "\")" 91 | in trace msg src 92 | -------------------------------------------------------------------------------- /src/Ocaml/Modules.idr: -------------------------------------------------------------------------------- 1 | module Ocaml.Modules 2 | 3 | import Compiler.Common 4 | import Compiler.CompileExpr 5 | 6 | import Core.TT 7 | 8 | import Data.List 9 | import Data.Strings 10 | import Data.StringMap 11 | import Data.NameMap 12 | import Data.SortedSet 13 | import Data.Vect 14 | 15 | import Ocaml.Utils 16 | 17 | 18 | splitByNamespace : List (Name, NamedDef) -> List (String, List (Name, NamedDef)) 19 | splitByNamespace = StringMap.toList . foldl addOne StringMap.empty 20 | where 21 | addOne : StringMap (List (Name, NamedDef)) -> 22 | (Name, NamedDef) -> 23 | StringMap (List (Name, NamedDef)) 24 | addOne nss def@(n, nd) = 25 | StringMap.mergeWith 26 | (++) 27 | (StringMap.singleton (namespace' n) [def]) 28 | nss 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | -- forward declaration 37 | tarjan : StringMap (SortedSet String) -> List (List String) 38 | findExpr : NamedCExp -> SortedSet String 39 | 40 | nsDef : NamedDef -> SortedSet String 41 | nsDef (MkNmFun _ rhs) = findExpr rhs 42 | nsDef (MkNmCon _ _ _) = SortedSet.empty 43 | nsDef (MkNmForeign ccs fargs rty) = SortedSet.empty 44 | nsDef (MkNmError rhs) = findExpr rhs 45 | 46 | ||| Information about module splitting 47 | ||| 48 | ||| Generally one module = one namespace, but modules can contain inline 49 | ||| namespaces, in which case there are more namespaces than modules, creating 50 | ||| possibly mutually recursive namespaces. 51 | ||| 52 | ||| One namespace of the group will be "elected" to be the identifier for the 53 | ||| group. 54 | public export 55 | record ModulesInfo where 56 | constructor MkModulesInfo 57 | components : List (List String) 58 | namespaceMapping : StringMap String 59 | defsByNamespace : StringMap (List (Name, NamedDef)) 60 | dependencies : StringMap (SortedSet String) 61 | 62 | total 63 | export 64 | moduleGroupIdentifier : (l : List String) -> NonEmpty l => String 65 | moduleGroupIdentifier (n::ns) = (foldl min n ns) 66 | 67 | export 68 | modules : List (Name, NamedDef) -> ModulesInfo 69 | modules defs = 70 | let 71 | defsByNS = StringMap.fromList $ splitByNamespace defs 72 | defDepsRaw = [StringMap.singleton (namespace' n) (SortedSet.delete (namespace' n) (nsDef d)) | (n, d) <- defs] 73 | defDeps = foldl (StringMap.mergeWith SortedSet.union) StringMap.empty defDepsRaw 74 | components = reverse $ tarjan defDeps -- tarjan generates reverse toposort 75 | nsMapping = foldl 76 | (\nm, modNames => case modNames of 77 | [] => nm 78 | mn::mns => 79 | let mlMod = moduleGroupIdentifier (mn::mns) 80 | in foldl (\nm, modName => StringMap.insert modName mlMod nm) 81 | nm 82 | modNames 83 | ) 84 | StringMap.empty 85 | components 86 | in MkModulesInfo components nsMapping defsByNS defDeps 87 | 88 | 89 | public export 90 | record Module where 91 | constructor MkModule 92 | name : String 93 | defs : List (Name, NamedDef) 94 | deps : SortedSet String 95 | 96 | export 97 | moduleDefs : ModulesInfo -> List Module 98 | moduleDefs info = flip concatMap info.components $ \mnames => case mnames of 99 | [] => [] 100 | n::ns => 101 | let 102 | groupId = moduleGroupIdentifier (n::ns) 103 | defs = concatMap 104 | (\mname => 105 | fromMaybe 106 | [] 107 | (StringMap.lookup mname info.defsByNamespace) 108 | ) 109 | mnames 110 | deps = foldl 111 | (\acc,name => 112 | let currDeps = fromMaybe SortedSet.empty $ StringMap.lookup name info.dependencies 113 | resolved = flip map (SortedSet.toList currDeps) $ \n => 114 | fromMaybe n $ StringMap.lookup n info.namespaceMapping 115 | in SortedSet.union 116 | (SortedSet.fromList resolved) 117 | acc 118 | ) 119 | SortedSet.empty 120 | mnames 121 | deps' = SortedSet.delete groupId deps 122 | in [MkModule groupId defs deps'] 123 | 124 | 125 | 126 | 127 | 128 | 129 | -- https://en.wikipedia.org/wiki/Tarjan%27s_strongly_connected_components_algorithm#The_algorithm_in_pseudocode 130 | record TarjanVertex where 131 | constructor TV 132 | index : Int 133 | lowlink : Int 134 | inStack : Bool 135 | 136 | record TarjanState where 137 | constructor TS 138 | vertices : StringMap TarjanVertex 139 | stack : List String 140 | nextIndex : Int 141 | components : List (List String) 142 | impossibleHappened : Bool 143 | 144 | tarjan deps = loop initialState (StringMap.keys deps) 145 | where 146 | initialState : TarjanState 147 | initialState = 148 | TS 149 | StringMap.empty 150 | [] 151 | 0 152 | [] 153 | False 154 | 155 | strongConnect : TarjanState -> String -> TarjanState 156 | strongConnect ts v = 157 | let ts'' = case StringMap.lookup v deps of 158 | Nothing => ts' -- no edges 159 | Just edgeSet => loop ts' (SortedSet.toList edgeSet) 160 | in case StringMap.lookup v ts''.vertices of 161 | Nothing => record { impossibleHappened = True } ts'' 162 | Just vtv => 163 | if vtv.index == vtv.lowlink 164 | then createComponent ts'' v [] 165 | else ts'' 166 | where 167 | createComponent : TarjanState -> String -> List String -> TarjanState 168 | createComponent ts v acc = 169 | case ts.stack of 170 | [] => record { impossibleHappened = True } ts 171 | w :: ws => 172 | let ts' = record { 173 | vertices $= adjust w record{ inStack = False }, 174 | stack = ws 175 | } ts 176 | in if w == v 177 | then record { components $= ((v :: acc) ::) } ts' -- that's it 178 | else createComponent ts' v (w :: acc) 179 | 180 | loop : TarjanState -> List String -> TarjanState 181 | loop ts [] = ts 182 | loop ts (w :: ws) = 183 | loop ( 184 | case StringMap.lookup w ts.vertices of 185 | Nothing => let ts' = strongConnect ts w in 186 | case StringMap.lookup w ts'.vertices of 187 | Nothing => record { impossibleHappened = True } ts' 188 | Just wtv => 189 | record { 190 | vertices $= adjust v record { 191 | lowlink $= min wtv.lowlink 192 | } 193 | } ts' 194 | 195 | Just wtv => case wtv.inStack of 196 | False => ts -- nothing to do 197 | True => 198 | record { 199 | vertices $= adjust v record { 200 | lowlink $= min wtv.index 201 | } 202 | } ts 203 | ) ws 204 | 205 | ts' : TarjanState 206 | ts' = record { 207 | vertices $= StringMap.insert v (TV ts.nextIndex ts.nextIndex True), 208 | stack $= (v ::), 209 | nextIndex $= (1+) 210 | }ts 211 | 212 | loop : TarjanState -> List String -> List (List String) 213 | loop ts [] = 214 | if ts.impossibleHappened 215 | then [] 216 | else ts.components 217 | loop ts (v :: vs) = 218 | case StringMap.lookup v ts.vertices of 219 | Just _ => loop ts vs -- done, skip 220 | Nothing => loop (strongConnect ts v) vs 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 | 229 | -- find references to other namespaces 230 | 231 | mutual 232 | findExpr (NmLocal fc x) = SortedSet.empty 233 | findExpr (NmRef fc x) = SortedSet.insert (namespace' x) SortedSet.empty 234 | findExpr (NmLam fc x expr) = findExpr expr 235 | findExpr (NmLet fc x rhs expr) = findExpr rhs <+> findExpr expr 236 | findExpr (NmApp fc base args) = findExpr base <+> concatMap findExpr args 237 | findExpr (NmCon fc name tag args) = concatMap findExpr args 238 | findExpr (NmOp fc fn args) = concatMap findExpr args 239 | findExpr (NmExtPrim fc name args) = concatMap findExpr args 240 | findExpr (NmForce fc expr) = findExpr expr 241 | findExpr (NmDelay fc expr) = findExpr expr 242 | findExpr (NmConCase fc expr alts def) = findExpr expr <+> concatMap findConAlt alts <+> concatMap findExpr def 243 | findExpr (NmConstCase fc expr alts def) = findExpr expr <+> concatMap findConstAlt alts <+> concatMap findExpr def 244 | findExpr (NmPrimVal fc val) = SortedSet.empty 245 | findExpr (NmErased fc) = SortedSet.empty 246 | findExpr (NmCrash fc x) = SortedSet.empty 247 | 248 | findConAlt : NamedConAlt -> SortedSet String 249 | findConAlt (MkNConAlt _ _ _ rhs) = findExpr rhs 250 | 251 | findConstAlt : NamedConstAlt -> SortedSet String 252 | findConstAlt (MkNConstAlt _ rhs) = findExpr rhs 253 | -------------------------------------------------------------------------------- /src/Ocaml/Ocaml.idr: -------------------------------------------------------------------------------- 1 | module Ocaml.Ocaml 2 | 3 | import Idris.Driver 4 | 5 | import Compiler.Common 6 | import Compiler.CompileExpr 7 | 8 | import Core.Context 9 | import Core.Context.Log as Log 10 | import Core.Directory 11 | 12 | import Utils.Path 13 | 14 | import Data.List 15 | import Data.Strings 16 | import Data.StringMap 17 | import Data.SortedSet 18 | import Data.NameMap 19 | import Data.Maybe 20 | import Data.Vect 21 | 22 | import System 23 | import System.Directory 24 | import System.File 25 | import System.Info 26 | 27 | 28 | import Ocaml.Expr 29 | import Ocaml.Foreign 30 | import Ocaml.Utils 31 | import Ocaml.Modules 32 | import Ocaml.CompileCommands 33 | 34 | 35 | ||| Generate OCaml code for a "definition" (function, constructor, foreign func, etc) 36 | mlDef : Name -> 37 | NamedDef -> 38 | Core String 39 | mlDef name (MkNmFun [] expr) = do 40 | let header = mlName name ++ " : Obj.t lazy_t = lazy (" 41 | code <- mlExpr expr 42 | pure $ header ++ code ++ ")\n\n" 43 | 44 | mlDef name (MkNmFun args expr) = do 45 | 46 | let argDecls = showSep " " $ map (\n => "(" ++ mlName n ++ " : Obj.t)") args 47 | header = mlName name ++ " " ++ argDecls ++ " : Obj.t = " 48 | 49 | code <- mlExpr expr 50 | pure $ header ++ code ++ "\n\n" 51 | 52 | mlDef name (MkNmCon _ _ _) = pure "" 53 | mlDef name (MkNmForeign ccs [] retTy) = do 54 | let header = mlName name ++ " () : Obj.t = " 55 | let callArgs = ["(Obj.magic ())"] 56 | let fun = foreignFun name ccs [] retTy 57 | let call = fun ++ " " ++ showSep " " callArgs 58 | 59 | pure $ header ++ "(Obj.magic (" ++ call ++ "))\n\n" 60 | 61 | mlDef name (MkNmForeign ccs argTys retTy) = do 62 | 63 | let args = flap ([1..(length argTys)] `zip` argTys) \(i, t) => 64 | let isWorld = case t of 65 | CFWorld => True 66 | _ => False 67 | in ("arg_" ++ show i, isWorld) 68 | 69 | let nonWorldArgs' = filter (\(_, isWorld) => not isWorld) args 70 | let nonWorldArgs = if isNil nonWorldArgs' then [("()", False)] else nonWorldArgs' 71 | 72 | let argDecls = showSep " " $ map (\(n,_) => "(" ++ n ++ " : Obj.t)") args 73 | let header = mlName name ++ " " ++ argDecls ++ " : Obj.t = " 74 | 75 | let callArgs = flap nonWorldArgs \(n,_) => "(Obj.magic " ++ n ++ ")" 76 | let fun = foreignFun name ccs argTys retTy 77 | let call = fun ++ " " ++ showSep " " callArgs 78 | 79 | pure $ header ++ "(Obj.magic (" ++ call ++ "))\n\n" 80 | 81 | mlDef name (MkNmError msg) = do 82 | let header = mlName name ++ " () : Obj.t = " 83 | body <- mlExpr msg 84 | pure $ header ++ body ++ "\n\n" 85 | 86 | writeModule : (path : String) -> (mod : Module) -> Core () 87 | writeModule path mod = do 88 | 89 | Right mlFile <- coreLift $ openFile path WriteTruncate 90 | | Left err => throw (FileErr path err) 91 | 92 | let append = \strData => Core.Core.do 93 | Right () <- coreLift $ fPutStr mlFile strData 94 | | Left err => throw (FileErr path err) 95 | coreLift $ fflush mlFile 96 | 97 | let imports = concatMap (++";;\n") $ map ("open "++) (SortedSet.toList mod.deps) 98 | 99 | append $ "open OcamlRts;;\n\n" ++ 100 | imports ++ "\nlet rec " 101 | 102 | first <- coreLift $ newIORef True 103 | defsWritten <- coreLift $ newIORef (the Int 0) 104 | for_ mod.defs \(n, d) => do 105 | def <- mlDef n d 106 | if def == "" 107 | then pure () 108 | else do 109 | isFirst <- coreLift $ readIORef first 110 | if isFirst 111 | then coreLift $ writeIORef first False 112 | else append "and " 113 | append def 114 | coreLift $ modifyIORef defsWritten (+1) 115 | 116 | append ";;" 117 | 118 | coreLift $ closeFile mlFile 119 | 120 | if !(coreLift $ readIORef defsWritten) == 0 121 | then do 122 | _ <- coreLift $ writeFile path "" 123 | pure () 124 | else pure () 125 | 126 | pure () 127 | 128 | 129 | ||| OCaml implementation of the `compileExpr` interface. 130 | compileExpr : CompilerCommands c => (comp : c) -> 131 | Ref Ctxt Defs -> 132 | (tmpDir : String) -> 133 | (outputDir : String) -> 134 | ClosedTerm -> 135 | (outfile : String) -> 136 | Core (Maybe String) 137 | compileExpr comp c tmpDir outputDir tm outfile = do 138 | let appDirRel = outfile ++ "_app" -- relative to build dir 139 | let appDirGen = outputDir appDirRel -- relative to here 140 | coreLift $ mkdirAll appDirGen 141 | Just cwd <- coreLift currentDir 142 | | Nothing => throw (InternalError "Can't get current directory") 143 | 144 | let ext = if isWindows then ".exe" else "" 145 | let outFile = cwd outputDir outfile <.> ext 146 | 147 | let modRelFileName = \ns,ext => appDirRel ns <.> ext 148 | let modAbsFileName = \ns,ext => cwd outputDir modRelFileName ns ext 149 | 150 | cData <- getCompileData Cases tm 151 | let ndefs = flap (namedDefs cData) \(name, _, def) => (name, def) 152 | let mainExpr = forget (mainExpr cData) 153 | 154 | ctxtDefs <- get Ctxt 155 | let context = gamma ctxtDefs 156 | 157 | let mods = modules ndefs 158 | 159 | modules <- for (moduleDefs mods) $ \mod => do 160 | let modName = mod.name 161 | let path = modAbsFileName modName "ml" 162 | writeModule path mod 163 | pure modName 164 | 165 | -- deal with Main function 166 | do 167 | -- main takes ALL modules as dependencies 168 | let mainImports = flap (StringMap.keys mods.defsByNamespace) $ \n => 169 | fromMaybe n $ StringMap.lookup n mods.namespaceMapping 170 | 171 | let mainFnName = UN "main" 172 | let mainDefs = [(mainFnName, MkNmFun [] mainExpr)] 173 | let mainMLPath = modAbsFileName "Main" "ml" 174 | let mainModule = MkModule "Main" mainDefs (SortedSet.fromList mainImports) 175 | 176 | writeModule mainMLPath mainModule 177 | 178 | -- still needs the actual call to the main function Main.main 179 | let mainCallSrc = "\n\nLazy.force (" ++ mlName mainFnName ++ ");;\n\n" 180 | 181 | Right mainMLFile <- coreLift $ openFile mainMLPath Append 182 | | Left err => throw (FileErr mainMLPath err) 183 | 184 | Right () <- coreLift $ fPutStr mainMLFile mainCallSrc 185 | | Left err => throw (FileErr mainMLPath err) 186 | 187 | coreLift $ closeFile mainMLFile 188 | 189 | -- TMP HACK 190 | -- .a and .h files 191 | coreLift $ system $ unwords 192 | ["cp", "~/.idris2/idris2-0.2.1/lib/*", appDirGen] 193 | 194 | coreLift $ system $ "cp ~/.idris2/idris2-0.2.1/support/ocaml/ocaml_rts.o " ++ appDirGen 195 | coreLift $ system $ "cp ~/.idris2/idris2-0.2.1/support/ocaml/OcamlRts.ml " ++ appDirGen 196 | 197 | let cmdBuildRts = compileRTSCmd comp "OcamlRts" 198 | cmdBuildMods = concat $ [compileModuleCmd comp ns | ns <- modules] 199 | ++ [compileModuleCmd comp "Main"] 200 | cmdLink = linkCmd comp 201 | (modules ++ ["Main"]) 202 | ["ocaml_rts.o", "libidris2_support.a"] 203 | "OcamlRts" 204 | outFile 205 | 206 | cmdFull = cmdBuildRts ++ cmdBuildMods ++ cmdLink 207 | 208 | for_ cmdFull $ \cmd => do 209 | let cmd' = "cd " ++ appDirGen ++ " && " ++ cmd 210 | ok <- the (Core Int) . coreLift $ system cmd' 211 | Log.log "codegen.ocaml.build" 2 $ "Running command `" ++ cmd ++ "`" 212 | if ok /= 0 213 | then throw . InternalError $ "Command `" ++ cmd ++ "` failed." 214 | else pure () 215 | 216 | pure (Just outFile) 217 | 218 | ||| OCaml implementation of the `executeExpr` interface. 219 | executeExpr : CompilerCommands c => (comp : c) -> 220 | Ref Ctxt Defs -> 221 | (tmpDir : String) -> 222 | ClosedTerm -> 223 | Core () 224 | executeExpr comp c tmpDir tm = do 225 | Just bin <- compileExpr comp c tmpDir tmpDir tm "tmpocaml" 226 | | Nothing => throw (InternalError "compileExpr returned Nothing") 227 | coreLift $ system bin 228 | pure () 229 | 230 | export 231 | codegenOcaml : CompilerCommands c => (comp : c) -> Codegen 232 | codegenOcaml comp = MkCG (compileExpr comp) (executeExpr comp) 233 | 234 | main : IO () 235 | main = 236 | mainWithCodegens [ 237 | ("ocaml-native", codegenOcaml $ nativeCompiler Nothing False), 238 | ("ocaml-native-debug", codegenOcaml $ nativeCompiler Nothing True), 239 | ("ocaml-bytecode", codegenOcaml $ bytecodeCompiler Nothing False), 240 | ("ocaml-bytecode-debug", codegenOcaml $ bytecodeCompiler Nothing True) 241 | ] 242 | -------------------------------------------------------------------------------- /src/Ocaml/PrimFns.idr: -------------------------------------------------------------------------------- 1 | ||| Code generation for primitive functions 2 | module Ocaml.PrimFns 3 | 4 | import Compiler.Common 5 | import Compiler.CompileExpr 6 | 7 | import Core.Context 8 | 9 | import Data.Vect 10 | 11 | import Ocaml.Utils 12 | 13 | bits8Bound : String -> String 14 | bits8Bound s = fnCall "ensure_bits8" [s] 15 | 16 | bits16Bound : String -> String 17 | bits16Bound s = fnCall "ensure_bits16" [s] 18 | 19 | bits32Bound : String -> String 20 | bits32Bound s = fnCall "ensure_bits32" [s] 21 | 22 | 23 | castFnForTy : Constant -> Core (String -> String) 24 | castFnForTy IntType = pure asInt 25 | castFnForTy IntegerType = pure asBint 26 | castFnForTy Bits8Type = pure asBits8 27 | castFnForTy Bits16Type = pure asBits16 28 | castFnForTy Bits32Type = pure asBits32 29 | castFnForTy Bits64Type = pure asBits64 30 | castFnForTy StringType = pure asString 31 | castFnForTy CharType = pure asChar 32 | castFnForTy DoubleType = pure asDouble 33 | castFnForTy ty = throw . InternalError $ "Unsupported type " ++ show ty 34 | 35 | binFn : (castFn : String -> String) -> (Vect 2 String -> String) -> Vect 2 String -> Core String 36 | binFn castFn f args = pure . mlRepr . f $ map castFn args 37 | 38 | 39 | addFn : Constant -> Vect 2 String -> Core String 40 | addFn ty args = do 41 | fn <- case ty of 42 | IntType => pure $ binFn asInt \[a, b] => binOp "+" a b 43 | IntegerType => pure $ binFn asBint \[a, b] => fnCall "Z.add" [a, b] 44 | Bits8Type => pure $ binFn asBits8 \[a, b] => bits8Bound $ binOp "+" a b 45 | Bits16Type => pure $ binFn asBits16 \[a, b] => bits16Bound $ binOp "+" a b 46 | Bits32Type => pure $ binFn asBits32 \[a, b] => bits32Bound $ binOp "+" a b 47 | Bits64Type => pure $ binFn asBits64 \[a, b] => fnCall "Int64.add" [a, b] 48 | DoubleType => pure $ binFn asDouble \[a, b] => binOp "+." a b 49 | _ => throw . InternalError $ "Unsupported add implementation for type " ++ show ty 50 | fn args 51 | 52 | subFn : Constant -> Vect 2 String -> Core String 53 | subFn ty args = do 54 | fn <- case ty of 55 | IntType => pure $ binFn asInt \[a, b] => binOp "-" a b 56 | IntegerType => pure $ binFn asBint \[a, b] => fnCall "Z.sub" [a, b] 57 | Bits8Type => pure $ binFn asBits8 \[a, b] => bits8Bound $ binOp "-" a b 58 | Bits16Type => pure $ binFn asBits16 \[a, b] => bits16Bound $ binOp "-" a b 59 | Bits32Type => pure $ binFn asBits32 \[a, b] => bits32Bound $ binOp "-" a b 60 | Bits64Type => pure $ binFn asBits64 \[a, b] => fnCall "Int64.sub" [a, b] 61 | DoubleType => pure $ binFn asDouble \[a, b] => binOp "-." a b 62 | _ => throw . InternalError $ "Unsupported sub implementation for type " ++ show ty 63 | fn args 64 | 65 | mulFn : Constant -> Vect 2 String -> Core String 66 | mulFn ty args = do 67 | fn <- case ty of 68 | IntType => pure $ binFn asInt \[a, b] => binOp "*" a b 69 | IntegerType => pure $ binFn asBint \[a, b] => fnCall "Z.mul" [a, b] 70 | Bits8Type => pure $ binFn asBits8 \[a, b] => bits8Bound $ binOp "*" a b 71 | Bits16Type => pure $ binFn asBits16 \[a, b] => bits16Bound $ binOp "*" a b 72 | Bits32Type => pure $ binFn asBits32 \[a, b] => bits32Bound $ binOp "*" a b 73 | Bits64Type => pure $ binFn asBits64 \[a, b] => fnCall "Int64.mul" [a, b] 74 | DoubleType => pure $ binFn asDouble \[a, b] => binOp "*." a b 75 | _ => throw . InternalError $ "Unsupported mul implementation for type " ++ show ty 76 | fn args 77 | 78 | divFn : Constant -> Vect 2 String -> Core String 79 | divFn ty args = do 80 | fn <- case ty of 81 | IntType => pure $ binFn asInt \[a, b] => binOp "/" a b 82 | IntegerType => pure $ binFn asBint \[a, b] => fnCall "Z.div" [a, b] 83 | Bits8Type => pure $ binFn asBits8 \[a, b] => bits8Bound $ binOp "/" a b 84 | Bits16Type => pure $ binFn asBits16 \[a, b] => bits16Bound $ binOp "/" a b 85 | Bits32Type => pure $ binFn asBits32 \[a, b] => bits32Bound $ binOp "/" a b 86 | Bits64Type => pure $ binFn asBits64 \[a, b] => fnCall "Int64.unsigned_div" [a, b] 87 | DoubleType => pure $ binFn asDouble \[a, b] => binOp "/." a b 88 | _ => throw . InternalError $ "Unsupported div implementation for type " ++ show ty 89 | fn args 90 | 91 | modFn : Constant -> Vect 2 String -> Core String 92 | modFn ty args = do 93 | fn <- case ty of 94 | IntType => pure $ binFn asInt \[a, b] => binOp "mod" a b 95 | IntegerType => pure $ binFn asBint \[a, b] => fnCall "Z.rem" [a, b] 96 | Bits8Type => pure $ binFn asBits8 \[a, b] => bits8Bound $ binOp "mod" a b 97 | Bits16Type => pure $ binFn asBits16 \[a, b] => bits16Bound $ binOp "mod" a b 98 | Bits32Type => pure $ binFn asBits32 \[a, b] => bits32Bound $ binOp "mod" a b 99 | Bits64Type => pure $ binFn asBits64 \[a, b] => fnCall "Int64.unsigned_rem" [a, b] 100 | _ => throw . InternalError $ "Unsupported mod implementation for type " ++ show ty 101 | fn args 102 | 103 | shiftLFn : Constant -> Vect 2 String -> Core String 104 | shiftLFn ty args = do 105 | fn <- case ty of 106 | IntType => pure $ binFn asInt \[a, b] => binOp "lsl" a b 107 | IntegerType => pure $ binFn asBint \[a, b] => fnCall "Z.shift_left" [a, fnCall "Z.to_int" [b]] 108 | Bits8Type => pure $ binFn asBits8 \[a, b] => bits8Bound $ binOp "lsl" a b 109 | Bits16Type => pure $ binFn asBits16 \[a, b] => bits16Bound $ binOp "lsl" a b 110 | Bits32Type => pure $ binFn asBits32 \[a, b] => bits32Bound $ binOp "lsl" a b 111 | Bits64Type => pure $ binFn asBits64 \[a, b] => fnCall "Int64.shift_left" [a, fnCall "Int64.to_int" [b]] 112 | _ => throw . InternalError $ "Unsupported shiftL implementation for type " ++ show ty 113 | fn args 114 | 115 | shiftRFn : Constant -> Vect 2 String -> Core String 116 | shiftRFn ty args = do 117 | fn <- case ty of 118 | IntType => pure $ binFn asInt \[a, b] => binOp "lsr" a b 119 | IntegerType => pure $ binFn asBint \[a, b] => fnCall "Z.shift_right" [a, fnCall "Z.to_int" [b]] 120 | Bits8Type => pure $ binFn asBits8 \[a, b] => bits8Bound $ binOp "lsr" a b 121 | Bits16Type => pure $ binFn asBits16 \[a, b] => bits16Bound $ binOp "lsr" a b 122 | Bits32Type => pure $ binFn asBits32 \[a, b] => bits32Bound $ binOp "lsr" a b 123 | Bits64Type => pure $ binFn asBits64 \[a, b] => fnCall "Int64.shift_right" [a, fnCall "Int64.to_int" [b]] 124 | _ => throw . InternalError $ "Unsupported shiftR implementation for type " ++ show ty 125 | fn args 126 | 127 | castToInt : Constant -> String -> Core String 128 | castToInt ty a = do 129 | case ty of 130 | IntegerType => pure . mlRepr $ fnCall "cast_bint_int" [asBint a] 131 | Bits8Type => pure a 132 | Bits16Type => pure a 133 | Bits32Type => pure a 134 | Bits64Type => pure . mlRepr $ fnCall "cast_bit64_int" [asBits64 a] 135 | DoubleType => pure . mlRepr $ fnCall "int_of_float" [asDouble a] 136 | StringType => pure . mlRepr $ fnCall "int_of_string" [asString a] 137 | CharType => pure . mlRepr $ fnCall "int_of_char" [asChar a] 138 | _ => throw . InternalError $ "Unsupported cast to Int implementation for type " ++ show ty 139 | 140 | castToInteger : Constant -> String -> Core String 141 | castToInteger ty a = do 142 | case ty of 143 | IntType => pure . mlRepr $ fnCall "Z.of_int" [asInt a] 144 | Bits8Type => pure . mlRepr $ fnCall "Z.of_int" [asBits8 a] 145 | Bits16Type => pure . mlRepr $ fnCall "Z.of_int" [asBits16 a] 146 | Bits32Type => pure . mlRepr $ fnCall "Z.of_int" [asBits32 a] 147 | Bits64Type => pure . mlRepr $ fnCall "Z.of_int64" [asBits64 a] 148 | DoubleType => pure . mlRepr $ fnCall "Z.of_float" [asDouble a] 149 | CharType => pure . mlRepr $ fnCall "Z.of_int" [fnCall "int_of_char" [asChar a]] 150 | StringType => pure . mlRepr $ fnCall "Z.of_string" [asString a] 151 | _ => throw . InternalError $ "Unsupported cast to Integer implementation for type " ++ show ty 152 | 153 | 154 | castToBits8 : Constant -> String -> Core String 155 | castToBits8 ty a = do 156 | case ty of 157 | IntType => pure . mlRepr $ fnCall "cast_int_bits8" [asInt a] 158 | IntegerType => pure . mlRepr $ fnCall "cast_bint_bits8" [asBint a] 159 | Bits16Type => pure . mlRepr $ fnCall "cast_int_bits8" [asBits16 a] 160 | Bits32Type => pure . mlRepr $ fnCall "cast_int_bits8" [asBits32 a] 161 | Bits64Type => pure . mlRepr $ fnCall "cast_bits64_bits8" [asBits64 a] 162 | _ => throw . InternalError $ "Unsupported cast to Bits8 implementation for type " ++ show ty 163 | 164 | castToBits16 : Constant -> String -> Core String 165 | castToBits16 ty a = do 166 | case ty of 167 | IntType => pure . mlRepr $ fnCall "cast_int_bits16" [asInt a] 168 | IntegerType => pure . mlRepr $ fnCall "cast_bint_bits16" [asBint a] 169 | Bits8Type => pure a 170 | Bits32Type => pure . mlRepr $ fnCall "cast_int_bits16" [asBits32 a] 171 | Bits64Type => pure . mlRepr $ fnCall "cast_bits64_bits8" [asBits64 a] 172 | _ => throw . InternalError $ "Unsupported cast to Bits16 implementation for type " ++ show ty 173 | 174 | castToBits32 : Constant -> String -> Core String 175 | castToBits32 ty a = do 176 | case ty of 177 | IntType => pure . mlRepr $ fnCall "cast_int_bits32" [asInt a] 178 | IntegerType => pure . mlRepr $ fnCall "cast_bint_bits32" [asBint a] 179 | Bits8Type => pure a 180 | Bits16Type => pure a 181 | Bits64Type => pure . mlRepr $ fnCall "cast_bits64_bits32" [asBits64 a] 182 | _ => throw . InternalError $ "Unsupported cast to Bits32 implementation for type " ++ show ty 183 | 184 | castToBits64 : Constant -> String -> Core String 185 | castToBits64 ty a = do 186 | case ty of 187 | IntType => pure . mlRepr $ fnCall "Int64.of_int" [asInt a] 188 | IntegerType => pure . mlRepr $ fnCall "cast_bint_bits64" [asBint a] 189 | Bits8Type => pure . mlRepr $ fnCall "Int64.of_int" [asBits8 a] 190 | Bits16Type => pure . mlRepr $ fnCall "Int64.of_int" [asBits16 a] 191 | Bits32Type => pure . mlRepr $ fnCall "Int64.of_int" [asBits32 a] 192 | _ => throw . InternalError $ "Unsupported cast to Bits64 implementation for type " ++ show ty 193 | 194 | castToString : Constant -> String -> Core String 195 | castToString ty a = do 196 | case ty of 197 | IntType => pure . mlRepr $ fnCall "string_of_int" [asInt a] 198 | IntegerType => pure . mlRepr $ fnCall "Z.to_string" [asBint a] 199 | Bits8Type => pure . mlRepr $ fnCall "string_of_int" [asBits8 a] 200 | Bits16Type => pure . mlRepr $ fnCall "string_of_int" [asBits16 a] 201 | Bits32Type => pure . mlRepr $ fnCall "string_of_int" [asBits32 a] 202 | Bits64Type => pure . mlRepr $ fnCall "Int64.to_string" [asBits64 a] -- TODO this behaves like signed ints 203 | DoubleType => pure . mlRepr $ fnCall "string_of_float" [asDouble a] 204 | CharType => pure . mlRepr $ fnCall "OcamlRts.String.of_char" [asChar a] 205 | _ => throw . InternalError $ "Unsupported cast to String implementation for type " ++ show ty 206 | 207 | castToDouble : Constant -> String -> Core String 208 | castToDouble ty a = do 209 | case ty of 210 | IntType => pure . mlRepr $ fnCall "float_of_int" [asInt a] 211 | IntegerType => pure . mlRepr $ fnCall "Z.to_float" [asBint a] 212 | StringType => pure . mlRepr $ fnCall "float_of_string" [asString a] 213 | _ => throw . InternalError $ "Unsupported cast to Double implementation for type " ++ show ty 214 | 215 | 216 | doubleFn : String -> Vect 1 String -> Core String 217 | doubleFn name [a] = pure . mlRepr $ fnCall name [asDouble a] 218 | 219 | 220 | export 221 | mlPrimFn : PrimFn arity -> Vect arity String -> Core String 222 | mlPrimFn (Add ty) args = addFn ty args 223 | mlPrimFn (Sub ty) args = subFn ty args 224 | mlPrimFn (Mul ty) args = mulFn ty args 225 | mlPrimFn (Div ty) args = divFn ty args 226 | mlPrimFn (Mod ty) args = modFn ty args 227 | mlPrimFn (Neg IntType) [a] = pure . mlRepr $ fnCall "-" [asInt a] 228 | mlPrimFn (Neg IntegerType) [a] = pure . mlRepr $ fnCall "Z.neg" [asBint a] 229 | mlPrimFn (Neg DoubleType) [a] = pure . mlRepr $ fnCall "-." [asDouble a] 230 | mlPrimFn (ShiftL ty) args = shiftLFn ty args 231 | mlPrimFn (ShiftR ty) args = shiftRFn ty args 232 | mlPrimFn (BAnd IntType) [a, b] = pure . mlRepr $ fnCall "Int.logand" [asInt a, asInt b] 233 | mlPrimFn (BAnd IntegerType) [a, b] = pure . mlRepr $ fnCall "Z.logand" [asBint a, asBint b] 234 | mlPrimFn (BAnd Bits8Type) [a, b] = pure . mlRepr . bits8Bound $ fnCall "Int.logand" [asBits8 a, asBits8 b] 235 | mlPrimFn (BAnd Bits16Type) [a, b] = pure . mlRepr . bits16Bound $ fnCall "Int.logand" [asBits16 a, asBits16 b] 236 | mlPrimFn (BAnd Bits32Type) [a, b] = pure . mlRepr . bits32Bound $ fnCall "Int.logand" [asBits32 a, asBits32 b] 237 | mlPrimFn (BAnd Bits64Type) [a, b] = pure . mlRepr $ fnCall "Int64.logand" [asBits64 a, asBits64 b] 238 | mlPrimFn (BAnd ty) args = throw $ InternalError ("unimplemented bitwise-and for type " ++ show ty) 239 | mlPrimFn (BOr IntType) [a, b] = pure . mlRepr $ fnCall "Int.logor" [asInt a, asInt b] 240 | mlPrimFn (BOr IntegerType) [a, b] = pure . mlRepr $ fnCall "Z.logor" [asBint a, asBint b] 241 | mlPrimFn (BOr Bits8Type) [a, b] = pure . mlRepr . bits8Bound $ fnCall "Int.logor" [asBits8 a, asBits8 b] 242 | mlPrimFn (BOr Bits16Type) [a, b] = pure . mlRepr . bits16Bound $ fnCall "Int.logor" [asBits16 a, asBits16 b] 243 | mlPrimFn (BOr Bits32Type) [a, b] = pure . mlRepr . bits32Bound $ fnCall "Int.logor" [asBits32 a, asBits32 b] 244 | mlPrimFn (BOr Bits64Type) [a, b] = pure . mlRepr $ fnCall "Int64.logor" [asBits64 a, asBits64 b] 245 | mlPrimFn (BOr ty) args = throw $ InternalError ("unimplemented bitwise-or for type " ++ show ty) 246 | mlPrimFn (BXOr IntType) [a, b] = pure . mlRepr $ fnCall "Int.logxor" [a, b] 247 | mlPrimFn (BXOr IntegerType) [a, b] = pure . mlRepr $ fnCall "Z.logxor" [a, b] 248 | mlPrimFn (BXOr Bits8Type) [a, b] = pure . mlRepr . bits8Bound $ fnCall "Int.logxor" [asBits8 a, asBits8 b] 249 | mlPrimFn (BXOr Bits16Type) [a, b] = pure . mlRepr . bits16Bound $ fnCall "Int.logxor" [asBits16 a, asBits16 b] 250 | mlPrimFn (BXOr Bits32Type) [a, b] = pure . mlRepr . bits32Bound $ fnCall "Int.logxor" [asBits32 a, asBits32 b] 251 | mlPrimFn (BXOr Bits64Type) [a, b] = pure . mlRepr $ fnCall "Int64.logxor" [asBits64 a, asBits64 b] 252 | mlPrimFn (BXOr ty) args = throw $ InternalError ("unimplemented bitwise-xor for type " ++ show ty) 253 | mlPrimFn (LT ty) [a, b] = castFnForTy ty >>= \t => pure . mlRepr $ boolOp "<" (t a) (t b) 254 | mlPrimFn (LTE ty) [a, b] = castFnForTy ty >>= \t => pure . mlRepr $ boolOp "<=" (t a) (t b) 255 | mlPrimFn (EQ ty) [a, b] = castFnForTy ty >>= \t => pure . mlRepr $ boolOp "=" (t a) (t b) 256 | mlPrimFn (GTE ty) [a, b] = castFnForTy ty >>= \t => pure . mlRepr $ boolOp ">=" (t a) (t b) 257 | mlPrimFn (GT ty) [a, b] = castFnForTy ty >>= \t => pure . mlRepr $ boolOp ">" (t a) (t b) 258 | mlPrimFn StrLength [a] = pure . mlRepr $ fnCall "OcamlRts.String.length" [asString a] 259 | mlPrimFn StrHead [a] = pure . mlRepr $ fnCall "OcamlRts.String.head" [asString a] 260 | mlPrimFn StrTail [a] = pure . mlRepr $ fnCall "OcamlRts.String.tail" [asString a] 261 | mlPrimFn StrIndex [s, i] = pure . mlRepr $ fnCall "OcamlRts.String.get" [asString s, asInt i] 262 | mlPrimFn StrCons [c, s] = pure . mlRepr $ fnCall "OcamlRts.String.cons" [asChar c, asString s] 263 | mlPrimFn StrAppend [a, b] = pure . mlRepr $ binOp "^" (asString a) (asString b) 264 | mlPrimFn StrReverse [a] = pure . mlRepr $ fnCall "OcamlRts.String.reverse" [asString a] 265 | mlPrimFn StrSubstr [offset, len, s] = pure . mlRepr $ fnCall "OcamlRts.String.substring" [asInt offset, asInt len, asString s] 266 | mlPrimFn DoubleExp args = doubleFn "Float.exp" args 267 | mlPrimFn DoubleLog args = doubleFn "Float.log" args 268 | mlPrimFn DoubleSin args = doubleFn "Float.sin" args 269 | mlPrimFn DoubleCos args = doubleFn "Float.cos" args 270 | mlPrimFn DoubleTan args = doubleFn "Float.tan" args 271 | mlPrimFn DoubleASin args = doubleFn "Float.asin" args 272 | mlPrimFn DoubleACos args = doubleFn "Float.acos" args 273 | mlPrimFn DoubleATan args = doubleFn "Float.atan" args 274 | mlPrimFn DoubleSqrt args = doubleFn "Float.sqrt" args 275 | mlPrimFn DoubleFloor args = doubleFn "Float.floor" args 276 | mlPrimFn DoubleCeiling args = doubleFn "Float.ceil" args 277 | mlPrimFn BelieveMe [_, _, x] = pure x 278 | mlPrimFn Crash [_, msg] = pure $ fnCall "raise" [fnCall "Idris2_Exception" [asString msg]] 279 | mlPrimFn (Cast ty IntType) [a] = castToInt ty a 280 | mlPrimFn (Cast ty IntegerType) [a] = castToInteger ty a 281 | mlPrimFn (Cast ty Bits8Type) [a] = castToBits8 ty a 282 | mlPrimFn (Cast ty Bits16Type) [a] = castToBits16 ty a 283 | mlPrimFn (Cast ty Bits32Type) [a] = castToBits32 ty a 284 | mlPrimFn (Cast ty Bits64Type) [a] = castToBits64 ty a 285 | mlPrimFn (Cast ty StringType) [a] = castToString ty a 286 | mlPrimFn (Cast ty DoubleType) [a] = castToDouble ty a 287 | mlPrimFn (Cast IntType CharType) [a] = pure . mlRepr $ fnCall "char_of_int" [asInt a] 288 | mlPrimFn (Cast from to) _ = throw . InternalError $ "Invalid cast " ++ show from ++ " -> " ++ show to 289 | mlPrimFn fn args = throw . InternalError $ "Unsupported primitive function " ++ show fn ++ " with args: " ++ show args 290 | 291 | -------------------------------------------------------------------------------- /src/Ocaml/Utils.idr: -------------------------------------------------------------------------------- 1 | module Ocaml.Utils 2 | 3 | import Compiler.Common 4 | import Compiler.CompileExpr 5 | 6 | import Core.Context 7 | 8 | import Data.List 9 | import Data.Vect 10 | 11 | export 12 | traverse : (a -> Core b) -> Vect n a -> Core (Vect n b) 13 | traverse f [] = pure [] 14 | traverse f (x::xs) = do 15 | x' <- f x 16 | xs' <- traverse f xs 17 | pure $ x' :: xs' 18 | 19 | 20 | export 21 | for : List a -> (a -> Core b) -> Core (List b) 22 | for [] f = pure [] 23 | for (x::xs) f = do 24 | x' <- f x 25 | rest <- for xs f 26 | pure (x' :: rest) 27 | 28 | export 29 | for_ : List a -> (a -> Core ()) -> Core () 30 | for_ [] f = pure () 31 | for_ (x::xs) f = do 32 | () <- f x 33 | for_ xs f 34 | 35 | export 36 | parens : String -> String 37 | parens s = "(" ++ s ++ ")" 38 | 39 | export 40 | binOp : (op : String) -> (a, b : String) -> String 41 | binOp op a b = parens $ a ++ " " ++ op ++ " " ++ b 42 | 43 | export 44 | fnCall : (fn : String) -> (args : List String) -> String 45 | fnCall fn args = parens $ fn ++ " " ++ showSep " " args 46 | 47 | export 48 | boolOp : (op : String) -> (a, b : String) -> String 49 | boolOp op a b = fnCall "int_of_bool" [binOp op a b] 50 | 51 | export 52 | mlRepr : String -> String 53 | mlRepr s = fnCall "Obj.repr" [s] 54 | 55 | 56 | 57 | 58 | export 59 | namespace' : Name -> String 60 | namespace' (NS ns _) = "Mod_" ++ showNSWithSep "_" ns 61 | namespace' _ = "Misc" 62 | 63 | 64 | public export 65 | flap : List a -> (a -> b) -> List b 66 | flap = flip map 67 | 68 | 69 | 70 | export 71 | asInt : String -> String 72 | asInt s = fnCall "as_int" [s] 73 | 74 | export 75 | asBint : String -> String 76 | asBint s = fnCall "as_bint" [s] 77 | 78 | export 79 | asBits8 : String -> String 80 | asBits8 s = fnCall "as_bits8" [s] 81 | 82 | export 83 | asBits16 : String -> String 84 | asBits16 s = fnCall "as_bits16" [s] 85 | 86 | export 87 | asBits32 : String -> String 88 | asBits32 s = fnCall "as_bits32" [s] 89 | 90 | export 91 | asBits64 : String -> String 92 | asBits64 s = fnCall "as_bits64" [s] 93 | 94 | export 95 | asString : String -> String 96 | asString s = fnCall "as_string" [s] 97 | 98 | export 99 | asChar : String -> String 100 | asChar s = fnCall "as_char" [s] 101 | 102 | export 103 | asDouble : String -> String 104 | asDouble s = fnCall "as_double" [s] 105 | -------------------------------------------------------------------------------- /support/OcamlRts.ml: -------------------------------------------------------------------------------- 1 | exception Idris2_Exception of string;; 2 | 3 | type idr2_char = char;; (* is actually just a byte? Not enough for code points *) 4 | 5 | let as_lazy : Obj.t -> Obj.t lazy_t = Obj.obj;; 6 | let as_fun : Obj.t -> (Obj.t -> Obj.t) = Obj.obj;; 7 | let as_ref : Obj.t -> Obj.t ref = Obj.obj;; 8 | let as_array : Obj.t -> Obj.t array = Obj.obj;; 9 | 10 | let as_erased (x : Obj.t) : unit = ();; 11 | let as_int : Obj.t -> int = Obj.obj;; 12 | let as_bint : Obj.t -> Z.t = Obj.obj;; 13 | let as_bits8 : Obj.t -> int = Obj.obj;; 14 | let as_bits16 : Obj.t -> int = Obj.obj;; 15 | let as_bits32 : Obj.t -> int = Obj.obj;; 16 | let as_bits64 : Obj.t -> int64 = Obj.obj;; 17 | let as_string : Obj.t -> string = Obj.obj;; 18 | let as_char : Obj.t -> idr2_char = Obj.obj;; 19 | let as_double : Obj.t -> float = Obj.obj;; 20 | let as_world (x : Obj.t) : unit = ();; 21 | 22 | let hint_obj_t (x : Obj.t) : Obj.t = x;; 23 | 24 | 25 | (* Primitive functions *) 26 | 27 | let ensure_bits8 (x : int) : int = 28 | let max = 1 lsl 8 in 29 | let x' = x mod max in 30 | if x' < 0 31 | then max + x' 32 | else x';; 33 | 34 | let ensure_bits16 (x : int) : int = 35 | let max = 1 lsl 16 in 36 | let x' = x mod max in 37 | if x' < 0 38 | then max + x' 39 | else x';; 40 | 41 | let ensure_bits32 (x : int) : int = 42 | let max = 1 lsl 32 in 43 | let x' = x mod max in 44 | if x' < 0 45 | then max + x' 46 | else x';; 47 | 48 | (* TODO handle signedness and overflow *) 49 | let cast_bint_int (x : Z.t) : int = 50 | let upper = Z.shift_left Z.one (Sys.int_size) in 51 | Z.to_int (Z.rem x upper);; 52 | 53 | (* TODO handle signedness and overflow *) 54 | let cast_bits64_int (x : int64) : int = Int64.to_int (Int64.unsigned_rem x (Int64.of_int (1 lsl 63)));;;; 55 | 56 | let cast_int_bits8 (x : int) : int = ensure_bits8 x;; 57 | let cast_bint_bits8 (x : Z.t) : int = ensure_bits8 (Z.to_int (Z.rem x (Z.of_int (1 lsl 8))));; 58 | let cast_bits64_bits8 (x : int64) : int = ensure_bits8 (Int64.to_int (Int64.unsigned_rem x (Int64.of_int (1 lsl 8))));; 59 | 60 | let cast_int_bits16 (x : int) : int = ensure_bits16 x;; 61 | let cast_bint_bits16 (x : Z.t) : int = ensure_bits16 (Z.to_int (Z.rem x (Z.of_int (1 lsl 16))));; 62 | let cast_bits64_bits16 (x : int64) : int = ensure_bits16 (Int64.to_int (Int64.unsigned_rem x (Int64.of_int (1 lsl 16))));; 63 | 64 | let cast_int_bits32 (x : int) : int = ensure_bits32 x;; 65 | let cast_bint_bits32 (x : Z.t) : int = ensure_bits32 (Z.to_int (Z.rem x (Z.of_int (1 lsl 32))));; 66 | let cast_bits64_bits32 (x : int64) : int = ensure_bits32 (Int64.to_int (Int64.unsigned_rem x (Int64.of_int (1 lsl 32))));; 67 | 68 | (* TODO this doesn't handle signed numbers yet *) 69 | let cast_bint_bits64 (x : Z.t) : int64 = 70 | let upper_32 = Z.shift_left Z.one 32 in 71 | let upper_64 = Z.shift_left upper_32 32 in 72 | Z.to_int64 (Z.rem x upper_64);; 73 | 74 | 75 | let int_of_bool (b : bool) : int = Bool.to_int b;; 76 | 77 | let get_tag (o : Obj.t) : int = 78 | if Obj.is_int o 79 | then Obj.obj o 80 | else Obj.tag o;; 81 | 82 | 83 | 84 | (* These types are made to match the Idris representation *) 85 | module Types = struct 86 | type world = World 87 | type os_clock 88 | 89 | module IdrisList = struct 90 | type 'a idris_list = 91 | | Nil (* int 0 *) 92 | | UNUSED of int (* block, tag 0 *) 93 | | Cons of 'a * 'a idris_list (* block, tag 1 *) 94 | 95 | let rec of_list = function 96 | | [] -> Nil 97 | | x :: xs -> Cons (x, of_list xs) 98 | 99 | let rec to_list = function 100 | | Nil -> [] 101 | | UNUSED _ -> failwith "UNUSED tag in idris list" 102 | | Cons (x, xs) -> x :: to_list xs 103 | 104 | let rec foldl f z = function 105 | | Nil -> z 106 | | UNUSED _ -> failwith "UNUSED tag in idris list" 107 | | Cons (x, xs) -> foldl f (f z x) xs 108 | end 109 | 110 | end 111 | open Types 112 | open Types.IdrisList 113 | 114 | let not_implemented msg = failwith ("not implemented yet: " ^ msg) 115 | 116 | module Debug = struct 117 | (* %foreign "ML:Rts.Debug.inspect" 118 | * prim__inspect : {a : Type} -> (x : a) -> (1 w : %World) -> IORes () 119 | * 120 | * inspect : a -> IO () 121 | * inspect x = primIO (prim__inspect x) 122 | *) 123 | external inspect : 'ty -> 'a -> unit = "inspect" 124 | end 125 | 126 | module IORef = struct 127 | let write (r : 'a ref) (x : 'a) : unit = r := x 128 | end 129 | 130 | module System = struct 131 | let get_args (_ : world) : string idris_list = 132 | IdrisList.of_list (Array.to_list Sys.argv) 133 | 134 | let fork_thread (sub : world -> unit) : Thread.t = 135 | Thread.create sub World 136 | 137 | let os_name (_ : world) : string = 138 | match Sys.os_type with 139 | | "Unix" -> "unix" 140 | | "Win32" -> "windows" 141 | | "Cygwin" -> "windows" 142 | | _ -> "unknown" 143 | 144 | external clocktime_gc_cpu : world -> os_clock = "ml_clocktime_gc_cpu" 145 | external clocktime_gc_real : world -> os_clock = "ml_clocktime_gc_real" 146 | external clocktime_monotonic : world -> os_clock = "ml_clocktime_monotonic" 147 | external clocktime_process : world -> os_clock = "ml_clocktime_process" 148 | external clocktime_thread : world -> os_clock = "ml_clocktime_thread" 149 | external clocktime_utc : world -> os_clock = "ml_clocktime_utc" 150 | external os_clock_nanosecond : os_clock -> int64 = "ml_os_clock_nanosecond" 151 | external os_clock_second : os_clock -> int64 = "ml_os_clock_second" 152 | external os_clock_valid : os_clock -> int = "ml_os_clock_valid" 153 | end 154 | 155 | module String = struct 156 | external reverse : string -> string = "ml_string_reverse" 157 | external substring : int -> int -> string -> string = "ml_string_substring" 158 | external cons : char -> string -> string = "ml_string_cons" 159 | external length : string -> int = "ml_string_length" 160 | external head : string -> char = "ml_string_head" 161 | external tail : string -> string = "ml_string_tail" 162 | external get : string -> int -> char = "ml_string_get" 163 | external unpack : string -> char idris_list = "ml_string_unpack" 164 | external pack : char idris_list -> string = "ml_string_pack" 165 | 166 | type char_result 167 | external readChar : int -> string -> char_result = "ml_string_readChar" 168 | 169 | let of_char (c : char) : string = String.make 1 c 170 | end 171 | 172 | module Bytes = struct 173 | (* pre-allocate a big buffer once and copy all strings in it *) 174 | external concat : string idris_list -> string = "ml_string_concat" 175 | 176 | (* implemented in C for easier debugging 177 | let concat (ssi : bytes idris_list) : bytes = 178 | let ss = IdrisList.to_list ssi in 179 | let total_length = List.fold_left (fun l s -> l + Bytes.length s) 0 ss in 180 | let result = Bytes.create total_length in 181 | let rec write_strings (ofs : int) = function 182 | | IdrisList.Nil -> () 183 | | IdrisList.UNUSED _ -> failwith "UNUSED" 184 | | IdrisList.Cons (src, rest) -> 185 | let len = Bytes.length src in 186 | Bytes.blit src 0 result ofs len; 187 | write_strings (ofs+len) rest 188 | in 189 | write_strings 0 ssi; 190 | result 191 | *) 192 | 193 | let append (x : bytes) (y : bytes) : bytes = 194 | let xlen = Bytes.length x in 195 | let ylen = Bytes.length y in 196 | let result = Bytes.create (xlen + ylen) in 197 | Bytes.blit x 0 result 0 xlen; 198 | Bytes.blit y 0 result xlen ylen; 199 | result 200 | end 201 | 202 | module C = struct 203 | type 'a pointer 204 | (* type 'file file_pointer *) 205 | type filep 206 | 207 | module Lib_libidris2_support = struct 208 | external idris2_putStr : string -> unit = "ml_idris2_putStr" 209 | external idris2_isNull : 'a pointer -> bool = "ml_idris2_isNull" 210 | external idris2_getString : string pointer -> string = "ml_idris2_getString" 211 | external idris2_getStr : world -> string = "ml_idris2_getStr" 212 | external idris2_getEnvPair : int -> string pointer = "ml_idris2_getEnvPair" 213 | 214 | (* idris_file.h *) 215 | external idris2_openFile : string -> string -> filep = "ml_idris2_openFile" 216 | external idris2_closeFile : filep -> unit = "ml_idris2_closeFile" 217 | external idris2_fileError : filep -> int = "ml_idris2_fileError" 218 | 219 | external idris2_fileErrno : world -> int = "ml_idris2_fileErrno" 220 | 221 | external idris2_removeFile : string -> int = "ml_idris2_removeFile" 222 | external idris2_fileSize : filep -> int = "ml_idris2_fileSize" 223 | 224 | external idris2_fpoll : filep -> int = "ml_idris2_fpoll" 225 | 226 | external idris2_readLine : filep -> string pointer = "ml_idris2_readLine" 227 | external idris2_readChars : int -> filep -> string pointer = "ml_idris2_readChars" 228 | 229 | external idris2_writeLine : filep -> string -> int = "ml_idris2_writeLine" 230 | 231 | external idris2_eof : filep -> int = "ml_idris2_eof" 232 | external idris2_fileAccessTime : filep -> int = "ml_idris2_fileAccessTime" 233 | external idris2_fileModifiedTime : filep -> int = "ml_idris2_fileModifiedTime" 234 | external idris2_fileStatusTime : filep -> int = "ml_idris2_fileStatusTime" 235 | 236 | external idris2_stdin : unit -> filep = "ml_idris2_stdin" 237 | external idris2_stdout : unit -> filep = "ml_idris2_stdout" 238 | external idris2_stderr : unit -> filep = "ml_idris2_stderr" 239 | 240 | (* idris_directory.h *) 241 | external idris2_currentDirectory : world -> string = "ml_idris2_currentDirectory" 242 | external idris2_changeDir : string -> int = "ml_idris2_changeDir" 243 | external idris2_createDir : string -> int = "ml_idris2_createDir" 244 | external idris2_openDir : string -> 'a pointer = "ml_idris2_openDir" 245 | external idris2_closeDir : 'a pointer -> unit = "ml_idris2_closeDir" 246 | external idris2_removeDir : string -> int = "ml_idris2_removeDir" 247 | external idris2_nextDirEntry : 'a pointer -> string = "ml_idris2_nextDirEntry" 248 | 249 | (* idris_buffer.h *) 250 | external idris2_newBuffer : int -> 'buffer pointer = "ml_idris2_newBuffer" 251 | external idris2_freeBuffer : 'buffer pointer -> unit = "ml_idris2_freeBuffer" 252 | external idris2_getBufferSize : 'buffer pointer -> int = "ml_idris2_getBufferSize" 253 | 254 | external idris2_setBufferByte : 'buffer pointer -> int -> int -> unit = "ml_idris2_setBufferByte" 255 | external idris2_setBufferInt : 'buffer pointer -> int -> int -> unit = "ml_idris2_setBufferInt" 256 | external idris2_setBufferBits8 : 'buffer pointer -> int -> int -> unit = "ml_idris2_setBufferBits8" 257 | external idris2_setBufferBits16 : 'buffer pointer -> int -> int -> unit = "ml_idris2_setBufferBits16" 258 | external idris2_setBufferBits32 : 'buffer pointer -> int -> int -> unit = "ml_idris2_setBufferBits32" 259 | external idris2_setBufferBits64 : 'buffer pointer -> int -> int64 -> unit = "ml_idris2_setBufferBits64" 260 | external idris2_setBufferDouble : 'buffer pointer -> int -> float -> unit = "ml_idris2_setBufferDouble" 261 | external idris2_setBufferString : 'buffer pointer -> int -> string -> unit = "ml_idris2_setBufferString" 262 | 263 | external idris2_copyBuffer : 'buffer pointer -> int -> int -> 'buffer pointer -> int -> unit = "ml_idris2_copyBuffer" 264 | 265 | external idris2_readBufferData : filep -> 'buffer pointer -> int -> int -> int = "ml_idris2_readBufferData" 266 | external idris2_writeBufferData : filep -> 'buffer pointer -> int -> int -> int = "ml_idris2_writeBufferData" 267 | 268 | external idris2_getBufferByte : 'buffer pointer -> int -> int = "ml_idris2_getBufferByte" 269 | external idris2_getBufferInt : 'buffer pointer -> int -> int = "ml_idris2_getBufferInt" 270 | external idris2_getBufferBits8 : 'buffer pointer -> int -> int = "ml_idris2_getBufferBits8" 271 | external idris2_getBufferBits16 : 'buffer pointer -> int -> int = "ml_idris2_getBufferBits16" 272 | external idris2_getBufferBits32 : 'buffer pointer -> int -> int = "ml_idris2_getBufferBits32" 273 | external idris2_getBufferBits64 : 'buffer pointer -> int -> int64 = "ml_idris2_getBufferBits64" 274 | external idris2_getBufferDouble : 'buffer pointer -> int -> float = "ml_idris2_getBufferDouble" 275 | external idris2_getBufferString : 'buffer pointer -> int -> int -> string = "ml_idris2_getBufferString" 276 | 277 | (* idris_net *) 278 | (* FIXME: this should work with buffers *) 279 | external idrnet_malloc : int -> 'buffer pointer = "ml_idrnet_malloc" 280 | external idrnet_free : 'buffer pointer -> unit = "ml_idrnet_free" 281 | external idrnet_peek : 'buffer pointer -> int -> int = "ml_idrnet_peek" 282 | external idrnet_poke : 'buffer pointer -> int -> int = "ml_idrnet_poke" 283 | 284 | external idrnet_errno : world -> int = "ml_idrnet_errno" 285 | 286 | external idrnet_socket : int -> int -> int -> int = "ml_idrnet_socket" 287 | 288 | external idrnet_bind : int -> int -> int -> string -> int -> int = "ml_idrnet_bind" 289 | 290 | external idrnet_getsockname : int -> 'address pointer -> 'address pointer -> int = "ml_idrnet_getsockname" 291 | external idrnet_connect : int -> int -> int -> string -> int = "ml_idrnet_connect" 292 | 293 | external idrnet_sockaddr_family : 'sockaddr pointer -> int = "ml_idrnet_sockaddr_family" 294 | external idrnet_sockaddr_ipv4 : 'sockaddr pointer -> string = "ml_idrnet_sockaddr_ipv4" 295 | external idrnet_sockaddr_ipv4_port : 'sockaddr pointer -> int = "ml_idrnet_sockaddr_ipv4_port" 296 | external idrnet_create_sockaddr : world -> 'sockaddr pointer = "ml_idrnet_create_sockaddr" 297 | 298 | external idrnet_accept : int -> 'sockaddr pointer -> int = "ml_idrnet_accept" 299 | 300 | external idrnet_send : int -> string -> int = "ml_idrnet_send" 301 | external idrnet_send_buf : int -> 'buffer pointer -> int -> int = "ml_idrnet_send_buf" 302 | 303 | external idrnet_recv : int -> int -> 'buffer pointer = "ml_idrnet_recv" 304 | external idrnet_recv_buf : int -> 'buffer pointer -> int -> int = "ml_idrnet_recv_buf" 305 | 306 | external idrnet_sendto : int -> string -> string -> int -> int -> int = "ml_idrnet_sendto" 307 | external idrnet_sendto_buf : int -> 'buffer pointer -> int -> string -> int -> int -> int = "ml_idrnet_sendto_buf_bytecode" "ml_idrnet_sendto_buf_native" 308 | 309 | external idrnet_recvfrom : int -> int -> 'buffer pointer = "ml_idrnet_recvfrom" 310 | external idrnet_recvfrom_buf : int -> 'buffer pointer -> int -> 'buffer pointer = "ml_idrnet_recvfrom" 311 | 312 | external idrnet_get_recv_res : 'result pointer -> int = "ml_idrnet_get_recv_res" 313 | external idrnet_get_recv_payload : 'result pointer -> string = "ml_idrnet_get_recv_payload" 314 | external idrnet_free_recv_struct : 'result pointer -> unit = "ml_idrnet_free_recv_struct" 315 | 316 | external idrnet_get_recvfrom_res : 'result pointer -> int = "ml_idrnet_get_recvfrom_res" 317 | external idrnet_get_recvfrom_payload : 'result pointer -> string = "ml_idrnet_get_recvfrom_payload" 318 | external idrnet_get_recvfrom_sockaddr : 'result pointer -> 'buffer pointer = "ml_idrnet_get_recvfrom_sockaddr" 319 | external idrnet_free_recvfrom_struct : 'result pointer -> unit = "ml_idrnet_free_recvfrom_struct" 320 | 321 | external idrnet_geteagain : world -> int = "ml_idrnet_geteagain" 322 | 323 | (* idris2_term.h *) 324 | external idris2_setupTerm : world -> unit = "ml_idris2_setupTerm" 325 | external idris2_getTermCols : world -> int = "ml_idris2_getTermCols" 326 | external idris2_getTermLines : world -> int = "ml_idris2_getTermLines" 327 | 328 | end 329 | 330 | module Lib_libc6 = struct 331 | 332 | external getenv : string -> string pointer = "ml_getenv" 333 | external system : string -> int = "ml_system" 334 | external exit : int -> unit = "ml_exit" 335 | external fflush : filep -> int = "ml_fflush" 336 | external fdopen : int -> string -> filep = "ml_fdopen" 337 | external chmod : string -> int -> int = "ml_chmod" 338 | 339 | external putchar : char -> int = "ml_putchar" 340 | external getchar : world -> int = "ml_getchar" 341 | external strlen : string -> int = "ml_strlen" 342 | 343 | external fgetc : filep -> int = "ml_fgetc" 344 | external listen : int -> int -> int = "ml_idris2_listen" 345 | end 346 | end 347 | -------------------------------------------------------------------------------- /support/ocaml_rts.c: -------------------------------------------------------------------------------- 1 | #define CAML_NAME_SPACE 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | #include 12 | 13 | #include "getline.h" 14 | #include "idris_buffer.h" 15 | #include "idris_directory.h" 16 | #include "idris_file.h" 17 | #include "idris_net.h" 18 | #include "idris_support.h" 19 | #include "idris_term.h" 20 | 21 | #include "sys/stat.h" 22 | 23 | 24 | /* FILE* as custom caml val */ 25 | 26 | 27 | CAMLprim value c_hello(value i) { 28 | CAMLparam0(); 29 | const char * const msg = "hello from C!"; 30 | printf("this is C; we received %d from OCaml\n", Int_val(i)); 31 | CAMLreturn(caml_alloc_initialized_string(strlen(msg), msg)); 32 | } 33 | 34 | 35 | // apparently this could be done using the OCaml Obj module from the stdlib 36 | // but this is already written so let's keep it 37 | void inspect_(int indent, value x) { 38 | for (int i = 0; i < indent; ++i) printf(" "); 39 | if (Is_block(x)) { 40 | switch (Tag_val(x)) { 41 | case Double_tag: 42 | printf("double: %f\n", Double_val(x)); 43 | break; 44 | 45 | case String_tag: 46 | printf("string: %s\n", String_val(x)); 47 | break; 48 | 49 | case Custom_tag: 50 | printf("custom tag\n"); 51 | break; 52 | 53 | default: 54 | printf( 55 | "block(tag = %d, size = %d)\n", 56 | Tag_val(x), 57 | Wosize_val(x) 58 | ); 59 | 60 | if (Tag_val(x) < 16) { 61 | // probably an ADT 62 | for (int i = 0; i < Wosize_val(x); ++i) { 63 | inspect_(indent+1, Field(x, i)); 64 | } 65 | } else { 66 | for (int i = 0; i < indent+1; ++i) printf(" "); 67 | printf("(fields omitted because tag too high)\n"); 68 | } 69 | break; 70 | } 71 | } else { 72 | printf("int %d\n", Int_val(x)); 73 | } 74 | } 75 | 76 | // returns the number of bytes read 77 | // 0 = malformed 78 | static inline size_t utf8_read(const uint8_t * bytes, size_t length, uint32_t * out_cp) 79 | { 80 | if (length < 1) { 81 | return 0; 82 | } 83 | 84 | if (bytes[0] < 0x80) { 85 | // one-byte representation 86 | *out_cp = (uint32_t) bytes[0]; 87 | return 1; 88 | } 89 | 90 | if (bytes[0] < 0xC0) { 91 | // continuation bytes cannot appear here 92 | return 0; 93 | } 94 | 95 | if (bytes[0] < 0xE0) { 96 | // two-byte representation 97 | if (length < 2) { 98 | return 0; 99 | } 100 | 101 | if ((bytes[1] & 0xC0) != 0x80) { 102 | // malformed continuation byte: must be 0b10xx_xxxx 103 | return 0; 104 | } 105 | 106 | *out_cp = ((uint32_t) (bytes[0] & 0x1F) << 6) 107 | | (uint32_t) (bytes[1] & 0x3F) 108 | ; 109 | return 2; 110 | } 111 | 112 | if (bytes[0] < 0xF0) { 113 | // three-byte representation 114 | if (length < 3) { 115 | return 0; 116 | } 117 | 118 | if ((bytes[1] & 0xC0) != 0x80 || (bytes[2] & 0xC0) != 0x80) { 119 | // malformed continuation byte: must be 0b10xx_xxxx 120 | return 0; 121 | } 122 | 123 | *out_cp = ((uint32_t) (bytes[0] & 0x0F) << 12) 124 | | ((uint32_t) (bytes[1] & 0x3F) << 6) 125 | | (uint32_t) (bytes[2] & 0x3F) 126 | ; 127 | return 3; 128 | } 129 | 130 | if (bytes[0] < 0xF8) { 131 | // four-byte representation 132 | if (length < 4) { 133 | return 0; 134 | } 135 | 136 | if ( 137 | (bytes[1] & 0xC0) != 0x80 138 | || (bytes[2] & 0xC0) != 0x80 139 | || (bytes[3] & 0xC0) != 0x80 140 | ) { 141 | // malformed continuation byte: must be 0b10xx_xxxx 142 | return 0; 143 | } 144 | 145 | *out_cp = ((uint32_t) (bytes[0] & 0x07) << 18) 146 | | ((uint32_t) (bytes[1] & 0x3F) << 12) 147 | | ((uint32_t) (bytes[2] & 0x3F) << 6) 148 | | (uint32_t) (bytes[3] & 0x3F) 149 | ; 150 | return 4; 151 | } 152 | 153 | return 0; 154 | } 155 | 156 | // zero = error 157 | static inline size_t utf8_width(uint32_t cp) 158 | { 159 | if (cp < 0x80) { 160 | return 1; 161 | } 162 | 163 | if (cp < 0x800) { 164 | return 2; 165 | } 166 | 167 | if (cp < 0x10000) { 168 | return 3; 169 | } 170 | 171 | if (cp < 0x110000) { 172 | return 4; 173 | } 174 | 175 | return 0; // code too high 176 | } 177 | 178 | static inline void utf8_write(uint8_t * buf, size_t cp_width, uint32_t cp) 179 | { 180 | switch (cp_width) { 181 | case 1: 182 | buf[0] = cp & 0x7F; 183 | break; 184 | 185 | case 2: 186 | buf[0] = ((cp >> 6) & 0x1F) | 0xC0; 187 | buf[1] = ( cp & 0x3F) | 0x80; 188 | break; 189 | 190 | case 3: 191 | buf[0] = ((cp >> 12) & 0x0F) | 0xE0; 192 | buf[1] = ((cp >> 6) & 0x3F) | 0x80; 193 | buf[2] = ( cp & 0x3F) | 0x80; 194 | break; 195 | 196 | case 4: 197 | buf[0] = ((cp >> 18) & 0x07) | 0xF0; 198 | buf[1] = ((cp >> 12) & 0x3F) | 0x80; 199 | buf[2] = ((cp >> 6) & 0x3F) | 0x80; 200 | buf[3] = ( cp & 0x3F) | 0x80; 201 | break; 202 | 203 | default: 204 | caml_failwith("utf8_write: invalid code point width"); 205 | break; 206 | } 207 | } 208 | 209 | CAMLprim value ml_string_readChar(value ofs, value src) 210 | { 211 | CAMLparam2(ofs, src); 212 | CAMLlocal1(result); 213 | 214 | uint32_t cp; 215 | const size_t cp_width = utf8_read( 216 | Bytes_val(src) + Int_val(ofs), 217 | caml_string_length(src) - Int_val(ofs), 218 | &cp 219 | ); 220 | 221 | if (cp_width == 0) { 222 | result = Val_int(0); // EOF, int 0 223 | } else { 224 | result = caml_alloc(2, 1); // Character, block tag 1 225 | Store_field(result, 0, Val_int(cp)); 226 | Store_field(result, 1, Val_int(cp_width)); 227 | } 228 | 229 | CAMLreturn(result); 230 | } 231 | 232 | CAMLprim value ml_string_reverse(value src) 233 | { 234 | CAMLparam1(src); 235 | CAMLlocal1(dst); 236 | 237 | const size_t src_length = caml_string_length(src); 238 | dst = caml_alloc_string(src_length); 239 | 240 | // all allocations are done, now we're going to take (char *) pointers 241 | // don't do any allocations anymore because it may invalidate the pointers! 242 | 243 | const uint8_t * src_start = Bytes_val(src); 244 | const uint8_t * src_end = src_start + src_length; 245 | const uint8_t * srcp = src_start; 246 | 247 | uint8_t * dst_start = Bytes_val(dst); 248 | uint8_t * dst_end = dst_start + src_length; 249 | uint8_t * dstp = dst_end; 250 | 251 | size_t bytes_remaining = src_length; 252 | while (srcp < src_end && dstp > dst_start) { 253 | uint32_t cp; 254 | const size_t cp_width = utf8_read(srcp, bytes_remaining, &cp); 255 | if (cp_width == 0) { 256 | caml_failwith("ml_string_reverse: malformed utf8 input"); 257 | } 258 | 259 | utf8_write(dstp-cp_width, cp_width, cp); 260 | 261 | bytes_remaining -= cp_width; 262 | srcp += cp_width; 263 | dstp -= cp_width; 264 | } 265 | 266 | if (srcp != src_end || dstp != dst_start) { 267 | caml_failwith("ml_string_reverse: desynchronised"); 268 | } 269 | 270 | CAMLreturn(dst); 271 | } 272 | 273 | // will return the pointer to the NUL byte if out of bounds 274 | const uint8_t * utf8_skip_chars(const uint8_t * buf, size_t buf_length, size_t n_chars) 275 | { 276 | while (n_chars > 0 && buf_length > 0) 277 | { 278 | uint32_t cp; 279 | const size_t cp_width = utf8_read(buf, buf_length, &cp); 280 | if (cp_width == 0) { 281 | caml_failwith("utf8_skip_chars: out of bounds or malformed string"); 282 | } 283 | 284 | buf += cp_width; 285 | buf_length -= cp_width; 286 | n_chars--; 287 | } 288 | 289 | return buf; 290 | } 291 | 292 | CAMLprim value ml_string_substring(value n_skip, value n_chars, value src) 293 | { 294 | CAMLparam3(n_skip, n_chars, src); 295 | CAMLlocal1(dst); 296 | 297 | const uint8_t * src_start = Bytes_val(src); 298 | const uint8_t * src_end = src_start + caml_string_length(src); 299 | 300 | const uint8_t * substr_start = utf8_skip_chars(src_start, src_end - src_start, Int_val(n_skip)); 301 | const uint8_t * substr_end = utf8_skip_chars(substr_start, src_end - substr_start, Int_val(n_chars)); 302 | const size_t subst_ofs = substr_start - src_start; 303 | const size_t substr_width = substr_end - substr_start; 304 | 305 | // here we allocate so pointers taken above are no longer valid 306 | // hence we need to take Bytes_val() again, and refer only to the length 307 | dst = caml_alloc_string(substr_end - substr_start); 308 | memcpy(Bytes_val(dst), Bytes_val(src) + subst_ofs, substr_width); 309 | 310 | CAMLreturn(dst); 311 | } 312 | 313 | CAMLprim value ml_string_cons(value cpv, value src) 314 | { 315 | CAMLparam2(cpv, src); 316 | CAMLlocal1(dst); 317 | 318 | const size_t src_length = caml_string_length(src); 319 | const uint32_t cp = Int_val(cpv); 320 | const size_t cp_width = utf8_width(cp); 321 | 322 | dst = caml_alloc_string(cp_width + src_length); 323 | 324 | // we take the pointer after allocation so it's fine 325 | uint8_t * dstp = Bytes_val(dst); 326 | 327 | utf8_write(dstp, cp_width, cp); 328 | memcpy(dstp+cp_width, Bytes_val(src), src_length); 329 | 330 | CAMLreturn(dst); 331 | } 332 | 333 | CAMLprim value ml_string_length(value src) 334 | { 335 | CAMLparam1(src); 336 | 337 | const uint8_t * srcp = Bytes_val(src); 338 | size_t bytes_remaining = caml_string_length(src); 339 | 340 | size_t n_chars = 0; 341 | while (bytes_remaining > 0) 342 | { 343 | uint32_t cp; 344 | size_t cp_width = utf8_read(srcp, bytes_remaining, &cp); 345 | if (cp_width == 0) 346 | { 347 | caml_failwith("ml_string_length: malformed string"); 348 | } 349 | 350 | srcp += cp_width; 351 | bytes_remaining -= cp_width; 352 | n_chars += 1; 353 | } 354 | 355 | CAMLreturn(Val_int(n_chars)); 356 | } 357 | 358 | CAMLprim value ml_string_head(value src) 359 | { 360 | CAMLparam1(src); 361 | 362 | uint32_t cp; 363 | const size_t cp_width = utf8_read(Bytes_val(src), caml_string_length(src), &cp); 364 | if (cp_width == 0) { 365 | caml_failwith("ml_string_head: empty or malformed string"); 366 | } 367 | 368 | CAMLreturn(Val_int(cp)); 369 | } 370 | 371 | CAMLprim value ml_string_tail(value src) 372 | { 373 | CAMLparam1(src); 374 | CAMLlocal1(dst); 375 | 376 | const uint8_t * srcp = Bytes_val(src); 377 | const size_t src_length = caml_string_length(src); 378 | 379 | uint32_t cp; 380 | const size_t cp_width = utf8_read(srcp, src_length, &cp); 381 | if (cp_width == 0) { 382 | caml_failwith("ml_string_tail: empty or malformed string"); 383 | } 384 | 385 | // allocation invalidates srcp 386 | dst = caml_alloc_string(src_length - cp_width); 387 | 388 | memcpy(Bytes_val(dst), Bytes_val(src) + cp_width, src_length - cp_width); 389 | 390 | CAMLreturn(dst); 391 | } 392 | 393 | CAMLprim value ml_string_get(value src, value i) 394 | { 395 | CAMLparam2(src, i); 396 | 397 | const uint8_t * src_start = Bytes_val(src); 398 | const uint8_t * src_end = src_start + caml_string_length(src); 399 | 400 | const uint8_t * p = utf8_skip_chars(src_start, src_end - src_start, Int_val(i)); 401 | if (p == src_end) 402 | { 403 | caml_failwith("ml_string_get: index out of bounds"); 404 | } 405 | 406 | uint32_t cp; 407 | const size_t cp_width = utf8_read(p, src_end - p, &cp); 408 | if (cp_width == 0) 409 | { 410 | caml_failwith("ml_string_get: out of bounds or malformed string"); 411 | } 412 | 413 | CAMLreturn(Val_int(cp)); 414 | } 415 | 416 | // useful for debugging UTF8, memory b0rkage and such 417 | void sanity_check(const char * msg, value s) 418 | { 419 | const uint8_t * p = Bytes_val(s); 420 | size_t bytes_remaining = caml_string_length(s); 421 | 422 | printf("validating: %s\n", p); 423 | printf("strlen = %d, caml_string_length = %d\n", strlen(p), bytes_remaining); 424 | printf("---------------------------------------------------\n"); 425 | 426 | while (bytes_remaining > 0) 427 | { 428 | uint32_t cp; 429 | const size_t cp_width = utf8_read(p, bytes_remaining, &cp); 430 | if (cp_width == 0) 431 | { 432 | printf("%p: %s\n", p, p); 433 | printf("%s: sanity check failed\n", msg); 434 | *((int *) 0) = 0; // segfault for gdb 435 | caml_failwith("sanity_check: malformed string"); 436 | } 437 | 438 | p += cp_width; 439 | bytes_remaining -= cp_width; 440 | } 441 | } 442 | 443 | CAMLprim value ml_string_unpack(value src) 444 | { 445 | CAMLparam1(src); 446 | CAMLlocal3(fst, prev, next); 447 | 448 | fst = Val_int(0); // represents idris's Nil 449 | 450 | size_t ofs = 0; 451 | size_t bytes_remaining = caml_string_length(src); 452 | 453 | while (bytes_remaining > 0) 454 | { 455 | uint32_t cp; 456 | const size_t cp_width = utf8_read(Bytes_val(src) + ofs, bytes_remaining, &cp); 457 | if (cp_width == 0) 458 | { 459 | caml_failwith("ml_string_unpack: malformed string"); 460 | } 461 | 462 | // special case for the first cell 463 | if (Is_long(fst)) { 464 | fst = caml_alloc(2, 1); // idris's (::) has tag 1 465 | Store_field(fst, 0, Val_int(cp)); 466 | Store_field(fst, 1, Val_int(0)); // points to Nil 467 | 468 | prev = fst; 469 | } else { 470 | next = caml_alloc(2, 1); 471 | Store_field(next, 0, Val_int(cp)); 472 | Store_field(next, 1, Val_int(0)); // points to Nil 473 | 474 | Store_field(prev, 1, next); // point prev->next to next 475 | prev = next; 476 | } 477 | 478 | bytes_remaining -= cp_width; 479 | ofs += cp_width; 480 | } 481 | 482 | CAMLreturn(fst); 483 | } 484 | 485 | CAMLprim value ml_string_pack(value cps) 486 | { 487 | CAMLparam1(cps); 488 | CAMLlocal2(p, dst); 489 | 490 | // first pass: get the total number of bytes 491 | size_t total_width = 0; 492 | for (p = cps; Is_block(p); p = Field(p, 1)) 493 | { 494 | const uint32_t cp = Int_val(Field(p, 0)); 495 | const size_t cp_width = utf8_width(cp); 496 | if (cp_width == 0) 497 | { 498 | caml_failwith("ml_string_pack: code point out of range"); 499 | } 500 | 501 | total_width += cp_width; 502 | } 503 | 504 | // second pass: encode the characters 505 | dst = caml_alloc_string(total_width); 506 | uint8_t * dstp = Bytes_val(dst); // must come after the allocation 507 | for (p = cps; Is_block(p); p = Field(p, 1)) 508 | { 509 | const uint32_t cp = Int_val(Field(p, 0)); 510 | const size_t cp_width = utf8_width(cp); 511 | if (cp_width == 0) 512 | { 513 | caml_failwith("ml_string_pack: impossible: code point out of range despite previous check"); 514 | } 515 | 516 | utf8_write(dstp, cp_width, cp); 517 | dstp += cp_width; 518 | } 519 | 520 | CAMLreturn(dst); 521 | } 522 | 523 | CAMLprim value ml_string_concat(value ss) 524 | { 525 | CAMLparam1(ss); 526 | CAMLlocal3(p, s, dst); 527 | 528 | // first pass: get the total number of bytes 529 | size_t total_width = 0; 530 | for (p = ss; Is_block(p); p = Field(p, 1)) 531 | { 532 | total_width += caml_string_length(Field(p, 0)); 533 | } 534 | 535 | // second pass: copy the strings 536 | dst = caml_alloc_string(total_width); 537 | uint8_t * dstp = Bytes_val(dst); // must come after the allocation 538 | for (p = ss; Is_block(p); p = Field(p, 1)) 539 | { 540 | s = Field(p, 0); 541 | 542 | const uint8_t * srcp = Bytes_val(s); 543 | const size_t width = caml_string_length(s); 544 | 545 | memcpy(dstp, srcp, width); 546 | 547 | dstp += width; 548 | } 549 | 550 | CAMLreturn(dst); 551 | } 552 | 553 | CAMLprim value inspect(value ty, value x) 554 | { 555 | CAMLparam2(ty, x); 556 | inspect_(0, x); 557 | CAMLreturn(Val_int(0)); // return unit 558 | } 559 | 560 | CAMLprim value ml_idris2_getStr(value unit) 561 | { 562 | CAMLparam1(unit); 563 | CAMLlocal1(result); 564 | 565 | char * rptr = idris2_getStr(); 566 | result = caml_copy_string(rptr); 567 | free(rptr); 568 | 569 | CAMLreturn(result); 570 | } 571 | 572 | CAMLprim value ml_idris2_getString(value sptr) 573 | { 574 | CAMLparam1(sptr); 575 | // sptr represents Ptr String 576 | // 577 | // which is either 0L 578 | // or a caml string 579 | // 580 | // since we always need an is_Null check before calling this function 581 | // the former can never be the case 582 | CAMLreturn(sptr); 583 | } 584 | 585 | CAMLprim value ml_idris2_getEnvPair(value i) 586 | { 587 | CAMLparam1(i); 588 | const char * result = idris2_getEnvPair(Int_val(i)); 589 | CAMLreturn((value) result); 590 | } 591 | 592 | CAMLprim value ml_idris2_isNull(value ptr) 593 | { 594 | CAMLparam1(ptr); 595 | const int result = idris2_isNull((void *) ptr); 596 | CAMLreturn(Val_int(result)); 597 | } 598 | 599 | 600 | 601 | 602 | CAMLprim value ml_idris2_putStr(value s) 603 | { 604 | CAMLparam1(s); 605 | idris2_putStr(String_val(s)); 606 | CAMLreturn(Val_int(0)); 607 | } 608 | 609 | CAMLprim value ml_idris2_openFile(value name, value mode) { 610 | CAMLparam2(name, mode); 611 | const FILE* result = idris2_openFile(String_val(name), String_val(mode)); 612 | CAMLreturn((value) result); 613 | } 614 | 615 | CAMLprim value ml_idris2_closeFile(value file) { 616 | CAMLparam1(file); 617 | idris2_closeFile((FILE *) file); 618 | CAMLreturn(Val_int(0)); 619 | } 620 | 621 | CAMLprim value ml_idris2_fileError(value file) { 622 | CAMLparam1(file); 623 | const int result = idris2_fileError((FILE *) file); 624 | CAMLreturn(Val_int(result)); 625 | } 626 | 627 | CAMLprim value ml_idris2_fileErrno(value unit) 628 | { 629 | CAMLparam1(unit); 630 | const int result = idris2_fileErrno(); 631 | CAMLreturn(Val_int(result)); 632 | } 633 | 634 | CAMLprim value ml_idris2_removeFile(value name) { 635 | CAMLparam1(name); 636 | const int result = idris2_removeFile(String_val(name)); 637 | CAMLreturn(Val_int(result)); 638 | } 639 | 640 | CAMLprim value ml_idris2_fileSize(value file) { 641 | CAMLparam1(file); 642 | const int result = idris2_fileSize((FILE *) file); 643 | CAMLreturn(Val_int(result)); 644 | } 645 | 646 | CAMLprim value ml_idris2_fpoll(value file) { 647 | CAMLparam1(file); 648 | const int result = idris2_fpoll((FILE *) file); 649 | CAMLreturn(Val_int(result)); 650 | } 651 | 652 | CAMLprim value ml_idris2_readLine(value file) { 653 | CAMLparam1(file); 654 | CAMLlocal1(result); 655 | 656 | char * rptr = idris2_readLine((FILE *) file); 657 | result = rptr ? caml_copy_string(rptr) : 0; 658 | free(rptr); 659 | 660 | CAMLreturn(result); 661 | } 662 | 663 | CAMLprim value ml_idris2_readChars(value num, value file) { 664 | CAMLparam2(num, file); 665 | CAMLlocal1(result); 666 | 667 | char * rptr = idris2_readChars(Int_val(num), (FILE *) file); 668 | result = rptr ? caml_copy_string(rptr) : 0; 669 | free(rptr); 670 | 671 | CAMLreturn(result); 672 | } 673 | 674 | CAMLprim value ml_idris2_writeLine(value file, value str) { 675 | CAMLparam2(file, str); 676 | const int result = idris2_writeLine((FILE *) file, String_val(str)); 677 | CAMLreturn(Val_int(result)); 678 | } 679 | 680 | CAMLprim value ml_idris2_eof(value file) { 681 | CAMLparam1(file); 682 | const int result = idris2_eof((FILE *)file); 683 | CAMLreturn(Val_int(result)); 684 | } 685 | 686 | CAMLprim value ml_idris2_fileAccessTime(value file) { 687 | CAMLparam1(file); 688 | const int result = idris2_fileAccessTime((FILE *)file); 689 | CAMLreturn(Val_int(result)); 690 | } 691 | 692 | CAMLprim value ml_idris2_fileModifiedTime(value file) { 693 | CAMLparam1(file); 694 | const int result = idris2_fileModifiedTime((FILE *)file); 695 | CAMLreturn(Val_int(result)); 696 | } 697 | 698 | CAMLprim value ml_idris2_fileStatusTime(value file) { 699 | CAMLparam1(file); 700 | const int result = idris2_fileStatusTime((FILE *)file); 701 | CAMLreturn(Val_int(result)); 702 | } 703 | 704 | CAMLprim value ml_idris2_stdin(value unit) { 705 | CAMLparam1(unit); 706 | FILE* result = idris2_stdin(); 707 | CAMLreturn((value) result); 708 | } 709 | 710 | CAMLprim value ml_idris2_stdout(value unit) { 711 | CAMLparam1(unit); 712 | FILE* result = idris2_stdout(); 713 | CAMLreturn((value) result); 714 | } 715 | 716 | CAMLprim value ml_idris2_stderr(value unit) { 717 | CAMLparam1(unit); 718 | FILE* result = idris2_stderr(); 719 | CAMLreturn((value) result); 720 | } 721 | 722 | CAMLprim value ml_idris2_currentDirectory(value unit) { 723 | CAMLparam1(unit); 724 | CAMLlocal1(result); 725 | 726 | char *rptr = idris2_currentDirectory(); 727 | result = rptr ? caml_copy_string(rptr) : 0; 728 | free(rptr); 729 | 730 | CAMLreturn(result); 731 | } 732 | 733 | CAMLprim value ml_idris2_changeDir(value dir) { 734 | CAMLparam1(dir); 735 | const int result = idris2_changeDir(String_val(dir)); 736 | CAMLreturn(Val_int(result)); 737 | } 738 | 739 | CAMLprim value ml_idris2_createDir(value dir) { 740 | CAMLparam1(dir); 741 | const int result = idris2_createDir(String_val(dir)); 742 | CAMLreturn(Val_int(result)); 743 | } 744 | 745 | CAMLprim value ml_idris2_openDir(value dir) { 746 | CAMLparam1(dir); 747 | const void *result = idris2_openDir(String_val(dir)); 748 | CAMLreturn((value) result); 749 | } 750 | 751 | CAMLprim value ml_idris2_closeDir(value dirInfo) { 752 | CAMLparam1(dirInfo); 753 | idris2_closeDir((void *)dirInfo); 754 | CAMLreturn(Val_int(0)); 755 | } 756 | 757 | CAMLprim value ml_idris2_removeDir(value dir) { 758 | CAMLparam1(dir); 759 | const int result = idris2_removeDir(String_val(dir)); 760 | CAMLreturn(Val_int(result)); 761 | } 762 | 763 | CAMLprim value ml_idris2_nextDirEntry(value dirInfo) { 764 | CAMLparam1(dirInfo); 765 | CAMLlocal1(result); 766 | 767 | const char * rptr = idris2_nextDirEntry((void *)dirInfo); 768 | result = rptr ? caml_copy_string(rptr) : 0; 769 | // do NOT free rptr here 770 | 771 | CAMLreturn(result); 772 | } 773 | 774 | /* libc stuff */ 775 | 776 | CAMLprim value ml_getenv(value s) 777 | { 778 | CAMLparam1(s); 779 | CAMLlocal1(result); 780 | 781 | const char * rptr = getenv(String_val(s)); 782 | result = rptr ? caml_copy_string(rptr) : 0; 783 | // do NOT free rptr 784 | 785 | CAMLreturn(result); 786 | } 787 | 788 | CAMLprim value ml_system(value s) 789 | { 790 | CAMLparam1(s); 791 | const int result = system(String_val(s)); 792 | CAMLreturn(Val_int(result)); 793 | } 794 | 795 | CAMLprim value ml_exit(value s) 796 | { 797 | CAMLparam1(s); 798 | exit(Int_val(s)); 799 | CAMLreturn(Val_int(0)); 800 | } 801 | 802 | CAMLprim value ml_fflush(value file) 803 | { 804 | CAMLparam1(file); 805 | const int result = fflush((FILE *)file); 806 | CAMLreturn(Val_int(result)); 807 | } 808 | 809 | CAMLprim value ml_fdopen(value fd, value mode) 810 | { 811 | CAMLparam2(fd, mode); 812 | FILE * result = fdopen(Int_val(fd), String_val(mode)); 813 | CAMLreturn((value) result); 814 | } 815 | 816 | CAMLprim value ml_chmod(value path, value mode) 817 | { 818 | CAMLparam2(path, mode); 819 | const int result = chmod(String_val(path), Int_val(mode)); 820 | CAMLreturn(Val_int(result)); 821 | } 822 | 823 | CAMLprim value ml_putchar(value c) 824 | { 825 | CAMLparam1(c); 826 | const int result = putchar(Int_val(c)); 827 | CAMLreturn(Val_int(result)); 828 | } 829 | 830 | CAMLprim value ml_getchar(value unit) 831 | { 832 | CAMLparam1(unit); 833 | const int result = getchar(); 834 | CAMLreturn(Val_int(result)); 835 | } 836 | 837 | CAMLprim value ml_strlen(value str) 838 | { 839 | CAMLparam1(str); 840 | size_t len = strlen(String_val(str)); 841 | CAMLreturn(Val_int(len)); 842 | } 843 | 844 | CAMLprim value ml_fgetc(value fptr) 845 | { 846 | CAMLparam1(fptr); 847 | CAMLreturn(Val_int(fgetc((FILE *)fptr))); 848 | } 849 | 850 | /* buffer stuff */ 851 | 852 | CAMLprim value ml_idris2_newBuffer(value size) 853 | { 854 | CAMLparam1(size); 855 | CAMLlocal1(result); 856 | result = caml_alloc_string(Int_val(size)); 857 | CAMLreturn(result); 858 | } 859 | 860 | CAMLprim value ml_idris2_freeBuffer(value buffer) 861 | { 862 | CAMLparam1(buffer); 863 | // nothing to do 864 | CAMLreturn(Val_int(0)); 865 | } 866 | 867 | CAMLprim value ml_idris2_getBufferSize(value buffer) 868 | { 869 | CAMLparam1(buffer); 870 | const int result = caml_string_length(buffer); 871 | CAMLreturn(Val_int(result)); 872 | } 873 | 874 | CAMLprim value ml_idris2_setBufferByte(value buffer, value loc, value val) 875 | { 876 | CAMLparam3(buffer, loc, val); 877 | ((uint8_t *) Bytes_val(buffer))[Int_val(loc)] = (uint8_t) Int_val(val); 878 | CAMLreturn(Val_int(0)); 879 | } 880 | 881 | CAMLprim value ml_idris2_setBufferInt(value buffer, value loc, value val) 882 | { 883 | CAMLparam3(buffer, loc, val); 884 | int64_t iv = Int_val(val); 885 | memcpy(Bytes_val(buffer) + Int_val(loc), &iv, sizeof(iv)); 886 | CAMLreturn(Val_int(0)); 887 | } 888 | 889 | CAMLprim value ml_idris2_setBufferBits8(value buffer, value loc, value val) 890 | { 891 | CAMLparam3(buffer, loc, val); 892 | int8_t iv = Int_val(val); 893 | memcpy(Bytes_val(buffer) + Int_val(loc), &iv, sizeof(iv)); 894 | CAMLreturn(Val_int(0)); 895 | } 896 | 897 | CAMLprim value ml_idris2_setBufferBits16(value buffer, value loc, value val) 898 | { 899 | CAMLparam3(buffer, loc, val); 900 | int16_t iv = Int_val(val); 901 | memcpy(Bytes_val(buffer) + Int_val(loc), &iv, sizeof(iv)); 902 | CAMLreturn(Val_int(0)); 903 | } 904 | 905 | CAMLprim value ml_idris2_setBufferBits32(value buffer, value loc, value val) 906 | { 907 | CAMLparam3(buffer, loc, val); 908 | int32_t iv = Int_val(val); 909 | memcpy(Bytes_val(buffer) + Int_val(loc), &iv, sizeof(iv)); 910 | CAMLreturn(Val_int(0)); 911 | } 912 | 913 | CAMLprim value ml_idris2_setBufferBits64(value buffer, value loc, value val) 914 | { 915 | CAMLparam3(buffer, loc, val); 916 | int64_t iv = Int64_val(val); 917 | memcpy(Bytes_val(buffer) + Int_val(loc), &iv, sizeof(iv)); 918 | CAMLreturn(Val_int(0)); 919 | } 920 | 921 | 922 | CAMLprim value ml_idris2_setBufferDouble(value buffer, value loc, value val) 923 | { 924 | CAMLparam3(buffer, loc, val); 925 | double dv = Double_val(val); 926 | memcpy(Bytes_val(buffer) + Int_val(loc), &dv, sizeof(dv)); 927 | CAMLreturn(Val_int(0)); 928 | } 929 | 930 | CAMLprim value ml_idris2_setBufferString(value buffer, value loc, value val) 931 | { 932 | CAMLparam3(buffer, loc, val); 933 | memcpy(Bytes_val(buffer) + Int_val(loc), String_val(val), strlen(String_val(val))); 934 | CAMLreturn(Val_int(0)); 935 | } 936 | 937 | CAMLprim value ml_idris2_copyBuffer(value from, value start, value len, value to, value loc) 938 | { 939 | CAMLparam5(from,start,len,to,loc); 940 | memcpy(Bytes_val(to) + Int_val(loc), Bytes_val(from) + Int_val(start), Int_val(len)); 941 | CAMLreturn(Val_int(0)); 942 | } 943 | 944 | CAMLprim value ml_idris2_readBufferData(value file, value buffer, value loc, value max) 945 | { 946 | CAMLparam4(file, buffer, loc, max); 947 | const size_t result = fread(Bytes_val(buffer) + Int_val(loc), 1, Int_val(max), (FILE *) file); 948 | CAMLreturn(Val_int(result)); 949 | } 950 | 951 | CAMLprim value ml_idris2_writeBufferData(value file, value buffer, value loc, value len) 952 | { 953 | CAMLparam4(file, buffer, loc, len); 954 | const size_t result = fwrite(Bytes_val(buffer) + Int_val(loc), 1, Int_val(len), (FILE *) file); 955 | CAMLreturn(Val_int(result)); 956 | } 957 | 958 | CAMLprim value ml_idris2_getBufferByte(value buffer, value loc) 959 | { 960 | CAMLparam2(buffer, loc); 961 | const uint8_t result = ((uint8_t *) Bytes_val(buffer))[Int_val(loc)]; 962 | CAMLreturn(Val_int(result)); 963 | } 964 | 965 | CAMLprim value ml_idris2_getBufferInt(value buffer, value loc) 966 | { 967 | CAMLparam2(buffer, loc); 968 | int64_t iv; 969 | memcpy(&iv, Bytes_val(buffer) + Int_val(loc), sizeof(iv)); 970 | CAMLreturn(Val_int(iv)); 971 | } 972 | 973 | CAMLprim value ml_idris2_getBufferBits8(value buffer, value loc) 974 | { 975 | CAMLparam2(buffer, loc); 976 | int8_t iv; 977 | memcpy(&iv, Bytes_val(buffer) + Int_val(loc), sizeof(iv)); 978 | CAMLreturn(Val_int(iv)); 979 | } 980 | 981 | CAMLprim value ml_idris2_getBufferBits16(value buffer, value loc) 982 | { 983 | CAMLparam2(buffer, loc); 984 | int16_t iv; 985 | memcpy(&iv, Bytes_val(buffer) + Int_val(loc), sizeof(iv)); 986 | CAMLreturn(Val_int(iv)); 987 | } 988 | 989 | CAMLprim value ml_idris2_getBufferBits32(value buffer, value loc) 990 | { 991 | CAMLparam2(buffer, loc); 992 | int32_t iv; 993 | memcpy(&iv, Bytes_val(buffer) + Int_val(loc), sizeof(iv)); 994 | CAMLreturn(Val_int(iv)); 995 | } 996 | 997 | CAMLprim value ml_idris2_getBufferBits64(value buffer, value loc) 998 | { 999 | CAMLparam2(buffer, loc); 1000 | int64_t iv; 1001 | memcpy(&iv, Bytes_val(buffer) + Int_val(loc), sizeof(iv)); 1002 | CAMLreturn(caml_copy_int64(iv)); 1003 | } 1004 | 1005 | CAMLprim value ml_idris2_getBufferDouble(value buffer, value loc) 1006 | { 1007 | CAMLparam2(buffer, loc); 1008 | CAMLlocal1(result); 1009 | 1010 | double dv; 1011 | memcpy(&dv, Bytes_val(buffer) + Int_val(loc), sizeof(dv)); 1012 | result = caml_copy_double(dv); 1013 | 1014 | CAMLreturn(result); 1015 | } 1016 | 1017 | CAMLprim value ml_idris2_getBufferString(value src, value ofs, value max_width) 1018 | { 1019 | CAMLparam3(src, ofs, max_width); 1020 | CAMLlocal1(dst); 1021 | 1022 | // idris2_getBufferString uses strncpy so we have to find where the NUL terminator is 1023 | const size_t nbytes = strnlen(Bytes_val(src) + Int_val(ofs), Int_val(max_width)); 1024 | dst = caml_alloc_string(nbytes); // ocaml null-terminates all strings 1025 | memcpy(Bytes_val(dst), Bytes_val(src) + Int_val(ofs), nbytes); 1026 | 1027 | CAMLreturn(dst); 1028 | } 1029 | 1030 | /* Idrnet */ 1031 | 1032 | CAMLprim value ml_idrnet_malloc(value size) 1033 | { 1034 | CAMLparam1(size); 1035 | void * result = idrnet_malloc(Val_int(size)); 1036 | CAMLreturn((value) result); 1037 | } 1038 | 1039 | CAMLprim value ml_idrnet_free(value buffer) 1040 | { 1041 | CAMLparam1(buffer); 1042 | idrnet_free((void *) buffer); 1043 | CAMLreturn(Val_int(0)); 1044 | } 1045 | 1046 | CAMLprim value ml_idrnet_peek(value buffer, value loc) 1047 | { 1048 | CAMLparam2(buffer, loc); 1049 | // TODO 1050 | CAMLreturn(Val_int(0)); 1051 | } 1052 | CAMLprim value ml_idrnet_poke(value buffer, value loc, value val) 1053 | { 1054 | CAMLparam3(buffer, loc, val); 1055 | // TODO 1056 | CAMLreturn(Val_int(0)); 1057 | } 1058 | 1059 | CAMLprim value ml_idrnet_errno() 1060 | { 1061 | CAMLparam0(); 1062 | 1063 | const int errno = idrnet_errno(); 1064 | 1065 | CAMLreturn(Val_int(errno)); 1066 | } 1067 | 1068 | CAMLprim value ml_idrnet_socket(value domain, value type, value protocol) 1069 | { 1070 | CAMLparam3(domain, type, protocol); 1071 | // TODO 1072 | CAMLreturn(Val_int(0)); 1073 | } 1074 | 1075 | CAMLprim value ml_idrnet_bind(value sockfd, value family, value socket_type, value host, value port) 1076 | { 1077 | CAMLparam5(sockfd, family, socket_type, host, port); 1078 | // TODO 1079 | CAMLreturn(Val_int(0)); 1080 | } 1081 | 1082 | CAMLprim value ml_idrnet_getsockname(value sockfd, value address, value len) 1083 | { 1084 | CAMLparam3(sockfd, address, len); 1085 | value result = Val_int(0); 1086 | CAMLreturn(result); 1087 | } 1088 | 1089 | CAMLprim value ml_idrnet_connect(value sockfd, value family, value socket_type, value host, value port) 1090 | { 1091 | CAMLparam5(sockfd, family, socket_type, host, port); 1092 | value result = Val_int(0); 1093 | CAMLreturn(result); 1094 | } 1095 | 1096 | CAMLprim value ml_idrnet_sockaddr_family(value sockaddr) 1097 | { 1098 | CAMLparam1(sockaddr); 1099 | value result = Val_int(0); 1100 | CAMLreturn(result); 1101 | } 1102 | 1103 | CAMLprim value ml_idrnet_sockaddr_ipv4(value sockaddr) 1104 | { 1105 | CAMLparam1(sockaddr); 1106 | value result = Val_int(0); 1107 | CAMLreturn(result); 1108 | } 1109 | CAMLprim value ml_idrnet_sockaddr_ipv4_port(value sockaddr) 1110 | { 1111 | CAMLparam1(sockaddr); 1112 | value result = Val_int(0); 1113 | CAMLreturn(result); 1114 | } 1115 | CAMLprim value ml_idrnet_create_sockaddr() 1116 | { 1117 | CAMLparam0(); 1118 | value result = Val_int(0); 1119 | CAMLreturn(result); 1120 | } 1121 | 1122 | CAMLprim value ml_idrnet_accept(value sockaddr) 1123 | { 1124 | CAMLparam1(sockaddr); 1125 | value result = Val_int(0); 1126 | CAMLreturn(result); 1127 | } 1128 | 1129 | CAMLprim value ml_idrnet_send(value sockfd, value data) 1130 | { 1131 | CAMLparam2(sockfd, data); 1132 | value result = Val_int(0); 1133 | CAMLreturn(result); 1134 | } 1135 | 1136 | CAMLprim value ml_idrnet_send_buf(value sockfd, value data, value len) 1137 | { 1138 | CAMLparam3(sockfd, data, len); 1139 | value result = Val_int(0); 1140 | CAMLreturn(result); 1141 | } 1142 | 1143 | CAMLprim value ml_idrnet_recv(value sockfd, value len) 1144 | { 1145 | CAMLparam2(sockfd, len); 1146 | value result = Val_int(0); 1147 | CAMLreturn(result); 1148 | } 1149 | 1150 | CAMLprim value ml_idrnet_recv_buf(value sockfd, value buf, value len) 1151 | { 1152 | CAMLparam3(sockfd, buf, len); 1153 | value result = Val_int(0); 1154 | CAMLreturn(result); 1155 | } 1156 | 1157 | CAMLprim value ml_idrnet_sendto(value sockfd, value data, value host, value port, value family) 1158 | { 1159 | CAMLparam5(sockfd, data, host, port, family); 1160 | value result = Val_int(0); 1161 | CAMLreturn(result); 1162 | } 1163 | 1164 | CAMLprim value ml_idrnet_sendto_buf_native(value sockfd, value buf, value len, value host, value port, value family) 1165 | { 1166 | CAMLparam5(sockfd, buf, len, host, port); 1167 | CAMLxparam1(family); 1168 | value result = Val_int(0); 1169 | CAMLreturn(result); 1170 | } 1171 | 1172 | CAMLprim value ml_idrnet_sendto_buf_bytecode(value * argv, int argn ) 1173 | { 1174 | // TODO: Assert argn == 6? 1175 | return ml_idrnet_sendto_buf_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); 1176 | } 1177 | 1178 | CAMLprim value ml_idrnet_recvfrom(value sockfd, value len) 1179 | { 1180 | CAMLparam2(sockfd, len); 1181 | value result = Val_int(0); 1182 | CAMLreturn(result); 1183 | } 1184 | CAMLprim value ml_idrnet_recvfrom_buf(value sockfd, value buf, value len) 1185 | { 1186 | CAMLparam3(sockfd, buf, len); 1187 | value result = Val_int(0); 1188 | CAMLreturn(result); 1189 | } 1190 | 1191 | CAMLprim value ml_idrnet_get_recv_res(value res_struct) 1192 | { 1193 | CAMLparam1(res_struct); 1194 | value result = Val_int(0); 1195 | CAMLreturn(result); 1196 | } 1197 | CAMLprim value ml_idrnet_get_recv_payload(value res_struct) 1198 | { 1199 | CAMLparam1(res_struct); 1200 | value result = Val_int(0); 1201 | CAMLreturn(result); 1202 | } 1203 | CAMLprim value ml_idrnet_free_recv_struct(value res_struct) 1204 | { 1205 | CAMLparam1(res_struct); 1206 | value result = Val_int(0); 1207 | CAMLreturn(result); 1208 | } 1209 | 1210 | CAMLprim value ml_idrnet_get_recvfrom_res(value res_struct) 1211 | { 1212 | CAMLparam1(res_struct); 1213 | value result = Val_int(0); 1214 | CAMLreturn(result); 1215 | } 1216 | CAMLprim value ml_idrnet_get_recvfrom_payload(value res_struct) 1217 | { 1218 | CAMLparam1(res_struct); 1219 | value result = Val_int(0); 1220 | CAMLreturn(result); 1221 | } 1222 | CAMLprim value ml_idrnet_get_recvfrom_sockaddr(value res_struct) 1223 | { 1224 | CAMLparam1(res_struct); 1225 | value result = Val_int(0); 1226 | CAMLreturn(result); 1227 | } 1228 | 1229 | CAMLprim value ml_idrnet_free_recvfrom_struct(value res_struct) 1230 | { 1231 | CAMLparam1(res_struct); 1232 | value result = Val_int(0); 1233 | CAMLreturn(result); 1234 | } 1235 | 1236 | CAMLprim value ml_idrnet_geteagain() 1237 | { 1238 | CAMLparam0(); 1239 | value result = Val_int(0); 1240 | CAMLreturn(result); 1241 | } 1242 | 1243 | CAMLprim value ml_idris2_listen(value socket, value backlog) 1244 | { 1245 | CAMLparam2(socket, backlog); 1246 | const int result = listen(socket, backlog); 1247 | CAMLreturn(Val_int(result)); 1248 | } 1249 | 1250 | CAMLprim value ml_idris2_setupTerm(value world) 1251 | { 1252 | CAMLparam1(world); 1253 | idris2_setupTerm(); 1254 | CAMLreturn(Val_int(0)); // unit 1255 | } 1256 | 1257 | CAMLprim value ml_idris2_getTermCols(value world) 1258 | { 1259 | CAMLparam1(world); 1260 | int ncols = idris2_getTermCols(); 1261 | CAMLreturn(Val_int(ncols)); 1262 | } 1263 | 1264 | CAMLprim value ml_idris2_getTermLines(value world) 1265 | { 1266 | CAMLparam1(world); 1267 | int nlines = idris2_getTermLines(); 1268 | CAMLreturn(Val_int(nlines)); 1269 | } 1270 | 1271 | // external clocktime_gc_cpu : world -> os_clock = "ml_clocktime_gc_cpu" 1272 | 1273 | CAMLprim value ml_clocktime_gc_cpu(value world) 1274 | { 1275 | CAMLparam1(world); 1276 | CAMLreturn((value) NULL); 1277 | } 1278 | 1279 | // external clocktime_gc_real : world -> os_clock = "ml_clocktime_gc_real" 1280 | 1281 | CAMLprim value ml_clocktime_gc_real(value world) 1282 | { 1283 | CAMLparam1(world); 1284 | CAMLreturn((value) NULL); 1285 | } 1286 | 1287 | // external clocktime_monotonic : world -> os_clock = "ml_clocktime_monotonic" 1288 | 1289 | CAMLprim value ml_clocktime_monotonic(value world) 1290 | { 1291 | CAMLparam1(world); 1292 | struct timespec ts = {}; 1293 | int res = clock_gettime(CLOCK_MONOTONIC, &ts); 1294 | if (res < 0) { 1295 | CAMLreturn((value) NULL); 1296 | } 1297 | 1298 | CAMLlocal1(result); 1299 | result = caml_alloc_string(Int_val(sizeof(ts))); 1300 | 1301 | memcpy(Bytes_val(result), &ts, sizeof(ts)); 1302 | 1303 | CAMLreturn(result); 1304 | } 1305 | 1306 | // external clocktime_process : world -> os_clock = "ml_clocktime_process" 1307 | 1308 | CAMLprim value ml_clocktime_process(value world) 1309 | { 1310 | CAMLparam1(world); 1311 | struct timespec ts = {}; 1312 | int res = clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &ts); 1313 | if (res < 0) { 1314 | CAMLreturn((value) NULL); 1315 | } 1316 | 1317 | CAMLlocal1(result); 1318 | result = caml_alloc_string(Int_val(sizeof(ts))); 1319 | 1320 | memcpy(Bytes_val(result), &ts, sizeof(ts)); 1321 | 1322 | CAMLreturn(result); 1323 | } 1324 | 1325 | // external clocktime_thread : world -> os_clock = "ml_clocktime_thread" 1326 | 1327 | CAMLprim value ml_clocktime_thread(value world) 1328 | { 1329 | CAMLparam1(world); 1330 | struct timespec ts = {}; 1331 | int res = clock_gettime(CLOCK_THREAD_CPUTIME_ID, &ts); 1332 | if (res < 0) { 1333 | CAMLreturn((value) NULL); 1334 | } 1335 | 1336 | CAMLlocal1(result); 1337 | result = caml_alloc_string(Int_val(sizeof(ts))); 1338 | 1339 | memcpy(Bytes_val(result), &ts, sizeof(ts)); 1340 | 1341 | CAMLreturn(result); 1342 | } 1343 | 1344 | 1345 | // external clocktime_utc : world -> os_clock = "ml_clocktime_utc" 1346 | 1347 | CAMLprim value ml_clocktime_utc(value world) 1348 | { 1349 | CAMLparam1(world); 1350 | time_t sec = time(NULL); 1351 | if ((long) sec == 0) { 1352 | CAMLreturn((value) NULL); 1353 | } 1354 | 1355 | struct timespec ts = {}; 1356 | ts.tv_sec = sec; 1357 | ts.tv_nsec = 0; 1358 | 1359 | CAMLlocal1(result); 1360 | result = caml_alloc_string(Int_val(sizeof(ts))); 1361 | 1362 | memcpy(Bytes_val(result), &ts, sizeof(ts)); 1363 | 1364 | CAMLreturn(result); 1365 | } 1366 | 1367 | // external os_clock_nanosecond : os_clock -> world -> int64 = "ml_os_clock_nanosecond" 1368 | 1369 | CAMLprim value ml_os_clock_nanosecond(value clock) 1370 | { 1371 | CAMLparam1(clock); 1372 | 1373 | if ((void *) clock == NULL) { 1374 | CAMLreturn(caml_copy_int64(0)); 1375 | } 1376 | 1377 | struct timespec ts = {}; 1378 | 1379 | memcpy(&ts, Bytes_val(clock), sizeof(ts)); 1380 | 1381 | CAMLreturn(caml_copy_int64(ts.tv_nsec)); 1382 | } 1383 | 1384 | // external os_clock_second : os_clock -> world -> int64 = "ml_os_clock_second" 1385 | 1386 | CAMLprim value ml_os_clock_second(value clock) 1387 | { 1388 | CAMLparam1(clock); 1389 | 1390 | if ((void *) clock == NULL) { 1391 | CAMLreturn(caml_copy_int64(0)); 1392 | } 1393 | 1394 | struct timespec ts = {}; 1395 | 1396 | memcpy(&ts, Bytes_val(clock), sizeof(ts)); 1397 | 1398 | CAMLreturn(caml_copy_int64(ts.tv_sec)); 1399 | } 1400 | 1401 | // external os_clock_valid : os_clock -> world -> int = "ml_os_clock_valid" 1402 | 1403 | CAMLprim value ml_os_clock_valid(value clock) 1404 | { 1405 | CAMLparam1(clock); 1406 | 1407 | if ((void *) clock == NULL) { 1408 | CAMLreturn(Val_int(0)); 1409 | } else { 1410 | CAMLreturn(Val_int(1)); 1411 | } 1412 | } 1413 | --------------------------------------------------------------------------------