ref: a2744a241a0175b15e700407f30a24afbc760fa9
parent: c8a135ea3235767a41c8639352525364dd1553d3
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Fri Nov 3 20:53:14 EDT 2023
More Floating stuff.
--- a/Makefile
+++ b/Makefile
@@ -31,7 +31,7 @@
# On MINGW you might need the additional flags -Wl,--stack,50000000 to increase stack space.
$(EVAL): src/runtime/eval.c
@mkdir -p bin
- $(GCC) -Wall -O3 src/runtime/eval.c -o $(EVAL)
+ $(GCC) -Wall -O3 src/runtime/eval.c -lm -o $(EVAL)
###
### Build the compiler with ghc, using standard libraries (Prelude, Data.List, etc)
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1337
-((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _153) ((B _12) _1)) _332))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _331))) ((A :10 (((S' P) _2) (((C' _13) _1) _1095))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _150) _12) _141))) ((A :20 (((S' B) _14) (((C' _153) _12) _142))) ((A :21 _1168) ((A :22 ((B _1211) _21)) ((A :23 (((S' _1211) _21) I)) ((A :24 _1138) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1167) ((C _140) _26))) ((A :28 (((C' _27) ((_149 _1181) _98)) ((_140 (_34 _1183)) _97))) ((A :29 ((B ((S _1211) (_34 _1183))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _331)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _332)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1095)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1095))) ((A :46 ((C _43) _141)) ((A :47 ((B _143) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _143) _48)) ((A :50 T) ((A :51 ((_148 ((B (B (_138 _50))) ((B ((C' C) _54)) (B P)))) (_152 _51))) ((A :52 (((((_11 _51) ((B (_138 _50)) P)) (_38 _53)) ((B (B (_138 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_138 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_140 _403)) _54)) ((A :56 ((B (_138 _50)) (B (P _1095)))) ((A :57 ((B (_138 _50)) (BK (P _1095)))) ((A :58 ((_138 _50) ((S P) I))) ((A :59 ((B (_138 _50)) ((C (S' P)) I))) ((A :60 ((_124 ((C ((C S') _65)) I)) (_128 _60))) ((A :61 (((_1309 (K ((P (_1318 "False")) (_1318 "True")))) (_1314 _61)) (_1315 _61))) ((A :62 ((_69 _67) _68)) ((A :63 (R _68)) ((A :64 (T _67)) ((A :65 ((P _68) _67)) ((A :66 _68) ((A :67 K) ((A :68 A) ((A :69 P) ((A :70 (T K)) ((A :71 (T A)) ((A :72 (K (noDefault "Bounded.minBound"))) ((A :73 (K (noDefault "Bounded.maxBound"))) ((A :74 ((_124 _1132) _1133)) ((A :75 ((((((((_364 _74) (_373 _75)) _1134) _1135) _1136) _1137) (_378 _75)) (_379 _75))) ((A :76 ((_124 _1142) (_128 _76))) ((A :77 ((((((((_364 _76) _1141) (((C' (C' (_125 _380))) _1141) _384)) (((C' (C' (_126 _380))) _1141) _386)) (((C' (C' (_125 _380))) _1141) _386)) (((C' (C' (_126 _380))) _1141) _386)) (_378 _77)) (_379 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1143) ((A :80 _1144) ((A :81 (((S' _64) (_1135 #97)) ((C _1135) #122))) ((A :82 (((S' _64) (_1135 #65)) ((C _1135) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1135 #48)) ((C _1135) #57))) ((A :85 (((S' _63) _83) _84)) ((A :86 (((S' _64) (_1135 #32)) ((C _1135) #126))) ((A :87 (((S' _63) ((C (_125 _74)) #32)) (((S' _63) ((C (_125 _74)) #9)) ((C (_125 _74)) #10)))) ((A :88 ((S ((S (((S' _64) (_1135 #65)) ((C _1135) #90))) (_68 (((noMatch "lib/Data/Char.hs") #72) #9)))) ((B _79) (((C' (_349 _154)) (((C' (_350 _154)) _80) (_80 #65))) (_80 #97))))) ((A :89 ((S ((S (((S' _64) (_1135 #97)) ((C _1135) #97))) (_68 (((noMatch "lib/Data/Char.hs") #76) #9)))) ((B _79) (((C' (_349 _154)) (((C' (_350 _154)) _80) (_80 #97))) (_80 #65))))) ((A :90 (((_1309 (K ((C ((S ((C ==) #39)) ((B (_140 (_1317 #39))) (((C' _140) ((B _1318) _91)) (_1317 #39))))) (_1318 "'\92&''")))) (_1314 _90)) ((B (_140 (_1317 #34))) (Y ((B (P (_1317 #34))) (((S' C) ((B
\ No newline at end of file
+1393
+((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _209) ((B _12) _1)) _388))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _387))) ((A :10 (((S' P) _2) (((C' _13) _1) _1151))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _206) _12) _197))) ((A :20 (((S' B) _14) (((C' _209) _12) _198))) ((A :21 _1224) ((A :22 ((B _1267) _21)) ((A :23 (((S' _1267) _21) I)) ((A :24 _1194) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1223) ((C _196) _26))) ((A :28 (((C' _27) ((_205 _1237) _108)) ((_196 (_34 _1239)) _107))) ((A :29 ((B ((S _1267) (_34 _1239))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _387)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _388)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1151)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1151))) ((A :46 ((C _43) _197)) ((A :47 ((B _199) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _199) _48)) ((A :50 T) ((A :51 ((_204 ((B (B (_194 _50))) ((B ((C' C) _54)) (B P)))) (_208 _51))) ((A :52 (((((_11 _51) ((B (_194 _50)) P)) (_38 _53)) ((B (B (_194 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_194 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_196 _459)) _54)) ((A :56 ((B (_194 _50)) (B (P _1151)))) ((A :57 ((B (_194 _50)) (BK (P _1151)))) ((A :58 ((_194 _50) ((S P) I))) ((A :59 ((B (_194 _50)) ((C (S' P)) I))) ((A :60 ((_134 ((C ((C S') _65)) I)) (_138 _60))) ((A :61 (((_1365 (K ((P (_1374 "False")) (_1374 "True")))) (_1370 _61)) (_1371 _61))) ((A :62 ((_69 _67) _68)) ((A :63 (R _68)) ((A :64 (T _67)) ((A :65 ((P _68) _67)) ((A :66 _68) ((A :67 K) ((A :68 A) ((A :69 P) ((A :70 (T K)) ((A :71 (T A)) ((A :72 (K (noDefault "Bounded.minBound"))) ((A :73 (K (noDefault "Bounded.maxBound"))) ((A :74 ((_134 _1188) _1189)) ((A :75 ((((((((_420 _74) (_429 _75)) _1190) _1191) _1192) _1193) (_434 _75)) (_435 _75))) ((A :76 ((_134 _1198) (_138 _76))) ((A :77 ((((((((_420 _76) _1197) (((C' (C' (_135 _436))) _1197) _440)) (((C' (C' (_136 _436))) _1197) _442)) (((C' (C' (_135 _436))) _1197) _442)) (((C' (C' (_136 _436))) _1197) _442)) (_434 _77)) (_435 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1199) ((A :80 _1200) ((A :81 (((S' _64) (_1191 #97)) ((C _1191) #122))) ((A :82 (((S' _64) (_1191 #65)) ((C _1191) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1191 #48)) ((C _1191) #57))) ((A :85 (((S' _63) _83) _84)) ((A :86 (((S' _64) (_1191 #32)) ((C _1191) #126))) ((A :87 (((S' _63) ((C (_135 _74)) #32)) (((S' _63) ((C (_135 _74)) #9)) ((C (_135 _74)) #10)))) ((A :88 ((S ((S (((S' _64) (_1191 #65)) ((C _1191) #90))) (_68 (((noMatch "lib/Data/Char.hs") #72) #9)))) ((B _79) (((C' (_405 _210)) (((C' (_406 _210)) _80) (_80 #65))) (_80 #97))))) ((A :89 ((S ((S (((S' _64) (_1191 #97)) ((C _1191) #97))) (_68 (((noMatch "lib/Data/Char.hs") #76) #9)))) ((B _79) (((C' (_405 _210)) (((C' (_406 _210)) _80) (_80 #97))) (_80 #65))))) ((A :90 (((_1365 (K ((C ((S ((C ==) #39)) ((B (_196 (_1373 #39))) (((C' _196) ((B _1374) _91)) (_1373 #39))))) (_1374 "'\92&''")))) (_1370 _90)) ((B (_196 (_1373 #34))) (Y ((B (P (_1373 #34))) (((S' C) ((
\ No newline at end of file
--- a/lib/Data/Double.hs
+++ b/lib/Data/Double.hs
@@ -5,6 +5,7 @@
import Control.Error
import Data.Bool_Type
import Data.Eq
+import Data.Floating
import Data.Fractional
import Data.Integer
import Data.Ord
@@ -46,3 +47,25 @@
-- herculean task of its own...
instance Show Double where
show = primDoubleShow
+
+instance Floating Double where
+ pi = 3.141592653589793
+ log x = primPerformIO (clog x)
+ exp x = primPerformIO (cexp x)
+ sqrt x = primPerformIO (csqrt x)
+ sin x = primPerformIO (csin x)
+ cos x = primPerformIO (ccos x)
+ tan x = primPerformIO (ctan x)
+ asin x = primPerformIO (casin x)
+ acos x = primPerformIO (cacos x)
+ atan x = primPerformIO (catan x)
+
+foreign import ccall "log" clog :: Double -> IO Double
+foreign import ccall "exp" cexp :: Double -> IO Double
+foreign import ccall "sqrt" csqrt :: Double -> IO Double
+foreign import ccall "sin" csin :: Double -> IO Double
+foreign import ccall "cos" ccos :: Double -> IO Double
+foreign import ccall "tan" ctan :: Double -> IO Double
+foreign import ccall "asin" casin :: Double -> IO Double
+foreign import ccall "acos" cacos :: Double -> IO Double
+foreign import ccall "atan" catan :: Double -> IO Double
--- a/lib/Prelude.hs
+++ b/lib/Prelude.hs
@@ -11,6 +11,7 @@
module Data.Either,
module Data.Enum,
module Data.Eq,
+ module Data.Floating,
module Data.Fractional,
module Data.Function,
module Data.Functor,
@@ -39,6 +40,7 @@
import Data.Either
import Data.Enum
import Data.Eq
+import Data.Floating
import Data.Fractional
import Data.Function
import Data.Functor
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -4,6 +4,7 @@
module MicroHs.Desugar(
desugar,
LDef, showLDefs,
+ encodeInteger,
) where
import Prelude
import Data.Char
@@ -282,7 +283,7 @@
showLDef :: LDef -> String
showLDef a =
case a of
- (i, e) -> showIdent i ++ " = " ++ showExp e
+ (i, e) -> showIdent i ++ " = " ++ show e
----------------
@@ -435,8 +436,8 @@
eCase :: Exp -> [(SPat, Exp)] -> Exp
eCase e as =
--- trace ("eCase " ++ showExp e ++ "\n" ++--- unlines [ unwords (map showIdent (conIdent c : xs)) ++ " -> " ++ showExp r | (SPat c xs, r) <- as ]) $
+-- trace ("eCase " ++ show e ++ "\n" +++-- unlines [ unwords (map showIdent (conIdent c : xs)) ++ " -> " ++ show r | (SPat c xs, r) <- as ]) $
apps e [lams xs r | (SPat _ xs, r) <- as ]
-- Split the matrix into segments so each first column has initially patterns -- followed by variables, followed by the rest.
--- a/src/MicroHs/Exp.hs
+++ b/src/MicroHs/Exp.hs
@@ -6,7 +6,7 @@
compileOpt,
-- compileOptX,
substExp,
- Exp(..), showExp, toStringP,
+ Exp(..), toStringP,
PrimOp,
encodeString,
app2, cCons, cNil, cFlip,
@@ -52,7 +52,6 @@
| App Exp Exp
| Lam Ident Exp
| Lit Lit
- --Xderiving (Show)
--pattern Let :: Ident -> Exp -> Exp -> Exp
--pattern Let i e b = App (Lam i b) e
@@ -404,8 +403,8 @@
improveT e = e
-}
-showExp :: Exp -> String
-showExp = render . ppExp
+instance Show Exp where
+ show = render . ppExp
ppExp :: Exp -> Doc
ppExp ae =
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -12,6 +12,7 @@
--Ximport Compat
--Wimport PrimTable
+import MicroHs.Desugar(encodeInteger)
import MicroHs.Expr
import MicroHs.Exp
import MicroHs.Ident
@@ -42,7 +43,8 @@
Lit (LDouble i) -> unsafeCoerce i
Lit (LStr s) -> trans r (encodeString s)
Lit (LPrim p) -> fromMaybe (error $ "primlookup: " ++ p) $ lookup p primTable
- _ -> error "trans: impossible"
+ Lit (LInteger i) -> trans r (encodeInteger i)
+ _ -> error $ "trans: impossible: " ++ show ae
-- Use linear search in this table.
-- 99% of the hits are among the combinators.
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -8,6 +8,7 @@
#include <locale.h>
#include <ctype.h>
#include <setjmp.h>
+#include <math.h>
#define GCRED 1 /* do some reductions during GC */
#define FASTTAGS 1 /* compute tag by pointer subtraction */
@@ -941,14 +942,24 @@
* II int name(int)
* IIV void name(int, int)
* III int name(int, int)
+ * DD double name(double)
* more can easily be added.
*/
struct {const char *ffi_name;
const funptr_t ffi_fun;
- enum { FFI_V, FFI_I, FFI_IV, FFI_II, FFI_IIV, FFI_III } ffi_how;+ enum { FFI_V, FFI_I, FFI_IV, FFI_II, FFI_IIV, FFI_III, FFI_DD } ffi_how; } ffi_table[] = { { "llabs", (funptr_t)llabs, FFI_II },+ { "log", (funptr_t)log, FFI_DD },+ { "exp", (funptr_t)exp, FFI_DD },+ { "sqrt", (funptr_t)sqrt, FFI_DD },+ { "sin", (funptr_t)sin, FFI_DD },+ { "cos", (funptr_t)cos, FFI_DD },+ { "tan", (funptr_t)tan, FFI_DD },+ { "asin", (funptr_t)asin, FFI_DD },+ { "acos", (funptr_t)acos, FFI_DD },+ { "atan", (funptr_t)atan, FFI_DD },};
/* Look up an FFI function by name */
@@ -2156,7 +2167,9 @@
int a = (int)GETVALUE(n);
funptr_t f = ffi_table[a].ffi_fun;
value_t r, x, y;
+ double rd, xd;
#define INTARG(n) evalint(ARG(TOP(n)))
+#define DBLARG(n) evaldouble(ARG(TOP(n)))
#define FFIV(n) CHECKIO(n)
#define FFI(n) CHECKIO(n); GCCHECK(1)
/* This isn't great, but this is MicroHs, so it's good enough. */
@@ -2165,8 +2178,9 @@
case FFI_I: FFI (0); r = (*(value_t (*)(void ))f)(); n = mkInt(r); RETIO(n);
case FFI_IV: FFIV(1); x = INTARG(1); (*(void (*)(value_t ))f)(x); RETIO(combUnit);
case FFI_II: FFI (1); x = INTARG(1); r = (*(value_t (*)(value_t ))f)(x); n = mkInt(r); RETIO(n);
- case FFI_IIV: FFIV(1); x = INTARG(1); y = INTARG(2); (*(void (*)(value_t, value_t))f)(x,y); RETIO(combUnit);
- case FFI_III: FFI (1); x = INTARG(1); y = INTARG(2); r = (*(value_t (*)(value_t, value_t))f)(x,y); n = mkInt(r); RETIO(n);
+ case FFI_IIV: FFIV(2); x = INTARG(1); y = INTARG(2); (*(void (*)(value_t, value_t))f)(x,y); RETIO(combUnit);
+ case FFI_III: FFI (2); x = INTARG(1); y = INTARG(2); r = (*(value_t (*)(value_t, value_t))f)(x,y); n = mkInt(r); RETIO(n);
+ case FFI_DD: FFI (1); xd = DBLARG(1); rd= (*(double (*)(double ))f)(xd); n = mkDouble(rd); RETIO(n);
default: ERR("T_IO_CCALL");}
}
--- /dev/null
+++ b/tests/Floating.hs
@@ -1,0 +1,8 @@
+module Floating(main) where
+import Prelude
+
+main :: IO ()
+main = do
+ print $ log (1000::Double)
+ print $ cos (pi::Double)
+ print $ sqrt (4::Double)
--- /dev/null
+++ b/tests/Floating.ref
@@ -1,0 +1,3 @@
+6.907755278982137
+-1.0
+2.0
--- a/tests/Makefile
+++ b/tests/Makefile
@@ -26,6 +26,7 @@
$(MHS) Infix && $(EVAL) > Infix.out && diff Infix.ref Infix.out
$(MHS) Class && $(EVAL) > Class.out && diff Class.ref Class.out
$(MHS) Eq && $(EVAL) > Eq.out && diff Eq.ref Eq.out
+ $(MHS) Floating && $(EVAL) > Floating.out && diff Floating.ref Floating.out
errtest:
sh errtester.sh < errmsg.test
@@ -36,4 +37,3 @@
clean:
rm -f *.out *.tmp
-
--
⑨