mirror of
https://github.com/edwinb/Idris2-boot.git
synced 2024-09-11 16:05:51 +03:00
Remove chicken back end
(Which was commented out anyway) Three scheme back ends is enough to maintain, and Gambit does the same job as chicken (fast startup of the interpreter, generating via C) but seems to deal with the code Idris generates better.
This commit is contained in:
parent
e14f8e1ac9
commit
15c6a0d137
2
Makefile
2
Makefile
@ -141,11 +141,9 @@ install-fromc: all-fromc install-all
|
||||
|
||||
install-support:
|
||||
mkdir -p ${PREFIX}/idris2-${IDRIS2_VERSION}/support/chez
|
||||
mkdir -p ${PREFIX}/idris2-${IDRIS2_VERSION}/support/chicken
|
||||
mkdir -p ${PREFIX}/idris2-${IDRIS2_VERSION}/support/racket
|
||||
mkdir -p ${PREFIX}/idris2-${IDRIS2_VERSION}/support/gambit
|
||||
install support/chez/* ${PREFIX}/idris2-${IDRIS2_VERSION}/support/chez
|
||||
install support/chicken/* ${PREFIX}/idris2-${IDRIS2_VERSION}/support/chicken
|
||||
install support/racket/* ${PREFIX}/idris2-${IDRIS2_VERSION}/support/racket
|
||||
install support/gambit/* ${PREFIX}/idris2-${IDRIS2_VERSION}/support/gambit
|
||||
|
||||
|
@ -7,7 +7,6 @@ modules =
|
||||
Compiler.Inline,
|
||||
Compiler.LambdaLift,
|
||||
Compiler.Scheme.Chez,
|
||||
-- Compiler.Scheme.Chicken,
|
||||
Compiler.Scheme.Racket,
|
||||
Compiler.Scheme.Gambit,
|
||||
Compiler.Scheme.Common,
|
||||
|
@ -1,112 +0,0 @@
|
||||
module Compiler.Scheme.Chicken
|
||||
|
||||
import Compiler.Common
|
||||
import Compiler.CompileExpr
|
||||
import Compiler.Inline
|
||||
import Compiler.Scheme.Common
|
||||
|
||||
import Core.Context
|
||||
import Core.Directory
|
||||
import Core.Name
|
||||
import Core.Options
|
||||
import Core.TT
|
||||
|
||||
import Utils.Hex
|
||||
|
||||
import Data.NameMap
|
||||
import Data.Vect
|
||||
import System
|
||||
import System.Info
|
||||
|
||||
%default covering
|
||||
|
||||
findCSI : IO String
|
||||
findCSI =
|
||||
do env <- getEnv "CHICKEN_CSI"
|
||||
pure $ fromMaybe "/usr/bin/env -S csi" env
|
||||
|
||||
findCSC : IO String
|
||||
findCSC =
|
||||
do env <- getEnv "CHICKEN_CSC"
|
||||
pure $ fromMaybe "/usr/bin/env -S csc" env
|
||||
|
||||
schHeader : List String -> String
|
||||
schHeader ds
|
||||
= "(use numbers)\n" ++ unlines ds ++ "\n" ++
|
||||
"(let ()\n"
|
||||
|
||||
schFooter : String
|
||||
schFooter = ")"
|
||||
|
||||
showChickenChar : Char -> String -> String
|
||||
showChickenChar '\\' = ("\\\\" ++)
|
||||
showChickenChar c
|
||||
= if c < chr 32 || c > chr 126
|
||||
then (("\\u" ++ pad (asHex (cast c))) ++)
|
||||
else strCons c
|
||||
where
|
||||
pad : String -> String
|
||||
pad str
|
||||
= case isLTE (length str) 4 of
|
||||
Yes _ => cast (List.replicate (4 - length str) '0') ++ str
|
||||
No _ => str
|
||||
|
||||
showChickenString : List Char -> String -> String
|
||||
showChickenString [] = id
|
||||
showChickenString ('"'::cs) = ("\\\"" ++) . showChickenString cs
|
||||
showChickenString (c ::cs) = (showChickenChar c) . showChickenString cs
|
||||
|
||||
chickenString : String -> String
|
||||
chickenString cs = strCons '"' (showChickenString (unpack cs) "\"")
|
||||
|
||||
mutual
|
||||
chickenPrim : Int -> SVars vars -> ExtPrim -> List (CExp vars) -> Core String
|
||||
chickenPrim i vs CCall [ret, fn, args, world]
|
||||
= throw (InternalError ("Can't compile C FFI calls to Chicken Scheme yet"))
|
||||
chickenPrim i vs SysCodegen []
|
||||
= pure $ "\"chicken\""
|
||||
chickenPrim i vs prim args
|
||||
= schExtCommon chickenPrim chickenString i vs prim args
|
||||
|
||||
compileToSCM : Ref Ctxt Defs ->
|
||||
ClosedTerm -> (outfile : String) -> Core ()
|
||||
compileToSCM c tm outfile
|
||||
= do ds <- getDirectives Chicken
|
||||
(ns, tags) <- findUsedNames tm
|
||||
defs <- get Ctxt
|
||||
compdefs <- traverse (getScheme chickenPrim chickenString defs) ns
|
||||
let code = concat compdefs
|
||||
main <- schExp chickenPrim chickenString 0 [] !(compileExp tags tm)
|
||||
support <- readDataFile "chicken/support.scm"
|
||||
let scm = schHeader ds ++ support ++ code ++ main ++ schFooter
|
||||
Right () <- coreLift $ writeFile outfile scm
|
||||
| Left err => throw (FileErr outfile err)
|
||||
coreLift $ chmod outfile 0o755
|
||||
pure ()
|
||||
|
||||
compileExpr : Ref Ctxt Defs -> (execDir : String) ->
|
||||
ClosedTerm -> (outfile : String) -> Core (Maybe String)
|
||||
compileExpr c execDir tm outfile
|
||||
= do tmp <- coreLift $ tmpName
|
||||
let outn = tmp ++ ".scm"
|
||||
compileToSCM c tm outn
|
||||
csc <- coreLift findCSC
|
||||
ok <- coreLift $ system (csc ++ " " ++ outn ++ " -o " ++ outfile)
|
||||
if ok == 0
|
||||
then pure (Just outfile)
|
||||
else pure Nothing
|
||||
|
||||
executeExpr : Ref Ctxt Defs -> (execDir : String) -> ClosedTerm -> Core ()
|
||||
executeExpr c execDir tm
|
||||
= do tmp <- coreLift $ tmpName
|
||||
let outn = tmp ++ ".scm"
|
||||
compileToSCM c tm outn
|
||||
csi <- coreLift findCSI
|
||||
coreLift $ system (csi ++ " -s " ++ outn)
|
||||
pure ()
|
||||
|
||||
export
|
||||
codegenChicken : Codegen
|
||||
codegenChicken = MkCG compileExpr executeExpr
|
||||
|
||||
|
@ -33,14 +33,12 @@ toString (MkDirs wdir sdir bdir edir dfix edirs ldirs ddirs) =
|
||||
|
||||
public export
|
||||
data CG = Chez
|
||||
| Chicken
|
||||
| Racket
|
||||
| Gambit
|
||||
|
||||
export
|
||||
Eq CG where
|
||||
Chez == Chez = True
|
||||
Chicken == Chicken = True
|
||||
Racket == Racket = True
|
||||
Gambit == Gambit = True
|
||||
_ == _ = False
|
||||
@ -49,7 +47,6 @@ export
|
||||
availableCGs : List (String, CG)
|
||||
availableCGs
|
||||
= [("chez", Chez),
|
||||
("chicken", Chicken),
|
||||
("racket", Racket),
|
||||
("gambit", Gambit)]
|
||||
|
||||
|
@ -716,14 +716,12 @@ TTC CDef where
|
||||
export
|
||||
TTC CG where
|
||||
toBuf b Chez = tag 0
|
||||
toBuf b Chicken = tag 1
|
||||
toBuf b Racket = tag 2
|
||||
toBuf b Gambit = tag 3
|
||||
|
||||
fromBuf b
|
||||
= case !getTag of
|
||||
0 => pure Chez
|
||||
1 => pure Chicken
|
||||
2 => pure Racket
|
||||
3 => pure Gambit
|
||||
_ => corrupt "CG"
|
||||
|
@ -1,7 +1,6 @@
|
||||
module Idris.IDEMode.REPL
|
||||
|
||||
import Compiler.Scheme.Chez
|
||||
-- import Compiler.Scheme.Chicken
|
||||
import Compiler.Scheme.Racket
|
||||
import Compiler.Scheme.Gambit
|
||||
import Compiler.Common
|
||||
|
@ -1,7 +1,6 @@
|
||||
module Idris.REPL
|
||||
|
||||
import Compiler.Scheme.Chez
|
||||
-- import Compiler.Scheme.Chicken
|
||||
import Compiler.Scheme.Racket
|
||||
import Compiler.Scheme.Gambit
|
||||
import Compiler.Common
|
||||
@ -242,8 +241,6 @@ findCG
|
||||
= do defs <- get Ctxt
|
||||
case codegen (session (options defs)) of
|
||||
Chez => pure codegenChez
|
||||
Chicken => throw (InternalError "Chicken CG not available")
|
||||
-- pure codegenChicken
|
||||
Racket => pure codegenRacket
|
||||
Gambit => pure codegenGambit
|
||||
|
||||
|
@ -1,143 +0,0 @@
|
||||
(define blodwen-read-args (lambda (desc)
|
||||
(case (vector-ref desc 0)
|
||||
((0) '())
|
||||
((1) (cons (vector-ref desc 2)
|
||||
(blodwen-read-args (vector-ref desc 3)))))))
|
||||
(define b+ (lambda (x y bits) (remainder (+ x y) (expt 2 bits))))
|
||||
(define b- (lambda (x y bits) (remainder (- x y) (expt 2 bits))))
|
||||
(define b* (lambda (x y bits) (remainder (* x y) (expt 2 bits))))
|
||||
(define b/ (lambda (x y bits) (remainder (exact-floor (/ x y)) (expt 2 bits))))
|
||||
|
||||
(define blodwen-shl (lambda (x y) (arithmetic-shift x y)))
|
||||
(define blodwen-shr (lambda (x y) (arithmetic-shift x (- y))))
|
||||
(define blodwen-and (lambda (x y) (bitwise-and x y)))
|
||||
(define blodwen-or (lambda (x y) (bitwise-or x y)))
|
||||
(define blodwen-xor (lambda (x y) (bitwise-xor x y)))
|
||||
|
||||
(define cast-num
|
||||
(lambda (x)
|
||||
(if (number? x) x 0)))
|
||||
(define destroy-prefix
|
||||
(lambda (x)
|
||||
(cond
|
||||
((equal? x "") "")
|
||||
((equal? (string-ref x 0) #\#) "")
|
||||
(else x))))
|
||||
(define cast-string-int
|
||||
(lambda (x)
|
||||
(floor (cast-num (string->number (destroy-prefix x))))))
|
||||
(define exact-floor
|
||||
(lambda (x)
|
||||
(inexact->exact (floor x))))
|
||||
(define cast-string-double
|
||||
(lambda (x)
|
||||
(cast-num (string->number (destroy-prefix x)))))
|
||||
(define string-cons (lambda (x y) (string-append (string x) y)))
|
||||
(define get-tag (lambda (x) (vector-ref x 0)))
|
||||
(define string-reverse (lambda (x)
|
||||
(list->string (reverse (string->list x)))))
|
||||
(define (string-substr off len s)
|
||||
(let* ((l (string-length s))
|
||||
(b (max 0 off))
|
||||
(x (max 0 len))
|
||||
(end (min l (+ b x))))
|
||||
(substring s b end)))
|
||||
|
||||
(define either-left
|
||||
(lambda (x)
|
||||
(vector 0 #f #f x)))
|
||||
|
||||
(define either-right
|
||||
(lambda (x)
|
||||
(vector 1 #f #f x)))
|
||||
|
||||
(define blodwen-error-quit
|
||||
(lambda (msg)
|
||||
(display msg)
|
||||
(newline)
|
||||
(exit 1)))
|
||||
|
||||
;; Files: Much of the following adapted from idris-chez, thanks to Niklas
|
||||
;; Larsson
|
||||
|
||||
;; All the file operations are implemented as primitives which return
|
||||
;; Either Int x, where the Int is an error code
|
||||
|
||||
;; If the file operation raises an error, catch it and return an appropriate
|
||||
;; error code
|
||||
(define (blodwen-file-op op)
|
||||
(handle-exceptions exn
|
||||
(begin (either-left 255)) ; TODO: Calculate proper code!
|
||||
(either-right (op))))
|
||||
|
||||
(define (blodwen-get-n n p)
|
||||
(if (input-port? p) (get-string-n p n) ""))
|
||||
|
||||
(define (blodwen-putstring p s)
|
||||
(if (output-port? p) (put-string p s) void)
|
||||
0)
|
||||
|
||||
(define (blodwen-open file mode bin)
|
||||
(cond
|
||||
((string=? mode "r") (open-input-file file))
|
||||
((string=? mode "w") (open-output-file file))
|
||||
(else (abort "I haven't worked that one out yet, sorry..."))))
|
||||
|
||||
(define (blodwen-close-port p)
|
||||
(cond
|
||||
((input-port? p) (close-input-port p))
|
||||
((output-port? p) (close-output-port p))))
|
||||
|
||||
(define (blodwen-get-line p)
|
||||
(if (port? p)
|
||||
(let ((str (read-line p)))
|
||||
(if (eof-object? str)
|
||||
""
|
||||
str))
|
||||
void))
|
||||
|
||||
(define (blodwen-get-char p)
|
||||
(if (port? p)
|
||||
(let ((chr (read-char p)))
|
||||
(if (eof-object? chr)
|
||||
#\nul
|
||||
chr))
|
||||
void))
|
||||
|
||||
(define (blodwen-eof p)
|
||||
(if (eof-object? (peek-char p))
|
||||
1
|
||||
0))
|
||||
|
||||
;; Threads
|
||||
|
||||
(define (blodwen-thread p)
|
||||
(thread-start! (make-thread (lambda () (p (vector 0))))))
|
||||
|
||||
(define (blodwen-set-thread-data p)
|
||||
(thread-specific-set! (current-thread) p))
|
||||
|
||||
(define (blodwen-get-thread-data)
|
||||
(thread-specific (current-thread)))
|
||||
|
||||
(define (blodwen-mutex) (make-mutex))
|
||||
(define (blodwen-lock m) (mutex-lock! m))
|
||||
(define (blodwen-unlock m) (mutex-unlock! m))
|
||||
(define (blodwen-thisthread) (current-thread))
|
||||
|
||||
(define (blodwen-condition) (make-condition-variable))
|
||||
(define (blodwen-condition-wait c m)
|
||||
(mutex-unlock! m c)
|
||||
(mutex-lock! m)) ;; lock again, for consistency with other CGs
|
||||
(define (blodwen-condition-wait-timeout c m t) (mutex-unlock! m c t))
|
||||
(define (blodwen-condition-signal c) (condition-variable-signal! c))
|
||||
(define (blodwen-condition-broadcast c) (condition-variable-broadcast! c))
|
||||
|
||||
(define (blodwen-sleep s) (sleep s))
|
||||
|
||||
(define (blodwen-args)
|
||||
(define (blodwen-build-args args)
|
||||
(if (null? args)
|
||||
(vector 0 '())
|
||||
(vector 1 '() (car args) (blodwen-build-args (cdr args)))))
|
||||
(blodwen-build-args (argv)))
|
Loading…
Reference in New Issue
Block a user