apple 0.2.0.0 → 0.3.0.0

raw patch · 97 files changed

+2233/−918 lines, 97 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−0
• Makefile +54/−0
• R/apple.R +5/−0
• README.md +6/−2
• Rc/Makefile +29/−0
• Rc/appler.c +121/−0
• apple.cabal +15/−2
• bench/Bench.hs +83/−19
• bench/apple/cat.apple +1/−0
• bench/apple/convMax.apple +1/−0
• bench/apple/evenIx.apple +1/−0
• bench/apple/evens.apple +1/−0
• bench/apple/maxWindow.apple +1/−0
• c/ffi.c +23/−0
• math/chisqcdf.apple +1/−1
• math/f11.apple +2/−3
• math/fcdf.apple +3/−3
• math/hypergeometric.apple +2/−3
• math/numbertheory/factors.apple +9/−0
• math/numbertheory/radical.apple +9/−0
• math/stats/covar.apple +6/−0
• math/stats/welch.apple +14/−0
• math/stats/whiten.apple +5/−0
• math/tcdf.apple +1/−1
• mk/os.mk +7/−0
• of/Test.hs +12/−12
• pyc/Makefile +37/−0
• pyc/applemodule.c +200/−0
• run/Main.hs +59/−40
• run/QC.hs +25/−7
• src/A.hs +4/−2
• src/A/Opt.hs +85/−14
• src/Asm/Aarch64.hs +219/−94
• src/Asm/Aarch64/B.hs +1/−1
• src/Asm/Aarch64/Byte.hs +28/−16
• src/Asm/Aarch64/CF.hs +21/−9
• src/Asm/Aarch64/Fr.hs +1/−1
• src/Asm/Aarch64/Opt.hs +1/−1
• src/Asm/Aarch64/P.hs +5/−5
• src/Asm/Aarch64/T.hs +90/−38
• src/Asm/Ar.hs +9/−9
• src/Asm/Ar/P.hs +3/−3
• src/Asm/BB.hs +2/−2
• src/Asm/G.hs +4/−4
• src/Asm/L.hs +2/−2
• src/Asm/LI.hs +1/−1
• src/Asm/M.hs +1/−1
• src/Asm/X86.hs +232/−111
• src/Asm/X86/B.hs +1/−1
• src/Asm/X86/Byte.hs +6/−6
• src/Asm/X86/CF.hs +11/−11
• src/Asm/X86/Frame.hs +1/−1
• src/Asm/X86/Opt.hs +2/−2
• src/Asm/X86/P.hs +5/−5
• src/Asm/X86/Sp.hs +4/−4
• src/Asm/X86/Trans.hs +6/−6
• src/C.hs +26/−13
• src/C/CF.hs +11/−1
• src/C/Trans.hs +395/−203
• src/CGen.hs +2/−2
• src/Class/E.hs +55/−0
• src/Dbg.hs +3/−3
• src/Hs/A.hs +3/−1
• src/IR.hs +1/−1
• src/IR/C.hs +6/−1
• src/IR/Hoist.hs +15/−13
• src/L.x +41/−18
• src/P.hs +7/−7
• src/Parser.y +21/−18
• src/Parser/Rw.hs +4/−1
• src/Ty.hs +94/−126
• src/Ty/M.hs +8/−3
• test/Spec.cpphs +10/−0
• test/data/T.apple +1/−1
• test/data/amgmGen.apple +1/−0
• test/data/coeffN.apple +0/−19
• test/data/conv.apple +1/−1
• test/data/hist.apple +1/−1
• test/data/mulT.apple +1/−0
• test/data/predictionStep.apple +1/−1
• test/data/scan.apple +0/−1
• test/data/softmax.apple +1/−1
• test/data/trainXor.apple +3/−3
• test/data/vb.apple +1/−1
• test/data/vmul.apple +1/−1
• test/examples/approxFfact.apple +1/−1
• test/examples/argmax.apple +1/−1
• test/examples/coeffs.apple +4/−5
• test/examples/convolve.apple +1/−1
• test/examples/dotprod.apple +1/−1
• test/examples/ellipticFourier.apple +6/−7
• test/examples/ramanujanFact.apple +1/−1
• test/examples/shoelace.apple +1/−1
• test/examples/stepMnist.apple +4/−4
• test/examples/stirling.apple +1/−1
• test/examples/trainMnist.apple +4/−9
• test/examples/xor.apple +2/−2

@@ -1,5 +1,19 @@ # apple +# 0.3.0.0++  * Display dimension information in REPL results+  * Fix bugs+  * Rotate (⊖), head, last more polymorphic (work on arrays).+  * More cases in the mid-end+  * Lifting constants out of loops works again+  * REPL no longer fails when being unable to monomorphize unused binds+  * Type signatures behave like an infix operator; more sensible+  * Building library no longer requires jacinda; prefer ripgrep/awk+  * Add function composition, `∴`+  * Implement equality on arrays+  * Add unicode fraction literals ⅚ &c.+ ## 0.2.0.0    * Add `:delete` to REPL

@@ -0,0 +1,54 @@+include mk/os.mk++MAKEFLAGS += -j++HC ?= ghc++HS_SRC := $(shell find src -type f) $(shell find lib -type f) apple.cabal+ifeq ($(UNAME),Linux)+	LD_VER := $(shell awk '/^[ \t]*lib-version-info:/{print $$2}' apple.cabal | sed 's/:/./g')+endif++libapple$(EXT): $(HS_SRC) include/apple.h+	cabal build flib:apple -w $(HC)+ifeq ($(UNAME),Linux)+	cp $$(cabal-plan list-bins apple:flib:apple | awk '{print $$2}').$(LD_VER) $@+	strip $@+else+	cp $$(cabal-plan list-bins apple:flib:apple | awk '{print $$2}') $@+endif++docs/index.html: doc/apple-by-example.md nb/hist.html nb/convolve.html nb/randomWalk.html+	pandoc --mathjax --lua-filter=include-files.lua -s $< -o $@ --toc++nb/%.html: nb/%.ipynb+	jupyter nbconvert $^ --to=html+	sed -i '' '1,6d' $@++moddeps.svg: $(HS_SRC)+	graphmod -i src | dot -Tsvg -o $@++install-lib: libapple$(EXT)+	cp $^ /usr/local/lib++install-py:+	make -C pyc install++install-r:+	make -C Rc install++install:+	cabal install -w $(HC)+	strip $$(readlink -f $$(which atc))+	strip $$(readlink -f $$(which writeo))+	strip $$(readlink -f $$(which arepl))++clean:+	make -C pyc clean+	make -C vscode clean+	make -C Rc clean+	rm -f nb/*.html+	rm -rf dist-newstyle tags tags.mtime moddeps.svg *.hp *.o *.prof *.tix *.svg *.so *.dylib py/__pycache__++fmt:+	fd '\.(cpphs|hs)$$' $$(ja -F'\s*:\s*' '{%/hs-source-dirs/}{`2}' -i apple.cabal) -x stylish-haskell -i

@@ -0,0 +1,5 @@+dyn.load("/usr/local/lib/libappler.dylib"); .Call("hs_init_R")+tyof<-function(a) {.Call("ty_R",a)}+asm<-function(a) {.Call("asm_R",a)}+jit<-function(a) {.Call("jit_R",a)}+run<-function(...) {.External("run_R",...)}

@@ -1,7 +1,9 @@ # Apple Array System -Many cases are not implemented. This is provided as an artefact.+Some cases are not implemented. This is provided as an artefact. +See [Apple by Example](https://vmchale.github.io/apple/) for a demonstration of capabilities.+ The compiler will bail out with arcane error messages rather than produce an incorrect result, except that the Python/R extension modules do not enforce type safety and thus may mysteriously segfault or produce unpredictable corrupt results.@@ -29,7 +31,6 @@ >>> sliding_mean=apple.jit('([((+)/x)%(ℝ(:x))]\`7)') >>> apple.f(sliding_mean,np.arange(0,10,dtype=np.float64)) array([3., 4., 5., 6.])->>> ```  ```R@@ -38,6 +39,9 @@ > run(sliding_mean,seq(0,10,1.0)) [1] 3 4 5 6 7 ```++The JIT'ed moving average in Apple happens to be faster than the rolling mean from+the [zoo package](https://cran.r-project.org/web/packages/zoo/index.html).  ## Dimension As a Functor 

@@ -0,0 +1,29 @@+HC ?= ghc++include ../mk/os.mk++GHC_VER := $(shell ${HC} --numeric-version)+R_VER := $(shell R --version | awk 'NR==1 {print $$0}' | rg '(\d+\.\d+)' -o)+HS_LIBDIR := $(shell ghc-pkg-$(GHC_VER) field rts dynamic-library-dirs | awk 'NR==1 {print $$2}')++ifeq ($(UNAME),Darwin)+	HS_INCLUDE_DIR := $(shell ghc-pkg-$(GHC_VER) field rts include-dirs | awk 'NR==2 {print $$1}')+	CFLAGS := -I /Library/Frameworks/R.framework/Versions/$(R_VER)-arm64/Headers+	LDFLAGS := -L /usr/local/lib -rpath /usr/local/lib -lHSrts-1.0.2-ghc$(GHC_VER) -L $(HS_LIBDIR) -rpath $(HS_LIBDIR) /Library/Frameworks/R.framework/Versions/$(R_VER)-arm64/R+else+	HS_INCLUDE_DIR := $(shell ghc-pkg-$(GHC_VER) field rts include-dirs | awk 'NR==1 {print $$2}')+endif++all: libappler$(EXT)++install: libappler$(EXT)+	cp $^ /usr/local/lib++%.o: %.c+	$(CC) -fPIC -O2 -c $< $(CFLAGS) -I $(HS_INCLUDE_DIR) -o $@++libappler$(EXT): appler.o+	$(CC) -shared $^ -o $@ -lapple -lffi $(LDFLAGS)++clean:+	rm -rf *.o *.so *.dylib

@@ -0,0 +1,121 @@+#include<sys/mman.h>+#include<R.h>+#include<Rinternals.h>+#include<HsFFI.h>+#include<ffi.h>+#include"../include/apple_abi.h"+#include"../c/ffi.c"++typedef size_t S;++#define Sw switch+#define C case+#define BR break;++// asReal : SEXP -> double+// asInteger : SEXP -> int+// ScalarReal : double -> SEXP+// ScalarInteger : int -> SEXP+// SEXPTYPE = INTSXP | REALSXP+// EXTPTR_PTR : SEXP -> void*++// http://adv-r.had.co.nz/C-interface.html++typedef struct AppleCache {+    U code;S code_sz;FnTy* ty;U sa;ffi_cif* ffi;+} AppleCache;++SEXP rf(U x) {+    J* i_p=x;+    J t=1;+    J rnk=i_p[0];+    SEXP dims=PROTECT(allocVector(INTSXP,(int)rnk));+    DO(i,rnk,t*=i_p[i+1];INTEGER(dims)[i]=(int)i_p[i+1]);+    SEXP ret=PROTECT(allocArray(REALSXP,dims));+    S sz=8*t;+    memcpy(REAL(ret),i_p+rnk+1,sz);+    UNPROTECT(2);+    R ret;+}++// vector only+U fr(SEXP x) {+    J rnk=1;J dim=length(x);+    J* ret=malloc(8*(2+dim));+    ret[0]=rnk;ret[1]=dim;+    memcpy(ret+2,REAL(x),dim*8);+    R ret;+}++SEXP hs_init_R(void) {+    hs_init(0,0);+    R mkString("...loaded GHC runtime");+}++SEXP ty_R(SEXP a) {+    char* err;char** err_p=&err;+    const char* inp=CHAR(asChar(a));+    char* ret=apple_printty(inp,err_p);+    if(ret==NULL) {+        SEXP ret=mkString(err);free(err);+        R ret;+    }+    R mkString(ret);+}++SEXP jit_R(SEXP a){+    char* err; char** err_p=&err;+    const char* inp=CHAR(asChar(a));+    FnTy* ty=apple_ty(inp,err_p);+    if(ty == NULL){+        SEXP ret=mkString(err);free(err);+        R ret;+    };+    U fp;S f_sz;U s;+    JC jc={(P)&malloc,(P)&free,(P)&lrand48,(P)&drand48,(P)&exp,(P)&log,(P)&pow};+    fp=apple_compile(&jc,inp,&f_sz,&s);+    AppleCache* rc=malloc(sizeof(AppleCache));+    ffi_cif* ffi=apple_ffi(ty);+    rc->code=fp;rc->code_sz=f_sz;rc->ty=ty;rc->sa=s;rc->ffi=ffi;+    // http://homepage.divms.uiowa.edu/~luke/R/simpleref.html+    // https://github.com/hadley/r-internals/blob/master/external-pointers.md+    SEXP r=R_MakeExternalPtr((U)rc,R_NilValue,R_NilValue);+    R r;+}++SEXP asm_R(SEXP a) {+    char* err; char** err_p=&err;+    const char* inp=CHAR(asChar(a));+    char* ret=apple_dumpasm(inp,err_p);+    if(ret==NULL) {+        SEXP ret=mkString(err);free(err);+        R ret;+    }+    R mkString(ret);+}++SEXP run_R(SEXP args){+    args=CDR(args);+    SEXP rc=CAR(args);+    AppleCache* c=(AppleCache*)(R_ExternalPtrAddr(rc));+    FnTy* ty=c->ty;U fp=c->code;ffi_cif* cif=c->ffi;+    SEXP r;+    int argc=ty->argc;+    U* vals=alloca(sizeof(U)*argc);+    U ret=alloca(8);+    for(int k=0;k<argc;k++){+        args=CDR(args);SEXP arg=CAR(args);+        Sw(ty->args[k]){+            C FA: {U* x=alloca(sizeof(U));x[0]=fr(arg);vals[k]=x;};BR+            C F_t: {F* xf=alloca(sizeof(F));xf[0]=asReal(arg);vals[k]=xf;};BR+            C I_t: {J* xi=alloca(sizeof(J));xi[0]=(int64_t)asInteger(arg);vals[k]=xi;};BR+        }+    }+    ffi_call(cif,fp,ret,vals);+    Sw(ty->res){+        C FA: r=rf(*(U*)ret);BR+        C F_t: r=ScalarReal(*(F*)ret);BR+        C I_t: r=ScalarInteger((int)(*(J*)ret));BR+    }+    R r;+}

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               apple-version:            0.2.0.0+version:            0.3.0.0 license:            AGPL-3 license-file:       LICENSE copyright:          Copyright: (c) 2022 Vanessa McHale@@ -22,6 +22,18 @@     test/harness/*.c     math/*.apple     math/*.apple+    math/numbertheory/*.apple+    math/numbertheory/*.apple+    math/stats/*.apple+    math/stats/*.apple+    Makefile+    mk/os.mk+    pyc/Makefile+    pyc/*.c+    Rc/Makefile+    Rc/*.c+    c/ffi.c+    R/apple.R  extra-doc-files:     README.md@@ -334,7 +346,8 @@         statistics,         bytestring,         erf,-        hypergeometric >=0.1.2.0+        hypergeometric >=0.1.2.0,+        deepseq      if impl(ghc >=8.10)         ghc-options: -Wunused-packages

@@ -1,11 +1,13 @@ module Main (main) where +import           Control.DeepSeq                  (NFData (..), rwhnf) import           Control.Exception                (Exception, throw) import           Criterion.Main import qualified Data.ByteString.Lazy             as BSL import           Data.Functor                     (($>)) import           Data.Int                         (Int64) import           Data.Number.Erf                  (erf, normcdf)+import           Foreign.ForeignPtr               (ForeignPtr, mallocForeignPtrBytes, withForeignPtr) import           Foreign.Marshal.Alloc            (free, mallocBytes) import           Foreign.Ptr                      (FunPtr, Ptr) import           Foreign.Storable                 (Storable (..))@@ -36,18 +38,16 @@  leakFp = fmap fst.case arch of {"aarch64" -> aFunP; "x86_64" -> funP} +aAF :: Storable a => Apple a -> IO (ForeignPtr (Apple a))+aAF x = do {p <- mallocForeignPtrBytes (sizeOf x); withForeignPtr p (`poke` x) $> p}++instance NFData (ForeignPtr a) where+    rnf = rwhnf+ main :: IO () main = do-    -- this sucks but using env segfaults?     xsPtr <- aA (AA 1 [500] xs)     ysPtr <- aA (AA 1 [500] ys)-    iPtr <- aA (AA 1 [10000000] (replicate 10000000 (1::Int)))-    fPtr <- aA (AA 1 [10000000] (replicate 10000000 (1::Double)))-    p0Ptr <- aA (AA 1 [3] [0.0::Double,4,4])-    p1Ptr <- aA (AA 1 [3] [0.0::Double,0.3])-    whPtr <- aA (AA 2 [2,2] [0.51426693,0.56885825,0.48725347,0.15041493::Double])-    woPtr <- aA (AA 1 [2] [0.14801747,0.37182892::Double])-    bhPtr <- aA (AA 1 [2] [0.79726405,0.67601843::Double])     fp <- fmap iii . leakFp =<< BSL.readFile "test/examples/risingFactorial.🍎"     entropyFp <- fmap af . leakFp =<< BSL.readFile "test/examples/entropy.🍏"     klFp <- fmap aaf . leakFp =<< BSL.readFile "test/examples/kl.🍎"@@ -55,18 +55,32 @@     ncdfFp <- fmap ff . leakFp =<< BSL.readFile "math/ncdf.🍎"     scanFp <- fmap aa . leakFp =<< BSL.readFile "bench/apple/scanmax.🍏"     scanfFp <- fmap aa . leakFp =<< BSL.readFile "bench/apple/scanmaxf.🍏"+    wMax <- fmap aa . leakFp =<< BSL.readFile "bench/apple/maxWindow.🍎"+    cMax <- fmap aa.leakFp =<< BSL.readFile "bench/apple/convMax.🍏"+    filt <- fmap aa.leakFp =<< BSL.readFile "bench/apple/evens.🍎"+    ixfilt <- fmap aa.leakFp =<< BSL.readFile "bench/apple/evenIx.🍎"     ᴀFp <- fmap aaf . leakFp =<< BSL.readFile "test/examples/offset.🍏"     gammaFp <- fmap ff . leakFp =<< BSL.readFile "math/gamma.🍏"     tcdfFp <- fmap fff . leakFp =<< BSL.readFile "math/tcdf.🍎"     xorFp <- fmap aaafp4 . leakFp =<< BSL.readFile "test/data/trainXor.🍎"     v'izeFp <- fmap aa . leakFp =<< BSL.readFile "bench/apple/vize.🍏"+    dp <- fmap aaf . leakFp =<< BSL.readFile "test/examples/dotprod.🍏"+    v <- fmap aaa . leakFp =<< BSL.readFile "test/data/vb.🍏"+    mul <- fmap aaa.leakFp =<< BSL.readFile "test/data/mul.🍏"+    mulT <- fmap aaa.leakFp =<< BSL.readFile "test/data/mulT.🍏"+    vr <- fmap aaa . leakFp =<< BSL.readFile "test/data/vmul.🍏"+    mulrank <- fmap aaa . leakFp =<< BSL.readFile "test/examples/mul.🍏"+    catFp <- fmap aaa . leakFp =<< BSL.readFile "bench/apple/cat.🍏"+    softmax <- fmap aa . leakFp =<< BSL.readFile "test/data/softmax.🍎"+    amgm <- fmap fff.leakFp =<< BSL.readFile "math/amgm.🍏"+    amgmG <- fmap fff.leakFp =<< BSL.readFile "test/data/amgmGen.🍏"     defaultMain [ env files $ \ ~(t, x, 𝛾, ꜰ, ᴀ) ->                   bgroup "pipeline"                       [ bench "tyParse (tcdf)" $ nf tyParse t                       , bench "tyParse (xor)" $ nf tyParse x                       , bench "x86asm (gamma)" $ nf x86G 𝛾                       , bench "x86asm (fcdf)" $ nf x86G ꜰ-                      , bench "x86asm (A)" $ nf x86G ᴀ+                      -- , bench "x86asm (A)" $ nf x86G ᴀ                       , bench "arm (fcdf)" $ nf aarch64 ꜰ                       , bench "arm (tcdf)" $ nf aarch64 t                       , bench "arm (A)" $ nf aarch64 ᴀ@@ -110,16 +124,47 @@                       [ bench "hs" $ nf Math.gamma (1.5 :: Double)                       , bench "jit" $ nf gammaFp 1.5                       ]-                , bgroup "scanmax"-                      [ bench "apple" $ nfIO (do {p<- scanFp iPtr;free p})-                      , bench "applef" $ nfIO (do {p<- scanfFp fPtr;free p})+                , env big $ \ ~(i,f) ->+                  bgroup "scanmax"+                      [ bench "apple" $ nfIO (do {p<- withForeignPtr i scanFp;free p})+                      , bench "applef" $ nfIO (do {p<- withForeignPtr f scanfFp;free p})                       ]-                , bgroup "elliptic"-                      [ bench "A" $ nfIO (pure $ ᴀFp p0Ptr p1Ptr) ]-                , bgroup "xor"-                      [ bench "train" $ nfIO (xorFp whPtr woPtr bhPtr 0.57823076) ]-                , bgroup "mnist"-                      [ bench "vize" $ nfIO (v'izeFp iPtr) ]+                , env simdEnv $ \ ~(isp, m, va) ->+                  env big $ \ ~(_,f) ->+                  bgroup "simd"+                      [ bench "dotprod" $ nfIO (withForeignPtr f $ \fPtr -> pure $ dp fPtr fPtr)+                      , bench "++" $ nfIO (do {p <- withForeignPtr isp $ \iSmallPtr -> catFp iSmallPtr iSmallPtr; free p})+                      , bench "window" $ nfIO (do {p <- withForeignPtr f wMax; free p})+                      , bench "vmul" $ nfIO (do {p <- withForeignPtr m $ \mPtr -> withForeignPtr va $ \vPtr -> v mPtr vPtr; free p})+                      , bench "mul" $ nfIO (do {p <- withForeignPtr m $ \mPtr -> mul mPtr mPtr; free p})+                      , bench "vmul (rank)" $ nfIO (do {p <- withForeignPtr m $ \mPtr -> withForeignPtr va $ \vPtr -> vr mPtr vPtr; free p})+                      , bench "mul (rank)" $ nfIO (do {p <- withForeignPtr m $ \mPtr -> mulrank mPtr mPtr; free p})+                      , bench "mul-of-transp" $ nfIO (do {p <- withForeignPtr m $ \mPtr ->mulT mPtr mPtr; free p})+                      ]+                , env big $ \ ~(i, f) ->+                  bgroup "idioms"+                      [ bench "conv (1-d)" $ nfIO (do {p <- withForeignPtr f cMax; free p})+                      , bench "even (filt)" $ nfIO (do {p <- withForeignPtr i filt; free p})+                      , bench "even (map-ix)" $ nfIO (do {p <- withForeignPtr i ixfilt; free p})+                      , bench "amgm" $ nf (amgm 1) 2+                      , bench "amgm (gen.)" $ nf (amgmG 1) 2+                      ]+                , env eEnv $ \ ~(p0,p1) ->+                  bgroup "elliptic"+                      [ bench "A" $ nfIO (withForeignPtr p0 $ \p0Ptr -> withForeignPtr p1 $ \p1Ptr -> pure $ ᴀFp p0Ptr p1Ptr) ]+                , env xorEnv $ \ ~(wh, wo, bh) ->+                  bgroup "xor" $+                      [ bench "train" $ nfIO $+                          withForeignPtr wh $ \whPtr ->+                          withForeignPtr wo $ \woPtr ->+                          withForeignPtr bh $ \bhPtr ->+                          xorFp whPtr woPtr bhPtr 0.57823076+                      ]+                , env simdEnv $ \ ~(isp, m, _) ->+                  bgroup "mnist"+                      [ bench "vize" $ nfIO (do {p <- withForeignPtr isp $ \iSmallPtr -> v'izeFp iSmallPtr; free p})+                      , bench "softmax" $ nfIO (do {p <- withForeignPtr m $ \mPtr -> softmax mPtr; free p})+                      ]                 ]     where erfSrc = BSL.readFile "math/erf.🍏"           gamma = BSL.readFile "math/gamma.🍏"@@ -134,11 +179,30 @@           yeet = either throw id           xs = replicate 500 (0.002 :: Double)           ys = replicate 500 (0.002 :: Double)+          big = do+              iPtr <- aAF (AA 1 [10000000] (replicate 10000000 (1::Int64)))+              fPtr <- aAF (AA 1 [10000000] (replicate 10000000 (1::Double)))+              pure (iPtr,fPtr)+          simdEnv = do+              isp <- aAF (AA 1 [100000] (replicate 100000 (1::Int64)))+              mPtr <- aAF (AA 2 [500,500] (replicate 250000 (0.002::Double)))+              vPtr <- aAF (AA 1 [500] (replicate 500 (3::Double)))+              pure (isp, mPtr, vPtr)+          xorEnv = do+              whPtr <- aAF (AA 2 [2,2] [0.51426693,0.56885825,0.48725347,0.15041493::Double])+              woPtr <- aAF (AA 1 [2] [0.14801747,0.37182892::Double])+              bhPtr <- aAF (AA 1 [2] [0.79726405,0.67601843::Double])+              pure (whPtr, woPtr, bhPtr)+          eEnv = do+              p0 <- aAF (AA 1 [3] [0.0::Double,4,4])+              p1 <- aAF (AA 1 [3] [0.0::Double,0.3])+              pure (p0,p1)  foreign import ccall "dynamic" iii :: FunPtr (Int -> Int -> Int) -> Int -> Int -> Int foreign import ccall "dynamic" ff :: FunPtr (Double -> Double) -> Double -> Double foreign import ccall "dynamic" fff :: FunPtr (Double -> Double -> Double) -> Double -> Double -> Double-foreign import ccall "dynamic" aaf :: FunPtr (U a -> U a -> Double) -> U a -> U a -> Double+foreign import ccall "dynamic" aaf :: FunPtr (U a -> U b -> Double) -> U a -> U b -> Double foreign import ccall "dynamic" af :: FunPtr (U a -> Double) -> U a -> Double foreign import ccall "dynamic" aa :: FunPtr (U a -> IO (U a)) -> U a -> IO (U a)+foreign import ccall "dynamic" aaa :: FunPtr (U a -> U b -> IO (U c)) -> U a -> U b -> IO (U c) foreign import ccall "dynamic" aaafp4 :: FunPtr (U a -> U b -> U c -> Double -> IO (Ptr (P4 (U d) (U e) (U f) g))) -> U a -> U b -> U c -> Double -> IO (Ptr (P4 (U d) (U e) (U f) g))

@@ -0,0 +1,1 @@+[x++(y::Vec n int)]

@@ -0,0 +1,1 @@+λas. ((⋉)/)⨳{7} (as :: Vec n float)

@@ -0,0 +1,1 @@+\xs. (xs˙)'even.⩪xs

@@ -0,0 +1,1 @@+(even.§)

@@ -0,0 +1,1 @@+λas. ((⋉)/)\`7 (as :: Vec n float)

@@ -0,0 +1,23 @@+#include<stdlib.h>+#include<ffi.h>+#include"../include/apple.h"++#define R return+#define Sw switch+#define C case+#define BR break;++#define DO(i,n,a) {int i;for(i=0;i<n;i++){a;}}++#define F(r,t) {Sw(t){C I_t: r=&ffi_type_sint64;BR;C F_t: r=&ffi_type_double;BR;C FA: r=&ffi_type_pointer;BR;C IA: r=&ffi_type_pointer;BR;C BA: r=&ffi_type_pointer;BR}}++ffi_cif* apple_ffi(FnTy* ty) {+    ffi_cif* cif=malloc(sizeof(*cif));+    int argc=ty->argc;+    ffi_type** args=malloc(sizeof(ffi_type*)*argc);+    enum apple_t* argv=ty->args;+    DO(i,argc,F(args[i],argv[i]))+    ffi_type* ret;F(ret,ty->res);+    ffi_prep_cif(cif,FFI_DEFAULT_ABI,(unsigned int)argc,ret,args);+    R cif;+}

@@ -8,7 +8,7 @@         rf ← [(*)/ₒ 1 (𝒻 x (x+y-1) (⌊y))]; fact ← rf 1;         Σ ← λN.λa. (+)/ₒ 0 (a'(⍳ 0 N 1));         term ← λn. {nn⟜ℝ n; ((rf a nn)%(rf b nn))*((z^n)%(fact nn))};-        Σ 99 term+        Σ 50 term       };       ((x**a)%a)*f11 a (1+a) (_x)     };

@@ -1,6 +1,5 @@ λa.λb.λz.-{+⸎   rf ← [(*)/ₒ 1 (frange x (x+y-1) (⌊y))]; fact ← rf 1;   Σ ← λN.λa. (+)/ₒ 0 (a'(⍳ 0 N 1));-  Σ 99 (λn. {nn⟜ℝ n; ((rf a nn)%(rf b nn))*((z^n)%(fact nn))})-}+  Σ 30 (λn. {nn⟜ℝ n; ((rf a nn)%(rf b nn))*((z^n)%(fact nn))})

@@ -13,7 +13,7 @@     };   Β ← λx.λy.     {-      Γ ⟜ λz.+      gammaln ⟜ λz.         {           zz ⟜ z-1;           c0 ← 0.999999999999997092;@@ -34,9 +34,9 @@                    , 0.368991826595316234e-5                    ⟩;           ss ← (+)/ ([y%(zz+ℝ x)]`(⍳ 1 14 1) coeffs);-          e:((((zz+0.5)*_.(zz+𝛾+0.5))-(zz+𝛾+0.5))+_.((√(2*𝜋))*(c0+ss)))+          (((zz+0.5)*_.(zz+𝛾+0.5))-(zz+𝛾+0.5))+_.((√(2*𝜋))*(c0+ss))         };-      Γ x*Γ y%Γ (x+y)+      e:(gammaln x+gammaln y-gammaln (x+y))     };   I ← λz.λa.λb. incΒ z a b%Β a b;   I ((n*x)%(m+n*x)) (n%2) (m%2)

@@ -1,6 +1,5 @@ λa.λb.λz.-{+⸎   rf ← [(*)/ₒ 1 (𝒻 x (x+y-1) (⌊y))]; fact ← rf 1;-  Σ ← λN.λa. (+)/ₒ 0 (a'(⍳ 0 N 1)); Π ← [(*)/x];+  Σ ← λN.λa. (+)/ₒ 0 (a'(⍳ 0 N 1)); Π ⇐ [(*)/x];   Σ 30 (λn. {nn⟜ℝ n; (Π ((λa.rf a nn)'a)%Π((λb. rf b nn)'b))*(z^n%fact nn)})-}

@@ -0,0 +1,9 @@+λn.+  { ni ⟜ ⌊(√(ℝn))+  ; pns ← (⍳ 2 ni 1)+  ; isPrime ← λn.¬((∨)/ₒ #f ([(n|x)=0]'(⍳ 2 (⌊(√(ℝn))) 1))); pf ⇐ (isPrime #.)+  ; pps ⟜ pf pns+  ; ?ni^2=n+    ,.pf ((/.n)'(}:? pps))⧺pps+    ,.pf (n⊲(/.n)'pps)⧺pps+  }

@@ -0,0 +1,9 @@+λn.+  { ni ⟜ ⌊(√(ℝn))+  ; pns ← (⍳ 2 ni 1)+  ; isPrime ← λn.¬((∨)/ₒ #f ([(n|x)=0]'(⍳ 2 (⌊(√(ℝn))) 1))); pf ⇐ (isPrime #.)+  ; pps ⟜  pf ((λk. ((n|k)=0)) #. pns)+  ; ?ni^2=n+    ,.((*)/ₒ 1 (pf ((n/.)'(}:? pps))⧺pps))+    ,.((*)/ₒ 1 (pf (n ⊲ ((n/.)'pps))⧺pps))+  }

@@ -0,0 +1,6 @@+λxs.+{+  𝜇 ← [⸎n⟜ ℝ(:x); (+)/x%n];+  rs ⟜ 𝜇'xs;+  rs+}

@@ -0,0 +1,14 @@+λxs.λys.+{+  sum ⇐ [(+)/x];+  𝜇 ⇐ λxs.λn. sum xs%n;+  𝜎 ⇐ λxs.λn. {𝜇 ⟜ 𝜇 xs n; sum ([(x-𝜇)^2]'xs)%(n-1)};+  xsn ⟜ ℝ(:xs); ysn ⟜ ℝ(:ys);+  s₁ ⟜ 𝜎 xs xsn; s₂ ⟜ 𝜎 ys ysn;+  sn₁ ⟜ s₁%xsn; sn₂ ⟜ s₂%ysn;+  s ⟜ (sn₁+sn₂);+  t ← (𝜇 xs xsn-𝜇 ys ysn)%√s;+  -- Welch–Satterthwaite equation+  𝜈 ← s^2%((sn₁^2)%(xsn-1)+(sn₂^2)%(ysn-1));+  (t,𝜈)+}

@@ -0,0 +1,5 @@+λm.+{+  sd ← λxs. {n ⟜ ℝ(:xs); μ ⟜((+)/xs)%n; √(((+)/([{d⟜x-μ; d^2}]'xs))%n)};+  ⍉((λxs. {σ ⟜ sd xs; (%σ)'xs})`{1} (m::M float))+}

@@ -29,5 +29,5 @@     term ← λn. {nn⟜ℝ n; rf a0 nn*(rf a1 nn%rf b nn)*(z^n%fact nn)};     Σ 50 term   };-  0.5+x*Γ(0.5*(ν+1))%((√(𝜋*ν))*Γ(ν*0.5))*f21 0.5 ((ν+1)%2) 1.5 (_(x^2%ν))+  0.5+x*Γ(0.5*(ν+1))%((√(𝜋*ν))*Γ(ν*0.5))*f21 ½ ((ν+1)%2) 1.5 (_(x^2%ν)) }

@@ -0,0 +1,7 @@+UNAME := $(shell uname)++ifeq ($(UNAME),Darwin)+	EXT := .dylib+else+	EXT := .so+endif

@@ -36,18 +36,18 @@     pwd <- getCurrentDirectory     defaultMain $         sequentialTestGroup "link object files" AllFinish-            [ ccOut pwd "test/examples/shoelace.🍎" "aaf" sys "6.000000"-            , ccOut pwd "test/data/predictionStep.🍏" "aafa" sys "1 4\n0.716413,0.721679,0.727807,0.731693\n"-            , ccOut pwd "test/data/map.🍏" "aaa" sys "2 2,2\n1.000000,2.000000,2.000000,2.000000\n"-            , ccOut pwd "test/data/maa.🍎" "aa" sys "1 2\n1.000000,3.000000\n"-            , ccOut pwd "test/data/bha.🍏" "bha" sys "1 2\n0.792800,0.663306\n"-            , ccOut pwd "test/data/mfa.🍎" "a" sys "2 4,2\n1.000000,1.000000,3.000000,3.000000,2.000000,2.000000,5.000000,5.000000\n"-            , ccOut pwd "test/data/cfLeft.🍏" "af" sys "4.123106\n"-            , ccOut pwd "test/data/sin.🍏" "ff" sys "-1.000000\n"-            , ccOut pwd "test/data/conv.🍏" "conv" sys "2 3,3\n9.000000,9.000000,9.000000,9.000000,9.000000,9.000000,9.000000,9.000000,9.000000\n"-            , ccOut pwd "math/hypergeometric.🍏" "hyper" sys "2.030078"-            , ccOut pwd "math/numbertheory/radical.🍎" "ii" sys "30"-            , ccOut pwd "test/data/pf.🍎" "ia" sys "1 3\n2,3,5\n"+            [ ccOut pwd "test/examples/shoelace.apple" "aaf" sys "6.000000"+            , ccOut pwd "test/data/predictionStep.apple" "aafa" sys "1 4\n0.716413,0.721679,0.727807,0.731693\n"+            , ccOut pwd "test/data/map.apple" "aaa" sys "2 2,2\n1.000000,2.000000,2.000000,2.000000\n"+            , ccOut pwd "test/data/maa.apple" "aa" sys "1 2\n1.000000,3.000000\n"+            , ccOut pwd "test/data/bha.apple" "bha" sys "1 2\n0.792800,0.663306\n"+            , ccOut pwd "test/data/mfa.apple" "a" sys "2 4,2\n1.000000,1.000000,3.000000,3.000000,2.000000,2.000000,5.000000,5.000000\n"+            , ccOut pwd "test/data/cfLeft.apple" "af" sys "4.123106\n"+            , ccOut pwd "test/data/sin.apple" "ff" sys "-1.000000\n"+            , ccOut pwd "test/data/conv.apple" "conv" sys "2 3,3\n9.000000,9.000000,9.000000,9.000000,9.000000,9.000000,9.000000,9.000000,9.000000\n"+            , ccOut pwd "math/hypergeometric.apple" "hyper" sys "2.030078"+            , ccOut pwd "math/numbertheory/radical.apple" "ii" sys "30"+            , ccOut pwd "test/data/pf.apple" "ia" sys "1 3\n2,3,5\n"             ]   where     sys = case arch of {"x86_64" -> X64; "aarch64" -> Aarch64}

@@ -0,0 +1,37 @@+HC ?= ghc++GHC_VER := $(shell ${HC} --numeric-version)+PY_VER := $(shell python3 --version | rg '(\d+\.\d+)\.\d+' -o -r '$$1')++UNAME := $(shell uname)++ifeq ($(UNAME),Darwin)+	CFLAGS=-I /Library/Frameworks/Python.framework/Versions/$(PY_VER)/include/python$(PY_VER) -I /Library/Frameworks/Python.framework/Versions/$(PY_VER)/lib/python$(PY_VER)/site-packages/numpy/_core/include+	LDFLAGS=-L /usr/local/lib -rpath /usr/local/lib -lHSrts-1.0.2-ghc$(GHC_VER) -L $(HS_LIBDIR) -rpath $(HS_LIBDIR) /Library/Frameworks/Python.framework/Versions/$(PY_VER)/Python+else+	CFLAGS=-I "$$(python3 -m site --user-site)/numpy/_core/include" -I /usr/local/include/python$(PY_VER)++endif++HS_LIBDIR := $(shell ghc-pkg-$(GHC_VER) field rts dynamic-library-dirs | awk 'NR==1 {print $$2}')+ifeq ($(UNAME),Darwin)+	HS_INCLUDE_DIR := $(shell ghc-pkg-$(GHC_VER) field rts include-dirs | awk 'NR==2 {print $$1}')+else+	HS_INCLUDE_DIR := $(shell ghc-pkg-$(GHC_VER) field rts include-dirs | awk 'NR==1 {print $$2}')+endif++all: apple.so++install: apple.so+	cp $^ $$(python3 -m site --user-site)++# cdeps applemodule.c | ja "[x+' '+y]|> \$0"++apple.o: applemodule.c+	$(CC) -fPIC -O2 -c $< $(CFLAGS) -I ../include -I $(HS_INCLUDE_DIR) -o $@++apple.so: apple.o+	$(CC) -shared $^ -o $@ -lapple -lffi $(LDFLAGS)++clean:+	rm -rf *.o *.so

@@ -0,0 +1,200 @@+#include <HsFFI.h>+#include <Python.h>+#include<sys/mman.h>+#include<numpy/arrayobject.h>+#include"../include/apple_abi.h"+#include"../c/ffi.c"++typedef void* U;typedef PyObject* PO;typedef PyArrayObject* NPA;typedef size_t S;++#define R return+#define Sw switch+#define C case+#define BR break;+#define CT(o,c,s) {PyArray_Descr *d=PyArray_DESCR(o);if(!(d->type==c)){PyErr_SetString(PyExc_RuntimeError,s);}}++// https://numpy.org/doc/stable/reference/c-api/array.html+U f_npy(const NPA o) {+    J rnk=PyArray_NDIM(o);+    npy_intp* dims=PyArray_DIMS(o);+    J n=PyArray_SIZE(o);+    J sz_i=1+rnk+n;+    CT(o,'d',"Error: expected an array of floats")+    S sz=sz_i*8;+    U x=malloc(sz);J* x_i=x; F* x_f=x;+    x_i[0]=rnk;+    DO(i,rnk,x_i[i+1]=(J)dims[i]);+    U data=PyArray_DATA(o);+    memcpy(x_f+rnk+1,data,n*8);+    R x;+}++U i_npy(NPA o) {+    J rnk=PyArray_NDIM(o);+    npy_intp* dims=PyArray_DIMS(o);+    J n=PyArray_SIZE(o);+    J sz_i=1+rnk+n;+    S sz=sz_i*8;+    CT(o,'l',"Error: expected an array of 64-bit integers")+    U x=malloc(sz);J* x_i=x;+    x_i[0]=rnk;+    DO(i,rnk,x_i[i+1]=(J)dims[i]);+    U data=PyArray_DATA(o);+    memcpy(x_i+rnk+1,data,n*8);+    R x;+}++PyObject* npy_i(U x) {+    J* i_p=x;+    J t=1;+    J rnk=i_p[0];+    npy_intp* dims=malloc(sizeof(npy_intp)*rnk);+    DO(i,rnk,t*=i_p[i+1];dims[i]=(npy_intp)i_p[i+1]);+    S sz=8*t;+    U data=malloc(sz);+    // TODO figure out how to do this without copying+    memcpy(data,i_p+rnk+1,sz);+    PyObject* res=PyArray_SimpleNewFromData(rnk,dims,NPY_INT64,data);+    PyArray_ENABLEFLAGS((PyArrayObject*)res,NPY_ARRAY_OWNDATA);+    free(x);R res;+}++PyObject* npy_f(U x) {+    J* i_p=x;+    J t=1;+    J rnk=i_p[0];+    npy_intp* dims=malloc(sizeof(npy_intp)*rnk);+    DO(i,rnk,t*=i_p[i+1];dims[i]=(npy_intp)i_p[i+1]);+    S sz=8*t;+    U data=malloc(sz);+    memcpy(data,i_p+rnk+1,sz);+    PyObject* res=PyArray_SimpleNewFromData(rnk,dims,NPY_FLOAT64,data);+    PyArray_ENABLEFLAGS((PyArrayObject*)res,NPY_ARRAY_OWNDATA);+    free(x);R res;+}++void freety(FnTy* x){free(x->args);free(x);}++static PyObject* apple_typeof(PyObject* self, PyObject *args) {+    const char* inp;+    PyArg_ParseTuple(args, "s", &inp);+    char* err;char** err_p = &err;+    char* res = apple_printty(inp,err_p);+    if (res == NULL) {+        PyErr_SetString(PyExc_RuntimeError, err);+        free(err);R NULL;+    }+    PyObject* pyres = PyUnicode_FromString(res);+    free(res); R pyres;+}++static PyObject* apple_asm(PyObject* self, PyObject *args) {+    const char* inp;+    PyArg_ParseTuple(args, "s", &inp);+    char* err;char** err_p = &err;+    char* res = apple_dumpasm(inp,err_p);+    if (res == NULL) {+        PyErr_SetString(PyExc_RuntimeError, err);+        free(err);R NULL;+    }+    PyObject* pyres = PyUnicode_FromString(res);+    free(res); R pyres;+}++static PyObject* apple_ir(PyObject* self, PyObject *args) {+    const char* inp;+    PyArg_ParseTuple(args, "s", &inp);+    char* err;char** err_p = &err;+    char* res = apple_dumpir(inp,err_p);+    if (res == NULL) {+        PyErr_SetString(PyExc_RuntimeError, err);+        free(err);R NULL;+    }+    PyObject* pyres = PyUnicode_FromString(res);+    free(res); R pyres;+}++typedef struct PyCacheObject {+    PyObject_HEAD+    U bc;S c_sz;FnTy* ty; U sa;ffi_cif* ffi;+} PyCacheObject;++static void cache_dealloc(PyCacheObject* self) {+    munmap(self->bc,self->c_sz);+    free(self->sa);freety(self->ty);free(self->ffi);+}++static PyTypeObject CacheType = {+    PyVarObject_HEAD_INIT(NULL, 0)+    .tp_name = "Cache",+    .tp_doc = PyDoc_STR("Cached JIT function"),+    .tp_basicsize = sizeof(PyCacheObject),+    .tp_itemsize = 0,+    .tp_flags = Py_TPFLAGS_DEFAULT,+    .tp_new = PyType_GenericNew,+    .tp_dealloc = (destructor)cache_dealloc,+};++static PyObject* apple_jit(PyObject *self, PyObject *args) {+    const char* inp;+    PyArg_ParseTuple(args, "s", &inp);+    char* err;char** err_p=&err;+    FnTy* ty=apple_ty(inp,err_p);+    if(ty == NULL){+        PyErr_SetString(PyExc_RuntimeError, err);+        free(err);R NULL;+    };+    U fp;S f_sz;U s;+    JC jc={(P)&malloc,(P)&free,(P)&lrand48,(P)&drand48,(P)&exp,(P)&log,(P)&pow};+    fp=apple_compile(&jc,inp,&f_sz,&s);+    PyCacheObject* cc=PyObject_New(PyCacheObject, &CacheType);+    ffi_cif* ffi=apple_ffi(ty);+    cc->bc=fp;cc->c_sz=f_sz;cc->ty=ty;cc->sa=s;cc->ffi=ffi;+    Py_INCREF(cc);+    R (PyObject*)cc;+}++// file:///usr/share/doc/libffi8/html/The-Basics.html+static PyObject* apple_f(PyObject* self, PyObject* args) {+    PyCacheObject* c;PO arg0=NULL;PO arg1=NULL;PO arg2=NULL;PO arg3=NULL;PO arg4=NULL;PO arg5=NULL;+    PyArg_ParseTuple(args, "O|OOOOOO", &c, &arg0, &arg1, &arg2, &arg3, &arg4, &arg5);+    FnTy* ty=c->ty;U fp=c->bc;+    PO r;+    ffi_cif* cif=c->ffi;+    int argc=ty->argc;+    U* vals=alloca(sizeof(U)*argc);+    U ret=alloca(8);+    PO pyarg;PO pyargs[]={arg0,arg1,arg2,arg3,arg4,arg5};+    for(int k=0;k<argc;k++){+        pyarg=pyargs[k];+        if(pyarg!=NULL){+            Sw(ty->args[k]){+                C IA: {U* x=alloca(sizeof(U));x[0]=i_npy((NPA)pyarg);vals[k]=x;};BR+                C FA: {U* x=alloca(sizeof(U));x[0]=f_npy((NPA)pyarg);vals[k]=x;};BR+                C I_t: {J* xi=alloca(sizeof(J));xi[0]=PyLong_AsLong(pyarg);vals[k]=xi;};BR+                C F_t: {F* xf=alloca(sizeof(F));xf[0]=PyFloat_AsDouble(pyarg);vals[k]=xf;};BR+            }+        }+    }+    ffi_call(cif,fp,ret,vals);+    Sw(ty->res){+        C IA: r=npy_i(*(U*)ret);BR+        C FA: r=npy_f(*(U*)ret);BR+        C F_t: r=PyFloat_FromDouble(*(F*)ret);BR+        C I_t: r=PyLong_FromLongLong(*(J*)ret);BR+    }+    R r;+};++static PyMethodDef AppleMethods[] = {+    {"f", apple_f, METH_VARARGS, "Run a JIT-compiled function"},+    {"jit", apple_jit, METH_VARARGS, "JIT a function"},+    {"typeof", apple_typeof, METH_VARARGS, "Display type of expression"},+    {"asm", apple_asm, METH_VARARGS, "Dump x86 assembly"},+    {"ir", apple_ir, METH_VARARGS, "Dump IR (debug)"},+    {NULL,NULL,0,NULL}+};++static struct PyModuleDef applemodule = { PyModuleDef_HEAD_INIT, "apple", NULL, -1, AppleMethods };++PyMODINIT_FUNC PyInit_apple(void) { hs_init(0,0); import_array(); R PyModule_Create(&applemodule); }

@@ -57,6 +57,8 @@  data Env = Env { _lex :: !AlexUserState, ee :: [(Nm AlexPosn, E AlexPosn)], mf :: CCtx, _arch :: Arch } +lg=lift . gets+ aEe :: Nm AlexPosn -> E AlexPosn -> Env -> Env aEe n e (Env l ees mm a) = Env l ((n,e):ees) mm a @@ -183,9 +185,7 @@ del s = lift $ modify (mE (filter (\((Nm n _ _),_) -> n /= st))) where st=T.pack s  listCtx :: Repl AlexPosn ()-listCtx = do-    bs <- lift $ gets ee-    liftIO $ putDoc (prettyLines (pretty.fst<$>bs)<>hardline)+listCtx = do {bs <- lg ee; liftIO $ putDoc (prettyLines (pretty.fst<$>bs)<>hardline)}  graph :: String -> Repl AlexPosn () graph s = liftIO $ case dumpX86Ass (ubs s) of@@ -214,18 +214,17 @@     , lOption "⍳" "integer range" "⌊" "floor"     , lOption "e:" "exp" "⨳ {m,n}" "convolve"     , lOption "\\~" "successive application" "\\`n" "dyadic infix"-    , lOption "_." "log" "'n" "map"+    , lOption "_." "log" "'" "map"     , lOption "`" "zip" "`{i,j∘[k,l]}" "rank"     , lOption "𝒻" "range (real)" "𝜋" "pi"     , lOption "_" "negate" ":" "size"-    , lOption "𝓉" "dimension" "}.?" "last"+    , lOption "𝓉" "dimension" "{x⟜y;z}" "no inline"     , lOption "->n" "select" "**" "power"-    , lOption "re:" "repeat" "}." "typesafe last"+    , lOption "re:" "repeat" "}." "last"     , lOption "⊲" "cons" "⊳" "snoc"     , lOption "^:" "iterate" "%." "matmul"     , lOption "⊗" "outer product" "⍉, |:" "transpose"-    , lOption "{.?" "head" "{." "typesafe head"-    , lOption "}.?" "last" "}:" "typesafe init"+    , lOption "{." "head" "}:" "typesafe init"     , lOption "⟨z,w⟩" "array literal" "?p,.e1,.e2" "conditional"     , lOption "/*" "fold all" "ℝ" "i->f conversion"     , lOption "⧺" "cat" "{:" "typesafe tail"@@ -234,13 +233,14 @@     , lOption "/ₒ" "fold with seed" "Λₒ" "scan with seed"     , lOption "{x←y;z}" "let...in" "⊙" "cycle"     , lOption "˙" "at" "|" "rem"-    , lOption "@." "index of" "di." "diagonal"+    , lOption "@." "index of" "/." "idiv"     , lOption "%:" "vector mul" "odd." "parity"     , lOption "~" "reverse" "¬,⊻,∧,∨" "logical"     , lOption "♭" "flatten" "♮" "add dimension"     , lOption "⩪" "indices of" "§, #." "filter"     , lOption "👁️" "identity m" "(i × j)" "dimensions"-    , lOption "gen." "generate" "{x⟜y;z}" "no inline"+    , lOption "gen." "generate" "}:?" "init"+    , lOption "{:?" "tail" "∴" "compose"     ]  lOption op0 desc0 op1 desc1 =@@ -258,13 +258,13 @@  disasm :: String -> Repl AlexPosn () disasm s = do-    st <- lift $ gets _lex-    a <- lift $ gets _arch-    let d=case a of {X64 -> eDtxt; AArch64{} -> edAtxt}+    st <- lg _lex     case rwP st (ubs s) of         Left err -> liftIO $ putDoc (pretty err <> hardline)         Right (eP, i) -> do             eC <- eRepl eP+            a <- lg _arch+            let d=case a of {X64 -> eDtxt; AArch64{} -> edAtxt}             res <- liftIO $ d i eC             liftIO $ case res of                 Left err -> putDoc (pretty err <> hardline)@@ -272,7 +272,7 @@  cR :: String -> Repl AlexPosn () cR s = do-    st <- lift $ gets _lex+    st <- lg _lex     case rwP st (ubs s) of         Left err -> liftIO $ putDoc (pretty err <> hardline)         Right (eP, i) -> do@@ -283,7 +283,7 @@  irR :: String -> Repl AlexPosn () irR s = do-    st <- lift $ gets _lex+    st <- lg _lex     case rwP st (ubs s) of         Left err -> liftIO $ putDoc (pretty err <> hardline)         Right (eP, i) -> do@@ -294,19 +294,20 @@  dumpAsm :: String -> Repl AlexPosn () dumpAsm s = do-    st <- lift $ gets _lex; a <- lift $ gets _arch-    let dump = case a of {X64 -> eDumpX86; AArch64{} -> eDumpAarch64}+    st <- lg _lex     case rwP st (ubs s) of         Left err -> liftIO $ putDoc (pretty err <> hardline)         Right (eP, i) -> do             eC <- eRepl eP+            a <- lg _arch+            let dump = case a of {X64 -> eDumpX86; AArch64{} -> eDumpAarch64}             liftIO $ case dump i eC of                 Left err -> putDoc (pretty err <> hardline)                 Right d  -> putDoc (d <> hardline)  tyExprR :: String -> Repl AlexPosn () tyExprR s = do-    st <- lift $ gets _lex+    st <- lg _lex     case rwP st (ubs s) of         Left err -> liftIO $ putDoc (pretty err <> hardline)         Right (eP, i) -> do@@ -317,7 +318,7 @@  annR :: String -> Repl AlexPosn () annR s = do-    st <- lift $ gets _lex+    st <- lg _lex     case rwP st (ubs s) of         Left err    -> liftIO $ putDoc (pretty err <> hardline)         Right (eP, i) -> do@@ -340,8 +341,7 @@  inspect :: String -> Repl AlexPosn () inspect s = do-    st <- lift $ gets _lex-    a <- lift $ gets _arch+    st <- lg _lex     case rwP st bs of         Left err -> liftIO $ putDoc (pretty err <> hardline)         Right (eP, i) -> do@@ -349,7 +349,7 @@             case tyC i eC of                 Left err -> liftIO $ putDoc (pretty err <> hardline)                 Right (e, _, i') -> do-                    c <- lift $ gets mf+                    a <- lg _arch; c <- lg mf                     let efp=case a of {X64 -> eFunP i' c; AArch64 m -> eAFunP i' (c,m)}                     liftIO $ do                         asm@(_, fp, _) <- efp eC@@ -364,7 +364,7 @@     if not p         then liftIO $ putStrLn "file does not exist."         else do-            st <- lift $ gets _lex+            st <- lg _lex             bs <- liftIO $ BSL.readFile fp             case tyParseCtx st bs of                 Left err -> liftIO $ putDoc (pretty err <> hardline)@@ -378,8 +378,7 @@ benchC s = case tyParse bs of     Left err -> liftIO $ putDoc (pretty err <> hardline)     Right _ -> do-        c <- lift $ gets mf-        a <- lift $ gets _arch+        c <- lg mf; a <- lg _arch         let cfp=case a of {X64 -> ctxFunP c; AArch64 m -> actxFunP (c,m)}         liftIO $ benchmark (nfIO (do{asm <- cfp bs; freeAsm asm}))     where bs = ubs s@@ -391,8 +390,7 @@  qc :: String -> Repl AlexPosn () qc s = do-    st <- lift $ gets _lex-    a <- lift $ gets _arch+    st <- lg _lex     case rwP st bs of         Left err -> liftIO $ putDoc (pretty err <> hardline)         Right (eP, i) -> do@@ -400,7 +398,7 @@             case tyC i eC of                 Left err -> liftIO $ putDoc (pretty err <> hardline)                 Right (e, _, i') -> do-                    c <- lift$gets mf+                    c <- lg mf; a <- lg _arch                     let efp=case a of {X64 -> eFunP i' c; AArch64 m -> eAFunP i' (c,m)}                     case up (eAnn e) of                         Nothing -> pErr ("must be a proposition." :: T.Text)@@ -411,8 +409,8 @@                                     (args, es, mps) <- unzip3 <$> gas ty                                     b <- callFFI fp retCUChar args                                     (if cb b-                                        then traverse free (catMaybes mps) *> loopϵ (n-1)-                                        else Just es <$ traverse_ free (catMaybes mps))+                                        then traverse freeP (catMaybes mps) *> loopϵ (n-1)+                                        else Just es <$ traverse_ freeP (catMaybes mps))                             res <- loopϵ (100::Int)                             case res of                                 Nothing -> putDoc ("Passed, 100." <> hardline)@@ -425,8 +423,7 @@  benchE :: String -> Repl AlexPosn () benchE s = do-    st <- lift $ gets _lex-    a <- lift $ gets _arch+    st <- lg _lex     case rwP st bs of         Left err -> pErr err         Right (eP, i) -> do@@ -434,7 +431,7 @@             case tyC i eC of                 Left err -> pErr err                 Right (e, _, i') -> do-                    c <- lift $ gets mf+                    c <- lg mf; a <- lg _arch                     let efp=case a of {X64 -> eFunP i' c; AArch64 m -> eAFunP i' (c,m)}                     case eAnn e of                         I -> do@@ -468,10 +465,17 @@  rSz A.B=1; rSz I=8; rSz A.F=8; rSz (P ts) = sum (rSz<$>ts); rSz Arr{}=8 +pD :: [Int64] -> Doc ann+pD [i] = "Vec" <+> pretty i+pD is  = "Arr" <+> tupledBy "×" (pretty<$>is)+ pE :: [Int64] -> [Doc ann] -> Doc ann-pE [_, n] xs = align (brackets (space <> concatWith (\x y -> x <> hardline <> ", " <> y) (list<$>chunksOf (fromIntegral n) xs) <> space))-pE _ xs      = list xs+pE is es = pD is <+> pEs is es +pEs :: [Int64] -> [Doc ann] -> Doc ann+pEs [_, n] xs = align (brackets (space <> concatWith (\x y -> x <> hardline <> ", " <> y) (list<$>chunksOf (fromIntegral n) xs) <> space))+pEs _ xs      = align (list xs)+ pR :: T a -> Ptr b -> IO (Doc ann) pR I p      = do {i <- peek (castPtr p :: Ptr Int64); pure (pretty i)} pR A.F p    = do {f <- peek (castPtr p :: Ptr Double); pure (pretty f)}@@ -509,8 +513,7 @@  printExpr :: String -> Repl AlexPosn () printExpr s = do-    st <- lift $ gets _lex-    a <- lift $ gets _arch+    st <- lg _lex     case rwP st bs of         Left err -> liftIO $ putDoc (pretty err <> hardline)         Right (eP, i) -> do@@ -522,7 +525,7 @@                         let t=eAnn e in putDoc (pretty e <+> ":" <+> pretty t <> hardline)                 Left err -> liftIO $ putDoc (pretty err <> hardline)                 Right (e, _, i') -> do-                    c <- lift $ gets mf+                    c <- lg mf; a <- lg _arch                     let efp=case a of {X64 -> eFunP i' c; AArch64 ma -> eAFunP i' (c,ma)}                     case eAnn e of                         I ->@@ -553,8 +556,24 @@  parseE st bs = fst . either (error "Internal error?") id $ rwP st bs +mentions :: E a -> Nm a -> Bool+mentions (EApp _ e0 e1) n     = e0 `mentions` n || e1 `mentions` n+mentions (Var _ n1) n         = n==n1+mentions ILit{} _             = False+mentions FLit{} _             = False+mentions BLit{} _             = False+mentions (Cond _ p e0 e1) n   = p `mentions` n || e0 `mentions` n || e1 `mentions` n+mentions Builtin{} _          = False+mentions (Let _ (_, eϵ) e) n  =  e `mentions` n || eϵ `mentions` n+mentions (Def _ (_, eϵ) e) n  =  e `mentions` n || eϵ `mentions` n+mentions (LLet _ (_, eϵ) e) n = e `mentions` n || eϵ `mentions` n+mentions (ALit _ es) n        = any (`mentions` n) es+mentions (A.Lam _ _ e) n      = e `mentions` n+mentions (Ann _ e _) n        = e `mentions` n+mentions (Tup _ es) n         = any (`mentions` n) es+ eRepl :: E AlexPosn -> Repl AlexPosn (E AlexPosn)-eRepl e = do { ees <- lift $ gets ee; pure $ foldLet ees e }-    where foldLet = thread . fmap (\b@(_,eϵ) -> Let (eAnn eϵ) b) where thread = foldr (.) id+eRepl e = do { ees <- lg ee; pure $ foldLet ees e }+    where foldLet = thread . fmap (\b@(n,eϵ) eR -> if eR `mentions` n then Let (eAnn eϵ) b eR else eR) where thread = foldr (.) id  pErr err = liftIO $ putDoc (pretty err <> hardline)

@@ -1,4 +1,4 @@-module QC ( gas, Val (..) ) where+module QC ( gas, Val (..), freeP ) where  import           A import           Control.Monad.State.Strict (StateT, evalStateT, get, gets, modify, put, runStateT)@@ -9,7 +9,7 @@ import qualified Data.IntMap                as IM import           Foreign.C.Types            (CDouble (..)) import           Foreign.LibFFI             (Arg, argCDouble, argInt64, argPtr)-import           Foreign.Marshal.Alloc      (mallocBytes)+import           Foreign.Marshal.Alloc      (free, mallocBytes) import           Foreign.Ptr                (Ptr) import           Foreign.Storable           (poke, sizeOf) import           Hs.A@@ -50,31 +50,49 @@         Nothing -> do {r <- lift rnk; ds <- lift$vectorOf (fromIntegral r) dim; modify (mapS (IM.insert n (r,ds))) $> (r,ds)}         Just s  -> pure s -data ValP = ArrDp (Ptr (Apple Double))+data ValP = ArrDp !(Ptr (Apple Double)) | ArrIp !(Ptr (Apple Int64)) -gas :: [T a] -> IO [(Arg, Val, Maybe (Ptr (Apple Double)))]+freeP :: ValP -> IO ()+freeP (ArrDp a) = free a+freeP (ArrIp a) = free a++gas :: [T a] -> IO [(Arg, Val, Maybe ValP)] gas = flip evalStateT (RSubst IM.empty IM.empty).traverse ga -data Val = ArrD !(Apple Double) | II !Int64 | D !Double+data Val = ArrD !(Apple Double) | AI !(Apple Int64) | II !Int64 | D !Double  instance Pretty Val where     pretty (ArrD a) = pretty a+    pretty (AI a)   = pretty a     pretty (II i)   = pretty i     pretty (D d)    = pretty d -ga :: T a -> StateT RSubst IO (Arg, Val, Maybe (Ptr (Apple Double)))+ga :: T a -> StateT RSubst IO (Arg, Val, Maybe ValP) ga (Arr sh A.F) = do     st <- get     (a, st') <- lift $ generate $ runStateT (gD sh) st     put st'     p <- lift $ mallocBytes (sizeOf a)-    lift (poke p a $> (argPtr p, ArrD a, Just p))+    lift (poke p a $> (argPtr p, ArrD a, Just (ArrDp p)))+ga (Arr sh A.I) = do+    st <- get+    (a, st') <- lift $ generate $ runStateT (gI sh) st+    put st'+    p <- lift $ mallocBytes (sizeOf a)+    lift (poke p a $> (argPtr p, AI a, Just (ArrIp p))) ga I = do     i <- lift $ generate chooseAny     pure (argInt64 i, II i, Nothing) ga A.F = do     x <- lift $ generate chooseAny     pure (argCDouble (CDouble x), D x, Nothing)++gI :: Sh a -> ShM (Apple Int64)+gI sh = do+    (r, ds) <- gg sh+    let n=fromIntegral$product ds+    es <- lift$vectorOf n chooseAny+    pure (AA r ds es)  gD :: Sh a -> ShM (Apple Double) gD sh = do

@@ -213,6 +213,7 @@     pretty Eye       = "👁️"     pretty Sr        = ">>"     pretty Sl        = "<<"+    pretty C         = "∴"  data Builtin = Plus | Minus | Times | Div | IntExp | Exp | Log              | Eq | Neq | Gt | Lt | Gte | Lte | CatE | IDiv | Mod@@ -228,9 +229,9 @@              | Mul | VMul | Outer | R | Head | HeadM | Tail | Init | RevE              | TailM | InitM              | Sin | Cos | Rot | Tan | Cyc | A1 | Even | Odd | IOf | Abs-             | And | Or | Xor | N | Sr | Sl+             | And | Or | Xor | N | Sr | Sl | C              deriving (Generic)-             -- TODO: window (feuilleter, stagger, ...) functions, reshape...?+             -- TODO: (feuilleter, stagger, ...) reshape...?  ptName :: Nm (T a) -> Doc ann ptName n@(Nm _ _ t) = parens (pretty n <+> ":" <+> pretty t)@@ -273,6 +274,7 @@ mPrec Mod    = Just 7 mPrec Succ   = Just 9 mPrec Fold   = Just 9+mPrec C      = Just 9 mPrec Ices   = Just 6 mPrec Filt   = Just 6 mPrec Map    = Just 5

@@ -29,6 +29,9 @@ optA e@BLit{}              = pure e optA e@Var{}               = pure e optA (Builtin t (Rank rs)) = pure (Builtin t (Rank (g<$>rs))) where g r@(_,Just{})=r; g (cr,Nothing)=(cr, Just [1..cr])+optA (Builtin ty C)        | Arrow fTy (Arrow gTy xTy@(Arrow tC tD)) <- ty = do+    f <- nextU "f" fTy; g <- nextU "g" gTy; x <- nextU "x" tC+    pure $ Lam ty f (Lam (gTy ~> xTy) g (Lam (tC ~> tD) x (EApp tD (Var fTy f) (EApp undefined (Var gTy g) (Var tC x))))) optA e@Builtin{}           = pure e optA (EApp _ (Builtin _ Size) xs) | Arr sh _ <- eAnn xs, Just sz <- mSz sh = pure $ ILit I (toInteger sz) optA (EApp _ (Builtin _ Dim) xs) | Arr (Ix _ i `Cons` _) _ <- eAnn xs = pure $ ILit I (toInteger i)@@ -103,15 +106,22 @@     | Arrow dom fCod <- eAnn f     , Arrow _ (Arrow _ cod) <- eAnn op = do         x' <- optA x-        x0 <- nextU "x" cod-        x1 <- nextU "y" dom+        x0 <- nextU "x" cod; x1 <- nextU "y" dom         opA <- optA op-        let vx0 = Var cod x0-            vx1 = Var dom x1+        let vx0 = Var cod x0; vx1 = Var dom x1             opTy = cod ~> dom ~> cod             op' = Lam opTy x0 (Lam (dom ~> cod) x1 (EApp cod (EApp undefined opA vx0) (EApp fCod f vx1)))             arrTy = eAnn x'         optA (EApp l0 (EApp undefined (EApp (arrTy ~> l0) (Builtin (opTy ~> arrTy ~> l0) ho0) op') seed) x')+optA (EApp l0 (EApp _ (Builtin _ Succ) f) (EApp _ (EApp _ (Builtin _ Map) g) xs))+    | (Arrow _ (Arrow _ fCod)) <- eAnn f+    , (Arrow gDom _) <- eAnn g = do+        f' <- optA f; g' <- optA g; g'' <- rE g+        xs' <- optA xs+        x <- nextU "w" gDom; y <- nextU "v" gDom+        let vx=Var gDom x; vy=Var gDom y+            f2g=Lam (gDom ~> gDom ~> fCod) x (Lam (gDom ~> fCod) y (EApp undefined (EApp undefined f' (EApp undefined g' vx)) (EApp undefined g'' vy)))+        pure (EApp l0 (EApp undefined (Builtin undefined Succ) f2g) xs') optA (EApp l0 (EApp _ (Builtin _ Map) f) (EApp _ (EApp _ (Builtin _ Map) g) xs))     | (Arrow _ fCod) <- eAnn f     , (Arrow gDom _) <- eAnn g = do@@ -135,22 +145,84 @@             op' = Lam opT x0 (Lam (dom ~> cod) x1 (EApp cod (EApp undefined opA vx0) (EApp fCod f' vx1)))             f''' = Lam fTy x0' (EApp fCod f'' vx0')         pure $ Id l0 $ FoldOfZip f''' op' [x']-optA (EApp _ (EApp _ (EApp _ (Builtin _ Zip) op) (EApp _ (EApp _ (Builtin _ Map) f) xs)) (EApp _ (EApp _ (Builtin _ Map) g) ys))+optA (EApp l0 (EApp _ (Builtin _ (Rank [(0,_)])) f) (EApp _ (EApp _ (EApp _ ho@(Builtin _ (Rank [(0,_),(0,_)])) op) xs) ys))+    | Arrow _ cod <- eAnn f+    , Arrow dom0 (Arrow dom1 _) <- eAnn op = do+        f' <- optA f; opA <- optA op; ho' <- optA ho+        xs' <- optA xs; ys' <- optA ys+        x <- nextU "x" dom0; y <- nextU "y" dom1+        let vx=Var dom0 x; vy=Var dom1 y+            opTy = dom0 ~> dom1 ~> cod+            op' = Lam opTy x (Lam undefined y (EApp undefined f' (EApp undefined (EApp undefined opA vx) vy)))+        pure (EApp l0 (EApp undefined (EApp undefined (ho' { eAnn = undefined }) op') xs') ys')+optA (EApp l0 (EApp _ (EApp _ ho@(Builtin _ (Rank [(0,_),(0,_)])) op) (EApp _ (EApp _ (Builtin _ (Rank [(0,_)])) f) xs)) (EApp _ (EApp _ (Builtin _ (Rank [(0,_)])) g) ys))     | Arrow dom0 _ <- eAnn f     , Arrow dom1 _ <- eAnn g     , Arrow _ (Arrow _ cod) <- eAnn op = do-        f' <- optA f+        f' <- optA f; g' <- optA g+        opA <- optA op; ho' <- optA ho+        xs' <- optA xs; ys' <- optA ys+        x <- nextU "x" dom0; y <- nextU "y" dom1+        let vx = Var dom0 x; vy = Var dom1 y+            opTy = dom0 ~> dom1 ~> cod+            op' = Lam opTy x (Lam undefined y (EApp undefined (EApp undefined opA (EApp undefined f' vx)) (EApp undefined g' vy)))+        pure (EApp l0 (EApp undefined (EApp undefined (ho' { eAnn = undefined }) op') xs') ys')+optA (EApp l0 (EApp _ (EApp _ ho@(Builtin _ (Rank [(0,_),(0,_)])) op) xs) (EApp _ (EApp _ (Builtin _ (Rank [(0,_)])) g) ys))+    | Arrow dom _ <- eAnn g+    , Arrow xT (Arrow _ cod) <- eAnn op = do         g' <- optA g+        opA <- optA op; ho' <- optA ho+        xs' <- optA xs; ys' <- optA ys+        x <- nextU "x" xT; y <- nextU "y" dom+        let vx = Var xT x; vy = Var dom y+            opTy = xT ~> dom ~> cod+            op' = Lam opTy x (Lam undefined y (EApp undefined (EApp undefined opA vx) (EApp undefined g' vy)))+        pure (EApp l0 (EApp undefined (EApp undefined (ho' { eAnn = undefined }) op') xs') ys')+optA (EApp l0 (EApp _ (EApp _ ho@(Builtin _ (Rank [(0,_),(0,_)])) op) (EApp _ (EApp _ (Builtin _ (Rank [(0,_)])) f) xs)) ys)+    | Arrow dom _ <- eAnn f+    , Arrow _ (Arrow yT cod) <- eAnn op = do+        f' <- optA f+        opA <- optA op; ho' <- optA ho+        xs' <- optA xs; ys' <- optA ys+        x <- nextU "x" dom; y <- nextU "y" yT+        let vx = Var dom x; vy = Var yT y+            opTy = dom ~> yT ~> cod+            op' = Lam opTy x (Lam undefined y (EApp undefined (EApp undefined opA (EApp undefined f' vx)) vy))+        pure (EApp l0 (EApp undefined (EApp undefined (ho' { eAnn = undefined }) op') xs') ys')+optA (EApp _ (EApp _ (EApp _ (Builtin _ Zip) op) (EApp _ (EApp _ (Builtin _ Map) f) xs)) (EApp _ (EApp _ (Builtin _ Map) g) ys))+    | Arrow dom0 _ <- eAnn f+    , Arrow dom1 _ <- eAnn g+    , Arrow _ (Arrow _ cod) <- eAnn op = do+        f' <- optA f; g' <- optA g         opA <- optA op-        xs' <- optA xs-        ys' <- optA ys-        x0 <- nextU "x" cod-        x1 <- nextU "y" dom0-        let vx0 = Var dom0 x0-            vx1 = Var dom1 x1+        xs' <- optA xs; ys' <- optA ys+        x0 <- nextU "x" dom0; x1 <- nextU "y" dom1+        let vx0 = Var dom0 x0; vx1 = Var dom1 x1             opTy = dom0 ~> dom1 ~> cod             op' = Lam opTy x0 (Lam undefined x1 (EApp undefined (EApp undefined opA (EApp undefined f' vx0)) (EApp undefined g' vx1)))         pure (EApp undefined (EApp undefined (EApp undefined (Builtin undefined Zip) op') xs') ys')+optA (EApp l (EApp _ (EApp _ (Builtin _ Zip) op) (EApp _ (EApp _ (Builtin _ Map) f) xs)) ys)+    | Arrow dom0 _ <- eAnn f+    , Arrow _ (Arrow dom1 cod) <- eAnn op = do+        f' <- optA f+        opA <- optA op+        xs' <- optA xs; ys' <- optA ys+        x0 <- nextU "x" dom0; x1 <- nextU "y" dom1+        let vx0 = Var dom0 x0; vx1 = Var dom1 x1+            opTy = dom0 ~> dom1 ~> cod+            op' = Lam opTy x0 (Lam undefined x1 (EApp undefined (EApp undefined opA (EApp undefined f' vx0)) vx1))+        pure (EApp l (EApp undefined (EApp undefined (Builtin undefined Zip) op') xs') ys')+optA (EApp l (EApp _ (EApp _ (Builtin _ Zip) op) xs) (EApp _ (EApp _ (Builtin _ Map) g) ys))+    | Arrow dom1 _ <- eAnn g+    , Arrow dom0 (Arrow _ cod) <- eAnn op = do+        g' <- optA g+        opA <- optA op+        xs' <- optA xs; ys' <- optA ys+        x0 <- nextU "x" dom0; x1 <- nextU "y" dom1+        let vx0 = Var dom0 x0; vx1 = Var dom1 x1+            opTy = dom0 ~> dom1 ~> cod+            op' = Lam opTy x0 (Lam undefined x1 (EApp undefined (EApp undefined opA vx0) (EApp undefined g' vx1)))+        pure (EApp l (EApp undefined (EApp undefined (Builtin undefined Zip) op') xs') ys') optA (EApp l (EApp t0 (EApp t1 (Builtin bt b@FoldS) op) seed) arr) = do     arr' <- optA arr     seed' <- optA seed@@ -176,8 +248,7 @@             | fTy@(Arrow dom0 (Arrow dom1 dom2)) <- eAnn f             , Arrow _ (Arrow _ cod) <- eAnn op -> do                 f' <- optA f; f'' <- rE f'-                xs' <- optA xs-                ys' <- optA ys+                xs' <- optA xs; ys' <- optA ys                 x0 <- nextU "x" cod; x1 <- nextU "y" dom0; x2 <- nextU "z" dom1                 x0' <- nextU "x" dom0; x1' <- nextU "y" dom1                 let vx0 = Var cod x0; vx1 = Var dom0 x1; vx2 = Var dom1 x2

@@ -6,15 +6,12 @@                    , Addr (..)                    , Cond (..)                    , Shift (..), BM (..)-                   , AbsReg (..)-                   , FAbsReg (..)-                   , AReg (..)-                   , FAReg (..)+                   , AbsReg (..), FAbsReg (..), F2Abs (..)+                   , AReg (..), FAReg (..), F2Reg (..)+                   , SIMD (..), simd2                    , prettyDebug-                   , mapR-                   , mapFR-                   , toInt-                   , fToInt+                   , mapR, mapFR, mapF2+                   , toInt, fToInt, f2ToInt                    , pus, pos                    , puds, pods                    , pSym@@ -23,6 +20,7 @@ import           Asm.M import           Control.DeepSeq   (NFData (..)) import           Data.Copointed+import           Data.List         (scanl') import           Data.Word         (Word16, Word8) import           GHC.Generics      (Generic) import           Numeric           (showHex)@@ -41,6 +39,9 @@  instance Show AReg where show = show.pretty +simd2 :: FAReg -> F2Reg+simd2 = toEnum.fromEnum+ data FAReg = D0 | D1 | D2 | D3 | D4 | D5 | D6 | D7 | D8 | D9 | D10 | D11 | D12 | D13 | D14 | D15 | D16 | D17 | D18 | D19 | D20 | D21 | D22 | D23 | D24 | D25 | D26 | D27 | D28 | D29 | D30 | D31 deriving (Eq, Ord, Enum, Generic)  instance Pretty FAReg where@@ -49,10 +50,28 @@     pretty D16 = "d16"; pretty D17 = "d17"; pretty D18 = "d18"; pretty D19 = "d19"; pretty D20 = "d20"; pretty D21 = "d21"; pretty D22 = "d22"; pretty D23 = "d23"     pretty D24 = "d24"; pretty D25 = "d25"; pretty D26 = "d26"; pretty D27 = "d27"; pretty D28 = "d28"; pretty D29 = "d29"; pretty D30 = "d30"; pretty D31 = "d31" -instance Show FAReg where show = show.pretty+instance Show FAReg where show=show.pretty +data F2Reg = V0 | V1 | V2 | V3 | V4 | V5 | V6 | V7 | V8 | V9 | V10 | V11 | V12 | V13 | V14 | V15 | V16 | V17 | V18 | V19 | V20 | V21 | V22 | V23 | V24 | V25 | V26 | V27 | V28 | V29 | V30 | V31 deriving (Eq, Ord, Enum, Generic)++class SIMD a where+    pv :: a -> Doc ann+    pq :: a -> Doc ann++instance SIMD F2Reg where+    pv V0 = "v0"; pv V1 = "v1"; pv V2 = "v2"; pv V3 = "v3"; pv V4 = "v4"; pv V5 = "v5"; pv V6 = "v6"; pv V7 = "v7"+    pv V8 = "v8"; pv V9 = "v9"; pv V10 = "v10"; pv V11 = "v11"; pv V12 = "v12"; pv V13 = "v13"; pv V14 = "v14"; pv V15 = "v15"+    pv V16 = "v16"; pv V17 = "v17"; pv V18 = "v18"; pv V19 = "v19"; pv V20 = "v20"; pv V21 = "v21"; pv V22 = "v22"; pv V23 = "v23"+    pv V24 = "v24"; pv V25 = "v25"; pv V26 = "v26"; pv V27 = "v27"; pv V28 = "v28"; pv V29 = "v29"; pv V30 = "v30"; pv V31 = "v31"++    pq V0 = "q0"; pq V1 = "q1"; pq V2 = "q2"; pq V3 = "q3"; pq V4 = "q4"; pq V5 = "q5"; pq V6 = "q6"; pq V7 = "q7"+    pq V8 = "q8"; pq V9 = "q9"; pq V10 = "q10"; pq V11 = "q11"; pq V12 = "q12"; pq V13 = "q13"; pq V14 = "q14"; pq V15 = "q15"+    pq V16 = "q16"; pq V17 = "q17"; pq V18 = "q18"; pq V19 = "q19"; pq V20 = "q20"; pq V21 = "q21"; pq V22 = "q22"; pq V23 = "q23"+    pq V24 = "q24"; pq V25 = "q25"; pq V26 = "q26"; pq V27 = "q27"; pq V28 = "q28"; pq V29 = "q29"; pq V30 = "q30"; pq V31 = "q31"+ instance NFData AReg where instance NFData FAReg where+instance NFData F2Reg where  data AbsReg = IReg !Int | CArg0 | CArg1 | CArg2 | CArg3 | CArg4 | CArg5 | CArg6 | CArg7 | LR | FP | ASP -- r0-r7 used for return values as well@@ -71,6 +90,10 @@     pretty CArg7    = "X7"     pretty FP       = "FP" +data F2Abs = F2Reg !Int++instance SIMD F2Abs where pq (F2Reg i) = "~Q" <> pretty i; pv (F2Reg i) = "~V" <> pretty i+ data FAbsReg = FReg !Int | FArg0 | FArg1 | FArg2 | FArg3 | FArg4 | FArg5 | FArg6 | FArg7  instance Pretty FAbsReg where@@ -109,6 +132,9 @@ fToInt FArg7    = 17 fToInt (FReg i) = 19+i +f2ToInt :: F2Abs -> Int+f2ToInt (F2Reg i) = 19+i+ data Shift = Zero | Three  instance NFData Shift where rnf Zero = (); rnf Three = ()@@ -130,6 +156,7 @@  instance Pretty reg => Pretty (Addr reg) where     pretty (R r)      = brackets (pretty r)+    pretty (RP r 0)   = brackets (pretty r)     pretty (RP r u)   = brackets (pretty r <> "," <+> hexd u)     pretty (BI b i s) = brackets (pretty b <> "," <+> pretty i <> "," <+> "LSL" <+> pretty s) @@ -145,83 +172,86 @@ pSym = case os of {"linux" -> id; "darwin" -> ("_"<>)}.pretty  -- https://developer.arm.com/documentation/ddi0596/2020-12/Base-Instructions-data AArch64 reg freg a = Label { ann :: a, label :: Label }-                        | B { ann :: a, label :: Label }-                        | Blr { ann :: a, rSrc :: reg }-                        | C { ann :: a, label :: Label }-                        | Bl { ann :: a, cfunc :: CFunc }-                        | Bc { ann :: a, cond :: Cond, label :: Label }-                        | Ret { ann :: a } | RetL { ann :: a, label :: Label }-                        | FMovXX { ann :: a, dDest, dSrc :: freg }-                        | FMovDR { ann :: a, dDest :: freg, rSrc :: reg }-                        | MovRR { ann :: a, rDest, rSrc :: reg }-                        | MovRC { ann :: a, rDest :: reg, cSrc :: Word16 }-                        | MovZ { ann :: a, rDest :: reg, cSrc :: Word16, lsl :: Int }-                        | MovRCf { ann :: a, rDest :: reg, cfunc :: CFunc }-                        | LdrRL { ann :: a, rDest :: reg, lSrc :: Int }-                        | MovK { ann :: a, rDest :: reg, cSrc :: Word16, lsl :: Int }-                        | Ldr { ann :: a, rDest :: reg, aSrc :: Addr reg }-                        | LdrB { ann :: a, rDest :: reg, aSrc :: Addr reg }-                        | Str { ann :: a, rSrc :: reg, aDest :: Addr reg }-                        | StrB { ann :: a, rSrc :: reg, aDest :: Addr reg }-                        | LdrD { ann :: a, dDest :: freg, aSrc :: Addr reg }-                        | StrD { ann :: a, dSrc :: freg, aDest :: Addr reg }-                        | SubRR { ann :: a, rDest, rSrc1, rSrc2 :: reg }-                        | AddRR { ann :: a, rDest, rSrc1, rSrc2 :: reg }-                        | AddRRS { ann :: a, rDest, rSrc1, rSrc2 :: reg, sC :: Word8 }-                        | ZeroR { ann :: a, rDest :: reg }-                        | Mvn { ann :: a, rDest, rSrc :: reg }-                        | AndRR { ann :: a, rDest, rSrc1, rSrc2 :: reg }-                        | OrRR { ann :: a, rDest, rSrc1, rSrc2 :: reg }-                        | Eor { ann :: a, rDest, rSrc1, rSrc2 :: reg }-                        | MulRR { ann :: a, rDest, rSrc1, rSrc2 :: reg }-                        | Madd { ann :: a, rDest, rSrc1, rSrc2, rSrc3 :: reg }-                        | Msub { ann :: a, rDest, rSrc1, rSrc2, rSrc3 :: reg }-                        | Sdiv { ann :: a, rDest, rSrc1, rSrc2 :: reg }-                        | AddRC { ann :: a, rDest, rSrc :: reg, rC :: Word16 }-                        | SubRC { ann :: a, rDest, rSrc :: reg, rC :: Word16 }-                        | Lsl { ann :: a, rDest, rSrc :: reg, sC :: Word8 }-                        | Asr { ann :: a, rDest, rSrc :: reg, sC :: Word8 }-                        | CmpRC { ann :: a, rSrc :: reg, cSrc :: Word16 }-                        | CmpRR { ann :: a, rSrc1, rSrc2 :: reg }-                        | Neg { ann :: a, rDest, rSrc :: reg }-                        | Fmul { ann :: a, dDest, dSrc1, dSrc2 :: freg }-                        | Fadd { ann :: a, dDest, dSrc1, dSrc2 :: freg }-                        | Fsub { ann :: a, dDest, dSrc1, dSrc2 :: freg }-                        | Fdiv { ann :: a, dDest, dSrc1, dSrc2 :: freg }-                        | FcmpZ { ann :: a, dSrc :: freg }-                        | Fcmp { ann :: a, dSrc1, dSrc2 :: freg }-                        | Fneg { ann :: a, dDest, dSrc :: freg }-                        | Scvtf { ann :: a, dDest :: freg, rSrc :: reg }-                        | Fcvtms { ann :: a, rDest :: reg, dSrc :: freg }-                        | Fcvtas { ann :: a, rDest :: reg, dSrc :: freg }-                        | Stp { ann :: a, rSrc1, rSrc2 :: reg, aDest :: Addr reg }-                        | Ldp { ann :: a, rDest1, rDest2 :: reg, aSrc :: Addr reg }-                        | StpD { ann :: a, dSrc1, dSrc2 :: freg, aDest :: Addr reg }-                        | LdpD { ann :: a, dDest1, dDest2 :: freg, aSrc :: Addr reg }-                        | Fmadd { ann :: a, dDest, dSrc1, dSrc2, dSrc3 :: freg }-                        | Fmsub { ann :: a, dDest, dSrc1, dSrc2, dSrc3 :: freg }-                        | Fsqrt { ann :: a, dDest, dSrc :: freg }-                        | Frintm { ann :: a, dDest, dSrc :: freg }-                        | MrsR { ann :: a, rDest :: reg }-                        | Fmax { ann :: a, dDest, dSrc1, dSrc2 :: freg }-                        | Fmin { ann :: a, dDest, dSrc1, dSrc2 :: freg }-                        | Fabs { ann :: a, dDest, dSrc :: freg }-                        | Csel { ann :: a, rDest, rSrc1, rSrc2 :: reg, cond :: Cond }-                        | Tbnz { ann :: a, rSrc :: reg, bit :: Word8, label :: Label }-                        | Tbz { ann :: a, rSrc :: reg, bit :: Word8, label :: Label }-                        | Cbnz { ann :: a, rSrc :: reg, label :: Label }-                        | Fcsel { ann :: a, dDest, dSrc1, dSrc2 :: freg, cond :: Cond }-                        | Cset { ann :: a, rDest :: reg, cond :: Cond }-                        | TstI { ann :: a, rSrc1 :: reg, imm :: BM }-                        | EorI { ann :: a, rSrc, rDesg :: reg, imm :: BM }-                        deriving (Functor, Generic)+data AArch64 reg freg f2 a = Label { ann :: a, label :: Label }+                         | B { ann :: a, label :: Label }+                         | Blr { ann :: a, rSrc :: reg }+                         | C { ann :: a, label :: Label }+                         | Bl { ann :: a, cfunc :: CFunc }+                         | Bc { ann :: a, cond :: Cond, label :: Label }+                         | Ret { ann :: a }                                              | RetL { ann :: a, label :: Label }+                         | FMovXX { ann :: a, dDest, dSrc :: freg }+                         | FMovDR { ann :: a, dDest :: freg, rSrc :: reg }+                         | MovRR { ann :: a, rDest, rSrc :: reg }+                         | MovRC { ann :: a, rDest :: reg, cSrc :: Word16 }+                         | MovZ { ann :: a, rDest :: reg, cSrc :: Word16, lsl :: Int }+                         | MovRCf { ann :: a, rDest :: reg, cfunc :: CFunc }+                         | LdrRL { ann :: a, rDest :: reg, lSrc :: Int }+                         | MovK { ann :: a, rDest :: reg, cSrc :: Word16, lsl :: Int }+                         | Ldr { ann :: a, rDest :: reg, aSrc :: Addr reg }+                         | LdrB { ann :: a, rDest :: reg, aSrc :: Addr reg }+                         | Str { ann :: a, rSrc :: reg, aDest :: Addr reg }+                         | StrB { ann :: a, rSrc :: reg, aDest :: Addr reg }+                         | LdrD { ann :: a, dDest :: freg, aSrc :: Addr reg }+                         | StrD { ann :: a, dSrc :: freg, aDest :: Addr reg }+                         | SubRR { ann :: a, rDest, rSrc1, rSrc2 :: reg }+                         | AddRR { ann :: a, rDest, rSrc1, rSrc2 :: reg }+                         | AddRRS { ann :: a, rDest, rSrc1, rSrc2 :: reg, sC :: Word8 }+                         | ZeroR { ann :: a, rDest :: reg }+                         | Mvn { ann :: a, rDest, rSrc :: reg }+                         | AndRR { ann :: a, rDest, rSrc1, rSrc2 :: reg }+                         | OrRR { ann :: a, rDest, rSrc1, rSrc2 :: reg }+                         | Eor { ann :: a, rDest, rSrc1, rSrc2 :: reg }+                         | MulRR { ann :: a, rDest, rSrc1, rSrc2 :: reg }+                         | Madd { ann :: a, rDest, rSrc1, rSrc2, rSrc3 :: reg }+                         | Msub { ann :: a, rDest, rSrc1, rSrc2, rSrc3 :: reg }+                         | Sdiv { ann :: a, rDest, rSrc1, rSrc2 :: reg }+                         | AddRC { ann :: a, rDest, rSrc :: reg, rC :: Word16 }+                         | SubRC { ann :: a, rDest, rSrc :: reg, rC :: Word16 }+                         | Lsl { ann :: a, rDest, rSrc :: reg, sC :: Word8 }+                         | Asr { ann :: a, rDest, rSrc :: reg, sC :: Word8 }+                         | CmpRC { ann :: a, rSrc :: reg, cSrc :: Word16 }+                         | CmpRR { ann :: a, rSrc1, rSrc2 :: reg }+                         | Neg { ann :: a, rDest, rSrc :: reg }+                         | Fmul { ann :: a, dDest, dSrc1, dSrc2 :: freg }+                         | Fadd { ann :: a, dDest, dSrc1, dSrc2 :: freg }+                         | Fsub { ann :: a, dDest, dSrc1, dSrc2 :: freg }+                         | Fdiv { ann :: a, dDest, dSrc1, dSrc2 :: freg }+                         | FcmpZ { ann :: a, dSrc :: freg }+                         | Fcmp { ann :: a, dSrc1, dSrc2 :: freg }+                         | Fneg { ann :: a, dDest, dSrc :: freg }+                         | Scvtf { ann :: a, dDest :: freg, rSrc :: reg }+                         | Fcvtms { ann :: a, rDest :: reg, dSrc :: freg }+                         | Fcvtas { ann :: a, rDest :: reg, dSrc :: freg }+                         | Stp { ann :: a, rSrc1, rSrc2 :: reg, aDest :: Addr reg }+                         | Ldp { ann :: a, rDest1, rDest2 :: reg, aSrc :: Addr reg }+                         | Stp2 { ann :: a, r2Src1, r2Src2 :: f2, aDest :: Addr reg }+                         | Ldp2 { ann :: a, r2Dest1, r2Dest2 :: f2, aRc :: Addr reg }+                         | StpD { ann :: a, dSrc1, dSrc2 :: freg, aDest :: Addr reg }+                         | LdpD { ann :: a, dDest1, dDest2 :: freg, aSrc :: Addr reg }+                         | Fmadd { ann :: a, dDest, dSrc1, dSrc2, dSrc3 :: freg }+                         | Fmsub { ann :: a, dDest, dSrc1, dSrc2, dSrc3 :: freg }+                         | Fsqrt { ann :: a, dDest, dSrc :: freg }+                         | Frintm { ann :: a, dDest, dSrc :: freg }+                         | MrsR { ann :: a, rDest :: reg }+                         | Fmax { ann :: a, dDest, dSrc1, dSrc2 :: freg }+                         | Fmin { ann :: a, dDest, dSrc1, dSrc2 :: freg }+                         | Fabs { ann :: a, dDest, dSrc :: freg }+                         | Csel { ann :: a, rDest, rSrc1, rSrc2 :: reg, cond :: Cond }+                         | Tbnz { ann :: a, rSrc :: reg, bit :: Word8, label :: Label }+                         | Tbz { ann :: a, rSrc :: reg, bit :: Word8, label :: Label }+                         | Cbnz { ann :: a, rSrc :: reg, label :: Label }+                         | Cbz { ann :: a, rSrc :: reg, label :: Label }+                         | Fcsel { ann :: a, dDest, dSrc1, dSrc2 :: freg, cond :: Cond }+                         | Cset { ann :: a, rDest :: reg, cond :: Cond }+                         | TstI { ann :: a, rSrc1 :: reg, imm :: BM }+                         | EorI { ann :: a, rSrc, rDesg :: reg, imm :: BM }+                         deriving (Functor, Generic) -instance (NFData r, NFData d, NFData a) => NFData (AArch64 r d a) where+instance (NFData r, NFData d, NFData x, NFData a) => NFData (AArch64 r d x a) where -instance Copointed (AArch64 reg freg) where copoint = ann+instance Copointed (AArch64 reg freg f2) where copoint = ann -mapR :: (areg -> reg) -> AArch64 areg afreg a -> AArch64 reg afreg a+mapR :: (areg -> reg) -> AArch64 areg afreg af2 a -> AArch64 reg afreg af2 a mapR _ (Label x l)           = Label x l mapR _ (B x l)               = B x l mapR _ (Bc x c l)            = Bc x c l@@ -289,12 +319,91 @@ mapR f (Tbnz l r n p)        = Tbnz l (f r) n p mapR f (Tbz l r n p)         = Tbz l (f r) n p mapR f (Cbnz x r l)          = Cbnz x (f r) l+mapR f (Cbz x r l)           = Cbz x (f r) l mapR _ (Fcsel l d0 d1 d2 p)  = Fcsel l d0 d1 d2 p mapR f (TstI l r i)          = TstI l (f r) i mapR f (Cset l r c)          = Cset l (f r) c mapR f (EorI l r0 r1 i)      = EorI l (f r0) (f r1) i+mapR f (Ldp2 l r0 r1 a)      = Ldp2 l r0 r1 (f<$>a)+mapR f (Stp2 l r0 r1 a)      = Stp2 l r0 r1 (f<$>a) -mapFR :: (afreg -> freg) -> AArch64 areg afreg a -> AArch64 areg freg a+mapF2 :: (af2 -> f2) -> AArch64 areg afreg af2 a -> AArch64 areg afreg f2 a+mapF2 _ (Label x l)           = Label x l+mapF2 _ (B x l)               = B x l+mapF2 _ (Bc x c l)            = Bc x c l+mapF2 _ (Bl x f)              = Bl x f+mapF2 _ (C x l)               = C x l+mapF2 _ (FMovXX l xr0 xr1)    = FMovXX l xr0 xr1+mapF2 _ (MovRR l r0 r1)       = MovRR l r0 r1+mapF2 _ (MovRC l r0 c)        = MovRC l r0 c+mapF2 _ (Ldr l r a)           = Ldr l r a+mapF2 _ (LdrB l r a)          = LdrB l r a+mapF2 _ (Str l r a)           = Str l r a+mapF2 _ (StrB l r a)          = StrB l r a+mapF2 _ (LdrD l xr a)         = LdrD l xr a+mapF2 _ (AddRR l r0 r1 r2)    = AddRR l r0 r1 r2+mapF2 _ (AddRRS l r0 r1 r2 s) = AddRRS l r0 r1 r2 s+mapF2 _ (AddRC l r0 r1 c)     = AddRC l r0 r1 c+mapF2 _ (SubRR l r0 r1 r2)    = SubRR l r0 r1 r2+mapF2 _ (SubRC l r0 r1 c)     = SubRC l r0 r1 c+mapF2 _ (ZeroR l r)           = ZeroR l r+mapF2 _ (Mvn l r0 r1)         = Mvn l r0 r1+mapF2 _ (AndRR l r0 r1 r2)    = AndRR l r0 r1 r2+mapF2 _ (OrRR l r0 r1 r2)     = OrRR l r0 r1 r2+mapF2 _ (Eor l r0 r1 r2)      = Eor l r0 r1 r2+mapF2 _ (EorI l r0 r1 i)      = EorI l r0 r1 i+mapF2 _ (Lsl l r0 r1 s)       = Lsl l r0 r1 s+mapF2 _ (Asr l r0 r1 s)       = Asr l r0 r1 s+mapF2 _ (CmpRC l r c)         = CmpRC l r c+mapF2 _ (CmpRR l r0 r1)       = CmpRR l r0 r1+mapF2 _ (Neg l r0 r1)         = Neg l r0 r1+mapF2 _ (Fmul l xr0 xr1 xr2)  = Fmul l xr0 xr1 xr2+mapF2 _ (Fadd l xr0 xr1 xr2)  = Fadd l xr0 xr1 xr2+mapF2 _ (Fsub l xr0 xr1 xr2)  = Fsub l xr0 xr1 xr2+mapF2 _ (FcmpZ l xr)          = FcmpZ l xr+mapF2 _ (Ret l)               = Ret l+mapF2 _ (RetL x l)            = RetL x l+mapF2 _ (Fdiv l d0 d1 d2)     = Fdiv l d0 d1 d2+mapF2 _ (MulRR l r0 r1 r2)    = MulRR l r0 r1 r2+mapF2 _ (Madd l r0 r1 r2 r3)  = Madd l r0 r1 r2 r3+mapF2 _ (Msub l r0 r1 r2 r3)  = Msub l r0 r1 r2 r3+mapF2 _ (Sdiv l r0 r1 r2)     = Sdiv l r0 r1 r2+mapF2 _ (StrD l d a)          = StrD l d a+mapF2 _ (Scvtf l d r)         = Scvtf l d r+mapF2 _ (Fcvtms l r d)        = Fcvtms l r d+mapF2 _ (Fcvtas l r d)        = Fcvtas l r d+mapF2 _ (MovK l r u s)        = MovK l r u s+mapF2 _ (MovZ l r u s)        = MovZ l r u s+mapF2 _ (FMovDR l d r)        = FMovDR l d r+mapF2 _ (Fcmp l d0 d1)        = Fcmp l d0 d1+mapF2 _ (Stp l r0 r1 a)       = Stp l r0 r1 a+mapF2 _ (Ldp l r0 r1 a)       = Ldp l r0 r1 a+mapF2 _ (StpD l d0 d1 a)      = StpD l d0 d1 a+mapF2 _ (LdpD l d0 d1 a)      = LdpD l d0 d1 a+mapF2 _ (Fmadd l d0 d1 d2 d3) = Fmadd l d0 d1 d2 d3+mapF2 _ (Fmsub l d0 d1 d2 d3) = Fmsub l d0 d1 d2 d3+mapF2 _ (Fsqrt l d0 d1)       = Fsqrt l d0 d1+mapF2 _ (Fneg l d0 d1)        = Fneg l d0 d1+mapF2 _ (Frintm l d0 d1)      = Frintm l d0 d1+mapF2 _ (MrsR l r)            = MrsR l r+mapF2 _ (Blr l r)             = Blr l r+mapF2 _ (MovRCf l r cf)       = MovRCf l r cf+mapF2 _ (LdrRL x r l)         = LdrRL x r l+mapF2 _ (Fmax l d0 d1 d2)     = Fmax l d0 d1 d2+mapF2 _ (Fmin l d0 d1 d2)     = Fmin l d0 d1 d2+mapF2 _ (Fabs l d0 d1)        = Fabs l d0 d1+mapF2 _ (Csel l r0 r1 r2 p)   = Csel l r0 r1 r2 p+mapF2 _ (Tbnz l r n p)        = Tbnz l r n p+mapF2 _ (Tbz l r n p)         = Tbz l r n p+mapF2 _ (Cbnz x r l)          = Cbnz x r l+mapF2 _ (Cbz x r l)           = Cbz x r l+mapF2 _ (Fcsel l d0 d1 d2 p)  = Fcsel l d0 d1 d2 p+mapF2 _ (TstI l r i)          = TstI l r i+mapF2 _ (Cset l r c)          = Cset l r c+mapF2 f (Ldp2 l r0 r1 a)      = Ldp2 l (f r0) (f r1) a+mapF2 f (Stp2 l r0 r1 a)      = Stp2 l (f r0) (f r1) a++mapFR :: (afreg -> freg) -> AArch64 areg afreg af2 a -> AArch64 areg freg af2 a mapFR _ (Label x l)           = Label x l mapFR _ (B x l)               = B x l mapFR _ (Bc x c l)            = Bc x c l@@ -363,27 +472,40 @@ mapFR _ (Tbnz l r n p)        = Tbnz l r n p mapFR _ (Tbz l r n p)         = Tbz l r n p mapFR _ (Cbnz x r l)          = Cbnz x r l+mapFR _ (Cbz x r l)           = Cbz x r l mapFR f (Fcsel l d0 d1 d2 p)  = Fcsel l (f d0) (f d1) (f d2) p mapFR _ (TstI l r i)          = TstI l r i mapFR _ (Cset l r c)          = Cset l r c+mapFR _ (Ldp2 l q0 q1 a)      = Ldp2 l q0 q1 a+mapFR _ (Stp2 l q0 q1 a)      = Stp2 l q0 q1 a  s2 :: [a] -> [(a, Maybe a)] s2 (r0:r1:rs) = (r0, Just r1):s2 rs s2 [r]        = [(r, Nothing)] s2 []         = [] -pus, pos :: [AReg] -> [AArch64 AReg freg ()]-pus = concatMap go.s2 where go (r0, Just r1) = [SubRC () SP SP 16, Stp () r0 r1 (R SP)]; go (r, Nothing) = [SubRC () SP SP 16, Str () r (R SP)]-pos = concatMap go.reverse.s2 where go (r0, Just r1) = [Ldp () r0 r1 (R SP), AddRC () SP SP 16]; go (r, Nothing) = [Ldr () r (R SP), AddRC () SP SP 16]+offs :: [a] -> [Word16]+offs rs = scanl' (\i _ -> i+16) 0 rs -puds, pods :: [freg] -> [AArch64 AReg freg ()]-puds = concatMap go.s2 where go (r0, Just r1) = [SubRC () SP SP 16, StpD () r0 r1 (R SP)]; go (r, Nothing) = [SubRC () SP SP 16, StrD () r (R SP)]-pods = concatMap go.reverse.s2 where go (r0, Just r1) = [LdpD () r0 r1 (R SP), AddRC () SP SP 16]; go (r, Nothing) = [LdrD () r (R SP), AddRC () SP SP 16]+rsOffs :: [a] -> ([(a, Maybe a)], [Word16], Word16)+rsOffs rs = let ixs=offs rs in (s2 rs, ixs, last ixs) +pus, pos :: [AReg] -> [AArch64 AReg freg f2reg ()]+pus rs = let (pps, ixs, r) = rsOffs rs in SubRC () SP SP r:concat (zipWith go pps ixs)+  where go (r0, Just r1) ix = [Stp () r0 r1 (RP SP ix)]; go (r, Nothing) ix = [Str () r (RP SP ix)]+pos rs = let (pps, ixs, r) = rsOffs rs in concat (zipWith go pps ixs)++[AddRC () SP SP r]+  where go (r0, Just r1) ix = [Ldp () r0 r1 (RP SP ix)]; go (r, Nothing) ix = [Ldr () r (RP SP ix)]++puds, pods :: [freg] -> [AArch64 AReg freg f2reg ()]+puds rs = let (pps, ixs, r) = rsOffs rs in SubRC () SP SP r:concat (zipWith go pps ixs)+  where go (r0, Just r1) ix = [StpD () r0 r1 (RP SP ix)]; go (r, Nothing) ix = [StrD () r (RP SP ix)]+pods rs = let (pps, ixs, r) = rsOffs rs in concat (zipWith go pps ixs)++[AddRC () SP SP r]+  where go (r0, Just r1) ix = [LdpD () r0 r1 (RP SP ix)]; go (r, Nothing) ix = [LdrD () r (RP SP ix)]+ hexd :: Integral a => a -> Doc ann hexd = pretty.($"").(("#0x"++).).showHex -instance (Pretty reg, Pretty freg) => Pretty (AArch64 reg freg a) where+instance (Pretty reg, Pretty freg, SIMD f2reg) => Pretty (AArch64 reg freg f2reg a) where     pretty (Label _ l)            = prettyLabel l <> ":"     pretty (B _ l)                = i4 ("b" <+> prettyLabel l)     pretty (Blr _ r)              = i4 ("blr" <+> pretty r)@@ -433,6 +555,8 @@     pretty (Fcmp _ d0 d1)         = i4 ("fcmp" <+> pretty d0 <> "," <+> pretty d1)     pretty (Stp _ r0 r1 a)        = i4 ("stp" <+> pretty r0 <> "," <+> pretty r1 <> "," <+> pretty a)     pretty (Ldp _ r0 r1 a)        = i4 ("ldp" <+> pretty r0 <> "," <+> pretty r1 <> "," <+> pretty a)+    pretty (Ldp2 _ q0 q1 a)       = i4 ("ldp" <+> pq q0 <> "," <+> pq q1 <> "," <+> pretty a)+    pretty (Stp2 _ q0 q1 a)       = i4 ("stp" <+> pq q0 <> "," <+> pq q1 <> "," <+> pretty a)     pretty (StpD _ d0 d1 a)       = i4 ("stp" <+> pretty d0 <> "," <+> pretty d1 <> "," <+> pretty a)     pretty (LdpD _ d0 d1 a)       = i4 ("ldp" <+> pretty d0 <> "," <+> pretty d1 <> "," <+> pretty a)     pretty (Fmadd _ d0 d1 d2 d3)  = i4 ("fmadd" <+> pretty d0 <> "," <+> pretty d1 <> "," <+> pretty d2 <> "," <+> pretty d3)@@ -452,14 +576,15 @@     pretty (Tbnz _ r n l)         = i4 ("tbnz" <+> pretty r <> "," <+> "#" <> pretty n <> "," <+> prettyLabel l)     pretty (Tbz _ r n l)          = i4 ("tbz" <+> pretty r <> "," <+> "#" <> pretty n <> "," <+> prettyLabel l)     pretty (Cbnz _ r l)           = i4 ("cbnz" <+> pretty r <> "," <+> prettyLabel l)+    pretty (Cbz _ r l)            = i4 ("cbz" <+> pretty r <> "," <+> prettyLabel l)     pretty (Fcsel _ d0 d1 d2 p)   = i4 ("fcsel" <+> pretty d0 <> "," <+> pretty d1 <> "," <+> pretty d2 <> "," <+> pretty p)     pretty (TstI _ r i)           = i4 ("tst" <+> pretty r <> "," <+> pretty i)     pretty (Cset _ r c)           = i4 ("cset" <+> pretty r <> "," <+> pretty c) -instance (Pretty reg, Pretty freg) => Show (AArch64 reg freg a) where show=show.pretty+instance (Pretty reg, Pretty freg, SIMD f2reg) => Show (AArch64 reg freg f2reg a) where show=show.pretty -prettyLive :: (Pretty reg, Pretty freg, Pretty o) => AArch64 reg freg o -> Doc ann+prettyLive :: (Pretty reg, Pretty freg, SIMD f2reg, Pretty o) => AArch64 reg freg f2reg o -> Doc ann prettyLive r = pretty r <+> pretty (ann r) -prettyDebug :: (Pretty freg, Pretty reg, Pretty o) => [AArch64 reg freg o] -> Doc ann+prettyDebug :: (Pretty freg, Pretty reg, SIMD f2reg, Pretty o) => [AArch64 reg freg f2reg o] -> Doc ann prettyDebug = prettyLines . fmap prettyLive

@@ -4,7 +4,7 @@ import           Asm.BB import           Data.List.Split (keepDelimsL, keepDelimsR, split, whenElt) -bb :: [AArch64 reg freg a] -> [BB AArch64 reg freg a ()]+bb :: [AArch64 reg freg f2reg a] -> [BB AArch64 reg freg f2reg a ()] bb = filter (not.emptyBB).fmap mkBB.concatMap (split (keepDelimsL$whenElt isL)).split (keepDelimsR$whenElt cf)     where cf B{}=True; cf Bc{}=True; cf Cbnz{}=True; cf Tbnz{}=True; cf Tbz{}=True; cf C{}=True; cf RetL{}=True; cf _=False           isL Label{}=True; isL _=False

@@ -21,20 +21,20 @@ import           Hs.FFI import           Sys.DL -hasMa :: [AArch64 reg freg a] -> Bool+hasMa :: [AArch64 reg freg f2reg a] -> Bool hasMa = any g where g (MovRCf _ _ Malloc)=True; g (MovRCf _ _ Free)=True; g (MovRCf _ _ DR)=True; g _=False -hasMath :: [AArch64 reg freg a] -> Bool+hasMath :: [AArch64 reg freg f2reg a] -> Bool hasMath = any g where g (MovRCf _ _ Exp)=True; g (MovRCf _ _ Log)=True; g (MovRCf _ _ Pow)=True; g _=False -prepAddrs :: [AArch64 reg freg a] -> IO (Maybe CCtx, Maybe MCtx)+prepAddrs :: [AArch64 reg freg f2reg a] -> IO (Maybe CCtx, Maybe MCtx) prepAddrs ss = case (hasMa ss, hasMath ss) of     (True, False)  -> do {m <- mem'; pure (Just m, Nothing)}     (False, False) -> pure (Nothing, Nothing)     (False, True)  -> do {m <- math'; pure (Nothing, Just m)}     (True, True)   -> do {c <- mem'; m <- math'; pure (Just c, Just m)} -assembleCtx :: (CCtx, MCtx) -> (IM.IntMap [Word64], [AArch64 AReg FAReg ()]) -> IO (BS.ByteString, FunPtr b, Maybe (Ptr Word64))+assembleCtx :: (CCtx, MCtx) -> (IM.IntMap [Word64], [AArch64 AReg FAReg F2Reg ()]) -> IO (BS.ByteString, FunPtr b, Maybe (Ptr Word64)) assembleCtx ctx (ds, isns) = do     let (sz, lbls) = mkIx 0 isns     p <- if hasMa isns then allocNear (fst4 (fst ctx)) (fromIntegral sz) else allocExec (fromIntegral sz)@@ -46,7 +46,7 @@ dbgFp asmϵ = do     (bss,_,ps) <- allFp asmϵ     mFree ps $> bss-allFp :: (IM.IntMap [Word64], [AArch64 AReg FAReg ()]) -> IO ([BS.ByteString], FunPtr b, Maybe (Ptr Word64))+allFp :: (IM.IntMap [Word64], [AArch64 AReg FAReg F2Reg ()]) -> IO ([BS.ByteString], FunPtr b, Maybe (Ptr Word64)) allFp (ds, instrs) = do     let (sz, lbls) = mkIx 0 instrs     (fn, p) <- do@@ -58,7 +58,7 @@     let is = asm 0 (ps, fn, lbls) instrs; b = BS.pack.concatMap reverse$is; bsϵ = BS.pack.reverse<$>is     (bsϵ,,snd<$>IM.lookupMin ps)<$>finish b p -mkIx :: Int -> [AArch64 AReg FAReg a] -> (Int, M.Map Label Int)+mkIx :: Int -> [AArch64 AReg FAReg F2Reg a] -> (Int, M.Map Label Int) mkIx ix (Label _ l:asms) = second (M.insert l ix) $ mkIx ix asms mkIx ix (C{}:asms)       = mkIx (ix+20) asms mkIx ix (MovRCf{}:asms)  = mkIx (ix+16) asms@@ -84,7 +84,7 @@  lb r rD = (0x7 .&. be r) `shiftL` 5 .|. be rD -asm :: Int -> (IM.IntMap (Ptr Word64), (Maybe CCtx, Maybe MCtx), M.Map Label Int) -> [AArch64 AReg FAReg ()] -> [[Word8]]+asm :: Int -> (IM.IntMap (Ptr Word64), (Maybe CCtx, Maybe MCtx), M.Map Label Int) -> [AArch64 AReg FAReg F2Reg ()] -> [[Word8]] asm _ _ [] = [] asm ix st (MovZ _ r i s:asms) = [0b11010010, 0b1 `shiftL` 7 .|. fromIntegral (s `quot` 16) `shiftL` 5 .|. fromIntegral (i `shiftR` 11), fromIntegral (0xff .&. (i `shiftR` 3)), fromIntegral (0x7 .&. i) `shiftL` 5 .|. be r]:asm (ix+4) st asms asm ix st (MovRC _ r i:asms) = asm ix st (MovZ () r i 0:asms)@@ -149,14 +149,21 @@ asm ix st (StrB _ r (RP rb u):asms) | u <= 4095 = [0b00111001, fromIntegral (u `shiftR` 6), fromIntegral (0b111111 .&. u) `shiftL` 2 .|. be rb `shiftR` 3, lb rb r]:asm (ix+4) st asms asm ix st (StrB _ r (BI rb ri s):asms) = [0b00111000, 0x1 `shiftL` 5 .|. be ri, 0x3 `shiftL` 5 .|. bs s `shiftL` 4 .|. 0x2 `shiftL` 2 .|. be rb `shiftR` 3, lb rb r]:asm (ix+4) st asms asm ix st (StrD _ d (BI rb ri s):asms) = [0xfc, 0x1 `shiftL` 5 .|. be ri, 0x3 `shiftL` 5 .|. bs s `shiftL` 4 .|. 0x2 `shiftL` 2 .|. be rb `shiftR` 3, lb rb d]:asm (ix+4) st asms-asm ix st (StrD _ d (R rb):asms) = [0b11111101, 0x0, be rb `shiftR` 3, lb rb d]:asm (ix+4) st asms+asm ix st (StrD _ d (RP rb u):asms) | (uϵ, 0) <- u `quotRem` 8, u <= 32760 = [0b11111101, fromIntegral (uϵ `shiftR` 6), fromIntegral (uϵ .&. 0b111111) `shiftL` 2 .|. be rb `shiftR` 3, lb rb d]:asm (ix+4) st asms+asm ix st (StrD x d (R rb):asms) = asm ix st (StrD x d (RP rb 0):asms) asm ix st (Stp x r0 r1 (R rb):asms) = asm ix st (Stp x r0 r1 (RP rb 0):asms) asm ix st (Stp _ r0 r1 (RP rb u):asms) | (u', 0) <- u `quotRem` 8, u <= 504 = [0xa9, fromIntegral (u' `shiftR` 1), fromIntegral (0x1 .&. u') `shiftL` 7 .|. be r1 `shiftL` 2 .|. be rb `shiftR` 3, lb rb r0]:asm (ix+4) st asms-asm ix st (StpD _ d0 d1 (R rb):asms) = [0b01101101, 0, be d1 `shiftL` 2 .|. be rb `shiftR` 3, lb rb d0]:asm (ix+4) st asms+asm ix st (Stp2 _ q0 q1 (RP rb u):asms) | (u', 0) <- u `quotRem` 16, u <= 1008 = [0b10101101, fromIntegral (u' `shiftR` 1), fromIntegral (0x1 .&. u') `shiftL` 7 .|. be q1 `shiftL` 2 .|. be rb `shiftR` 3, lb rb q0]:asm (ix+4) st asms+asm ix st (Stp2 x q0 q1 (R rb):asms) = asm ix st (Stp2 x q0 q1 (RP rb 0):asms)+asm ix st (StpD x d0 d1 (R rb):asms) = asm ix st (StpD x d0 d1 (RP rb 0):asms)+asm ix st (StpD _ d0 d1 (RP rb u):asms) | (uϵ, 0) <- u `quotRem` 8, u <= 504 = [0b01101101, fromIntegral (uϵ `shiftR` 1), fromIntegral (uϵ .&. 0b1) `shiftL` 7 .|. be d1 `shiftL` 2 .|. be rb `shiftR` 3, lb rb d0]:asm (ix+4) st asms asm ix st (LdrD x d (R rb):asms) = asm ix st (LdrD x d (RP rb 0):asms)-asm ix st (LdrD _ d (RP rb u):asms) | (uϵ, 0) <- u `quotRem` 8 = [0b11111101, 0x1 `shiftL` 6 .|. fromIntegral (uϵ `shiftR` 6), fromIntegral (0b111111 .&. uϵ) `shiftL` 2 .|. be rb `shiftR` 3, lb rb d]:asm (ix+4) st asms+asm ix st (LdrD _ d (RP rb u):asms) | (uϵ, 0) <- u `quotRem` 8, u < 32760 = [0b11111101, 0x1 `shiftL` 6 .|. fromIntegral (uϵ `shiftR` 6), fromIntegral (0b111111 .&. uϵ) `shiftL` 2 .|. be rb `shiftR` 3, lb rb d]:asm (ix+4) st asms asm ix st (LdrD _ d (BI rb ri s):asms) = [0b11111100, 0x3 `shiftL` 5 .|. be ri, 0x3 `shiftL` 5 .|. bs s `shiftL` 4 .|. 0x2 `shiftL` 2 .|. be rb `shiftR` 3, lb rb d]:asm (ix+4) st asms-asm ix st (LdpD _ d0 d1 (R rb):asms) = [0x6d, 1 `shiftL` 6, be d1 `shiftL` 2 .|. be rb `shiftR` 3, lb rb d0]:asm (ix+4) st asms+asm ix st (LdpD _ d0 d1 (RP rb u):asms) | (uϵ, 0) <- u `quotRem` 8, uϵ <= 504 = [0x6d, 0x1 `shiftL` 6 .|. fromIntegral (uϵ `shiftR` 1), fromIntegral (uϵ .&. 0b1) `shiftL` 7 .|. be d1 `shiftL` 2 .|. be rb `shiftR` 3, lb rb d0]:asm (ix+4) st asms+asm ix st (LdpD x d0 d1 (R rb):asms) = asm ix st (LdpD x d0 d1 (RP rb 0):asms)+asm ix st (Ldp2 _ q0 q1 (RP rb u):asms) | (uϵ, 0) <- u `quotRem` 16, u <= 1008 = [0b10101101, 0x1 `shiftL` 6 .|. fromIntegral (uϵ `shiftR` 1), fromIntegral (0x1 .&. uϵ) `shiftL` 7 .|. be q1 `shiftL` 2 .|. be rb `shiftR` 3, lb rb q0]:asm (ix+4) st asms+asm ix st (Ldp2 x q0 q1 (R rb):asms) = asm ix st (Ldp2 x q0 q1 (RP rb 0):asms) asm ix st (CmpRR _ r0 r1:asms) = [0b11101011, be r1, be r0 `shiftR` 3, (0x7 .&. be r0) `shiftL` 5 .|. 0b11111]:asm (ix+4) st asms asm ix st (CmpRC _ r u:asms) = [0b11110001, fromIntegral (u `shiftR` 6), (0b111111 .&. fromIntegral u) `shiftL` 2 .|. (be r `shiftR` 3), (0x7 .&. be r) `shiftL` 5 .|. 0b11111]:asm (ix+4) st asms asm ix st (Scvtf _ d r:asms) = [0b10011110, 0b01100010, be r `shiftR` 3, lb r d]:asm (ix+4) st asms@@ -180,16 +187,21 @@         offs=(lIx-ix) `quot` 4         isn=[0b10110101, fromIntegral (offs `lsr` 11), fromIntegral (0xff .&. (offs `lsr` 3)), fromIntegral (0x7 .&. offs) `shiftL` 5 .|. be r]     in isn:asm (ix+4) st asms-asm ix st (Tbz _ r 0 l:asms) =+asm ix st (Cbz _ r l:asms) =     let lIx=get l st         offs=(lIx-ix) `quot` 4-        isn=[0b00110110, fromIntegral (offs `lsr` 11), fromIntegral (0xff .&. (offs `lsr` 3)), fromIntegral (0x7 .&. offs) `shiftL` 5 .|. be r]+        isn=[0b10110100, fromIntegral (offs `lsr` 11), fromIntegral (0xff .&. (offs `lsr` 3)), fromIntegral (0x7 .&. offs) `shiftL` 5 .|. be r]     in isn:asm (ix+4) st asms-asm ix st (Tbnz _ r 0 l:asms) =+asm ix st (Tbz _ r b l:asms) | b <= 31 =     let lIx=get l st         offs=(lIx-ix) `quot` 4-        isn=[0b00110111, fromIntegral (offs `lsr` 11), fromIntegral (0xff .&. (offs `lsr` 3)), fromIntegral (0x7 .&. offs) `shiftL` 5 .|. be r]+        isn=[0b00110110, b `shiftL` 3 .|. fromIntegral (offs `lsr` 11), fromIntegral (0xff .&. (offs `lsr` 3)), fromIntegral (0x7 .&. offs) `shiftL` 5 .|. be r]     in isn:asm (ix+4) st asms+asm ix st (Tbnz _ r b l:asms) | b <= 31 =+    let lIx=get l st+        offs=(lIx-ix) `quot` 4+        isn=[0b00110111, b `shiftL` 3 .|. fromIntegral (offs `lsr` 11), fromIntegral (0xff .&. (offs `lsr` 3)), fromIntegral (0x7 .&. offs) `shiftL` 5 .|. be r]+    in isn:asm (ix+4) st asms asm ix st (C _ l:asms) =     let lIx=get l st         offs=(lIx-(ix+8)) `quot` 4@@ -222,7 +234,7 @@     in asm ix st (MovRC () r (fromIntegral w0):MovK () r (fromIntegral w1) 16:MovK () r (fromIntegral w2) 32:MovK () r (fromIntegral w3) 48:asms) asm _ _ (isn:_) = error (show isn) -m4 :: AReg -> Int -> [AArch64 AReg FAReg ()]+m4 :: AReg -> Int -> [AArch64 AReg FAReg F2Reg ()] m4 r a = let w0=a .&. 0xffff; w1=(a .&. 0xffff0000) `lsr` 16; w2=(a .&. 0xFFFF00000000) `lsr` 32; w3=(a .&. 0xFFFF000000000000) `lsr` 48          in [MovRC () r (fromIntegral w0), MovK () r (fromIntegral w1) 16, MovK () r (fromIntegral w2) 32, MovK () r (fromIntegral w3) 48] 

@@ -12,10 +12,10 @@ import           Data.Functor (void, ($>)) import qualified Data.IntSet  as IS -mkControlFlow :: (E reg, E freg) => [BB AArch64 reg freg () ()] -> [BB AArch64 reg freg () ControlAnn]+mkControlFlow :: (E reg, E freg, E f2reg) => [BB AArch64 reg freg f2reg () ()] -> [BB AArch64 reg freg f2reg () ControlAnn] mkControlFlow instrs = runFreshM (broadcasts instrs *> addControlFlow instrs) -expand :: (E reg, E freg) => BB AArch64 reg freg () Liveness -> [AArch64 reg freg Liveness]+expand :: (E reg, E freg, E f2reg) => BB AArch64 reg freg f2reg () Liveness -> [AArch64 reg freg f2reg Liveness] expand (BB asms@(_:_) li) = scanr (\n p -> lN n (ann p)) lS iasms     where lN a s =             let ai=uses a <> (ao IS.\\ defs a)@@ -29,7 +29,7 @@           (iasms, asm) = (init asms, last asms) expand _ = [] -addControlFlow :: (E reg, E freg) => [BB AArch64 reg freg () ()] -> FreshM [BB AArch64 reg freg () ControlAnn]+addControlFlow :: (E reg, E freg, E f2reg) => [BB AArch64 reg freg f2reg () ()] -> FreshM [BB AArch64 reg freg f2reg () ControlAnn] addControlFlow [] = pure [] addControlFlow (BB [] _:bbs) = addControlFlow bbs addControlFlow (BB asms _:bbs) = do@@ -57,15 +57,15 @@ udb asms = UD (uBB asms) (uBBF asms) (dBB asms) (dBBF asms) udd asm = UD (uses asm) (usesF asm) (defs asm) (defsF asm) -uBB, dBB :: E reg => [AArch64 reg freg a] -> IS.IntSet+uBB, dBB :: E reg => [AArch64 reg freg f2reg a] -> IS.IntSet uBB = foldr (\p n -> uses p `IS.union` (n IS.\\ defs p)) IS.empty dBB = foldMap defs -uBBF, dBBF :: E freg => [AArch64 reg freg a] -> IS.IntSet+uBBF, dBBF :: (E freg, E f2reg) => [AArch64 reg freg f2reg a] -> IS.IntSet uBBF = foldr (\p n -> usesF p `IS.union` (n IS.\\ defsF p)) IS.empty dBBF = foldMap defsF -defs, uses :: E reg => AArch64 reg freg a -> IS.IntSet+defs, uses :: E reg => AArch64 reg freg f2reg a -> IS.IntSet uses (MovRR _ _ r)        = singleton r uses MovRC{}              = IS.empty uses FMovXX{}             = IS.empty@@ -110,7 +110,9 @@ uses MovZ{}               = IS.empty uses Fcmp{}               = IS.empty uses (StpD _ _ _ a)       = uA a+uses (Stp2 _ _ _ a)       = uA a uses (LdpD _ _ _ a)       = uA a+uses (Ldp2 _ _ _ a)       = uA a uses Fmadd{}              = IS.empty uses Fmsub{}              = IS.empty uses Fsqrt{}              = IS.empty@@ -132,6 +134,7 @@ uses Bc{}                 = IS.empty uses B{}                  = IS.empty uses (Cbnz _ r _)         = singleton r+uses (Cbz _ r _)          = singleton r uses (Tbnz _ r _ _)       = singleton r uses (Tbz _ r _ _)        = singleton r uses Ret{}                = singleton CArg0@@ -151,6 +154,8 @@ defs LdpD{}              = IS.empty defs Stp{}               = IS.empty defs StpD{}              = IS.empty+defs Stp2{}              = IS.empty+defs Ldp2{}              = IS.empty defs (Ldp _ r0 r1 _)     = fromList [r0, r1] defs (SubRR _ r _ _)     = singleton r defs (AddRR _ r _ _)     = singleton r@@ -205,6 +210,7 @@ defs Bc{}                = IS.empty defs B{}                 = IS.empty defs Cbnz{}              = IS.empty+defs Cbz{}               = IS.empty defs Tbnz{}              = IS.empty defs Tbz{}               = IS.empty defs Ret{}               = IS.empty@@ -213,7 +219,7 @@ defs C{}                 = fromList [LR, FP] defs RetL{}              = IS.empty -defsF, usesF :: E freg => AArch64 reg freg ann -> IS.IntSet+defsF, usesF :: (E freg, E f2reg) => AArch64 reg freg f2reg ann -> IS.IntSet defsF (FMovXX _ r _)     = singleton r defsF MovRR{}            = IS.empty defsF MovRC{}            = IS.empty@@ -222,6 +228,7 @@ defsF Str{}              = IS.empty defsF StrB{}             = IS.empty defsF (LdrD _ r _)       = singleton r+defsF (Ldp2 _ q0 q1 _)   = fromList [q0, q1] defsF AddRR{}            = IS.empty defsF AddRRS{}           = IS.empty defsF SubRR{}            = IS.empty@@ -259,6 +266,7 @@ defsF Ldp{}              = IS.empty defsF Stp{}              = IS.empty defsF StpD{}             = IS.empty+defsF Stp2{}             = IS.empty defsF (Fmadd _ d0 _ _ _) = singleton d0 defsF (Fmsub _ d0 _ _ _) = singleton d0 defsF (Fsqrt _ d _)      = singleton d@@ -281,6 +289,7 @@ defsF Bc{}               = IS.empty defsF B{}                = IS.empty defsF Cbnz{}             = IS.empty+defsF Cbz{}              = IS.empty defsF Tbnz{}             = IS.empty defsF Tbz{}              = IS.empty defsF Ret{}              = IS.empty@@ -331,6 +340,8 @@ usesF FMovDR{}             = IS.empty usesF (Fcmp _ r0 r1)       = fromList [r0, r1] usesF (StpD _ r0 r1 _)     = fromList [r0, r1]+usesF (Stp2 _ q0 q1 _)     = fromList [q0, q1]+usesF Ldp2{}               = IS.empty usesF Stp{}                = IS.empty usesF Ldp{}                = IS.empty usesF LdpD{}               = IS.empty@@ -356,6 +367,7 @@ usesF Bc{}                 = IS.empty usesF B{}                  = IS.empty usesF Cbnz{}               = IS.empty+usesF Cbz{}                = IS.empty usesF Tbnz{}               = IS.empty usesF Tbz{}                = IS.empty usesF Ret{}                = fromList [FArg0, FArg1]@@ -364,14 +376,14 @@ usesF C{}                  = IS.empty usesF RetL{}               = IS.empty -next :: (E reg, E freg) => [BB AArch64 reg freg () ()] -> FreshM ([N] -> [N], [BB AArch64 reg freg () ControlAnn])+next :: (E reg, E freg, E f2reg) => [BB AArch64 reg freg f2reg () ()] -> FreshM ([N] -> [N], [BB AArch64 reg freg f2reg () ControlAnn]) next bbs = do     nextBs <- addControlFlow bbs     case nextBs of         []    -> pure (id, [])         (b:_) -> pure ((node (caBB b) :), nextBs) -broadcasts :: [BB AArch64 reg freg a ()] -> FreshM ()+broadcasts :: [BB AArch64 reg freg f2reg a ()] -> FreshM () broadcasts [] = pure () broadcasts ((BB asms@(asm:_) _):bbs@((BB (Label _ retL:_) _):_)) | C _ l <- last asms = do     { i <- fm retL; b3 i l

@@ -8,7 +8,7 @@ import qualified Data.IntSet    as IS import           Data.Maybe     (mapMaybe) -frameC :: [AArch64 AReg FAReg Live] -> [AArch64 AReg FAReg ()]+frameC :: [AArch64 AReg FAReg F2Reg Live] -> [AArch64 AReg FAReg F2Reg ()] frameC = concat.go IS.empty IS.empty     where go _ _ [] = []           go _ _ [isn] = [[void isn]]

@@ -2,7 +2,7 @@  import           Asm.Aarch64 -opt :: (Eq reg, Eq freg) => [AArch64 reg freg ()] -> [AArch64 reg freg ()]+opt :: (Eq reg, Eq freg) => [AArch64 reg freg f2reg ()] -> [AArch64 reg freg f2reg ()] opt (Str _ r0 (R ar0):Str _ r1 (RP ar1 8):asms) | ar0 == ar1 = Stp () r0 r1 (R ar0):opt asms opt ((MovRC _ r 0):asms) = opt (ZeroR () r:asms) opt ((ZeroR _ r0):(MovK _ r1 u s):asms) | r0 == r1 = opt (MovZ () r1 u s:asms)

@@ -9,22 +9,22 @@ import qualified Data.Set       as S  gallocFrame :: Int -- ^ int supply for spilling-            -> [AArch64 AbsReg FAbsReg ()] -> [AArch64 AReg FAReg ()]+            -> [AArch64 AbsReg FAbsReg F2Abs ()] -> [AArch64 AReg FAReg F2Reg ()] gallocFrame u = frameC . mkIntervals . galloc u -galloc :: Int -> [AArch64 AbsReg FAbsReg ()] -> [AArch64 AReg FAReg ()]-galloc u isns = frame clob'd (fmap (mapR ((regs IM.!).toInt).mapFR ((fregs IM.!).fToInt)) isns')+galloc :: Int -> [AArch64 AbsReg FAbsReg F2Abs ()] -> [AArch64 AReg FAReg F2Reg ()]+galloc u isns = frame clob'd (fmap (mapR ((regs IM.!).toInt).mapFR ((fregs IM.!).fToInt).mapF2 (simd2.(fregs IM.!).f2ToInt)) isns')     where (regs, fregs, isns') = gallocOn u (isns++[Ret ()])           clob'd = S.fromList $ IM.elems regs  {-# SCC frame #-}-frame :: S.Set AReg -> [AArch64 AReg FAReg ()] -> [AArch64 AReg FAReg ()]+frame :: S.Set AReg -> [AArch64 AReg FAReg F2Reg ()] -> [AArch64 AReg FAReg F2Reg ()] frame clob asms = pre++asms++post++[Ret ()] where     pre=pus clobs; post=pos clobs     -- https://developer.arm.com/documentation/102374/0101/Procedure-Call-Standard     clobs = S.toList (clob `S.intersection` S.fromList [X18 .. X28]) -gallocOn :: Int -> [AArch64 AbsReg FAbsReg ()] -> (IM.IntMap AReg, IM.IntMap FAReg, [AArch64 AbsReg FAbsReg ()])+gallocOn :: Int -> [AArch64 AbsReg FAbsReg F2Abs ()] -> (IM.IntMap AReg, IM.IntMap FAReg, [AArch64 AbsReg FAbsReg F2Abs ()]) gallocOn u = go u 0 pres     where go uϵ offs pres' isns = rmaps               where rmaps = case (regsM, fregsM) of

@@ -61,27 +61,32 @@ nextR :: WM AbsReg nextR = IReg <$> nextI +nextV :: WM F2Abs+nextV = F2Reg <$> nextI+ nextF :: WM FAbsReg nextF = FReg <$> nextI -irToAarch64 :: IR.WSt -> [IR.Stmt] -> (Int, [AArch64 AbsReg FAbsReg ()])+irToAarch64 :: IR.WSt -> [IR.Stmt] -> (Int, [AArch64 AbsReg FAbsReg F2Abs ()]) irToAarch64 st = swap . second IR.wtemps . flip runState st . foldMapA ir  -- only needs to be "quadword aligned" when it is the base register for load/store instructions-aR :: AbsReg -> WM [AArch64 AbsReg FAbsReg ()]+aR :: AbsReg -> WM [AArch64 AbsReg FAbsReg F2Abs ()] aR t = do     l <- nextL+    -- FIXME: bool-tuples are size 9 &c.+    -- (this would crash on stack-allocated arrays of bools...)     pure [TstI () t (BM 1 3), Bc () Eq l, AddRC () t t 8, Label () l] -plF :: IR.FExp -> WM ([AArch64 AbsReg FAbsReg ()] -> [AArch64 AbsReg FAbsReg ()], FAbsReg)+plF :: IR.FExp -> WM ([AArch64 AbsReg FAbsReg F2Abs ()] -> [AArch64 AbsReg FAbsReg F2Abs ()], FAbsReg) plF (IR.FReg t) = pure (id, fabsReg t) plF e           = do {i <- nextI; pl <- feval e (IR.FTemp i); pure ((pl++), FReg i)} -plI :: IR.Exp -> WM ([AArch64 AbsReg FAbsReg ()] -> [AArch64 AbsReg FAbsReg ()], AbsReg)+plI :: IR.Exp -> WM ([AArch64 AbsReg FAbsReg F2Abs ()] -> [AArch64 AbsReg FAbsReg F2Abs ()], AbsReg) plI (IR.Reg t) = pure (id, absReg t) plI e          = do {i <- nextI; pl <- eval e (IR.ITemp i); pure ((pl++), IReg i)} -ir :: IR.Stmt -> WM [AArch64 AbsReg FAbsReg ()]+ir :: IR.Stmt -> WM [AArch64 AbsReg FAbsReg F2Abs ()] ir (IR.R l)      = pure [RetL () l] ir (IR.L l)      = pure [Label () l] ir (IR.J l)      = pure [B () l]@@ -111,34 +116,39 @@     (plE,r) <- plI e     pure $ plE [Str () r (RP (absReg t) p)] ir (IR.Wr (IR.AP t (Just (IR.IB Op.IAsl eI (IR.ConstI 3))) _) e) = do-    r <- nextI; rI <- nextI-    plE <- eval e (IR.ITemp r); plEI <- eval eI (IR.ITemp rI)-    pure $ plE ++ plEI ++ [Str () (IReg r) (BI (absReg t) (IReg rI) Three)]+    (plE,r) <- plI e; (plEI,rI) <- plI eI+    pure $ plE $ plEI [Str () r (BI (absReg t) rI Three)] ir (IR.Wr (IR.AP t (Just (IR.IB Op.IPlus (IR.IB Op.IAsl eI (IR.ConstI 3)) (IR.ConstI i))) _) e) | (ix, 0) <- i `quotRem` 8 = do-    r <- nextI; rI <- nextI-    plE <- eval e (IR.ITemp r); plEI <- eval (eI+IR.ConstI ix) (IR.ITemp rI)-    pure $ plE ++ plEI ++ [Str () (IReg r) (BI (absReg t) (IReg rI) Three)]+    rI <- nextI+    plEI <- eval (eI+IR.ConstI ix) (IR.ITemp rI)+    (plE,r) <- plI e+    pure $ plE $ plEI ++ [Str () r (BI (absReg t) (IReg rI) Three)] ir (IR.Wr (IR.AP t (Just eI) _) e) = do-    r <- nextI; rI <- nextI-    plE <- eval e (IR.ITemp r); plEI <- eval eI (IR.ITemp rI)-    pure $ plE ++ plEI ++ [Str () (IReg r) (BI (absReg t) (IReg rI) Zero)]+    (plE,r) <- plI e; (plEI,rI) <- plI eI+    pure $ plE $ plEI [Str () r (BI (absReg t) rI Zero)]+ir (IR.WrB (IR.AP t (Just (IR.ConstI i)) _) (IR.ConstI n)) | Just iu <- mu16 i, Just u <- mu16 n = do+    r <- nextR+    pure [MovRC () r u, StrB () r (RP (absReg t) iu)]+ir (IR.WrB (IR.AP t (Just eI) _) (IR.ConstI n)) | Just u <- mu16 n = do+    i <- nextR+    (plEI,rI) <- plI eI+    pure $ plEI [MovRC () i u, StrB () i (BI (absReg t) rI Zero)]+ir (IR.WrB (IR.AP t (Just (IR.ConstI ix)) _) (IR.Is i)) | Just iu <- mu16 ix = do+    pure [StrB () (absReg i) (RP (absReg t) iu)] ir (IR.WrB (IR.AP t (Just eI) _) (IR.Is i)) = do-    rI <- nextI-    plEI <- eval eI (IR.ITemp rI)-    pure $ plEI ++ [StrB () (absReg i) (BI (absReg t) (IReg rI) Zero)]+    (plEI,rI) <- plI eI+    pure $ plEI [StrB () (absReg i) (BI (absReg t) rI Zero)] ir (IR.WrF (IR.AP tB (Just (IR.IB Op.IAsl eI (IR.ConstI 3))) _) e) = do-    iI <- nextI-    plEI <- eval eI (IR.ITemp iI)+    (plEI,iI) <- plI eI     (plE,i) <- plF e-    pure $ plE $ plEI ++ [StrD () i (BI (absReg tB) (IReg iI) Three)]+    pure $ plE $ plEI [StrD () i (BI (absReg tB) iI Three)] ir (IR.WrF (IR.AP tB (Just (IR.IB Op.IPlus (IR.IB Op.IAsl eI (IR.ConstI 3)) (IR.ConstI ix8))) _) e) | (ix, 0) <- ix8 `quotRem` 8 = do     iI <- nextI     plEI <- eval (eI+IR.ConstI ix) (IR.ITemp iI)     (plE,i) <- plF e     pure $ plE $ plEI ++ [StrD () i (BI (absReg tB) (IReg iI) Three)] ir (IR.WrF (IR.AP t (Just eI) _) e) = do-    (plEI,iI) <- plI eI-    (plE,i) <- plF e+    (plE,i) <- plF e; (plEI,iI) <- plI eI     pure $ plE $ plEI [StrD () i (BI (absReg t) iI Zero)] ir (IR.WrF (IR.AP t Nothing _) e) = do     (plE,i) <- plF e@@ -163,6 +173,12 @@ ir (IR.MJ (IR.FRel op e0 e1) l) | c <- frel op = do     (plE0,r0) <- plF e0; (plE1,r1) <- plF e1     pure $ plE0 $ plE1 [Fcmp () r0 r1, Bc () c l]+ir (IR.MJ (IR.BU Op.BNeg p) l) = do+    (plE,r) <- plI p+    pure $ plE [Cbz () r l]+ir (IR.MJ p l) = do+    (plE,r) <- plI p+    pure $ plE [Cbnz () r l] ir (IR.Cmov (IR.IRel op e0 e1) t e) | c <- iop op = do     (plE0,r0) <- plI e0; (plE1,r1) <- plI e1     (plE,r) <- plI e@@ -183,8 +199,7 @@     (plE0,r0) <- plI e0     pure $ plE0 [TstI () r0 (BM 1 0), Cset () (absReg t) Eq] ir (IR.Fcmov (IR.IRel op e0 (IR.ConstI i64)) t e) | c <- iop op, Just u <- m12 i64 = do-    (plE0,r0) <- plI e0-    (plE,i) <- plF e+    (plE0,r0) <- plI e0; (plE,i) <- plF e     pure $ plE $ plE0 [CmpRC () r0 u, Fcsel () (fabsReg t) i (fabsReg t) c] ir (IR.Fcmov (IR.IRel op e0 e1) t e) | c <- iop op = do     (plE0,r0) <- plI e0; (plE1,r1) <- plI e1@@ -195,12 +210,10 @@     (plE,i) <- plF e     pure $ plE $ plE0 $ plE1 [Fcmp () r0 r1, Fcsel () (fabsReg t) i (fabsReg t) c] ir (IR.Fcmov (IR.IU Op.IOdd e0) t e) = do-    (plE0,r0) <- plI e0-    (plE,i) <- plF e+    (plE0,r0) <- plI e0; (plE,i) <- plF e     pure $ plE $ plE0 [TstI () r0 (BM 1 0), Fcsel () (fabsReg t) i (fabsReg t) Neq] ir (IR.Fcmov (IR.IU Op.IEven e0) t e) = do-    (plE0,r0) <- plI e0-    (plE,i) <- plF e+    (plE0,r0) <- plI e0; (plE,i) <- plF e     pure $ plE $ plE0 [TstI () r0 (BM 1 0), Fcsel () (fabsReg t) i (fabsReg t) Eq] ir (IR.Cpy (IR.AP tD Nothing _) (IR.AP tS Nothing _) (IR.ConstI n)) | (n', 0) <- n `quotRem` 2, n' <= 4 = do     t0 <- nextR; t1 <- nextR@@ -233,6 +246,42 @@     plES <- eval (IR.Reg tS+eS) (IR.ITemp rS)     let li=fromIntegral$(n-1)*8     pure $ plED ++ plES ++ concat [ [Ldp () t0 t1 (RP (IReg rS) (i*16)), Stp () t0 t1 (RP (IReg rD) (i*16))] | i <- fromIntegral<$>[0..(n'-1)] ] ++ [Ldr () t0 (RP (IReg rS) li), Str () t0 (RP (IReg rD) li)]+ir (IR.Cpy (IR.AP tD (Just (IR.ConstI oD)) _) (IR.AP tS (Just (IR.ConstI oS)) _) eN) | Just uS <- mu16 oS, Just uD <- mu16 oD = do+    rD <- nextI; rS <- nextI; i <- nextR+    t0 <- nextR; t1 <- nextR+    plED <- eval (IR.Reg tD) (IR.ITemp rD)+    plES <- eval (IR.Reg tS) (IR.ITemp rS)+    (plEN, rN) <- plI eN+    let rDA=IReg rD; rSA=IReg rS+    l <- nextL; eL <- nextL+    pure $ plED ++ plES ++ plEN [ZeroR () i, CmpRR () i rN, Bc () Geq eL, Tbz () rN 0 l, Ldr () t0 (RP rSA uS), Str () t0 (RP rDA uD), MovRC () i 1, Bc () Geq eL, AddRC () rSA rSA 8, AddRC () rDA rDA 8, Label () l, Ldp () t0 t1 (RP rSA uS), Stp () t0 t1 (RP rDA uD), AddRC () rSA rSA 16, AddRC () rDA rDA 16, AddRC () i i 2, CmpRR () i rN, Bc () Lt l, Label () eL]+ir (IR.Cpy (IR.AP tD (Just (IR.ConstI oD)) _) (IR.AP tS eS _) eN) | Just uD <- mu16 oD = do+    rD <- nextI; rS <- nextI; i <- nextR+    t0 <- nextR; t1 <- nextR+    plED <- eval (IR.Reg tD) (IR.ITemp rD)+    plES <- eval (maybe id (+) eS$IR.Reg tS) (IR.ITemp rS)+    (plEN, rN) <- plI eN+    let rDA=IReg rD; rSA=IReg rS+    l <- nextL; eL <- nextL+    pure $ plED ++ plES ++ plEN [ZeroR () i, CmpRR () i rN, Bc () Geq eL, Tbz () rN 0 l, Ldr () t0 (R rSA), Str () t0 (RP rDA uD), MovRC () i 1, Bc () Geq eL, AddRC () rSA rSA 8, AddRC () rDA rDA 8, Label () l, Ldp () t0 t1 (R rSA), Stp () t0 t1 (RP rDA uD), AddRC () rSA rSA 16, AddRC () rDA rDA 16, AddRC () i i 2, CmpRR () i rN, Bc () Lt l, Label () eL]+ir (IR.Cpy (IR.AP tD eD _) (IR.AP tS (Just (IR.ConstI oS)) _) eN) | Just uS <- mu16 oS = do+    rD <- nextI; rS <- nextI; i <- nextR+    t0 <- nextR; t1 <- nextR+    plED <- eval (maybe id (+) eD$IR.Reg tD) (IR.ITemp rD)+    plES <- eval (IR.Reg tS) (IR.ITemp rS)+    (plEN, rN) <- plI eN+    let rDA=IReg rD; rSA=IReg rS+    l <- nextL; eL <- nextL+    pure $ plED ++ plES ++ plEN [ZeroR () i, CmpRR () i rN, Bc () Geq eL, Tbz () rN 0 l, Ldr () t0 (RP rSA uS), Str () t0 (R rDA), MovRC () i 1, Bc () Geq eL, AddRC () rSA rSA 8, AddRC () rDA rDA 8, Label () l, Ldp () t0 t1 (RP rSA uS), Stp () t0 t1 (R rDA), AddRC () rSA rSA 16, AddRC () rDA rDA 16, AddRC () i i 2, CmpRR () i rN, Bc () Lt l, Label () eL]+ir (IR.Cpy (IR.AP tD eD _) (IR.AP tS (Just (IR.IB Op.IPlus eS (IR.ConstI oS))) _) eN) | Just uS <- mu16 oS = do+    rD <- nextI; rS <- nextI; i <- nextR+    t0 <- nextR; t1 <- nextR+    plED <- eval (maybe id (+) eD$IR.Reg tD) (IR.ITemp rD)+    plES <- eval (eS+IR.Reg tS) (IR.ITemp rS)+    (plEN, rN) <- plI eN+    let rDA=IReg rD; rSA=IReg rS+    l <- nextL; eL <- nextL+    pure $ plED ++ plES ++ plEN [ZeroR () i, CmpRR () i rN, Bc () Geq eL, Tbz () rN 0 l, Ldr () t0 (RP rSA uS), Str () t0 (R rDA), MovRC () i 1, Bc () Geq eL, AddRC () rSA rSA 8, AddRC () rDA rDA 8, Label () l, Ldp () t0 t1 (RP rSA uS), Stp () t0 t1 (R rDA), AddRC () rSA rSA 16, AddRC () rDA rDA 16, AddRC () i i 2, CmpRR () i rN, Bc () Lt l, Label () eL] ir (IR.Cpy (IR.AP tD eD _) (IR.AP tS eS _) eN) = do     rD <- nextI; rS <- nextI; i <- nextR     t0 <- nextR; t1 <- nextR@@ -241,7 +290,7 @@     (plEN, rN) <- plI eN     let rDA=IReg rD; rSA=IReg rS     l <- nextL; eL <- nextL-    pure $ plED ++ plES ++ plEN [ZeroR () i, CmpRR () i rN, Bc () Geq eL, Tbz () rN 0 l, Ldr () t0 (R rSA), Str () t0 (R rDA), MovRC () i 1, AddRC () rSA rSA 8, AddRC () rDA rDA 8, Label () l, Ldp () t0 t1 (R rSA), Stp () t0 t1 (R rDA), AddRC () rSA rSA 16, AddRC () rDA rDA 16, AddRC () i i 2, CmpRR () i rN, Bc () Lt l, Label () eL]+    pure $ plED ++ plES ++ plEN [ZeroR () i, CmpRR () i rN, Bc () Geq eL, Tbz () rN 0 l, Ldr () t0 (R rSA), Str () t0 (R rDA), MovRC () i 1, Bc () Geq eL, AddRC () rSA rSA 8, AddRC () rDA rDA 8, Label () l, Ldp () t0 t1 (R rSA), Stp () t0 t1 (R rDA), AddRC () rSA rSA 16, AddRC () rDA rDA 16, AddRC () i i 2, CmpRR () i rN, Bc () Lt l, Label () eL] ir (IR.Cpy1 (IR.AP tD (Just (IR.ConstI di)) _) (IR.AP tS (Just (IR.ConstI si)) _) eN) | Just du <- mu16 di, Just su <- mu16 si = do     rD <- nextI; rS <- nextI; i <- nextR; t <- nextR     (plEN, rN) <- plI eN@@ -265,19 +314,18 @@     pure $ puL ++ [AddRC () FP ASP 16, MovRCf () r DR, Blr () r, FMovXX () (fabsReg t) FArg0] ++ poL ir s             = error (show s) -puL, poL :: [AArch64 AbsReg freg ()]+puL, poL :: [AArch64 AbsReg freg f2reg ()] puL = [SubRC () ASP ASP 16, Stp () FP LR (R ASP)] poL = [Ldp () FP LR (R ASP), AddRC () ASP ASP 16] -sai i | i `rem` 16 == 0 = i+16 | otherwise = i+24--- FIXME: only do +16 when necessary+sai i | i `rem` 16 == 0 = i+16 | otherwise = i+16+(16-r) where r = i `rem` 16 -mw64 :: Word64 -> AbsReg -> [AArch64 AbsReg freg ()]+mw64 :: Word64 -> AbsReg -> [AArch64 AbsReg freg f2reg ()] mw64 w r =     let w0=w .&. 0xffff; w1=(w .&. 0xffff0000) `rotateR` 16; w2=(w .&. 0xFFFF00000000) `rotateR` 32; w3=(w .&. 0xFFFF000000000000) `rotateR` 48     in MovRC () r (fromIntegral w0):[MovK () r (fromIntegral wi) s | (wi, s) <- [(w1, 16), (w2, 32), (w3, 48)], wi /= 0 ] -ssin :: IR.FTemp -> WM [AArch64 AbsReg FAbsReg ()]+ssin :: IR.FTemp -> WM [AArch64 AbsReg FAbsReg F2Abs ()] ssin t = do     d1 <- nextF; d2 <- nextF; d3 <- nextF     tsI <- nextI@@ -287,7 +335,7 @@   where     d0 = fabsReg t -cosϵ :: IR.FTemp -> WM [AArch64 AbsReg FAbsReg ()]+cosϵ :: IR.FTemp -> WM [AArch64 AbsReg FAbsReg F2Abs ()] cosϵ t = do     d1 <- nextF; d2 <- nextF; d3 <- nextF     tsI <- nextI@@ -297,7 +345,7 @@   where     d0 = fabsReg t -feval :: IR.FExp -> IR.FTemp -> WM [AArch64 AbsReg FAbsReg ()]+feval :: IR.FExp -> IR.FTemp -> WM [AArch64 AbsReg FAbsReg F2Abs ()] feval (IR.FReg tS) tD = pure [FMovXX () (fabsReg tD) (fabsReg tS)] feval (IR.ConstF d) t = do     i <- nextI@@ -384,10 +432,11 @@     pure $ plE [Fsqrt () (fabsReg t) r] feval e _             = error (show e) -eval :: IR.Exp -> IR.Temp -> WM [AArch64 AbsReg FAbsReg ()]+eval :: IR.Exp -> IR.Temp -> WM [AArch64 AbsReg FAbsReg F2Abs ()] eval (IR.Reg tS) tD = pure [MovRR () (absReg tD) (absReg tS)] eval (IR.ConstI 0) tD = pure [ZeroR () (absReg tD)] eval (IR.ConstI i) tD | Just u <- mu16 i = pure [MovRC () (absReg tD) u]+eval (IR.ConstI i) tD | Just u <- mu16 (-i) = let t=absReg tD in pure [MovRC () t u, Neg () t t] eval (IR.ConstI i) tD = pure $ mw64 (fromIntegral i) (absReg tD) eval (IR.Is p) tD = pure [MovRR () (absReg tD) (absReg p)] eval (IR.IB Op.IPlus (IR.IB Op.IAsl e0 (IR.ConstI i)) e1) t | Just u <- ms i = do@@ -428,11 +477,14 @@ eval (IR.IB op e0 e1) t | Just isn <- mIop op = do     (plE0,r0) <- plI e0; (plE1,r1) <- plI e1     pure $ plE0 $ plE1 [isn () (absReg t) r0 r1]+eval (IR.IRel rel e0 e1) t | c <- iop rel = do+    (plE0,r0) <- plI e0; (plE1,r1) <- plI e1+    pure $ plE0 $ plE1 [CmpRR () r0 r1, Cset () (absReg t) c] eval (IR.IRFloor e) t = do     (plE,r) <- plF e     pure $ plE [Fcvtms () (absReg t) r] eval (IR.EAt (IR.AP tB (Just (IR.ConstI i)) _)) tD | Just p <- mp i = pure [Ldr () (absReg tD) (RP (absReg tB) p)]-eval (IR.BAt (IR.AP tB (Just (IR.ConstI i)) _)) tD | Just p <- mp i = pure [LdrB () (absReg tD) (RP (absReg tB) p)]+eval (IR.BAt (IR.AP tB (Just (IR.ConstI i)) _)) tD | Just u <- mu16 i = pure [LdrB () (absReg tD) (RP (absReg tB) u)] eval (IR.EAt (IR.AP rB (Just (IR.IB Op.IAsl eI (IR.ConstI 3))) _)) t = do     (plE,i) <- plI eI     pure $ plE [Ldr () (absReg t) (BI (absReg rB) i Three)]

@@ -13,18 +13,18 @@ import           CF import           Class.E -class Arch arch reg freg where-    cf :: [BB arch reg freg () ()] -> [BB arch reg freg () ControlAnn]+class Arch arch reg freg f2reg where+    cf :: [BB arch reg freg f2reg () ()] -> [BB arch reg freg f2reg () ControlAnn]      -- | result: src, dest-    mI :: arch reg freg a -> Maybe (reg, reg)-    mf :: arch reg freg a -> Maybe (freg, freg)+    mI :: arch reg freg f2reg a -> Maybe (reg, reg)+    mf :: arch reg freg f2reg a -> Maybe (freg, freg) -    bb :: [arch reg freg a] -> [BB arch reg freg a ()]-    expand :: BB arch reg freg () Liveness -> [arch reg freg Liveness]-    udd :: arch reg freg a -> UD+    bb :: [arch reg freg f2reg a] -> [BB arch reg freg f2reg a ()]+    expand :: BB arch reg freg f2reg () Liveness -> [arch reg freg f2reg Liveness]+    udd :: arch reg freg f2reg a -> UD -instance (E reg, E freg) => Arch X86.X86 reg freg where+instance (E reg, E freg) => Arch X86.X86 reg freg f2reg where     cf = X86.mkControlFlow      mI (X86.MovRR _ r0 r1) = Just (r1, r0)@@ -37,7 +37,7 @@     expand = X86.expand     udd = X86.udd -instance (E reg, E freg) => Arch AArch64.AArch64 reg freg where+instance (E reg, E freg, E f2reg) => Arch AArch64.AArch64 reg freg f2reg where     cf = AArch64.mkControlFlow      mI (AArch64.MovRR _ r0 r1) = Just (r0, r1)

@@ -7,9 +7,9 @@ import           Data.Copointed import           Data.Tuple.Extra (both) -bundle :: (E reg, E freg, Copointed (arch reg freg), Arch arch reg freg)-       => [arch reg freg ()]-       -> ([arch reg freg (UD, Liveness, Maybe (Int,Int))], [arch reg freg (UD, Liveness, Maybe (Int,Int))])+bundle :: (E reg, E freg, Copointed (arch reg freg f2), Arch arch reg freg f2)+       => [arch reg freg f2 ()]+       -> ([arch reg freg f2 (UD, Liveness, Maybe (Int,Int))], [arch reg freg f2 (UD, Liveness, Maybe (Int,Int))]) bundle isns =     let cfIsns = fmap udd isns; lIsns = mkLive isns         mvIsns = fmap (both toInt).mI<$>isns

@@ -4,6 +4,6 @@  import           Data.Copointed -data BB arch reg freg a b = BB { unBB :: [arch reg freg a], caBB :: b } deriving (Functor)+data BB arch reg freg f2reg a b = BB { unBB :: [arch reg freg f2reg a], caBB :: b } deriving (Functor) -instance Copointed (BB arch reg freg a) where copoint=caBB+instance Copointed (BB arch reg freg f2reg a) where copoint=caBB

@@ -85,8 +85,8 @@ buildOverF :: Copointed p => [[p (UD, Liveness, Maybe M)]] -> St -> St buildOverF blocks = thread [ \s -> snd $ buildF (fout (snd3 (copoint (last isns)))) s (reverse isns) | isns <- blocks ] -alloc :: (Ord reg, Arch arch areg afreg, Copointed (arch areg afreg))-      => [arch areg afreg (UD, Liveness, Maybe (Int,Int))]+alloc :: (Ord reg, Arch arch areg afreg af2, Copointed (arch areg afreg af2))+      => [arch areg afreg af2 (UD, Liveness, Maybe (Int,Int))]       -> [reg] -- ^ available registers       -> IS.IntSet -- ^ Precolored @areg@       -> IM.IntMap reg -- ^ Precolored map@@ -100,8 +100,8 @@     in if IS.null s then Right rs else Left s     where nIsns = fmap snd3 <$> aIsns; ᴋ = length regs -allocF :: (Ord freg, Arch arch areg afreg, Copointed (arch areg afreg))-       => [arch areg afreg (UD, Liveness, Maybe (Int,Int))]+allocF :: (Ord freg, Arch arch areg afreg af2, Copointed (arch areg afreg af2))+       => [arch areg afreg af2 (UD, Liveness, Maybe (Int,Int))]        -> [freg] -- ^ available registers        -> IS.IntSet -- ^ Precolored @afreg@        -> IM.IntMap freg -- ^ Precolored map

@@ -5,8 +5,8 @@ import           CF import           LR -mkLive :: (Arch arch reg freg) => [arch reg freg ()] -> [arch reg freg Liveness]+mkLive :: (Arch arch reg freg f2) => [arch reg freg f2 ()] -> [arch reg freg f2 Liveness] mkLive = concatMap expand. liveBB -liveBB :: (Arch arch reg freg) => [arch reg freg ()] -> [BB arch reg freg () Liveness]+liveBB :: (Arch arch reg freg f2) => [arch reg freg f2 ()] -> [BB arch reg freg f2 () Liveness] liveBB = fmap (fmap liveness) . reconstructFlat . cf . bb

@@ -8,6 +8,6 @@ import           Data.Copointed import           LI -mkIntervals :: (Arch arch reg freg, Copointed (arch reg freg)) => [arch reg freg ()] -> [arch reg freg Live]+mkIntervals :: (Arch arch reg freg f2, Copointed (arch reg freg f2)) => [arch reg freg f2 ()] -> [arch reg freg f2 Live] mkIntervals = intervals . enliven . mkLive     where enliven = zipWith (\n a -> fmap (NLiveness n) a) [0..]

@@ -57,7 +57,7 @@  instance Pretty CFunc where     pretty Malloc="malloc"; pretty Free="free"-    pretty JR="mrand48"; pretty DR="drand48"+    pretty JR="lrand48"; pretty DR="drand48"     pretty Exp="exp"; pretty Log="log"; pretty Pow="pow"  mFree :: Maybe (Ptr a) -> IO ()

@@ -5,10 +5,8 @@ {-# LANGUAGE OverloadedStrings          #-}  module Asm.X86 ( X86 (..)-               , AbsReg (..)-               , FAbsReg (..)-               , X86Reg (..)-               , FX86Reg (..)+               , AbsReg (..), FAbsReg (..), X2Abs (..)+               , X86Reg (..), FX86Reg (..), F2X86 (..)                , Addr (..)                , ST (..)                , Scale (..)@@ -17,12 +15,10 @@                , Label                , CFunc (..)                , prettyDebugX86-               , toInt-               , fToInt-               , imm8+               , toInt, fToInt, f2ToInt+               , imm8, simd2                , roundMode-               , mapR-               , mapFR+               , mapR, mapFR, mapF2                , fR                , hasMa                ) where@@ -42,9 +38,16 @@ data FX86Reg = XMM1 | XMM2 | XMM3 | XMM4 | XMM5 | XMM6 | XMM7 | XMM8 | XMM9 | XMM10 | XMM11 | XMM12 | XMM13 | XMM14 | XMM15 | XMM0              deriving (Eq, Ord, Enum, Generic) +data F2X86 = YMM1 | YMM2 | YMM3 | YMM4 | YMM5 | YMM6 | YMM7 | YMM8 | YMM9 | YMM10 | YMM11 | YMM12 | YMM13 | YMM14 | YMM15 | YMM0+           deriving (Eq, Ord, Enum, Generic)+ instance NFData X86Reg where instance NFData FX86Reg where+instance NFData F2X86 where +simd2 :: FX86Reg -> F2X86+simd2 = toEnum.fromEnum+ instance Pretty X86Reg where     pretty Rax = "rax"     pretty Rbx = "rbx"@@ -81,11 +84,28 @@     pretty XMM14 = "xmm14"     pretty XMM15 = "xmm15" -instance Show X86Reg where show = show . pretty+instance Pretty F2X86 where+    pretty YMM0  = "ymm0"+    pretty YMM1  = "ymm1"+    pretty YMM2  = "ymm2"+    pretty YMM3  = "ymm3"+    pretty YMM4  = "ymm4"+    pretty YMM5  = "ymm5"+    pretty YMM6  = "ymm6"+    pretty YMM7  = "ymm7"+    pretty YMM8  = "ymm8"+    pretty YMM9  = "ymm9"+    pretty YMM10 = "ymm10"+    pretty YMM11 = "ymm11"+    pretty YMM12 = "ymm12"+    pretty YMM13 = "ymm13"+    pretty YMM14 = "ymm14"+    pretty YMM15 = "ymm15" +instance Show X86Reg where show = show . pretty instance Show FX86Reg where show = show . pretty+instance Show F2X86 where show = show . pretty --- TODO: FAbsReg data AbsReg = IReg !Int             | CArg0 | CArg1 | CArg2 | CArg3 | CArg4 | CArg5             | CRet@@ -98,6 +118,8 @@              | FRet0 | FRet1              deriving (Eq, Ord) +data X2Abs = F2Reg !Int deriving (Eq, Ord)+ instance Pretty AbsReg where     pretty CArg0    = "rdi"     pretty CArg1    = "rsi"@@ -125,6 +147,9 @@     pretty FRet1    = "xmm1"     pretty (FReg i) = "^xmm" <> pretty i +instance Pretty X2Abs where+    pretty (F2Reg i) = "ymm" <> pretty i+ toInt :: AbsReg -> Int toInt CArg0    = 0 toInt CArg1    = 1@@ -152,6 +177,9 @@ fToInt FRet1    = 9 -- xmm1 fToInt (FReg i) = 16+i +f2ToInt :: X2Abs -> Int+f2ToInt (F2Reg i) = 16+i+ newtype ST = ST Int8 deriving (NFData)  instance Pretty ST where@@ -191,7 +219,7 @@     pretty Nleus  = "NLE_US"     pretty Ordq   = "ORD_Q" -hasMa :: [X86 reg freg a] -> Bool+hasMa :: [X86 reg freg f2reg a] -> Bool hasMa = any g where g Call{} = True; g _ = False  -- https://www.felixcloutier.com/x86/cmppd@@ -224,103 +252,103 @@     pretty (RSD b One i d) = brackets (pretty b <> pretty i <> pix d)     pretty (RSD b s i d)   = brackets (pretty b <> "+" <> pretty s <> "*" <> pretty i <> pix d) -data X86 reg freg a = Label { ann :: a, label :: Label }-                    | IAddRR { ann :: a, rAdd1, rAdd2 :: reg }-                    | IAddRI { ann :: a, rAdd1 :: reg, rAddI :: Int64 }-                    | ISubRR { ann :: a, rSub1, rSub2 :: reg }-                    | ISubRI { ann :: a, rSub :: reg, rSubI :: Int64 }-                    | IMulRR { ann :: a, rMul1, rMul2 :: reg }-                    | IMulRA { ann :: a, rMul :: reg, aSrc :: Addr reg }-                    | XorRR { ann :: a, rXor1, rXor2 :: reg }-                    | MovRR { ann :: a, rDest, rSrc :: reg }-                    | MovRA { ann :: a, rDest :: reg, aSrc :: Addr reg }-                    | MovAR { ann :: a, aDest :: Addr reg, rSrc :: reg }-                    | MovRL { ann :: a, rDest :: reg, lSrc :: Int }-                    | MovAI32 { ann :: a, aDest :: Addr reg, i32Src :: Int32 }-                    | MovRI { ann :: a, rDest :: reg, iSrc :: Int64 }-                    | MovqXR { ann :: a, fDest :: freg, rSrc :: reg }-                    | MovqXA { ann :: a, fDest :: freg, aSrc :: Addr reg }-                    | MovqAX { ann :: a, aDest :: Addr reg, fSrc :: freg }-                    | MovqRX { ann :: a, rDest :: reg, fSrc :: freg }-                    | Fld { ann :: a, a87 :: Addr reg }-                    | FldS { ann :: a, stIsn :: ST }-                    | Fldl2e { ann :: a }-                    | Fldln2 { ann :: a }-                    | Fld1 { ann :: a }-                    | Fyl2x { ann :: a }-                    | Fsin { ann :: a }-                    | Fcos { ann :: a }-                    | Fstp { ann :: a, a87 :: Addr reg }-                    | F2xm1 { ann :: a }-                    | Fmulp { ann :: a }-                    | Fprem { ann :: a }-                    | Faddp { ann :: a }-                    | Fscale { ann :: a }-                    | Fninit { ann :: a }-                    | Fxch { ann :: a, stIsn :: ST }-                    | J { ann :: a, label :: Label }-                    | Je { ann :: a, jLabel :: Label }-                    | Jne { ann :: a, jLabel :: Label }-                    | Jg { ann :: a, jLabel :: Label }-                    | Jge { ann :: a, jLabel :: Label }-                    | Jl { ann :: a, jLabel :: Label }-                    | Jle { ann :: a, jLabel :: Label }-                    | C { ann :: a, label :: Label }-                    | CmpRR { ann :: a, rCmp, rCmp' :: reg }-                    | CmpRI { ann :: a, rCmp :: reg, cmpI32 :: Int32 }-                    | Vcmppd { ann :: a, fDest, fCmp, fCmp' :: freg, cpred :: Pred }-                    | Test { ann :: a, rCmp, rCmp' :: reg }-                    | TestI { ann :: a, rCmp :: reg, cmpI32 :: Int32 }-                    | Ret { ann :: a } | RetL { ann :: a, label :: Label }-                    | Vdivsd { ann :: a, fDest, fSrc1, fSrc2 :: freg }-                    | Movapd { ann :: a, fDest, fSrc :: freg }-                    | Roundsd { ann :: a, fDest, fSrc :: freg, mode :: RoundMode }-                    | Cvttsd2si { ann :: a, rDest :: reg, fSrc :: freg }-                    | Mulsd { ann :: a, fDest, fSrc :: freg }-                    | Addsd { ann :: a, fDest, fSrc :: freg }-                    | Subsd { ann :: a, fDest, fSrc :: freg }-                    | Divsd { ann :: a, fDest, fSrc :: freg }-                    | Vmulsd { ann :: a, fDest, fSrc1, fSrc2 :: freg }-                    | Vaddsd { ann :: a, fDest, fSrc1, fSrc2 :: freg }-                    | Vsubsd { ann :: a, fDest, fSrc1, fSrc2 :: freg }-                    | VaddsdA { ann :: a, fDest, fSrc :: freg, aSrc :: Addr reg }-                    | Cvtsi2sd { ann :: a, fDest :: freg, rSrc :: reg }-                    | Vfmadd231sd { ann :: a, fDest, fSrc1, fSrc2 :: freg }-                    | Vfmadd213sd { ann :: a, fDest, fSrc1, fSrc2 :: freg }-                    | Vfmsub231sd { ann :: a, fDest, fSrc1, fSrc2 :: freg }-                    | Vfmsub213sd { ann :: a, fDest, fSrc1, fSrc2 :: freg }-                    | Vfmsub132sd { ann :: a, fDest, fSrc1, fSrc2 :: freg }-                    | Vfmnadd231sd { ann :: a, fDest, fSrc1, fSrc2 :: freg }-                    | Vfmadd231sdA { ann :: a, fDest, fSrc :: freg, aSrc :: Addr reg }-                    | Push { ann :: a, rSrc :: reg }-                    | Pop { ann :: a, rDest :: reg }-                    | Call { ann :: a, cfunc :: CFunc }-                    | IDiv { ann :: a, rSrc :: reg }-                    | Sal { ann :: a, rSrc :: reg, iExp :: Int8 }-                    | Sar { ann :: a, rSrc :: reg, iExp :: Int8 }-                    | Sqrtsd { ann :: a, fDest, fSrc :: freg }-                    | Maxsd { ann :: a, fDest, fSrc :: freg }-                    | Vmaxsd { ann :: a, fDest, fSrc1, fSrc2 :: freg }-                    | VmaxsdA { ann :: a, fDest, fSrc :: freg, aSrc :: Addr reg }-                    | Minsd { ann :: a, fDest, fSrc :: freg }-                    | Vminsd { ann :: a, fDest, rSrc1, rSrc2 :: freg }-                    | Not { ann :: a, rSrc :: reg }-                    | And { ann :: a, rDest, rSrc :: reg }-                    | Cmovnle { ann :: a, rDest, rSrc :: reg }-                    | Cmovnl { ann :: a, rDest, rSrc :: reg }-                    | Cmovne { ann :: a, rDest , rSrc :: reg }-                    | Cmove { ann :: a, rDest, rSrc :: reg }-                    | Cmovl { ann :: a, rDest, rSrc :: reg }-                    | Cmovle { ann :: a, rDest, rSrc :: reg }-                    | Rdrand { ann :: a, rDest :: reg }-                    | Neg { ann :: a, rDest :: reg }+data X86 reg freg f2 a = Label { ann :: a, label :: Label }+                       | IAddRR { ann :: a, rAdd1, rAdd2 :: reg }+                       | IAddRI { ann :: a, rAdd1 :: reg, rAddI :: Int64 }+                       | ISubRR { ann :: a, rSub1, rSub2 :: reg }+                       | ISubRI { ann :: a, rSub :: reg, rSubI :: Int64 }+                       | IMulRR { ann :: a, rMul1, rMul2 :: reg }+                       | IMulRA { ann :: a, rMul :: reg, aSrc :: Addr reg }+                       | XorRR { ann :: a, rXor1, rXor2 :: reg }+                       | MovRR { ann :: a, rDest, rSrc :: reg }+                       | MovRA { ann :: a, rDest :: reg, aSrc :: Addr reg }+                       | MovAR { ann :: a, aDest :: Addr reg, rSrc :: reg }+                       | MovRL { ann :: a, rDest :: reg, lSrc :: Int }+                       | MovAI32 { ann :: a, aDest :: Addr reg, i32Src :: Int32 }+                       | MovRI { ann :: a, rDest :: reg, iSrc :: Int64 }+                       | MovqXR { ann :: a, fDest :: freg, rSrc :: reg }+                       | MovqXA { ann :: a, fDest :: freg, aSrc :: Addr reg }+                       | MovqAX { ann :: a, aDest :: Addr reg, fSrc :: freg }+                       | MovqRX { ann :: a, rDest :: reg, fSrc :: freg }+                       | Fld { ann :: a, a87 :: Addr reg }+                       | FldS { ann :: a, stIsn :: ST }+                       | Fldl2e { ann :: a }+                       | Fldln2 { ann :: a }+                       | Fld1 { ann :: a }+                       | Fyl2x { ann :: a }+                       | Fsin { ann :: a }+                       | Fcos { ann :: a }+                       | Fstp { ann :: a, a87 :: Addr reg }+                       | F2xm1 { ann :: a }+                       | Fmulp { ann :: a }+                       | Fprem { ann :: a }+                       | Faddp { ann :: a }+                       | Fscale { ann :: a }+                       | Fninit { ann :: a }+                       | Fxch { ann :: a, stIsn :: ST }+                       | J { ann :: a, label :: Label }+                       | Je { ann :: a, jLabel :: Label }+                       | Jne { ann :: a, jLabel :: Label }+                       | Jg { ann :: a, jLabel :: Label }+                       | Jge { ann :: a, jLabel :: Label }+                       | Jl { ann :: a, jLabel :: Label }+                       | Jle { ann :: a, jLabel :: Label }+                       | C { ann :: a, label :: Label }+                       | CmpRR { ann :: a, rCmp, rCmp' :: reg }+                       | CmpRI { ann :: a, rCmp :: reg, cmpI32 :: Int32 }+                       | Vcmppd { ann :: a, fDest, fCmp, fCmp' :: freg, cpred :: Pred }+                       | Test { ann :: a, rCmp, rCmp' :: reg }+                       | TestI { ann :: a, rCmp :: reg, cmpI32 :: Int32 }+                       | Ret { ann :: a }                                                 | RetL { ann :: a, label :: Label }+                       | Vdivsd { ann :: a, fDest, fSrc1, fSrc2 :: freg }+                       | Movapd { ann :: a, fDest, fSrc :: freg }+                       | Roundsd { ann :: a, fDest, fSrc :: freg, mode :: RoundMode }+                       | Cvttsd2si { ann :: a, rDest :: reg, fSrc :: freg }+                       | Mulsd { ann :: a, fDest, fSrc :: freg }+                       | Addsd { ann :: a, fDest, fSrc :: freg }+                       | Subsd { ann :: a, fDest, fSrc :: freg }+                       | Divsd { ann :: a, fDest, fSrc :: freg }+                       | Vmulsd { ann :: a, fDest, fSrc1, fSrc2 :: freg }+                       | Vaddsd { ann :: a, fDest, fSrc1, fSrc2 :: freg }+                       | Vsubsd { ann :: a, fDest, fSrc1, fSrc2 :: freg }+                       | VaddsdA { ann :: a, fDest, fSrc :: freg, aSrc :: Addr reg }+                       | Cvtsi2sd { ann :: a, fDest :: freg, rSrc :: reg }+                       | Vfmadd231sd { ann :: a, fDest, fSrc1, fSrc2 :: freg }+                       | Vfmadd213sd { ann :: a, fDest, fSrc1, fSrc2 :: freg }+                       | Vfmsub231sd { ann :: a, fDest, fSrc1, fSrc2 :: freg }+                       | Vfmsub213sd { ann :: a, fDest, fSrc1, fSrc2 :: freg }+                       | Vfmsub132sd { ann :: a, fDest, fSrc1, fSrc2 :: freg }+                       | Vfmnadd231sd { ann :: a, fDest, fSrc1, fSrc2 :: freg }+                       | Vfmadd231sdA { ann :: a, fDest, fSrc :: freg, aSrc :: Addr reg }+                       | Push { ann :: a, rSrc :: reg }+                       | Pop { ann :: a, rDest :: reg }+                       | Call { ann :: a, cfunc :: CFunc }+                       | IDiv { ann :: a, rSrc :: reg }+                       | Sal { ann :: a, rSrc :: reg, iExp :: Int8 }+                       | Sar { ann :: a, rSrc :: reg, iExp :: Int8 }+                       | Sqrtsd { ann :: a, fDest, fSrc :: freg }+                       | Maxsd { ann :: a, fDest, fSrc :: freg }+                       | Vmaxsd { ann :: a, fDest, fSrc1, fSrc2 :: freg }+                       | VmaxsdA { ann :: a, fDest, fSrc :: freg, aSrc :: Addr reg }+                       | Minsd { ann :: a, fDest, fSrc :: freg }+                       | Vminsd { ann :: a, fDest, rSrc1, rSrc2 :: freg }+                       | Not { ann :: a, rSrc :: reg }+                       | And { ann :: a, rDest, rSrc :: reg }+                       | Cmovnle { ann :: a, rDest, rSrc :: reg }+                       | Cmovnl { ann :: a, rDest, rSrc :: reg }+                       | Cmovne { ann :: a, rDest , rSrc :: reg }+                       | Cmove { ann :: a, rDest, rSrc :: reg }+                       | Cmovl { ann :: a, rDest, rSrc :: reg }+                       | Cmovle { ann :: a, rDest, rSrc :: reg }+                       | Rdrand { ann :: a, rDest :: reg }+                       | Neg { ann :: a, rDest :: reg }                     deriving (Functor, Generic) -instance (NFData a, NFData reg, NFData freg) => NFData (X86 reg freg a) where+instance (NFData a, NFData reg, NFData freg, NFData f2) => NFData (X86 reg freg f2 a) where -instance Copointed (X86 reg freg) where copoint = ann+instance Copointed (X86 reg freg f2reg) where copoint = ann -instance (Pretty reg, Pretty freg) => Pretty (X86 reg freg a) where+instance (Pretty reg, Pretty freg, Pretty f2reg) => Pretty (X86 reg freg f2reg a) where     pretty (J _ l)                       = i4 ("jmp" <+> prettyLabel l)     pretty (Label _ l)                   = prettyLabel l <> colon     pretty (CmpRR _ r0 r1)               = i4 ("cmp" <+> pretty r0 <> "," <+> pretty r1)@@ -420,12 +448,12 @@     pretty RetL{}                        = i4 "ret"     pretty (Neg _ r)                     = i4 ("neg" <+> pretty r) -instance (Pretty reg, Pretty freg) => Show (X86 reg freg a) where show = show . pretty+instance (Pretty reg, Pretty freg, Pretty f2) => Show (X86 reg freg f2 a) where show = show . pretty -prettyLive :: (Pretty reg, Pretty freg, Pretty o) => X86 reg freg o -> Doc ann+prettyLive :: (Pretty reg, Pretty freg, Pretty f2, Pretty o) => X86 reg freg f2 o -> Doc ann prettyLive r = pretty r <+> pretty (ann r) -prettyDebugX86 :: (Pretty freg, Pretty reg, Pretty o) => [X86 reg freg o] -> Doc ann+prettyDebugX86 :: (Pretty freg, Pretty reg, Pretty f2reg, Pretty o) => [X86 reg freg f2reg o] -> Doc ann prettyDebugX86 = prettyLines . fmap prettyLive  (@<>) :: Semigroup m => (reg -> m) -> Addr reg -> m@@ -435,7 +463,7 @@ (@<>) f (RS r0 _ r1)    = f r0 <> f r1 (@<>) f (RSD r0 _ r1 _) = f r0 <> f r1 -mapR :: (areg -> reg) -> X86 areg afreg a -> X86 reg afreg a+mapR :: (areg -> reg) -> X86 areg afreg af2 a -> X86 reg afreg af2 a mapR f (MovRR l r0 r1)              = MovRR l (f r0) (f r1) mapR f (MovRL x r l)                = MovRL x (f r) l mapR _ (Jg x l)                     = Jg x l@@ -529,7 +557,7 @@ mapR _ (RetL a l)                   = RetL a l mapR f (Neg a r)                    = Neg a (f r) -fR :: (Monoid m) => (reg -> m) -> X86 reg freg a -> m+fR :: (Monoid m) => (reg -> m) -> X86 reg freg f2reg a -> m fR _ Jg{}                   = mempty fR _ J{}                    = mempty fR f (MovAR _ a r)          = f @<> a <> f r@@ -622,7 +650,100 @@ fR f (Rdrand _ r)           = f r fR f (Neg _ r)              = f r -mapFR :: (afreg -> freg) -> X86 areg afreg a -> X86 areg freg a+mapF2 :: (af2 -> f2) -> X86 areg afreg af2 a -> X86 areg afreg f2 a+mapF2 _ (Jg x l)                     = Jg x l+mapF2 _ (J x l)                      = J x l+mapF2 _ (Label x l)                  = Label x l+mapF2 _ (MovRI l r i)                = MovRI l r i+mapF2 _ (MovRR l r0 r1)              = MovRR l r0 r1+mapF2 _ (MovRL x r l)                = MovRL x r l+mapF2 _ (IAddRI l r i)               = IAddRI l r i+mapF2 _ (Movapd l r0 r1)             = Movapd l r0 r1+mapF2 _ (Mulsd l xr0 xr1)            = Mulsd l xr0 xr1+mapF2 _ (MovqXR l xr r)              = MovqXR l xr r+mapF2 _ (Roundsd l xr0 xr1 s)        = Roundsd l xr0 xr1 s+mapF2 _ (Cvttsd2si l r xr)           = Cvttsd2si l r xr+mapF2 _ (Vsubsd l xr0 xr1 xr2)       = Vsubsd l xr0 xr1 xr2+mapF2 _ (Vaddsd l xr0 xr1 xr2)       = Vaddsd l xr0 xr1 xr2+mapF2 _ (VaddsdA l xr0 xr1 r)        = VaddsdA l xr0 xr1 r+mapF2 _ (Vdivsd l xr0 xr1 xr2)       = Vdivsd l xr0 xr1 xr2+mapF2 _ (CmpRR l r0 r1)              = CmpRR l r0 r1+mapF2 _ (Addsd l xr0 xr1)            = Addsd l xr0 xr1+mapF2 _ (IAddRR l r0 r1)             = IAddRR l r0 r1+mapF2 _ (ISubRR l r0 r1)             = ISubRR l r0 r1+mapF2 _ (IMulRR l r0 r1)             = IMulRR l r0 r1+mapF2 _ (IMulRA l r a)               = IMulRA l r a+mapF2 _ (ISubRI l r i)               = ISubRI l r i+mapF2 _ (MovRA l r a)                = MovRA l r a+mapF2 _ (MovAI32 l r i)              = MovAI32 l r i+mapF2 _ (MovAR l a r)                = MovAR l a r+mapF2 _ (MovqXA l xr a)              = MovqXA l xr a+mapF2 _ (MovqAX l a xr)              = MovqAX l a xr+mapF2 _ (Fld l a)                    = Fld l a+mapF2 _ (FldS l s)                   = FldS l s+mapF2 _ (Fldl2e l)                   = Fldl2e l+mapF2 _ (Fldln2 l)                   = Fldln2 l+mapF2 _ (Fld1 l)                     = Fld1 l+mapF2 _ (Fyl2x l)                    = Fyl2x l+mapF2 _ (Fstp l a)                   = Fstp l a+mapF2 _ (F2xm1 l)                    = F2xm1 l+mapF2 _ (Fmulp l)                    = Fmulp l+mapF2 _ (Fprem l)                    = Fprem l+mapF2 _ (Faddp l)                    = Faddp l+mapF2 _ (Fscale l)                   = Fscale l+mapF2 _ (Fninit l)                   = Fninit l+mapF2 _ (Fxch l s)                   = Fxch l s+mapF2 _ (Je x l)                     = Je x l+mapF2 _ (Jge x l)                    = Jge x l+mapF2 _ (Jne x l)                    = Jne x l+mapF2 _ (Jl x l)                     = Jl x l+mapF2 _ (Jle x l)                    = Jle x l+mapF2 _ (CmpRI l r i)                = CmpRI l r i+mapF2 _ (Ret l)                      = Ret l+mapF2 _ (Subsd l xr0 xr1)            = Subsd l xr0 xr1+mapF2 _ (Divsd l xr0 xr1)            = Divsd l xr0 xr1+mapF2 _ (Vmulsd l xr0 xr1 xr2)       = Vmulsd l xr0 xr1 xr2+mapF2 _ (Push l r)                   = Push l r+mapF2 _ (Pop l r)                    = Pop l r+mapF2 _ (IDiv l r)                   = IDiv l r+mapF2 _ (Call l f)                   = Call l f+mapF2 _ (Sal l r i)                  = Sal l r i+mapF2 _ (Sar l r i)                  = Sar l r i+mapF2 _ (Maxsd l xr0 xr1)            = Maxsd l xr0 xr1+mapF2 _ (Vmaxsd l xr0 xr1 xr2)       = Vmaxsd l xr0 xr1 xr2+mapF2 _ (VmaxsdA l xr0 xr1 a)        = VmaxsdA l xr0 xr1 a+mapF2 _ (Minsd l xr0 xr1)            = Minsd l xr0 xr1+mapF2 _ (Vminsd l xr0 xr1 xr2)       = Vminsd l xr0 xr1 xr2+mapF2 _ (Not l r)                    = Not l r+mapF2 _ (Cvtsi2sd l xr r)            = Cvtsi2sd l xr r+mapF2 _ (Vfmadd231sd l xr0 xr1 xr2)  = Vfmadd231sd l xr0 xr1 xr2+mapF2 _ (Vfmnadd231sd l xr0 xr1 xr2) = Vfmnadd231sd l xr0 xr1 xr2+mapF2 _ (Vfmadd213sd l xr0 xr1 xr2)  = Vfmadd213sd l xr0 xr1 xr2+mapF2 _ (Vfmsub213sd l xr0 xr1 xr2)  = Vfmsub213sd l xr0 xr1 xr2+mapF2 _ (Vfmsub231sd l xr0 xr1 xr2)  = Vfmsub231sd l xr0 xr1 xr2+mapF2 _ (Vfmsub132sd l xr0 xr1 xr2)  = Vfmsub132sd l xr0 xr1 xr2+mapF2 _ (Vfmadd231sdA l xr0 xr1 a)   = Vfmadd231sdA l xr0 xr1 a+mapF2 _ (Sqrtsd l xr0 xr1)           = Sqrtsd l xr0 xr1+mapF2 _ (And l r0 r1)                = And l r0 r1+mapF2 _ (Cmovnle l r0 r1)            = Cmovnle l r0 r1+mapF2 _ (Cmovnl l r0 r1)             = Cmovnl l r0 r1+mapF2 _ (Cmovne l r0 r1)             = Cmovne l r0 r1+mapF2 _ (Cmove l r0 r1)              = Cmove l r0 r1+mapF2 _ (Cmovl l r0 r1)              = Cmovl l r0 r1+mapF2 _ (Cmovle l r0 r1)             = Cmovle l r0 r1+mapF2 _ (Rdrand l r)                 = Rdrand l r+mapF2 _ (TestI l r i)                = TestI l r i+mapF2 _ (Test l r0 r1)               = Test l r0 r1+mapF2 _ (Vcmppd l xr0 xr1 xr2 p)     = Vcmppd l xr0 xr1 xr2 p+mapF2 _ (MovqRX l r xr)              = MovqRX l r xr+mapF2 _ (Fsin l)                     = Fsin l+mapF2 _ (Fcos l)                     = Fcos l+mapF2 _ (XorRR l r0 r1)              = XorRR l r0 r1+mapF2 _ (C a l)                      = C a l+mapF2 _ (RetL a l)                   = RetL a l+mapF2 _ (Neg a r)                    = Neg a r++mapFR :: (afreg -> freg) -> X86 areg afreg af2 a -> X86 areg freg af2 a mapFR _ (Jg x l)                     = Jg x l mapFR _ (J x l)                      = J x l mapFR _ (Label x l)                  = Label x l

@@ -4,7 +4,7 @@ import           Asm.X86 import           Data.List.Split (keepDelimsL, keepDelimsR, split, whenElt) -bb :: [X86 reg freg a] -> [BB X86 reg freg a ()]+bb :: [X86 reg freg f2reg a] -> [BB X86 reg freg f2reg a ()] bb = filter (not.emptyBB).fmap mkBB.concatMap (split (keepDelimsL$whenElt isL)).split (keepDelimsR$whenElt cf)     where cf J{}=True; cf Jl{}=True; cf Jg{}=True; cf Jge{}=True; cf Jle{}=True; cf Jne{}=True; cf C{}=True; cf RetL{}=True; cf _=False           isL Label{}=True; isL _=False

@@ -25,14 +25,14 @@ pI :: Ptr a -> Int pI = (\(IntPtr i) -> i) . ptrToIntPtr -prepAddrs :: [X86 reg freg a] -> IO (Maybe CCtx)+prepAddrs :: [X86 reg freg f2reg a] -> IO (Maybe CCtx) prepAddrs ss = if hasMa ss then Just <$> mem' else pure Nothing  dbgFp asmϵ = do     (bs, _, ps) <- allFp asmϵ     mFree ps $> bs -assembleCtx :: CCtx -> (IM.IntMap [Word64], [X86 X86Reg FX86Reg a]) -> IO (BS.ByteString, FunPtr b, Maybe (Ptr Word64))+assembleCtx :: CCtx -> (IM.IntMap [Word64], [X86 X86Reg FX86Reg F2X86 a]) -> IO (BS.ByteString, FunPtr b, Maybe (Ptr Word64)) assembleCtx ctx (ds, isns) = do     let (sz, lbls) = mkIx 0 isns     p <- if hasMa isns then allocNear (fst4 ctx) (fromIntegral sz) else allocExec (fromIntegral sz)@@ -41,7 +41,7 @@         mP = snd<$>IM.lookupMin arrs     (b,,mP)<$>finish b p -allFp :: (IM.IntMap [Word64], [X86 X86Reg FX86Reg a]) -> IO ([BS.ByteString], FunPtr b, Maybe (Ptr Word64))+allFp :: (IM.IntMap [Word64], [X86 X86Reg FX86Reg F2X86 a]) -> IO ([BS.ByteString], FunPtr b, Maybe (Ptr Word64)) allFp (ds, instrs) = do     let (sz, lbls) = mkIx 0 instrs     (fn, p) <- do@@ -54,7 +54,7 @@         mP = snd<$>IM.lookupMin arrs     (bs,,mP)<$>finish b p -assemble :: (IM.IntMap [Word64], [X86 X86Reg FX86Reg a]) -> BS.ByteString+assemble :: (IM.IntMap [Word64], [X86 X86Reg FX86Reg F2X86 a]) -> BS.ByteString assemble (_, instrs) =     let (_, lbls) = mkIx 0 instrs in     BS.pack.concat$asm 0 (error "Internal error: no self", error "Arrays not allowed :(", Nothing, lbls) instrs@@ -169,7 +169,7 @@           modRMB = 0x1 `shiftL` 6 .|. b0 `shiftL` 3 .|. 0x4           sib = bb `shiftL` 3 .|. bb -mkIx :: Int -> [X86 X86Reg FX86Reg a] -> (Int, M.Map Label Int)+mkIx :: Int -> [X86 X86Reg FX86Reg F2X86 a] -> (Int, M.Map Label Int) mkIx ix (Pop _ r:asms) | fits r               = mkIx (ix+1) asms                        | otherwise            = mkIx (ix+2) asms mkIx ix (Push _ r:asms) | fits r              = mkIx (ix+1) asms@@ -327,7 +327,7 @@ fits :: RMB reg => reg -> Bool fits r = let (e, _) = modRM r in e == 0 -asm :: Int -> (Int, IM.IntMap (Ptr Word64), Maybe CCtx, M.Map Label Int) -> [X86 X86Reg FX86Reg a] -> [[Word8]]+asm :: Int -> (Int, IM.IntMap (Ptr Word64), Maybe CCtx, M.Map Label Int) -> [X86 X86Reg FX86Reg F2X86 a] -> [[Word8]] asm _ _ [] = [] asm ix st (Push _ r:asms) | fits r =     let (_, b0) = modRM r

@@ -15,10 +15,10 @@ import           Data.Functor (void, ($>)) import qualified Data.IntSet  as IS -mkControlFlow :: (E reg, E freg) => [BB X86 reg freg () ()] -> [BB X86 reg freg () ControlAnn]+mkControlFlow :: (E reg, E freg) => [BB X86 reg freg f2reg () ()] -> [BB X86 reg freg f2reg () ControlAnn] mkControlFlow isns = runFreshM (broadcasts isns *> addControlFlow isns) -expand :: (E reg, E freg) => BB X86 reg freg () Liveness -> [X86 reg freg Liveness]+expand :: (E reg, E freg) => BB X86 reg freg f2reg () Liveness -> [X86 reg freg f2reg Liveness] expand (BB asms@(_:_) li) = scanr (\n p -> lN n (ann p)) lS iasms     where lN a s =             let ai=uses a <> (ao IS.\\ defs a)@@ -35,7 +35,7 @@ {-# SCC addControlFlow #-} -- | Annotate instructions with a unique node name and a list of all possible -- destinations.-addControlFlow :: (E reg, E freg) => [BB X86 reg freg () ()] -> FreshM [BB X86 reg freg () ControlAnn]+addControlFlow :: (E reg, E freg) => [BB X86 reg freg f2reg () ()] -> FreshM [BB X86 reg freg f2reg () ControlAnn] addControlFlow [] = pure [] addControlFlow (BB asms _:bbs) = do     { i <- case asms of@@ -59,11 +59,11 @@ ubb asm = UD (uBB asm) (uBBF asm) (dBB asm) (dBBF asm) udd asm = UD (uses asm) (usesF asm) (defs asm) (defsF asm) -uBB, dBB :: E reg => [X86 reg freg a] -> IS.IntSet+uBB, dBB :: E reg => [X86 reg freg f2reg a] -> IS.IntSet uBB = foldr (\p n -> uses p `IS.union` (n IS.\\ defs p)) IS.empty dBB = foldMap defs -uBBF, dBBF :: E freg => [X86 reg freg a] -> IS.IntSet+uBBF, dBBF :: E freg => [X86 reg freg f2reg a] -> IS.IntSet uBBF = foldr (\p n -> usesF p `IS.union` (n IS.\\ defsF p)) IS.empty dBBF = foldMap defsF @@ -74,7 +74,7 @@ uA (RS b _ i)    = fromList [b,i] uA (RSD b _ i _) = fromList [b,i] -usesF :: E freg => X86 reg freg ann -> IS.IntSet+usesF :: E freg => X86 reg freg f2reg ann -> IS.IntSet usesF (Movapd _ _ r)            = singleton r usesF (Vmulsd _ _ r0 r1)        = fromList [r0, r1] usesF (Vaddsd _ _ r0 r1)        = fromList [r0, r1]@@ -161,7 +161,7 @@ usesF RetL{}                    = IS.empty usesF Ret{}                     = fromList [FRet0, FRet1] -uses :: E reg => X86 reg freg ann -> IS.IntSet+uses :: E reg => X86 reg freg f2reg ann -> IS.IntSet uses (MovRR _ _ r)          = singleton r uses MovRL{}                = IS.empty uses (And _ r0 r1)          = fromList [r0, r1]@@ -250,7 +250,7 @@ uses RetL{}                 = IS.empty uses Ret{}                  = singleton CRet -defsF :: E freg => X86 reg freg ann -> IS.IntSet+defsF :: E freg => X86 reg freg f2reg ann -> IS.IntSet defsF (Movapd _ r _)         = singleton r defsF (Vmulsd _ r _ _)       = singleton r defsF (Vaddsd _ r _ _)       = singleton r@@ -338,7 +338,7 @@ defsF RetL{}                 = IS.empty defsF Ret{}                  = IS.empty -defs :: (E reg) => X86 reg freg ann -> IS.IntSet+defs :: (E reg) => X86 reg freg f2reg ann -> IS.IntSet defs (MovRR _ r _)     = singleton r defs (MovRL _ r _)     = singleton r defs MovqXR{}          = IS.empty@@ -427,7 +427,7 @@ defs RetL{}            = IS.empty defs Ret{}             = IS.empty -next :: (E reg, E freg) => [BB X86 reg freg () ()] -> FreshM ([Int] -> [Int], [BB X86 reg freg () ControlAnn])+next :: (E reg, E freg) => [BB X86 reg freg f2reg () ()] -> FreshM ([Int] -> [Int], [BB X86 reg freg f2reg () ControlAnn]) next asms = do     nextAsms <- addControlFlow asms     case nextAsms of@@ -435,7 +435,7 @@         (asm:_) -> pure ((node (caBB asm) :), nextAsms)  -- | Construct map assigning labels to their node name.-broadcasts :: [BB X86 reg freg a ()] -> FreshM ()+broadcasts :: [BB X86 reg freg f2reg a ()] -> FreshM () broadcasts [] = pure () broadcasts ((BB asms@(asm:_) _):bbs@((BB (Label _ retL:_) _):_)) | C _ l <- last asms = do     { i <- fm retL; b3 i l

@@ -7,7 +7,7 @@ import qualified Data.IntSet    as IS import           Data.Maybe     (mapMaybe) -frameC :: [X86 X86Reg FX86Reg Live] -> [X86 X86Reg FX86Reg ()]+frameC :: [X86 X86Reg FX86Reg F2X86 Live] -> [X86 X86Reg FX86Reg F2X86 ()] frameC = concat . go IS.empty IS.empty     where go _ _ [] = []           go s fs (isn:isns) =

@@ -18,10 +18,10 @@ occ r a = toInt r `IS.member` foldMap (IS.singleton.toInt) a  -- remove noops-optX86 :: (E reg, E freg, Eq reg, Eq freg) => [X86 reg freg ()] -> [X86 reg freg ()]+optX86 :: (E reg, E freg, Eq reg, Eq freg) => [X86 reg freg f2 ()] -> [X86 reg freg f2 ()] optX86 = opt.mkLive -opt :: (E reg, E freg, Eq reg, Eq freg) => [X86 reg freg Liveness] -> [X86 reg freg ()]+opt :: (E reg, E freg, Eq reg, Eq freg) => [X86 reg freg f2 Liveness] -> [X86 reg freg f2 ()] opt [] = [] opt (ISubRI _ _ 0:asms) = opt asms opt (MovqXA _ xrϵ a:Vfmadd231sd l xr0 xr1 xr2:asms) | xr2 == xrϵ && (toInt xr2 `IS.notMember` fout l) = Vfmadd231sdA () xr0 xr1 (optAddr a):opt asms

@@ -12,17 +12,17 @@  -- TODO: don't bother re-analyzing if no Calls gallocFrame :: Int -- ^ int supply for spilling-            -> [X86 AbsReg FAbsReg ()] -> [X86 X86Reg FX86Reg ()]+            -> [X86 AbsReg FAbsReg X2Abs ()] -> [X86 X86Reg FX86Reg F2X86 ()] gallocFrame u = frameC . mkIntervals . galloc u  {-# SCC galloc #-}-galloc :: Int -> [X86 AbsReg FAbsReg ()] -> [X86 X86Reg FX86Reg ()]-galloc u isns = frame clob'd (fmap (mapR ((regs IM.!).toInt).mapFR ((fregs IM.!).fToInt)) isns')+galloc :: Int -> [X86 AbsReg FAbsReg X2Abs ()] -> [X86 X86Reg FX86Reg F2X86 ()]+galloc u isns = frame clob'd (fmap (mapR ((regs IM.!).toInt).mapFR ((fregs IM.!).fToInt).mapF2 (simd2.(fregs IM.!).f2ToInt)) isns')     where (regs, fregs, isns') = gallocOn u (isns ++ [Ret()])           clob'd = S.fromList $ IM.elems regs  {-# SCC frame #-}-frame :: S.Set X86Reg -> [X86 X86Reg FX86Reg ()] -> [X86 X86Reg FX86Reg ()]+frame :: S.Set X86Reg -> [X86 X86Reg FX86Reg F2X86 ()] -> [X86 X86Reg FX86Reg F2X86 ()] frame clob asms = pre++asms++post++[Ret()] where     pre = save$Push () <$> clobs     post = restore$Pop () <$> reverse clobs@@ -32,7 +32,7 @@     -- https://stackoverflow.com/questions/51523127/why-does-the-compiler-reserve-a-little-stack-space-but-not-the-whole-array-size  {-# INLINE gallocOn #-}-gallocOn :: Int -> [X86 AbsReg FAbsReg ()] -> (IM.IntMap X86Reg, IM.IntMap FX86Reg, [X86 AbsReg FAbsReg ()])+gallocOn :: Int -> [X86 AbsReg FAbsReg X2Abs ()] -> (IM.IntMap X86Reg, IM.IntMap FX86Reg, [X86 AbsReg FAbsReg X2Abs ()]) gallocOn u = go u 16 pres True     where go uϵ offs pres' i isns = rmaps               where rmaps = case (regsM, fregsM) of

@@ -18,8 +18,8 @@ spill :: Int -- ^ Unique state       -> Int       -> IS.IntSet-      -> [X86 AbsReg FAbsReg a]-      -> (Int, Int, [X86 AbsReg FAbsReg ()])+      -> [X86 AbsReg FAbsReg X2Abs a]+      -> (Int, Int, [X86 AbsReg FAbsReg X2Abs ()]) spill u offs m isns =     let (o', ᴍ) = spillM offs m isns         (nisns, u') = runState ᴍ u@@ -27,8 +27,8 @@  spillM :: Int -- ^ Offset (from already spilled)        -> IS.IntSet-       -> [X86 AbsReg FAbsReg a]-       -> (Int, SpM [X86 AbsReg FAbsReg ()]) -- ^ offset, rewritten+       -> [X86 AbsReg FAbsReg X2Abs a]+       -> (Int, SpM [X86 AbsReg FAbsReg X2Abs ()]) -- ^ offset, rewritten spillM offs m isns = (foffs, concatMapM g isns)     where g isn = do             let is = [ toInt r | r <- fR pure isn, toInt r `IS.member` m ]

@@ -13,11 +13,11 @@ import qualified IR import qualified Op -plF :: IR.FExp -> WM ([X86 AbsReg FAbsReg ()] -> [X86 AbsReg FAbsReg ()], FAbsReg)+plF :: IR.FExp -> WM ([X86 AbsReg FAbsReg X2Abs ()] -> [X86 AbsReg FAbsReg X2Abs ()], FAbsReg) plF (IR.FReg t) = pure (id, fabsReg t) plF e           = do {i <- nextI; pl <- feval e (IR.FTemp i); pure ((pl++), FReg i)} -plI :: IR.Exp -> WM ([X86 AbsReg FAbsReg ()] -> [X86 AbsReg FAbsReg ()], AbsReg)+plI :: IR.Exp -> WM ([X86 AbsReg FAbsReg X2Abs ()] -> [X86 AbsReg FAbsReg X2Abs ()], AbsReg) plI (IR.Reg t) = pure (id, absReg t) plI e          = do {i <- nextI; pl <- evalE e (IR.ITemp i); pure ((pl++), IReg i)} @@ -43,7 +43,7 @@ fabsReg IR.FRet      = FRet0 fabsReg IR.FRet1     = FRet1 -irToX86 :: IR.WSt -> [IR.Stmt] -> (Int, [X86 AbsReg FAbsReg ()])+irToX86 :: IR.WSt -> [IR.Stmt] -> (Int, [X86 AbsReg FAbsReg X2Abs ()]) irToX86 st = swap . second IR.wtemps . flip runState st . foldMapA ir  nextR :: WM AbsReg@@ -76,7 +76,7 @@ nopPred Op.FLt  = Nltus nopPred Op.FLeq = Nleus -ir :: IR.Stmt -> WM [X86 AbsReg FAbsReg ()]+ir :: IR.Stmt -> WM [X86 AbsReg FAbsReg X2Abs ()] ir (IR.MT t (IR.EAt (IR.AP m (Just (IR.ConstI i)) _))) | Just i8 <- mi8 i = pure [MovRA () (absReg t) (RC (absReg m) i8)] ir (IR.MT t (IR.EAt (IR.AP m Nothing _)))               = pure [MovRA () (absReg t) (R$absReg m)] ir (IR.MX t (IR.FAt (IR.AP m Nothing _ )))              = pure [MovqXA () (fabsReg t) (R (absReg m))]@@ -315,7 +315,7 @@ mSse Op.FTimes = Just Vmulsd mSse Op.FExp   = Nothing -feval :: IR.FExp -> IR.FTemp -> WM [X86 AbsReg FAbsReg ()] -- TODO: feval 0 (xor?)+feval :: IR.FExp -> IR.FTemp -> WM [X86 AbsReg FAbsReg X2Abs ()] -- TODO: feval 0 (xor?) feval (IR.FB Op.FDiv (IR.FReg r0) (IR.FReg r1)) t   | t == r0 = pure [Divsd () (fabsReg t) (fabsReg r1)] feval (IR.FB Op.FTimes (IR.FReg r0) (IR.FReg r1)) t | t == r0 = pure [Mulsd () (fabsReg t) (fabsReg r1)] feval (IR.FB Op.FMinus (IR.FReg r0) (IR.FReg r1)) t | t == r0 = pure [Subsd () (fabsReg t) (fabsReg r1)]@@ -376,7 +376,7 @@     pure $ plE ++ [MovqXA () (fabsReg rD) (RS (absReg m) Eight (IReg i))] feval e _                                           = error (show e) -evalE :: IR.Exp -> IR.Temp -> WM [X86 AbsReg FAbsReg ()]+evalE :: IR.Exp -> IR.Temp -> WM [X86 AbsReg FAbsReg X2Abs ()] evalE (IR.Reg r) rD                                  = pure [MovRR () (absReg rD) (absReg r)] evalE (IR.ConstI 0) rD                               = pure [XorRR () (absReg rD) (absReg rD)] evalE (IR.ConstI i) rD                               = pure [MovRI () (absReg rD) i]

@@ -1,10 +1,11 @@ {-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}  -- first IR with for loops and array accesses, inspired by C-module C ( Temp (..), FTemp (..), BTemp (..)+module C ( Temp (..), FTemp (..), F2Temp (..), BTemp (..)          , ArrAcc (..)-         , CE (..), CFE (..)+         , CE (..), CFE (..), F1E, F2E          , PE (..)          , CS (..)          , (=:)@@ -18,6 +19,7 @@ import           Data.Copointed import           Data.Int          (Int64) import qualified Data.IntMap       as IM+import           Data.Void         (Void) import           Data.Word         (Word64) import           Op import           Prettyprinter     (Doc, Pretty (..), brackets, comma, dot, hardline, indent, lbrace, parens, rbrace, tupled, (<+>))@@ -33,6 +35,8 @@ data FTemp = FTemp !Int            | F0 | F1 | F2 | F3 | F4 | F5 | FRet0 | FRet1 deriving Eq +data F2Temp = F2Temp !Int+ instance Pretty BTemp where pretty (BTemp i) = "P" <> pretty i; pretty CBRet = "PRet"  instance Pretty Temp where@@ -46,6 +50,9 @@     pretty C5        = "CArg5"     pretty CRet      = "CRet" +instance Pretty F2Temp where+    pretty (F2Temp i) = "Y" <> pretty i+ instance Pretty FTemp where     pretty (FTemp i) = "X" <> pretty i     pretty F0        = "FArg0"@@ -84,7 +91,7 @@ mPrec IPlus=Just 6;mPrec ITimes=Just 7;mPrec IMinus=Just 6;mPrec IDiv=Nothing;mPrec IRem=Nothing;mPrec IAsl=Nothing; mPrec IMax=Nothing; mPrec IMin=Nothing; mPrec IAsr=Nothing; mPrec (BI p) = Just$bPrec p fprec FPlus=Just 6;fprec FMinus=Just 6;fprec FTimes=Just 7; fprec FDiv=Just 7; fprec FExp=Just 8; fprec FMax=Nothing; fprec FMin=Nothing -data CE = EAt ArrAcc | Bin IBin CE CE | Tmp Temp | ConstI !Int64 | CFloor CFE+data CE = EAt ArrAcc | Bin IBin CE CE | Tmp Temp | ConstI !Int64 | CFloor (CFE FTemp Double CE)         | LA !Int -- assembler data         | DP Temp CE -- pointer, rank @@ -105,18 +112,20 @@ instance Num CE where     (+) = Bin IPlus; (*) = Bin ITimes; (-) = Bin IMinus; fromInteger=ConstI . fromInteger -data CFE = FAt ArrAcc | FBin FBin CFE CFE | FUn FUn CFE | FTmp FTemp | ConstF !Double | IE CE+type F1E=CFE FTemp Double CE; type F2E=CFE F2Temp (Double, Double) Void -instance Num CFE where+data CFE t x e = FAt ArrAcc | FBin FBin (CFE t x e) (CFE t x e) | FUn FUn (CFE t x e) | FTmp t | ConstF !x | IE e++instance Num (CFE t Double e) where     (+) = FBin FPlus; (*) = FBin FTimes; (-) = FBin FMinus; fromInteger=ConstF . fromInteger -instance Fractional CFE where+instance Fractional (CFE t Double e) where     (/) = FBin FDiv; fromRational=ConstF . fromRational -instance Pretty CFE where pretty=ps 0+instance (Pretty x, PS e, Pretty t, Pretty e) => Pretty (CFE t x e) where pretty=ps 0  data PE = IRel IRel CE CE-        | FRel FRel CFE CFE+        | FRel FRel (CFE FTemp Double CE) (CFE FTemp Double CE)         | Boo BBin PE PE         | BConst Bool         | IUn IUn CE@@ -135,7 +144,7 @@     pretty (Boo op e0 e1)   = pretty e0 <+> pretty op <+> pretty e1     pretty (BU op e)        = pretty op <> pretty e -instance PS CFE where+instance (Pretty x, Pretty e, Pretty t, PS e) => PS (CFE t x e) where     ps _ (FAt a)         = pretty a     ps _ (FUn f e)       = parens (pretty f <+> pretty e)     ps d (FBin op x0 x1) | Just d' <- fprec op = parensp (d>d') (ps (d'+1) x0 <+> pretty op <+> ps (d'+1) x1)@@ -144,7 +153,7 @@     ps _ (ConstF x)      = pretty x     ps d (IE e)          = parensp (d>10) ("itof" <+> ps 11 e) -instance Show CFE where show=show.pretty+instance (Pretty x, PS e, Pretty t, Pretty e) => Show (CFE t x e) where show=show.pretty  infix 9 =: @@ -153,11 +162,14 @@ data CS a = For { lann :: a, ixVar :: Temp, eLow :: CE, loopCond :: IRel, eUpper :: CE, body :: [CS a] }           | For1 { lann :: a, ixVar :: Temp, eLow :: CE, loopCond :: IRel, eUpper :: CE, body :: [CS a] }           | While { lann :: a, iVar :: Temp, loopCond :: IRel, eDone :: CE, body :: [CS a] }+          | WT { lann :: a, bE :: PE, body :: [CS a] }           | MT { lann :: a, tDest :: Temp, tSrc :: CE }-          | MX { lann :: a, ftDest :: FTemp, ftSrc :: CFE }+          | MX { lann :: a, ftDest :: FTemp, ftSrc :: CFE FTemp Double CE }+          | MX2 { lann :: a, f2tDest :: F2Temp, f2tSrc :: CFE F2Temp (Double, Double) Void }           | MB { lann :: a, bDest :: BTemp, pSrc :: PE }           | Wr { lann :: a, addr :: ArrAcc, wrE :: CE }-          | WrF { lann :: a, addr :: ArrAcc, wrF :: CFE }+          | WrF { lann :: a, addr :: ArrAcc, wrF :: CFE FTemp Double CE }+          | Wr2F { lann :: a, addr :: ArrAcc, wrF2 :: CFE F2Temp (Double, Double) Void }           | WrP { lann :: a, addr :: ArrAcc , wrB :: PE }           | Ma { lann :: a, label :: AL, temp :: Temp, rank :: CE, nElem :: CE, elemSz :: !Int64 }           | Free Temp@@ -170,7 +182,7 @@           | Sa { lann :: a, temp :: Temp, allocBytes :: CE }           | Pop { lann :: a, aBytes :: CE }           | Cmov { lann :: a, scond :: PE, tdest :: Temp, src :: CE }-          | Fcmov { lann :: a, scond :: PE, fdest :: FTemp, fsrc :: CFE }+          | Fcmov { lann :: a, scond :: PE, fdest :: FTemp, fsrc :: CFE FTemp Double CE }           -- TODO: Fcneg?           | Cset { lann :: a, scond :: PE, bdest :: BTemp }           | SZ { lann :: a, szDest :: Temp, arr :: Temp, rank :: CE, mLabel :: Maybe AL }@@ -201,6 +213,7 @@ pL f (For l t el rel eu ss) = "for" <> parens (pretty t <> comma <+> pretty t <> "≔" <> pretty el <> comma <+> pretty t <> pretty rel <> pretty eu) <+> lbrace <#> indent 4 (pCS f ss) <#> rbrace <> f l pL f (For1 l t el rel eu ss) = "for-1" <> parens (pretty t <> comma <+> pretty t <> "≔" <> pretty el <> comma <+> pretty t <> pretty rel <> pretty eu) <+> lbrace <#> indent 4 (pCS f ss) <#> rbrace <> f l pL f (While l t rel eb ss)  = "while" <> parens (pretty t <> pretty rel <> pretty eb) <+> lbrace <#> indent 4 (pCS f ss) <#> rbrace <> f l+pL f (WT l p ss)            = "while" <> parens (pretty p) <+> lbrace <#> indent 4 (pCS f ss) <#> rbrace <> f l pL f (Ifn't l p s)          = "ifn't" <+> parens (pretty p) <+> lbrace <#> indent 4 (pCS f s) <#> rbrace <> f l pL f (If l p s0 s1)         = "if" <+> parens (pretty p) <+> lbrace <#> indent 4 (pCS f s0) <#> rbrace <+> "else" <+> lbrace <#> indent 4 (pCS f s1) <#> rbrace <> f l pL _ RA{}                   = mempty

@@ -66,6 +66,7 @@     go (For ann _ _ _ _ ss:cs)  = (node ann, (ann, emptyL)):go ss++go cs     go (For1 ann _ _ _ _ ss:cs) = (node ann, (ann, emptyL)):go ss++go cs     go (While ann _ _ _ ss:cs)  = (node ann, (ann, emptyL)):go ss++go cs+    go (WT ann _ ss:cs)         = (node ann, (ann, emptyL)):go ss++go cs     go (If ann _ ss ss':cs)     = (node ann, (ann, emptyL)):go ss++go ss'++go cs     go (Ifn't ann _ ss:cs)      = (node ann, (ann, emptyL)):go ss++go cs     go (Def ann _ ss:cs)        = (node ann, (ann, emptyL)):go ss++go cs@@ -75,6 +76,7 @@ inspectOrder (For ann _ _ _ _ ss:cs)  = node ann:inspectOrder ss++inspectOrder cs inspectOrder (For1 ann _ _ _ _ ss:cs) = node ann:inspectOrder ss++inspectOrder cs inspectOrder (While ann _ _ _ ss:cs)  = node ann:inspectOrder ss++inspectOrder cs+inspectOrder (WT ann _ ss:cs)         = node ann:inspectOrder ss++inspectOrder cs inspectOrder (If ann _ ss ss':cs)     = node ann:inspectOrder ss++inspectOrder ss'++inspectOrder cs inspectOrder (Ifn't ann _ ss:cs)      = node ann:inspectOrder ss++inspectOrder cs inspectOrder (Def ann _ ss:cs)        = node ann:inspectOrder ss++inspectOrder cs@@ -150,6 +152,13 @@     pure $ While (ControlAnn i (f (h [])) udϵ) t c ed ss':stmts'   where     udϵ = UD (uE ed) IS.empty IS.empty IS.empty+addCF ((WT _ t ss):stmts) = do+    i <- getFresh+    (f, stmts') <- next stmts+    (h, ss') <- tieBody i f ss+    pure $ WT (ControlAnn i (f (h [])) udϵ) t ss':stmts'+  where+    udϵ = UD IS.empty IS.empty IS.empty IS.empty addCF (If _ p b0 b1:stmts) = do     i <- getFresh     (f, stmts') <- next stmts@@ -180,7 +189,7 @@ uE (CFloor e0)   = uF e0 uE (DP _ e)      = uE e -uF :: CFE -> IS.IntSet+uF :: CFE FTemp x CE -> IS.IntSet uF ConstF{}       = IS.empty uF FTmp{}         = IS.empty uF (FAt a)        = uA a@@ -253,6 +262,7 @@ brs (For _ _ _ _ _ ss:stmts)  = brs ss *> brs stmts brs (For1 _ _ _ _ _ ss:stmts) = brs ss *> brs stmts brs (While _ _ _ _ ss:stmts)  = brs ss *> brs stmts+brs (WT _ _ ss:stmts)         = brs ss *> brs stmts brs (If _ _ ss ss':stmts)     = brs ss *> brs ss' *> brs stmts brs (Ifn't _ _ ss:stmts)      = brs ss *> brs stmts brs (_:asms)                  = brs asms

@@ -30,23 +30,24 @@                , vars        :: IM.IntMap Temp -- track vars so that (Var x) can be replaced at the site                , pvars       :: IM.IntMap BTemp                , dvars       :: IM.IntMap FTemp+               , d2vars      :: IM.IntMap F2Temp                , avars       :: IM.IntMap (Maybe AL, Temp)-               , fvars       :: IM.IntMap (Label, [Arg], Either FTemp Temp)+               , fvars       :: IM.IntMap (Label, [Arg], RT)                , _aa         :: AsmData                , mts         :: IM.IntMap Temp                }  nextI :: CM Int-nextI = state (\(CSt tϵ ar as l v b d a f aas ts) -> (tϵ, CSt (tϵ+1) ar as l v b d a f aas ts))+nextI = state (\(CSt tϵ ar as l v b d d2 a f aas ts) -> (tϵ, CSt (tϵ+1) ar as l v b d d2 a f aas ts))  nextArr :: Temp -> CM AL-nextArr r = state (\(CSt t a@(AL i) as l v b d aϵ f aas ts) -> (a, CSt t (AL$i+1) as l v b d aϵ f aas (AL.insert a r ts)))+nextArr r = state (\(CSt t a@(AL i) as l v b d d2 aϵ f aas ts) -> (a, CSt t (AL$i+1) as l v b d d2 aϵ f aas (AL.insert a r ts)))  nextAA :: CM Int-nextAA = state (\(CSt t ar as l v b d a f aas ts) -> (as, CSt t ar (as+1) l v b d a f aas ts))+nextAA = state (\(CSt t ar as l v b d d2 a f aas ts) -> (as, CSt t ar (as+1) l v b d d2 a f aas ts))  neL :: CM Label-neL = state (\(CSt t ar as l v b d a f aas ts) -> (l, CSt t ar as (l+1) v b d a f aas ts))+neL = state (\(CSt t ar as l v b d d2 a f aas ts) -> (l, CSt t ar as (l+1) v b d d2 a f aas ts))  nBT :: CM BTemp nBT = BTemp<$>nextI@@ -57,23 +58,38 @@ newFTemp :: CM FTemp newFTemp = FTemp <$> nextI +newF2Temp :: CM F2Temp+newF2Temp = F2Temp <$> nextI+ addAA :: Int -> [Word64] -> CSt -> CSt-addAA i aa (CSt t ar as l v b d a f aas ts) = CSt t ar as l v b d a f (IM.insert i aa aas) ts+addAA i aa (CSt t ar as l v b d d2 a f aas ts) = CSt t ar as l v b d d2 a f (IM.insert i aa aas) ts  addVar :: Nm a -> Temp -> CSt -> CSt-addVar n r (CSt t ar as l v b d a f aas ts) = CSt t ar as l (insert n r v) b d a f aas ts+addVar n r (CSt t ar as l v b d d2 a f aas ts) = CSt t ar as l (insert n r v) b d d2 a f aas ts  addD :: Nm a -> FTemp -> CSt -> CSt-addD n r (CSt t ar as l v b d a f aas ts) = CSt t ar as l v b (insert n r d) a f aas ts+addD n r (CSt t ar as l v b d d2 a f aas ts) = CSt t ar as l v b (insert n r d) d2 a f aas ts +bI :: Nm a -> CM Temp+bI n = state (\(CSt t ar as l v b d d2 a f aas ts) -> let r=ITemp t in (r, CSt (t+1) ar as l (insert n r v) b d d2 a f aas ts))++bD :: Nm a -> CM FTemp+bD n = state (\(CSt t ar as l v b d d2 a f aas ts) -> let r=FTemp t in (r, CSt (t+1) ar as l v b (insert n r d) d2 a f aas ts))++bB :: Nm a -> CM BTemp+bB n = state (\(CSt t ar as l v b d d2 a f aas ts) -> let r=BTemp t in (r, CSt (t+1) ar as l v (insert n r b) d d2 a f aas ts))++addD2 :: Nm a -> F2Temp -> CSt -> CSt+addD2 n r (CSt t ar as l v b d d2 a f aas ts) = CSt t ar as l v b d (insert n r d2) a f aas ts+ addB :: Nm a -> BTemp -> CSt -> CSt-addB n r (CSt t ar as l v b d a f aas ts) = CSt t ar as l v (insert n r b) d a f aas ts+addB n r (CSt t ar as l v b d d2 a f aas ts) = CSt t ar as l v (insert n r b) d d2 a f aas ts  addAVar :: Nm a -> (Maybe AL, Temp) -> CSt -> CSt-addAVar n r (CSt t ar as l v b d a f aas ts) = CSt t ar as l v b d (insert n r a) f aas ts+addAVar n r (CSt t ar as l v b d d2 a f aas ts) = CSt t ar as l v b d d2 (insert n r a) f aas ts -addF :: Nm a -> (Label, [Arg], Either FTemp Temp) -> CSt -> CSt-addF n f (CSt t ar as l v b d a fs aas ts) = CSt t ar as l v b d a (insert n f fs) aas ts+addF :: Nm a -> (Label, [Arg], RT) -> CSt -> CSt+addF n f (CSt t ar as l v b d d2 a fs aas ts) = CSt t ar as l v b d d2 a (insert n f fs) aas ts  getT :: IM.IntMap b -> Nm a -> b getT st n = findWithDefault (error ("Internal error: variable " ++ show n ++ " not assigned to a temp.")) n st@@ -101,9 +117,6 @@ rel :: Builtin -> Maybe IRel rel Eq=Just IEq; rel Neq=Just INeq; rel Lt=Just ILt; rel Gt=Just IGt; rel Lte=Just ILeq; rel Gte=Just IGeq; rel _=Nothing -mIF :: T a -> Maybe (T a)-mIF (Arr _ F)=Just F; mIF (Arr _ I)=Just I; mIF _=Nothing- mAA :: T a -> Maybe ((T a, Int64), (T a, Int64)) mAA (Arrow t0 t1) = (,) <$> tRnk t0 <*> tRnk t1 mAA _             = Nothing@@ -114,15 +127,18 @@ bT :: Integral b => T a -> b bT (P ts)=sum (bT<$>ts); bT F=8; bT I=8; bT B=1; bT Arr{}=8 -bSz, rSz, nSz :: Integral b => T a -> Maybe b-bSz (P ts)=sum<$>traverse bSz ts; bSz F=Just 8; bSz I=Just 8; bSz B=Just 1; bSz _=Nothing+rSz, nSz :: Integral b => T a -> Maybe b rSz F=Just 8; rSz I=Just 8; rSz B=Just 1; rSz _=Nothing nSz F=Just 8; nSz I=Just 8; nSz B=Just 1; nSz (P ts)=sum<$>traverse nSz ts; nSz _=Nothing  aB :: Integral b => T a -> Maybe b aB (Arr (_ `Cons` Nil) t) = nSz t; aB _ = Nothing aRr (Arr (_ `Cons` Nil) t) = rr t; aRr _ = Nothing+aN (Arr _ t) = nt t; aN _=Nothing +nt :: T a -> Maybe (T a)+nt I=Just I; nt F=Just F; nt B=Just B; nt t@P{} = Just t; nt _=Nothing+ rr :: Integral b => T a -> Maybe (T a, b) rr I=Just (I,8); rr F=Just (F,8); rr B=Just (B,1); rr _=Nothing @@ -193,7 +209,7 @@ mIFs = fmap concat.traverse mIFϵ where mIFϵ (FLit _ d)=Just [castDoubleToWord64 d]; mIFϵ (ILit _ n)=Just [fromIntegral n]; mIFϵ (Tup _ xs)=mIFs xs; mIFϵ _=Nothing  writeC :: E (T ()) -> ([CS ()], LSt, AsmData, IM.IntMap Temp)-writeC = π.flip runState (CSt 0 (AL 0) 0 0 IM.empty IM.empty IM.empty IM.empty IM.empty IM.empty IM.empty) . writeCM . fmap rLi where π (s, CSt t _ _ l _ _ _ _ _ aa a) = (s, LSt l t, aa, a)+writeC = π.flip runState (CSt 0 (AL 0) 0 0 IM.empty IM.empty IM.empty IM.empty IM.empty IM.empty IM.empty IM.empty) . writeCM . fmap rLi where π (s, CSt t _ _ l _ _ _ _ _ _ aa a) = (s, LSt l t, aa, a)  writeCM :: E (T ()) -> CM [CS ()] writeCM eϵ = do@@ -278,7 +294,7 @@ writeRF e args = fmap snd.writeF e (ra<$>args)  data Arg = IPA !Temp | FA !FTemp | AA !Temp (Maybe AL) | BA !BTemp-data RT = IT Temp | FT FTemp | PT BTemp+data RT = IT !Temp | FT !FTemp | PT !BTemp  mt :: ArrAcc -> RT -> CS () mt p (IT t) = t =: EAt p@@ -291,6 +307,7 @@ wt p (PT t) = WrP () p (Is t)  ra (FT f)=FA f; ra (IT r)=IPA r; ra (PT r)=BA r+art (IPA r)=IT r;art (FA r)=FT r; art (BA r)=PT r  eeval :: E (T ()) -> RT -> CM [CS ()] eeval e (IT t) = eval e t@@ -332,34 +349,61 @@     g t b            = (:[]) . For () t 0 ILt b  -- the resulting expressions/statement contain free variables that will be iterated over in the main rank-ification loop, these free variables are returned alongside-extrCell :: [Cell () Temp] -> [Temp] -> (Temp, Maybe AL) -> Temp -> CM ([Temp], [CS ()])-extrCell fixBounds sstrides (srcP, srcL) dest = do+extrCell :: Int64 -> [Cell () Temp] -> [Temp] -> (Temp, Maybe AL) -> Temp -> CM ([Temp], [CS ()])+extrCell sz fixBounds sstrides (srcP, srcL) dest = do     (dims, ts, arrIxes, complts) <- switch fixBounds     t <- newITemp; i <- newITemp     pure (complts, (i =: 0:) $ forAll ts (Tmp<$>dims)-        [t =: EAt (At srcP (Tmp<$>sstrides) (Tmp<$>arrIxes) srcL 8), Wr () (Raw dest (Tmp i) Nothing 8) (Tmp t), i+=1])+        [t =: EAt (At srcP (Tmp<$>sstrides) (Tmp<$>arrIxes) srcL sz), Wr () (Raw dest (Tmp i) Nothing sz) (Tmp t), i+=1])     where switch (Bound d:ds) = do {t <- newITemp; qmap (d:) (t:) (t:) id <$> switch ds}           switch (Fixed:ds)   = do {f <- newITemp; qmap id id (f:) (f:) <$> switch ds}           switch []           = pure ([], [], [], []) +vslop :: Int64 -> Int -> CM (Temp, [CS ()], CS ())+vslop sz n = do+    slopP <- newITemp+    pure (slopP, [Sa () slopP szSlop, Wr () (ARnk slopP Nothing) 1, Wr () (ADim slopP 0 Nothing) (fromIntegral n)], Pop () szSlop)+  where+    szSlop=ConstI$16+fromIntegral n*sz++plSlop :: Int64 -> Int64 -> [CE] -> CM (Temp, Temp, [CS ()], CS ())+plSlop sz slopRnk complDims = do+    slopP <- newITemp; slopSz <- newITemp; slopE <- newITemp+    pure (slopP, slopSz,+            PlProd () slopSz complDims+                :slopE=:(Tmp slopSz*ConstI sz+ConstI (8*(slopRnk+1)))+                :Sa () slopP (Tmp slopE):Wr () (ARnk slopP Nothing) (ConstI slopRnk)+                :diml (slopP, Nothing) complDims,+         Pop () (Tmp slopE))++codT :: T () -> T ()+codT (Arrow _ t@Arrow{}) = codT t+codT (Arrow _ t)         = t++r00 :: E (T ()) -> Maybe (E (T ()), [E (T ())])+r00 (EApp _ (Builtin _ (Rank is)) f) | all ((==0).fst) is = Just (f, [])+r00 (EApp _ f e) | Arr{} <- eAnn e = second (e:) <$> r00 f+r00 _ = Nothing+ llet :: (Nm (T ()), E (T ())) -> CM [CS ()] llet (n,e') | isArr (eAnn e') = do     eR <- newITemp     (l, ss) <- aeval e' eR     modify (addAVar n (l,eR)) $> ss llet (n,e') | isI (eAnn e') = do-    eR <- newITemp-    ss <- eval e' eR-    modify (addVar n eR) $> ss+    eR <- bI n+    eval e' eR llet (n,e') | isF (eAnn e') = do-    eR <- newFTemp-    ss <- feval e' eR-    modify (addD n eR) $> ss-llet (n,e') | Arrow F F <- eAnn e' = do+    eR <- bD n+    feval e' eR+llet (n,e') | isB (eAnn e') = do+    eR <- bB n+    peval e' eR+llet (n,e') | Arrow tD tC <- eAnn e', isR tD && isR tC = do     l <- neL-    x <- newFTemp; y <- newFTemp-    (_, ss) <- writeF e' [FA x] (FT y)-    modify (addF n (l, [FA x], Left y))+    x <- rtemp tD; y <- rtemp tC+    (_, ss) <- writeF e' [ra x] y+    modify (addF n (l, [ra x], y))     pure [C.Def () l ss]  aeval :: E (T ()) -> Temp -> CM (Maybe AL, [CS ()])@@ -418,9 +462,55 @@     (plX, (lX, xR)) <- plA xs     xRnk <- newITemp; szR <- newITemp; rnk <- newITemp     a <- nextArr t+    td <- newITemp; xRd <- newITemp     pure (Just a,             plX$xRnk=:eRnk sh (xR,lX):SZ () szR xR (Tmp xRnk) lX:rnk =: (Tmp xRnk+1):Ma () a t (Tmp rnk) (Tmp szR) sz:-           [Wr () (ADim t 0 (Just a)) 1, CpyD () (ADim t 1 (Just a)) (ADim xR 0 lX) (Tmp xRnk), CpyE () (AElem t (Tmp rnk) 0 (Just a) sz) (AElem xR (Tmp xRnk) 0 lX sz) (Tmp szR) sz])+           [Wr () (ADim t 0 (Just a)) 1, CpyD () (ADim t 1 (Just a)) (ADim xR 0 lX) (Tmp xRnk), td=:DP t (Tmp rnk), xRd=:DP xR (Tmp xRnk), CpyE () (Raw td 0 (Just a) sz) (Raw xRd 0 lX sz) (Tmp szR) sz])+aeval (EApp oTy (Builtin _ Init) x) t | Just sz <- aB oTy = do+    nR <- newITemp+    (a,aV) <- vSz t (Tmp nR) sz+    (plX, (lX, xR)) <- plA x+    pure (Just a, plX$nR =: (ev (eAnn x) (xR,lX)-1):aV++[CpyE () (AElem t 1 0 (Just a) sz) (AElem xR 1 0 lX sz) (Tmp nR) sz])+aeval (EApp oTy (Builtin _ InitM) x) t | Just sz <- aB oTy = do+    nR <- newITemp+    (a,aV) <- vSz t (Bin IMax (Tmp nR) 0) sz+    (plX, (lX, xR)) <- plA x+    pure (Just a,+        plX$+        nR =: (ev (eAnn x) (xR,lX)-1)+        :aV++[CpyE () (AElem t 1 0 (Just a) sz) (AElem xR 1 0 lX sz) (Tmp nR) sz])+aeval (EApp oTy (Builtin _ Tail) x) t | Just sz <- aB oTy = do+    nR <- newITemp+    (a,aV) <- vSz t (Tmp nR) sz+    (plX, (lX, xR)) <- plA x+    pure (Just a, plX$nR =: (ev (eAnn x) (xR,lX)-1):aV++[CpyE () (AElem t 1 0 (Just a) sz) (AElem xR 1 1 lX sz) (Tmp nR) sz])+aeval (EApp _ (Builtin _ Head) xs) t | Just (tX, xRnk) <- tRnk (eAnn xs), Just sz <- nSz tX = do+    a <- nextArr t+    (plX, (lX, xR)) <- plA xs+    (dts, plDs) <- plDim xRnk (xR, lX)+    szA <- newITemp+    pure (Just a, plX$tail plDs++PlProd () szA (Tmp<$>tail dts):Ma () a t 1 (Tmp szA) sz:CpyD () (ADim t 0 (Just a)) (ADim xR 1 lX) (ConstI$xRnk-1):[CpyE () (AElem t 1 0 (Just a) sz) (AElem xR (ConstI xRnk) 0 lX sz) (Tmp szA) sz])+aeval (EApp _ (Builtin _ Last) xs) t | Just (tX, xRnk) <- tRnk (eAnn xs), Just sz <- nSz tX = do+    a <- nextArr t+    (plX, (lX, xR)) <- plA xs+    (dts, plDs) <- plDim xRnk (xR, lX)+    let n=head dts+    szA <- newITemp+    pure (Just a, plX$plDs++PlProd () szA (Tmp<$>tail dts):Ma () a t 1 (Tmp szA) sz:CpyD () (ADim t 0 (Just a)) (ADim xR 1 lX) (ConstI$xRnk-1):[CpyE () (AElem t 1 0 (Just a) sz) (AElem xR (ConstI xRnk) ((Tmp n-1)*Tmp szA) lX sz) (Tmp szA) sz])+aeval (EApp _ (Builtin _ Tail) xs) t | Just (tX, xRnk) <- tRnk (eAnn xs), Just sz <- nSz tX = do+    a <- nextArr t+    (plX, (lX, xR)) <- plA xs+    (dts, plDs) <- plDim xRnk (xR, lX)+    let n=head dts; rnkE=ConstI xRnk+    szA <- newITemp; szz <- newITemp; d1 <- newITemp+    pure (Just a, plX$plDs++PlProd () szz (Tmp<$>tail dts):d1=:(Tmp n-1):szA=:(Tmp szz*Tmp d1):Ma () a t rnkE (Tmp szA) sz:Wr () (ADim t 0 (Just a)) (Tmp d1):CpyD () (ADim t 1 (Just a)) (ADim xR 1 lX) (ConstI$xRnk-1):[CpyE () (AElem t rnkE 0 (Just a) sz) (AElem xR rnkE (Tmp szz) lX sz) (Tmp szA) sz])+aeval (EApp _ (Builtin _ Init) xs) t | Just (tX, xRnk) <- tRnk (eAnn xs), Just sz <- nSz tX = do+    a <- nextArr t+    (plX, (lX, xR)) <- plA xs+    (dts, plDs) <- plDim xRnk (xR, lX)+    let n=head dts; rnkE=ConstI xRnk+    szA <- newITemp; d1 <- newITemp+    pure (Just a, plX$plDs++d1=:(Tmp n-1):PlProd () szA (Tmp<$>d1:tail dts):Ma () a t rnkE (Tmp szA) sz:Wr () (ADim t 0 (Just a)) (Tmp d1):CpyD () (ADim t 1 (Just a)) (ADim xR 1 lX) (ConstI$xRnk-1):[CpyE () (AElem t rnkE 0 (Just a) sz) (AElem xR rnkE 0 lX sz) (Tmp szA) sz]) aeval (EApp _ (Builtin _ Flat) xs) t | (Arr sh ty) <- eAnn xs, Just sz <- nSz ty = do     (plX, (lX, xR)) <- plA xs     xRnk <- newITemp; szR <- newITemp@@ -432,10 +522,7 @@     (a,aV) <- vSz t (Tmp szR) sz     (step, pinches) <- aS op [(tD, AElem xR 1 (Tmp iR) l)] tC (AElem t 1 (Tmp iR) (Just a))     let loop=for (eAnn e) iR 0 ILt (Tmp szR) step-    pure (Just a,-        plE$-        szR=:ev (eAnn e) (xR,l):aV-        ++sas pinches [loop])+    pure (Just a, plE$szR=:ev (eAnn e) (xR,l):aV++sas pinches [loop]) aeval (EApp _ (EApp _ (Builtin _ Filt) p) xs) t | tXs@(Arr (_ `Cons` Nil) tX) <- eAnn xs, Just sz <- nSz tX = do     a <- nextArr t     szR <- newITemp; nR <- newITemp; b <- nBT@@ -467,69 +554,66 @@         szR=:ev tXs (xsR,lX)         :Ma () a t 1 (Tmp szR) 8         :m'p pinch [nR=:0, loop, Wr () (ADim t 0 (Just a)) (Tmp nR)])-aeval (EApp _ (EApp _ (Builtin _ Map) f) xs) t | (Arrow tD tC) <- eAnn f, Just (_, xRnk) <- tRnk (eAnn xs), Just (ta, rnk) <- tRnk tD, Just szD <- bSz ta, Just sz <- bSz tC = do+aeval (EApp _ (EApp _ (Builtin _ Map) f) xs) t | (Arrow tD tC) <- eAnn f, Just (_, xRnk) <- tRnk (eAnn xs), Just (ta, rnk) <- tRnk tD, Just szD <- nSz ta, Just sz <- nSz tC = do     a <- nextArr t-    slopP <- newITemp; szR <- newITemp; slopSz <- newITemp-    xd <- newITemp; i <- newITemp; k <- newITemp+    szR <- newITemp; xd <- newITemp; i <- newITemp; k <- newITemp     (plX, (lX, xR)) <- plA xs+    let slopDims=[EAt (ADim xR (ConstI l) lX) | l <- [rnk..(xRnk-1)]]+    (slopP, slopSz, aSlop, pops) <- plSlop szD rnk slopDims     (y, wRet, pinch) <- rW tC (AElem t 1 (Tmp k) (Just a) sz)     (_, ss) <- writeF f [AA slopP Nothing] y-    let slopDims=[EAt (ADim xR (ConstI l) lX) | l <- [rnk..(xRnk-1)]]-        xDims=[EAt (ADim xR (ConstI l) lX) | l <- [0..(rnk-1)]]-        slopE=Tmp slopSz*ConstI szD+fromIntegral (8+8*rnk)+    let xDims=[EAt (ADim xR (ConstI l) lX) | l <- [0..(rnk-1)]]         dimsFromIn=ConstI$xRnk-rnk         oRnk=xRnk-rnk         step=CpyE () (AElem slopP (ConstI rnk) 0 Nothing szD) (Raw xd (Tmp i) lX szD) (Tmp slopSz) szD:ss++[wRet, i+=Tmp slopSz]     pure (Just a,         plX$-        PlProd () slopSz slopDims:Sa () slopP slopE:diml (slopP, Nothing) slopDims+        aSlop         ++PlProd () szR xDims         :Ma () a t (ConstI oRnk) (Tmp szR) sz             :CpyD () (ADim t 0 (Just a)) (ADim xR 0 lX) dimsFromIn         :xd=:DP xR (ConstI xRnk):i=:0         :m'p pinch-            (fors (eAnn xs) k 0 ILt (Tmp szR) step:[Pop () slopE]))-aeval (EApp _ (EApp _ (Builtin _ Map) f) xs) t | (Arrow tD tC) <- eAnn f, Just (_, xRnk) <- tRnk (eAnn xs), Just (ta, rnk) <- tRnk tC, Just szO <- bSz ta, isIF tD = do+            (fors (eAnn xs) k 0 ILt (Tmp szR) step:[pops]))+aeval (EApp _ (EApp _ (Builtin _ Map) f) xs) t | (Arrow tD tC) <- eAnn f, Just (_, xRnk) <- tRnk (eAnn xs), Just (ta, rnk) <- tRnk tC, Just szO <- nSz ta, Just dSz <- nSz tD = do     a <- nextArr t-    x <- rtemp tD; y <- newITemp; y0 <- newITemp; szX <- newITemp; szY <- newITemp+    y <- newITemp; y0 <- newITemp; szX <- newITemp; szY <- newITemp     j <- newITemp; k <- newITemp; td <- newITemp; yd <- newITemp     (plX, (lX, xR)) <- plA xs-    (lY0, ss0) <- writeF f [ra x] (IT y0)+    (x0, wX0, pinch0) <- arg tD (AElem xR (ConstI xRnk) 0 lX dSz)+    (x, wX, pinch) <- arg tD (AElem xR (ConstI xRnk) (Tmp k) lX dSz)+    (lY0, ss0) <- writeF f [ra x0] (IT y0)     (lY, ss) <- writeF f [ra x] (IT y)     let xDims=[EAt (ADim xR (ConstI l) lX) | l <- [0..(xRnk-1)]]         yDims=[EAt (ADim y0 (ConstI l) lY0) | l <- [0..(rnk-1)]]         oRnk=xRnk+rnk-        step=mt (AElem xR (ConstI xRnk) (Tmp k) (Just a) 8) x:ss++[yd=:DP y (ConstI rnk), CpyE () (Raw td (Tmp j) (Just a) szO) (Raw yd 0 lY undefined) (Tmp szY) szO, j+=Tmp szY]+        step=wX:ss++[yd=:DP y (ConstI rnk), CpyE () (Raw td (Tmp j) (Just a) szO) (Raw yd 0 lY undefined) (Tmp szY) szO, j+=Tmp szY]     pure (Just a,-        plX$-        mt (AElem xR (ConstI xRnk) 0 lX 8) x-        :ss0+        plX$m'p pinch0 (wX0:ss0)         ++PlProd () szY yDims         :PlProd () szX xDims         :Ma () a t (ConstI oRnk) (Tmp szX*Tmp szY) szO             :CpyD () (ADim t 0 (Just a)) (ADim xR 0 lX) (ConstI xRnk)             :CpyD () (ADim t (ConstI xRnk) (Just a)) (ADim y0 0 lY0) (ConstI rnk)         :td=:DP t (ConstI$xRnk+rnk)-        :j=:0-          :[fors (eAnn xs) k 0 ILt (Tmp szX) step])-aeval (EApp _ (EApp _ (Builtin _ Map) f) xs) t | tX <- eAnn xs, Just (_, xRnk) <- tRnk tX, Just ((ta0, rnk0), (ta1, rnk1)) <- mAA (eAnn f), Just sz0 <- bSz ta0, Just sz1 <- bSz ta1 = do+        :j=:0:m'p pinch [fors (eAnn xs) k 0 ILt (Tmp szX) step])+aeval (EApp _ (EApp _ (Builtin _ Map) f) xs) t | tX <- eAnn xs, Just (_, xRnk) <- tRnk tX, Just ((ta0, rnk0), (ta1, rnk1)) <- mAA (eAnn f), Just sz0 <- nSz ta0, Just sz1 <- nSz ta1 = do     a <- nextArr t-    slopP <- newITemp; y <- newITemp; y0 <- newITemp-    szR <- newITemp; slopSz <- newITemp; szY <- newITemp+    y <- newITemp; y0 <- newITemp+    szR <- newITemp; szY <- newITemp     i <- newITemp; j <- newITemp; k <- newITemp; kL <- newITemp; xd <- newITemp; td <- newITemp     (plX, (lX, xR)) <- plA xs+    let slopDims=[EAt (ADim xR (ConstI l) lX) | l <- [rnk0..(xRnk-1)]]+    (slopP, slopSz, aSlop, pops) <- plSlop sz1 rnk0 slopDims     (lY0, ss0) <- writeF f [AA slopP Nothing] (IT y0)     (lY, ss) <- writeF f [AA slopP Nothing] (IT y)-    let slopDims=[EAt (ADim xR (ConstI l) lX) | l <- [rnk0..(xRnk-1)]]-        xDims=[EAt (ADim xR (ConstI l) lX) | l <- [0..(rnk0-1)]]+    let xDims=[EAt (ADim xR (ConstI l) lX) | l <- [0..(rnk0-1)]]         yDims=[EAt (ADim y0 (ConstI l) lY0) | l <- [0..(rnk1-1)]]-        slopE=Tmp slopSz*ConstI sz1+fromIntegral (8+8*rnk0)         dimsFromIn=ConstI$xRnk-rnk0         oRnk=xRnk-rnk0+rnk1         step=CpyE () (AElem slopP (ConstI rnk0) 0 Nothing sz0) (Raw xd (Tmp i) lX sz0) (Tmp slopSz) sz0:ss++[CpyE () (Raw td (Tmp j) (Just a) sz1) (AElem y (ConstI rnk1) 0 lY sz1) (Tmp szY) sz1, i+=Tmp slopSz, j+=Tmp szY]     pure (Just a,-        plX$-        PlProd () slopSz slopDims:Sa () slopP slopE:diml (slopP, Nothing) slopDims+        plX$aSlop         ++xd=:DP xR (ConstI xRnk)         :CpyE () (AElem slopP (ConstI rnk0) 0 Nothing sz0) (Raw xd 0 lX sz0) (Tmp slopSz) sz0         :ss0@@ -541,80 +625,107 @@         :PlProd () szY yDims         :PlProd () kL xDims:i =: 0:j =: 0             :fors tX k 0 ILt (Tmp kL) step-        :[Pop () slopE])-aeval (EApp _ (EApp _ (Builtin _ (Rank [(0, _)])) f) xs) t | Arr sh _ <- eAnn xs, (Arrow tX tY) <- eAnn f, Just szY <- nSz tY, nind tX = do+        :[pops])+aeval e t | Just (f, xss) <- r00 e, Just xsTys <- traverse (aN.eAnn) xss, tXs@(Arr sh _) <- eAnn (head xss), tC <- codT (eAnn f), Just szC <- nSz tC = do     a <- nextArr t-    rnkR <- newITemp; szR <- newITemp-    i <- newITemp; xRd <- newITemp; tD <- newITemp-    (plX, (lX, xR)) <- plA xs-    (step, pinches) <- aS f [(tX, Raw xRd (Tmp i) lX)] tY (Raw tD (Tmp i) (Just a))-    let loop=for (eAnn xs) i 0 ILt (Tmp szR) step-    pure (Just a, plX$rnkR =: eRnk sh (xR,lX):SZ () szR xR (Tmp rnkR) lX:Ma () a t (Tmp rnkR) (Tmp szR) szY:CpyD () (ADim t 0 (Just a)) (ADim xR 0 lX) (Tmp rnkR):xRd =: DP xR (Tmp rnkR):tD =: DP t (Tmp rnkR):sas pinches [loop])-aeval (EApp _ (EApp _ (EApp _ (Builtin _ (Rank [(0, _), (0, _)])) op) xs) ys) t | Arr sh _ <- eAnn xs, Arrow tX (Arrow tY tC) <- eAnn op, Just szC <- nSz tC, nind tX && nind tY = do+    xRds <- traverse (\_ -> newITemp) xss; tD <- newITemp+    rnkR <- newITemp; szR <- newITemp; i <- newITemp+    (plXs, (lXs, xRs)) <- second unzip.unzip <$> traverse plA xss+    let xR=head xRs; lX=head lXs+    (step, pinches) <- aS f (reverse$zipWith3 (\tXϵ xRd lXϵ -> (tXϵ, Raw xRd (Tmp i) lXϵ)) xsTys xRds lXs) tC (Raw tD (Tmp i) (Just a))+    let loop=for tXs i 0 ILt (Tmp szR) step+    pure (Just a, thread plXs$rnkR=:eRnk sh (xR,lX):SZ () szR xR (Tmp rnkR) lX:Ma () a t (Tmp rnkR) (Tmp szR) szC:CpyD () (ADim t 0 (Just a)) (ADim xR 0 lX) (Tmp rnkR):zipWith (\xRϵ xRd -> xRd=:DP xRϵ (Tmp rnkR)) xRs xRds++tD=:DP t (Tmp rnkR):sas pinches [loop])+aeval (EApp _ (EApp _ (EApp _ (Builtin _ (Rank [(0, _), (cr, Just ixs)])) op) xs) ys) t | Just (yT, yRnk) <- tRnk (eAnn ys)+                                                                                        , Just (_, xRnk) <- tRnk (eAnn xs)+                                                                                        , Arrow tX (Arrow _ tCod) <- eAnn op+                                                                                        , Just xSz <- nSz tX+                                                                                        , Just (tC, cSz) <- rr tCod+                                                                                        , Just ySz <- nSz yT+                                                                                        = do     a <- nextArr t-    rnkR <- newITemp; szR <- newITemp-    xRd <- newITemp; yRd <- newITemp; tD <- newITemp     (plX, (lX, xR)) <- plA xs; (plY, (lY, yR)) <- plA ys-    i <- newITemp-    (step, pinches) <- aS op [(tX, Raw xRd (Tmp i) lX), (tY, Raw yRd (Tmp i) lY)] tC (Raw tD (Tmp i) (Just a))-    let loop=for (eAnn xs) i 0 ILt (Tmp szR) step-    pure (Just a, plX $ plY $ rnkR =: eRnk sh (xR,lX):SZ () szR xR (Tmp rnkR) lX:Ma () a t (Tmp rnkR) (Tmp szR) szC:CpyD () (ADim t 0 (Just a)) (ADim xR 0 lX) (Tmp rnkR):xRd =: DP xR (Tmp rnkR):yRd =: DP yR (Tmp rnkR):tD =: DP t (Tmp rnkR):sas pinches [loop])+    zR <- rtemp tC+    let ixsIs=IS.fromList ixs; allIx=[ if ix `IS.member` ixsIs then Index() else Cell() | ix <- [1..fromIntegral yRnk] ]+    oSz <- newITemp+    ix <- newITemp+    (dts, dss) <- plDim yRnk (yR, lY)+    (sts, sssϵ) <- offByDim (reverse dts)+    let _:sstrides = sts; sss=init sssϵ+        allDims = zipWith (\ixϵ dt -> case ixϵ of {Cell{} -> Cell dt; Index{} -> Index dt}) allIx dts+        ~(oDims, complDims) = part allDims+        slopRnk=fromIntegral cr::Int64; oRnk=yRnk-slopRnk+    (slopP, _, aSlop, pops) <- plSlop ySz slopRnk (Tmp<$>complDims)+    (x, pAX, pinch) <- arg tX (AElem xR (ConstI xRnk) (Tmp ix) lX xSz)+    (_, ss) <- writeF op [ra x, AA slopP Nothing] zR+    let ecArg = zipWith (\d tt -> case (d,tt) of (dϵ,Index{}) -> Bound dϵ; (_,Cell{}) -> Fixed) dts allIx+    yRd <- newITemp; slopPd <- newITemp+    (complts, place) <- extrCell ySz ecArg sstrides (yRd, lY) slopPd+    let loop=forAll complts (Tmp<$>oDims) $ pAX:place ++ ss ++ [wt (AElem t (ConstI oRnk) (Tmp ix) (Just a) cSz) zR, ix+=1]+    pure (Just a,+        plX$+        plY$+        dss+++        aSlop+        ++[tϵ=:0 | tϵ <- complts]+        ++mt (AElem xR (ConstI xRnk) 0 lX xSz) x+        :sss+        ++yRd=:DP yR (ConstI yRnk):slopPd=:DP slopP (ConstI slopRnk)+        :PlProd () oSz (Tmp<$>oDims)+            :Ma () a t (ConstI oRnk) (Tmp oSz) cSz+            :diml (t, Just a) (Tmp<$>oDims)+        ++ix=:0:m'p pinch loop+        ++[pops]) aeval (EApp _ (EApp _ (EApp _ (Builtin _ (Rank [(0, _), (cr, Just ixs)])) op) xs) ys) t | Just (yT, yRnk) <- tRnk (eAnn ys)                                                                                         , Just (_, xRnk) <- tRnk (eAnn xs)                                                                                         , (Arrow tX (Arrow _ tCod)) <- eAnn op                                                                                         , Just (tC, opRnk) <- tRnk tCod                                                                                         , Just xSz <- nSz tX-                                                                                        , isIF yT && isIF tC = do+                                                                                        , Just cSz <- rSz tC+                                                                                        , Just ySz <- nSz yT = do     a <- nextArr t     zR <- newITemp     (plX, (lX, xR)) <- plA xs; (plY, (lY, yR)) <- plA ys-    slopP <- newITemp     let ixsIs = IS.fromList ixs; allIx = [ if ix `IS.member` ixsIs then Index() else Cell() | ix <- [1..fromIntegral yRnk] ]-    oSz <- newITemp; slopSz <- newITemp; zSz <- newITemp+    oSz <- newITemp; zSz <- newITemp     ix <- newITemp; it <- newITemp-    slopE <- newITemp     (dts, dss) <- plDim yRnk (yR, lY)     (sts, sssϵ) <- offByDim (reverse dts)     let _:sstrides = sts; sss=init sssϵ         allDims = zipWith (\ixϵ dt -> case ixϵ of {Cell{} -> Cell dt; Index{} -> Index dt}) allIx dts         ~(oDims, complDims) = part allDims         slopRnk=fromIntegral cr::Int64; oRnk=yRnk+opRnk-slopRnk+    (slopP, _, aSlop, pops) <- plSlop xSz slopRnk (Tmp<$>complDims)     (x, pAX, pinch) <- arg tX (AElem xR (ConstI xRnk) (Tmp ix) lX xSz)     (lZ, ss) <- writeF op [ra x, AA slopP Nothing] (IT zR)     let ecArg = zipWith (\d tt -> case (d,tt) of (dϵ,Index{}) -> Bound dϵ; (_,Cell{}) -> Fixed) dts allIx     yRd <- newITemp; slopPd <- newITemp-    (complts, place) <- extrCell ecArg sstrides (yRd, lY) slopPd-    let loop=forAll complts (Tmp<$>oDims) $ pAX:place ++ ss ++ [CpyE () (AElem t (ConstI oRnk) (Tmp it) (Just a) 8) (AElem zR (ConstI opRnk) 0 lZ undefined) (Tmp zSz) 8, ix+=1, it+=Tmp zSz]+    (complts, place) <- extrCell ySz ecArg sstrides (yRd, lY) slopPd+    let loop=forAll complts (Tmp<$>oDims) $ pAX:place ++ ss ++ [CpyE () (AElem t (ConstI oRnk) (Tmp it) (Just a) cSz) (AElem zR (ConstI opRnk) 0 lZ undefined) (Tmp zSz) cSz, ix+=1, it+=Tmp zSz]     (dots, doss) <- plDim opRnk (zR, lZ)     pure (Just a,         plX$         plY$         dss-        ++PlProd () slopSz (Tmp<$>complDims)-            :slopE =: Bin IAsl (Tmp slopSz+ConstI (slopRnk+1)) 3-            :Sa () slopP (Tmp slopE):Wr () (ARnk slopP Nothing) (ConstI slopRnk)-            :diml (slopP, Nothing) (Tmp<$>complDims)+        ++aSlop         ++[tϵ=:0 | tϵ <- complts]-        ++mt (AElem xR (ConstI xRnk) 0 lX undefined) x+        ++mt (AElem xR (ConstI xRnk) 0 lX xSz) x         :sss         ++yRd =: DP yR (ConstI yRnk):slopPd =: DP slopP (ConstI slopRnk)         :place-        ++ss-        ++doss+        ++ss++doss         ++PlProd () zSz (Tmp<$>dots)         :PlProd () oSz (Tmp<$>(zSz:oDims))-            :Ma () a t (ConstI oRnk) (Tmp oSz) 8+            :Ma () a t (ConstI oRnk) (Tmp oSz) cSz             :diml (t, Just a) (Tmp<$>(oDims++dots))-        ++ix=:0:it=:0:m'p pinch loop-        ++[Pop () (Tmp slopE)])+        ++ix=:0:it=:0:m'p pinch loop++[pops]) aeval (EApp _ (EApp _ (Builtin _ (Rank [(cr, Just ixs)])) f) xs) t | Just (tA, rnk) <- tRnk (eAnn xs)                                                                     , (Arrow _ tC) <- eAnn f-                                                                    , Just ySz <- nSz tC, isIF tA = do+                                                                    , Just ySz <- nSz tC+                                                                    , Just aSz <- nSz tA = do     a <- nextArr t     (plX, (lX, xR)) <- plA xs-    slopP <- newITemp     let ixsIs = IS.fromList ixs; allIx = [ if ix `IS.member` ixsIs then Index() else Cell() | ix <- [1..fromIntegral rnk] ]-    oSz <- newITemp; slopSz <- newITemp; slopE <- newITemp+    oSz <- newITemp     di <- newITemp     (dts, dss) <- plDim rnk (xR, lX)     (sts, sssϵ) <- offByDim (reverse dts)@@ -622,32 +733,29 @@         allDims = zipWith (\ix dt -> case ix of {Cell{} -> Cell dt; Index{} -> Index dt}) allIx dts         ~(oDims, complDims) = part allDims         oRnk=rnk-fromIntegral cr; slopRnk=fromIntegral cr::Int64+    (slopP, _, aSlop, popS) <- plSlop aSz slopRnk (Tmp<$>complDims)     (y, wY, pinch) <- rW tC (AElem t (ConstI oRnk) (Tmp di) Nothing ySz)     (_, ss) <- writeF f [AA slopP Nothing] y     let ecArg = zipWith (\d tt -> case (d,tt) of (dϵ,Index{}) -> Bound dϵ; (_,Cell{}) -> Fixed) dts allIx     xRd <- newITemp; slopPd <- newITemp-    (complts, place) <- extrCell ecArg sstrides (xRd, lX) slopPd+    (complts, place) <- extrCell aSz ecArg sstrides (xRd, lX) slopPd     let loop=forAll complts (Tmp<$>oDims) $ place ++ ss ++ [wY, di+=1]     pure (Just a,         plX $ dss-        ++PlProd () slopSz (Tmp<$>complDims)-            :slopE =: Bin IAsl (Tmp slopSz+ConstI (slopRnk+1)) 3-            :Sa () slopP (Tmp slopE):Wr () (ARnk slopP Nothing) (ConstI slopRnk)-            :diml (slopP, Nothing) (Tmp<$>complDims)+        ++aSlop         ++PlProd () oSz (Tmp<$>oDims)             :Ma () a t (ConstI oRnk) (Tmp oSz) ySz             :diml (t, Just a) (Tmp<$>oDims)         ++sss         ++xRd =: DP xR (ConstI rnk):slopPd =: DP slopP (ConstI slopRnk):di =: 0:m'p pinch loop-        ++[Pop () (Tmp slopE)])-aeval (EApp tO (EApp _ (Builtin _ (Rank [(cr, Just ixs)])) f) xs) t | Just (tA, xRnk) <- tRnk (eAnn xs)-                                                                    , Just {} <- mIF tO+        ++[popS])+aeval (EApp _ (EApp _ (Builtin _ (Rank [(cr, Just ixs)])) f) xs) t | Just (tA, xRnk) <- tRnk (eAnn xs)                                                                     , (Arrow _ tCod) <- eAnn f-                                                                    , Just (_, opRnk) <- tRnk tCod-                                                                    , isIF tA = do+                                                                    , Just (tC, opRnk) <- tRnk tCod+                                                                    , Just aSz <- nSz tA+                                                                    , Just cSz <- nSz tC = do     a <- nextArr t     (plX, (lX, xR)) <- plA xs-    slopP <- newITemp     let ixIs = IS.fromList ixs; allIx = [ if ix `IS.member` ixIs then Index() else Cell() | ix <- [1..fromIntegral xRnk] ]     yR <- newITemp; ySz <- newITemp     (dts,dss) <- plDim xRnk (xR,lX)@@ -655,35 +763,31 @@     let _:sstrides = sts; sss=init sssϵ         allDims = zipWith (\ix dt -> case ix of {Cell{} -> Cell dt; Index{} -> Index dt}) allIx dts         ~(oDims, complDims) = part allDims-        slopRnk=fromIntegral cr::Int64; oRnk=xRnk+opRnk-slopRnk+        slopRnk=fromIntegral cr::Int64; slopRnkE=ConstI slopRnk; oRnk=xRnk+opRnk-slopRnk+    (slopP, _, aSlop, popS) <- plSlop aSz slopRnk (Tmp<$>complDims)     (lY, ss) <- writeF f [AA slopP Nothing] (IT yR)     let ecArg = zipWith (\d tt -> case (d,tt) of (dϵ,Index{}) -> Bound dϵ; (_,Cell{}) -> Fixed) dts allIx-    xRd <- newITemp; slopPd <- newITemp; slopSz <- newITemp-    slopE <- newITemp; oSz <- newITemp-    (complts, place) <- extrCell ecArg sstrides (xRd, lX) slopPd+    xRd <- newITemp; slopPd <- newITemp+    oSz <- newITemp+    (complts, place) <- extrCell aSz ecArg sstrides (xRd, lX) slopPd     it <- newITemp     let loop=forAll complts (Tmp<$>oDims)-                $ place ++ ss ++ [CpyE () (AElem t (ConstI oRnk) (Tmp it) (Just a) 8) (AElem yR (ConstI opRnk) 0 lY undefined) (Tmp ySz) 8, it+=Tmp ySz]+                $ place ++ ss ++ [CpyE () (AElem t (ConstI oRnk) (Tmp it) (Just a) cSz) (AElem yR (ConstI opRnk) 0 lY undefined) (Tmp ySz) cSz, it+=Tmp ySz]     (dots, doss) <- plDim opRnk (yR, lY)     pure (Just a,-        plX $-        dss-        ++PlProd () slopSz (Tmp<$>complDims)-            :slopE =: Bin IAsl (Tmp slopSz+ConstI (slopRnk+1)) 3-            :Sa () slopP (Tmp slopE):Wr () (ARnk slopP Nothing) (ConstI slopRnk)-            :diml (slopP, Nothing) (Tmp<$>complDims)+        plX $ dss+        ++aSlop         ++[tϵ=:0 | tϵ <- complts]         ++sss-        ++xRd=:DP xR (ConstI xRnk):slopPd=:DP slopP (ConstI slopRnk)+        ++xRd=:DP xR (ConstI xRnk):slopPd=:DP slopP slopRnkE         :place         ++ss         ++doss         ++PlProd () ySz (Tmp<$>dots)         :PlProd () oSz (Tmp<$>(ySz:oDims))-            :Ma () a t (ConstI oRnk) (Tmp oSz) 8+            :Ma () a t (ConstI oRnk) (Tmp oSz) cSz             :diml (t, Just a) (Tmp<$>(oDims++dots))-        ++it=:0:loop-        ++[Pop () (Tmp slopE)]+        ++it=:0:loop++[popS]         ) aeval (EApp _ (EApp _ (Builtin _ CatE) x) y) t | tX <- eAnn x, Just (ty, 1) <- tRnk tX = do     xnR <- newITemp; ynR <- newITemp; tn <- newITemp@@ -707,6 +811,13 @@     let pN=n =: (Bin Op.IDiv (Tmp endR - Tmp startR) (Tmp incrR)+1)         loop=for ty i 0 ILt (Tmp n) [Wr () (AElem t 1 (Tmp i) (Just a) 8) (Tmp startR), startR+=Tmp incrR]     pure (Just a, pStart++pEnd++pIncr++pN:aV++[loop])+aeval (EApp ty (EApp _ (EApp _ (Builtin _ FRange) (FLit _ s)) (FLit _ e)) (ILit _ n)) t = do+    i <- newITemp+    let nE=ConstI$fromIntegral n+    (a,aV) <- v8 t nE+    accR <- newFTemp; incR <- newFTemp+    let loop=for ty i 0 ILt nE [WrF () (AElem t 1 (Tmp i) (Just a) 8) (FTmp accR), MX () accR (FTmp accR+FTmp incR)]+    pure (Just a, aV++MX () accR (ConstF s):MX () incR (ConstF$(e-s)/(realToFrac n-1)):[loop]) aeval (EApp ty (EApp _ (EApp _ (Builtin _ FRange) start) end) steps) t = do     i <- newITemp     startR <- newFTemp; incrR <- newFTemp; n <- newITemp@@ -744,11 +855,12 @@     i <- newITemp; j <- newITemp; m <- newITemp; n <- newITemp; z <- newFTemp     (aL,aV) <- v8 t (Tmp m)     (plAA, (lA, aR)) <- plA a; (plX, (lX, xR)) <- plA x+    aRd <- newITemp; xRd <- newITemp; td <- newITemp     let loop = forc (eAnn a) i 0 ILt (Tmp m)                 [ MX () z 0,                   for tX j 0 ILt (Tmp n)-                      [ MX () z (FTmp z+FAt (AElem aR 2 (Tmp m*Tmp j+Tmp i) lA 8)*FAt (AElem xR 1 (Tmp j) lX 8)) ]-                , WrF () (AElem t 1 (Tmp i) (Just aL) 8) (FTmp z)+                      [ MX () z (FTmp z+FAt (Raw aRd (Tmp m*Tmp j+Tmp i) lA 8)*FAt (Raw xRd (Tmp j) lX 8)) ]+                , WrF () (Raw td (Tmp i) (Just aL) 8) (FTmp z)                 ]     pure (Just aL,         plAA$@@ -756,18 +868,20 @@         m=:ec tA (aR,lA)         :aV         ++n=:ev tX (xR,lX)+        :aRd=:DP aR 2:xRd=:DP xR 1:td=:DP t 1         :[loop])   where     tA=eAnn a; tX=eAnn x aeval (EApp _ (EApp _ (Builtin _ VMul) a) x) t | f1 tX = do     i <- newITemp; j <- newITemp; m <- newITemp; n <- newITemp; z <- newFTemp+    aRd <- newITemp; xRd <- newITemp; td <- newITemp     (aL,aV) <- v8 t (Tmp m)     (plAA, (lA, aR)) <- plA a; (plX, (lX, xR)) <- plA x     let loop = for tA i 0 ILt (Tmp m)                   [ MX () z 0,                     for tX j 0 ILt (Tmp n)-                        [ MX () z (FTmp z+FAt (AElem aR 2 (Tmp n*Tmp i+Tmp j) lA 8)*FAt (AElem xR 1 (Tmp j) lX 8)) ]-                  , WrF () (AElem t 1 (Tmp i) (Just aL) 8) (FTmp z)+                        [ MX () z (FTmp z+FAt (Raw aRd (Tmp n*Tmp i+Tmp j) lA 8)*FAt (Raw xRd (Tmp j) lX 8)) ]+                  , WrF () (Raw td (Tmp i) (Just aL) 8) (FTmp z)                   ]     pure (Just aL,         plAA$@@ -775,46 +889,49 @@         m=:ev tA (aR,lA)         :aV         ++n=:ev tX (xR,lX)+        :aRd=:DP aR 2:xRd=:DP xR 1:td=:DP t 1         :[loop])   where     tA=eAnn a; tX=eAnn x aeval (EApp _ (EApp _ (Builtin _ Mul) (EApp _ (Builtin _ T) a)) b) t | Just (F, _) <- tRnk tA = do     aL <- nextArr t     i <- newITemp; j <- newITemp; k <- newITemp; m <- newITemp; n <- newITemp; o <- newITemp; z <- newFTemp+    aRd <- newITemp; bRd <- newITemp; td <- newITemp     (plAA, (lA, aR)) <- plA a     (plB, (lB, bR)) <- plA b     let loop=forc tA i 0 ILt (Tmp m)                 [forc (eAnn b) j 0 ILt (Tmp o)                     [ MX () z 0, for tA k 0 ILt (Tmp n)-                        [MX () z (FTmp z+FAt (AElem aR 2 (Tmp k*Tmp m+Tmp i) lA 8)*FAt (AElem bR 2 (Tmp k*Tmp o+Tmp j) lB 8))]-                    , WrF () (AElem t 2 (Tmp i*Tmp o+Tmp j) (Just aL) 8) (FTmp z)]+                        [MX () z (FTmp z+FAt (Raw aRd (Tmp k*Tmp m+Tmp i) lA 8)*FAt (Raw bRd (Tmp k*Tmp o+Tmp j) lB 8))]+                    , WrF () (Raw td (Tmp i*Tmp o+Tmp j) (Just aL) 8) (FTmp z)]                 ]     pure (Just aL,         plAA$         plB$         m=:ec tA (aR,lA):o=:ec tB (bR,lB)         :Ma () aL t 2 (Tmp m*Tmp o) 8:diml (t, Just aL) [Tmp m, Tmp o]-        ++n=:ev tA (aR,lA)+        ++n=:ev tA (aR,lA):aRd=:DP aR 2:bRd=:DP bR 2:td=:DP t 2         :[loop])   where     tA=eAnn a; tB=eAnn b aeval (EApp _ (EApp _ (Builtin _ Mul) a) b) t | Just (F, _) <- tRnk tA = do     aL <- nextArr t     i <- newITemp; j <- newITemp; k <- newITemp; m <- newITemp; n <- newITemp; o <- newITemp; z <- newFTemp+    aRd <- newITemp; bRd <- newITemp; td <- newITemp     (plAA, (lA, aR)) <- plA a     (plB, (lB, bR)) <- plA b     let loop=for tA i 0 ILt (Tmp m)                 [forc tB j 0 ILt (Tmp o)                     [ MX () z 0, for tB k 0 ILt (Tmp n)-                              [MX () z (FTmp z+FAt (AElem aR 2 (Tmp n*Tmp i+Tmp k) lA 8)*FAt (AElem bR 2 (Tmp k*Tmp o+Tmp j) lB 8))]-                    , WrF () (AElem t 2 (Tmp i*Tmp o+Tmp j) (Just aL) 8) (FTmp z)]+                              [MX () z (FTmp z+FAt (Raw aRd (Tmp n*Tmp i+Tmp k) lA 8)*FAt (Raw bRd (Tmp k*Tmp o+Tmp j) lB 8))]+                    , WrF () (Raw td (Tmp i*Tmp o+Tmp j) (Just aL) 8) (FTmp z)]                     ]     pure (Just aL,         plAA$         plB$         m=:ev tA (aR,lA):o=:ec tB (bR,lB)         :Ma () aL t 2 (Tmp m*Tmp o) 8:diml (t, Just aL) [Tmp m, Tmp o]-        ++n=:ev tB (bR,lB)+        ++n=:ev tB (bR,lB):aRd=:DP aR 2:bRd=:DP bR 2:td=:DP t 2         :[loop])   where     tA=eAnn a; tB=eAnn b@@ -832,6 +949,14 @@     (plXs, (lX, xsR)) <- plA xs     (a,aV) <- vSz t (Tmp nR) sz     pure (Just a, plXs$m'sa xR mSz++plX++nϵR =: ev (eAnn xs) (xsR,lX):nR =: (Tmp nϵR+1):aV++[CpyE () (AElem t 1 0 (Just a) sz) (TupM xR Nothing) 1 sz, CpyE () (AElem t 1 1 (Just a) sz) (AElem xsR 1 0 lX sz) (Tmp nϵR) sz]++m'pop mSz)+aeval (EApp _ (EApp _ (Builtin _ ConsE) x) xs) t | Just (tX, xRnk) <- tRnk (eAnn x), tXs <- eAnn xs, Just (_, xsRnk) <- tRnk tXs = do+    a <- nextArr t+    (plX, (lX, xR)) <- plA x; (plXs, (lXs, xsR)) <- plA xs+    (dts,dss) <- plDim xRnk (xR, lX)+    d1R <- newITemp; d1'R <- newITemp+    szR <- newITemp; nX <- newITemp+    let rnkE=ConstI xsRnk; szX=bT tX+    pure (Just a, plXs$plX$d1R=:ev tXs (xsR,lXs):dss++d1'R=:(Tmp d1R+1):PlProd () nX (Tmp<$>dts):szR=:(Tmp d1'R*Tmp nX):Ma () a t rnkE (Tmp szR) szX:Wr () (ADim t 0 (Just a)) (Tmp d1'R):CpyD () (ADim t 1 (Just a)) (ADim xsR 1 lXs) (ConstI$xsRnk-1):[CpyE () (AElem t rnkE 0 (Just a) szX) (AElem xR (ConstI xRnk) 0 lX szX) (Tmp nX) szX, CpyE () (AElem t rnkE (Tmp nX) (Just a) szX) (AElem xsR (ConstI xsRnk) 0 lXs szX) (Tmp d1R*Tmp nX) szX]) aeval (EApp _ (EApp _ (Builtin _ Snoc) x) xs) t | tX <- eAnn x, Just sz <- rSz tX = do     xR <- rtemp tX     nR <- newITemp; nϵR <- newITemp@@ -846,6 +971,14 @@     (plXs, (lX, xsR)) <- plA xs     (a,aV) <- vSz t (Tmp nR) sz     pure (Just a, plXs$m'sa xR mSz++plX++nϵR =: ev (eAnn xs) (xsR,lX):nR =: (Tmp nϵR+1):aV++[CpyE () (AElem t 1 (Tmp nϵR) (Just a) sz) (TupM xR Nothing) 1 sz, CpyE () (AElem t 1 0 (Just a) sz) (AElem xsR 1 0 lX sz) (Tmp nϵR) sz]++m'pop mSz)+aeval (EApp _ (EApp _ (Builtin _ Snoc) x) xs) t | Just (tX, xRnk) <- tRnk (eAnn x), tXs <- eAnn xs, Just (_, xsRnk) <- tRnk tXs = do+    a <- nextArr t+    (plX, (lX, xR)) <- plA x; (plXs, (lXs, xsR)) <- plA xs+    (dts,dss) <- plDim xRnk (xR, lX)+    d1R <- newITemp; d1'R <- newITemp+    szR <- newITemp; nX <- newITemp+    let rnkE=ConstI xsRnk; szX=bT tX+    pure (Just a, plXs$plX$d1R=:ev tXs (xsR,lXs):dss++d1'R=:(Tmp d1R+1):PlProd () nX (Tmp<$>dts):szR=:(Tmp d1'R*Tmp nX):Ma () a t rnkE (Tmp szR) szX:Wr () (ADim t 0 (Just a)) (Tmp d1'R):CpyD () (ADim t 1 (Just a)) (ADim xsR 1 lXs) (ConstI$xsRnk-1):[CpyE () (AElem t rnkE (Tmp d1R*Tmp nX) (Just a) szX) (AElem xR (ConstI xRnk) 0 lX szX) (Tmp nX) szX, CpyE () (AElem t rnkE 0 (Just a) szX) (AElem xsR (ConstI xsRnk) 0 lXs szX) (Tmp d1R*Tmp nX) szX]) aeval (EApp ty (EApp _ (Builtin _ Re) n) x) t | tX <- eAnn x, Just xSz <- rSz tX = do     xR <- rtemp tX; nR <- newITemp     (a,aV) <- vSz t (Tmp nR) xSz@@ -866,32 +999,17 @@     (plX, (lX, xR)) <- plA x     plN <- eval n nR     xRnk <- newITemp; oRnk <- newITemp+    td <- newITemp; xRd <- newITemp     szX <- newITemp-    let loop = for ty k 0 ILt (Tmp nR) [CpyE () (AElem t (Tmp oRnk) (Tmp k*Tmp szX) (Just a) sz) (AElem xR (Tmp xRnk) 0 lX sz) (Tmp szX) sz]+    let loop = for ty k 0 ILt (Tmp nR) [CpyE () (Raw td (Tmp k*Tmp szX) (Just a) sz) (Raw xRd 0 lX sz) (Tmp szX) sz]     pure (Just a,         plX$         xRnk=:eRnk sh (xR,lX):oRnk=:(Tmp xRnk+1):SZ () szX xR (Tmp xRnk) lX         :plN         ++Ma () a t (Tmp oRnk) (Tmp szX*Tmp nR) sz:Wr () (ADim t 0 (Just a)) (Tmp nR):CpyD () (ADim t 1 (Just a)) (ADim xR 0 lX) (Tmp xRnk)+        :td=:DP t (Tmp oRnk)+        :xRd=:DP xR (Tmp xRnk)         :[loop])-aeval (EApp oTy (Builtin _ Init) x) t | Just sz <- aB oTy = do-    nR <- newITemp-    (a,aV) <- vSz t (Tmp nR) sz-    (plX, (lX, xR)) <- plA x-    pure (Just a, plX$nR =: (ev (eAnn x) (xR,lX)-1):aV++[CpyE () (AElem t 1 0 (Just a) sz) (AElem xR 1 0 lX sz) (Tmp nR) sz])-aeval (EApp oTy (Builtin _ InitM) x) t | Just sz <- aB oTy = do-    nR <- newITemp-    (a,aV) <- vSz t (Bin IMax (Tmp nR) 0) sz-    (plX, (lX, xR)) <- plA x-    pure (Just a,-        plX$-        nR =: (ev (eAnn x) (xR,lX)-1)-        :aV++[CpyE () (AElem t 1 0 (Just a) sz) (AElem xR 1 0 lX sz) (Tmp nR) sz])-aeval (EApp oTy (Builtin _ Tail) x) t | Just sz <- aB oTy = do-    nR <- newITemp-    (a,aV) <- vSz t (Tmp nR) sz-    (plX, (lX, xR)) <- plA x-    pure (Just a, plX$nR =: (ev (eAnn x) (xR,lX)-1):aV++[CpyE () (AElem t 1 0 (Just a) sz) (AElem xR 1 1 lX sz) (Tmp nR) sz]) aeval (EApp ty (EApp _ (EApp _ (Builtin _ Zip) op) xs) ys) t | (Arrow tX (Arrow tY tC)) <- eAnn op, Just zSz <- nSz tC, nind tX && nind tY = do     nR <- newITemp; i <- newITemp     (a,aV) <- vSz t (Tmp nR) zSz@@ -899,44 +1017,83 @@     (step, pinches) <- aS op [(tX, AElem aPX 1 (Tmp i) lX), (tY, AElem aPY 1 (Tmp i) lY)] tC (AElem t 1 (Tmp i) (Just a))     let loop=for ty i 0 ILt (Tmp nR) step     pure (Just a, plEX$plEY$nR =: ev (eAnn xs) (aPX,lX):aV++sas pinches [loop])-aeval (EApp _ (EApp _ (EApp _ (Builtin _ ScanS) op) seed) e) t | (Arrow tX (Arrow tY _)) <- eAnn op, isIF tX && isIF tY = do-    acc <- rtemp tX; x <- rtemp tY-    i <- newITemp; n <- newITemp+aeval (EApp _ (EApp _ (EApp _ (Builtin _ ScanS) op) seed) e) t | (Arrow tX (Arrow tY _)) <- eAnn op, Just xSz <- rSz tX, Just ySz <- nSz tY = do+    acc <- rtemp tX; i <- newITemp; n <- newITemp     plS <- eeval seed acc-    (a,aV) <- v8 t (Tmp n)+    (a,aV) <- vSz t (Tmp n) xSz     (plE, (l, aP)) <- plA e+    (x, wX, pinch) <- arg tY (AElem aP 1 (Tmp i) l ySz)     ss <- writeRF op [acc, x] acc-    let loopBody=wt (AElem t 1 (Tmp i) (Just a) 8) acc:mt (AElem aP 1 (Tmp i) l 8) x:ss+    let loopBody=wt (AElem t 1 (Tmp i) (Just a) xSz) acc:wX:ss         loop=for (eAnn e) i 0 ILt (Tmp n) loopBody-    pure (Just a, plE$plS++n =: (ev (eAnn e) (aP,l)+1):aV++[loop])-aeval (EApp _ (EApp _ (Builtin _ Scan) op) xs) t | (Arrow tAcc (Arrow tX _)) <- eAnn op, isIF tAcc && isIF tX = do+    pure (Just a, plE$plS++n =: (ev (eAnn e) (aP,l)+1):aV++m'p pinch [loop])+aeval (EApp _ (EApp _ (Builtin _ Scan) op) xs) t | (Arrow tAcc (Arrow tX _)) <- eAnn op, Just accSz <- rSz tAcc, Just xSz <- rSz tX = do     acc <- rtemp tAcc; x <- rtemp tX     i <- newITemp; n <- newITemp-    (a,aV) <- v8 t (Tmp n)+    (a,aV) <- vSz t (Tmp n) accSz     (plE, (l, aP)) <- plA xs     ss <- writeRF op [acc, x] acc-    let loopBody=wt (AElem t 1 (Tmp i-1) (Just a) 8) acc:mt (AElem aP 1 (Tmp i) l 8) x:ss+    let loopBody=wt (AElem t 1 (Tmp i-1) (Just a) accSz) acc:mt (AElem aP 1 (Tmp i) l xSz) x:ss         loop=for1 (eAnn xs) i 1 ILeq (Tmp n) loopBody-    pure (Just a, plE$n =: ev (eAnn xs) (aP,l):aV++mt (AElem aP 1 0 l 8) acc:[loop])+    pure (Just a, plE$n =: ev (eAnn xs) (aP,l):aV++mt (AElem aP 1 0 l xSz) acc:[loop])+    -- TODO: array case aeval (EApp oTy (EApp _ (Builtin _ (DI n)) op) xs) t | Just (ot, oSz) <- aRr oTy, Just xSz <- aB (eAnn xs) = do-    slopP <- newITemp     szR <- newITemp; sz'R <- newITemp; i <- newITemp     fR <- rtemp ot     (a,aV) <- vSz t (Tmp sz'R) xSz+    (slopP, aSlop, pops) <- vslop xSz n     (_, ss) <- writeF op [AA slopP Nothing] fR-    let szSlop=fromIntegral$16+fromIntegral oSz*n     (plX, (lX, aP)) <- plA xs     let sz'=Tmp szR-fromIntegral(n-1)     let loopBody=CpyE () (AElem slopP 1 0 Nothing xSz) (AElem aP 1 (Tmp i) lX xSz) (fromIntegral n) xSz:ss++[wt (AElem t 1 (Tmp i) (Just a) oSz) fR]         loop=for oTy i 0 ILt (Tmp sz'R) loopBody-    pure (Just a, plX$szR =: ev (eAnn xs) (aP,lX):sz'R =: sz':aV++Sa () slopP szSlop:Wr () (ARnk slopP Nothing) 1:Wr () (ADim slopP 0 Nothing) (fromIntegral n):loop:[Pop () szSlop])-    -- TODO: not just I,F+    pure (Just a, plX$szR =: ev (eAnn xs) (aP,lX):sz'R =: sz':aV++aSlop++loop:[pops])+aeval (EApp oTy (EApp _ (Builtin _ (DI n)) op) xs) t | Just ((_, 1), (tO, cRnk)) <- mAA (eAnn op), Just (tX, 1) <- tRnk (eAnn xs) = do+    a <- nextArr t+    d1x <- newITemp; i <- newITemp; d1 <- newITemp+    z0R <- newITemp; zR <- newITemp; nC <- newITemp+    let szX=bT tX; szO=bT tO; oRnk=ConstI$1+cRnk; neϵ=fromIntegral n+    (plX, (lX, xR)) <- plA xs+    (slopP, aSlop, pops) <- vslop szX n+    (lZ0, ss0) <- writeF op [AA slopP Nothing] (IT z0R)+    (lZ, ss) <- writeF op [AA slopP Nothing] (IT zR)+    (dots, plOds) <- plDim cRnk (z0R, lZ0)+    let loopBody = CpyE () (AElem slopP 1 0 Nothing szX) (AElem xR 1 (Tmp i) lX szX) neϵ szX:ss++[CpyE () (AElem t oRnk (Tmp i*Tmp nC) (Just a) szO) (AElem zR (ConstI cRnk) 0 lZ szO) (Tmp nC) szO]+        loop = for oTy i 0 ILt (Tmp d1) loopBody+    pure (Just a,+        plX$+        d1x=:ev (eAnn xs) (xR,lX)+        :d1=:(Tmp d1x-(neϵ-1))+        :aSlop+        ++CpyE () (AElem slopP 1 0 Nothing szX) (AElem xR 1 0 lX szX) neϵ szX:ss0+        ++plOds++PlProd () nC (Tmp<$>dots)+        :Ma () a t oRnk (Tmp d1*Tmp nC) szO+        :zipWith (\j tϵ -> Wr () (ADim t (ConstI j) (Just a)) (Tmp tϵ)) [0..] (d1:dots)+        ++loop+        :[pops])+    -- TODO: array case aeval (EApp _ (EApp _ (Builtin _ Rot) n) xs) t | tXs <- eAnn xs, Just sz <- aB tXs = do-    nR <- newITemp; c <- newITemp; szR <- newITemp-    plN <- eval n nR+    c <- newITemp; szR <- newITemp+    (plN, nR) <- plEV n     (plX, (lX, xsR)) <- plA xs     (a, aV) <- vSz t (Tmp szR) sz-    pure (Just a, plX$plN++szR =: ev tXs (xsR,lX):aV++Ifn't () (IRel IGeq (Tmp nR) 0) [nR+=Tmp szR]:c =: (Tmp szR-Tmp nR):[CpyE () (AElem t 1 0 (Just a) sz) (AElem xsR 1 (Tmp nR) lX sz) (Tmp c) sz, CpyE () (AElem t 1 (Tmp c) (Just a) sz) (AElem xsR 1 0 lX sz) (Tmp nR) sz])+    pure (Just a, plX$plN$szR =: ev tXs (xsR,lX):aV++Ifn't () (IRel IGeq (Tmp nR) 0) [nR+=Tmp szR]:c =: (Tmp szR-Tmp nR):[CpyE () (AElem t 1 0 (Just a) sz) (AElem xsR 1 (Tmp nR) lX sz) (Tmp c) sz, CpyE () (AElem t 1 (Tmp c) (Just a) sz) (AElem xsR 1 0 lX sz) (Tmp nR) sz])+aeval (EApp _ (EApp _ (Builtin _ Rot) n) xs) t | Just (tX, xRnk) <- tRnk (eAnn xs), Just sz <- nSz tX = do+    a <- nextArr t+    c <- newITemp; szR <- newITemp+    (plN, nR) <- plEV n+    (plX, (lX, xR)) <- plA xs+    (dts,dss) <- plDim xRnk (xR,lX)+    let d1=head dts; ns=tail dts+        rnkE=ConstI xRnk+    pure (Just a,+        plX$plN$dss+        ++PlProd () szR (Tmp<$>ns)+        :Ma () a t rnkE (Tmp d1*Tmp szR) sz+        :CpyD () (ADim t 0 (Just a)) (ADim xR 0 lX) rnkE+        :Ifn't () (IRel IGeq (Tmp nR) 0) [nR+=Tmp d1]+        :c=:(Tmp d1-Tmp nR)+        :[CpyE () (AElem t rnkE 0 (Just a) sz) (AElem xR rnkE (Tmp nR*Tmp szR) lX sz) (Tmp c*Tmp szR) sz, CpyE () (AElem t rnkE (Tmp c*Tmp szR) (Just a) sz) (AElem xR rnkE 0 lX sz) (Tmp nR*Tmp szR) sz]) aeval (Id _ (AShLit ns es)) t | Just ws <- mIFs es = do     let rnk=fromIntegral$length ns     n <- nextAA@@ -1030,19 +1187,19 @@     let loop=for oTy i 0 ILt (Tmp nR) (wt (AElem t 1 (Tmp i) (Just a) sz) acc:ss)     pure (Just a, plS++plN++aV++[loop]) aeval (EApp ty (EApp _ (EApp _ (Builtin _ Gen) seed) op) n) t | isΠR (eAnn seed) = do-    nR <- newITemp; plN <- eval n nR; i <- newITemp+    nR <- newITemp; plN <- eval n nR; i <- newITemp; td <- newITemp     acc <- newITemp     (szs,mP,_,plS) <- πe seed acc     let πsz=last szs     (a,aV) <- vSz t (Tmp nR) πsz     (_, ss) <- writeF op [IPA acc] (IT acc)-    let loop=for ty i 0 ILt (Tmp nR) (CpyE () (AElem t 1 (Tmp i) (Just a) πsz) (TupM acc Nothing) 1 πsz:ss)-    pure (Just a, m'sa acc mP++plS++plN++aV++loop:m'pop mP)+    let loop=for ty i 0 ILt (Tmp nR) (CpyE () (Raw td (Tmp i) (Just a) πsz) (TupM acc Nothing) 1 πsz:ss)+    pure (Just a, m'sa acc mP++plS++plN++aV++td=:DP t 1:loop:m'pop mP) aeval (EApp oTy (EApp _ (Builtin _ (Conv is)) f) x) t     | (Arrow _ tC) <- eAnn f     , Just (tX, xRnk) <- tRnk (eAnn x)     , Just (_, oRnk) <- tRnk oTy-    , Just oSz <- bSz tC, Just xSz <- bSz tX, oRnk==xRnk = do+    , Just oSz <- nSz tC, Just xSz <- nSz tX, oRnk==xRnk = do     a <- nextArr t     xRd <- newITemp; szR <- newITemp; slopP <- newITemp     (plX, (lX, xR)) <- plA x@@ -1050,7 +1207,7 @@     (tdims, dims) <- unzip <$> zipWithM (\dt i -> do {odim <- newITemp; pure (odim, odim =: (Tmp dt-fromIntegral (i-1)))}) dts is     io <- traverse (\_ -> newITemp) tdims     iw <- traverse (\_ -> newITemp) is; j <- newITemp-    let slopSz=product is; slopRnk=length is; slopE=fromIntegral ((slopSz+slopRnk+1)*fromIntegral oSz); slopDims=fromIntegral<$>is+    let slopSz=product is; slopRnk=length is; slopE=fromIntegral (slopSz*fromIntegral oSz+(slopRnk+1)*8); slopDims=fromIntegral<$>is         rnk=ConstI oRnk     z <- rtemp tC; k <- newITemp; o <- rtemp tX     (_, ss) <- writeF f [AA slopP Nothing] z@@ -1076,7 +1233,11 @@ plC (Var I x)  = do {st <- gets vars; pure (id, Tmp$getT st x)} plC e          = do {t <- newITemp; pl <- eval e t; pure ((pl++), Tmp t)} -plD :: E (T ()) -> CM ([CS ()] -> [CS ()], CFE)+plD2 :: E (T ()) -> CM ([CS ()] -> [CS ()], F2Temp)+plD2 (Var F x) = do {st <- gets d2vars; pure (id, getT st x)}+plD2 e         = do {t <- newF2Temp; pl <- f2eval e t; pure ((pl++), t)}++plD :: E (T ()) -> CM ([CS ()] -> [CS ()], F1E) plD (FLit _ x) = pure (id, ConstF x) plD (Var F x)  = do {st <- gets dvars; pure (id, FTmp$getT st x)} plD e          = do {t <- newFTemp; pl <- feval e t; pure ((pl++), FTmp t)}@@ -1125,6 +1286,16 @@ peval (EApp _ (EApp _ (Builtin (Arrow F _) op) e0) e1) t | Just fop' <- frel op = do     (plE0,e0e) <- plD e0; (plE1, e1e) <- plD e1     pure $ plE0 $ plE1 [Cset () (FRel fop' e0e e1e) t]+peval (EApp _ (EApp _ (Builtin (Arrow (Arr _ ty) _) Eq) e0) e1) t | Arr sh _ <- eAnn e0, isIF ty =do+    (plX0, (lX0, x0R)) <- plA e0; (plX1, (lX1, x1R)) <- plA e1+    rnkR <- newITemp; szR <- newITemp+    i <- newITemp; j <- newITemp+    x0Rd <- newITemp; x1Rd <- newITemp+    let eqDim = Cset () (IRel IEq (EAt (ADim x0R (Tmp i) lX0)) (EAt (ADim x1R (Tmp i) lX1))) t+        eCond = case ty of+            F -> FRel FEq (FAt (Raw x0Rd (Tmp j) lX0 8)) (FAt (Raw x1Rd (Tmp j) lX1 8))+            I -> IRel IEq (EAt (Raw x0Rd (Tmp j) lX0 8)) (EAt (Raw x1Rd (Tmp j) lX1 8))+    pure $ plX0 $ plX1 $ rnkR=:eRnk sh (x0R,lX0):MB () t (BConst True):i=:0:WT () (Boo AndB (Is t) (IRel ILt (Tmp i) (Tmp rnkR))) [eqDim, i+=1]:SZ () szR x0R (Tmp rnkR) lX0:x0Rd=:DP x0R (Tmp rnkR):x1Rd=:DP x1R (Tmp rnkR):j=:0:[WT () (Boo AndB (Is t) (IRel ILt (Tmp j) (Tmp szR))) [Cset () eCond t, j+=1]] peval (EApp _ (EApp _ (Builtin _ op) e0) e1) t | Just boo <- mB op = do     (pl0,e0R) <- plP e0; (pl1,e1R) <- plP e1     pure $ pl0 $ pl1 [MB () t (Boo boo e0R e1R)]@@ -1133,29 +1304,31 @@     pure $ pl [MB () t (BU BNeg e0R)] peval (EApp _ (EApp _ (Builtin _ Fold) op) e) acc | (Arrow tX _) <- eAnn op, isB tX = do     x <- nBT-    szR <- newITemp-    i <- newITemp+    i <- newITemp; szR <- newITemp     (plE, (l, aP)) <- plA e     ss <- writeRF op [PT acc, PT x] (PT acc)     let loopBody=MB () x (PAt (AElem aP 1 (Tmp i) l 1)):ss         loop=for1 (eAnn e) i 1 ILt (Tmp szR) loopBody     pure $ plE$szR =: ev (eAnn e) (aP,l):MB () acc (PAt (AElem aP 1 0 l 1)):[loop]-peval (EApp _ (EApp _ (EApp _ (Builtin _ FoldS) op) seed) e) acc | (Arrow _ (Arrow tY _)) <- eAnn op, Just szY <- rSz tY = do-    x <- rtemp tY-    szR <- newITemp-    i <- newITemp+peval (EApp _ (EApp _ (EApp _ (Builtin _ FoldS) op) seed) e) acc | (Arrow _ (Arrow tY _)) <- eAnn op, Just szY <- nSz tY = do+    i <- newITemp; szR <- newITemp     (plE, (l, aP)) <- plA e     plAcc <- peval seed acc+    (x, wX, pinch) <- arg tY (AElem aP 1 (Tmp i) l szY)     ss <- writeRF op [PT acc, x] (PT acc)-    let loopBody=mt (AElem aP 1 (Tmp i) l szY) x:ss+    let loopBody=wX:ss         loop=for (eAnn e) i 0 ILt (Tmp szR) loopBody-    pure $ plE $ plAcc++szR=:ev (eAnn e) (aP,l):[loop]+    pure $ plE $ plAcc++szR=:ev (eAnn e) (aP,l):m'p pinch [loop] peval (EApp _ (Builtin _ Head) xs) t = do     (plX, (l, a)) <- plA xs     pure $ plX [MB () t (PAt (AElem a 1 0 l 1))] peval (EApp _ (Builtin _ Last) xs) t = do     (plX, (l, a)) <- plA xs     pure $ plX [MB () t (PAt (AElem a 1 (ev (eAnn xs) (a,l)-1) l 1))]+peval (EApp _ (Builtin _ (TAt i)) e) t = do+    k <- newITemp+    (offs, a, _, plT) <- πe e k+    pure $ m'sa k a++plT ++ MB () t (PAt (Raw k (ConstI$offs!!(i-1)) Nothing 1)):m'pop a peval e _ = error (show e)  eval :: E (T ()) -> Temp -> CM [CS ()]@@ -1178,16 +1351,14 @@     let loopBody=x=:EAt (AElem aP 1 (Tmp i) l 8):ss         loop=for1 (eAnn e) i 1 ILt (Tmp szR) loopBody     pure $ plE$szR =: ev (eAnn e) (aP,l):acc =: EAt (AElem aP 1 0 l 8):[loop]-eval (EApp _ (EApp _ (EApp _ (Builtin _ FoldS) op) seed) e) acc | (Arrow _ (Arrow tX _)) <- eAnn op, Just xSz <- rSz tX = do-    x <- rtemp tX-    szR <- newITemp-    i <- newITemp+eval (EApp _ (EApp _ (EApp _ (Builtin _ FoldS) op) seed) e) acc | (Arrow _ (Arrow tX _)) <- eAnn op, Just xSz <- nSz tX, tArr <- eAnn e = do+    i <- newITemp; szR <- newITemp     (plE, (l, eR)) <- plA e     plAcc <- eval seed acc+    (x, wX, pinch) <- arg tX (AElem eR 1 (Tmp i) l xSz)     ss <- writeRF op [IT acc, x] (IT acc)-    let loopBody=mt (AElem eR 1 (Tmp i) l xSz) x:ss-        loop=for (eAnn e) i 0 ILt (Tmp szR) loopBody-    pure $ plE$plAcc++szR =: ev (eAnn e) (eR,l):[loop]+    let loop=for tArr i 0 ILt (Tmp szR) (wX:ss)+    pure $ plE$plAcc++szR =: ev tArr (eR,l):m'p pinch [loop] eval (EApp I (EApp _ (Builtin _ op) e0) e1) t | Just cop <- mOp op = do     (pl0,e0e) <- plC e0; (pl1,e1e) <- plC e1     pure $ pl0 $ pl1 [t =: Bin cop e0e e1e]@@ -1232,7 +1403,7 @@ eval (EApp _ (Builtin _ (TAt i)) e) t = do     k <- newITemp     (offs, a, _, plT) <- πe e k-    pure $ m'sa t a++plT ++ t =: EAt (Raw k (ConstI$offs!!(i-1)) Nothing 1):m'pop a+    pure $ m'sa k a++plT ++ t =: EAt (Raw k (ConstI$offs!!(i-1)) Nothing 1):m'pop a eval (EApp _ (EApp _ (Builtin _ IOf) p) xs) t | (Arrow tD _) <- eAnn p, Just szX <- nSz tD = do     pR <- nBT     szR <- newITemp; i <- newITemp; done <- newITemp@@ -1286,7 +1457,7 @@ mFun :: Builtin -> Maybe FUn mFun Sqrt=Just FSqrt; mFun Log=Just FLog; mFun Sin=Just FSin; mFun Cos=Just FCos; mFun Abs=Just FAbs; mFun _=Nothing -mFEval :: E (T ()) -> Maybe (CM CFE)+mFEval :: E (T ()) -> Maybe (CM F1E) mFEval (FLit _ d) = Just (pure $ ConstF d) mFEval (Var _ x) = Just $ do     st <- gets dvars@@ -1322,6 +1493,15 @@     plPP <- peval p pR; plE0 <- eeval e0 t; plE1 <- eeval e1 t     pure (Nothing, plPP ++ [If () (Is pR) plE0 plE1]) +f2eval :: E (T ()) -> F2Temp -> CM [CS ()]+f2eval (LLet _ b e) t = do+    ss <- llet b+    (ss++) <$> f2eval e t+f2eval (Var _ x) t = do {st <- gets d2vars; pure [MX2 () t (FTmp $ getT st x)]}+f2eval (EApp _ (EApp _ (Builtin _ op) e0) e1) t | Just fb <- mFop op = do+    (pl0,e0R) <- plD2 e0; (pl1,e1R) <- plD2 e1+    pure $ pl0 $ pl1 [MX2 () t (FBin fb (FTmp e0R) (FTmp e1R))]+ feval :: E (T ()) -> FTemp -> CM [CS ()] feval (LLet _ b e) t = do     ss <- llet b@@ -1341,6 +1521,9 @@ feval (EApp _ (EApp _ (Builtin _ Plus) e0) (EApp _ (EApp _ (Builtin _ Times) e1) e2)) t = do     (pl0,t0) <- plF e0; (pl1,t1) <- plF e1; (pl2,t2) <- plF e2     pure $ pl0 $ pl1 $ pl2 [MX () t (FTmp t0+FTmp t1*FTmp t2)]+feval (EApp _ (EApp _ (Builtin _ Minus) e0) (EApp _ (EApp _ (Builtin _ Times) e1) e2)) t = do+    (pl0,t0) <- plF e0; (pl1,t1) <- plF e1; (pl2,t2) <- plF e2+    pure $ pl0 $ pl1 $ pl2 [MX () t (FTmp t0-FTmp t1*FTmp t2)] feval (EApp _ (EApp _ (Builtin _ op) e0) e1) t | Just fb <- mFop op = do     (pl0,e0e) <- plD e0; (pl1,e1R) <- plF e1     pure $ pl0 $ pl1 [MX () t (FBin fb e0e (FTmp e1R))]@@ -1436,16 +1619,17 @@     let loopBody=mt (AElem eR 1 (Tmp i) l 8) x:ss++[i =: (Tmp i-1)]         loop=While () i IGeq 0 loopBody     pure $ plE $ plAcc++i =: (ev (eAnn e) (eR,l)-1):[loop]-feval (EApp _ (EApp _ (EApp _ (Builtin _ FoldA) op) seed) xs) acc | Arr sh _ <- eAnn xs, (Arrow _ (Arrow tX _)) <- eAnn op, isIF tX = do+feval (EApp _ (EApp _ (EApp _ (Builtin _ FoldA) op) seed) xs) acc | tXs@(Arr sh _) <- eAnn xs, (Arrow _ (Arrow tX _)) <- eAnn op, isIF tX = do     x <- rtemp tX     rnkR <- newITemp; szR <- newITemp; k <- newITemp     (plE, (lX, xsR)) <- plA xs     plAcc <- feval seed acc     ss <- writeRF op [x, FT acc] (FT acc)-    let step=mt (AElem xsR (Tmp rnkR) (Tmp k) lX 8) x:ss-        loop=for (eAnn xs) k 0 ILt (Tmp szR) step-        plSz = case tIx (eAnn xs) of {Just (_, is) -> szR=:ConstI (product is); Nothing -> SZ () szR xsR (Tmp rnkR) lX}-    pure $ plE $ plAcc ++ [rnkR =: eRnk sh (xsR, lX), plSz, loop]+    xsRd <- newITemp+    let step=mt (Raw xsRd (Tmp k) lX 8) x:ss+        loop=for tXs k 0 ILt (Tmp szR) step+        plSz = case tIx tXs of {Just (_, is) -> szR=:ConstI (product is); Nothing -> SZ () szR xsR (Tmp rnkR) lX}+    pure $ plE $ plAcc ++ [rnkR =: eRnk sh (xsR, lX), plSz, xsRd=:DP xsR (Tmp rnkR), loop] feval (EApp _ (EApp _ (EApp _ (Builtin _ FoldS) op) seed) (EApp _ (EApp _ (EApp _ (Builtin _ IRange) start) end) incr)) acc = do     i <- newITemp     endR <- newITemp@@ -1461,16 +1645,24 @@     plIncr <- feval ((end `eMinus` start) `eDiv` (EApp F (Builtin (Arrow I F) ItoF) nSteps `eMinus` FLit F 1)) incrR     ss <- writeRF op [FT acc, FT xR] (FT acc)     pure $ plStart ++ MX () xR (FTmp startR):plEnd++plIncr++plAcc++[for ty i 0 ILt (Tmp endI) (ss++[MX () xR (FTmp xR+FTmp incrR)])]-feval (EApp _ (EApp _ (EApp _ (Builtin _ FoldS) op) seed) e) acc | (Arrow _ (Arrow tX _)) <- eAnn op, Just xSz <- rSz tX = do-    x <- rtemp tX+feval (EApp _ (EApp _ (EApp _ (Builtin _ FoldS) op) seed) e) acc | (Arrow _ (Arrow tX _)) <- eAnn op, Just xSz <- nSz tX = do     szR <- newITemp     i <- newITemp     (plE, (l, eR)) <- plA e     plAcc <- feval seed acc+    (x, wX, pinch) <- arg tX (AElem eR 1 (Tmp i) l xSz)     ss <- writeRF op [FT acc, x] (FT acc)-    let loopBody=mt (AElem eR 1 (Tmp i) l xSz) x:ss+    let loopBody=wX:ss         loop=for (eAnn e) i 0 ILt (Tmp szR) loopBody-    pure $ plE $ plAcc++szR =: ev (eAnn e) (eR,l):[loop]+    pure $ plE $ plAcc++szR =: ev (eAnn e) (eR,l):m'p pinch [loop]+feval (EApp _ (EApp _ (EApp _ (Builtin _ FoldS) op) seed) e) acc | (Arrow _ (Arrow tX _)) <- eAnn op, Just xSz <- nSz tX, tArr <- eAnn e = do+    i <- newITemp; szR <- newITemp+    plAcc <- feval seed acc+    (plX, (lX, xR)) <- plA e+    (x, wX, pinch) <- arg tX (AElem xR 1 (Tmp i) lX xSz)+    ss <- writeRF op [FT acc, x] (FT acc)+    let loop=for tArr i 0 ILt (Tmp szR) (wX:ss)+    pure $ plX$plAcc++szR=:ev tArr (xR,lX):m'p pinch [loop] feval (EApp _ (EApp _ (EApp _ (Builtin _ Iter) f) n) x) t = do     (plN,nR) <- plC n     plX <- feval x t@@ -1482,10 +1674,10 @@     k <- newITemp     (offs, a, _, plT) <- πe e k     pure $ m'sa k a++plT ++ MX () t (FAt (Raw k (ConstI$offs!!(i-1)) Nothing 1)):m'pop a-feval (EApp _ (Var _ f) x) t | isF (eAnn x) = do+feval (EApp _ (Var _ f) x) t | Just ~(tX, _) <- rr (eAnn x) = do     st <- gets fvars-    let (l, [FA a], Left r) = getT st f-    plX <- feval x a+    let (l, [a], FT r) = getT st f+    plX <- eeval x (art a)     retL <- neL     pure $ plX ++ [G () l retL, MX () t (FTmp r)] feval (Id _ (FoldGen seed g f n)) t = do

@@ -6,7 +6,7 @@ import           Control.Exception (Exception) import           Data.Bifunctor    (first) import qualified Data.Text         as T-import           Prettyprinter     (Doc, Pretty (..), braces, parens, tupled, (<+>))+import           Prettyprinter     (Doc, Pretty (..), braces, parens, softline', tupled, (<+>)) import           Prettyprinter.Ext  data CType = CR | CI | CB | Af | Ai | Ab@@ -21,7 +21,7 @@         let args = zip ins ['a'..] in         "extern" <+> pretty out <+> pretty n <+> tupled (px<$>ins) <> ";"             <#> px out <+> pretty n <> "_wrapper" <+> tupled (fmap (\(t,var) -> pretty t <+> pretty var) args)-            <> braces+            <> softline' <> braces                 (foldMap d args                 <> pretty out <+> "res" <> "=" <> ax out (pretty n<>tupled (l.snd<$>args))<>";"                 <> foldMap f args

@@ -42,6 +42,24 @@     toInt X86.XMM14 = -11     toInt X86.XMM15 = -12 +instance E X86.F2X86 where+    toInt X86.YMM0  = 8+    toInt X86.YMM1  = 9+    toInt X86.YMM2  = 10+    toInt X86.YMM3  = 11+    toInt X86.YMM4  = 12+    toInt X86.YMM5  = 13+    toInt X86.YMM6  = 14+    toInt X86.YMM7  = 15+    toInt X86.YMM8  = -5+    toInt X86.YMM9  = -6+    toInt X86.YMM10 = -7+    toInt X86.YMM11 = -8+    toInt X86.YMM12 = -9+    toInt X86.YMM13 = -10+    toInt X86.YMM14 = -11+    toInt X86.YMM15 = -12+ instance E X86.AbsReg where     toInt = X86.toInt @@ -116,8 +134,45 @@     toInt AArch64.D30 = -45     toInt AArch64.D31 = -46 +instance E AArch64.F2Reg where+    toInt AArch64.V0  = 10+    toInt AArch64.V1  = 11+    toInt AArch64.V2  = 12+    toInt AArch64.V3  = 13+    toInt AArch64.V4  = 14+    toInt AArch64.V5  = 15+    toInt AArch64.V6  = 16+    toInt AArch64.V7  = 17+    toInt AArch64.V8  = -23+    toInt AArch64.V9  = -24+    toInt AArch64.V10 = -25+    toInt AArch64.V11 = -26+    toInt AArch64.V12 = -27+    toInt AArch64.V13 = -28+    toInt AArch64.V14 = -29+    toInt AArch64.V15 = -30+    toInt AArch64.V16 = -31+    toInt AArch64.V17 = -32+    toInt AArch64.V18 = -33+    toInt AArch64.V19 = -34+    toInt AArch64.V20 = -35+    toInt AArch64.V21 = -36+    toInt AArch64.V22 = -37+    toInt AArch64.V23 = -38+    toInt AArch64.V24 = -39+    toInt AArch64.V25 = -40+    toInt AArch64.V26 = -41+    toInt AArch64.V27 = -42+    toInt AArch64.V28 = -43+    toInt AArch64.V29 = -44+    toInt AArch64.V30 = -45+    toInt AArch64.V31 = -46+ instance E AArch64.AbsReg where     toInt = AArch64.toInt  instance E AArch64.FAbsReg where     toInt = AArch64.fToInt++instance E AArch64.F2Abs where+    toInt = AArch64.f2ToInt

@@ -145,7 +145,7 @@ prettyCI = prettyLines.fmap (pL ((space<>).pretty))  dumpLoop :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann)-dumpLoop = fmap (pg.loop.π).ir where π (a,_,_)=a; pg (t,ss,_) = pS ss<#>pretty (fmap (IS.toList . snd) t); pS=prettyLines.fmap (\(s,l) -> pretty (node l) <> ":" <+> pretty s)+dumpLoop = fmap (pg.loop.π).ir where π (a,_,_)=a; pg (t,ss,_) = pS ss<#>pretty (fmap (\(nϵ,ns) -> nϵ:IS.toList ns) t); pS=prettyLines.fmap (\(s,l) -> pretty (node l) <> ":" <+> pretty s)  dumpDomTree :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) dumpDomTree = fmap (pg.hoist.π).ir where π (a,_,_)=a; pg (_,t,asϵ,_) = pS asϵ<#>pretty (drawTree (show<$>t)); pS=prettyLines.fmap (\(s,l) -> pretty (node l) <> ":" <+> pretty s)@@ -165,10 +165,10 @@ dumpALiveness :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) dumpALiveness = fmap (Aarch64.prettyDebug . mkLive . (\(x,_,st) -> snd (irToAarch64 st x))) . ir -x86Iv :: BSL.ByteString -> Either (Err AlexPosn) [X86.X86 X86.AbsReg X86.FAbsReg Live]+x86Iv :: BSL.ByteString -> Either (Err AlexPosn) [X86.X86 X86.AbsReg X86.FAbsReg X86.X2Abs Live] x86Iv = fmap (mkIntervals . (\(x,_,st) -> snd (irToX86 st x))) . ir -aarch64Iv :: BSL.ByteString -> Either (Err AlexPosn) [Aarch64.AArch64 Aarch64.AbsReg Aarch64.FAbsReg Live]+aarch64Iv :: BSL.ByteString -> Either (Err AlexPosn) [Aarch64.AArch64 Aarch64.AbsReg Aarch64.FAbsReg Aarch64.F2Abs Live] aarch64Iv = fmap (mkIntervals . (\(x,_,st) -> snd (irToAarch64 st x))) . ir  printParsed :: BSL.ByteString -> Doc ann

@@ -26,7 +26,7 @@  instance Show AB where show=show.pretty -data Apple a = AA !Int64 [Int64] [a] deriving (Functor)+data Apple a = AA !Int64 [Int64] [a] deriving (Eq, Functor)  data P2 a b = P2 a b; hs2 (P2 a b) = (a,b) data P3 a b c = P3 a b c; hs3 (P3 a b c) = (a,b,c)@@ -56,6 +56,8 @@  instance Pretty a => Pretty (Apple a) where     pretty (AA _ dims xs) = "Arr" <+> tupledBy "×" (pretty <$> dims) <+> pE dims xs++instance Pretty a => Show (Apple a) where show=show.pretty  instance (Pretty a, Pretty b) => Pretty (P2 a b) where     pretty (P2 x y) = tupledBy "*" [pretty x, pretty y]

@@ -84,7 +84,7 @@     pretty (J l)         = parens ("j" <+> prettyLabel l)     pretty (Wr p e)      = parens ("write" <+> pretty p <+> pretty e)     pretty (WrF p e)     = parens ("write" <+> pretty p <+> pretty e)-    pretty (WrB p e)     = parens ("write" <+> pretty p <+> pretty e)+    pretty (WrB p e)     = parens ("write-1" <+> pretty p <+> pretty e)     pretty (Ma _ t e)    = parens ("malloc" <+> pretty t <+> ":" <+> pretty e)     pretty (Free t)      = parens ("free" <+> pretty t)     pretty (Cmov p t e)  = parens ("cmov" <+> pretty p <+> pretty t <+> pretty e)

@@ -77,6 +77,11 @@     s' <- foldMapM cToIRM s     pure $ MJ (IR.IRel (nr rel) (Reg t') (irE eb)) eL:L l:s'++[MJ (IR.IRel rel (Reg t') (irE eb)) l, L eL]   where t'=ctemp t+cToIRM (WT _ p s) = do+    l <- nextL; eL <- nextL+    s' <- foldMapM cToIRM s+    pure $ MJ (IR.BU BNeg p') eL:L l:s'++[MJ p' l, L eL]+  where p'=irp p cToIRM (C.RA _ i) = pure [IR.RA i] cToIRM (CpyD _ a0 a1 e) = pure [Cpy (irAt a0) (irAt a1) (irE e)] cToIRM (CpyE _ a0 a1 e 8) = pure [Cpy (irAt a0) (irAt a1) (irE e)]@@ -147,7 +152,7 @@ irp (C.BConst False)   = IR.ConstI 0 irp (C.Boo op e0 e1)   = IB (BI op) (irp e0) (irp e1) -irX :: CFE -> FExp+irX :: F1E -> FExp irX (C.ConstF x)    = IR.ConstF x irX (FTmp t)        = FReg (fx t) irX (C.FAt a)       = IR.FAt (irAt a)

@@ -7,11 +7,14 @@ import           Control.Monad.State.Strict (gets, modify, runState) import qualified Data.Array                 as A import           Data.Bifunctor             (bimap, first, second)+import           Data.Foldable              (toList)+import           Data.Function              (on) import           Data.Functor               (($>)) import           Data.Graph                 (Tree (Node)) import           Data.Graph.Dom             (Graph, Node, domTree) import qualified Data.IntMap                as IM import qualified Data.IntSet                as IS+import           Data.List                  (sortBy) import qualified Data.Map.Strict            as M import           Data.Maybe                 (catMaybes, fromJust, fromMaybe) import           Data.Tuple.Extra           (first3, snd3)@@ -131,24 +134,23 @@  {-# SCC ols #-} ols :: [Loop] -> [Loop]-ols ls = filter (\(_,ns) -> not $ any (\(_,ns') -> ns `IS.isSubsetOf` ns') ls) ls+ols ls = filter (\(_,ns) -> not $ any (\(_,ns') -> ns `IS.isProperSubsetOf` ns') ls) ls  et :: Graph -> A.Array Int Stmt -> [N] -> Tree N -> [(N, [N])]-et g ss seen t = expandLoop t <$> tLoops g ss seen t+et g ss seen t = expandLoop t <$> loopHeads g ss seen t -{-# SCC expandLoop #-}-expandLoop :: Tree N -> (N,N) -> (N,[N])--- wir müssen wissen, wir werden wissen-expandLoop t se = fromJust (go [] se t)+-- everything the start node dominates+expandLoop :: Tree N -> N -> (N,[N])+--- wir müssen wissen, wir werden wissen+expandLoop t s = (s, fromJust (go t))   where-    go seen (s,e) (Node n _) | e == n = Just (s, dropWhile (/=s) (reverse seen))-    go _ _ (Node _ [])       = Nothing-    go seen seϵ (Node n ns)  = mh (go (n:seen) seϵ <$> ns) where mh xs=case catMaybes xs of {[] -> Nothing; (nϵ:_) -> Just nϵ}+    go (Node n tϵ) | n==s = Just$concatMap toList tϵ+    go (Node _ ns) = mh (go<$>ns) where mh xs=case catMaybes xs of {[] -> Nothing; (nϵ:_) -> Just nϵ} -tLoops :: Graph -> A.Array Int Stmt -> [N] -> Tree N -> [(N, N)]-tLoops g ss seen (Node n cs) =+loopHeads :: Graph -> A.Array Int Stmt -> [N] -> Tree N -> [N]+loopHeads g ss seen (Node n cs) =     let bes=filter (hasEdge g n) seen-    in (if isMJ n then (fmap (,n) bes++) else id) $ concatMap (tLoops g ss (n:seen)) cs+    in (if isMJ n then (bes++) else id) $ concatMap (loopHeads g ss (n:seen)) cs   where     isMJ nϵ = p (ss A.! nϵ)     p MJ{}=True; p _=False@@ -160,4 +162,4 @@ mkG (ns,m) = (domG, domTree (node (snd (head ns)), domG), sa, IM.fromList ((\(s, ann) -> (node ann, (s, ann)))<$>ns))   where     domG = IM.fromList [ (node ann, IS.fromList (conn ann)) | (_, ann) <- ns ]-    sa = A.listArray (0,m-1) ns+    sa = A.listArray (0,m-1) (sortBy (compare `on` (node.snd)) ns)

@@ -5,14 +5,12 @@     {-# LANGUAGE StandaloneDeriving #-}     module L ( alexMonadScan              , alexInitUserState-             , runAlex-             , runAlexSt              , withAlexSt              , freshName              , newIdent              , AlexPosn (..)              , Alex (..)-             , Token (..)+             , Tok (..)              , Sym (..)              , Builtin (..)              , Var (..)@@ -175,6 +173,7 @@         "++"                     { mkSym PlusPlus }         ">>"                     { mkSym Sr }         "<<"                     { mkSym Sl }+        ∴                        { mkSym Therefore }         ⊖                        { mkSym Rotate }         ⊙                        { mkSym Cyc }         ˙                        { mkSym A1 }@@ -192,6 +191,7 @@         ∧                        { mkSym And }         ∨                        { mkSym Or }         ¬                        { mkSym Not }+        ⅟                        { mkSym Inv }          "]"                      { mkSym RSqBracket `andBegin` 0 } @@ -243,6 +243,27 @@         _"0x"$hexit+             { tok (\p s -> alex $ TokInt p (negate $ hexP $ BSL.drop 3 s)) }         $digitsubscript+         { tok (\p s -> alex $ TokIx p (parseSubscript $ mkText s)) } +        ¼                        { mkFloat 0.25 }+        ½                        { mkFloat 0.5 }+        ¾                        { mkFloat 0.75 }++        ⅓                        { mkFloat (1/3) }+        ⅕                        { mkFloat 0.2 }+        ⅙                        { mkFloat (1/6) }+        ⅐                        { mkFloat (1/7) }+        ⅛                        { mkFloat 0.125 }+        ⅑                        { mkFloat (1/9) }+        ⅒                        { mkFloat (1/10) }+        ⅔                        { mkFloat (2/3) }+        ⅖                        { mkFloat 0.4 }+        ¾                        { mkFloat 0.75 }+        ⅗                        { mkFloat 0.6 }+        ⅘                        { mkFloat 0.8 }+        ⅚                        { mkFloat (5/6) }+        ⅜                        { mkFloat 0.375 }+        ⅝                        { mkFloat 0.625 }+        ⅞                        { mkFloat 0.875 }+         @float                   { tok (\p s -> alex $ TokFloat p (read $ ASCII.unpack s)) }         _@float                  { tok (\p s -> alex $ TokFloat p (negate $ read $ ASCII.unpack $ BSL.tail s)) } @@ -265,6 +286,8 @@  mkBuiltin = constructor TokB +mkFloat = constructor TokFloat+ mkText :: BSL.ByteString -> T.Text mkText = decodeUtf8 . BSL.toStrict @@ -310,7 +333,8 @@          | Geq | Gt | Eq | Neq | Leq | Lt          | FoldA | FoldS | Tilde | Cyc | A1 | Mod          | AtDot | Eye | Para | Weier | Ice | B | Sharp-         | And | Or | Xor | Not | Sr | Sl | IDiv+         | And | Or | Xor | Not | Sr | Sl | IDiv | Inv+         | Therefore          deriving (Generic, NFData)  instance Pretty Sym where@@ -398,6 +422,8 @@     pretty IxTimes      = "×"     pretty Sr           = ">>"     pretty Sl           = "<<"+    pretty Therefore    = "∴"+    pretty Inv          = "⅟"  -- | Reserved/special variables data Var = VarX | VarY deriving (Generic, NFData)@@ -451,17 +477,17 @@     pretty BuiltinAbs    = "abs."     pretty BuiltinD      = "di." -data Token a = EOF { loc :: a }-             | TokSym { loc :: a, sym :: Sym }-             | TokName { loc :: a, _name :: Nm a }-             | TokIx { loc :: a, six :: Int }-             | TokB { loc :: a, _builtin :: Builtin }-             | TokResVar { loc :: a, _var :: Var }-             | TokInt { loc :: a, int :: Integer }-             | TokFloat { loc :: a, float :: Double }-             deriving (Generic, NFData)+data Tok = EOF { loc :: AlexPosn }+         | TokSym { loc :: AlexPosn, sym :: !Sym }+         | TokName { loc :: AlexPosn, _name :: !(Nm AlexPosn) }+         | TokIx { loc :: AlexPosn, six :: !Int }+         | TokB { loc :: AlexPosn, _builtin :: !Builtin }+         | TokResVar { loc :: AlexPosn, _var :: !Var }+         | TokInt { loc :: AlexPosn, int :: !Integer }+         | TokFloat { loc :: AlexPosn, float :: !Double }+         deriving (Generic, NFData) -instance Pretty (Token a) where+instance Pretty Tok where     pretty EOF{}           = "(eof)"     pretty (TokSym _ s)    = "symbol" <+> squotes (pretty s)     pretty (TokName _ n)   = "identifier" <+> squotes (pretty n)@@ -490,7 +516,7 @@ newIdentAlex pos t = do     st <- alexGetUserState     let (st', n) = newIdent pos t st-    alexSetUserState st' $> (n $> pos)+    alexSetUserState st' $> n  freshIdent :: AlexPosn -> T.Text -> Int -> (Int, Nm AlexPosn) freshIdent pos t max' =@@ -503,9 +529,6 @@         Just i  -> (pre, Nm t (U i) pos)         Nothing -> let i = max'+1; nNm = Nm t (U i) pos                    in ((i, M.insert t i ns, IM.insert i nNm us), nNm)--runAlexSt :: BSL.ByteString -> Alex a -> Either String (AlexUserState, a)-runAlexSt inp = withAlexSt inp alexInitUserState  withAlexSt :: BSL.ByteString -> AlexUserState -> Alex a -> Either String (AlexUserState, a) withAlexSt inp ust (Alex f) = first alex_ust <$> f

@@ -78,7 +78,7 @@ import           Ty import           Ty.M -data Err a = PErr (ParseE a) | TyErr (TyE a) | RErr RE deriving (Generic)+data Err a = PErr ParseE | TyErr (TyE a) | RErr RE deriving (Generic)  instance Pretty a => Show (Err a) where     show = show . pretty@@ -94,13 +94,13 @@  rwP st = fmap (uncurry renameECtx.second rewrite) . parseWithMaxCtx st -parseRenameCtx :: AlexUserState -> BSL.ByteString -> Either (ParseE AlexPosn) (E AlexPosn, Int)+parseRenameCtx :: AlexUserState -> BSL.ByteString -> Either ParseE (E AlexPosn, Int) parseRenameCtx st = fmap (uncurry renameECtx.second rewrite) . parseWithMaxCtx st  renameECtx :: Int -> E a -> (E a, Int) renameECtx i ast = let (e, m) = dedfn i ast in rG m e -parseRename :: BSL.ByteString -> Either (ParseE AlexPosn) (E AlexPosn, Int)+parseRename :: BSL.ByteString -> Either ParseE (E AlexPosn, Int) parseRename = parseRenameCtx alexInitUserState  tyC :: Int -> E a -> Either (Err a) (E (T ()), [(Nm a, C)], Int)@@ -154,16 +154,16 @@ aso (MovRCf () r0 f:Blr () r1:asms) | r0 == r1 = Bl () f:aso asms aso (asm:asms) = asm:aso asms; aso [] = [] -aarch64 :: BSL.ByteString -> Either (Err AlexPosn) (IR.AsmData, [AArch64 AReg FAReg ()])+aarch64 :: BSL.ByteString -> Either (Err AlexPosn) (IR.AsmData, [AArch64 AReg FAReg F2Reg ()]) aarch64 = fmap (second (Aarch64.opt . Aarch64.opt . uncurry Aarch64.gallocFrame).(\(x,aa,st) -> (aa,irToAarch64 st x))) . ir -x86G :: BSL.ByteString -> Either (Err AlexPosn) (IR.AsmData, [X86 X86Reg FX86Reg ()])+x86G :: BSL.ByteString -> Either (Err AlexPosn) (IR.AsmData, [X86 X86Reg FX86Reg F2X86 ()]) x86G = walloc (uncurry X86.gallocFrame) -eAarch64 :: Int -> E a -> Either (Err a) (IR.AsmData, [AArch64 AReg FAReg ()])+eAarch64 :: Int -> E a -> Either (Err a) (IR.AsmData, [AArch64 AReg FAReg F2Reg ()]) eAarch64 i = fmap (second (Aarch64.opt . Aarch64.opt . uncurry Aarch64.gallocFrame).(\(x,aa,st) -> (aa,irToAarch64 st x))) . eir i -ex86G :: Int -> E a -> Either (Err a) (IR.AsmData, [X86 X86Reg FX86Reg ()])+ex86G :: Int -> E a -> Either (Err a) (IR.AsmData, [X86 X86Reg FX86Reg F2X86 ()]) ex86G i = wallocE i (uncurry X86.gallocFrame)  eDumpX86 :: Int -> E a -> Either (Err a) (Doc ann)

@@ -14,7 +14,6 @@ import qualified Data.ByteString.Char8 as ASCII import Data.Functor (void) import qualified Data.Text as T-import Data.Typeable (Typeable) import GHC.Generics (Generic) import qualified Nm import Nm hiding (loc)@@ -25,9 +24,8 @@ }  %name parseE E-%name parseBind B-%tokentype { Token AlexPosn }-%error { parseError }+%tokentype { Tok }+%error { parseErr } %monad { Parse } { (>>=) } { pure } %lexer { lift alexMonadScan >>= } { EOF _ } @@ -45,6 +43,7 @@     polybind { TokSym $$ PolyBind }     semicolon { TokSym $$ Semicolon }     comma { TokSym $$ Comma }+    therefore { TokSym $$ Therefore }     underscore { TokSym $$ Underscore }     question { TokSym $$ QuestionMark }     condSplit { TokSym $$ CondSplit }@@ -85,6 +84,7 @@     rot { TokSym $$ Rotate }     sr { TokSym $$ L.Sr }     sl { TokSym $$ L.Sl }+    inv { TokSym $$ Inv }      plus { TokSym $$ L.Plus }     minus { TokSym $$ L.Minus }@@ -253,6 +253,7 @@      | ice { Builtin $1 Ices }      | para { Builtin $1 Filt }      | sr { Builtin $1 A.Sr } | sl { Builtin $1 A.Sl }+     | therefore { Builtin $1 C }  B :: { (Bnd, (Nm AlexPosn, E AlexPosn)) }   : name bind E { (L, ($1, $3)) }@@ -266,6 +267,8 @@   | pi { FLit $1 pi }   | tt { BLit $1 True }   | ff { BLit $1 False }+  | inv E { EApp $1 (EApp $1 (Builtin $1 Div) (FLit $1 1)) $2 }+  | parens(inv) { EApp $1 (Builtin $1 Div) (FLit $1 1) }   | parens(BBin) { $1 }   | lparen E BBin rparen { Parens $1 (EApp $1 $3 $2) }   | lparen BBin E rparen {% do { n <- lift $ freshName "x" ; pure (A.Lam $1 n (EApp $1 (EApp $1 $2 (Var (Nm.loc n) n)) $3)) } }@@ -323,8 +326,8 @@  { -parseError :: Token AlexPosn -> Parse a-parseError = throwError . Unexpected+parseErr :: Tok -> Parse a+parseErr = throwError . Unexpected  data Bnd = L | LL | D @@ -334,33 +337,33 @@ mkLet l ((LL, b):bs) e  = LLet l b (mkLet l bs e) mkLet l ((D, b):bs) e   = Def l b (mkLet l bs e) -data ParseE a = Unexpected (Token a)-              | LexErr String-              deriving (Generic)+data ParseE = Unexpected Tok+            | LexErr String+            deriving (Generic) -instance Pretty a => Pretty (ParseE a) where+instance Pretty ParseE where     pretty (Unexpected tok)  = pretty (loc tok) <+> "Unexpected" <+> pretty tok     pretty (LexErr str)      = pretty (T.pack str) -instance Pretty a => Show (ParseE a) where+instance Show ParseE where     show = show . pretty -instance (Pretty a, Typeable a) => Exception (ParseE a)+instance Exception ParseE -instance NFData a => NFData (ParseE a) where+instance NFData ParseE where -type Parse = ExceptT (ParseE AlexPosn) Alex+type Parse = ExceptT ParseE Alex -parseAll :: AlexUserState -> BSL.ByteString -> Either (ParseE AlexPosn) (AlexUserState, E AlexPosn)+parseAll :: AlexUserState -> BSL.ByteString -> Either ParseE (AlexUserState, E AlexPosn) parseAll = runParseSt parseE -parseWithMaxCtx :: AlexUserState -> BSL.ByteString -> Either (ParseE AlexPosn) (Int, E AlexPosn)+parseWithMaxCtx :: AlexUserState -> BSL.ByteString -> Either ParseE (Int, E AlexPosn) parseWithMaxCtx st b = fmap (first fst3) (parseAll st b) where fst3 (x, _, _) = x -runParseSt :: Parse a -> AlexUserState -> BSL.ByteString -> Either (ParseE AlexPosn) (AlexUserState, a)+runParseSt :: Parse a -> AlexUserState -> BSL.ByteString -> Either ParseE (AlexUserState, a) runParseSt parser u bs = liftErr $ withAlexSt bs u (runExceptT parser) -liftErr :: Either String (b, Either (ParseE a) c) -> Either (ParseE a) (b, c)+liftErr :: Either String (b, Either ParseE c) -> Either ParseE (b, c) liftErr (Left err)            = Left (LexErr err) liftErr (Right (_, Left err)) = Left err liftErr (Right (i, Right x))  = Right (i, x)

@@ -36,13 +36,15 @@ isBinOp Flat   = False isBinOp AddDim = False isBinOp RevE   = False+isBinOp C      = True isBinOp _      = True  fi :: Builtin -> Int+fi C = 9 fi Succ = 9; fi Fold = 9 fi IntExp = 8; fi Exp = 8 fi Times = 7; fi Div = 7; fi Mod = 7-fi Mul =7+fi Mul = 7; fi VMul = 7 fi Plus = 6; fi Minus = 6 fi And = 3; fi Or = 2; fi Xor = 6 fi Ices = 6; fi Filt=6@@ -82,6 +84,7 @@ rw (EApp l e0 e') =     case rw e' of         (EApp lϵ (EApp lϵϵ e3@(Builtin _ op) e4) e2) | isBinOp op -> EApp l (EApp lϵϵ e3 (rw $ EApp lϵ e0 e4)) e2+        (Ann lϵ e1 t)                                             -> Ann lϵ (rw $ EApp l e0 e1) t         (EApp lϵ e1@EApp{} e2)                                    -> EApp l (rw $ EApp lϵ e0 e1) e2         (EApp lϵ e1 e2)                                           -> EApp l (EApp lϵ (rw e0) e1) e2         eRw                                                       -> EApp l (rw e0) eRw

@@ -229,6 +229,11 @@ fsh :: T.Text -> TyM a (Sh ()) fsh n = SVar <$> freshN n () +fc :: T.Text -> a -> C -> TyM a (T ())+fc n l c = do+    n <- freshN n l+    pushVarConstraint n l c $> TVar (void n)+ ftv :: T.Text -> TyM a (T ()) ftv n = ft n () @@ -426,38 +431,28 @@  tyNumBinOp :: a -> TyM a (T (), Subst a) tyNumBinOp l = do-    n <- freshN "a" l-    let n' = TVar (void n)-    pushVarConstraint n l IsNum-    pure (n' ~> n' ~> n', mempty)+    n <- fc "a" l IsNum+    pure (n ~> n ~> n, mempty)  mm :: a -> TyM a (T (), Subst a) mm l = do-    n <- freshN "o" l-    let n' = TVar (void n)-    pushVarConstraint n l IsOrd-    pure (n' ~> n' ~> n', mempty)+    n <- fc "o" l IsOrd+    pure (n ~> n ~> n, mempty)  tyBoo :: a -> TyM a (T (), Subst a) tyBoo l = do-    n <- freshN "b" l-    let n'=TVar (void n)-    pushVarConstraint n l HasBits-    pure (n' ~> n' ~> n', mempty)+    n <- fc "b" l HasBits+    pure (n ~> n ~> n, mempty)  tyOrdBinRel :: a -> TyM a (T (), Subst a) tyOrdBinRel l = do-    n <- freshN "o" l-    let n' = TVar (void n)-    pushVarConstraint n l IsOrd-    pure (n' ~> n' ~> B, mempty)+    n <- fc "o" l IsOrd+    pure (n ~> n ~> B, mempty)  tyEqBinRel :: a -> TyM a (T (), Subst a) tyEqBinRel l = do-    n <- freshN "e" l-    let n'=TVar (void n)-    pushVarConstraint n l IsEq-    pure (n' ~> n' ~> B, mempty)+    n <- fc "e" l IsEq+    pure (n ~> n ~> B, mempty)  sel :: [Int] -> Sh a -> Sh a sel axes sh = roll Nil (fmap snd (filter ((`elem` axes) . fst) (zip [1..] unrolled))) where@@ -489,18 +484,15 @@ tyB _ Even = pure (I ~> B, mempty); tyB _ Odd = pure (I ~> B, mempty) tyB _ Sr = pure (I ~> I ~> I, mempty); tyB _ Sl = pure (I ~> I ~> I, mempty) tyB l R = do-    n <- freshN "a" l; sh <- freshN "sh" ()-    let n' = TVar (void n)-    pushVarConstraint n l IsNum-    pure (n' ~> n' ~> Arr (SVar sh) n', mempty)+    n <- fc "a" l IsNum; sh <- fsh "sh"+    pure (n ~> n ~> Arr sh n, mempty) tyB _ Iter = do{a <- ftv "a"; let s = Arrow a a in pure (s ~> I ~> s, mempty)} tyB _ ConsE = do     a <- ftv "a"; i <- fti "i"     pure (a ~> vV i a ~> vV (StaPlus () i (Ix()1)) a, mempty) tyB l Snoc = tyB l ConsE tyB _ A1 = do-    a <- ftv "a"; i <- fti "i"-    sh <- fsh "sh"+    a <- ftv "a"; i <- fti "i"; sh <- fsh "sh"     pure (Arr (i `Cons` sh) a ~> I ~> Arr sh a, mempty) tyB _ IOf = do     a <- ftv "a"; i <- fti "i"@@ -509,44 +501,43 @@     a <- ftv "a"; i <- fti "i"     pure (Arr (i `Cons` i `Cons` Nil) a ~> vV i a, mempty) tyB _ LastM = do-    a <- ftv "a"; i <- fti "i"-    pure (vV i a ~> a, mempty)+    a <- ftv "a"; i <- fti "i"; sh <- fsh "sh"+    pure (Arr (i `Cons` sh) a ~> Arr sh a, mempty) tyB _ Last = do-    a <- ftv "a"; i <- fti "i"-    pure (vV (StaPlus () i (Ix()1)) a ~> a, mempty)+    a <- ftv "a"; i <- fti "i"; sh <- fsh "sh"+    pure (Arr (StaPlus () i (Ix()1) `Cons` sh) a ~> Arr sh a, mempty) tyB _ Head = do-    a <- ftv "a"; i <- fti "i"-    pure (vV (StaPlus () i (Ix()1)) a ~> a, mempty)+    a <- ftv "a"; i <- fti "i"; sh <- fsh "sh"+    pure (Arr (StaPlus () i (Ix()1) `Cons` sh) a ~> Arr sh a, mempty) tyB _ Init = do-    a <- ftv "a"; i <- fti "i"-    pure (vV (StaPlus () i (Ix()1)) a ~> vV i a, mempty)+    a <- ftv "a"; i <- fti "i"; sh <- fsh "sh"+    pure (Arr (StaPlus () i (Ix()1) `Cons` sh) a ~> Arr (i `Cons` sh) a, mempty) tyB _ InitM = do-    a <- ftv "a"; i <- fti "i"; n <- ftie-    pure (vV i a ~> vV n a, mempty)+    a <- ftv "a"; i <- fti "i"; n <- ftie; sh <- fsh "sh"+    pure (Arr (i `Cons` sh) a ~> Arr (n `Cons` sh) a, mempty) tyB _ Tail = do-    a <- ftv "a"; i <- fti "i"-    pure (vV (StaPlus () i (Ix()1)) a ~> vV i a, mempty)+    a <- ftv "a"; i <- fti "i"; sh <- fsh "sh"+    pure (Arr (StaPlus () i (Ix()1) `Cons` sh) a ~> Arr (i `Cons` sh) a, mempty) tyB _ TailM = do-    a <- ftv "a"; i <- fti "i"; n <- ftie-    pure (vV i a ~> vV n a, mempty)+    a <- ftv "a"; i <- fti "i"; n <- ftie; sh <- fsh "sh"+    pure (Arr (i `Cons` sh) a ~> Arr (n `Cons` sh) a, mempty) tyB _ Rot = do-    a <- ftv "a"; i <- fti "i"-    pure (I ~> vV i a ~> vV i a, mempty)+    a <- ftv "a"; i <- fti "i"; sh <- fsh "sh"+    pure (I ~> Arr (i `Cons` sh) a ~> Arr (i `Cons` sh) a, mempty) tyB _ Cyc = do     sh <- fsh "sh"; a <- ftv "a"; i <- fti "i"; n <- ftie     pure (Arr (i `Cons` sh) a ~> I ~> Arr (n `Cons` sh) a, mempty) tyB _ HeadM = do-    a <- ftv "a"; i <- fti "i"-    pure (vV i a ~> a, mempty)+    a <- ftv "a"; i <- fti "i"; sh <- fsh "sh"+    pure (Arr (i `Cons` sh) a ~> Arr sh a, mempty) tyB _ Re = do     a <- ftv "a"; n <- ftie     pure (I ~> a ~> Arr (n `Cons` Nil) a, mempty) tyB _ FRange = do {n <- ftie; pure (F ~> F ~> I ~> Arr (n `Cons` Nil) F, mempty)} tyB _ Fib = do-    n <- ftie; a <- freshN "a" ()-    let a' = TVar a-        arrTy = Arr (n `Cons` Nil) a'-    pure (a' ~> a' ~> (a' ~> a' ~> a') ~> I ~> arrTy, mempty)+    n <- ftie; a <- ftv "a"+    let arrTy = Arr (n `Cons` Nil) a+    pure (a ~> a ~> (a ~> a ~> a) ~> I ~> arrTy, mempty) tyB _ IRange = do {n <- ftie; pure (I ~> I ~> I ~> Arr (n `Cons` Nil) I, mempty)} tyB l Plus = tyNumBinOp l; tyB l Minus = tyNumBinOp l tyB l Times = tyNumBinOp l@@ -554,27 +545,19 @@ tyB l Lte = tyOrdBinRel l; tyB l Eq = tyEqBinRel l; tyB l Neq = tyEqBinRel l tyB l And = tyBoo l; tyB l Or = tyBoo l; tyB l Xor = tyBoo l tyB l N = do-    n <- freshN "b" l-    let n'=TVar (void n)-    pushVarConstraint n l HasBits-    pure (n' ~> n', mempty)+    n <- fc "b" l HasBits+    pure (n ~> n, mempty) tyB _ Exp = pure (F ~> F ~> F, mempty) tyB l Min = mm l; tyB l Max = mm l tyB l IntExp = do-    n <- freshN "a" l-    let n' = TVar (void n)-    pushVarConstraint n l IsNum-    pure (n' ~> I ~> n', mempty)+    n <- fc "a" l IsNum+    pure (n ~> I ~> n, mempty) tyB l Neg = do-    n <- freshN "a" l-    let n' = TVar (void n)-    pushVarConstraint n l IsNum-    pure (n' ~> n', mempty)+    n <- fc "a" l IsNum+    pure (n ~> n, mempty) tyB l Abs = do-    n <- freshN "a" l-    let n' = TVar (void n)-    pushVarConstraint n l IsNum-    pure (n' ~> n', mempty)+    n <- fc "a" l IsNum+    pure (n ~> n, mempty) tyB _ Sqrt = pure (F ~> F, mempty) tyB _ Log = pure (F ~> F, mempty) tyB _ Div = pure (F ~> F ~> F, mempty)@@ -594,10 +577,9 @@     sh <- fsh "sh"; a <- ftv "a"     pure (Arr sh a ~> Arr (Ix()1 `Cons` sh) a, mempty) tyB _ CatE = do-    i <- freshN "i" (); j <- freshN "j" ()-    n <- freshN "a" ()-    let i' = IVar () i; j' = IVar () j; n' = TVar n-    pure (vV i' n' ~> vV j' n' ~> vV (StaPlus () i' j') n', mempty)+    i <- fti "i"; j <- fti "j"+    n <- ftv "a"+    pure (vV i n ~> vV j n ~> vV (StaPlus () i j) n, mempty) tyB _ Scan = do     a <- ftv "a"; i <- fti "i"; sh <- fsh "sh"     let i1 = StaPlus () i (Ix()1)@@ -620,59 +602,48 @@         t = Arrow (Arr (foldr Cons sh (zipWith (StaPlus ()) is nx)) a) (Arr (foldr Cons Nil is) b)     pure (opTy ~> t, mempty) tyB _ Succ = do-    sh <- fsh "sh"-    i <- fti "i"+    i <- fti "i"; sh <- fsh "sh"     a <- ftv "a"; b <- ftv "b"     let opTy = a ~> (a ~> b)     pure (opTy ~> (Arr (StaPlus () i (Ix () 1) `Cons` sh) a ~> Arr (i `Cons` sh) b), mempty) tyB _ (TAt i) = do     ρ <- freshN "ρ" ()-    a <- freshN "a" ()-    let aV = TVar a-    pure (Ρ ρ (IM.singleton i aV) ~> aV, mempty)+    a <- ftv "a"+    pure (Ρ ρ (IM.singleton i a) ~> a, mempty) tyB _ Map = do-    ix <- freshN "i" ()-    a <- freshN "a" (); b <- freshN "b" ()-    let arrSh = IVar () ix `Cons` Nil -- TODO: sh??-        a' = TVar a; b' = TVar b-        fTy = a' ~> b'-        gTy = Arr arrSh a' ~> Arr arrSh b'+    i <- fti "i"+    a <- ftv "a"; b <- ftv "b"+    let fTy = a ~> b+        gTy = vV i a ~> vV i b     -- depends on Arr nil a = a, Arr (i+j) a = Arr i (Arr j sh)     pure (fTy ~> gTy, mempty) tyB _ Zip = do-    i <- freshN "i" ()-    a <- freshN "a" (); b <- freshN "b" (); c <- freshN "c" ()-    let arrSh = vx (IVar () i)-        a' = TVar a; b' = TVar b; c' = TVar c-        fTy = a' ~> b' ~> c'-        gTy = Arr arrSh a' ~> Arr arrSh b' ~> Arr arrSh c'+    i <- fti "i"+    a <- ftv "a"; b <- ftv "b"; c <- ftv "c"+    let fTy = a ~> b ~> c+        gTy = vV i a ~> vV i b ~> vV i c     pure (fTy ~> gTy, mempty) tyB l (Rank as) = do-    let ixN n = zipWithM (\_ c -> freshN (T.singleton c) ()) [1..n] ['i'..]-    shs <- traverse (\(i,ax) -> do {is <- ixN (maybe i maximum ax); sh <- fsh "sh"; pure $ foldr Cons sh (IVar () <$> is)}) as+    let ixN n = zipWithM (\_ c -> fti (T.singleton c)) [1..n] ['i'..]+    shs <- traverse (\(i,ax) -> do {is <- ixN (maybe i maximum ax); sh <- fsh "sh"; pure $ foldr Cons sh is}) as     vs <- zipWithM (\_ c -> ftv (T.singleton c)) as ['a'..]-    codSh <- freshN "sh" ()+    codSh <- fsh "sh"     cod <- ftv "c"     let mArrs = zipWith Arr shs vs-        codTy = Arr (SVar codSh) cod+        codTy = Arr codSh cod         fTy = foldr (~>) cod $ zipWith3 (\ax sh t -> case ax of {(_,Nothing) -> Arr (trim sh) t;(_,Just axs) -> Arr (sel axs sh) t}) as shs vs         rTy = foldr (~>) codTy mArrs         shsU = zipWith (\ax sh -> case ax of {(n,Nothing) -> tydrop n sh;(_,Just axs) -> del axs sh}) as shs         shUHere sh sh' = fmap snd (liftU $ mgShPrep LF l mempty (sh$>l) (sh'$>l))-    s <- zipWithM shUHere shsU (tail shsU++[SVar codSh])+    s <- zipWithM shUHere shsU (tail shsU++[codSh])     pure (fTy ~> rTy, mconcat s) tyB _ Fold = do-    ix <- fti "i"; sh <- fsh "sh"-    a <- freshN "a" ()-    let sh1 = StaPlus () ix (Ix()1) `Cons` sh-        a' = TVar a-    pure ((a' ~> a' ~> a') ~> Arr sh1 a' ~> Arr sh a', mempty)+    i <- fti "i"; sh <- fsh "sh"; a <- ftv "a"+    let sh1 = StaPlus () i (Ix()1) `Cons` sh+    pure ((a ~> a ~> a) ~> Arr sh1 a ~> Arr sh a, mempty) tyB _ FoldS = do-    ix <- fti "i"; sh <- fsh "sh";-    a <- freshN "a" ()-    let sh1 = ix `Cons` sh-        a' = TVar a-    pure ((a' ~> a' ~> a') ~> a' ~> Arr sh1 a' ~> Arr sh a', mempty)+    i <- fti "i"; sh <- fsh "sh"; a <- ftv "a"+    pure ((a ~> a ~> a) ~> a ~> Arr (i `Cons` sh) a ~> Arr sh a, mempty) tyB _ Foldl = do     ix <- fti "i"; sh <- fsh "sh"; a <- ftv "a"     let sh1 = ix `Cons` sh@@ -697,22 +668,16 @@     let arrTy = Arr (n `Cons` Nil) a     pure (a ~> (a ~> a) ~> I ~> arrTy, mempty) tyB l Mul = do-    a <- freshN "a" l+    a <- fc "a" l IsNum     i <- fti "i"; j <- fti "j"; k <- fti "k"-    pushVarConstraint a l IsNum-    let a' = TVar (void a)-    pure (Arr (i `Cons` j `Cons` Nil) a' ~> Arr (j `Cons` k `Cons` Nil) a' ~> Arr (i `Cons` k `Cons` Nil) a', mempty)+    pure (Arr (i `Cons` j `Cons` Nil) a ~> Arr (j `Cons` k `Cons` Nil) a ~> Arr (i `Cons` k `Cons` Nil) a, mempty) tyB l VMul = do-    a <- freshN "a" l+    a <- fc "a" l IsNum     i <- fti "i"; j <- fti "j"-    pushVarConstraint a l IsNum-    let a' = TVar (void a)-    pure (Arr (i `Cons` j `Cons` Nil) a' ~> vV j a' ~> vV i a', mempty)+    pure (Arr (i `Cons` j `Cons` Nil) a ~> vV j a ~> vV i a, mempty) tyB l Eye = do-    a <- freshN "a" l; i <- fti "i"-    pushVarConstraint a l IsNum-    let a'=TVar (void a)-    pure (Arr (i `Cons` i `Cons` Nil) a', mempty)+    a <- fc "a" l IsNum; i <- fti "i"+    pure (Arr (i `Cons` i `Cons` Nil) a, mempty) tyB _ Sin = pure (F ~> F, mempty) tyB _ Cos = pure (F ~> F, mempty) tyB _ Tan = pure (F ~> F, mempty)@@ -722,6 +687,9 @@ tyB _ Filt = do     a <- ftv "a"; i <- fti "i"; n <- ftie     pure ((a ~> B) ~> vV i a ~> vV n a, mempty)+tyB _ C = do+    a <- ftv "a"; b <- ftv "b"; c <- ftv "c"+    pure ((b ~> c) ~> (a ~> b) ~> a ~> c, mempty)  liftCloneTy :: T b -> TyM a (T b, IM.IntMap Int) liftCloneTy t = do@@ -796,17 +764,18 @@ chkE _         = Right ()  checkTy :: T a -> (C, a) -> Either (TyE a) (Maybe (Nm a, C))-checkTy (TVar n) (c, _)  = pure $ Just(n, c)-checkTy I (IsNum, _)     = pure Nothing-checkTy F (IsNum, _)     = pure Nothing-checkTy I (IsOrd, _)     = pure Nothing-checkTy I (HasBits, _)   = pure Nothing-checkTy B (HasBits, _)   = pure Nothing-checkTy F (IsOrd, _)     = pure Nothing-checkTy I (IsEq, _)      = pure Nothing-checkTy F (IsEq, _)      = pure Nothing-checkTy t (c@IsNum, l)   = Left$ Doesn'tSatisfy l t c-checkTy t (c@HasBits, l) = Left$ Doesn'tSatisfy l t c+checkTy (TVar n) (c, _)       = pure $ Just(n, c)+checkTy I (IsNum, _)          = pure Nothing+checkTy F (IsNum, _)          = pure Nothing+checkTy I (IsOrd, _)          = pure Nothing+checkTy I (HasBits, _)        = pure Nothing+checkTy B (HasBits, _)        = pure Nothing+checkTy F (IsOrd, _)          = pure Nothing+checkTy I (IsEq, _)           = pure Nothing+checkTy F (IsEq, _)           = pure Nothing+checkTy t (c@IsNum, l)        = Left$ Doesn'tSatisfy l t c+checkTy t (c@HasBits, l)      = Left$ Doesn'tSatisfy l t c+checkTy (Arr _ t) c@(IsEq, l) = checkTy t c  substI :: Subst a -> Int -> Maybe (T a) substI s@(Subst ts is sh) i =@@ -895,9 +864,8 @@ tyE s (FLit _ x) = pure (FLit F x, s) tyE s (BLit _ x) = pure (BLit B x, s) tyE s (ILit l m) = do-    n <- freshN "a" l-    pushVarConstraint n l IsNum-    pure (ILit (TVar (void n)) m, s)+    n <- fc "a" l IsNum+    pure (ILit n m, s) tyE s (Builtin l b) = do {(t,sϵ) <- tyB l b ; pure (Builtin t b, sϵ<>s)} tyE s (Lam _ nϵ e) = do     n <- ftv "a"

@@ -73,14 +73,19 @@ ata _ = Nothing  dynI :: I a -> Bool-dynI Ix{}    = False-dynI IVar{}  = True-dynI IEVar{} = True+dynI Ix{}      = False+dynI IVar{}    = True+dynI IEVar{}   = True+dynI StaPlus{} = True+dynI StaMul{}  = True  dynSh :: Sh a -> Bool dynSh SVar{}      = True dynSh Nil         = False dynSh (Cons i sh) = dynI i || dynSh sh+dynSh Rev{}       = True+dynSh Cat{}       = True+dynSh Π{}         = True  foldMapAlternative :: (Traversable t, Alternative f) => (a -> f b) -> t a -> f b foldMapAlternative f xs = asum (f <$> xs)

@@ -74,12 +74,14 @@     , testCase "bessel1" $ do { res <- fpIff "math/bessel.apple" 1 3 ; res @?= bessel1 1 3 }     , testCase "amgm" $ do { res <- fpFff "math/amgm.apple" 1 (sqrt 2) ; res @?= agm 1 (sqrt 2) }     , testCase "transpose" $ do { (AA 2 [2, 3] res) <- fpAa "test/data/T.apple" (AA 2 [3,2] [1,2,3,4,5,6::Double]); res @?= [1,3,5,2,4,6::Double] }+    , testCase "whiten" $ do { (AA 2 [3,3] res) <- fpAa "math/stats/whiten.apple" (AA 2 [3,3] [1.9,2.3,1.7,1.5,2.5,2.2,0.8,0.6,1.7::Double]); res @?= [4.179442778108569,2.698113510169924,7.212489168102781,3.299560087980449,2.9327320762716567,9.333809511662423,1.7597653802562396,0.7038556983051976,7.212489168102781::Double] }     , testCase "vmul builtin" $ do { (AA 1 [3] res) <- fpAaa "test/data/vb.apple" (AA 2 [3,2] [1,2,3,4,5,6::Double]) (AA 1 [2] [1,1::Double]); res @?= [3,7,11::Double] }     , testCase "vmul builtin" $ do { (AA 1 [2] res) <- fpAaa "test/data/vb.apple" (AA 2 [2,3] [1,2,3,4,5,6::Double]) (AA 1 [3] [1,1,1::Double]); res @?= [6,15::Double] }     , testCase "vmul" $ do { (AA 1 [3] res) <- fpAaa "test/data/vmul.apple" (AA 2 [3,2] [1,2,3,4,5,6::Double]) (AA 1 [2] [1,1::Double]); res @?= [3,7,11::Double] }     -- 3,4,5 instead of 4,5,6!     , testCase "vmul" $ do { (AA 1 [2] res) <- fpAaa "test/data/vmul.apple" (AA 2 [2,3] [1,2,3,4,5,6::Double]) (AA 1 [3] [1,1,1::Double]); res @?= [6,15::Double] }     , testCase "matmul builtin" $ do { (AA 2 [2, 2] res) <- fpAaa "test/data/mul.apple" (AA 2 [2,3] [2,1,1,5,4,1::Double]) (AA 2 [3,2] [2,0,2,0,7,3::Double]); res @?= [13,3,25,3::Double] }+    , testCase "mul-of-transp" $ do { (AA 2 [2, 2] res) <- fpAaa "test/data/mulT.apple" (AA 2 [2,3] [2,1,1,5,4,1::Double]) (AA 2 [2,3] [2,2,7,0,0,3::Double]); res @?= [13,3,25,3::Double] }     , testCase "matmul" $ do { (AA 2 [2, 2] res) <- fpAaa "test/examples/mul.apple" (AA 2 [2,3] [2,1,1,5,4,1::Double]) (AA 2 [3,2] [2,0,2,0,7,3::Double]); res @?= [13,3,25,3::Double] }     , testCase "map" $ do { (AA 2 [2, 2] res) <- fpAaa "test/data/map.apple" (AA 2 [2,2] [1,2,3,4::Double]) (AA 1 [2] [3,5::Double]); res @?= [4,7,6,9::Double] }     , testCase "luhn check" $ do { res <- fpAi "test/examples/luhn.apple" [4,0,1,2,8,8,8,8,8,8,8,8,1,8,8,1]; res @?= 1 }@@ -104,11 +106,19 @@     , testCase "k-l" $ do { res <- jitKl [0.25, 0.25, 0.5] [0.66, 0.33, 0] ; res @?= kl [0.25, 0.25, 0.5] [0.66, 0.33, 0] }     , testCase "fizzbuzz" $ do { (AA 1 [10] res) <- fpAa "test/examples/fizzbuzz.apple" (AA 1 [10] [0..9::Double]); res @?= [15.0,3.0,0.0,3.0,5.0,3.0,0.0,0.0,3.0,0.0::Double] }     , testCase "filt" $ do { (AA 1 [10] res) <- fpAa "test/examples/partition.apple" (AA 1 [10] [0..9::Double]); res @?= [F,F,F,F,F,F,T,T,T,T] }+    , testCase "softmax" $ do { (AA 2 [2,2] res) <- fpAa "test/data/softmax.apple" (AA 2 [2,2] [0.25,0.75,0.3,0.5::Double]); res @?= [0.4875026035157896,0.5621765008857981,0.5124973964842103,0.4378234991142019::Double] }     , testCase "gamma" $ do { res <- gammaJit (-3.5) ; res @?= gamma (-3.5) }     , testCase "tcdf" $ do { res <- fpFff "math/tcdf.apple" 2 12 ; res ≈ tcdf 12 2 }     , testCase "fcdf" $ do { res <- fpFfff "math/fcdf.apple" 5 2 2 ; res @?= 0.6339381452606089 }     , testCase "chi-squared cdf" $ do { res <- fpFff "math/chisqcdf.apple" 2 2 ; res @?= chisqcdf 2 2 }+    , testCase "chi-squared cdf" $ do { res <- fpFff "math/chisqcdf.apple" 10 28 ; res @?= chisqcdf 10 28 }     , testCase "ramanujan" $ do { res <- fpFf "test/examples/ramanujanFact.apple" 7 ; res ≈ 5040 }+    , testCase "conv (1-d)" $+        let v = AA 1 [10] [1..10::Double]+        in do { res0 <- fpAa "bench/apple/maxWindow.apple" v; res1 <- fpAa "bench/apple/convMax.apple" v; (res0 :: Apple Double) @?= res1 }+    , testCase "ix" $+        let v = AA 1 [20] [1..20::Int64]+        in do { res0 <- fpAa "bench/apple/evens.apple" v; res1 <- fpAa "bench/apple/evenIx.apple" v; (res0 :: Apple Int64) @?= res1 }     ,  rfTest     ] 

@@ -1,1 +1,1 @@-[|:(x::Arr(i`Cons`j`Cons`Nil)float)]+[|:(x::M float)]

@@ -0,0 +1,1 @@+λx.λy.(}. (gen. (x,y) [{a⟜x->1;g⟜x->2;((a+g)%2,√(a*g))}] 6))->1

@@ -1,19 +0,0 @@--- aₙ, bₙ, cₙ, dₙ in Kuhl+Giardina-λxs.λys.λn.-  { sum ← [(+)/x]-  ; tieSelf ← [({.x)⊳x]; Δ ← [(-)\~(tieSelf x)]-  ; dxs ⟜ Δ xs; dys ⟜ Δ ys-  ; dts ⟜ [√(x^2+y^2)]`dxs dys-  ; dxss ⟜ ((%)`dxs dts); dyss ⟜ ((%)`dys dts)-  ; pts ⟜ (+)Λₒ 0 dts ; T ⟜}. pts-  ; n ⟜ ℝn; k ⟜ 2*n*𝜋-  ; scaleRad ← [k*x%T]-  ; cosDiffs ⟜ (-)\~([cos.(scaleRad x)]' pts)-  ; sinDiffs ⟜ (-)\~([sin.(scaleRad x)]' pts)-  ; c ⟜ T%(2*n^2*𝜋^2)-  ; aₙ ← c*sum ((*)`dxss cosDiffs)-  ; bₙ ← c*sum ((*)`dxss sinDiffs)-  ; cₙ ← c*sum ((*)`dyss cosDiffs)-  ; dₙ ← c*sum ((*)`dyss sinDiffs)-  ; (aₙ,bₙ,cₙ,dₙ)-  }

@@ -1,2 +1,2 @@ -- mean filter-([((+)/* 0 (x::Arr (2`Cons`2`Cons`Nil) float))%ℝ(:x)] ⨳ {2,2})+([((+)/* 0 (x::Arr (2 × 2) float))%ℝ(:x)] ⨳ {2,2})

@@ -1,1 +1,1 @@-[cos.(2*𝜋*x)*√(_2*_.y)]`((𝔯 0 1)::Vec 1000 float) (𝔯 0 1)+[cos.(2*𝜋*x)*√(_2*_.y)]`(𝔯 0 1::Vec 1000 float) (𝔯 0 1)

@@ -0,0 +1,1 @@+[(x::M float)%.⍉y]

@@ -2,5 +2,5 @@ λho.λwo.λbo.   { sigmoid ← [1%(1+ℯ(_x))]   -- prediction: 4-  ; sigmoid'((+bo)'(ho%:wo))+  ; (sigmoid ∴ (+bo))'(ho%:wo)   }

@@ -1,1 +0,0 @@-[(+) Λ 0 (⍳ 1 x 1)]

@@ -6,5 +6,5 @@   { m ⟜ (⋉)/* _1 xs; a ⟜ [e:(x-m)]`{0} xs   ; sum ← [(+)/x]   ; n ⟜ sum`{1∘[1]} (a::M float)-  ; ⍉(([(%x)'y]`{0,1∘[1]} n a))+  ; ⍉([(%x)'y]`{0,1∘[1]} n a)   }

@@ -3,20 +3,20 @@ λwh.λwo.λbh.λbo. { X ⟜ ⟨⟨0,0⟩,⟨0,1⟩,⟨1,0⟩,⟨1,1⟩⟩;   Y ⟜ ⟨0,1,1,0⟩;-  sigmoid ← [1%(1+ℯ(_x))];+  sigmoid ← [⅟(1+ℯ(_x))];   sDdx ← [x*(1-x)];   sum ⇐ [(+)/x];   -- ho: 4x2   -- prediction: 4   ho ⟜ sigmoid`{0} ([(+)`bh x]'(X%.wh));-  prediction ⟜ sigmoid'((+bo)'(ho%:wo));+  prediction ⟜ (sigmoid ∴ (+bo))'(ho%:wo);   l1E ← (-)`Y prediction;   l1Δ ⟜ (*)`(sDdx'prediction) l1E; -- 4   he ← l1Δ (*)⊗ wo; -- 4x2   hΔ ⟜ (*)`{0,0} (sDdx`{0} ho) he; -- 4x2   wha ← (+)`{0,0} wh ((|:X)%.hΔ);   woa ← (+)`wo ((|:ho)%:l1Δ);-  bha ← sum'((<|)`{0,1} bh hΔ);+  bha ← [(+)/ₒ x y]`{0,1} bh hΔ;   boa ← bo + sum l1Δ;   (wha,woa,bha,boa) }

@@ -1,1 +1,1 @@-[(x::Arr (i`Cons`j`Cons`Nil) float)%:y]+[(x::Arr (i × j) float)%:y]

@@ -2,5 +2,5 @@ {   dot ⇐ [(+)/((*)`x y)];   -- "iterate over second axis" (i.e. columns)-  (dot x)`{1∘[2]} (A::Arr (i`Cons`j`Cons`Nil) float)+  (dot x)`{1∘[2]} (A::Arr (i × j) float) }

@@ -1,1 +1,1 @@-\n.(√(2*𝜋))*n**(n+1%2)*(e:(_n))+\n.(√(2*𝜋))*n**(n+½)*(e:(_n))

@@ -1,1 +1,1 @@-[{m⟜(⋉)/(x::Vec n float); (=m)@.x}]+[{m⟜(⋉)/x::Vec n float; (=m)@.x}]

@@ -1,16 +1,15 @@ -- aₙ, bₙ, cₙ, dₙ in Kuhl+Giardina λxs.λys.λN.   { sum ← [(+)/x]-  ; tieSelf ← [({.x)⊳x]; Δ ← [(-)\~(tieSelf x)]+  ; tieSelf ← [({.x)⊳x]; Δ ← ((-)\~) ∴ tieSelf   ; dxs ⟜ Δ xs; dys ⟜ Δ ys   ; dts ⟜ [√(x^2+y^2)]`dxs dys   ; dxss ⟜ ((%)`dxs dts); dyss ⟜ ((%)`dys dts)   ; pts ⟜ (+)Λₒ 0 dts; T ⟜}. pts   ; coeffs ← λn.-    { n ⟜ ℝn; k ⟜ 2*n*𝜋-    ; scaleRad ← [k*x%T]-    ; cosDiffs ⟜ (-)\~([cos.(scaleRad x)]'pts)-    ; sinDiffs ⟜ (-)\~([sin.(scaleRad x)]'pts)+    { n ⟜ ℝn; k ⟜ 2*n*𝜋%T+    ; cosDiffs ⟜ (-)\~((cos. ∴ (k*))'pts)+    ; sinDiffs ⟜ (-)\~((sin. ∴ (k*))'pts)     ; c ⟜ T%(2*n^2*𝜋^2)     ; aₙ ← c*sum ((*)`dxss cosDiffs)     ; bₙ ← c*sum ((*)`dxss sinDiffs)

@@ -1,2 +1,2 @@ -- mean filter-([((+)/* 0 (x::Arr (7`Cons`7`Cons`Nil) float))%ℝ(:x)] ⨳ {7,7})+([((+)/* 0 (x::Arr (7 × 7) float))%ℝ(:x)] ⨳ {7,7})

@@ -1,1 +1,1 @@-[(+)/ ((*)`((x::Arr (i `Cons` Nil) float)) y)]+[(+)/ ((*)`(x::Vec n float) y)]

@@ -1,15 +1,14 @@ λxs.λys.λN.   { sum ← [(+)/x]-  ; tieSelf ← [({.x)⊳x]; Δ ← [(-)\~(tieSelf x)]+  ; tieSelf ← [({.x)⊳x]; Δ ← ((-)\~) ∴ tieSelf   ; dxs ⟜ Δ xs; dys ⟜ Δ ys   ; dts ⟜ [√(x^2+y^2)]`dxs dys   ; dxss ⟜ ((%)`dxs dts); dyss ⟜ ((%)`dys dts)   ; pxs ← (+)Λ dxs; pys ← (+)Λ dys; pts ⟜ (+)Λₒ 0 dts; T ⟜}. pts   ; coeffs ← λn.-    { n ⟜ ℝn; k ⟜ 2*n*𝜋-    ; scaleRad ← [k*x%T]-    ; cosDiffs ⟜ (-)\~([cos.(scaleRad x)]'pts)-    ; sinDiffs ⟜ (-)\~([sin.(scaleRad x)]'pts)+    { n ⟜ ℝn; k ⟜ 2*n*𝜋%T+    ; cosDiffs ⟜ (-)\~((cos. ∴ (k*))'pts)+    ; sinDiffs ⟜ (-)\~((sin. ∴ (k*))'pts)     ; c ⟜ T%(2*n^2*𝜋^2)     ; aₙ ← c*sum ((*)`dxss cosDiffs)     ; bₙ ← c*sum ((*)`dxss sinDiffs)@@ -21,7 +20,7 @@   ; ppts ⟜ {: pts   ; 𝜉 ← (-)`pxs ((*)`((%)`dxs dts) ppts)   ; 𝛿 ← (-)`pys ((*)`((%)`dys dts) ppts)-  ; A ← ((sum ((*)`((%)`dxs dts) dtss))%2 + (sum ((*)`𝜉 dts)))%T-  ; C ← ((sum ((*)`((%)`dys dts) dtss))%2 + (sum ((*)`𝛿 dts)))%T+  ; A ← (0.5*sum ((*)`((%)`dxs dts) dtss) + sum ((*)`𝜉 dts))%T+  ; C ← (0.5*sum ((*)`((%)`dys dts) dtss) + sum ((*)`𝛿 dts))%T   ; (coeffs'(irange 1 N 1),A,C)   }

@@ -1,2 +1,2 @@ -- upper bound on the factorial: https://math.stackexchange.com/questions/676952/is-ramanujans-approximation-for-the-factorial-optimal-or-can-it-be-tweaked-a-\n.(√𝜋)*((n%(e:1))**n)*((8*n^3+4*n^2+n+1%100)**(1%6))+\n.(√𝜋)*((n%(e:1))**n)*((8*n^3+4*n^2+n+1%100)**⅙)

@@ -1,1 +1,1 @@-λas.λbs. {sum ⇐ [(+)/x]; 0.5*abs.(sum((*)`as (1⊖bs)) - sum((*)`(1⊖as) bs))}+λas.λbs. {sum ⇐ [(+)/x]; ½*abs.(sum((*)`as (1⊖bs)) - sum((*)`(1⊖as) bs))}

@@ -1,5 +1,5 @@--- x: 600000x784--- targets: 600000x10+-- x: 60000x784+-- targets: 60000x10 λx.λtargets. λl1.λl2.   {@@ -7,7 +7,7 @@       { m ⟜ (⋉)/* _1 xs; a ⟜ [e:(x-m)]`{0} xs       ; sum ← [(+)/x]       ; n ⟜ sum`{1} (a::M float)-      ; ⍉(([(%x)'y]`{0,1} n a))+      ; ⍉([(%x)'y]`{0,1} n a)       };     dsoftmax ← λxs.         { m ⟜ (⋉)/* _1 xs; a ⟜ [e:(x-m)]`{0} xs@@ -22,7 +22,7 @@     xl2p ⟜ xSigmoid%.l2;     out ← softmax xl2p;     -- bw-    error ⟜ (*)`{0,0} ({n⟜ℝ(𝓉out); [2*x%n]`{0} ((-)`{0,0} out targets)}) (dsoftmax xl2p);+    error ⟜ (*)`{0,0} ({n⟜2%(ℝ(𝓉out)); [x*n]`{0} ((-)`{0,0} out targets)}) (dsoftmax xl2p);     ul2 ← (⍉xSigmoid)%.error;     ul1 ← (⍉x)%.((*)`{0,0} (⍉(l2%.(⍉error))) (dsigmoid xl1p));     ((+)`{0,0} l1 ul1, (+)`{0,0} l2 ul2)

@@ -1,1 +1,1 @@-\n.(√(2*𝜋))*n**(n+1%2)*(e:(_n))+\n.(√(2*𝜋))*n**(n+½)*(e:(_n))

@@ -2,8 +2,8 @@ {   x ⟜  ♭`{3∘[2,3,4]} (trainImages :: Arr (60000 × 28 × 28 × 1) float);   targets ⟜ (λn.[?x=n,.1::float,.0]'irange 0 9 1)'trainLabels;-  l1init ← (𝔯 0 1) :: M ₇₈₄,₁₂₈ float;-  l2init ← (𝔯 0 1); -- :: M ₁₂₈,₁₀ float;+  l1init ← 𝔯 0 1 :: M ₇₈₄,₁₂₈ float;+  l2init ← 𝔯 0 1; -- 128×10   train ←     λl1.λl2.       {@@ -11,14 +11,9 @@           { m ⟜ (⋉)/* _1 xs; a ⟜ [e:(x-m)]`{0} xs           ; sum ← [(+)/x]           ; n ⟜ sum`{1} (a::M float)-          ; ⍉(([(%x)'y]`{0,1} n a))+          ; ⍉([(%x)'y]`{0,1} n a)           };-        dsoftmax ← λxs.-            { m ⟜ (⋉)/* _1 xs; a ⟜ [e:(x-m)]`{0} xs-            ; sum ← [(+)/x]-            ; n ⟜ sum`{1} (a::M float)-            ; ⍉([x*(1-x)]`{0} ([(%x)'y]`{0,1} n a))-            };+        dsoftmax ← λxs. [x*(1-x)]`{0} (softmax xs);         dsigmoid ← ((λx.⸎x⟜ℯ(_x);x%(1+x)^2)`{0});         -- fw         xl1p ⟜ x%.l1;

@@ -8,7 +8,7 @@     -- ho: 4x2     { ho ← sigmoid`{0} ([(+)`bh x]'(X%.wh))     -- prediction: 4-    ; prediction ← sigmoid'((+bo)'(ho%:wo))+    ; prediction ← (sigmoid ∴ (+bo))'(ho%:wo)     ; (ho,prediction)     };   -- wh: 2x2 wo: 2 bh: 2 bo: (scalar)@@ -22,7 +22,7 @@     ; hΔ ← (*)`{0,0} (sDdx`{0} ho) he -- 4x2     ; wha ← (+)`{0,0} wh ((|:X)%.hΔ)     ; woa ← (+)`wo ((|:ho)%:l1Δ)-    ; bha ← sum'((<|)`{0,1} bh hΔ)+    ; bha ← [(+)/ₒ x y]`{0,1} bh hΔ     ; boa ← bo + sum l1Δ     ; (wha,woa,bha,boa)     };