diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# apple + +## 0.1.0.0 + +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,14 @@ +Copyright (C) 2022 Vanessa McHale + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU Affero General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Affero General Public License for more details. + +You should have received a copy of the GNU Affero General Public License +along with this program. If not, see . diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,144 @@ +# Apple Array System + +Many cases are not implemented. This is provided as an artefact. + +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. + +Spilling (during register allocation) is not implemented for Arm. Also +floating-point registers aren't spilled on x86. + +## Compiler-As-a-Library + +Rather than an environment-based interpreter or a compiler invoked on the +command line and generating object files, one calls a library function which +returns assembly or machine code from a source string. + +Thus the same implementation can be used interpreted, compiled, or called from +another language. + +``` + > [((+)/x)%ℝ(:x)]\`7 (frange 1 10 10) +Arr (4) [4.0, 5.0, 6.0, 7.0] +``` + +```python +>>> import apple +>>> import numpy as np +>>> sliding_mean=apple.jit('([((+)/x)%(ℝ(:x))]\`7)') +>>> apple.f(sliding_mean,np.arange(0,10,dtype=np.float64)) +array([3., 4., 5., 6.]) +>>> +``` + +```R +> source("R/apple.R") +> sliding_mean<-jit("([((+)/x)%ℝ(:x)]\\`7)") +> run(sliding_mean,seq(0,10,1.0)) +[1] 3 4 5 6 7 +``` + +## Dimension As a Functor + +This is based on J (and APL?). Looping is replaced by functoriality (rerank). + +To supply a zero-cells (scalars) as the first argument to `⊲` (cons) and 1-cells as the second: + +``` +(⊲)`{0,1} +``` + +We can further specify that the cells should be selected along some axis, e.g. +to get vector-matrix multiplication: + +``` +λA.λx. +{ + dot ⇐ [(+)/((*)`x y)]; + (dot x)`{1∘[2]} (A::Arr (i`Cons`j`Cons`Nil) float) +} +``` + +The `2` means "iterate over the second axis" i.e. columns. + +## Installation + +Use [ghcup](https://www.haskell.org/ghcup/) to install [cabal](https://www.haskell.org/cabal/) and GHC. Then: + +``` +make install +``` + +to install `arepl` (the REPL). + +Run + +``` +make +sudo make install-lib +``` + +To install the shared library. + +### Python + +To install the Python module: + +``` +make install-py +``` + +### R + +Install `libappler.so` on your system like so: + +``` +make -C Rc +sudo make install-r +``` + +Then: + +``` +source("R/apple.R") +``` + +to access the functions. + +## Documentation + +Type `\l` in the REPL to show the reference card: + +``` + > \l +Λ scan √ sqrt +⋉ max ⋊ min +⍳ integer range ⌊ floor +ℯ exp ⨳ {m,n} convolve +\~ successive application \`n dyadic infix +_. log 'n map +` zip `{i,j∘[k,l]} rank +𝒻 range (real) 𝜋 pi +_ negate : size +𝓉 dimension }.? last +->n select ** power +gen. generate 𝓕 fibonacci +re: repeat }. typesafe last +⊲ cons ⊳ snoc +^: iterate %. matmul +⊗ outer product |: transpose +{.? head {. typesafe head +}.? last }: typesafe init +⟨z,w⟩ array literal ?p,.e1,.e2 conditional +... +``` + +Enter `:help` in REPL: + +``` + > :help +:help, :h Show this help +:ty Display the type of an expression +... +``` diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,32 @@ +module Main (main) where + +import Control.Exception (throwIO) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Version as V +import Options.Applicative +import P +import qualified Paths_apple as P + +fp :: Parser FilePath +fp = argument str + (metavar "SRC_FILE" + <> help "Source file") + +wrapper :: ParserInfo FilePath +wrapper = info (helper <*> versionMod <*> fp) + (fullDesc + <> progDesc "Editor integration for the Apple language" + <> header "atc - apple type checker") + +versionMod :: Parser (a -> a) +versionMod = infoOption (V.showVersion P.version) (short 'V' <> long "version" <> help "Show version") + +main :: IO () +main = run =<< execParser wrapper + +run :: FilePath -> IO () +run fpϵ = do + contents <- BSL.readFile fpϵ + case tyParse contents of + Left err -> throwIO err + Right{} -> pure () diff --git a/apple.cabal b/apple.cabal new file mode 100644 --- /dev/null +++ b/apple.cabal @@ -0,0 +1,337 @@ +cabal-version: 2.0 +name: apple +version: 0.1.0.0 +license: AGPL-3 +license-file: LICENSE +copyright: Copyright: (c) 2022 Vanessa McHale +maintainer: vamchale@gmail.com +author: Vanessa McHale +synopsis: Apple array language compiler +description: Compiler for a typed, APL-inspired array language. +category: Language, Array +build-type: Simple +data-files: ./include/apple_abi.h +extra-source-files: + include/apple.h + include/apple_p.h + test/examples/*.apple + test/examples/*.apple + bench/apple/*.apple + test/data/*.apple + test/data/*.apple + test/harness/*.c + math/*.apple + math/*.apple + +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/vmchale/apple + +library + exposed-modules: + Dbg + P + A + Ty + Ty.M + Nm + U + I + L + Parser + CGen + Hs.A + Hs.FFI + Sys.DL + Prettyprinter.Ext + build-tool-depends: + alex:alex >=3.5.0.0, happy:happy, hsc2hs:hsc2hs, c2hs:c2hs + + hs-source-dirs: src + other-modules: + Bits + CF + CF.AL + LI + R + LR + R.Dfn + R.M + R.R + Parser.Rw + Ty.Clone + A.Eta + A.Opt + Op + C + C.Alloc + C.CF + C.Trans + IR + IR.CF + IR.Hoist + IR.Opt + IR.C + Class.E + Data.Copointed + Asm.Ar + Asm.Ar.P + Asm.L + Asm.LI + Asm.BB + Asm.X86 + Asm.X86.B + Asm.X86.Byte + Asm.X86.CF + Asm.X86.Opt + Asm.X86.Frame + Asm.X86.P + Asm.X86.Sp + Asm.X86.Trans + Asm.Aarch64 + Asm.Aarch64.B + Asm.Aarch64.Byte + Asm.Aarch64.CF + Asm.Aarch64.Fr + Asm.Aarch64.P + Asm.Aarch64.Opt + Asm.Aarch64.T + Asm.G + Asm.M + Asm.CF + Nm.IntMap + + default-language: Haskell2010 + other-extensions: + DeriveGeneric DeriveAnyClass OverloadedStrings StandaloneDeriving + RankNTypes FlexibleContexts DeriveFoldable DeriveFunctor + ScopedTypeVariables TupleSections BinaryLiterals MagicHash + MultiParamTypeClasses GeneralizedNewtypeDeriving + + ghc-options: + -Wall -fno-warn-missing-signatures -Wno-x-partial + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities -Wmissing-export-lists + -Wcpp-undef + + build-depends: + base >=4.17 && <5, + prettyprinter >=1.7.0, + deepseq, + text, + mtl >=2.2.2, + containers >=0.6.0.1, + microlens, + microlens-mtl >=0.1.8.0, + array, + bytestring, + transformers, + unix, + split >=0.2.0.0, + extra >=1.7.4, + composition-prelude >=1.1.0.1, + dom-lt + + if impl(ghc >=8.10) + ghc-options: -Wunused-packages + + if impl(ghc >=9.2) + ghc-options: -Wno-operator-whitespace-ext-conflict + +library as + exposed-modules: + H + other-modules: Nasm, As + + hs-source-dirs: as + default-language: Haskell2010 + ghc-options: + -Wall -Wno-x-partial -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints -Widentities + -Wmissing-export-lists -Wcpp-undef + + build-depends: + base, + apple, + process, + temporary, + prettyprinter, + text, + bytestring + + if impl(ghc >=8.10) + ghc-options: -Wunused-packages + +foreign-library apple + type: native-shared + build-tool-depends: c2hs:c2hs >=0.19.1 + hs-source-dirs: lib + other-modules: E + default-language: Haskell2010 + include-dirs: include + install-includes: apple.h + ghc-options: + -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Wmissing-export-lists + + build-depends: + base, + apple, + bytestring >=0.11.0.0, + prettyprinter >=1.7.0, + text + + if os(linux) + lib-version-info: 1:0:0 + + if os(windows) + options: standalone + + if impl(ghc >=8.10) + ghc-options: -Wunused-packages + +executable atc + main-is: Main.hs + hs-source-dirs: app + other-modules: Paths_apple + autogen-modules: Paths_apple + default-language: Haskell2010 + ghc-options: + -Wall -Wno-x-partial -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints -Widentities + -Wmissing-export-lists -Wcpp-undef + + build-depends: + base, + apple, + optparse-applicative >=0.13.0.0, + bytestring + + if impl(ghc >=8.10) + ghc-options: -Wunused-packages + +executable writeo + main-is: Main.hs + hs-source-dirs: exe + other-modules: Paths_apple + autogen-modules: Paths_apple + default-language: Haskell2010 + ghc-options: + -Wall -Wno-x-partial -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints -Widentities + -Wcpp-undef -Wmissing-export-lists + + build-depends: + base, + as, + optparse-applicative >=0.14.0.0, + text + + if impl(ghc >=8.10) + ghc-options: -Wunused-packages + +executable arepl + main-is: Main.hs + other-modules: QC + hs-source-dirs: run + default-language: Haskell2010 + ghc-options: + -Wall -Wno-missing-signatures -Wno-x-partial + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities -Wmissing-export-lists + -Wcpp-undef -Wno-operator-whitespace-ext-conflict + + build-depends: + base, + apple, + bytestring, + libffi, + criterion, + prettyprinter, + haskeline, + mtl, + transformers, + text, + directory, + filepath, + extra, + QuickCheck, + containers, + split >=0.2.0.0 + + if impl(ghc >=8.10) + ghc-options: -Wunused-packages + +test-suite apple-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: cpphs:cpphs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: + -threaded -rtsopts "-with-rtsopts=-N -k1k" -Wall + -fno-warn-missing-signatures -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints -Widentities + -Wmissing-export-lists -Wcpp-undef + + build-depends: + base, + apple, + tasty, + tasty-hunit, + bytestring, + hypergeometric >=0.1.4.0 + + if impl(ghc >=8.10) + ghc-options: -Wunused-packages + +test-suite apple-o + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: of + default-language: Haskell2010 + ghc-options: + -rtsopts -with-rtsopts=-k1k -Wall + -fno-warn-missing-signatures -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints -Widentities + -Wmissing-export-lists -Wcpp-undef + + build-depends: + base, + as, + tasty, + tasty-hunit, + temporary, + process, + text, + filepath, + directory + + if impl(ghc >=8.10) + ghc-options: -Wunused-packages + +benchmark apple-bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: + -rtsopts -Wall -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints -Widentities + -Wmissing-export-lists -Wcpp-undef + + build-depends: + base, + apple, + criterion, + statistics, + bytestring, + erf, + hypergeometric >=0.1.2.0 + + if impl(ghc >=8.10) + ghc-options: -Wunused-packages diff --git a/as/As.hs b/as/As.hs new file mode 100644 --- /dev/null +++ b/as/As.hs @@ -0,0 +1,26 @@ +module As ( writeO ) where + +import qualified Data.ByteString.Lazy as BSL +import Data.Functor (void) +import qualified Data.Text as T +import qualified Data.Text.Lazy.IO as TLIO +import P +import Prettyprinter (layoutCompact) +import Prettyprinter.Render.Text (renderLazy) +import System.Info (arch, os) +import System.IO (hFlush) +import System.IO.Temp (withSystemTempFile) +import System.Process (CreateProcess (..), StdStream (Inherit), proc, readCreateProcess) + +writeO :: T.Text -- ^ Function name + -> BSL.ByteString + -> Bool -- ^ Debug symbols? + -> IO () +writeO f contents dbg = withSystemTempFile "apple.S" $ \fp h -> do + let txt = renderLazy $ layoutCompact (as f contents) + TLIO.hPutStr h txt + hFlush h + let debugFlag = if dbg then ("-g":) else id + {-# SCC "as" #-} void $ readCreateProcess ((proc exe (debugFlag [fp, "-o", fpO])) { std_err = Inherit }) "" + where fpO = T.unpack f <> ".o" + exe=case (arch, os) of {("aarch64",_) -> "as"; (_,"linux") -> "aarch64-linux-gnu-as"} diff --git a/as/H.hs b/as/H.hs new file mode 100644 --- /dev/null +++ b/as/H.hs @@ -0,0 +1,25 @@ +module H ( Arch (..), run ) where + +import qualified As +import CGen +import Control.Exception (Exception, throwIO) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as T +import qualified Nasm +import P +import Prettyprinter.Render.Text (hPutDoc) +import System.IO (IOMode (WriteMode), withFile) + +data Arch = Aarch64 | X64 + +run :: (FilePath, Arch, T.Text) -> IO () +run (fpϵ, a, n) = do + contents <- BSL.readFile fpϵ + ct <- cS contents + let asm=case a of {X64 -> Nasm.writeO; Aarch64 -> As.writeO} + asm n contents True + withFile (T.unpack n <> ".h") WriteMode $ \h -> hPutDoc h ct + where cS s = do {t <- yIO (fst<$>getTy s); yIO $ pCty n t} + +yIO :: Exception x => Either x a -> IO a +yIO = either throwIO pure diff --git a/as/Nasm.hs b/as/Nasm.hs new file mode 100644 --- /dev/null +++ b/as/Nasm.hs @@ -0,0 +1,24 @@ +module Nasm ( writeO ) where + +import qualified Data.ByteString.Lazy as BSL +import Data.Functor (void) +import qualified Data.Text as T +import qualified Data.Text.Lazy.IO as TLIO +import Dbg +import Prettyprinter (layoutCompact) +import Prettyprinter.Render.Text (renderLazy) +import System.IO (hFlush) +import System.IO.Temp (withSystemTempFile) +import System.Process (CreateProcess (..), StdStream (Inherit), proc, readCreateProcess) + +writeO :: T.Text -- ^ Function name + -> BSL.ByteString + -> Bool -- ^ Debug symbols? + -> IO () +writeO f contents dbg = withSystemTempFile "apple.S" $ \fp h -> do + let txt = renderLazy $ layoutCompact (nasm f contents) + TLIO.hPutStr h txt + hFlush h + let debugFlag = if dbg then ("-g":) else id + {-# SCC "nasm" #-} void $ readCreateProcess ((proc "nasm" (debugFlag [fp, "-f", "elf64", "-o", fpO])) { std_err = Inherit }) "" + where fpO = T.unpack f <> ".o" diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,144 @@ +module Main (main) where + +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.Marshal.Alloc (free, mallocBytes) +import Foreign.Ptr (FunPtr, Ptr) +import Foreign.Storable (Storable (..)) +import Hs.A +import I +import qualified Math.Hypergeometric as Hyper +import qualified Math.SpecialFunction as Math +import P +import Statistics.Distribution (cumulative) +import Statistics.Distribution.StudentT (studentT) +import System.Info (arch) +import Ty + +risingFactorial :: Integral a => a -> a -> a +risingFactorial x n = product [x..(x+n-1)] +{-# SPECIALIZE risingFactorial :: Int -> Int -> Int #-} + +hsEntropy :: Floating a => [a] -> a +hsEntropy xs = sum [ x * log x | x <- xs ] + +kl :: Floating a => [a] -> [a] -> a +kl xs ys = sum (zipWith (\x y -> x * log (x/y)) xs ys) + +aA :: Storable a => Apple a -> IO (U a) +aA x = do + p <- mallocBytes (sizeOf x) + poke p x $> p + +leakFp = fmap fst.case arch of {"aarch64" -> aFunP; "x86_64" -> funP} + +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.🍎" + erfFp <- fmap ff . leakFp =<< BSL.readFile "math/erf.🍏" + 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.🍏" + ᴀ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.🍏" + 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 "arm (fcdf)" $ nf aarch64 ꜰ + , bench "arm (tcdf)" $ nf aarch64 t + , bench "arm (A)" $ nf aarch64 ᴀ + ] + -- TODO: thunks after type checking? + , env (fmap yeet erfParsed) $ \ast -> + bgroup "ty" + [ bench "tyClosed" $ nf (\(e, m) -> tyClosed m e) ast + ] + , env (fmap yeet erfTy) $ \e -> + bgroup "inline" + [ bench "inline" $ nf (\(ast, i) -> fst (inline i ast)) e + ] + , bgroup "erf" + [ bench "erf (libm)" $ nf erf (1 :: Double) + , bench "erf (hypergeometric)" $ nf Hyper.erf (1 :: Double) + , bench "erf (jit)" $ nfIO (pure $ erfFp 1) + ] + , bgroup "risingFactorial" + [ bench "hs" $ nf (risingFactorial 5) (15 :: Int64) + , bench "jit" $ nf (fp 5) 15 + ] + , bgroup "entropy" + [ bench "hs" $ nf hsEntropy xs + , bench "jit" $ nfIO $ (pure $ entropyFp xsPtr) + ] + , bgroup "k-l" + [ bench "hs" $ nf (kl xs) ys + , bench "jit" $ nfIO (pure $ klFp xsPtr ysPtr) + ] + , bgroup "ncdf" + [ bench "lib" $ nf normcdf (2 :: Double) + , bench "jit" $ nf ncdfFp 2 + ] + , bgroup "tcdf" + [ bench "hs" $ nf (Math.tcdf (12::Double)) (2::Double) + , bench "stat" $ nf (cumulative (studentT 12)) 2 + , bench "jit" $ nf (tcdfFp 2) 12 + ] + , bgroup "Γ" + [ 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}) + ] + , 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) ] + ] + where erfSrc = BSL.readFile "math/erf.🍏" + gamma = BSL.readFile "math/gamma.🍏" + tcdf = BSL.readFile "math/tcdf.🍎" + xor = BSL.readFile "test/examples/xor.🍎" + fcdf = BSL.readFile "math/fcdf.🍎" + offA = BSL.readFile "test/examples/ellipticFourier.🍎" + files = (,,,,) <$> tcdf <*> xor <*> gamma <*> fcdf <*> offA + erfParsed = parseRename <$> erfSrc + erfTy = tyParse <$> erfSrc + yeet :: (Exception e) => Either e a -> a + yeet = either throw id + xs = replicate 500 (0.002 :: Double) + ys = replicate 500 (0.002 :: Double) + +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" 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" 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)) diff --git a/bench/apple/scanmax.apple b/bench/apple/scanmax.apple new file mode 100644 --- /dev/null +++ b/bench/apple/scanmax.apple @@ -0,0 +1,3 @@ +-- see https://pythonspeed.com/articles/numba-faster-python/ and also +-- http://blog.vmchale.com/article/numba-why +[(⋉) Λₒ 0 (x::Arr (i `Cons` Nil) int)] diff --git a/bench/apple/scanmaxf.apple b/bench/apple/scanmaxf.apple new file mode 100644 --- /dev/null +++ b/bench/apple/scanmaxf.apple @@ -0,0 +1,1 @@ +[(⋉)Λₒ 0 (x::Arr (i `Cons` Nil) float)] diff --git a/bench/apple/vize.apple b/bench/apple/vize.apple new file mode 100644 --- /dev/null +++ b/bench/apple/vize.apple @@ -0,0 +1,1 @@ +((λn.[?x=n,.1::float,.0]'irange 0 9 1)') diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -0,0 +1,50 @@ +module Main (main) where + +import qualified Data.Text as T +import qualified Data.Version as V +import H +import Options.Applicative +import qualified Paths_apple as P +import System.Info (arch) + +fp :: Parser FilePath +fp = argument str + (metavar "SRC_FILE" + <> help "Source file") + +fun :: Parser T.Text +fun = strOption + (short 'f' + <> metavar "FUNCTION" + <> help "Function name in generated .o") + +farch :: Parser Arch +farch = fmap parseArch $ optional $ strOption + (long "arch" + <> metavar "ARCH" + <> help "Target architecture" + <> completer (listCompleter ["x64", "aarch64"])) + where parseArch :: Maybe String -> Arch + parseArch str' = case (str', arch) of + (Nothing, "aarch64") -> Aarch64 + (Nothing, "x86_64") -> X64 + (Just "aarch64", _) -> Aarch64 + (Just "arm64", _) -> Aarch64 + (Just "x64", _) -> X64 + (Just "x86_64", _) -> X64 + (Just "x86-64", _) -> X64 + (Just "amd64", _) -> X64 + _ -> error "Failed to parse architecture! Try one of x64, aarch64" + +wrapper :: ParserInfo (FilePath, Arch, T.Text) +wrapper = info (helper <*> versionMod <*> p) + (fullDesc + <> header "Output object files with Apple array system" + <> progDesc "writeo - generate object files") + where p = (,,) <$> fp <*> farch <*> fun + +versionMod :: Parser (a -> a) +versionMod = infoOption (V.showVersion P.version) (short 'V' <> long "version" <> help "Show version") + +main :: IO () +main = run =<< execParser wrapper diff --git a/include/apple.h b/include/apple.h new file mode 100644 --- /dev/null +++ b/include/apple.h @@ -0,0 +1,23 @@ +#include +typedef intptr_t P; + +// exp, log, pow can be NULL on X86 +typedef struct JC {P ma; P free;P r;P xr;P e;P log;P pow;} JC; + +void* apple_compile(JC*,const char*,size_t*,void**); + +// NULL on error +// first argument: source +// second argument: error return +char* apple_printty(const char*, char**); +char* apple_dumpasm(const char*, char**); +char* apple_x86(const char*, char**); +char* apple_aarch64(const char*, char**); +char* apple_dumpir(const char*, char**); + +enum apple_t{I_t,F_t,B_t,IA,FA,BA}; + +typedef struct FnTy {int argc; enum apple_t* args; enum apple_t res;} FnTy; + +// NULL on error +FnTy* apple_ty(const char*, char**); diff --git a/include/apple_abi.h b/include/apple_abi.h new file mode 100644 --- /dev/null +++ b/include/apple_abi.h @@ -0,0 +1,41 @@ +#include +#include +#include + +#define R return + +#undef I + +typedef double F;typedef int64_t J; typedef void* U; typedef bool B; + +#define DO(i,n,a) {J i;for(i=0;i)) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Word (Word8, Word64) +import Dbg +import Foreign.C.String (CString) +import Foreign.C.Types (CInt (..), CSize (..), CChar) +import Foreign.Marshal.Alloc (mallocBytes) +import Foreign.Ptr (Ptr, castPtr, castFunPtrToPtr, nullPtr) +import Foreign.Storable (poke, pokeByteOff, sizeOf) +import Prettyprinter (Doc, Pretty) +import Prettyprinter.Ext +import System.Info (arch) + +#include +#include +#include + +data FnTy +data JitCtx + +{# fun memcpy as ^ { castPtr `Ptr a', castPtr `Ptr a', coerce `CSize' } -> `Ptr a' castPtr #} + +{# enum apple_t as CT {} #} + +ct :: CType -> CT +ct CR = F_t; ct CI = I_t; ct CB = B_t +ct Af = FA; ct Ai = IA; ct Ab = BA + +t32 :: CType -> CInt +t32 = fromIntegral.fromEnum.ct + +tcstr :: T.Text -> IO CString +tcstr t = + BS.unsafeUseAsCStringLen (encodeUtf8 t) $ \(bs,sz) -> do + p <- mallocBytes (sz+1) + _ <- memcpy p bs (fromIntegral sz) + pokeByteOff p sz (0::CChar) $> p + +harnessString :: Pretty a => (BSL.ByteString -> Either a (Doc ann)) -> CString -> Ptr CString -> IO CString +harnessString oup src errPtr = do + bSrc <- BS.unsafePackCString src + case oup (BSL.fromStrict bSrc) of + Left err -> + (poke errPtr =<< tcstr (ptxt err)) $> nullPtr + Right d -> tcstr (aText d) + +apple_dumpasm, apple_x86, apple_aarch64 :: CString -> Ptr CString -> IO CString +apple_dumpasm = case arch of {"aarch64" -> apple_aarch64; "x86_64" -> apple_x86} + +apple_x86 = harnessString dumpX86G + +apple_aarch64 = harnessString dumpAarch64 + +apple_dumpir :: CString -> Ptr CString -> IO CString +apple_dumpir = harnessString dumpIR + +apple_printty :: CString -> Ptr CString -> IO CString +apple_printty = harnessString tyExpr + +apple_ty :: CString -> Ptr CString -> IO (Ptr FnTy) +apple_ty src errPtr = do + bSrc <- BS.unsafePackCString src + let b = getTy (BSL.fromStrict bSrc) + case b of + Left err -> do + poke errPtr =<< tcstr (ptxt err) + pure nullPtr + Right (t, []) -> + case tCTy t of + Left te -> do {poke errPtr =<< tcstr (ptxt te); pure nullPtr} + Right (tis, to) -> do + let argc = length tis + sp <- mallocBytes {# sizeof FnTy #} + ip <- mallocBytes (argc * sizeOf (undefined::CInt)) + {# set FnTy.argc #} sp (fromIntegral argc) + {# set FnTy.res #} sp (t32 to) + zipWithM_ (\ti n -> do + pokeByteOff ip (n * sizeOf (undefined::CInt)) (t32 ti)) tis [0..] + {# set FnTy.args #} sp ip + pure sp + +cfp = case arch of {"aarch64" -> actxFunP; "x86_64" -> ctxFunP.fst} +jNull x p = case x of {Nothing -> poke p nullPtr; Just xϵ -> poke p xϵ} + +apple_compile :: Ptr JitCtx -> CString -> Ptr CSize -> Ptr (Ptr Word64) -> IO (Ptr Word8) +apple_compile jp src szPtr sPtr = do + m <- il <$> {# get JC->ma #} jp + f <- il <$> {# get JC->free #} jp + r <- il <$> {# get JC->r #} jp + xr <- il <$> {# get JC->xr #} jp + e <- il <$> {# get JC->e #} jp + l <- il <$> {# get JC->log #} jp + p <- il <$> {# get JC->pow #} jp + bSrc <- BS.unsafePackCString src + (sz, fp, aa) <- cfp ((m,f,xr,r), (e,l,p)) (BSL.fromStrict bSrc) + jNull aa sPtr + poke szPtr (fromIntegral sz) $> castFunPtrToPtr fp + where + il = fromIntegral + +foreign export ccall apple_compile :: Ptr JitCtx -> CString -> Ptr CSize -> Ptr (Ptr Word64) -> IO (Ptr Word8) +foreign export ccall apple_printty :: CString -> Ptr CString -> IO CString +foreign export ccall apple_dumpasm :: CString -> Ptr CString -> IO CString +foreign export ccall apple_dumpir :: CString -> Ptr CString -> IO CString +foreign export ccall apple_ty :: CString -> Ptr CString -> IO (Ptr FnTy) diff --git a/math/amgm.apple b/math/amgm.apple new file mode 100644 --- /dev/null +++ b/math/amgm.apple @@ -0,0 +1,1 @@ +λx.λy.([{a⟜x->1;g⟜x->2;((a+g)%2,√(a*g))}]^:6 (x,y))->1 diff --git a/math/bessel.apple b/math/bessel.apple new file mode 100644 --- /dev/null +++ b/math/bessel.apple @@ -0,0 +1,9 @@ +λ𝛼.λx. + { fact ← [(*)/ₒ 1 (⍳ 1 x 1)] + ; f10 ← λa.λx. + { rf ← [(*)/ₒ 1 (𝒻 x (x+y-1) (⌊y))]; ffact ← rf 1 + ; mkIx ← λk. {kk⟜ℝ k; (x^k%(rf a kk))%ffact kk} + ; (+)/(mkIx'(⍳ 0 30 1)) + } + ; ((x%2)^𝛼%ℝ(fact 𝛼))*f10 (ℝ(𝛼+1)) (_((x^2)%4)) + } diff --git a/math/chisqcdf.apple b/math/chisqcdf.apple new file mode 100644 --- /dev/null +++ b/math/chisqcdf.apple @@ -0,0 +1,39 @@ +λk.λx. +{ + -- lower incomplete gamma + 𝛾 ← λa.λx. + { + f11 ← λa.λb.λz. + { + 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 + }; + ((x**a)%a)*f11 a (1+a) (_x) + }; + Γ ← λz. + { + zz ⟜ z-1; + c0 ← 0.999999999999997092; + 𝛾 ← 607%128; + coeffs ← ⟨ 57.1562356658629235 + , _59.5979603554754912 + , 14.1360979747417471 + , _0.491913816097620199 + , 0.339946499848118887e-4 + , 0.465236289270485756e-4 + , _0.983744753048795646e-4 + , 0.158088703224912494e-3 + , _0.210264441724104883e-3 + , 0.217439618115212643e-3 + , _0.164318106536763890e-3 + , 0.844182239838527433e-4 + , _0.261908384015814087e-4 + , 0.368991826595316234e-5 + ⟩; + ss ← (+)/ ([y%(zz+ℝ x)]`(⍳ 1 14 1) coeffs); + e:((((zz+0.5)*(_.(zz+𝛾+0.5)))-(zz+𝛾+0.5))+_.((√(2*𝜋))*(c0+ss))) + }; + 𝛾 (k%2) (x%2)%Γ(k%2) +} diff --git a/math/completeElliptic.apple b/math/completeElliptic.apple new file mode 100644 --- /dev/null +++ b/math/completeElliptic.apple @@ -0,0 +1,5 @@ +λk. +{ + agm ← λx.λy.([{a⟜x->1;g⟜x->2;((a+g)%2,√(a*g))}]^:6 (x,y))->1; + 𝜋%(2*agm 1 (√(1-k^2))) +} diff --git a/math/erf.apple b/math/erf.apple new file mode 100644 --- /dev/null +++ b/math/erf.apple @@ -0,0 +1,7 @@ +-- https://mathworld.wolfram.com/Erf.html +λz. +{ + ffact ← [(*)/ₒ 1 (𝒻 1 x (⌊x))]; + Σ ← λN.λa. (+)/ₒ 0 (a'(⍳ 0 N 1)); + (2%√𝜋)*Σ 30 (λn. {nf⟜ℝn; ((_1^n)*z^(2*n+1))%((ffact nf)*(2*nf+1))}) +} diff --git a/math/f11.apple b/math/f11.apple new file mode 100644 --- /dev/null +++ b/math/f11.apple @@ -0,0 +1,6 @@ +λ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))}) +} diff --git a/math/fcdf.apple b/math/fcdf.apple new file mode 100644 --- /dev/null +++ b/math/fcdf.apple @@ -0,0 +1,43 @@ +λn.λm.λx. +{ + incΒ ← λz.λa.λb. + { + f21 ← λa0.λa1.λb.λz. + { + rf ← [(*)/ₒ 1 (𝒻 x (x+y-1) (⌊y))]; fact ← rf 1; + Σ ← λN.λa. (+)/ₒ 0 (a'(⍳ 0 N 1)); + term ← λn. {nn⟜ℝ n; ((rf a0 nn)*(rf a1 nn)%(rf b nn))*((z^n)%(fact nn))}; + Σ 30 term + }; + ((z**a)%a)*f21 a (1-b) (a+1) z + }; + Β ← λx.λy. + { + Γ ⟜ λz. + { + zz ⟜ z-1; + c0 ← 0.999999999999997092; + 𝛾 ← 607%128; + coeffs ← ⟨ 57.1562356658629235 + , _59.5979603554754912 + , 14.1360979747417471 + , _0.491913816097620199 + , 0.339946499848118887e-4 + , 0.465236289270485756e-4 + , _0.983744753048795646e-4 + , 0.158088703224912494e-3 + , _0.210264441724104883e-3 + , 0.217439618115212643e-3 + , _0.164318106536763890e-3 + , 0.844182239838527433e-4 + , _0.261908384015814087e-4 + , 0.368991826595316234e-5 + ⟩; + ss ← (+)/ ([y%(zz+ℝ x)]`(⍳ 1 14 1) coeffs); + e:((((zz+0.5)*_.(zz+𝛾+0.5))-(zz+𝛾+0.5))+_.((√(2*𝜋))*(c0+ss))) + }; + Γ x*Γ y%Γ (x+y) + }; + I ← λz.λa.λb. incΒ z a b%Β a b; + I ((n*x)%(m+n*x)) (n%2) (m%2) +} diff --git a/math/gamma.apple b/math/gamma.apple new file mode 100644 --- /dev/null +++ b/math/gamma.apple @@ -0,0 +1,26 @@ +λz. + { Γ ← λz. + { + zz ⟜ z-1; + c0 ← 0.999999999999997092; + 𝛾 ← 607%128; + coeffs ← ⟨ 57.1562356658629235 + , _59.5979603554754912 + , 14.1360979747417471 + , _0.491913816097620199 + , 0.339946499848118887e-4 + , 0.465236289270485756e-4 + , _0.983744753048795646e-4 + , 0.158088703224912494e-3 + , _0.210264441724104883e-3 + , 0.217439618115212643e-3 + , _0.164318106536763890e-3 + , 0.844182239838527433e-4 + , _0.261908384015814087e-4 + , 0.368991826595316234e-5 + ⟩; + ss ← (+)/([y%(zz+itof x)]`(⍳ 1 14 1) coeffs); + (((zz+0.5)*_.(zz+𝛾+0.5))-(zz+𝛾+0.5))+_.((√(2*𝜋))*(c0+ss)) + }; + e:(?z≥0.5,.Γ z,.(_.𝜋)-(_.(sin.(𝜋*z)))-Γ(1-z)) + } diff --git a/math/hypergeometric.apple b/math/hypergeometric.apple new file mode 100644 --- /dev/null +++ b/math/hypergeometric.apple @@ -0,0 +1,6 @@ +λa.λb.λz. +{ + rf ← [(*)/ₒ 1 (𝒻 x (x+y-1) (⌊y))]; fact ← rf 1; + Σ ← λ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)}) +} diff --git a/math/log.apple b/math/log.apple new file mode 100644 --- /dev/null +++ b/math/log.apple @@ -0,0 +1,6 @@ +λm.λx. +{ + amgm ← λx.λy.([{a⟜x->1;g⟜x->2;((a+g)%2,√(a*g))}]^:15 (x,y))->1; + -- m>2 + 𝜋%(2*amgm 1 (0.5^(m-2)%x))-ℝ m*0.6931471805599453 +} diff --git a/math/n.apple b/math/n.apple new file mode 100644 --- /dev/null +++ b/math/n.apple @@ -0,0 +1,2 @@ +-- http://dspguide.com/ch2/6.htm +cos.(2*𝜋*𝔯 0 1)*√(_2*_.(𝔯 0 1)) diff --git a/math/ncdf.apple b/math/ncdf.apple new file mode 100644 --- /dev/null +++ b/math/ncdf.apple @@ -0,0 +1,11 @@ +λz. +{ + erf ← λz. + { + ffact ← [(*)/ₒ 1 (𝒻 1 x (⌊x))]; + Σ ← λN.λa. (+)/ₒ 0 (a'(⍳ 0 N 1)); + (2%√𝜋)*Σ 30 (λn. {nf⟜ℝn; ((_1^n)*z^(2*n+1))%((ffact nf)*(2*nf+1))}) + }; + zz ⟜ z%(√2); + 0.5*(1+erf(zz)) +} diff --git a/math/splitmix.apple b/math/splitmix.apple new file mode 100644 --- /dev/null +++ b/math/splitmix.apple @@ -0,0 +1,5 @@ +λx. + { s ← x + 0x9e3779b97f4a7c15 + ; z0 ← s + ; (z0,s) + } diff --git a/math/t.apple b/math/t.apple new file mode 100644 --- /dev/null +++ b/math/t.apple @@ -0,0 +1,11 @@ +λxs.λys. +{ + sum ⇐ [(+)/x]; + 𝜇 ⇐ λxs.λn. sum xs%n; + 𝜎 ⇐ λxs.λn. {𝜇 ⟜ 𝜇 xs n; sum ([(x-𝜇)^2]'xs)%(n-1)}; + xsn ⟜ ℝ(:xs); ysn ⟜ ℝ(:ys); + 𝜈 ⟜ xsn+ysn-2; + sₚ ← √(((xsn-1)*(𝜎 xs xsn)+(ysn-1)*(𝜎 ys ysn))%𝜈); + t ← (𝜇 xs xsn-𝜇 ys ysn)%(sₚ*√(1%(xsn+ysn))); + t +} diff --git a/math/tcdf.apple b/math/tcdf.apple new file mode 100644 --- /dev/null +++ b/math/tcdf.apple @@ -0,0 +1,33 @@ +λx.λν. +{ + gammaln ← λz. { + zz ⟜ z-1; + c0 ← 0.999999999999997092; + 𝛾 ← 607%128; + coeffs ← ⟨ 57.1562356658629235 + , _59.5979603554754912 + , 14.1360979747417471 + , _0.491913816097620199 + , 0.339946499848118887e-4 + , 0.465236289270485756e-4 + , _0.983744753048795646e-4 + , 0.158088703224912494e-3 + , _0.210264441724104883e-3 + , 0.217439618115212643e-3 + , _0.164318106536763890e-3 + , 0.844182239838527433e-4 + , _0.261908384015814087e-4 + , 0.368991826595316234e-5 + ⟩; + ss ← (+)/ ([y%(zz+itof x)]`(⍳ 1 14 1) coeffs); + (((zz+0.5)*_.(zz+𝛾+0.5))-(zz+𝛾+0.5))+_.((√(2*𝜋))*(c0+ss)) + }; + Γ ⟜ [ℯ(gammaln x)]; + f21 ← λa0.λa1.λb.λz. { + rf ← [(*)/ₒ 1 (𝒻 x (x+y-1) (⌊y))]; fact ← rf 1; + Σ ← λN.λa. (+)/ₒ 0 (a'(⍳ 0 N 1)); + 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%ν)) +} diff --git a/of/Test.hs b/of/Test.hs new file mode 100644 --- /dev/null +++ b/of/Test.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Data.Functor (void) +import qualified Data.Text as T +import H +import System.Directory (getCurrentDirectory, setCurrentDirectory) +import System.FilePath (()) +import System.Info (arch) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (proc, readCreateProcess) +import Test.Tasty (DependencyType (AllFinish), TestTree, defaultMain, sequentialTestGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +readCc :: FilePath + -> FilePath -- ^ Apple source file + -> T.Text + -> Arch + -> IO String +readCc pwd aSrc tyt a = + withSystemTempDirectory "apple" $ \dir -> do + setCurrentDirectory dir + let n=T.unpack tyt + run (pwd aSrc, a, tyt) + let c = pwd "test/harness" n <> "_harness.c" + {-# SCC "cc" #-} void $ readCreateProcess (proc "cc" [n <> ".o", c, "-I", dir, "-I", pwd "include"]) "" + {-# SCC "a.out" #-} readCreateProcess (proc (dir "a.out") []) "" + +ccOut :: FilePath -> FilePath -> T.Text -> Arch -> String -> TestTree +ccOut pwd fp tyt a expected = testCase (T.unpack tyt) $ do + actual <- readCc pwd fp tyt a + actual @?= expected + +main :: IO () +main = do + 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" + ] + where + sys = case arch of {"x86_64" -> X64; "aarch64" -> Aarch64} diff --git a/run/Main.hs b/run/Main.hs new file mode 100644 --- /dev/null +++ b/run/Main.hs @@ -0,0 +1,542 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Main (main) where + +import A +import Control.Monad (zipWithM, zipWithM_) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.State (StateT, evalStateT, gets, modify) +import Control.Monad.Trans.Class (lift) +import Criterion (benchmark, nfIO) +import qualified Data.ByteString.Lazy as BSL +import Data.Foldable (traverse_) +import Data.Functor ((<&>)) +import Data.Int (Int64) +import Data.List +import Data.List.Split (chunksOf) +import Data.Maybe (catMaybes) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Traversable (forM) +import Data.Tuple.Extra (first3) +import Data.Word (Word8) +import Dbg +import Foreign.LibFFI (argPtr, callFFI, retCDouble, retCUChar, retInt64, retPtr, retWord8) +import Foreign.Marshal.Alloc (free) +import Foreign.Marshal.Array (peekArray) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (peek) +import Hs.A +import Hs.FFI +import L +import Nm +import Numeric.Extra (showHex) +import Prettyprinter (Doc, align, brackets, concatWith, hardline, list, pretty, space, tupled, (<+>)) +import Prettyprinter.Ext +import Prettyprinter.Render.Text (putDoc) +import QC +import Sys.DL +import System.Console.Haskeline (Completion, CompletionFunc, InputT, completeFilename, defaultSettings, fallbackCompletion, getInputLine, historyFile, runInputT, + setComplete, simpleCompletion) +import System.Directory (doesFileExist, getHomeDirectory) +import System.FilePath (()) +import System.Info (arch) +import Ty +import Ty.M + +main :: IO () +main = runRepl loop + +namesStr :: StateT Env IO [String] +namesStr = gets (fmap (T.unpack.name.fst) . ee) + +data Arch = X64 | AArch64 !MCtx + +data Env = Env { _lex :: !AlexUserState, ee :: [(Nm AlexPosn, E AlexPosn)], mf :: CCtx, _arch :: Arch } + +aEe :: Nm AlexPosn -> E AlexPosn -> Env -> Env +aEe n e (Env l ees mm a) = Env l ((n,e):ees) mm a + +setL :: AlexUserState -> Env -> Env +setL lSt (Env _ ees mm a) = Env lSt ees mm a + +type Repl a = InputT (StateT Env IO) + +cyclicSimple :: [String] -> [Completion] +cyclicSimple = fmap simpleCompletion + +runRepl :: Repl a x -> IO x +runRepl x = do + histDir <- ( ".apple_history") <$> getHomeDirectory + mfϵ <- mem' + initSt <- Env alexInitUserState [] mfϵ <$> case arch of {"x86_64" -> pure X64; "aarch64" -> AArch64<$>math'; _ -> error "Unsupported architecture!"} + let myCompleter = appleCompletions `fallbackCompletion` completeFilename + let settings = setComplete myCompleter $ defaultSettings { historyFile = Just histDir } + flip evalStateT initSt $ runInputT settings x + +appleCompletions :: CompletionFunc (StateT Env IO) +appleCompletions (":","") = pure (":", cyclicSimple ["help", "h", "ty", "quit", "q", "quickcheck", "qc", "list", "ann", "bench", "y", "yank"]) +appleCompletions ("i:", "") = pure ("i:", cyclicSimple ["r", "nspect", ""]) +appleCompletions ("ri:", "") = pure ("ri:", cyclicSimple [""]) +appleCompletions ("c:", "") = pure ("c:", cyclicSimple ["mm", "ompile"]) +appleCompletions ("mc:", "") = pure ("mc:", cyclicSimple ["m"]) +appleCompletions ("mmc:", "") = pure ("mmc:", cyclicSimple [""]) +appleCompletions ("ni:", "") = pure ("ni:", [simpleCompletion "spect"]) +appleCompletions ("sni:", "") = pure ("sni:", [simpleCompletion "pect"]) +appleCompletions ("psni:", "") = pure ("psni:", [simpleCompletion "ect"]) +appleCompletions ("epsni:", "") = pure ("epsni:", [simpleCompletion "ct"]) +appleCompletions ("cepsni:", "") = pure ("cepsni:", [simpleCompletion "t"]) +appleCompletions ("tcepsni:", "") = pure ("tcepsni:", [simpleCompletion ""]) +appleCompletions ("t:", "") = pure ("t:", cyclicSimple ["y"]) +appleCompletions ("b:", "") = pure ("b:", cyclicSimple ["ench", ""]) +appleCompletions ("eb:", "") = pure ("eb:", [simpleCompletion "nch"]) +appleCompletions ("neb:", "") = pure ("neb:", [simpleCompletion "ch"]) +appleCompletions ("cneb:", "") = pure ("cneb:", [simpleCompletion "h"]) +appleCompletions ("hcneb:", "") = pure ("hcneb:", [simpleCompletion ""]) +appleCompletions ("oc:", "") = pure ("oc:", cyclicSimple ["mpile"]) +appleCompletions ("moc:", "") = pure ("moc:", cyclicSimple ["pile"]) +appleCompletions ("pmoc:", "") = pure ("pmoc:", cyclicSimple ["ile"]) +appleCompletions ("ipmoc:", "") = pure ("ipmoc:", cyclicSimple ["le"]) +appleCompletions ("lipmoc:", "") = pure ("lipmoc:", cyclicSimple ["e"]) +appleCompletions ("elipmoc:", "") = pure ("elipmoc:", cyclicSimple [""]) +appleCompletions ("yt:", "") = pure ("yt:", cyclicSimple [""]) +appleCompletions ("y:", "") = pure ("y:", cyclicSimple ["ank", ""]) +appleCompletions ("ay:", "") = pure ("ay:", cyclicSimple ["nk"]) +appleCompletions ("nay:", "") = pure ("nay:", cyclicSimple ["k"]) +appleCompletions ("knay:", "") = pure ("knay:", cyclicSimple [""]) +appleCompletions ("d:", "") = pure ("d:", [simpleCompletion "isasm"]) +appleCompletions ("id:", "") = pure ("id:", [simpleCompletion "sasm"]) +appleCompletions ("sid:", "") = pure ("sid:", [simpleCompletion "asm"]) +appleCompletions ("asid:", "") = pure ("asid:", [simpleCompletion "sm"]) +appleCompletions ("sasid:", "") = pure ("sasid:", [simpleCompletion "m"]) +appleCompletions ("msasid:", "") = pure ("msasid:", [simpleCompletion ""]) +appleCompletions ("a:", "") = pure ("a:", [simpleCompletion "sm", simpleCompletion "nn"]) +appleCompletions ("sa:", "") = pure ("sa:", [simpleCompletion "m"]) +appleCompletions ("msa:", "") = pure ("msa:", [simpleCompletion ""]) +appleCompletions ("na:", "") = pure ("na:", [simpleCompletion "n"]) +appleCompletions ("nna:", "") = pure ("nna:", [simpleCompletion ""]) +appleCompletions ("l:", "") = pure ("l:", cyclicSimple ["ist"]) +appleCompletions ("il:", "") = pure ("il:", cyclicSimple ["st"]) +appleCompletions ("sil:", "") = pure ("sil:", cyclicSimple ["t"]) +appleCompletions ("tsil:", "") = pure ("tsil:", cyclicSimple []) +appleCompletions ("q:", "") = pure ("q:", cyclicSimple ["uit", "c", ""]) +appleCompletions ("cq:", "") = pure ("cq:", [simpleCompletion ""]) +appleCompletions ("uq:", "") = pure ("uq:", [simpleCompletion "it"]) +appleCompletions ("iuq:", "") = pure ("iuq:", [simpleCompletion "t"]) +appleCompletions ("tiuq:", "") = pure ("tiuq:", [simpleCompletion ""]) +appleCompletions ("h:", "") = pure ("h:", cyclicSimple ["elp", ""]) +appleCompletions ("eh:", "") = pure ("eh:", [simpleCompletion "lp"]) +appleCompletions ("leh:", "") = pure ("leh:", [simpleCompletion "p"]) +appleCompletions ("pleh:", "") = pure ("pleh:", [simpleCompletion ""]) +appleCompletions (" yt:", "") = do { ns <- namesStr ; pure (" yt:", cyclicSimple ns) } +appleCompletions (" t:", "") = do { ns <- namesStr ; pure (" t:", cyclicSimple ns) } +appleCompletions ("", "") = ("",) . cyclicSimple <$> namesStr +appleCompletions (rp, "") = do { ns <- namesStr ; pure (unwords ("" : tail (words rp)), cyclicSimple (namePrefix ns rp)) } +appleCompletions _ = pure (undefined, []) + +namePrefix :: [String] -> String -> [String] +namePrefix names prevRev = filter (last (words (reverse prevRev)) `isPrefixOf`) names + +loop :: Repl AlexPosn () +loop = do + inp <- getInputLine " > " + case words <$> inp of + Just [] -> loop + Just (":h":_) -> showHelp *> loop + Just (":help":_) -> showHelp *> loop + Just ("\\l":_) -> langHelp *> loop + Just (":ty":e) -> tyExprR (unwords e) *> loop + Just [":q"] -> pure () + Just [":quit"] -> pure () + Just (":asm":e) -> dumpAsm (unwords e) *> loop + Just (":ann":e) -> annR (unwords e) *> loop + Just (":b":e) -> benchE (unwords e) *> loop + Just (":bench":e) -> benchE (unwords e) *> loop + Just (":ir":e) -> irR (unwords e) *> loop + Just (":c":e) -> cR (unwords e) *> loop + Just (":cmm":e) -> cR (unwords e) *> loop + Just (":disasm":e) -> disasm (unwords e) *> loop + Just (":inspect":e) -> inspect (unwords e) *> loop + Just (":compile":e) -> benchC (unwords e) *> loop + Just (":yank":f:[fp]) -> iCtx f fp *> loop + Just [":list"] -> listCtx *> loop + Just (":y":f:[fp]) -> iCtx f fp *> loop + Just (":graph":e) -> graph (unwords e) *> loop + Just (":qc":e) -> qc (unwords e) *> loop + Just (":quickcheck":e) -> qc (unwords e) *> loop + Just e -> printExpr (unwords e) *> loop + Nothing -> pure () + +listCtx :: Repl AlexPosn () +listCtx = do + bs <- lift $ gets ee + liftIO $ putDoc (prettyLines (pretty.fst<$>bs)<>hardline) + +graph :: String -> Repl AlexPosn () +graph s = liftIO $ case dumpX86Ass (ubs s) of + Left err -> putDoc (pretty err <> hardline) + Right d -> putDoc (d <> hardline) + +showHelp :: Repl AlexPosn () +showHelp = liftIO $ putStr $ concat + [ helpOption ":help, :h" "" "Show this help" + , helpOption ":ty" "" "Display the type of an expression" + , helpOption ":ann" "" "Annotate with types" + , helpOption ":bench, :b" "" "Benchmark an expression" + , helpOption ":list" "" "List all names that are in scope" + , helpOption ":qc" "" "Property test" + , helpOption ":quit, :q" "" "Quit REPL" + , helpOption ":yank, :y" " " "Read file" + , helpOption "\\l" "" "Reference card" + -- TODO: dump debug state + ] + +langHelp :: Repl AlexPosn () +langHelp = liftIO $ putStr $ concat + [ lOption "Λ" "scan" "√" "sqrt" + , lOption "⋉" "max" "⋊" "min" + , lOption "⍳" "integer range" "⌊" "floor" + , lOption "ℯ" "exp" "⨳ {m,n}" "convolve" + , lOption "\\~" "successive application" "\\`n" "dyadic infix" + , lOption "_." "log" "'n" "map" + , lOption "`" "zip" "`{i,j∘[k,l]}" "rank" + , lOption "𝒻" "range (real)" "𝜋" "pi" + , lOption "_" "negate" ":" "size" + , lOption "𝓉" "dimension" "}.?" "last" + , lOption "->n" "select" "**" "power" + , lOption "re:" "repeat" "}." "typesafe last" + , lOption "⊲" "cons" "⊳" "snoc" + , lOption "^:" "iterate" "%." "matmul" + , lOption "⊗" "outer product" "|:" "transpose" + , lOption "{.?" "head" "{." "typesafe head" + , lOption "}.?" "last" "}:" "typesafe init" + , lOption "⟨z,w⟩" "array literal" "?p,.e1,.e2" "conditional" + , lOption "/*" "fold all" "ℝ" "i->f conversion" + , lOption "⧺" "cat" "{:" "typesafe tail" + , lOption "⊖" "rotate" "sin." "sine" + , lOption "𝔯" "rand" "⍳" "range (int)" + , lOption "/ₒ" "fold with seed" "Λₒ" "scan with seed" + , lOption "{x←y;z}" "let...in" "⊙" "cycle" + , lOption "˙" "at" "|" "rem" + , lOption "@." "index of" "di." "diagonal" + , 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 op0 desc0 op1 desc1 = + rightPad 14 op0 ++ rightPad 25 desc0 ++ rightPad 14 op1 ++ desc1 ++ "\n" + +rightPad :: Int -> String -> String +rightPad n str = take n $ str ++ repeat ' ' + +helpOption :: String -> String -> String -> String +helpOption cmd args desc = + rightPad 15 cmd ++ rightPad 14 args ++ desc ++ "\n" + +ubs :: String -> BSL.ByteString +ubs = encodeUtf8 . TL.pack + +disasm :: String -> Repl AlexPosn () +disasm s = do + st <- lift $ gets _lex + a <- lift $ gets _arch + let d=case a of {X64 -> eDtxt; AArch64{} -> edAtxt} + case rwP st (ubs s) of + Left err -> liftIO $ putDoc (pretty err <> hardline) + Right (eP, i) -> do + eC <- eRepl eP + res <- liftIO $ d i eC + liftIO $ case res of + Left err -> putDoc (pretty err <> hardline) + Right b -> TIO.putStr b + +cR :: String -> Repl AlexPosn () +cR s = do + st <- lift $ gets _lex + case rwP st (ubs s) of + Left err -> liftIO $ putDoc (pretty err <> hardline) + Right (eP, i) -> do + eC <- eRepl eP + liftIO $ case eDumpC i eC of + Left err -> putDoc (pretty err <> hardline) + Right d -> putDoc (d <> hardline) + +irR :: String -> Repl AlexPosn () +irR s = do + st <- lift $ gets _lex + case rwP st (ubs s) of + Left err -> liftIO $ putDoc (pretty err <> hardline) + Right (eP, i) -> do + eC <- eRepl eP + liftIO $ case eDumpIR i eC of + Left err -> putDoc (pretty err <> hardline) + Right d -> putDoc (d <> hardline) + +dumpAsm :: String -> Repl AlexPosn () +dumpAsm s = do + st <- lift $ gets _lex; a <- lift $ gets _arch + let dump = case a of {X64 -> eDumpX86; AArch64{} -> eDumpAarch64} + case rwP st (ubs s) of + Left err -> liftIO $ putDoc (pretty err <> hardline) + Right (eP, i) -> do + eC <- eRepl eP + 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 + case rwP st (ubs s) of + Left err -> liftIO $ putDoc (pretty err <> hardline) + Right (eP, i) -> do + eC <- eRepl eP + liftIO $ case tyClosed i eC of + Left err -> putDoc (pretty err <> hardline) + Right (e,c,_) -> putDoc (prettyC (eAnn e, c) <> hardline) + +annR :: String -> Repl AlexPosn () +annR s = do + st <- lift $ gets _lex + case rwP st (ubs s) of + Left err -> liftIO $ putDoc (pretty err <> hardline) + Right (eP, i) -> do + eC <- eRepl eP + liftIO $ case tyClosed i eC of + Left err -> putDoc (pretty err <> hardline) + Right (e,_,_) -> putDoc (prettyTyped e <> hardline) + +freeAsm (sz, fp, mp) = freeFunPtr sz fp -- *> traverse_ free mp + + +dbgAB :: T b -> U a -> IO T.Text +dbgAB (Arr _ t) p = do + rnk <- peek (castPtr p :: Ptr Int64) + dims <- forM [1..fromIntegral rnk] $ \o -> peek $ p `plusPtr` (8*o) + let sz = fromIntegral (8+8*rnk+rSz t*product dims) + hextext <$> peekArray sz (castPtr p :: Ptr Word8) + +hextext = T.unwords . fmap (T.pack.($"").showHex) + +inspect :: String -> Repl AlexPosn () +inspect s = do + st <- lift $ gets _lex + a <- lift $ gets _arch + case rwP st bs of + Left err -> liftIO $ putDoc (pretty err <> hardline) + Right (eP, i) -> do + eC <- eRepl eP + case tyC i eC of + Left err -> liftIO $ putDoc (pretty err <> hardline) + Right (e, _, i') -> do + c <- lift $ gets mf + let efp=case a of {X64 -> eFunP i' c; AArch64 m -> eAFunP i' (c,m)} + liftIO $ do + asm@(_, fp, _) <- efp eC + p <- callFFI fp (retPtr undefined) [] + TIO.putStrLn =<< dbgAB (eAnn e) p + free p *> freeAsm asm + where bs = ubs s + +iCtx :: String -> String -> Repl AlexPosn () +iCtx f fp = do + p <- liftIO $ doesFileExist fp + if not p + then liftIO $ putStrLn "file does not exist." + else do + st <- lift $ gets _lex + bs <- liftIO $ BSL.readFile fp + case tyParseCtx st bs of + Left err -> liftIO $ putDoc (pretty err <> hardline) + Right (_,i) -> + let (st', n) = newIdent (AlexPn 0 0 0) (T.pack f) (setM i st) + x' = parseE st' bs + in lift $ do {modify (aEe n x'); modify (setL st')} + where setM i' (_, mm, im) = (i', mm, im) + +benchC :: String -> Repl AlexPosn () +benchC s = case tyParse bs of + Left err -> liftIO $ putDoc (pretty err <> hardline) + Right _ -> do + c <- lift $ gets mf + a <- lift $ gets _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 + +up :: T a -> Maybe [T a] +up (A.Arrow t0 t1@A.Arrow{}) = (t0:)<$>up t1 +up (A.Arrow t A.B) = Just [t] +up _ = Nothing + +qc :: String -> Repl AlexPosn () +qc s = do + st <- lift $ gets _lex + a <- lift $ gets _arch + case rwP st bs of + Left err -> liftIO $ putDoc (pretty err <> hardline) + Right (eP, i) -> do + eC <- eRepl eP + case tyC i eC of + Left err -> liftIO $ putDoc (pretty err <> hardline) + Right (e, _, i') -> do + c <- lift$gets mf + 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) + Just ty -> liftIO $ do + asm@(_, fp, _) <- efp eC + let loopϵ 0 = pure Nothing + loopϵ n = do + (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)) + res <- loopϵ (100::Int) + case res of + Nothing -> putDoc ("Passed, 100." <> hardline) + Just ex -> putDoc ("Proposition failed!" <> hardline <> pretty ex <> hardline) + freeAsm asm + + where bs = ubs s + cb 0=False; cb 1=True + catArrs (ArrD p:vs) = p:catArrs vs; catArrs [] = []; catArrs (_:vs) = catArrs vs + +benchE :: String -> Repl AlexPosn () +benchE s = do + st <- lift $ gets _lex + a <- lift $ gets _arch + case rwP st bs of + Left err -> pErr err + Right (eP, i) -> do + eC <- eRepl eP + case tyC i eC of + Left err -> pErr err + Right (e, _, i') -> do + c <- lift $ gets mf + let efp=case a of {X64 -> eFunP i' c; AArch64 m -> eAFunP i' (c,m)} + case eAnn e of + I -> do + liftIO $ do + asm@(_, fp, _) <- efp eC + benchmark (nfIO $ callFFI fp retInt64 []) + freeAsm asm + A.F -> do + liftIO $ do + asm@(_, fp, _) <- efp eC + benchmark (nfIO $ callFFI fp retCDouble []) + freeAsm asm + P [A.F,A.F] -> error "Haskell support for float ABI is poor :(" + (Arr _ _) -> do + liftIO $ do + asm@(_, fp, _) <- efp eC + benchmark (nfIO (do{p<- callFFI fp (retPtr undefined) []; free p})) + freeAsm asm + P{} -> + liftIO $ do + asm@(_, fp, _) <- efp eC + benchmark (nfIO (do{p<- callFFI fp (retPtr undefined) []; free p})) + freeAsm asm + A.Arrow{} -> liftIO $ putDoc ("Cannot benchmark a function without arguments" <> hardline) + where bs = ubs s + +rSz A.B=1; rSz I=8; rSz A.F=8; rSz (P ts) = sum (rSz<$>ts); rSz Arr{}=8 + +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 + +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)} +pR A.B p = do {b <- peek (castPtr p :: Ptr AB); pure (pretty b)} +pR (P ts) p = tupledBy "*" <$> traverse (`pR` p) ts + +peekInterpret :: T a -> Ptr b -> IO (Doc ann) +peekInterpret (Arr _ t) p = do + rnk <- peek (castPtr p :: Ptr Int64) + dims <- forM [1..fromIntegral rnk] $ \o -> peek $ p `plusPtr` (8*o) + let datOffs = 8+8*fromIntegral rnk + xsP = [1..fromIntegral (product dims)] <&> \o -> p `plusPtr` (datOffs+elemSz*(o-1)) + xs <- traverse (pR t) xsP + pure (pE dims xs) + where + elemSz :: Integral a => a + elemSz = rSz t +peekInterpret (P ts) p = tupled <$> + let ds=offs ts + in zipWithM (use peekInterpret) ts ((p `plusPtr`)<$>ds) +peekInterpret t p = pR t p + +offs = scanl' (\off t -> off+rSz t) 0 + +πp :: T a -> Ptr a -> IO (Ptr a) +πp Arr{} p = peek (castPtr p) +πp _ p = pure p + +use f t addr = f t =<< πp t addr + +freeByT :: T a -> Ptr b -> IO () +freeByT Arr{} p = free p +freeByT (P ts) p = let ds = offs ts in zipWithM_ (use freeByT) ts ((p `plusPtr`)<$>ds) +freeByT _ _ = pure () + +printExpr :: String -> Repl AlexPosn () +printExpr s = do + st <- lift $ gets _lex + a <- lift $ gets _arch + case rwP st bs of + Left err -> liftIO $ putDoc (pretty err <> hardline) + Right (eP, i) -> do + eC <- eRepl eP + case first3 (fmap rLi) <$> tyC i eC of + Left (RErr MR{}) -> liftIO $ case tyClosed i eC of + Left e -> putDoc (pretty e <> hardline) + Right (e, _, _) -> + 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 + let efp=case a of {X64 -> eFunP i' c; AArch64 ma -> eAFunP i' (c,ma)} + case eAnn e of + I -> + liftIO $ do + asm@(_, fp, _) <- efp eC -- TODO: i after tyClosed gets discarded? + print =<< callFFI fp retInt64 [] + freeAsm asm + A.F -> + liftIO $ do + asm@(_, fp, _) <- efp eC + print =<< callFFI fp retCDouble [] + freeAsm asm + A.B -> + liftIO $ do + asm@(_, fp, _) <- efp eC + cb <- callFFI fp retWord8 [] + putStrLn (sB cb) + freeAsm asm + where sB 1 = "#t"; sB 0 = "#f" + t@A.Arrow{} -> liftIO $ putDoc (pretty e <+> ":" <+> pretty t <> hardline) + t -> + liftIO $ do + asm@(_, fp, _) <- efp eC + p <- callFFI fp (retPtr undefined) [] + putDoc.(<>hardline) =<< peekInterpret t p + freeByT t p *> freeAsm asm + where bs = ubs s + +parseE st bs = fst . either (error "Internal error?") id $ rwP st bs + +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 + +pErr err = liftIO $ putDoc (pretty err <> hardline) diff --git a/run/QC.hs b/run/QC.hs new file mode 100644 --- /dev/null +++ b/run/QC.hs @@ -0,0 +1,84 @@ +module QC ( gas, Val (..) ) where + +import A +import Control.Monad.State.Strict (StateT, evalStateT, get, gets, modify, put, runStateT) +import Control.Monad.Trans.Class (lift) +import Data.Bifunctor (bimap) +import Data.Functor (($>)) +import Data.Int (Int64) +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.Ptr (Ptr) +import Foreign.Storable (poke, sizeOf) +import Hs.A +import Nm +import Prettyprinter (Pretty (..)) +import Test.QuickCheck.Gen (Gen, chooseAny, chooseInt64, frequency, genDouble, generate, vectorOf) +import U + +rnk :: Gen Int64 +rnk = frequency [(8, pure 1), (3, pure 2), (2, pure 3)] + +dim :: Gen Int64 +dim = chooseInt64 (0, 20) + +data RSubst = RSubst { iS :: IM.IntMap Int64, sS :: IM.IntMap (Int64, [Int64]) } + +mapI f (RSubst i s) = RSubst (f i) s +mapS g (RSubst i s) = RSubst i (g s) + +type ShM = StateT RSubst Gen + +gg :: Sh a -> ShM (Int64, [Int64]) +gg Nil = pure (0, []) +gg (Ix _ i `Cons` sh) = bimap (+1) (fromIntegral i:)<$>gg sh +gg (IVar _ (Nm _ (U n) _) `Cons` sh) = do + iSt <- gets iS + case IM.lookup n iSt of + Nothing -> do {d <- lift dim; modify (mapI (IM.insert n d)); bimap (+1) (d:)<$>gg sh} + Just d -> bimap (+1) (d:)<$>gg sh +gg (StaPlus _ (IVar _ (Nm _ (U n) _)) (Ix _ i) `Cons` sh) | i' <- fromIntegral i = do + iSt <- gets iS + case IM.lookup n iSt of + Nothing -> do {d <- lift$chooseInt64 (0,10); modify (mapI (IM.insert n d)); bimap (+1) ((d+i'):)<$>gg sh} + Just d -> bimap (+1) ((d+i'):)<$>gg sh +gg (SVar (Nm _ (U n) _)) = do + sSt <- gets sS + case IM.lookup n sSt of + 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)) + +gas :: [T a] -> IO [(Arg, Val, Maybe (Ptr (Apple Double)))] +gas = flip evalStateT (RSubst IM.empty IM.empty).traverse ga + +data Val = ArrD !(Apple Double) | II !Int64 | D !Double + +instance Pretty Val where + pretty (ArrD 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 (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)) +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) + +gD :: Sh a -> ShM (Apple Double) +gD sh = do + (r, ds) <- gg sh + let n=fromIntegral$product ds + es <- lift$vectorOf n genDouble + pure (AA r ds es) diff --git a/src/A.hs b/src/A.hs new file mode 100644 --- /dev/null +++ b/src/A.hs @@ -0,0 +1,404 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | AST +module A ( T (..) + , (~>) + , I (..), Sh (..) + , C (..) + , E (..) + , Idiom (..) + , Builtin (..) + , ResVar (..) + , prettyTyped + , prettyC + , rLi + ) where + +import Control.DeepSeq (NFData) +import qualified Data.IntMap as IM +import GHC.Generics (Generic) +import Nm +import Prettyprinter (Doc, Pretty (..), braces, brackets, colon, comma, encloseSep, flatAlt, group, hsep, lbrace, lbracket, parens, pipe, punctuate, rbrace, rbracket, + tupled, (<+>)) +import Prettyprinter.Ext + +instance Pretty (I a) where pretty=ps 0 + +instance PS (I a) where + ps _ (Ix _ i) = pretty i + ps _ (IVar _ n) = pretty n + ps d (StaPlus _ i j) = parensp (d>5) (ps 6 i <+> "+" <+> ps 6 j) + ps d (StaMul _ i j) = parensp (d>7) (ps 8 i <+> "*" <+> ps 8 j) + ps _ (IEVar _ n) = "#" <> pretty n + +data I a = Ix { ia :: a, ii :: !Int } + | IVar { ia :: a, ixn :: Nm a } + | IEVar { ia :: a , ie :: Nm a } -- existential + | StaPlus { ia :: a, ix0, ix1 :: I a } + | StaMul { ia :: a, ix0, ix1 :: I a } + deriving (Functor, Generic) + +instance Show (I a) where + show = show . pretty + +data C = IsNum | IsOrd -- implies eq + | HasBits deriving (Generic, Eq, Ord) + +instance NFData C where + +instance Pretty C where pretty IsNum = "IsNum"; pretty IsOrd = "IsOrd"; pretty HasBits = "HasBits" + +instance Show C where show=show.pretty + +tupledArr = group . encloseSep (flatAlt "⟨ " "⟨") (flatAlt " ⟩" "⟩") ", " + +data Sh a = Nil + | SVar (Nm a) + | Cons (I a) (Sh a) + | Rev (Sh a) + | Cat (Sh a) (Sh a) + | Π (Sh a) + deriving (Functor, Generic) + +infixr 8 `Cons` + +instance Show (Sh a) where show=show.pretty + +instance Pretty (Sh a) where pretty=ps 0 + +unroll Nil = Just [] +unroll (Cons i sh) = (i:)<$>unroll sh +unroll _ = Nothing + +instance PS (Sh a) where + ps _ (SVar n) = pretty n + ps _ sh@Cons{} | Just is <- unroll sh = tupledBy " × " (pretty <$> is) + ps d (Cons i sh) = parensp (d>6) (pretty i <+> "`Cons`" <+> pretty sh) + ps _ Nil = "Nil" + ps d (Cat s s') = parensp (d>5) (ps 6 s <+> "⧺" <+> ps 6 s') + ps d (Rev s) = parensp (d>appPrec) ("rev" <+> ps (appPrec+1) s) + ps d (Π s) = parensp (d>appPrec) ("Π" <+> ps (appPrec+1) s) + +appPrec=10 + +infixr 0 ~> +(~>) = Arrow + +data T a = Arr (Sh a) (T a) + | F -- | double + | I -- | int + | B -- | bool + | Li (I a) + | TVar (Nm a) -- | Kind \(*\) + | Arrow (T a) (T a) + | P [T a] + | Ρ (TyNm a) (IM.IntMap (T a)) + deriving (Functor, Generic) + +instance Show (T a) where show=show.pretty + +instance Pretty (T a) where pretty=ps 0 + +instance PS (T a) where + ps d (Arr (i `Cons` Nil) t) = parensp (d>appPrec) ("Vec" <+> ps (appPrec+1) i <+> ps (appPrec+1) t) + ps d (Arr i t) = parensp (d>appPrec) ("Arr" <+> ps (appPrec+1) i <+> ps (appPrec+1) t) + ps _ F = "float" + ps _ I = "int" + ps _ (Li i) = "int" <> parens (pretty i) + ps _ B = "bool" + ps _ (TVar n) = pretty n + ps d (Arrow t0 t1) = parensp (d>0) (ps 1 t0 <+> "→" <+> ps 0 t1) + ps _ (P ts) = tupledBy " * " (pretty <$> ts) + ps _ (Ρ n fs) = braces (pretty n <+> pipe <+> prettyFields (IM.toList fs)) + +rLi :: T a -> T a +rLi Li{} = I +rLi (Arrow t0 t1) = Arrow (rLi t0) (rLi t1) +rLi (Arr sh t) = Arr sh (rLi t) +rLi (Ρ n ts) = Ρ n (rLi <$> ts) +rLi (P ts) = P (rLi <$> ts) +rLi t = t + +prettyFields :: [(Int, T a)] -> Doc ann +prettyFields = mconcat . punctuate "," . fmap g where g (i, t) = pretty i <> ":" <+> pretty t + +prettyRank :: (Int, Maybe [Int]) -> Doc ann +prettyRank (i, Nothing) = pretty i +prettyRank (i, Just as) = pretty i <+> "∘" <+> encloseSep lbracket rbracket comma (pretty<$>as) + +instance Pretty Builtin where + pretty Plus = "+" + pretty Fold = "/" + pretty FoldS = "/ₒ" + pretty FoldA = "/*" + pretty Times = "*" + pretty FRange = "𝒻" + pretty IRange = "⍳" + pretty Floor = "⌊" + pretty Minus = "-" + pretty Max = "⋉" + pretty Min = "⋊" + pretty Map = "'" + pretty Zip = "`" + pretty Div = "%" + pretty IntExp = "^" + pretty Exp = "**" + pretty ItoF = "ℝ" + pretty Neg = "_" + pretty Sqrt = "√" + pretty Log = "_." + pretty Re = "re:" + pretty Size = ":" + pretty (Rank as) = "`" <> encloseSep lbrace rbrace comma (prettyRank<$>as) + pretty IDiv = "/." + pretty Scan = "Λ" + pretty ScanS = "Λₒ" + pretty (DI i) = "\\`" <> pretty i + pretty (Conv ns) = "⨳" <+> encloseSep lbrace rbrace comma (pretty<$>ns) + pretty (TAt i) = parens ("->" <> pretty i) + pretty Gen = "gen." + pretty Last = "}." + pretty LastM = "}.?" + pretty Head = "{." + pretty HeadM = "{.?" + pretty Tail = "{:" + pretty Init = "}:" + pretty ConsE = "⊲" + pretty Snoc = "⊳" + pretty Mul = "%." + pretty VMul = "%:" + pretty Iter = "^:" + pretty Succ = "\\~" + pretty T = "|:" + pretty Fib = "𝓕" + pretty Dim = "𝓉" + pretty Sin = "sin." + pretty Cos = "cos." + pretty Tan = "tan." + pretty Gte = "≥" + pretty Gt = ">" + pretty Lt = "<" + pretty Eq = "=" + pretty Neq = "≠" + pretty Lte = "≤" + pretty CatE = "⧺" + pretty R = "𝔯" + pretty Rot = "⊖" + pretty Cyc = "⊙" + pretty A1 = "˙" + pretty Even = "even." + pretty Odd = "odd." + pretty Mod = "mod" + pretty IOf = "@." + pretty Filt = "§" + pretty Abs = "abs." + pretty Di = "di." + pretty RevE = "~" + pretty Flat = "♭" + pretty AddDim = "♮" + pretty Xor = "⊻" + pretty And = "∧" + pretty Or = "∨" + pretty N = "¬" + pretty Ices = "℘" + pretty Eye = "👁️" + pretty Sr = ">>" + pretty Sl = "<<" + +data Builtin = Plus | Minus | Times | Div | IntExp | Exp | Log + | Eq | Neq | Gt | Lt | Gte | Lte | CatE | IDiv | Mod + | Max | Min | Neg | Sqrt | T | Di + | Flat | AddDim | Ices | Filt | Eye + | IRange | FRange + | Map | FoldA | Zip + | Rank [(Int, Maybe [Int])] + | Fold | FoldS | Foldl | Floor | ItoF | Iter + | Scan | ScanS | Size | Dim | Re | Gen | Fib | Succ + | DI !Int -- dyadic infix + | Conv [Int] | TAt !Int | Last | LastM | ConsE | Snoc + | Mul | VMul | Outer | R | Head | HeadM | Tail | Init | RevE + | Sin | Cos | Rot | Tan | Cyc | A1 | Even | Odd | IOf | Abs + | And | Or | Xor | N | Sr | Sl + deriving (Generic) + -- TODO: window (feuilleter, stagger, ...) functions, reshape...? + +ptName :: Nm (T a) -> Doc ann +ptName n@(Nm _ _ t) = parens (pretty n <+> ":" <+> pretty t) + +prettyC :: (T (), [(Nm a, C)]) -> Doc ann +prettyC (t, []) = pretty t +prettyC (t, cs) = tupled (pc<$>cs) <+> ":=>" <+> pretty t + where pc (n, c) = pretty c <+> pretty n + +-- TODO: constraints +prettyTyped :: E (T a) -> Doc ann +prettyTyped (Var t n) = parens (pretty n <+> ":" <+> pretty t) +prettyTyped (Builtin t b) = parens (pretty b <+> ":" <+> pretty t) +prettyTyped (ILit t n) = parens (pretty n <+> ":" <+> pretty t) +prettyTyped (FLit t x) = parens (pretty x <+> ":" <+> pretty t) +prettyTyped (BLit t True) = parens ("#t" <+> colon <+> pretty t) +prettyTyped (BLit t False) = parens ("#f" <+> colon <+> pretty t) +prettyTyped (Cond t p e0 e1) = parens ("?" <+> prettyTyped p <+> ",." <+> prettyTyped e0 <+> prettyTyped e1) <+> colon <+> pretty t +prettyTyped (Lam _ n@(Nm _ _ xt) e) = parens ("λ" <> parens (pretty n <+> ":" <+> pretty xt) <> "." <+> prettyTyped e) +prettyTyped (EApp _ (EApp _ (EApp _ (Builtin _ FoldS) e0) e1) e2) = parens (prettyTyped e0 <> "/ₒ" <+> prettyTyped e1 <+> prettyTyped e2) +prettyTyped (EApp _ (EApp _ (EApp _ (Builtin _ FoldA) e0) e1) e2) = parens (prettyTyped e0 <> "/*" <+> prettyTyped e1 <+> prettyTyped e2) +prettyTyped (EApp _ (EApp _ (EApp _ (Builtin _ Foldl) e0) e1) e2) = parens (prettyTyped e0 <> "/l" <+> prettyTyped e1 <+> prettyTyped e2) +prettyTyped (EApp t (EApp _ (EApp _ (Builtin _ Outer) e0) e1) e2) = parens (prettyTyped e1 <+> pretty e0 <> "⊗" <+> prettyTyped e2 <+> ":" <+> pretty t) +prettyTyped (EApp _ e0@(Builtin _ op) e1) | isBinOp op = parens (prettyTyped e1 <+> prettyTyped e0) +prettyTyped (EApp _ e0 e1) = parens (prettyTyped e0 <+> prettyTyped e1) +prettyTyped (Let t (n, e) e') = parens (braces (ptName n <+> "←" <+> prettyTyped e <> ";" <+> prettyTyped e') <+> pretty t) +prettyTyped (LLet t (n, e) e') = parens (braces (ptName n <+> "⟜" <+> prettyTyped e <> ";" <+> prettyTyped e') <+> pretty t) +prettyTyped (Def t (n, e) e') = parens (braces (ptName n <+> "⇐" <+> prettyTyped e <> ";" <+> prettyTyped e') <+> pretty t) +prettyTyped (Tup _ es) = tupled (prettyTyped <$> es) +prettyTyped e@(ALit t _) = parens (pretty e <+> ":" <+> pretty t) + +mPrec :: Builtin -> Maybe Int +mPrec Plus = Just 6 +mPrec Minus = Just 6 +mPrec Times = Just 7 +mPrec Div = Just 7 +mPrec IDiv = Just 7 +mPrec Exp = Just 8 +mPrec IntExp = Just 8 +mPrec Mod = Just 7 +mPrec Succ = Just 9 +mPrec Fold = Just 9 +mPrec Map = Just 5 +mPrec ConsE = Just 4 +mPrec Snoc = Just 4 +mPrec CatE = Just 5 +mPrec Sr = Just 8 +mPrec Sl = Just 8 +mPrec Xor = Just 6 +mPrec And = Just 3 +mPrec Or = Just 2 +mPrec Eq = Just 4 +mPrec Neq = Just 4 +mPrec Gt = Just 4 +mPrec Lt = Just 4 +mPrec Gte = Just 4 +mPrec Lte = Just 4 +mPrec _ = Nothing + +isBinOp :: Builtin -> Bool +isBinOp Plus = True +isBinOp Minus = True +isBinOp Times = True +isBinOp Div = True +isBinOp IDiv = True +isBinOp Exp = True +isBinOp IntExp = True +isBinOp DI{} = True +isBinOp Conv{} = True +isBinOp Mul = True +isBinOp VMul = True +isBinOp Rot = True +isBinOp ConsE = True +isBinOp Snoc = True +isBinOp Scan = True +isBinOp Fold = True +isBinOp Map = True +isBinOp Cyc = True +isBinOp A1 = True +isBinOp Mod = True +isBinOp IOf = True +isBinOp And = True +isBinOp Or = True +isBinOp Xor = True +isBinOp Filt = True +isBinOp Ices = True +isBinOp Sr = True +isBinOp Sl = True +isBinOp _ = False + +instance Pretty (E a) where pretty=ps 0 + +instance PS (E a) where + ps d (Lam _ n e) = parensp (d>1) ("λ" <> pretty n <> "." <+> ps 2 e) + ps _ (Var _ n) = pretty n + ps _ (Builtin _ op) | isBinOp op = parens (pretty op) + ps _ (Builtin _ b) = pretty b + ps d (EApp _ (Builtin _ (TAt i)) e) = parensp (d>9) (ps 10 e <> "->" <> pretty i) + ps _ (EApp _ (Builtin _ op) e0) | isBinOp op = parens (pretty e0 <+> pretty op) + ps d (EApp _ (EApp _ (Builtin _ op) e0) e1) | Just d' <- mPrec op = parensp (d>d') (ps (d'+1) e0 <+> pretty op <+> ps (d'+1) e1) + ps _ (EApp _ (EApp _ (Builtin _ op) e0) e1) | isBinOp op = parens (ps 10 e0 <+> pretty op <+> ps 10 e1) + ps _ (EApp _ (EApp _ (EApp _ (Builtin _ Iter) e0) e1) e2) = parens (ps 10 e0 <> "^:" <+> ps 10 e1 <+> ps 11 e2) + ps _ (EApp _ (EApp _ (EApp _ (Builtin _ FoldS) e0) e1) e2) = parens (pretty e0 <> "/ₒ" <+> pretty e1 <+> pretty e2) + ps _ (EApp _ (EApp _ (EApp _ (Builtin _ Foldl) e0) e1) e2) = parens (pretty e0 <> "/l" <+> pretty e1 <+> pretty e2) + ps _ (EApp _ (EApp _ (EApp _ (Builtin _ FoldA) e0) e1) e2) = parens (pretty e0 <> "/*" <+> pretty e1 <+> pretty e2) + ps _ (EApp _ (EApp _ (EApp _ (Builtin _ ScanS) e0) e1) e2) = parens (pretty e0 <+> "Λₒ" <+> pretty e1 <+> pretty e2) + ps _ (EApp _ (EApp _ (EApp _ (Builtin _ Zip) e0) e1) e2) = parens (pretty e0 <+> "`" <+> pretty e1 <+> pretty e2) + ps _ (EApp _ (EApp _ (EApp _ (Builtin _ Outer) e0) e1) e2) = parens (pretty e1 <+> ps 10 e0 <+> "⊗" <+> pretty e2) + ps _ (EApp _ (EApp _ (Builtin _ op@Rank{}) e0) e1) = parens (pretty e0 <+> pretty op <+> pretty e1) + ps _ (EApp _ (EApp _ (Builtin _ op@Conv{}) e0) e1) = parens (pretty e0 <+> pretty op <+> pretty e1) + ps _ (EApp _ (EApp _ (Builtin _ (DI i)) e0) e1) = parens (pretty e0 <+> "\\`" <> pretty i <+> pretty e1) + ps _ (EApp _ (EApp _ (Builtin _ Succ) e0) e1) = parens (pretty e0 <+> "\\~" <+> pretty e1) + ps d (EApp _ e0 e1) = parensp (d>10) (ps 10 e0 <+> ps 11 e1) + ps _ (FLit _ x) = pretty x + ps _ (ILit _ n) = pretty n + ps _ (BLit _ True) = "#t" + ps _ (BLit _ False) = "#f" + ps _ (Dfn _ e) = brackets (pretty e) + ps _ (ResVar _ x) = pretty x + ps _ (Parens _ e) = parens (pretty e) + ps _ (Let _ (n, e) e') = braces (pretty n <+> "←" <+> pretty e <> ";" <+> pretty e') + ps _ (Def _ (n, e) e') = braces (pretty n <+> "⇐" <+> pretty e <> ";" <+> pretty e') + ps _ (LLet _ (n, e) e') = braces (pretty n <+> "⟜" <+> pretty e <> ";" <+> pretty e') + ps _ (Id _ idm) = pretty idm + ps _ (Tup _ es) = tupled (pretty <$> es) + ps _ (ALit _ es) = tupledArr (pretty <$> es) + ps d (Ann _ e t) = parensp (d>1) (ps 2 e <+> "::" <+> ps 1 t) + ps d (Cond _ p e₀ e₁) = "?" <> pretty p <> ",." <+> ps d e₀ <+> ",." <+> ps d e₁ + +instance Show (E a) where show=show.pretty + +data ResVar = X | Y deriving (Generic) + +instance Pretty ResVar where + pretty X = "x"; pretty Y = "y" + +data Idiom = FoldSOfZip { seedI, opI :: E (T ()), esI :: [E (T ())] } + | FoldOfZip { zopI, opI :: E (T ()), esI :: [E (T ())] } + | FoldGen { seedG, ufG, fG, nG :: E (T ()) } + | AShLit { litSh :: [Int], esLit :: [E (T ())] } + deriving (Generic) + +instance Pretty Idiom where + pretty (FoldSOfZip seed op es) = parens ("foldS-of-zip" <+> pretty seed <+> pretty op <+> pretty es) + pretty (FoldOfZip zop op es) = parens ("fold-of-zip" <+> pretty zop <+> pretty op <+> pretty es) + pretty (FoldGen seed g f n) = parens ("fold-gen" <+> brackets (pretty seed) <+> parens (pretty g) <+> parens (pretty f) <+> parens (pretty n)) + pretty (AShLit re es) = parens ("re" <+> hsep (pretty <$> re) <+> "|" <+> pretty es) + +instance Show Idiom where show=show.pretty + +data E a = ALit { eAnn :: a, arrLit :: [E a] } -- TODO: include shape? + -- TODO: bool array + | Var { eAnn :: a, eVar :: Nm a } + | Builtin { eAnn :: a, eBuiltin :: !Builtin } + | EApp { eAnn :: a, eF, eArg :: E a } + | Lam { eAnn :: a, eVar :: Nm a, eIn :: E a } + | ILit { eAnn :: a, eILit :: !Integer } + | FLit { eAnn :: a, eFLit :: !Double } + | BLit { eAnn :: a, eBLit :: !Bool } + | Cond { eAnn :: a, prop, ifBranch, elseBranch :: E a } + | Let { eAnn :: a, eBnd :: (Nm a, E a), eIn :: E a } + | Def { eAnn :: a, eBnd :: (Nm a, E a), eIn :: E a } + | LLet { eAnn :: a, eBnd :: (Nm a, E a), eIn :: E a } + | Dfn { eAnn :: a, eIn :: E a } + | ResVar { eAnn :: a, eXY :: ResVar } + | Parens { eAnn :: a, eExp :: E a } + | Ann { eAnn :: a, eEe :: E a, eTy :: T a } + | Tup { eAnn :: a, eEs :: [E a] } + | Id { eAnn :: a, eIdiom :: Idiom } + deriving (Functor, Generic) + +instance NFData Builtin where +instance NFData ResVar where +instance NFData Idiom where +instance NFData a => NFData (E a) where +instance NFData a => NFData (I a) where +instance NFData a => NFData (Sh a) where +instance NFData a => NFData (T a) where diff --git a/src/A/Eta.hs b/src/A/Eta.hs new file mode 100644 --- /dev/null +++ b/src/A/Eta.hs @@ -0,0 +1,89 @@ +module A.Eta ( η ) where + +import A +import Control.Monad ((<=<)) +import R.M + +-- domains +doms :: T a -> [T a] +doms (Arrow t t') = t:doms t' +doms _ = [] + +-- count lambdas +cLam :: E a -> Int +cLam (Lam _ _ e) = 1 + cLam e; cLam _ = 0 + +thread = foldr (.) id + +unseam :: [T ()] -> RM (E (T ()) -> E (T ()), E (T ()) -> E (T ())) +unseam ts = do + lApps <- traverse (\t -> do { n <- nextN t ; pure (\e' -> let t' = eAnn e' in Lam (t ~> t') n e', \e' -> let Arrow _ cod = eAnn e' in EApp cod e' (Var t n)) }) ts + let (ls, eApps) = unzip lApps + pure (thread ls, thread (reverse eApps)) + +mkLam :: [T ()] -> E (T ()) -> RM (E (T ())) +mkLam ts e = do + (lam, app) <- unseam ts + pure $ lam (app e) + +η :: E (T ()) -> RM (E (T ())) +η = ηM <=< ηAt + +tuck :: E a -> (E a -> E a, E a) +tuck (Lam l n e) = let (f, e') = tuck e in (Lam l n.f, e') +tuck e = (id, e) + +ηAt :: E (T ()) -> RM (E (T ())) +ηAt (EApp t0 (EApp t1 ho@(Builtin _ Gen) seed) op) = EApp t0 <$> EApp t1 ho <$> ηAt seed <*> η op +ηAt (EApp t ho@(Builtin _ Scan{}) op) = EApp t ho <$> η op +ηAt (EApp t ho@(Builtin _ ScanS{}) op) = EApp t ho <$> η op +ηAt (EApp t ho@(Builtin _ Zip{}) op) = EApp t ho <$> η op +ηAt (EApp t ho@(Builtin _ Succ{}) op) = EApp t ho <$> η op +ηAt (EApp t ho@(Builtin _ FoldS) op) = EApp t ho <$> η op +ηAt (EApp t ho@(Builtin _ Fold) op) = EApp t ho <$> η op +ηAt (EApp t ho@(Builtin _ FoldA) op) = EApp t ho <$> η op +ηAt (EApp t ho@(Builtin _ Foldl) op) = EApp t ho <$> η op +ηAt (EApp t ho@(Builtin _ Map{}) op) = EApp t ho <$> η op +ηAt (EApp t ho@(Builtin _ Rank{}) op) = EApp t ho <$> η op +ηAt (EApp t ho@(Builtin _ DI{}) op) = EApp t ho <$> η op +ηAt (EApp t ho@(Builtin _ Conv{}) op) = EApp t ho <$> η op +ηAt (EApp t ho@(Builtin _ Outer) op) = EApp t ho <$> η op +ηAt (EApp t e0 e1) = EApp t <$> ηAt e0 <*> ηAt e1 +ηAt (Lam l n e) = Lam l n <$> ηAt e +ηAt (Cond l p e e') = Cond l <$> ηAt p <*> ηAt e <*> ηAt e' +ηAt (LLet l (n, e') e) = do { e'𝜂 <- ηAt e'; e𝜂 <- ηAt e; pure $ LLet l (n, e'𝜂) e𝜂 } +ηAt (Id l idm) = Id l <$> ηIdm idm +ηAt (ALit l es) = ALit l <$> traverse ηAt es +ηAt (Tup l es) = Tup l <$> traverse ηAt es +ηAt e = pure e + +ηIdm (FoldSOfZip seed op es) = FoldSOfZip <$> ηAt seed <*> ηAt op <*> traverse ηAt es +ηIdm (FoldOfZip zop op es) = FoldOfZip <$> ηAt zop <*> ηAt op <*> traverse ηAt es +ηIdm (FoldGen seed g f n) = FoldGen <$> ηAt seed <*> ηM g <*> ηM f <*> ηAt n +ηIdm (AShLit ds es) = AShLit ds <$> traverse ηAt es + +-- outermost only +ηM :: E (T ()) -> RM (E (T ())) +ηM e@FLit{} = pure e +ηM e@ILit{} = pure e +ηM e@ALit{} = pure e +ηM e@(Id _ AShLit{}) = pure e +ηM e@(Id _ FoldGen{}) = pure e +ηM e@(Id _ FoldOfZip{}) = pure e +ηM e@(Id _ FoldSOfZip{}) = pure e +ηM e@Cond{} = pure e +ηM e@BLit{} = pure e +ηM e@Tup{} = pure e +ηM e@(Var t@Arrow{} _) = mkLam (doms t) e +ηM e@Var{} = pure e +ηM e@(Builtin t@Arrow{} _) = mkLam (doms t) e +ηM e@Builtin{} = pure e +ηM e@(EApp t@Arrow{} _ _) = mkLam (doms t) e +ηM e@EApp{} = pure e +ηM e@LLet{} = pure e +ηM e@(Lam t@Arrow{} _ _) = do + let l = length (doms t) + (preL, e') = tuck e + (lam, app) <- unseam (take (l-cLam e) $ doms t) + pure (lam (preL (app e'))) +-- "\\y. (y*)" -> (λx. (λy. (y * x))) diff --git a/src/A/Opt.hs b/src/A/Opt.hs new file mode 100644 --- /dev/null +++ b/src/A/Opt.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE OverloadedStrings #-} + +module A.Opt ( optA + ) where + +import A +import Data.Bits ((.<<.), (.>>.)) +import R +import R.R + +-- TODO zip-of-map->zip + +fop op e0 = EApp F (EApp (F ~> F) (Builtin (F ~> F ~> F) op) e0) +eMinus = fop Minus; eDiv = fop Div + +mShLit (Id _ (AShLit is es)) = Just (is, es) +mShLit (ALit _ es) = Just ([length es], es) +mShLit _ = Nothing + +mSz :: Sh a -> Maybe Int +mSz (Ix _ i `Cons` sh) = (i*)<$>mSz sh +mSz Nil = Just 1 +mSz _ = Nothing + +optA :: E (T ()) -> RM (E (T ())) +optA (ILit F x) = pure (FLit F (realToFrac x)) +optA e@ILit{} = pure e +optA e@FLit{} = pure e +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 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) +optA (EApp l0 (EApp l1 op@(Builtin _ Exp) e0) e1) = do + e0' <- optA e0 + e1' <- optA e1 + pure $ case (e0', e1') of + (FLit _ x, FLit _ y) -> FLit l0 (x**y) + _ -> EApp l0 (EApp l1 op e0') e1' +optA (EApp l0 (EApp l1 op@(Builtin l2 Div) e0) e1) = do + e0' <- optA e0 + e1' <- optA e1 + pure $ case (e0', e1') of + (FLit _ x, FLit _ y) -> FLit l0 (x/y) + (x, FLit t y) -> EApp l0 (EApp l1 (Builtin l2 Times) x) (FLit t (1/y)) + _ -> EApp l0 (EApp l1 op e0') e1' +optA (EApp l0 op@(Builtin _ N) e0) = do + e0' <- optA e0 + pure $ case e0' of + (BLit _ b) -> BLit B (not b) + _ -> EApp l0 op e0' +optA (EApp l0 (EApp l1 op@(Builtin _ Sr) e0) e1) = do + e0' <- optA e0 + e1' <- optA e1 + pure $ case (e0', e1') of + (ILit _ m, ILit _ n) -> ILit I (m .>>. fromIntegral n) + _ -> EApp l0 (EApp l1 op e0') e1' +optA (EApp l0 (EApp l1 op@(Builtin _ Sl) e0) e1) = do + e0' <- optA e0 + e1' <- optA e1 + pure $ case (e0', e1') of + (ILit _ m, ILit _ n) -> ILit I (m .<<. fromIntegral n) + _ -> EApp l0 (EApp l1 op e0') e1' +optA (Lam l n e) = Lam l n <$> optA e +optA (EApp l0 (EApp l1 op@(Builtin _ Times) x) y) = do + xO <- optA x + yO <- optA y + pure $ case (xO, yO) of + (FLit _ x', FLit _ y') -> FLit F (x'*y') + (FLit _ x', ILit _ y') -> FLit F (x'*realToFrac y') + (ILit _ x', FLit _ y') -> FLit F (realToFrac x'*y') + _ -> EApp l0 (EApp l1 op xO) yO +optA (EApp l0 f@(Builtin _ ItoF) x) = do + x' <- optA x + pure $ case x' of + ILit _ n -> FLit F (realToFrac n) + _ -> EApp l0 f x' +optA (EApp l0 (EApp l1 op@(Builtin _ Minus) x) y) = do + xO <- optA x + yO <- optA y + pure $ case (xO, yO) of + (FLit _ x', FLit _ y') -> FLit F (x'-y') + (FLit _ x', ILit _ y') -> FLit F (x'-realToFrac y') + (ILit _ x', FLit _ y') -> FLit F (realToFrac x'-y') + _ -> EApp l0 (EApp l1 op xO) yO +optA (EApp l op@(Builtin _ Sqrt) x) = do + xO <- optA x + pure $ case xO of + FLit _ z -> FLit F (sqrt z) + _ -> EApp l op xO +optA (EApp _ (Builtin _ Floor) (EApp _ (Builtin _ ItoF) x)) = optA x +optA (EApp ty (EApp _ (Builtin _ IntExp) x) (ILit _ 2)) = pure $ EApp ty (EApp (ty ~> ty) (Builtin (ty ~> ty ~> ty) Times) x) x +optA (EApp l0 (EApp _ (Builtin _ Fold) op) (EApp _ (EApp _ (EApp _ (Builtin _ FRange) start) end) nSteps)) = do + start' <- optA start + incrN <- optA $ (end `eMinus` start) `eDiv` (EApp F (Builtin (Arrow I F) ItoF) nSteps `eMinus` FLit F 1) + fF <- optA op + n <- nextU "n" F + pure $ Id l0 $ FoldGen start' (Lam (F ~> F) n (EApp F (EApp (F ~> F) (Builtin (F ~> F ~> F) Plus) incrN) (Var F n))) fF nSteps +optA (EApp l0 (EApp _ (Builtin _ Fold) op) (EApp _ (EApp _ (EApp _ (Builtin _ Gen) seed) f) n)) = + Id l0 <$> (FoldGen <$> optA seed <*> optA f <*> optA op <*> optA n) +optA (EApp l0 (EApp _ (EApp _ (Builtin _ ho0@FoldS) op) seed) (EApp _ (EApp _ (Builtin _ Map) f) x)) + | Arrow dom fCod <- eAnn f + , Arrow _ (Arrow _ cod) <- eAnn op = do + x' <- optA x + x0 <- nextU "x" cod + x1 <- nextU "y" dom + opA <- optA op + 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 _ Map) f) (EApp _ (EApp _ (Builtin _ Map) g) xs)) + | (Arrow _ fCod) <- eAnn f + , (Arrow gDom _) <- eAnn g = do + f' <- optA f; g' <- optA g + xs' <- optA xs + x <- nextU "x" gDom + let vx=Var gDom x + fog=Lam (gDom ~> fCod) x (EApp undefined f' (EApp undefined g' vx)) + pure (EApp l0 (EApp undefined (Builtin undefined Map) fog) xs') +optA (EApp l0 (EApp _ (Builtin _ Fold) op) (EApp _ (EApp _ (Builtin _ Map) f) x)) + | fTy@(Arrow dom fCod) <- eAnn f + , Arrow _ (Arrow _ cod) <- eAnn op = do + f' <- optA f; f'' <- rE f' + x' <- optA x + x0 <- nextU "x" cod; x1 <- nextU "y" dom + x0' <- nextU "x" dom + opA <- optA op + let vx0 = Var cod x0; vx1 = Var dom x1 + vx0' = Var dom x0' + opT = cod ~> dom ~> cod + 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)) + | 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 + 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 t0 (EApp t1 (Builtin bt b@FoldS) op) seed) arr) = do + arr' <- optA arr + seed' <- optA seed + opA <- optA op + case arr' of + (EApp _ (EApp _ (EApp _ (Builtin _ Zip) f) xs) ys) + | Arrow dom0 (Arrow dom1 dom2) <- eAnn f + , Arrow _ (Arrow _ cod) <- eAnn op -> do + f' <- optA f + xs' <- optA xs + ys' <- optA ys + x0 <- nextU "x" cod; x1 <- nextU "y" dom0; x2 <- nextU "z" dom1 + let vx0 = Var cod x0; vx1 = Var dom0 x1; vx2 = Var dom1 x2 + opTy = cod ~> dom0 ~> dom1 ~> cod + op' = Lam opTy x0 (Lam undefined x1 (Lam (dom1 ~> cod) x2 (EApp cod (EApp undefined opA vx0) (EApp dom2 (EApp undefined f' vx1) vx2)))) + pure $ Id l $ FoldSOfZip seed' op' [xs',ys'] + _ -> pure (EApp l (EApp t0 (EApp t1 (Builtin bt b) opA) seed') arr') +optA (EApp t0 (EApp t1 (Builtin bt Fold) op) arr) = do + arr' <- optA arr + opA <- optA op + case arr' of + (EApp _ (EApp _ (EApp _ (Builtin _ Zip) f) xs) ys) + | 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 + 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 + vx0' = Var dom0 x0'; vx1' = Var dom1 x1' + opT = cod ~> dom0 ~> dom1 ~> cod + op' = Lam opT x0 (Lam undefined x1 (Lam (dom1 ~> cod) x2 (EApp cod (EApp undefined opA vx0) (EApp dom2 (EApp undefined f' vx1) vx2)))) + f''' = Lam fTy x0' (Lam undefined x1' (EApp dom2 (EApp undefined f'' vx0') vx1')) + pure $ Id t0 $ FoldOfZip f''' op' [xs',ys'] + _ -> pure (EApp t0 (EApp t1 (Builtin bt Fold) opA) arr') +optA (EApp l e0 e1) = EApp l <$> optA e0 <*> optA e1 +optA (ALit l es) = do + es' <- traverse optA es + pure $ case unzip <$> traverse mShLit es' of + Nothing -> Id l $ AShLit [length es] es' + Just (ds, esϵ) -> Id l $ AShLit (length ds : head ds) (concat esϵ) +optA (Tup l es) = Tup l <$> traverse optA es +optA (Let l (n, e') e) = do + e'Opt <- optA e' + eOpt <- optA e + pure $ Let l (n, e'Opt) eOpt +optA (LLet l (n, e') e) = do + e'Opt <- optA e' + eOpt <- optA e + pure $ LLet l (n, e'Opt) eOpt +optA (Id l idm) = Id l <$> optI idm +optA (Cond l p e0 e1) = Cond l <$> optA p <*> optA e0 <*> optA e1 + +optI (FoldSOfZip seed op es) = FoldSOfZip <$> optA seed <*> optA op <*> traverse optA es +optI (FoldOfZip zop op es) = FoldOfZip <$> optA zop <*> optA op <*> traverse optA es +optI (FoldGen seed f g n) = FoldGen <$> optA seed <*> optA f <*> optA g <*> optA n +optI (AShLit ds es) = AShLit ds <$> traverse optA es diff --git a/src/Asm/Aarch64.hs b/src/Asm/Aarch64.hs new file mode 100644 --- /dev/null +++ b/src/Asm/Aarch64.hs @@ -0,0 +1,465 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Asm.Aarch64 ( AArch64 (..) + , Addr (..) + , Cond (..) + , Shift (..), BM (..) + , AbsReg (..) + , FAbsReg (..) + , AReg (..) + , FAReg (..) + , prettyDebug + , mapR + , mapFR + , toInt + , fToInt + , pus, pos + , puds, pods + , pSym + ) where + +import Asm.M +import Control.DeepSeq (NFData (..)) +import Data.Copointed +import Data.Word (Word16, Word8) +import GHC.Generics (Generic) +import Numeric (showHex) +import Prettyprinter (Doc, Pretty (..), brackets, (<+>)) +import Prettyprinter.Ext +import System.Info (os) + +-- https://developer.arm.com/documentation/102374/0101/Registers-in-AArch64---other-registers +data AReg = X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 | X16 | X17 | X18 | X19 | X20 | X21 | X22 | X23 | X24 | X25 | X26 | X27 | X28 | X29 | X30 | SP deriving (Eq, Ord, Enum, Generic) + +instance Pretty AReg where + pretty X0 = "x0"; pretty X1 = "x1"; pretty X2 = "x2"; pretty X3 = "x3"; pretty X4 = "x4"; pretty X5 = "x5"; pretty X6 = "x6"; pretty X7 = "x7" + pretty X8 = "x8"; pretty X9 = "x9"; pretty X10 = "x10"; pretty X11 = "x11"; pretty X12 = "x12"; pretty X13 = "x13"; pretty X14 = "x14"; pretty X15 = "x15" + pretty X16 = "x16"; pretty X17 = "x17"; pretty X18 = "x18"; pretty X19 = "x19"; pretty X20 = "x20"; pretty X21 = "x21"; pretty X22 = "x22"; pretty X23 = "x23" + pretty X24 = "x24"; pretty X25 = "x25"; pretty X26 = "x26"; pretty X27 = "x27"; pretty X28 = "x28"; pretty X29 = "x29"; pretty X30 = "x30"; pretty SP = "sp" + +instance Show AReg where show = show.pretty + +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 + pretty D0 = "d0"; pretty D1 = "d1"; pretty D2 = "d2"; pretty D3 = "d3"; pretty D4 = "d4"; pretty D5 = "d5"; pretty D6 = "d6"; pretty D7 = "d7" + pretty D8 = "d8"; pretty D9 = "d9"; pretty D10 = "d10"; pretty D11 = "d11"; pretty D12 = "d12"; pretty D13 = "d13"; pretty D14 = "d14"; pretty D15 = "d15" + 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 NFData AReg where +instance NFData FAReg where + +data AbsReg = IReg !Int | CArg0 | CArg1 | CArg2 | CArg3 | CArg4 | CArg5 | CArg6 | CArg7 | LR | FP | ASP +-- r0-r7 used for return values as well + +instance Pretty AbsReg where + pretty (IReg i) = "T" <> pretty i + pretty LR = "LR" + pretty ASP = "SP" + pretty CArg0 = "X0" + pretty CArg1 = "X1" + pretty CArg2 = "X2" + pretty CArg3 = "X3" + pretty CArg4 = "X4" + pretty CArg5 = "X5" + pretty CArg6 = "X6" + pretty CArg7 = "X7" + pretty FP = "FP" + +data FAbsReg = FReg !Int | FArg0 | FArg1 | FArg2 | FArg3 | FArg4 | FArg5 | FArg6 | FArg7 + +instance Pretty FAbsReg where + pretty (FReg i) = "F" <> pretty i + pretty FArg0 = "D0" + pretty FArg1 = "D1" + pretty FArg2 = "D2" + pretty FArg3 = "D3" + pretty FArg4 = "D4" + pretty FArg5 = "D5" + pretty FArg6 = "D6" + pretty FArg7 = "D7" + +toInt :: AbsReg -> Int +toInt CArg0 = 0 +toInt CArg1 = 1 +toInt CArg2 = 2 +toInt CArg3 = 3 +toInt CArg4 = 4 +toInt CArg5 = 5 +toInt CArg6 = 6 +toInt CArg7 = 7 +toInt LR = 8 +toInt ASP = 9 +toInt FP = 18 +toInt (IReg i) = 19+i + +fToInt :: FAbsReg -> Int +fToInt FArg0 = 10 +fToInt FArg1 = 11 +fToInt FArg2 = 12 +fToInt FArg3 = 13 +fToInt FArg4 = 14 +fToInt FArg5 = 15 +fToInt FArg6 = 16 +fToInt FArg7 = 17 +fToInt (FReg i) = 19+i + +data Shift = Zero | Three + +instance NFData Shift where rnf Zero = (); rnf Three = () + +instance Pretty Shift where + pretty Zero = "#0"; pretty Three = "#3" + +-- left: shift left by this much +data BM = BM { ims, left :: !Word8 } deriving Eq + +instance NFData BM where rnf (BM i ls) = rnf i `seq` rnf ls + +instance Pretty BM where + pretty (BM m l) = "0b" <> pretty (replicate (fromIntegral m) '1' ++ replicate (fromIntegral l) '0') + +data Addr reg = R reg | RP reg Word16 | BI reg reg Shift deriving (Functor, Generic) + +instance NFData a => NFData (Addr a) where + +instance Pretty reg => Pretty (Addr reg) where + pretty (R r) = 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) + +data Cond = Eq | Neq | Geq | Lt | Gt | Leq + +instance NFData Cond where rnf Eq=(); rnf Neq=(); rnf Geq=(); rnf Lt=(); rnf Gt=(); rnf Leq=() + +instance Pretty Cond where + pretty Eq = "EQ"; pretty Neq = "NE"; pretty Geq = "GE" + pretty Lt = "LT"; pretty Gt = "GT"; pretty Leq = "LE" + +pSym :: Pretty a => a -> Doc ann +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) + +instance (NFData r, NFData d, NFData a) => NFData (AArch64 r d a) where + +instance Copointed (AArch64 reg freg) where copoint = ann + +mapR :: (areg -> reg) -> AArch64 areg afreg a -> AArch64 reg afreg a +mapR _ (Label x l) = Label x l +mapR _ (B x l) = B x l +mapR _ (Bc x c l) = Bc x c l +mapR _ (Bl x f) = Bl x f +mapR _ (C x l) = C x l +mapR _ (FMovXX l r0 r1) = FMovXX l r0 r1 +mapR f (MovRR l r0 r1) = MovRR l (f r0) (f r1) +mapR f (MovRC l r c) = MovRC l (f r) c +mapR f (Ldr l r a) = Ldr l (f r) (f <$> a) +mapR f (LdrB l r a) = LdrB l (f r) (f <$> a) +mapR f (Str l r a) = Str l (f r) (f <$> a) +mapR f (StrB l r a) = StrB l (f r) (f<$>a) +mapR f (LdrD l xr a) = LdrD l xr (f <$> a) +mapR f (AddRR l r0 r1 r2) = AddRR l (f r0) (f r1) (f r2) +mapR f (AddRRS l r0 r1 r2 s) = AddRRS l (f r0) (f r1) (f r2) s +mapR f (SubRR l r0 r1 r2) = SubRR l (f r0) (f r1) (f r2) +mapR f (AddRC l r0 r1 c) = AddRC l (f r0) (f r1) c +mapR f (SubRC l r0 r1 c) = SubRC l (f r0) (f r1) c +mapR f (ZeroR l r) = ZeroR l (f r) +mapR f (Mvn l r0 r1) = Mvn l (f r0) (f r1) +mapR f (AndRR l r0 r1 r2) = AndRR l (f r0) (f r1) (f r2) +mapR f (OrRR l r0 r1 r2) = OrRR l (f r0) (f r1) (f r2) +mapR f (Eor l r0 r1 r2) = Eor l (f r0) (f r1) (f r2) +mapR f (Lsl l r0 r1 s) = Lsl l (f r0) (f r1) s +mapR f (Asr l r0 r1 s) = Asr l (f r0) (f r1) s +mapR f (CmpRR l r0 r1) = CmpRR l (f r0) (f r1) +mapR f (CmpRC l r c) = CmpRC l (f r) c +mapR f (Neg l r0 r1) = Neg l (f r0) (f r1) +mapR _ (Fadd l xr0 xr1 xr2) = Fadd l xr0 xr1 xr2 +mapR _ (Fsub l xr0 xr1 xr2) = Fsub l xr0 xr1 xr2 +mapR _ (Fmul l xr0 xr1 xr2) = Fmul l xr0 xr1 xr2 +mapR _ (Fneg l xr0 xr1) = Fneg l xr0 xr1 +mapR _ (FcmpZ l xr) = FcmpZ l xr +mapR _ (Ret l) = Ret l +mapR _ (RetL x l) = RetL x l +mapR f (MulRR l r0 r1 r2) = MulRR l (f r0) (f r1) (f r2) +mapR f (Madd l r0 r1 r2 r3) = Madd l (f r0) (f r1) (f r2) (f r3) +mapR f (Msub l r0 r1 r2 r3) = Msub l (f r0) (f r1) (f r2) (f r3) +mapR f (Sdiv l r0 r1 r2) = Sdiv l (f r0) (f r1) (f r2) +mapR f (StrD l d a) = StrD l d (f <$> a) +mapR _ (Fdiv l d0 d1 d2) = Fdiv l d0 d1 d2 +mapR f (Scvtf l d r) = Scvtf l d (f r) +mapR f (Fcvtms l r d) = Fcvtms l (f r) d +mapR f (Fcvtas l r d) = Fcvtas l (f r) d +mapR f (MovK l r u s) = MovK l (f r) u s +mapR f (MovZ l r u s) = MovZ l (f r) u s +mapR f (FMovDR l d r) = FMovDR l d (f r) +mapR _ (Fcmp l d0 d1) = Fcmp l d0 d1 +mapR f (Ldp l r0 r1 a) = Ldp l (f r0) (f r1) (f <$> a) +mapR f (Stp l r0 r1 a) = Stp l (f r0) (f r1) (f <$> a) +mapR f (LdpD l d0 d1 a) = LdpD l d0 d1 (f <$> a) +mapR f (StpD l d0 d1 a) = StpD l d0 d1 (f <$> a) +mapR _ (Fmadd l d0 d1 d2 d3) = Fmadd l d0 d1 d2 d3 +mapR _ (Fmsub l d0 d1 d2 d3) = Fmsub l d0 d1 d2 d3 +mapR _ (Fsqrt l d0 d1) = Fsqrt l d0 d1 +mapR _ (Frintm l d0 d1) = Frintm l d0 d1 +mapR f (MrsR l r) = MrsR l (f r) +mapR f (MovRCf l r cf) = MovRCf l (f r) cf +mapR f (LdrRL x r l) = LdrRL x (f r) l +mapR f (Blr l r) = Blr l (f r) +mapR _ (Fmax l d0 d1 d2) = Fmax l d0 d1 d2 +mapR _ (Fmin l d0 d1 d2) = Fmin l d0 d1 d2 +mapR _ (Fabs l d0 d1) = Fabs l d0 d1 +mapR f (Csel l r0 r1 r2 p) = Csel l (f r0) (f r1) (f r2) p +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 _ (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 + +mapFR :: (afreg -> freg) -> AArch64 areg afreg a -> AArch64 areg freg a +mapFR _ (Label x l) = Label x l +mapFR _ (B x l) = B x l +mapFR _ (Bc x c l) = Bc x c l +mapFR _ (Bl x f) = Bl x f +mapFR _ (C x l) = C x l +mapFR f (FMovXX l xr0 xr1) = FMovXX l (f xr0) (f xr1) +mapFR _ (MovRR l r0 r1) = MovRR l r0 r1 +mapFR _ (MovRC l r0 c) = MovRC l r0 c +mapFR _ (Ldr l r a) = Ldr l r a +mapFR _ (LdrB l r a) = LdrB l r a +mapFR _ (Str l r a) = Str l r a +mapFR _ (StrB l r a) = StrB l r a +mapFR f (LdrD l xr a) = LdrD l (f xr) a +mapFR _ (AddRR l r0 r1 r2) = AddRR l r0 r1 r2 +mapFR _ (AddRRS l r0 r1 r2 s) = AddRRS l r0 r1 r2 s +mapFR _ (AddRC l r0 r1 c) = AddRC l r0 r1 c +mapFR _ (SubRR l r0 r1 r2) = SubRR l r0 r1 r2 +mapFR _ (SubRC l r0 r1 c) = SubRC l r0 r1 c +mapFR _ (ZeroR l r) = ZeroR l r +mapFR _ (Mvn l r0 r1) = Mvn l r0 r1 +mapFR _ (AndRR l r0 r1 r2) = AndRR l r0 r1 r2 +mapFR _ (OrRR l r0 r1 r2) = OrRR l r0 r1 r2 +mapFR _ (Eor l r0 r1 r2) = Eor l r0 r1 r2 +mapFR _ (EorI l r0 r1 i) = EorI l r0 r1 i +mapFR _ (Lsl l r0 r1 s) = Lsl l r0 r1 s +mapFR _ (Asr l r0 r1 s) = Asr l r0 r1 s +mapFR _ (CmpRC l r c) = CmpRC l r c +mapFR _ (CmpRR l r0 r1) = CmpRR l r0 r1 +mapFR _ (Neg l r0 r1) = Neg l r0 r1 +mapFR f (Fmul l xr0 xr1 xr2) = Fmul l (f xr0) (f xr1) (f xr2) +mapFR f (Fadd l xr0 xr1 xr2) = Fadd l (f xr0) (f xr1) (f xr2) +mapFR f (Fsub l xr0 xr1 xr2) = Fsub l (f xr0) (f xr1) (f xr2) +mapFR f (FcmpZ l xr) = FcmpZ l (f xr) +mapFR _ (Ret l) = Ret l +mapFR _ (RetL x l) = RetL x l +mapFR f (Fdiv l d0 d1 d2) = Fdiv l (f d0) (f d1) (f d2) +mapFR _ (MulRR l r0 r1 r2) = MulRR l r0 r1 r2 +mapFR _ (Madd l r0 r1 r2 r3) = Madd l r0 r1 r2 r3 +mapFR _ (Msub l r0 r1 r2 r3) = Msub l r0 r1 r2 r3 +mapFR _ (Sdiv l r0 r1 r2) = Sdiv l r0 r1 r2 +mapFR f (StrD l d a) = StrD l (f d) a +mapFR f (Scvtf l d r) = Scvtf l (f d) r +mapFR f (Fcvtms l r d) = Fcvtms l r (f d) +mapFR f (Fcvtas l r d) = Fcvtas l r (f d) +mapFR _ (MovK l r u s) = MovK l r u s +mapFR _ (MovZ l r u s) = MovZ l r u s +mapFR f (FMovDR l d r) = FMovDR l (f d) r +mapFR f (Fcmp l d0 d1) = Fcmp l (f d0) (f d1) +mapFR _ (Stp l r0 r1 a) = Stp l r0 r1 a +mapFR _ (Ldp l r0 r1 a) = Ldp l r0 r1 a +mapFR f (StpD l d0 d1 a) = StpD l (f d0) (f d1) a +mapFR f (LdpD l d0 d1 a) = LdpD l (f d0) (f d1) a +mapFR f (Fmadd l d0 d1 d2 d3) = Fmadd l (f d0) (f d1) (f d2) (f d3) +mapFR f (Fmsub l d0 d1 d2 d3) = Fmsub l (f d0) (f d1) (f d2) (f d3) +mapFR f (Fsqrt l d0 d1) = Fsqrt l (f d0) (f d1) +mapFR f (Fneg l d0 d1) = Fneg l (f d0) (f d1) +mapFR f (Frintm l d0 d1) = Frintm l (f d0) (f d1) +mapFR _ (MrsR l r) = MrsR l r +mapFR _ (Blr l r) = Blr l r +mapFR _ (MovRCf l r cf) = MovRCf l r cf +mapFR _ (LdrRL x r l) = LdrRL x r l +mapFR f (Fmax l d0 d1 d2) = Fmax l (f d0) (f d1) (f d2) +mapFR f (Fmin l d0 d1 d2) = Fmin l (f d0) (f d1) (f d2) +mapFR f (Fabs l d0 d1) = Fabs l (f d0) (f d1) +mapFR _ (Csel l r0 r1 r2 p) = Csel l r0 r1 r2 p +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 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 + +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] + +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] + +hexd :: Integral a => a -> Doc ann +hexd = pretty.($"").(("#0x"++).).showHex + +instance (Pretty reg, Pretty freg) => Pretty (AArch64 reg freg a) where + pretty (Label _ l) = prettyLabel l <> ":" + pretty (B _ l) = i4 ("b" <+> prettyLabel l) + pretty (Blr _ r) = i4 ("blr" <+> pretty r) + pretty (Bl _ l) = i4 ("bl" <+> pSym l) + pretty (C _ l) = i4 ("call" <+> pretty l) + pretty (Bc _ c l) = i4 ("b." <> pretty c <+> prettyLabel l) + pretty (FMovXX _ xr0 xr1) = i4 ("fmov" <+> pretty xr0 <> "," <+> pretty xr1) + pretty (FMovDR _ d r) = i4 ("fmov" <+> pretty d <> "," <+> pretty r) + pretty (MovRR _ r0 r1) = i4 ("mov" <+> pretty r0 <> "," <+> pretty r1) + pretty (MovRC _ r u) = i4 ("mov" <+> pretty r <> "," <+> hexd u) + pretty (Ldr _ r a) = i4 ("ldr" <+> pretty r <> "," <+> pretty a) + pretty (LdrB _ r a) = i4 ("ldrb" <+> pretty r <> "," <+> pretty a) + pretty (Str _ r a) = i4 ("str" <+> pretty r <> "," <+> pretty a) + pretty (StrB _ r a) = i4 ("strb" <+> pretty r <> "," <+> pretty a) + pretty (LdrD _ xr a) = i4 ("ldr" <+> pretty xr <> "," <+> pretty a) + pretty (StrD _ xr a) = i4 ("str" <+> pretty xr <> "," <+> pretty a) + pretty (AddRR _ rD rS rS') = i4 ("add" <+> pretty rD <> "," <+> pretty rS <> "," <+> pretty rS') + pretty (AddRRS _ rD rS rS' s) = i4 ("add" <+> pretty rD <> "," <+> pretty rS <> "," <+> pretty rS' <> "," <+> "LSL" <+> "#" <> pretty s) + pretty (SubRR _ rD rS rS') = i4 ("sub" <+> pretty rD <> "," <+> pretty rS <> "," <+> pretty rS') + pretty (AndRR _ rD rS rS') = i4 ("and" <+> pretty rD <> "," <+> pretty rS <> "," <+> pretty rS') + pretty (OrRR _ rD rS rS') = i4 ("orr" <+> pretty rD <> "," <+> pretty rS <> "," <+> pretty rS') + pretty (Eor _ rD rS rS') = i4 ("eor" <+> pretty rD <> "," <+> pretty rS <> "," <+> pretty rS') + pretty (EorI _ rD rS i) = i4 ("eor" <+> pretty rD <> "," <+> pretty rS <> "," <+> pretty i) + pretty (ZeroR _ rD) = i4 ("eor" <+> pretty rD <> "," <+> pretty rD <> "," <+> pretty rD) + pretty (Mvn _ rD rS) = i4 ("mvn" <+> pretty rD <> "," <+> pretty rS) + pretty (MulRR _ rD rS rS') = i4 ("mul" <+> pretty rD <> "," <+> pretty rS <> "," <+> pretty rS') + pretty (SubRC _ rD rS u) = i4 ("sub" <+> pretty rD <> "," <+> pretty rS <> "," <+> hexd u) + pretty (AddRC _ rD rS u) = i4 ("add" <+> pretty rD <> "," <+> pretty rS <> "," <+> hexd u) + pretty (Lsl _ rD rS u) = i4 ("lsl" <+> pretty rD <> "," <+> pretty rS <> "," <+> hexd u) + pretty (Asr _ rD rS u) = i4 ("asr" <+> pretty rD <> "," <+> pretty rS <> "," <+> hexd u) + pretty (CmpRC _ r u) = i4 ("cmp" <+> pretty r <> "," <+> hexd u) + pretty (CmpRR _ r0 r1) = i4 ("cmp" <+> pretty r0 <> "," <+> pretty r1) + pretty (Neg _ rD rS) = i4 ("neg" <+> pretty rD <> "," <+> pretty rS) + pretty (Fmul _ rD r0 r1) = i4 ("fmul" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (Fadd _ rD r0 r1) = i4 ("fadd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (Fsub _ rD r0 r1) = i4 ("fsub" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (Fdiv _ rD r0 r1) = i4 ("fdiv" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (FcmpZ _ xr) = i4 ("fcmp" <+> pretty xr <> "," <+> "#0.0") + pretty (Fneg _ d0 d1) = i4 ("fneg" <+> pretty d0 <> "," <+> pretty d1) + pretty Ret{} = i4 "ret" + pretty RetL{} = i4 "ret" + pretty (Scvtf _ d r) = i4 ("scvtf" <+> pretty d <> "," <+> pretty r) + pretty (Fcvtms _ r d) = i4 ("fcvtms" <+> pretty r <> "," <+> pretty d) + pretty (Fcvtas _ r d) = i4 ("fcvtas" <+> pretty r <> "," <+> pretty d) + pretty (MovK _ r i s) = i4 ("movk" <+> pretty r <> "," <+> hexd i <> "," <+> "LSL" <+> "#" <> pretty s) + pretty (MovZ _ r i s) = i4 ("movz" <+> pretty r <> "," <+> hexd i <> "," <+> "LSL" <+> "#" <> pretty s) + 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 (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) + pretty (Fmsub _ d0 d1 d2 d3) = i4 ("fmsub" <+> pretty d0 <> "," <+> pretty d1 <> "," <+> pretty d2 <> "," <+> pretty d3) + pretty (Madd _ r0 r1 r2 r3) = i4 ("madd" <+> pretty r0 <> "," <+> pretty r1 <> "," <+> pretty r2 <> "," <+> pretty r3) + pretty (Msub _ r0 r1 r2 r3) = i4 ("msub" <+> pretty r0 <> "," <+> pretty r1 <> "," <+> pretty r2 <> "," <+> pretty r3) + pretty (Sdiv _ rD rS rS') = i4 ("sdiv" <+> pretty rD <> "," <+> pretty rS <> "," <+> pretty rS') + pretty (Fsqrt _ d0 d1) = i4 ("fsqrt" <+> pretty d0 <> "," <+> pretty d1) + pretty (Frintm _ d0 d1) = i4 ("frintm" <+> pretty d0 <> "," <+> pretty d1) + pretty (MrsR _ r) = i4 ("mrs" <+> pretty r <> "," <+> "rndr") + pretty (MovRCf _ r cf) = i4 ("mov" <+> pretty r <> "," <+> pretty cf) + pretty (LdrRL _ r l) = i4 ("ldr" <+> pretty r <> "," <+> "=arr_" <> pretty l) + pretty (Fmax _ d0 d1 d2) = i4 ("fmax" <+> pretty d0 <> "," <+> pretty d1 <> "," <+> pretty d2) + pretty (Fmin _ d0 d1 d2) = i4 ("fmin" <+> pretty d0 <> "," <+> pretty d1 <> "," <+> pretty d2) + pretty (Fabs _ d0 d1) = i4 ("fabs" <+> pretty d0 <> "," <+> pretty d1) + pretty (Csel _ r0 r1 r2 p) = i4 ("csel" <+> pretty r0 <> "," <+> pretty r1 <> "," <+> pretty r2 <> "," <+> pretty p) + 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 (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 + +prettyLive :: (Pretty reg, Pretty freg, Pretty o) => AArch64 reg freg o -> Doc ann +prettyLive r = pretty r <+> pretty (ann r) + +prettyDebug :: (Pretty freg, Pretty reg, Pretty o) => [AArch64 reg freg o] -> Doc ann +prettyDebug = prettyLines . fmap prettyLive diff --git a/src/Asm/Aarch64/B.hs b/src/Asm/Aarch64/B.hs new file mode 100644 --- /dev/null +++ b/src/Asm/Aarch64/B.hs @@ -0,0 +1,12 @@ +module Asm.Aarch64.B ( bb ) where + +import Asm.Aarch64 +import Asm.BB +import Data.List.Split (keepDelimsL, keepDelimsR, split, whenElt) + +bb :: [AArch64 reg freg a] -> [BB AArch64 reg freg 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 + mkBB x = BB x () + emptyBB (BB [] _)=True; emptyBB _=False diff --git a/src/Asm/Aarch64/Byte.hs b/src/Asm/Aarch64/Byte.hs new file mode 100644 --- /dev/null +++ b/src/Asm/Aarch64/Byte.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TupleSections #-} + +-- https://developer.arm.com/documentation/ddi0602/2021-12/Base-Instructions +module Asm.Aarch64.Byte ( allFp, assembleCtx, dbgFp ) where + +import Asm.Aarch64 +import Asm.M +import Control.Monad (when) +import Data.Bifunctor (bimap, second) +import Data.Bits (Bits (..)) +import qualified Data.ByteString as BS +import Data.Functor (($>)) +import qualified Data.IntMap as IM +import qualified Data.Map as M +import Data.Tuple.Extra (fst3, thd3) +import Data.Word (Word64, Word8) +import Foreign.Ptr (FunPtr, IntPtr (..), Ptr, nullPtr, ptrToIntPtr) +import GHC.Base (Int (I#), iShiftRL#) +import Hs.FFI +import Sys.DL + +hasMa :: [AArch64 reg freg 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 = 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 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 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) + when (p==nullPtr) $ error "failed to allocate memory for JIT" + ps <- aArr ds + let b = BS.pack.concatMap reverse$asm 0 (ps, bimap Just Just ctx, lbls) isns + (b,,snd<$>IM.lookupMin ps)<$>finish b p + +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 (ds, instrs) = do + let (sz, lbls) = mkIx 0 instrs + (fn, p) <- do + res <- prepAddrs instrs + case res of + (Just (m, _, _, _),_) -> (res,) <$> allocNear m (fromIntegral sz) + _ -> (res,) <$> allocExec (fromIntegral sz) + ps <- aArr ds + 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 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 +mkIx ix (LdrRL{}:asms) = mkIx (ix+16) asms +mkIx ix (_:asms) = mkIx (ix+4) asms +mkIx ix [] = (ix, M.empty) + +be :: Enum a => a -> Word8 +be = fromIntegral.fromEnum + +-- https://developer.arm.com/documentation/ddi0406/c/Application-Level-Architecture/Instruction-Details/Conditional-execution?lang=en +bp :: Cond -> Word8 +bp Eq=0b0000; bp Neq=0b0001; bp Gt=0b1100; bp Leq=0b1101; bp Geq=0b1010; bp Lt=0b1011 + +ip :: Cond -> Word8 +ip = bp.inv where inv Eq=Neq; inv Neq=Eq; inv Gt=Leq; inv Geq=Lt; inv Lt=Geq; inv Leq=Gt + +bs :: Shift -> Word8 +bs Zero=0b0; bs Three=0b1 + +lsr :: Int -> Int -> Int +lsr (I# n) (I# k) = I# (iShiftRL# n k) + +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 _ _ [] = [] +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) +asm ix st (MovK _ r i s:asms) = [0b11110010, 0b1 `shiftL` 7 .|. fromIntegral (s `quot` 16) `shiftL` 5 .|. fromIntegral (i `shiftR` 11), fromIntegral (i `shiftR` 3), (fromIntegral (0x7 .&. i) `shiftL` 5) .|. be r]:asm (ix+4) st asms +asm ix st (FMovDR _ d r:asms) = [0b10011110, 0b01100111, be r `shiftR` 3, lb r d]:asm (ix+4) st asms +asm ix st (FMovXX _ d0 d1:asms) = [0b00011110, 0x1 `shiftL` 6 .|. 0b100000, 0b10000 `shiftL` 2 .|. be d1 `shiftR` 3, lb d1 d0]:asm (ix+4) st asms +asm ix st (Fadd _ d0 d1 d2:asms) = [0b00011110, 0x3 `shiftL` 5 .|. be d2, 0b001010 `shiftL` 2 .|. (be d1 `shiftR` 3), lb d1 d0]:asm (ix+4) st asms +asm ix st (Fmul _ d0 d1 d2:asms) = [0b00011110, 0x3 `shiftL` 5 .|. be d2, 0x2 `shiftL` 2 .|. (be d1 `shiftR` 3), lb d1 d0]:asm (ix+4) st asms +asm ix st (Fsub _ d0 d1 d2:asms) = [0b00011110, 0x3 `shiftL` 5 .|. be d2, 0b1110 `shiftL` 2 .|. (be d1 `shiftR` 3), lb d1 d0]:asm (ix+4) st asms +asm ix st (Fdiv _ d0 d1 d2:asms) = [0b00011110, 0x3 `shiftL` 5 .|. be d2, 0b110 `shiftL` 2 .|. (be d1 `shiftR` 3), lb d1 d0]:asm (ix+4) st asms +asm ix st (Fmax _ d0 d1 d2:asms) = [0b00011110, 0x3 `shiftL` 5 .|. be d2, 0b10010 `shiftL` 2 .|. be d1 `shiftR` 3, lb d1 d0]:asm (ix+4) st asms +asm ix st (Fmin _ d0 d1 d2:asms) = [0b00011110, 0x3 `shiftL` 5 .|. be d2, 0b10110 `shiftL` 2 .|. be d1 `shiftR` 3, lb d1 d0]:asm (ix+4) st asms +asm ix st (Fabs _ d0 d1:asms) = [0b00011110, 0x60, 0x3 `shiftL` 6 .|. be d1 `shiftR` 3, lb d1 d0]:asm (ix+4) st asms +asm ix st (Fmadd _ d0 d1 d2 d3:asms) = [0b00011111, 0x2 `shiftL` 5 .|. be d2, be d3 `shiftL` 2 .|. be d1 `shiftR` 3, lb d1 d0]:asm (ix+4) st asms +asm ix st (Fmsub _ d0 d1 d2 d3:asms) = [0b00011111, 0x2 `shiftL` 5 .|. be d2, 0x1 `shiftL` 7 .|. be d3 `shiftL` 2 .|. be d1 `shiftR` 3, lb d1 d0]:asm (ix+4) st asms +asm ix st (Label{}:asms) = asm ix st asms +asm ix st (Ret{}:asms) = [0b11010110, 0b01011111, be X30 `shiftR` 3, (0x7 .&. be X30) `shiftL` 5]:asm (ix+4) st asms +asm ix st (RetL{}:asms) = [0b11010110, 0b01011111, be X30 `shiftR` 3, (0x7 .&. be X30) `shiftL` 5]:asm (ix+4) st asms +asm ix st (MrsR _ r:asms) = [0b11010101, 0b00111011, 0b00100100, be r]:asm (ix+4) st asms +asm _ _ (SubRR _ _ SP SP:_) = error "encoding not valid/supported" +asm _ _ (AddRR _ _ SP SP:_) = error "encoding not valid/supported." +asm ix st (SubRR _ SP r1 r2:asms) = [0b11001011, 0x1 `shiftL` 5 .|. be r2, 0b111 `shiftL` 5 .|. be r1 `shiftR` 3, lb r1 SP]:asm (ix+4) st asms +asm ix st (SubRR _ r0 SP r2:asms) = [0b11001011, 0x1 `shiftL` 5 .|. be r2, 0b111 `shiftL` 5 .|. be SP `shiftR` 3, lb SP r0]:asm (ix+4) st asms +asm ix st (SubRR _ r0 r1 r2:asms) = [0b11001011, be r2, be r1 `shiftR` 3, lb r1 r0]:asm (ix+4) st asms +asm ix st (AddRR _ SP r1 r2:asms) = [0b10001011, 0b1 `shiftL` 5 .|. be r2, 0b111 `shiftL` 5 .|. be r1 `shiftR` 3, lb r1 SP]:asm (ix+4) st asms +asm ix st (AddRR _ r0 SP r2:asms) = [0b10001011, 0b1 `shiftL` 5 .|. be r2, 0b111 `shiftL` 5 .|. be SP `shiftR` 3, lb SP r0]:asm (ix+4) st asms +asm ix st (AddRR l r0 r1 r2:asms) = asm ix st (AddRRS l r0 r1 r2 0:asms) +asm ix st (AddRRS _ r0 r1 r2 s:asms) = [0b10001011, be r2, s `shiftL` 2 .|. be r1 `shiftR` 3, lb r1 r0]:asm (ix+4) st asms +asm ix st (AndRR _ r0 r1 r2:asms) = [0b10001010, be r2, be r1 `shiftR` 3, lb r1 r0]:asm (ix+4) st asms +asm ix st (Eor _ r0 r1 r2:asms) = [0b11001010, be r2, be r1 `shiftR` 3, lb r1 r0]:asm (ix+4) st asms +asm ix st (Mvn _ r0 r1:asms) = [0b10101010, 0x1 `shiftL` 5 .|. be r1, 0x3, 0x7 `shiftL` 5 .|. be r0]:asm (ix+4) st asms +asm ix st (OrRR _ r0 r1 r2:asms) = [0b10101010, be r2, be r1 `shiftR` 3, lb r1 r0]:asm (ix+4) st asms +asm ix st (Neg _ r0 r1:asms) = [0b11001011, be r1, 0x3, 0x7 `shiftL` 5 .|. be r0]:asm (ix+4) st asms +asm ix st (MulRR _ r0 r1 r2:asms) = [0b10011011, be r2, 0b11111 `shiftL` 2 .|. be r1 `shiftR` 3, lb r1 r0]:asm (ix+4) st asms +asm ix st (Sdiv _ r0 r1 r2:asms) = [0b10011010, 0b110 `shiftL` 5 .|. be r2, 0b11 `shiftL` 2 .|. be r1 `shiftR` 3, lb r1 r0]:asm (ix+4) st asms +asm ix st (Madd _ r0 r1 r2 r3:asms) = [0b10011011, be r2, be r3 `shiftL` 2 .|. be r1 `shiftR` 3, lb r1 r0]:asm (ix+4) st asms +asm ix st (Msub _ r0 r1 r2 r3:asms) = [0b10011011, be r2, 0b1 `shiftL` 7 .|. be r3 `shiftL` 2 .|. be r1 `shiftR` 3, lb r1 r0]:asm (ix+4) st asms +asm ix st (AddRC _ r0 r1 i:asms) = [0b10010001, fromIntegral (i `shiftR` 6), fromIntegral (0b111111 .&. i) `shiftL` 2 .|. (be r1 `shiftR` 3), lb r1 r0]:asm (ix+4) st asms +asm ix st (SubRC _ r0 r1 i:asms) = [0b11010001, fromIntegral (i `shiftR` 6), fromIntegral (0b111111 .&. i) `shiftL` 2 .|. be r1 `shiftR` 3, lb r1 r0]:asm (ix+4) st asms +asm ix st (MovRR x r0 SP:asms) = asm ix st (AddRC x r0 SP 0:asms) +asm ix st (MovRR x SP r1:asms) = asm ix st (AddRC x SP r1 0:asms) +asm ix st (MovRR _ r0 r1:asms) = [0b10101010, be r1, 0x3, 0x7 `shiftL` 5 .|. be r0]:asm (ix+4) st asms +asm ix st (ZeroR _ r:asms) = [0b11001010, be r, be r `shiftR` 3, lb r r]:asm (ix+4) st asms +asm ix st (Csel _ r0 r1 r2 p:asms) = [0b10011010, 0x1 `shiftL` 7 .|. be r2, bp p `shiftL` 4 .|. be r1 `shiftR` 3, lb r1 r0]:asm (ix+4) st asms +asm ix st (Cset _ r p:asms) = [0b10011010, 0b10011111, ip p `shiftL` 4 .|. 0x7, 0x7 `shiftL` 5 .|. be r]:asm (ix+4) st asms +asm ix st (TstI _ r (BM 1 ro):asms) | ro <= 0b111111 = [0b11110010, 0x1 `shiftL` 6 .|. (0b111111 .&. (-ro)), be r `shiftR` 3, (0x7 .&. be r) `shiftL` 5 .|. 0b11111]:asm (ix+4) st asms +asm ix st (EorI _ r0 r1 (BM 1 0):asms) = [0b11010010, 0x1 `shiftL` 6, be r1 `shiftR` 5, lb r1 r0]:asm (ix+4) st asms +asm ix st (Fcsel _ d0 d1 d2 p:asms) = [0b00011110, 0x3 `shiftL` 5 .|. be d2, bp p `shiftL` 4 .|. 0x3 `shiftL` 2 .|. be d1 `shiftR` 3, lb d1 d0]:asm (ix+4) st asms +asm ix st (Fcmp _ d0 d1:asms) = [0b00011110, 0x3 `shiftL` 5 .|. be d1, 0b1000 `shiftL` 2 .|. be d0 `shiftR` 5, be d0 `shiftL` 5]:asm (ix+4) st asms +asm ix st (Ldr _ r (RP rb u):asms) | (uϵ, 0) <- u `quotRem` 8 = [0b11111001, 0x1 `shiftL` 6 .|. fromIntegral (uϵ `shiftR` 6), fromIntegral (0b111111 .&. uϵ) `shiftL` 2 .|. be rb `shiftR` 3, lb rb r]:asm (ix+4) st asms +asm ix st (Ldr _ r (R rb):asms) = [0xf9, 0x1 `shiftL` 6, be rb `shiftR` 3, lb rb r]:asm (ix+4) st asms +asm ix st (Ldr _ r (BI rb ri s):asms) = [0b11111000, 0x3 `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 (LdrB _ r (RP rb u):asms) | u <= 4095 = [0b00111001, 0x1 `shiftL` 6 .|. (fromIntegral u `shiftR` 6), fromIntegral (0b111111 .&. u) `shiftL` 2 .|. be rb `shiftR` 3, lb rb r]:asm (ix+4) st asms +asm ix st (LdrB _ r (BI rb ri s):asms) = [0b00111000, 0x3 `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 (Ldp x r0 r1 (R rb):asms) = asm ix st (Ldp x r0 r1 (RP rb 0):asms) +asm ix st (Ldp _ r0 r1 (RP rb u):asms) | (u', 0) <- u `quotRem` 8, u <= 504 = [0xa9, 0x1 `shiftL` 6 .|. 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 (Str x r (R rb):asms) = asm ix st (Str x r (RP rb 0):asms) +asm ix st (Str _ r (RP rb u):asms) | (uu, 0) <- u `quotRem` 8 = [0xf9, fromIntegral (uu `shiftR` 6), fromIntegral (0b111111 .&. uu) `shiftL` 2 .|. be rb `shiftR` 3, lb rb r]:asm (ix+4) st asms +asm ix st (Str _ r (BI rb ri s):asms) = [0b11111000, 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 (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 (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 (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 (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 (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 +asm ix st (Fcvtms _ r d:asms) = [0b10011110, 0x1 `shiftL` 6 .|. 0b110000, be d `shiftR` 3, lb d r]:asm (ix+4) st asms +asm ix st (Fcvtas _ r d:asms) = [0b10011110, 0x1 `shiftL` 6 .|. 0b100100, be d `shiftR` 3, lb d r]:asm (ix+4) st asms +asm ix st (Fsqrt _ d0 d1:asms) = [0b00011110, 0b01100001, 0x3 `shiftL` 6 .|. be d1 `shiftR` 3, lb d1 d0]:asm (ix+4) st asms +asm ix st (Fneg _ d0 d1:asms) = [0b00011110, 0b01100001, 0x1 `shiftL` 6 .|. be d1 `shiftR` 3, lb d1 d0]:asm (ix+4) st asms +asm ix st (Frintm _ d0 d1:asms) = [0b00011110, 0b01100101, 0x1 `shiftL` 6 .|. be d1 `shiftR` 3, lb d1 d0]:asm (ix+4) st asms +asm ix st (Asr _ r0 r1 s:asms) = [0b10010011, 0x1 `shiftL` 6 .|. s, 0b111111 `shiftL` 2 .|. be r1 `shiftR` 3, lb r0 r1]:asm (ix+4) st asms +asm ix st (Lsl _ r0 r1 s:asms) = + let immr= (-s) `mod` 64 + imms=63-s + in [0b11010011, 0x1 `shiftL` 6 .|. immr, imms `shiftL` 2 .|. be r1 `shiftR` 3, lb r1 r0]:asm (ix+4) st asms +asm ix st (Bc _ p l:asms) = + let lIx=get l st + offs=(lIx-ix) `quot` 4 + isn=[0b01010100, fromIntegral (offs `lsr` 11), fromIntegral (0xff .&. (offs `lsr` 3)), (fromIntegral (0x7 .&. offs) `shiftL` 5) .|. bp p] + in isn:asm (ix+4) st asms +asm ix st (Cbnz _ r l:asms) = + let lIx=get l st + 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) = + 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] + in isn:asm (ix+4) st asms +asm ix st (Tbnz _ r 0 l:asms) = + 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] + in isn:asm (ix+4) st asms +asm ix st (C _ l:asms) = + let lIx=get l st + offs=(lIx-(ix+8)) `quot` 4 + isn=[0b100101 `shiftL` 2 .|. fromIntegral (0x3 .&. (offs `lsr` 24)), fromIntegral (0xff .&. (offs `lsr` 16)), fromIntegral (0xff .&. (offs `lsr` 8)), fromIntegral (0xff .&. offs)] + pro=asm ix undefined [SubRC () SP SP 16, Stp () X29 X30 (R SP)] + in pro++isn:asm (ix+12) st (Ldp () X29 X30 (R SP):AddRC () SP SP 16:asms) +asm ix st (B _ l:asms) = + let lIx=get l st + offs=(lIx-ix) `quot` 4 + isn=[0x5 `shiftL` 2 .|. fromIntegral (0x3 .&. (offs `lsr` 24)), fromIntegral (0xff .&. (offs `lsr` 16)), fromIntegral (0xff .&. (offs `lsr` 8)), fromIntegral (0xff .&. offs)] + in isn:asm (ix+4) st asms +asm ix st (Blr _ r:asms) = [0b11010110, 0b00111111, be r `shiftR` 3, (0x7 .&. be r) `shiftL` 5]:asm (ix+4) st asms +asm ix st@(_, (Just (m, _, _, _), _), _) (MovRCf _ r Malloc:asms) = + asm ix st (m4 r m++asms) +asm ix st@(_, (Just (_, f, _, _), _), _) (MovRCf _ r Free:asms) = + asm ix st (m4 r f++asms) +asm ix st@(_, (_, Just (_, l, _)),_) (MovRCf _ r Log:asms) = + asm ix st (m4 r l++asms) +asm ix st@(_, (_, Just (e, _, _)),_) (MovRCf _ r Exp:asms) = + asm ix st (m4 r e++asms) +asm ix st@(_, (_, Just (_, _, p)),_) (MovRCf _ r Pow:asms) = + asm ix st (m4 r p++asms) +asm ix st@(_, (Just (_, _, d, _), _),_) (MovRCf _ r DR:asms) = + asm ix st (m4 r d++asms) +asm ix st@(_, (Just (_, _, _, j), _),_) (MovRCf _ r JR:asms) = + asm ix st (m4 r j++asms) +asm ix st (LdrRL _ r l:asms) = + let p = pI$arr l st + w0=p .&. 0xffff; w1=(p .&. 0xffff0000) `lsr` 16; w2=(p .&. 0xFFFF00000000) `lsr` 32; w3=(p .&. 0xFFFF000000000000) `lsr` 48 + 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 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] + +get :: Label -> (IM.IntMap (Ptr Word64), (Maybe CCtx, Maybe MCtx), M.Map Label Int) -> Int +get l = + M.findWithDefault (error "Internal error: label not found") l . thd3 + +arr :: Int -> (IM.IntMap (Ptr Word64), (Maybe CCtx, Maybe MCtx), M.Map Label Int) -> Ptr Word64 +arr n = IM.findWithDefault (error "Internal error: array not found during assembler stage") n . fst3 + +fst4 :: (a, b, c, d) -> a +fst4 (x, _, _, _) = x + +pI :: Ptr a -> Int +pI = (\(IntPtr i) -> i) . ptrToIntPtr diff --git a/src/Asm/Aarch64/CF.hs b/src/Asm/Aarch64/CF.hs new file mode 100644 --- /dev/null +++ b/src/Asm/Aarch64/CF.hs @@ -0,0 +1,382 @@ +module Asm.Aarch64.CF ( mkControlFlow + , expand + , udd + ) where + +import Asm.Aarch64 +import Asm.BB +import Asm.CF +import Asm.M +import CF +import Class.E as E +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 instrs = runFreshM (broadcasts instrs *> addControlFlow instrs) + +expand :: (E reg, E freg) => BB AArch64 reg freg () Liveness -> [AArch64 reg freg 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) + ao=ins s + aif=usesF a <> (aof IS.\\ defsF a) + aof=fins s + in a $> Liveness ai ao aif aof + lS = let ao=out li + aof=fout li + in asm $> Liveness (uses asm `IS.union` (ao `IS.difference` defs asm)) ao (usesF asm `IS.union` (aof `IS.difference` defsF asm)) aof + (iasms, asm) = (init asms, last asms) +expand _ = [] + +addControlFlow :: (E reg, E freg) => [BB AArch64 reg freg () ()] -> FreshM [BB AArch64 reg freg () ControlAnn] +addControlFlow [] = pure [] +addControlFlow (BB [] _:bbs) = addControlFlow bbs +addControlFlow (BB asms _:bbs) = do + { i <- case asms of + (Label _ l:_) -> lookupLabel l + _ -> getFresh + ; (f, bbs') <- next bbs + ; acc <- case last asms of + B _ lϵ -> do {l_i <- lookupLabel lϵ; pure [l_i]} + Bc _ _ lϵ -> do {l_i <- lookupLabel lϵ; pure (f [l_i])} + Tbnz _ _ _ lϵ -> do {l_i <- lookupLabel lϵ; pure $ f [l_i]} + Tbz _ _ _ lϵ -> do {l_i <- lookupLabel lϵ; pure $ f [l_i]} + Cbnz _ _ lϵ -> do {l_i <- lookupLabel lϵ; pure $ f [l_i]} + C _ lϵ -> do {l_i <- lookupLabel lϵ; pure $ f [l_i]} + RetL _ lϵ -> lC lϵ + _ -> pure (f []) + ; pure (BB asms (ControlAnn i acc (udb asms)) : bbs') + } + +uA :: E reg => Addr reg -> IS.IntSet +uA (R r) = singleton r +uA (RP r _) = singleton r +uA (BI b i _) = fromList [b, i] + +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 = 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 = 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 +uses (MovRR _ _ r) = singleton r +uses MovRC{} = IS.empty +uses FMovXX{} = IS.empty +uses (Ldr _ _ a) = uA a +uses (LdrB _ _ a) = uA a +uses (Str _ r a) = IS.insert (E.toInt r) $ uA a +uses (StrB _ r a) = IS.insert (E.toInt r) $ uA a +uses (Ldp _ _ _ a) = uA a +uses (Stp _ r0 r1 a) = fromList [r0, r1] <> uA a +uses (LdrD _ _ a) = uA a +uses (SubRR _ _ r0 r1) = fromList [r0, r1] +uses (AddRR _ _ r0 r1) = fromList [r0, r1] +uses (AddRRS _ _ r0 r1 _) = fromList [r0, r1] +uses (AndRR _ _ r0 r1) = fromList [r0, r1] +uses (OrRR _ _ r0 r1) = fromList [r0, r1] +uses (Eor _ _ r0 r1) = fromList [r0, r1] +uses (EorI _ _ r0 _) = singleton r0 +uses ZeroR{} = IS.empty +uses (Mvn _ _ r) = singleton r +uses (AddRC _ _ r _) = singleton r +uses (SubRC _ _ r _) = singleton r +uses (Lsl _ _ r _) = singleton r +uses (Asr _ _ r _) = singleton r +uses (CmpRR _ r0 r1) = fromList [r0, r1] +uses (CmpRC _ r _) = singleton r +uses (Neg _ _ r) = singleton r +uses Fmul{} = IS.empty +uses Fadd{} = IS.empty +uses Fsub{} = IS.empty +uses FcmpZ{} = IS.empty +uses (StrD _ _ a) = uA a +uses (MulRR _ _ r0 r1) = fromList [r0, r1] +uses (Madd _ _ r0 r1 r2) = fromList [r0, r1, r2] +uses (Msub _ _ r0 r1 r2) = fromList [r0, r1, r2] +uses (Sdiv _ _ r0 r1) = fromList [r0, r1] +uses Fdiv{} = IS.empty +uses (Scvtf _ _ r) = singleton r +uses Fcvtms{} = IS.empty +uses Fcvtas{} = IS.empty +uses (FMovDR _ _ r) = singleton r +uses (MovK _ r _ _) = singleton r +uses MovZ{} = IS.empty +uses Fcmp{} = IS.empty +uses (StpD _ _ _ a) = uA a +uses (LdpD _ _ _ a) = uA a +uses Fmadd{} = IS.empty +uses Fmsub{} = IS.empty +uses Fsqrt{} = IS.empty +uses Fneg{} = IS.empty +uses Frintm{} = IS.empty +uses MrsR{} = IS.empty +uses (MovRCf _ _ Free) = singleton CArg0 +uses (MovRCf _ _ Malloc) = singleton CArg0 +uses MovRCf{} = IS.empty +uses LdrRL{} = IS.empty +uses (Blr _ r) = singleton r +uses Fmax{} = IS.empty +uses Fmin{} = IS.empty +uses Fabs{} = IS.empty +uses (Csel _ _ r1 r2 _) = fromList [r1, r2] +uses Fcsel{} = IS.empty +uses (TstI _ r _) = singleton r +uses Label{} = IS.empty +uses Bc{} = IS.empty +uses B{} = IS.empty +uses (Cbnz _ r _) = singleton r +uses (Tbnz _ r _ _) = singleton r +uses (Tbz _ r _ _) = singleton r +uses Ret{} = singleton CArg0 +uses Cset{} = IS.empty +uses Bl{} = IS.empty +uses C{} = singleton ASP +uses RetL{} = singleton LR + +defs FMovXX{} = IS.empty +defs (MovRC _ r _) = singleton r +defs (MovRR _ r _) = singleton r +defs (Ldr _ r _) = singleton r +defs (LdrB _ r _) = singleton r +defs Str{} = IS.empty +defs StrB{} = IS.empty +defs LdrD{} = IS.empty +defs LdpD{} = IS.empty +defs Stp{} = IS.empty +defs StpD{} = IS.empty +defs (Ldp _ r0 r1 _) = fromList [r0, r1] +defs (SubRR _ r _ _) = singleton r +defs (AddRR _ r _ _) = singleton r +defs (AddRRS _ r _ _ _) = singleton r +defs (AndRR _ r _ _) = singleton r +defs (OrRR _ r _ _) = singleton r +defs (Eor _ r _ _) = singleton r +defs (EorI _ r _ _) = singleton r +defs (ZeroR _ r) = singleton r +defs (Mvn _ r _) = singleton r +defs (AddRC _ r _ _) = singleton r +defs (SubRC _ r _ _) = singleton r +defs (Lsl _ r _ _) = singleton r +defs (Asr _ r _ _) = singleton r +defs CmpRC{} = IS.empty +defs CmpRR{} = IS.empty +defs (Neg _ r _) = singleton r +defs Fmul{} = IS.empty +defs Fadd{} = IS.empty +defs Fsub{} = IS.empty +defs FcmpZ{} = IS.empty +defs StrD{} = IS.empty +defs (MulRR _ r _ _) = singleton r +defs (Madd _ r _ _ _) = singleton r +defs (Msub _ r _ _ _) = singleton r +defs (Sdiv _ r _ _) = singleton r +defs Fdiv{} = IS.empty +defs Scvtf{} = IS.empty +defs (Fcvtms _ r _) = singleton r +defs (Fcvtas _ r _) = singleton r +defs FMovDR{} = IS.empty +defs (MovK _ r _ _) = singleton r +defs (MovZ _ r _ _) = singleton r +defs Fcmp{} = IS.empty +defs Fmadd{} = IS.empty +defs Fmsub{} = IS.empty +defs Fsqrt{} = IS.empty +defs Fneg{} = IS.empty +defs Frintm{} = IS.empty +defs (MrsR _ r) = singleton r +defs Blr{} = singleton LR +defs (MovRCf _ r Malloc) = singleton r <> singleton CArg0 +defs (LdrRL _ r _) = singleton r +defs MovRCf{} = IS.empty +defs Fmax{} = IS.empty +defs Fmin{} = IS.empty +defs Fabs{} = IS.empty +defs (Csel _ r _ _ _) = singleton r +defs Fcsel{} = IS.empty +defs TstI{} = IS.empty +defs Label{} = IS.empty +defs Bc{} = IS.empty +defs B{} = IS.empty +defs Cbnz{} = IS.empty +defs Tbnz{} = IS.empty +defs Tbz{} = IS.empty +defs Ret{} = IS.empty +defs (Cset _ r _) = singleton r +defs Bl{} = singleton LR +defs C{} = fromList [LR, FP] +defs RetL{} = IS.empty + +defsF, usesF :: E freg => AArch64 reg freg ann -> IS.IntSet +defsF (FMovXX _ r _) = singleton r +defsF MovRR{} = IS.empty +defsF MovRC{} = IS.empty +defsF Ldr{} = IS.empty +defsF LdrB{} = IS.empty +defsF Str{} = IS.empty +defsF StrB{} = IS.empty +defsF (LdrD _ r _) = singleton r +defsF AddRR{} = IS.empty +defsF AddRRS{} = IS.empty +defsF SubRR{} = IS.empty +defsF AndRR{} = IS.empty +defsF OrRR{} = IS.empty +defsF Eor{} = IS.empty +defsF EorI{} = IS.empty +defsF ZeroR{} = IS.empty +defsF Mvn{} = IS.empty +defsF AddRC{} = IS.empty +defsF SubRC{} = IS.empty +defsF Lsl{} = IS.empty +defsF Asr{} = IS.empty +defsF CmpRR{} = IS.empty +defsF CmpRC{} = IS.empty +defsF Neg{} = IS.empty +defsF (Fmul _ r _ _) = singleton r +defsF (Fadd _ r _ _) = singleton r +defsF (Fsub _ r _ _) = singleton r +defsF FcmpZ{} = IS.empty +defsF (Fdiv _ d _ _) = singleton d +defsF StrD{} = IS.empty +defsF MulRR{} = IS.empty +defsF Madd{} = IS.empty +defsF Msub{} = IS.empty +defsF Sdiv{} = IS.empty +defsF (Scvtf _ r _) = singleton r +defsF Fcvtms{} = IS.empty +defsF Fcvtas{} = IS.empty +defsF (FMovDR _ r _) = singleton r +defsF MovK{} = IS.empty +defsF MovZ{} = IS.empty +defsF Fcmp{} = IS.empty +defsF (LdpD _ r0 r1 _) = fromList [r0, r1] +defsF Ldp{} = IS.empty +defsF Stp{} = IS.empty +defsF StpD{} = IS.empty +defsF (Fmadd _ d0 _ _ _) = singleton d0 +defsF (Fmsub _ d0 _ _ _) = singleton d0 +defsF (Fsqrt _ d _) = singleton d +defsF (Fneg _ d _) = singleton d +defsF (Frintm _ d _) = singleton d +defsF MrsR{} = IS.empty +defsF Blr{} = IS.empty +defsF (MovRCf _ _ Exp) = singleton FArg0 +defsF (MovRCf _ _ Log) = singleton FArg0 +defsF (MovRCf _ _ Pow) = singleton FArg0 +defsF MovRCf{} = IS.empty +defsF LdrRL{} = IS.empty +defsF (Fmax _ d _ _) = singleton d +defsF (Fmin _ d _ _) = singleton d +defsF (Fabs _ d _) = singleton d +defsF Csel{} = IS.empty +defsF TstI{} = IS.empty +defsF (Fcsel _ d0 _ _ _) = singleton d0 +defsF Label{} = IS.empty +defsF Bc{} = IS.empty +defsF B{} = IS.empty +defsF Cbnz{} = IS.empty +defsF Tbnz{} = IS.empty +defsF Tbz{} = IS.empty +defsF Ret{} = IS.empty +defsF RetL{} = IS.empty +defsF Cset{} = IS.empty +defsF Bl{} = IS.empty +defsF C{} = IS.empty + +usesF (FMovXX _ _ r) = singleton r +usesF MovRR{} = IS.empty +usesF MovRC{} = IS.empty +usesF Ldr{} = IS.empty +usesF LdrB{} = IS.empty +usesF LdrD{} = IS.empty +usesF Str{} = IS.empty +usesF StrB{} = IS.empty +usesF AddRR{} = IS.empty +usesF AddRRS{} = IS.empty +usesF SubRR{} = IS.empty +usesF ZeroR{} = IS.empty +usesF Mvn{} = IS.empty +usesF AndRR{} = IS.empty +usesF OrRR{} = IS.empty +usesF Eor{} = IS.empty +usesF EorI{} = IS.empty +usesF AddRC{} = IS.empty +usesF SubRC{} = IS.empty +usesF Lsl{} = IS.empty +usesF Asr{} = IS.empty +usesF CmpRR{} = IS.empty +usesF CmpRC{} = IS.empty +usesF Neg{} = IS.empty +usesF (Fadd _ _ r0 r1) = fromList [r0, r1] +usesF (Fsub _ _ r0 r1) = fromList [r0, r1] +usesF (Fmul _ _ r0 r1) = fromList [r0, r1] +usesF (FcmpZ _ r) = singleton r +usesF (Fdiv _ _ r0 r1) = fromList [r0, r1] +usesF (StrD _ r _) = singleton r +usesF MulRR{} = IS.empty +usesF Madd{} = IS.empty +usesF Msub{} = IS.empty +usesF Sdiv{} = IS.empty +usesF Scvtf{} = IS.empty +usesF (Fcvtms _ _ r) = singleton r +usesF (Fcvtas _ _ r) = singleton r +usesF MovK{} = IS.empty +usesF MovZ{} = IS.empty +usesF FMovDR{} = IS.empty +usesF (Fcmp _ r0 r1) = fromList [r0, r1] +usesF (StpD _ r0 r1 _) = fromList [r0, r1] +usesF Stp{} = IS.empty +usesF Ldp{} = IS.empty +usesF LdpD{} = IS.empty +usesF (Fmadd _ _ d0 d1 d2) = fromList [d0, d1, d2] +usesF (Fmsub _ _ d0 d1 d2) = fromList [d0, d1, d2] +usesF (Fsqrt _ _ d) = singleton d +usesF (Fneg _ _ d) = singleton d +usesF (Frintm _ _ d) = singleton d +usesF MrsR{} = IS.empty +usesF Blr{} = IS.empty +usesF (MovRCf _ _ Exp) = singleton FArg0 +usesF (MovRCf _ _ Log) = singleton FArg0 +usesF (MovRCf _ _ Pow) = fromList [FArg0, FArg1] +usesF MovRCf{} = IS.empty +usesF LdrRL{} = IS.empty +usesF (Fmax _ _ d0 d1) = fromList [d0, d1] +usesF (Fmin _ _ d0 d1) = fromList [d0, d1] +usesF (Fabs _ _ d) = singleton d +usesF Csel{} = IS.empty +usesF TstI{} = IS.empty +usesF (Fcsel _ _ d0 d1 _) = fromList [d0, d1] +usesF Label{} = IS.empty +usesF Bc{} = IS.empty +usesF B{} = IS.empty +usesF Cbnz{} = IS.empty +usesF Tbnz{} = IS.empty +usesF Tbz{} = IS.empty +usesF Ret{} = fromList [FArg0, FArg1] +usesF Cset{} = IS.empty +usesF Bl{} = IS.empty +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 bbs = do + nextBs <- addControlFlow bbs + case nextBs of + [] -> pure (id, []) + (b:_) -> pure ((node (caBB b) :), nextBs) + +broadcasts :: [BB AArch64 reg freg a ()] -> FreshM () +broadcasts [] = pure () +broadcasts ((BB asms@(asm:_) _):bbs@((BB (Label _ retL:_) _):_)) | C _ l <- last asms = do + { i <- fm retL; b3 i l + ; case asm of {Label _ lϵ -> void $ fm lϵ; _ -> pure ()} + ; broadcasts bbs + } +broadcasts ((BB (Label _ l:_) _):asms) = fm l *> broadcasts asms +broadcasts (_:asms) = broadcasts asms diff --git a/src/Asm/Aarch64/Fr.hs b/src/Asm/Aarch64/Fr.hs new file mode 100644 --- /dev/null +++ b/src/Asm/Aarch64/Fr.hs @@ -0,0 +1,83 @@ +module Asm.Aarch64.Fr ( frameC ) where + +import Asm.Aarch64 +import Asm.M +import CF +import Data.Copointed +import Data.Functor (void) +import qualified Data.IntSet as IS +import Data.Maybe (mapMaybe) + +frameC :: [AArch64 AReg FAReg Live] -> [AArch64 AReg FAReg ()] +frameC = concat.go IS.empty IS.empty + where go _ _ [] = [] + go _ _ [isn] = [[void isn]] + go s fs (isn0@(MovRCf _ _ cf):isn1@Blr{}:isns) = + let i0 = copoint isn0; i1=copoint isn1 + s' = s `IS.union` new i0 `IS.difference` done i0 + s'' = s' `IS.union` new i1 `IS.difference` done i1 + fs' = fs `IS.union` fnew i0 `IS.difference` fdone i0 + fs'' = fs' `IS.union` fnew i1 `IS.difference` fdone i1 + cs = handleX0 cf $ mapMaybe fromInt (IS.toList s) + ds = handleD0 cf $ mapMaybe fInt (IS.toList fs) + save = pus cs; restore = pos cs + saved = puds ds; restored = pods ds + in (save ++ saved ++ void isn0:void isn1:restored ++ restore) : go s'' fs'' isns + go s fs (isn:isns) = + let i = copoint isn + s' = s `IS.union` new i `IS.difference` done i + fs' = fs `IS.union` fnew i `IS.difference` fdone i + in [void isn] : go s' fs' isns + handleX0 Malloc=filter (/=X0); handleX0 Free=id; handleX0 Exp=id; handleX0 Log=id; handleX0 Pow=id; handleX0 DR=id; handleX0 JR=filter (/=X0) + handleD0 Exp=filter (/=D0); handleD0 Log=filter (/=D0);handleD0 Malloc=id;handleD0 Free=id; handleD0 Pow=filter (\d->d/=D0 && d/=D1); handleD0 DR=filter (/=D0); handleD0 JR=id + +-- https://developer.arm.com/documentation/102374/0101/Procedure-Call-Standard +fromInt :: Int -> Maybe AReg +fromInt 0 = Just X0 +fromInt 1 = Just X1 +fromInt 2 = Just X2 +fromInt 3 = Just X3 +fromInt 4 = Just X4 +fromInt 5 = Just X5 +fromInt 6 = Just X6 +fromInt 7 = Just X7 +fromInt (-1) = Just X8 +fromInt (-2) = Just X9 +fromInt (-3) = Just X10 +fromInt (-4) = Just X11 +fromInt (-5) = Just X12 +fromInt (-6) = Just X13 +fromInt (-7) = Just X14 +fromInt (-8) = Just X15 +fromInt (-9) = Just X16 +fromInt (-10) = Just X17 +fromInt (-11) = Just X18 +fromInt _ = Nothing + +-- https://learn.microsoft.com/en-us/cpp/build/arm64-windows-abi-conventions?view=msvc-170#floating-pointsimd-registers +fInt :: Int -> Maybe FAReg +fInt 10 = Just D0 +fInt 11 = Just D1 +fInt 12 = Just D2 +fInt 13 = Just D3 +fInt 14 = Just D4 +fInt 15 = Just D5 +fInt 16 = Just D6 +fInt 17 = Just D7 +fInt (-31) = Just D16 +fInt (-32) = Just D17 +fInt (-33) = Just D18 +fInt (-34) = Just D19 +fInt (-35) = Just D20 +fInt (-36) = Just D21 +fInt (-37) = Just D22 +fInt (-38) = Just D23 +fInt (-39) = Just D24 +fInt (-40) = Just D25 +fInt (-41) = Just D26 +fInt (-42) = Just D27 +fInt (-43) = Just D28 +fInt (-44) = Just D29 +fInt (-45) = Just D30 +fInt (-46) = Just D31 +fInt _ = Nothing diff --git a/src/Asm/Aarch64/Opt.hs b/src/Asm/Aarch64/Opt.hs new file mode 100644 --- /dev/null +++ b/src/Asm/Aarch64/Opt.hs @@ -0,0 +1,12 @@ +module Asm.Aarch64.Opt ( opt ) where + +import Asm.Aarch64 + +opt :: (Eq reg, Eq freg) => [AArch64 reg freg ()] -> [AArch64 reg freg ()] +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) +opt ((MovRR _ r0 r1):asms) | r0 == r1 = opt asms +opt ((FMovXX _ r0 r1):asms) | r0 == r1 = opt asms +opt (asm:asms) = asm : opt asms +opt [] = [] diff --git a/src/Asm/Aarch64/P.hs b/src/Asm/Aarch64/P.hs new file mode 100644 --- /dev/null +++ b/src/Asm/Aarch64/P.hs @@ -0,0 +1,41 @@ +module Asm.Aarch64.P ( gallocFrame, gallocOn ) where + +import Asm.Aarch64 +import Asm.Aarch64.Fr +import Asm.Ar.P +import Asm.G +import Asm.LI +import qualified Data.IntMap as IM +import qualified Data.Set as S + +gallocFrame :: Int -- ^ int supply for spilling + -> [AArch64 AbsReg FAbsReg ()] -> [AArch64 AReg FAReg ()] +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') + 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 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 u = go u 0 pres + where go uϵ offs pres' isns = rmaps + where rmaps = case (regsM, fregsM) of + (Right regs, Right fregs) -> (regs, fregs, init isns) + -- https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms#Respect-the-purpose-of-specific-CPU-registers + regsM = alloc aIsns (filter (/= X18) [X0 .. X28]) (IM.keysSet pres') pres' + fregsM = allocF aFIsns [D0 .. D30] (IM.keysSet preFs) preFs + (aIsns, aFIsns) = bundle isns + +pres :: IM.IntMap AReg +pres = IM.fromList [(0, X0), (1, X1), (2, X2), (3, X3), (4, X4), (5, X5), (6, X6), (7, X7), (8, X30), (9, SP), (18, X29)] + +preFs :: IM.IntMap FAReg +preFs = IM.fromList [(10, D0), (11, D1), (12, D2), (13, D3), (14, D4), (15, D5), (16, D6), (17, D7)] diff --git a/src/Asm/Aarch64/T.hs b/src/Asm/Aarch64/T.hs new file mode 100644 --- /dev/null +++ b/src/Asm/Aarch64/T.hs @@ -0,0 +1,443 @@ +module Asm.Aarch64.T ( irToAarch64 ) where + +import Asm.Aarch64 +import Asm.M +import Control.Monad.State.Strict (runState) +import Data.Bifunctor (second) +import Data.Bits (rotateR, (.&.)) +import Data.Tuple (swap) +import Data.Word (Word16, Word64, Word8) +import GHC.Float (castDoubleToWord64) +import qualified IR +import qualified Op + +absReg :: IR.Temp -> AbsReg +absReg (IR.ITemp i) = IReg i; absReg (IR.ATemp i) = IReg i +absReg IR.C0 = CArg0; absReg IR.C1 = CArg1; absReg IR.C2 = CArg2 +absReg IR.C3 = CArg3; absReg IR.C4 = CArg4; absReg IR.C5 = CArg5 +absReg IR.CRet = CArg0 + +fabsReg :: IR.FTemp -> FAbsReg +fabsReg (IR.FTemp i) = FReg i +fabsReg IR.F0 = FArg0; fabsReg IR.F1 = FArg1; fabsReg IR.F2 = FArg2 +fabsReg IR.F3 = FArg3; fabsReg IR.F4 = FArg4; fabsReg IR.F5 = FArg5 +fabsReg IR.FRet = FArg0; fabsReg IR.FRet1 = FArg1 + +mB Op.AndB = AndRR +mB Op.OrB = OrRR +mB Op.XorB = Eor + +mIop Op.IPlus = Just AddRR +mIop Op.IMinus = Just SubRR +mIop Op.ITimes = Just MulRR +mIop (Op.BI b) = Just$mB b +mIop _ = Nothing + +mFop Op.FPlus = Just Fadd +mFop Op.FMinus = Just Fsub +mFop Op.FTimes = Just Fmul +mFop Op.FDiv = Just Fdiv +mFop Op.FMax = Just Fmax +mFop Op.FMin = Just Fmin +mFop _ = Nothing + +frel :: Op.FRel -> Cond +frel Op.FGeq = Geq +frel Op.FLeq = Leq +frel Op.FGt = Gt +frel Op.FLt = Lt +frel Op.FEq = Eq +frel Op.FNeq = Neq + +iop :: Op.IRel -> Cond +iop Op.IEq = Eq +iop Op.INeq = Neq +iop Op.IGeq = Geq +iop Op.ILeq = Leq +iop Op.IGt = Gt +iop Op.ILt = Lt + +nextR :: WM AbsReg +nextR = IReg <$> nextI + +nextF :: WM FAbsReg +nextF = FReg <$> nextI + +irToAarch64 :: IR.WSt -> [IR.Stmt] -> (Int, [AArch64 AbsReg FAbsReg ()]) +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 t = do + l <- nextL + 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.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.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.R l) = pure [RetL () l] +ir (IR.L l) = pure [Label () l] +ir (IR.J l) = pure [B () l] +ir (IR.C l) = pure [C () l] +ir (IR.MX t e) = feval e t +ir (IR.MT t e) = eval e t +ir (IR.Ma _ t e) = do {r <- nextR; plE <- eval e IR.C0; pure $ plE ++ puL ++ [AddRC () FP ASP 16, MovRCf () r Malloc, Blr () r, MovRR () (absReg t) CArg0] ++ poL} +ir (IR.Free t) = do {r <- nextR; pure $ puL ++ [MovRR () CArg0 (absReg t), AddRC () FP ASP 16, MovRCf () r Free, Blr () r] ++ poL} +ir (IR.Sa t (IR.ConstI i)) | Just u <- mu16 (sai i) = pure [SubRC () ASP ASP u, MovRR () (absReg t) ASP] +ir (IR.Sa t (IR.Reg r)) = let r'=absReg r in do {plR <- aR r'; pure $ plR++[SubRR () ASP ASP (absReg r), MovRR () (absReg t) ASP]} +ir (IR.Sa t e) = do + r <- nextI; plE <- eval e (IR.ITemp r) + let r'=IReg r + plR <- aR r' + pure $ plE ++ plR ++ [SubRR () ASP ASP r', MovRR () (absReg t) ASP] +ir (IR.Pop (IR.ConstI i)) | Just u <- mu16 (sai i) = pure [AddRC () ASP ASP u] +ir (IR.Pop (IR.Reg r)) = let r'=absReg r in do {plR <- aR r'; pure $ plR ++ [AddRR () ASP ASP r']} +ir (IR.Pop e) = do + r <- nextI; plE <- eval e (IR.ITemp r) + let r'=IReg r + plR <- aR r' + pure $ plE ++ plR ++ [AddRR () ASP ASP r'] +ir (IR.Wr (IR.AP t Nothing _) e) = do + (plE,r) <- plI e + pure $ plE [Str () r (R $ absReg t)] +ir (IR.Wr (IR.AP t (Just (IR.ConstI i)) _) e) | Just p <- mp i = do + (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)] +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)] +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)] +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)] +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) + (plE,i) <- plF e + pure $ plE $ plEI ++ [StrD () i (BI (absReg tB) (IReg 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 + pure $ plE $ plEI [StrD () i (BI (absReg t) iI Zero)] +ir (IR.WrF (IR.AP t Nothing _) e) = do + (plE,i) <- plF e + pure $ plE [StrD () i (R (absReg t))] +ir (IR.MJ (IR.IRel Op.INeq e (IR.ConstI 0)) l) = do + (plE,r) <- plI e + pure $ plE [Cbnz () r l] +ir (IR.MJ (IR.Is r) l) = + pure [Cbnz () (absReg r) l] +ir (IR.MJ (IR.IU Op.IEven e) l) = do + (plE,r) <- plI e + pure $ plE [Tbz () r 0 l] +ir (IR.MJ (IR.IRel op e (IR.ConstI i)) l) | c <- iop op, Just u <- m12 i = do + (plE,r) <- plI e + pure $ plE [CmpRC () r u, Bc () c l] +ir (IR.MJ (IR.IRel op e0 e1) l) | c <- iop op = do + (plE0,r0) <- plI e0; (plE1,r1) <- plI e1 + pure $ plE0 $ plE1 [CmpRR () r0 r1, Bc () c l] +ir (IR.MJ (IR.FRel op e (IR.ConstF 0)) l) | c <- frel op = do + (plE,i) <- plF e + pure $ plE [FcmpZ () i, Bc () c l] +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.Cmov (IR.IRel op e0 e1) t e) | c <- iop op = do + (plE0,r0) <- plI e0; (plE1,r1) <- plI e1 + (plE,r) <- plI e + pure $ plE $ plE0 $ plE1 [CmpRR () r0 r1, Csel () (absReg t) r (absReg t) c] +ir (IR.Cset t (IR.IRel op e0 (IR.ConstI i))) | c <- iop op, Just u <- m12 i = do + (plE0,r0) <- plI e0 + pure $ plE0 [CmpRC () r0 u, Cset () (absReg t) c] +ir (IR.Cset t (IR.IRel op e0 e1)) | c <- iop op = do + (plE0,r0) <- plI e0; (plE1,r1) <- plI e1 + pure $ plE0 $ plE1 [CmpRR () r0 r1, Cset () (absReg t) c] +ir (IR.Cset t (IR.FRel op e0 e1)) | c <- frel op = do + (plE0,r0) <- plF e0; (plE1,r1) <- plF e1 + pure $ plE0 $ plE1 [Fcmp () r0 r1, Cset () (absReg t) c] +ir (IR.Cset t (IR.IU Op.IOdd e0)) = do + (plE0,r0) <- plI e0 + pure $ plE0 [TstI () r0 (BM 1 0), Cset () (absReg t) Neq] +ir (IR.Cset t (IR.IU Op.IEven e0)) = do + (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 + 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 + (plE,i) <- plF e + pure $ plE $ plE0 $ plE1 [CmpRR () r0 r1, Fcsel () (fabsReg t) i (fabsReg t) c] +ir (IR.Fcmov (IR.FRel op e0 e1) t e) | c <- frel op = do + (plE0,r0) <- plF e0; (plE1,r1) <- plF e1 + (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 + 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 + 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 + pure $ concat [ [Ldp () t0 t1 (RP (absReg tS) (i*16)), Stp () t0 t1 (RP (absReg tD) (i*16))] | i <- fromIntegral<$>[0..(n'-1)] ] +ir (IR.Cpy (IR.AP tD Nothing _) (IR.AP tS Nothing _) (IR.ConstI n)) | n <= 4 = do + t <- nextR + pure $ concat [ [Ldr () t (RP (absReg tS) (i*8)), Str () t (RP (absReg tD) (i*8))] | i <- fromIntegral<$>[0..(n-1)] ] +ir (IR.Cpy (IR.AP tD Nothing _) (IR.AP tS (Just eS) _) (IR.ConstI n)) | (n', 0) <- n `quotRem` 2, n' <= 4 = do + rD <- nextI; rS <- nextI + t0 <- nextR; t1 <- nextR + plED <- eval (IR.Reg tD) (IR.ITemp rD) + plES <- eval (IR.Reg tS+eS) (IR.ITemp rS) + 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)] ] +ir (IR.Cpy (IR.AP tD (Just eD) _) (IR.AP tS Nothing _) (IR.ConstI n)) | (n', 0) <- n `quotRem` 2, n' <= 4 = do + rD <- nextI; rS <- nextI + t0 <- nextR; t1 <- nextR + plED <- eval (IR.Reg tD+eD) (IR.ITemp rD) + plES <- eval (IR.Reg tS) (IR.ITemp rS) + 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)] ] +ir (IR.Cpy (IR.AP tD (Just eD) _) (IR.AP tS (Just eS) _) (IR.ConstI n)) | (n', 0) <- n `quotRem` 2, n' <= 4 = do + rD <- nextI; rS <- nextI + t0 <- nextR; t1 <- nextR + plED <- eval (IR.Reg tD+eD) (IR.ITemp rD) + plES <- eval (IR.Reg tS+eS) (IR.ITemp rS) + 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)] ] +ir (IR.Cpy (IR.AP tD (Just eD) _) (IR.AP tS (Just eS) _) (IR.ConstI n)) | (n', 1) <- n `quotRem` 2, n' <= 4 = do + rD <- nextI; rS <- nextI + t0 <- nextR; t1 <- nextR + plED <- eval (IR.Reg tD+eD) (IR.ITemp rD) + 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 eD _) (IR.AP tS eS _) eN) = do + rD <- nextI; rS <- nextI; rN <- nextI; i <- nextR + t0 <- nextR; t1 <- nextR + plED <- eval (maybe id (+) eD$IR.Reg tD) (IR.ITemp rD) + plES <- eval (maybe id (+) eS$IR.Reg tS) (IR.ITemp rS) + plEN <- eval eN (IR.ITemp rN) + let rDA=IReg rD; rSA=IReg rS; rNA=IReg rN + l <- nextL; eL <- nextL + pure $ plED ++ plES ++ plEN ++ [MovRC () i 0, CmpRR () i rNA, Bc () Geq eL, Tbz () rNA 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 rNA, Bc () Lt l, Label () eL] +-- ir (IR.IRnd t) = pure [MrsR () (absReg t)] +ir (IR.IRnd t) = do + r <- nextR + pure $ puL ++ [AddRC () FP ASP 16, MovRCf () r JR, Blr () r, MovRR () (absReg t) CArg0] ++ poL +ir (IR.FRnd t) = do + r <- nextR + 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 = [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 + +mw64 :: Word64 -> AbsReg -> [AArch64 AbsReg freg ()] +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 t = do + d1 <- nextF; d2 <- nextF; d3 <- nextF + tsI <- nextI + let tsIR=IR.FTemp tsI; tsC=FReg tsI + pl3 <- feval (IR.ConstF$ -(1/6)) tsIR; pl5 <- feval (IR.ConstF$1/120) tsIR; pl7 <- feval (IR.ConstF$ -(1/5040)) tsIR + pure $ [Fmul () d1 d0 d0, Fmul () d2 d1 d0, Fmul () d3 d2 d1, Fmul () d1 d1 d3] ++ pl3 ++ Fmadd () d0 d2 tsC d0 : pl5 ++ Fmadd () d0 d3 tsC d0 : pl7 ++ [Fmadd () d0 d1 tsC d0] + where + d0 = fabsReg t + +cosϵ :: IR.FTemp -> WM [AArch64 AbsReg FAbsReg ()] +cosϵ t = do + d1 <- nextF; d2 <- nextF; d3 <- nextF + tsI <- nextI + let tsIR=IR.FTemp tsI; tsC=FReg tsI + pl0 <- feval 1 tsIR; pl2 <- feval (IR.ConstF$ -(1/2)) tsIR; pl4 <- feval (IR.ConstF$1/24) tsIR; pl6 <- feval (IR.ConstF$ -(1/720)) tsIR + pure $ [Fmul () d1 d0 d0, Fmul () d2 d1 d1, Fmul () d3 d2 d1] ++ pl0 ++ FMovXX () d0 tsC : pl2 ++ Fmadd () d0 d1 tsC d0 : pl4 ++ Fmadd () d0 d2 tsC d0 : pl6 ++ [Fmadd () d0 d3 tsC d0] + where + d0 = fabsReg t + +feval :: IR.FExp -> IR.FTemp -> WM [AArch64 AbsReg FAbsReg ()] +feval (IR.FReg tS) tD = pure [FMovXX () (fabsReg tD) (fabsReg tS)] +feval (IR.ConstF d) t = do + i <- nextI + let r=IReg i + w=castDoubleToWord64 d + pure $ mw64 w r ++ [FMovDR () (fabsReg t) r] +-- https://litchie.com/2020/04/sine +feval (IR.FU Op.FSin e) t = do + plE <- feval e t + let d0=fabsReg t + s <- ssin t; c <- cosϵ t + lc <- nextL; endL <- nextL + i <- nextR; d2 <- nextF; i7 <- nextI + π4i<-nextI; plπ4 <- feval (IR.ConstF$pi/4) (IR.FTemp π4i); pl7 <- eval (IR.ConstI 7) (IR.ITemp i7) + let π4=FReg π4i + dRot <- nextF; nres <- nextF + pure $ + plE + ++plπ4 + ++[Fdiv () d2 d0 π4, Frintm () d2 d2, Fmsub () d0 π4 d2 d0, Fcvtas () i d2] + ++pl7 + ++[AndRR () i i (IReg i7), TstI () i (BM 1 0), Fsub () dRot π4 d0, Fcsel () d0 dRot d0 Neq] + ++[ CmpRC () i 1, Bc () Eq lc, CmpRC () i 2, Bc () Eq lc + , CmpRC () i 5, Bc () Eq lc, CmpRC () i 6, Bc () Eq lc + ] + ++s++B () endL + :Label () lc:c + ++[Label () endL] + ++[Fneg () nres d0, TstI () i (BM 1 2), Fcsel () d0 nres d0 Neq] +feval (IR.FU Op.FCos e) t = feval (IR.FU Op.FSin (IR.ConstF(pi/2)-e)) t +feval (IR.FB Op.FExp (IR.ConstF 2.718281828459045) e) t = do + r <- nextR + plE <- feval e IR.F0 + pure $ plE ++ puL ++ [AddRC () FP ASP 16, MovRCf () r Exp, Blr () r, FMovXX () (fabsReg t) FArg0] ++ poL +feval (IR.FB Op.FExp e0 e1) t = do + r <- nextR + plE0 <- feval e0 IR.F0; plE1 <- feval e1 IR.F1 + pure $ plE0 ++ plE1 ++ puL ++ [AddRC () FP ASP 16, MovRCf () r Pow, Blr () r, FMovXX () (fabsReg t) FArg0] ++ poL +feval (IR.FU Op.FLog e) t = do + r <- nextR + plE <- feval e IR.F0 + pure $ plE ++ puL ++ [AddRC () FP ASP 16, MovRCf () r Log, Blr () r, FMovXX () (fabsReg t) FArg0] ++ poL +feval (IR.FB Op.FPlus e0 (IR.FB Op.FTimes e1 e2)) t = do + (plE0,i0) <- plF e0; (plE1,i1) <- plF e1; (plE2,i2) <- plF e2 + pure $ plE0 $ plE1 $ plE2 [Fmadd () (fabsReg t) i1 i2 i0] +feval (IR.FB Op.FPlus (IR.FB Op.FTimes e0 e1) e2) t = do + (plE0,i0) <- plF e0; (plE1,i1) <- plF e1; (plE2,i2) <- plF e2 + pure $ plE0 $ plE1 $ plE2 [Fmadd () (fabsReg t) i0 i1 i2] +feval (IR.FB Op.FMinus e0 (IR.FB Op.FTimes e1 e2)) t = do + (plE0,i0) <- plF e0; (plE1,i1) <- plF e1; (plE2,i2) <- plF e2 + pure $ plE0 $ plE1 $ plE2 [Fmsub () (fabsReg t) i1 i2 i0] +feval (IR.FB Op.FMinus (IR.ConstF 0) e) t = do + (plE,i) <- plF e + pure $ plE [Fneg () (fabsReg t) i] +feval (IR.FB Op.FTimes (IR.ConstF (-1)) e) t = do + (plE,i) <- plF e + pure $ plE [Fneg () (fabsReg t) i] +feval (IR.FB Op.FTimes e (IR.ConstF (-1))) t = do + (plE,i) <- plF e + pure $ plE [Fneg () (fabsReg t) i] +feval (IR.FB fop e0 e1) t | Just isn <- mFop fop = do + (plE0,r0) <- plF e0; (plE1,r1) <- plF e1 + pure $ plE0 $ plE1 [isn () (fabsReg t) r0 r1] +feval (IR.FU Op.FAbs e) t = do + (plE,i) <- plF e + pure $ plE [Fabs () (fabsReg t) i] +feval (IR.FAt (IR.AP tS (Just (IR.ConstI i)) _)) tD | Just i8 <- mp i = pure [LdrD () (fabsReg tD) (RP (absReg tS) i8)] +feval (IR.FAt (IR.AP tB (Just (IR.IB Op.IAsl eI (IR.ConstI 3))) _)) tD = do + (plE,i) <- plI eI + pure $ plE [LdrD () (fabsReg tD) (BI (absReg tB) i Three)] +feval (IR.FAt (IR.AP tB (Just (IR.IB Op.IPlus (IR.IB Op.IAsl eI (IR.ConstI 3)) (IR.ConstI ix8))) _)) tD | (ix, 0) <- ix8 `quotRem` 8 = do + i <- nextI; plE <- eval (eI+IR.ConstI ix) (IR.ITemp i) + pure $ plE ++ [LdrD () (fabsReg tD) (BI (absReg tB) (IReg i) Three)] +feval (IR.FAt (IR.AP tB (Just e) _)) tD = do + i <- nextI; plE <- eval e (IR.ITemp i) + pure $ plE ++ [LdrD () (fabsReg tD) (BI (absReg tB) (IReg i) Zero)] +feval (IR.FAt (IR.AP tB Nothing _)) tD = + pure [LdrD () (fabsReg tD) (R (absReg tB))] +feval (IR.FConv e) tD = do + (plE,r) <- plI e + pure $ plE [Scvtf () (fabsReg tD) r] +feval (IR.FU Op.FSqrt e) t = do + (plE,r) <- plF e + pure $ plE [Fsqrt () (fabsReg t) r] +feval e _ = error (show e) + +eval :: IR.Exp -> IR.Temp -> WM [AArch64 AbsReg FAbsReg ()] +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 = 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 + r0 <- nextI; r1 <- nextI + plE0 <- eval e0 (IR.ITemp r0); plE1 <- eval e1 (IR.ITemp r1) + pure $ plE0 ++ plE1 ++ [AddRRS () (absReg t) (IReg r1) (IReg r0) u] +eval (IR.IB Op.IPlus e (IR.ConstI i)) t | Just u <- m12 i = do + r <- nextI; plE <- eval e (IR.ITemp r) + pure $ plE ++ [AddRC () (absReg t) (IReg r) u] +eval (IR.IB Op.IMinus e (IR.ConstI i)) t | Just u <- m12 i = do + (plE,r) <- plI e + pure $ plE [SubRC () (absReg t) r u] +eval (IR.IB Op.IAsl e (IR.ConstI i)) t = do + (plE,r) <- plI e + pure $ plE [Lsl () (absReg t) r (fromIntegral (i `mod` 64))] +eval (IR.IB Op.IMinus (IR.ConstI 0) e) t = do + (plE,r) <- plI e + pure $ plE [Neg () (absReg t) r] +eval (IR.IB Op.ITimes (IR.ConstI (-1)) e) t = do + (plE,r) <- plI e + pure $ plE [Neg () (absReg t) r] +eval (IR.IB Op.ITimes e (IR.ConstI (-1))) t = do + (plE,r) <- plI e + pure $ plE [Neg () (absReg t) r] +eval (IR.IB Op.IRem e0 e1) t = do + r2 <- nextR + (plE0,r0) <- plI e0; (plE1,r1) <- plI e1 + pure $ plE0 $ plE1 [Sdiv () r2 r0 r1, Msub () (absReg t) r2 r1 r0] +eval (IR.IB Op.IPlus (IR.IB Op.ITimes e0 e1) e2) t = do + (plE0,r0) <- plI e0; (plE1,r1) <- plI e1; (plE2,r2) <- plI e2 + pure $ plE0 $ plE1 $ plE2 [Madd () (absReg t) r0 r1 r2] +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.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.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)] +eval (IR.EAt (IR.AP rB Nothing _)) t = do + pure [Ldr () (absReg t) (R (absReg rB))] +eval (IR.EAt (IR.AP rB (Just e) _)) t = do + (plE,i) <- plI e + pure $ plE [Ldr () (absReg t) (BI (absReg rB) i Zero)] +eval (IR.BAt (IR.AP rB (Just e) _)) t = do + (plE,i) <- plI e + pure $ plE [LdrB () (absReg t) (BI (absReg rB) i Zero)] +eval (IR.IB Op.IAsr e (IR.ConstI i)) t | Just s <- ms i = do + (plE,r) <- plI e + pure $ plE [Asr () (absReg t) r s] +eval (IR.LA n) t = pure [LdrRL () (absReg t) n] +eval (IR.BU Op.BNeg (IR.Is r)) t = pure [EorI () (absReg t) (absReg r) (BM 1 0)] +eval e _ = error (show e) + +ms :: Integral a => a -> Maybe Word8 +ms i | i >=0 && i <= 63 = Just (fromIntegral i) | otherwise = Nothing + +m12, mu16 :: Integral a => a -> Maybe Word16 +m12 i | i >= 0 && i < 4096 = Just (fromIntegral i) | otherwise = Nothing + +mu16 i | i > fromIntegral (maxBound :: Word16) || i < fromIntegral (minBound :: Word16) = Nothing + | otherwise = Just (fromIntegral i) + +mp :: Integral a => a -> Maybe Word16 +mp i | i `rem` 8 == 0 && i >= 0 && i <= 32760 = Just (fromIntegral i) | otherwise = Nothing diff --git a/src/Asm/Ar.hs b/src/Asm/Ar.hs new file mode 100644 --- /dev/null +++ b/src/Asm/Ar.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Asm.Ar ( Arch (..) ) where + +import qualified Asm.Aarch64 as AArch64 +import qualified Asm.Aarch64.B as AArch64 +import qualified Asm.Aarch64.CF as AArch64 +import Asm.BB +import qualified Asm.X86 as X86 +import qualified Asm.X86.B as X86 +import qualified Asm.X86.CF as X86 +import CF +import Class.E + +class Arch arch reg freg where + cf :: [BB arch reg freg () ()] -> [BB arch reg freg () ControlAnn] + + -- | result: src, dest + mI :: arch reg freg a -> Maybe (reg, reg) + mf :: arch reg freg 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 + +instance (E reg, E freg) => Arch X86.X86 reg freg where + cf = X86.mkControlFlow + + mI (X86.MovRR _ r0 r1) = Just (r1, r0) + mI _ = Nothing + + mf (X86.Movapd _ r0 r1) = Just (r1, r0) + mf _ = Nothing + + bb = X86.bb + expand = X86.expand + udd = X86.udd + +instance (E reg, E freg) => Arch AArch64.AArch64 reg freg where + cf = AArch64.mkControlFlow + + mI (AArch64.MovRR _ r0 r1) = Just (r0, r1) + mI _ = Nothing + + mf (AArch64.FMovXX _ r0 r1) = Just (r0, r1) + mf _ = Nothing + + bb = AArch64.bb + expand = AArch64.expand + udd = AArch64.udd diff --git a/src/Asm/Ar/P.hs b/src/Asm/Ar/P.hs new file mode 100644 --- /dev/null +++ b/src/Asm/Ar/P.hs @@ -0,0 +1,18 @@ +module Asm.Ar.P ( bundle ) where + +import Asm.Ar +import Asm.L +import CF +import Class.E +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 isns = + let cfIsns = fmap udd isns; lIsns = mkLive isns + mvIsns = fmap (both toInt).mI<$>isns + mvFIsns = fmap (both toInt).mf<$>isns + combine x y z = let tup = (x, copoint y, z) in tup <$ y + in (zipWith3 combine cfIsns lIsns mvIsns, zipWith3 combine cfIsns lIsns mvFIsns) diff --git a/src/Asm/BB.hs b/src/Asm/BB.hs new file mode 100644 --- /dev/null +++ b/src/Asm/BB.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DeriveFunctor #-} + +module Asm.BB ( BB (..) ) where + +import Data.Copointed + +data BB arch reg freg a b = BB { unBB :: [arch reg freg a], caBB :: b } deriving (Functor) + +instance Copointed (BB arch reg freg a) where copoint=caBB diff --git a/src/Asm/CF.hs b/src/Asm/CF.hs new file mode 100644 --- /dev/null +++ b/src/Asm/CF.hs @@ -0,0 +1,49 @@ +module Asm.CF ( N, FreshM + , runFreshM + , getFresh, fm + , lookupLabel, lC + , broadcast + , b3 + , singleton + , fromList + ) where + +import Asm.M +import Class.E as E +import Control.Monad.State.Strict (State, evalState, gets, modify, state) +import Data.Functor (($>)) +import qualified Data.IntSet as IS +import qualified Data.Map as M +import Data.Tuple.Extra (second3, snd3, thd3, third3) + +type N=Int + +-- map of labels by node +type FreshM = State (N, M.Map Label N, M.Map Label [N]) + +runFreshM :: FreshM a -> a +runFreshM = flip evalState (0, mempty, mempty) + +getFresh :: FreshM N +getFresh = state (\(i,m0,m1) -> (i,(i+1,m0,m1))) + +fm :: Label -> FreshM N +fm l = do {st <- gets snd3; case M.lookup l st of {Just i -> pure i; Nothing -> do {i <- getFresh; broadcast i l $> i}}} + +lookupLabel :: Label -> FreshM N +lookupLabel l = gets (M.findWithDefault (error "Internal error in control-flow graph: node label not in map.") l . snd3) + +lC :: Label -> FreshM [N] +lC l = gets (M.findWithDefault (error "Internal error in CF graph: node label not in map.") l . thd3) + +broadcast :: N -> Label -> FreshM () +broadcast i l = modify (second3 (M.insert l i)) + +b3 :: N -> Label -> FreshM () +b3 i l = modify (third3 (M.alter (\k -> Just$case k of {Nothing -> [i]; Just is -> i:is}) l)) + +singleton :: E reg => reg -> IS.IntSet +singleton = IS.singleton . E.toInt + +fromList :: E reg => [reg] -> IS.IntSet +fromList = foldMap singleton diff --git a/src/Asm/G.hs b/src/Asm/G.hs new file mode 100644 --- /dev/null +++ b/src/Asm/G.hs @@ -0,0 +1,314 @@ +-- | From Appel +module Asm.G ( alloc, allocF ) where + +import Asm.Ar +import Asm.BB +import CF +import Data.Copointed +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Set as S +import Data.Tuple.Extra (fst3, snd3, thd3) + +type K=Int + +-- move list: map from abstract registers (def ∪ used) to nodes +type Movs = IM.IntMap MS +type GS = S.Set (Int, Int) +type GL = IM.IntMap [Int] + +-- TODO: might work as lazy lists idk (deletion) +-- difference would still be annoying though... +data Wk = Wk { pre :: IS.IntSet, sp :: IS.IntSet, fr :: IS.IntSet, simp :: IS.IntSet } + +mapSp f w = w { sp = f (sp w) } +mapFr f w = w { fr = f (fr w) } +mapSimp f w = w { simp = f (simp w) } + +type M = (Int, Int); type MS = S.Set M + +-- TODO: appel says to make these doubly-linked lists +data Mv = Mv { coal :: MS, constr :: MS, frz :: MS, wl :: MS, actv :: MS } + +mapWl f mv = mv { wl = f (wl mv) } +mapActv f mv = mv { actv = f (actv mv) } +mapCoal f mv = mv { coal = f (coal mv) } +mapFrz f mv = mv { frz = f (frz mv) } +mapConstr f mv = mv { constr = f (constr mv) } + +data Ns = Ns { coalN :: IS.IntSet, colN :: IS.IntSet, spN :: IS.IntSet } + +mapCoalN f ns = ns { coalN = f (coalN ns) } +mapColN f ns = ns { colN = f (colN ns) } +mapSpN f ns = ns { spN = f (spN ns) } + +data St = St { mvs :: Movs, aS :: GS, aL :: GL, mvS :: Mv, ɴs :: Ns, degs :: !(IM.IntMap Int), initial :: [Int], wkls :: Wk, stack :: [Int], alias :: IM.IntMap Int } + +mapMv f st = st { mvS = f (mvS st) }; mapWk f st = st { wkls = f (wkls st) }; mapNs f st = st { ɴs = f (ɴs st) } + +thread :: [a -> a] -> a -> a +thread = foldr (.) id + +(!:) :: IM.Key -> Int -> GL -> GL +(!:) k i = IM.alter (\kϵ -> Just$case kϵ of {Nothing -> [i]; Just is -> i:is}) k + +(@!) :: IM.Key -> M -> Movs -> Movs +(@!) k i = IM.alter (\kϵ -> Just$case kϵ of {Nothing -> S.singleton i; Just is -> S.insert i is}) k + +(!.) :: Monoid m => IM.IntMap m -> IM.Key -> m +(!.) m k = IM.findWithDefault mempty k m + +n !* d = IM.findWithDefault maxBound n d + +dec :: IM.Key -> IM.IntMap Int -> IM.IntMap Int +dec = IM.alter (\k -> case k of {Nothing -> Nothing;Just d -> Just$d-1}) + +inc :: IM.Key -> IM.IntMap Int -> IM.IntMap Int +inc = IM.alter (\k -> case k of {Nothing -> Just 1;Just d -> Just$d+1}) + +emptySt :: IS.IntSet -- ^ Precolored registers + -> [Int] + -> St +emptySt preC rs = St IM.empty S.empty IM.empty (Mv S.empty S.empty S.empty S.empty S.empty) (Ns IS.empty IS.empty IS.empty) IM.empty rs (Wk preC IS.empty IS.empty IS.empty) [] IM.empty + +getIs :: Copointed p => [p Liveness] -> IS.IntSet +getIs = foldMap (g.copoint) where g (Liveness is os _ _) = is<>os + +getIFs :: Copointed p => [p Liveness] -> IS.IntSet +getIFs = foldMap (g.copoint) where g (Liveness _ _ fis fos) = fis<>fos + +{-# SCC buildOver #-} +buildOver :: Copointed p => [[p (UD, Liveness, Maybe M)]] -> St -> St +buildOver blocks = thread [ \s -> snd $ build (out (snd3 (copoint (last isns)))) s (reverse isns) | isns <- blocks ] + +{-# SCC buildOverF #-} +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))] + -> [reg] -- ^ available registers + -> IS.IntSet -- ^ Precolored @areg@ + -> IM.IntMap reg -- ^ Precolored map + -> Either IS.IntSet (IM.IntMap reg) -- ^ Map from abs reg. id (temp) to concrete reg. +alloc aIsns regs preC preCM = + let st0 = buildOver (unBB<$>bb aIsns) (emptySt preC (IS.toList $ getIs nIsns IS.\\ preC)) + st1 = mkWorklist ᴋ st0 + st2 = emptyWkl ᴋ st1 + (st3, rs) = assign preCM regs st2 + s = spN (ɴs st3) + 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))] + -> [freg] -- ^ available registers + -> IS.IntSet -- ^ Precolored @afreg@ + -> IM.IntMap freg -- ^ Precolored map + -> Either IS.IntSet (IM.IntMap freg) -- ^ Map from abs freg. id (temp) to concrete reg. +allocF aIsns regs preC preCM = + let st0 = buildOverF (unBB<$>bb aIsns) (emptySt preC (IS.toList $ getIFs nIsns IS.\\ preC)) + st1 = mkWorklist ᴋ st0 + st2 = emptyWkl ᴋ st1 + (st3, rs) = assign preCM regs st2 + s = spN (ɴs st3) + in if IS.null s then Right rs else Left s + where nIsns = fmap snd3 <$> aIsns; ᴋ = length regs + +{-# SCC emptyWkl #-} +emptyWkl :: K -> St -> St +emptyWkl ᴋ s | not $ IS.null (simp (wkls s)) = emptyWkl ᴋ (simplify ᴋ s) + | not $ S.null (wl (mvS s)) = emptyWkl ᴋ (coalesce ᴋ s) + | not $ IS.null (fr (wkls s)) = emptyWkl ᴋ (freeze ᴋ s) + | not $ IS.null (sp (wkls s)) = emptyWkl ᴋ (sspill ᴋ s) + | otherwise = s + +{-# SCC buildF #-} +buildF :: (Copointed p) => IS.IntSet -> St -> [p (UD, Liveness, Maybe M)] -> (IS.IntSet, St) +buildF l st [] = (l, st) +buildF l st@(St ml as al mv ns ds i wk s a) (isn:isns) | Just mIx <- thd3 (copoint isn) = + let ca = fst3 (copoint isn) + u = usesFNode ca; d = defsFNode ca + lm = l IS.\\ u + ml' = thread [ kϵ @! mIx | kϵ <- IS.toList (u `IS.union` d) ] ml + le = lm `IS.union` d + st' = St ml' as al (mapWl (S.insert mIx) mv) ns ds i wk s a + st'' = thread [ addEdge lϵ dϵ | lϵ <- IS.toList le, dϵ <- IS.toList d ] st' + l' = u `IS.union` (lm IS.\\ d) + in buildF l' st'' isns + | otherwise = + let ca = fst3 (copoint isn) + u = usesFNode ca; d = defsFNode ca + le = l `IS.union` d + st'' = thread [ addEdge lϵ dϵ | lϵ <- IS.toList le, dϵ <- IS.toList d ] st + l' = u `IS.union` (l IS.\\ d) + in buildF l' st'' isns + +{-# SCC build #-} +-- | To be called in reverse order +build :: (Copointed p) + => IS.IntSet -- ^ Live-out for the block + -> St + -> [p (UD, Liveness, Maybe M)] + -> (IS.IntSet, St) +build l st [] = (l, st) +build l st@(St ml as al mv ns ds i wk s a) (isn:isns) | Just mIx <- thd3 (copoint isn) = + let ca = fst3 (copoint isn) + u = usesNode ca; d = defsNode ca + lm = l IS.\\ u + ml' = thread [ kϵ @! mIx | kϵ <- IS.toList (u `IS.union` d) ] ml + le = lm `IS.union` d + st' = St ml' as al (mapWl (S.insert mIx) mv) ns ds i wk s a + st'' = thread [ addEdge lϵ dϵ | lϵ <- IS.toList le, dϵ <- IS.toList d ] st' + l' = u `IS.union` (lm IS.\\ d) + in build l' st'' isns + | otherwise = + let ca = fst3 (copoint isn) + u = usesNode ca + d = defsNode ca + le = l `IS.union` d + st'' = thread [ addEdge lϵ dϵ | lϵ <- IS.toList le, dϵ <- IS.toList d ] st + l' = u `IS.union` (l IS.\\ d) + in build l' st'' isns + +{-# SCC addEdge #-} +addEdge :: Int -> Int -> St -> St +addEdge u v st@(St ml as al mv ns ds i wk s a) = + if (u, v) `S.notMember` as && u /= v + then + let as' = S.insert (u,v) $ S.insert (v,u) as + preC = pre wk + uC = u `IS.notMember` preC + vC = v `IS.notMember` preC + al' = (if uC then u !: v else id)$(if vC then v !: u else id) al + ds' = (if uC then inc u else id)$(if vC then inc v else id) ds + in St ml as' al' mv ns ds' i wk s a + else st + +{-# SCC mkWorklist #-} +mkWorklist :: K -> St -> St +mkWorklist ᴋ st@(St _ _ _ _ _ ds i wk _ _) = + let wk' = thread [ (case () of { _ | n !* ds >= ᴋ -> mapSp; _ | isMR n st -> mapFr; _-> mapSimp}) (IS.insert n) | n <- i ] wk + in st { initial = [], wkls = wk' } + +-- same for xmm0, r15 +-- ᴋ = 16 + +isMR :: Int -> St -> Bool +isMR i st = not $ S.null (nodeMoves i st) + +{-# SCC nodeMoves #-} +nodeMoves :: Int -> St -> MS +nodeMoves n (St ml _ _ mv _ _ _ _ _ _) = ml !. n `S.intersection` (actv mv `S.union` wl mv) + +{-# SCC simplify #-} +simplify :: K -> St -> St +simplify ᴋ s@(St _ _ _ _ _ _ _ wk@(Wk _ _ _ stϵ) st _) | Just (n,ns) <- IS.minView stϵ = + let s' = s { wkls = wk { simp = ns }, stack = n:st } + in thread [ ddg ᴋ m | m <- adj n s' ] s' + | otherwise = s + +{-# SCC ddg #-} +-- decrement degree +ddg :: K -> Int -> St -> St +ddg ᴋ m s | m `IS.member` pre (wkls s) = s + | otherwise = + let d = degs s; s' = s { degs = dec m d } + in if d IM.! m == ᴋ + then let s'' = enaMv (m:adj m s) s' + in mapWk (mapSp (IS.delete m).(if isMR m s'' then mapFr else mapSimp) (IS.insert m)) s'' + else s' + +-- enable moves +enaMv :: [Int] -> St -> St +enaMv ns = thread (fmap g ns) where + g n st = let ms = S.toList (nodeMoves n st) in thread (fmap h ms) st + where h m stϵ | m `S.member` actv(mvS stϵ) = mapMv (mapWl (S.insert m) . mapActv (S.delete m)) st + | otherwise = st + +{-# SCC addWkl #-} +addWkl :: K -> Int -> St -> St +addWkl ᴋ u st | u `IS.notMember` pre (wkls st) && not (isMR u st) && u !* degs st < ᴋ = mapWk (mapFr (IS.delete u) . mapSimp (IS.insert u)) st + | otherwise = st + +{-# SCC ok #-} +ok :: K -> Int -> Int -> St -> Bool +ok ᴋ t r s = t `IS.member` pre (wkls s) || degs s IM.! t < ᴋ || (t,r) `S.member` aS s + +{-# SCC conserv #-} +conserv :: K -> [Int] -> St -> Bool +conserv ᴋ is s = + let d = degs s + k = length (filter (\n -> (n !* d)>=ᴋ) is) + in k<ᴋ + +{-# SCC getAlias #-} +getAlias :: Int -> St -> Int +getAlias i s = case IM.lookup i (alias s) of {Just i' -> getAlias i' s; Nothing -> i} + +{-# SCC combine #-} +combine :: K -> Int -> Int -> St -> St +combine ᴋ u v st = + let st0 = mapWk (\(Wk p s f sm) -> if v `IS.member` f then Wk p s (IS.delete v f) sm else Wk p (IS.delete v s) f sm) st + st1 = mapNs (mapCoalN (IS.insert v)) st0 + st2 = st1 { alias = IM.insert v u (alias st1) } + -- https://github.com/sunchao/tiger/blob/d083a354987b7f1fe23f7065ab0c19c714e78cc4/color.sml#L265 + st3 = let m = mvs st2 -- default to S.empty if we haven't filled it in + mvu = m !. u; mvv = m !. v in st2 { mvs = IM.insert u (mvu `S.union` mvv) m } + st4 = thread [ ddg ᴋ t.addEdge t u | t <- adj v st2 ] st3 + in if u `IS.member` fr(wkls st3) && u !* degs st4 >= ᴋ then mapWk(\(Wk p s f sm) -> Wk p (IS.insert u s) (IS.delete u f) sm) st4 else st4 + +freeze :: K -> St -> St +freeze ᴋ s | Just (u, _) <- IS.minView (fr$wkls s) = + let s0 = mapWk (mapFr (IS.delete u).mapSimp (IS.insert u)) s in freezeMoves ᴋ u s0 + +{-# SCC freezeMoves #-} +freezeMoves :: K -> Int -> St -> St +freezeMoves ᴋ u st = thread (fmap g (S.toList$nodeMoves u st)) st where + g m@(x, y) s = + let y' = getAlias y s; v = if y' == getAlias u s then getAlias x s else y' + st0 = mapMv (mapActv (S.delete m).mapFrz (S.insert m)) s + in if S.null (nodeMoves v st0) && v !* degs st0 < ᴋ + then mapWk (mapFr (IS.delete v).mapSimp (IS.insert v)) st0 + else st0 + +{-# SCC adj #-} +adj :: Int -> St -> [Int] +adj n s = aL s !. n ∖ (IS.fromList (stack s) <> coalN (ɴs s)) + +(∖) :: [Int] -> IS.IntSet -> [Int] +(∖) x yϵ = filter (`IS.notMember` yϵ) x + +dSet :: Ord reg => [reg] -> [reg] -> [reg] +dSet x ys = filter (`S.notMember` yϵ) x where yϵ = S.fromList ys + +{-# SCC coalesce #-} +coalesce :: K -> St -> St +coalesce ᴋ s | Just (m@(x,y), nWl) <- S.minView (wl$mvS s) = + let y' = getAlias y s + preS = pre (wkls s) + (u, v) = if y' `IS.member` preS then (y',x') else (x',y') where x' = getAlias x s + s0 = mapMv (\mv -> mv { wl = nWl }) s + in case () of + _ | u == v -> addWkl ᴋ u $ mapMv (mapCoal (S.insert m)) s0 + | v `IS.member` preS || (u,v) `S.member` aS s0 -> addWkl ᴋ v $ addWkl ᴋ u $ mapMv (mapConstr (S.insert m)) s0 + | let av = adj v s0 in if u `IS.member` preS then all (\t -> ok ᴋ t u s0) av else conserv ᴋ (adj u s0 ++ av) s0 -> + addWkl ᴋ u $ combine ᴋ u v $ mapMv (mapCoal (S.insert m)) s0 + | otherwise -> mapMv (mapActv (S.insert m)) s0 + +sspill :: K -> St -> St +sspill ᴋ s | Just (m, nSp) <- IS.minView (sp$wkls s) = freezeMoves ᴋ m $ mapWk (mapSimp (IS.insert m). \wk -> wk { sp = nSp }) s + +{-# SCC assign #-} +assign :: (Ord reg) => IM.IntMap reg -> [reg] -> St -> (St, IM.IntMap reg) +assign iC colors s = snip $ go (s, colors, iC) where + snip (x, _, z) = (x, z) + go (sϵ@(St _ _ _ _ (Ns ns _ _) _ _ _ [] _), _, c) = (sϵ, undefined, thread [ IM.insert n (c IM.! getAlias n sϵ) | n <- IS.toList ns ] c) + go (sϵ@(St _ _ al _ _ _ _ _ (n:ns) _), okϵ, cs) = + let ok0 = okϵ `dSet` [ cs IM.! getAlias w sϵ | w <- al !. n, getAlias w sϵ `IS.member` (colN (ɴs sϵ) `IS.union` pre (wkls sϵ)) ] + s0 = sϵ { stack = ns } + (s1, cs0) = + case ok0 of + c:_ -> (mapNs (mapColN (IS.insert n)) s0, IM.insert n c cs) + _ -> (mapNs (mapSpN (IS.insert n)) s0, cs) + in go (s1, colors, cs0) diff --git a/src/Asm/L.hs b/src/Asm/L.hs new file mode 100644 --- /dev/null +++ b/src/Asm/L.hs @@ -0,0 +1,12 @@ +module Asm.L ( mkLive, liveBB ) where + +import Asm.Ar +import Asm.BB +import CF +import LR + +mkLive :: (Arch arch reg freg) => [arch reg freg ()] -> [arch reg freg Liveness] +mkLive = concatMap expand. liveBB + +liveBB :: (Arch arch reg freg) => [arch reg freg ()] -> [BB arch reg freg () Liveness] +liveBB = fmap (fmap liveness) . reconstructFlat . cf . bb diff --git a/src/Asm/LI.hs b/src/Asm/LI.hs new file mode 100644 --- /dev/null +++ b/src/Asm/LI.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Asm.LI ( mkIntervals ) where + +import Asm.Ar +import Asm.L +import CF +import Data.Copointed +import LI + +mkIntervals :: (Arch arch reg freg, Copointed (arch reg freg)) => [arch reg freg ()] -> [arch reg freg Live] +mkIntervals = intervals . enliven . mkLive + where enliven = zipWith (\n a -> fmap (NLiveness n) a) [0..] diff --git a/src/Asm/M.hs b/src/Asm/M.hs new file mode 100644 --- /dev/null +++ b/src/Asm/M.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Asm.M ( CFunc (..) + , WM + , Label + , nextI + , nextL + , foldMapA + , prettyLabel + , i4 + , pAsm, prettyAsm + , aArr, mFree + ) where + +import Control.DeepSeq (NFData) +import Control.Monad.State.Strict (State, state) +import Data.Foldable (fold, traverse_) +import qualified Data.IntMap as IM +import Data.List (scanl') +import Data.Word (Word64) +import Foreign.Marshal.Alloc (free) +import Foreign.Marshal.Array (mallocArray, pokeArray) +import Foreign.Ptr (Ptr, plusPtr) +import GHC.Generics (Generic) +import qualified IR +import Prettyprinter (Doc, Pretty (pretty), indent) +import Prettyprinter.Ext + +type WM = State IR.WSt + +type Label = Word + +foldMapA :: (Applicative f, Traversable t, Monoid m) => (a -> f m) -> t a -> f m +foldMapA = (fmap fold .) . traverse + +prettyLabel :: Label -> Doc ann +prettyLabel l = "apple_" <> pretty l + +i4 = indent 4 + +prettyAsm :: (Pretty isn) => (IR.AsmData, [isn]) -> Doc ann +prettyAsm (ds,is) = pAD ds <#> pAsm is + +pAsm :: Pretty isn => [isn] -> Doc ann +pAsm = prettyLines.fmap pretty + +nextI :: WM Int +nextI = state (\(IR.WSt l i) -> (i, IR.WSt l (i+1))) + +nextL :: WM Label +nextL = state (\(IR.WSt i t) -> (i, IR.WSt (i+1) t)) + +data CFunc = Malloc | Free | JR | DR | Exp | Log | Pow deriving (Generic) + +instance NFData CFunc where + +instance Pretty CFunc where + pretty Malloc="malloc"; pretty Free="free" + pretty JR="mrand48"; pretty DR="drand48" + pretty Exp="exp"; pretty Log="log"; pretty Pow="pow" + +mFree :: Maybe (Ptr a) -> IO () +mFree = traverse_ free + +aArr :: IM.IntMap [Word64] -> IO (IM.IntMap (Ptr Word64)) +aArr as = do + let bls = fmap length as; bl = sum bls + p <- mallocArray bl + let bs = concat (IM.elems as) + pokeArray p bs + pure $ case IM.toList bls of + [] -> IM.empty + ((k0,l0):bls') -> IM.fromList . fmap (\(x,_,z) -> (x,z)) $ scanl' (\(_, lϵ, pϵ) (k, l) -> (k, l, pϵ `plusPtr` (lϵ*8))) (k0, l0, p) bls' diff --git a/src/Asm/X86.hs b/src/Asm/X86.hs new file mode 100644 --- /dev/null +++ b/src/Asm/X86.hs @@ -0,0 +1,716 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Asm.X86 ( X86 (..) + , AbsReg (..) + , FAbsReg (..) + , X86Reg (..) + , FX86Reg (..) + , Addr (..) + , ST (..) + , Scale (..) + , Pred (..) + , RoundMode (..) + , Label + , CFunc (..) + , prettyDebugX86 + , toInt + , fToInt + , imm8 + , roundMode + , mapR + , mapFR + , fR + , hasMa + ) where + +import Asm.M +import Control.DeepSeq (NFData (..)) +import Data.Copointed +import Data.Int (Int32, Int64, Int8) +import Data.Word (Word8) +import GHC.Generics (Generic) +import Prettyprinter (Doc, Pretty (..), brackets, colon, (<+>)) +import Prettyprinter.Ext + +data X86Reg = Rcx | Rdx | Rsi | Rdi | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 | Rbx | Rax | Rbp | Rsp + deriving (Eq, Ord, Enum, Generic) + +data FX86Reg = XMM1 | XMM2 | XMM3 | XMM4 | XMM5 | XMM6 | XMM7 | XMM8 | XMM9 | XMM10 | XMM11 | XMM12 | XMM13 | XMM14 | XMM15 | XMM0 + deriving (Eq, Ord, Enum, Generic) + +instance NFData X86Reg where +instance NFData FX86Reg where + +instance Pretty X86Reg where + pretty Rax = "rax" + pretty Rbx = "rbx" + pretty Rcx = "rcx" + pretty Rdx = "rdx" + pretty Rsi = "rsi" + pretty Rdi = "rdi" + pretty R8 = "r8" + pretty R9 = "r9" + pretty R10 = "r10" + pretty R11 = "r11" + pretty R12 = "r12" + pretty R13 = "r13" + pretty R14 = "r14" + pretty R15 = "r15" + pretty Rsp = "rsp" + pretty Rbp = "rbp" + +instance Pretty FX86Reg where + pretty XMM0 = "xmm0" + pretty XMM1 = "xmm1" + pretty XMM2 = "xmm2" + pretty XMM3 = "xmm3" + pretty XMM4 = "xmm4" + pretty XMM5 = "xmm5" + pretty XMM6 = "xmm6" + pretty XMM7 = "xmm7" + pretty XMM8 = "xmm8" + pretty XMM9 = "xmm9" + pretty XMM10 = "xmm10" + pretty XMM11 = "xmm11" + pretty XMM12 = "xmm12" + pretty XMM13 = "xmm13" + pretty XMM14 = "xmm14" + pretty XMM15 = "xmm15" + +instance Show X86Reg where show = show . pretty + +instance Show FX86Reg where show = show . pretty + +-- TODO: FAbsReg +data AbsReg = IReg !Int + | CArg0 | CArg1 | CArg2 | CArg3 | CArg4 | CArg5 + | CRet + | SP | BP + | Quot | Rem + deriving (Eq, Ord) + +data FAbsReg = FReg !Int + | FArg0 | FArg1 | FArg2 | FArg3 | FArg4 | FArg5 | FArg6 | FArg7 + | FRet0 | FRet1 + deriving (Eq, Ord) + +instance Pretty AbsReg where + pretty CArg0 = "rdi" + pretty CArg1 = "rsi" + pretty CArg2 = "rdx" + pretty CArg3 = "rcx" + pretty CArg4 = "r8" + pretty CArg5 = "r9" + pretty CRet = "rax" + pretty SP = "rsp" + pretty Quot = "rax" + pretty Rem = "rdx" + pretty (IReg i) = "^r" <> pretty i + pretty BP = "rbp" + +instance Pretty FAbsReg where + pretty FArg0 = "xmm0" + pretty FArg1 = "xmm1" + pretty FArg2 = "xmm2" + pretty FArg3 = "xmm3" + pretty FArg4 = "xmm4" + pretty FArg5 = "xmm5" + pretty FArg6 = "xmm6" + pretty FArg7 = "xmm7" + pretty FRet0 = "xmm0" + pretty FRet1 = "xmm1" + pretty (FReg i) = "^xmm" <> pretty i + +toInt :: AbsReg -> Int +toInt CArg0 = 0 +toInt CArg1 = 1 +toInt CArg2 = 2 +toInt CArg3 = 3 +toInt CArg4 = 4 +toInt CArg5 = 5 +toInt CRet = 6 +toInt SP = 7 +toInt Quot = 6 -- FIXME: I think this is wrong, graph approach would precolor both...? +toInt Rem = 2 +toInt (IReg i) = 16+i +toInt BP = -16 + +fToInt :: FAbsReg -> Int +fToInt FArg0 = 8 +fToInt FArg1 = 9 +fToInt FArg2 = 10 +fToInt FArg3 = 11 +fToInt FArg4 = 12 +fToInt FArg5 = 13 +fToInt FArg6 = 14 +fToInt FArg7 = 15 +fToInt FRet0 = 8 -- xmm0 +fToInt FRet1 = 9 -- xmm1 +fToInt (FReg i) = 16+i + +newtype ST = ST Int8 deriving (NFData) + +instance Pretty ST where + pretty (ST i) = "st" <> pretty i + +data RoundMode = RNearest | RDown | RUp | RZero deriving Generic + +instance NFData RoundMode where + +-- 3 bits, stored as Word8 for ease of manipulation +roundMode :: RoundMode -> Word8 +roundMode RNearest = 0x0 +roundMode RDown = 0x1 +roundMode RUp = 0x2 +roundMode RZero = 0x3 + +instance Pretty RoundMode where + pretty = pretty . roundMode + +data Scale = One | Two | Four | Eight deriving (Eq, Generic) + +instance Pretty Scale where + pretty One = "1" + pretty Two = "2" + pretty Four = "4" + pretty Eight = "8" + +data Pred = Eqoq | Ltos | Leos | Unordq | Nequq | Nltus | Nleus | Ordq deriving (Generic) + +instance Pretty Pred where + pretty Eqoq = "EQ_OQ" + pretty Ltos = "LT_OS" + pretty Leos = "LE_OS" + pretty Unordq = "UNORD_Q" + pretty Nequq = "NEQ_UQ" + pretty Nltus = "NLT_US" + pretty Nleus = "NLE_US" + pretty Ordq = "ORD_Q" + +hasMa :: [X86 reg freg a] -> Bool +hasMa = any g where g Call{} = True; g _ = False + +-- https://www.felixcloutier.com/x86/cmppd +imm8 :: Pred -> Int8 +imm8 Eqoq = 0 +imm8 Ltos = 1 +imm8 Leos = 2 +imm8 Unordq = 3 +imm8 Nequq = 4 +imm8 Nltus = 5 +imm8 Nleus = 6 +imm8 Ordq = 7 + +instance NFData Pred where + +data Addr reg = R reg | RC reg Int8 | RC32 reg Int32 | RS reg Scale reg | RSD reg Scale reg Int8 deriving (Eq, Generic, Functor, Foldable) + +instance NFData Scale where + +instance NFData reg => NFData (Addr reg) where + +pix c | c < 0 = pretty c | otherwise = "+" <> pretty c + +instance Pretty reg => Pretty (Addr reg) where + pretty (R r) = brackets (pretty r) + pretty (RC r c) = brackets (pretty r <> pix c) + pretty (RC32 r c) = brackets (pretty r <> pix c) + pretty (RS b One i) = brackets (pretty b <> "+" <> pretty i) + pretty (RS b s i) = brackets (pretty b <> "+" <> pretty s <> "*" <> pretty i) + 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 } + deriving (Functor, Generic) + +instance (NFData a, NFData reg, NFData freg) => NFData (X86 reg freg a) where + +instance Copointed (X86 reg freg) where copoint = ann + +instance (Pretty reg, Pretty freg) => Pretty (X86 reg freg 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) + pretty (MovRR _ r0 r1) = i4 ("mov" <+> pretty r0 <> "," <+> pretty r1) + pretty (MovRL _ r l) = i4 ("mov" <+> pretty r <> "," <+> "arr_" <> pretty l) + pretty (MovRI _ r i) = i4 ("mov" <+> pretty r <> "," <+> pretty i) + pretty (XorRR _ r0 r1) = i4 ("xor" <+> pretty r0 <> "," <+> pretty r1) + pretty (MovqXR _ r0 r1) = i4 ("movq" <+> pretty r0 <> "," <+> pretty r1) + pretty (IAddRR _ r0 r1) = i4 ("add" <+> pretty r0 <> "," <+> pretty r1) + pretty (IAddRI _ r i) = i4 ("add" <+> pretty r <> "," <+> pretty i) + pretty (ISubRR _ r0 r1) = i4 ("sub" <+> pretty r0 <> "," <+> pretty r1) + pretty (ISubRI _ r i) = i4 ("sub" <+> pretty r <> "," <+> pretty i) + pretty (IMulRR _ r0 r1) = i4 ("imul" <+> pretty r0 <> "," <+> pretty r1) + pretty (IMulRA _ r a) = i4 ("imul" <+> pretty r <> "," <+> pretty a) + pretty (Jne _ l) = i4 ("jne" <+> prettyLabel l) + pretty (Jle _ l) = i4 ("jle" <+> prettyLabel l) + pretty (Je _ l) = i4 ("je" <+> prettyLabel l) + pretty (Jge _ l) = i4 ("jge" <+> prettyLabel l) + pretty (Jg _ l) = i4 ("jg" <+> prettyLabel l) + pretty (Jl _ l) = i4 ("jl" <+> prettyLabel l) + pretty Ret{} = i4 "ret" + pretty (Vdivsd _ rD r0 r1) = i4 ("vdivsd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (Movapd _ r0 r1) = i4 ("movapd" <+> pretty r0 <> "," <+> pretty r1) + pretty (Cvttsd2si _ r0 r1) = i4 ("cvttsd2si" <+> pretty r0 <> "," <+> pretty r1) + pretty (Vmulsd _ rD r0 r1) = i4 ("vmulsd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (Vaddsd _ rD r0 r1) = i4 ("vaddsd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (VaddsdA _ rD r a) = i4 ("vaddsd" <+> pretty rD <> "," <+> pretty r <> "," <+> pretty a) + pretty (Vsubsd _ rD r0 r1) = i4 ("vsubsd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (Cvtsi2sd _ r0 r1) = i4 ("cvtsi2sd" <+> pretty r0 <> "," <+> pretty r1) + pretty (Roundsd _ r0 r1 m) = i4 ("roundsd" <+> pretty r0 <> "," <+> pretty r1 <> "," <+> pretty m) + pretty (CmpRI _ r i) = i4 ("cmp" <+> pretty r <> "," <+> pretty i) + pretty (Divsd _ r0 r1) = i4 ("divsd" <+> pretty r0 <> "," <+> pretty r1) + pretty (Mulsd _ r0 r1) = i4 ("mulsd" <+> pretty r0 <> "," <+> pretty r1) + pretty (Addsd _ r0 r1) = i4 ("addsd" <+> pretty r0 <> "," <+> pretty r1) + pretty (Subsd _ r0 r1) = i4 ("subsd" <+> pretty r0 <> "," <+> pretty r1) + pretty (MovRA _ r a) = i4 ("mov" <+> pretty r <> "," <+> pretty a) + pretty (MovAR _ a r) = i4 ("mov" <+> pretty a <> "," <+> pretty r) + pretty (MovAI32 _ a i) = i4 ("mov qword" <+> pretty a <> "," <+> pretty i) + pretty (MovqXA _ x a) = i4 ("movq" <+> pretty x <> "," <+> pretty a) + pretty (MovqAX _ a x) = i4 ("movq" <+> pretty a <> "," <+> pretty x) + pretty (Fld _ a) = i4 ("fld qword" <+> pretty a) + pretty Fyl2x{} = i4 "fyl2x" + pretty (Fstp _ a) = i4 ("fstp qword" <+> pretty a) + pretty F2xm1{} = i4 "f2xm1" + pretty Fldl2e{} = i4 "fldl2e" + pretty Fldln2{} = i4 "fldln2" + pretty Fld1{} = i4 "fld1" + pretty Fsin{} = i4 "fsin" + pretty Fcos{} = i4 "fcos" + pretty Fprem{} = i4 "fprem" + pretty Faddp{} = i4 "faddp" + pretty Fscale{} = i4 "fscale" + pretty Fninit{} = i4 "fninit" + pretty (Fxch _ st) = i4 ("fxch" <+> pretty st) + pretty (FldS _ st) = i4 ("fld" <+> pretty st) + pretty Fmulp{} = i4 "fmulp" + pretty (Vfmadd231sd _ rD r0 r1) = i4 ("vfmadd231sd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (Vfmnadd231sd _ rD r0 r1) = i4 ("vfmnadd231sd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (Vfmadd213sd _ rD r0 r1) = i4 ("vfmadd213sd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (Vfmsub231sd _ rD r0 r1) = i4 ("vfsubd231sd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (Vfmsub213sd _ rD r0 r1) = i4 ("vfsubd213sd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (Vfmsub132sd _ rD r0 r1) = i4 ("vfsubd132sd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1) + pretty (Vfmadd231sdA _ rD r a) = i4 ("vfmadd231sd" <+> pretty rD <> "," <+> pretty r <> "," <+> pretty a) + pretty (Push _ r) = i4 ("push" <+> pretty r) + pretty (Pop _ r) = i4 ("pop" <+> pretty r) + pretty (IDiv _ r) = i4 ("idiv" <+> pretty r) + pretty (Call _ f) = i4 ("call" <+> pretty f <+> "wrt ..plt") + pretty (Sal _ r i) = i4 ("sal" <+> pretty r <> "," <+> pretty i) + pretty (Sar _ r i) = i4 ("sar" <+> pretty r <> "," <+> pretty i) + pretty (Sqrtsd _ r0 r1) = i4 ("sqrtsd" <+> pretty r0 <> "," <+> pretty r1) + pretty (Maxsd _ r0 r1) = i4 ("maxsd" <+> pretty r0 <> "," <+> pretty r1) + pretty (Vmaxsd _ r0 r1 r2) = i4 ("vmaxsd" <+> pretty r0 <> "," <+> pretty r1 <> "," <+> pretty r2) + pretty (VmaxsdA _ r0 r1 a) = i4 ("vmaxsd" <+> pretty r0 <> "," <+> pretty r1 <> "," <+> pretty a) + pretty (Minsd _ r0 r1) = i4 ("minsd" <+> pretty r0 <> "," <+> pretty r1) + pretty (Vminsd _ r0 r1 r2) = i4 ("vminsd" <+> pretty r0 <> "," <+> pretty r1 <> "," <+> pretty r2) + pretty (Not _ r) = i4 ("not" <+> pretty r) + pretty (And _ r0 r1) = i4 ("and" <+> pretty r0 <> "," <+> pretty r1) + pretty (Cmovnle _ r0 r1) = i4 ("cmovnle" <+> pretty r0 <> "," <+> pretty r1) + pretty (Cmovnl _ r0 r1) = i4 ("cmovnl" <+> pretty r0 <> "," <+> pretty r1) + pretty (Cmovne _ r0 r1) = i4 ("cmovne" <+> pretty r0 <> "," <+> pretty r1) + pretty (Cmove _ r0 r1) = i4 ("cmove" <+> pretty r0 <> "," <+> pretty r1) + pretty (Cmovl _ r0 r1) = i4 ("cmovl" <+> pretty r0 <> "," <+> pretty r1) + pretty (Cmovle _ r0 r1) = i4 ("cmovle" <+> pretty r0 <> "," <+> pretty r1) + pretty (Rdrand _ r) = i4 ("rdrand" <+> pretty r) + pretty (Test _ r0 r1) = i4 ("test" <+> pretty r0 <> "," <+> pretty r1) + pretty (TestI _ r0 i) = i4 ("test" <+> pretty r0 <> "," <+> pretty i) + pretty (MovqRX _ r xr) = i4 ("movq" <+> pretty r <> "," <+> pretty xr) + pretty (Vcmppd _ xr0 xr1 xr2 Eqoq) = i4 ("vcmpeqpd" <+> pretty xr0 <> "," <+> pretty xr1 <> "," <+> pretty xr2) + pretty (Vcmppd _ xr0 xr1 xr2 Ltos) = i4 ("vcmpltpd" <+> pretty xr0 <> "," <+> pretty xr1 <> "," <+> pretty xr2) + pretty (Vcmppd _ xr0 xr1 xr2 Leos) = i4 ("vcmplepd" <+> pretty xr0 <> "," <+> pretty xr1 <> "," <+> pretty xr2) + pretty (Vcmppd _ xr0 xr1 xr2 Unordq) = i4 ("vcmpunordpd" <+> pretty xr0 <> "," <+> pretty xr1 <> "," <+> pretty xr2) + pretty (Vcmppd _ xr0 xr1 xr2 Nequq) = i4 ("vcmpneqpd" <+> pretty xr0 <> "," <+> pretty xr1 <> "," <+> pretty xr2) + pretty (Vcmppd _ xr0 xr1 xr2 Nltus) = i4 ("vcmpnltpd" <+> pretty xr0 <> "," <+> pretty xr1 <> "," <+> pretty xr2) + pretty (Vcmppd _ xr0 xr1 xr2 Nleus) = i4 ("vcmpnlepd" <+> pretty xr0 <> "," <+> pretty xr1 <> "," <+> pretty xr2) + pretty (Vcmppd _ xr0 xr1 xr2 Ordq) = i4 ("vcmpordpd" <+> pretty xr0 <> "," <+> pretty xr1 <> "," <+> pretty xr2) + pretty (C _ l) = i4 ("call" <+> prettyLabel l) + 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 + +prettyLive :: (Pretty reg, Pretty freg, Pretty o) => X86 reg freg o -> Doc ann +prettyLive r = pretty r <+> pretty (ann r) + +prettyDebugX86 :: (Pretty freg, Pretty reg, Pretty o) => [X86 reg freg o] -> Doc ann +prettyDebugX86 = prettyLines . fmap prettyLive + +(@<>) :: Semigroup m => (reg -> m) -> Addr reg -> m +(@<>) f (R r) = f r +(@<>) f (RC r _) = f r +(@<>) f (RC32 r _) = f r +(@<>) 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 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 +mapR _ (Je x l) = Je x l +mapR _ (Jge x l) = Jge x l +mapR _ (Jne x l) = Jne x l +mapR _ (J x l) = J x l +mapR _ (Jl x l) = Jl x l +mapR _ (Jle x l) = Jle x l +mapR _ (Label x l) = Label x l +mapR f (IMulRR l r0 r1) = IMulRR l (f r0) (f r1) +mapR f (IMulRA l r a) = IMulRA l (f r) (f<$>a) +mapR f (IAddRR l r0 r1) = IAddRR l (f r0) (f r1) +mapR f (ISubRR l r0 r1) = ISubRR l (f r0) (f r1) +mapR f (CmpRR l r0 r1) = CmpRR l (f r0) (f r1) +mapR f (ISubRI l r0 i) = ISubRI l (f r0) i +mapR f (IAddRI l r0 i) = IAddRI l (f r0) i +mapR f (MovRI l r0 i) = MovRI l (f r0) i +mapR f (MovRA l r a) = MovRA l (f r) (f<$>a) +mapR f (MovAR l a r) = MovAR l (f<$>a) (f r) +mapR f (MovAI32 l a i) = MovAI32 l (f<$>a) i + +mapR f (MovqXR l xr r) = MovqXR l xr (f r) +mapR f (MovqXA l xr a) = MovqXA l xr (f<$>a) +mapR f (MovqAX l a xr) = MovqAX l (f<$>a) xr +mapR f (Fld l a) = Fld l (f<$>a) +mapR _ (Fldl2e l) = Fldl2e l +mapR _ (Fldln2 l) = Fldln2 l +mapR _ (Fld1 l) = Fld1 l +mapR _ (Fyl2x l) = Fyl2x l +mapR f (Fstp l a) = Fstp l (f<$>a) +mapR _ (F2xm1 l) = F2xm1 l +mapR _ (Fmulp l) = Fmulp l +mapR _ (Fprem l) = Fprem l +mapR _ (Faddp l) = Faddp l +mapR _ (Fscale l) = Fscale l +mapR f (CmpRI l r i) = CmpRI l (f r) i +mapR _ (Ret l) = Ret l +mapR _ (Vdivsd l xr0 xr1 xr2) = Vdivsd l xr0 xr1 xr2 +mapR _ (Movapd l xr0 xr1) = Movapd l xr0 xr1 +mapR _ (FldS l s) = FldS l s +mapR _ (Fxch l s) = Fxch l s +mapR _ (Mulsd l xr0 xr1) = Mulsd l xr0 xr1 +mapR _ (Addsd l xr0 xr1) = Addsd l xr0 xr1 +mapR _ (Subsd l xr0 xr1) = Subsd l xr0 xr1 +mapR _ (Divsd l xr0 xr1) = Divsd l xr0 xr1 +mapR _ (Vmulsd l xr0 xr1 xr2) = Vmulsd l xr0 xr1 xr2 +mapR _ (Vaddsd l xr0 xr1 xr2) = Vaddsd l xr0 xr1 xr2 +mapR f (VaddsdA l xr0 xr1 a) = VaddsdA l xr0 xr1 (f<$>a) +mapR _ (Vsubsd l xr0 xr1 xr2) = Vsubsd l xr0 xr1 xr2 +mapR f (Cvttsd2si l r xr) = Cvttsd2si l (f r) xr +mapR f (Push l r) = Push l (f r) +mapR f (Pop l r) = Pop l (f r) +mapR _ (Call l f) = Call l f +mapR f (IDiv l r) = IDiv l (f r) +mapR _ (Roundsd l xr0 xr1 m) = Roundsd l xr0 xr1 m +mapR f (Cvtsi2sd l xr r) = Cvtsi2sd l xr (f r) +mapR _ (Vfmadd231sd l xr0 xr1 xr2) = Vfmadd231sd l xr0 xr1 xr2 +mapR _ (Vfmnadd231sd l xr0 xr1 xr2) = Vfmnadd231sd l xr0 xr1 xr2 +mapR _ (Vfmadd213sd l xr0 xr1 xr2) = Vfmadd213sd l xr0 xr1 xr2 +mapR _ (Vfmsub213sd l xr0 xr1 xr2) = Vfmsub213sd l xr0 xr1 xr2 +mapR _ (Vfmsub231sd l xr0 xr1 xr2) = Vfmsub231sd l xr0 xr1 xr2 +mapR _ (Vfmsub132sd l xr0 xr1 xr2) = Vfmsub132sd l xr0 xr1 xr2 +mapR f (Vfmadd231sdA l xr0 xr a) = Vfmadd231sdA l xr0 xr (f<$>a) +mapR f (Sal l r i) = Sal l (f r) i +mapR f (Sar l r i) = Sar l (f r) i +mapR _ (Sqrtsd l xr0 xr1) = Sqrtsd l xr0 xr1 +mapR _ (Maxsd l xr0 xr1) = Maxsd l xr0 xr1 +mapR _ (Minsd l xr0 xr1) = Minsd l xr0 xr1 +mapR _ (Vmaxsd l xr0 xr1 xr2) = Vmaxsd l xr0 xr1 xr2 +mapR _ (Vminsd l xr0 xr1 xr2) = Vminsd l xr0 xr1 xr2 +mapR f (VmaxsdA l xr0 xr1 a) = VmaxsdA l xr0 xr1 (f<$>a) +mapR f (Not l r) = Not l (f r) +mapR f (And l r0 r1) = And l (f r0) (f r1) +mapR f (Rdrand l r) = Rdrand l (f r) +mapR f (Cmovnle l r0 r1) = Cmovnle l (f r0) (f r1) +mapR f (Cmovnl l r0 r1) = Cmovnl l (f r0) (f r1) +mapR f (Cmovne l r0 r1) = Cmovne l (f r0) (f r1) +mapR f (Cmove l r0 r1) = Cmove l (f r0) (f r1) +mapR f (Cmovl l r0 r1) = Cmovl l (f r0) (f r1) +mapR f (Cmovle l r0 r1) = Cmovle l (f r0) (f r1) +mapR _ (Fninit l) = Fninit l +mapR f (Test l r0 r1) = Test l (f r0) (f r1) +mapR f (TestI l r i) = TestI l (f r) i +mapR _ (Vcmppd l xr0 xr1 xr2 p) = Vcmppd l xr0 xr1 xr2 p +mapR f (MovqRX l r xr) = MovqRX l (f r) xr +mapR _ (Fsin l) = Fsin l +mapR _ (Fcos l) = Fcos l +mapR f (XorRR l r0 r1) = XorRR l (f r0) (f r1) +mapR _ (C a l) = C a l +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 _ Jg{} = mempty +fR _ J{} = mempty +fR f (MovAR _ a r) = f @<> a <> f r +fR f (MovRA _ r a) = f r <> f @<> a +fR f (MovRR _ r0 r1) = f r0 <> f r1 +fR f (MovRL _ r _) = f r +fR _ Label{} = mempty +fR f (IAddRR _ r0 r1) = f r0 <> f r1 +fR f (IAddRI _ r _) = f r +fR f (ISubRR _ r0 r1) = f r0 <> f r1 +fR f (ISubRI _ r _) = f r +fR f (IMulRR _ r0 r1) = f r0 <> f r1 +fR f (IMulRA _ r a) = f r <> f @<> a +fR f (XorRR _ r0 r1) = f r0 <> f r1 +fR f (MovAI32 _ a _) = f @<> a +fR f (MovRI _ r _) = f r +fR f (MovqXR _ _ r) = f r +fR f (MovqXA _ _ a) = f @<> a +fR f (MovqAX _ a _) = f @<> a +fR f (MovqRX _ r _) = f r +fR f (Fld _ a) = f @<> a +fR _ FldS{} = mempty +fR _ Fldl2e{} = mempty +fR _ Fldln2{} = mempty +fR _ Fld1{} = mempty +fR _ Fyl2x{} = mempty +fR _ Fsin{} = mempty +fR _ Fcos{} = mempty +fR f (Fstp _ a) = f @<> a +fR _ F2xm1{} = mempty +fR _ Fmulp{} = mempty +fR _ Fprem{} = mempty +fR _ Faddp{} = mempty +fR _ Fscale{} = mempty +fR _ Fninit{} = mempty +fR _ Fxch{} = mempty +fR _ Je{} = mempty +fR _ Jne{} = mempty +fR _ Jge{} = mempty +fR _ Jl{} = mempty +fR _ Jle{} = mempty +fR _ C{} = mempty +fR f (CmpRR _ r0 r1) = f r0 <> f r1 +fR f (CmpRI _ r _) = f r +fR f (Test _ r0 r1) = f r0 <> f r1 +fR _ Vcmppd{} = mempty +fR f (TestI _ r _) = f r +fR _ Ret{} = mempty +fR _ RetL{} = mempty +fR _ Vdivsd{} = mempty +fR _ Movapd{} = mempty +fR _ Roundsd{} = mempty +fR f (Cvttsd2si _ r _) = f r +fR _ Mulsd{} = mempty +fR _ Addsd{} = mempty +fR _ Subsd{} = mempty +fR _ Divsd{} = mempty +fR _ Vmulsd{} = mempty +fR _ Vaddsd{} = mempty +fR f (VaddsdA _ _ _ a) = f @<> a +fR _ Vsubsd{} = mempty +fR f (Cvtsi2sd _ _ r) = f r +fR _ Vfmadd231sd{} = mempty +fR _ Vfmnadd231sd{} = mempty +fR _ Vfmadd213sd{} = mempty +fR _ Vfmsub213sd{} = mempty +fR _ Vfmsub231sd{} = mempty +fR _ Vfmsub132sd{} = mempty +fR f (Vfmadd231sdA _ _ _ a) = f @<> a +fR f (Push _ r) = f r +fR f (Pop _ r) = f r +fR _ Call{} = mempty +fR f (IDiv _ r) = f r +fR f (Sal _ r _) = f r +fR f (Sar _ r _) = f r +fR _ Sqrtsd{} = mempty +fR _ Maxsd{} = mempty +fR _ Vmaxsd{} = mempty +fR f (VmaxsdA _ _ _ a) = f @<> a +fR _ Minsd{} = mempty +fR _ Vminsd{} = mempty +fR f (Not _ r) = f r +fR f (And _ r0 r1) = f r0 <> f r1 +fR f (Cmovnle _ r0 r1) = f r0 <> f r1 +fR f (Cmovnl _ r0 r1) = f r0 <> f r1 +fR f (Cmovne _ r0 r1) = f r0 <> f r1 +fR f (Cmove _ r0 r1) = f r0 <> f r1 +fR f (Cmovl _ r0 r1) = f r0 <> f r1 +fR f (Cmovle _ r0 r1) = f r0 <> f r1 +fR f (Rdrand _ r) = f r +fR f (Neg _ r) = f r + +mapFR :: (afreg -> freg) -> X86 areg afreg a -> X86 areg freg a +mapFR _ (Jg x l) = Jg x l +mapFR _ (J x l) = J x l +mapFR _ (Label x l) = Label x l +mapFR _ (MovRI l r i) = MovRI l r i +mapFR _ (MovRR l r0 r1) = MovRR l r0 r1 +mapFR _ (MovRL x r l) = MovRL x r l +mapFR _ (IAddRI l r i) = IAddRI l r i +mapFR f (Movapd l r0 r1) = Movapd l (f r0) (f r1) +mapFR f (Mulsd l xr0 xr1) = Mulsd l (f xr0) (f xr1) +mapFR f (MovqXR l xr r) = MovqXR l (f xr) r +mapFR f (Roundsd l xr0 xr1 s) = Roundsd l (f xr0) (f xr1) s +mapFR f (Cvttsd2si l r xr) = Cvttsd2si l r (f xr) +mapFR f (Vsubsd l xr0 xr1 xr2) = Vsubsd l (f xr0) (f xr1) (f xr2) +mapFR f (Vaddsd l xr0 xr1 xr2) = Vaddsd l (f xr0) (f xr1) (f xr2) +mapFR f (VaddsdA l xr0 xr1 r) = VaddsdA l (f xr0) (f xr1) r +mapFR f (Vdivsd l xr0 xr1 xr2) = Vdivsd l (f xr0) (f xr1) (f xr2) +mapFR _ (CmpRR l r0 r1) = CmpRR l r0 r1 +mapFR f (Addsd l xr0 xr1) = Addsd l (f xr0) (f xr1) +mapFR _ (IAddRR l r0 r1) = IAddRR l r0 r1 +mapFR _ (ISubRR l r0 r1) = ISubRR l r0 r1 +mapFR _ (IMulRR l r0 r1) = IMulRR l r0 r1 +mapFR _ (IMulRA l r a) = IMulRA l r a +mapFR _ (ISubRI l r i) = ISubRI l r i +mapFR _ (MovRA l r a) = MovRA l r a +mapFR _ (MovAI32 l r i) = MovAI32 l r i +mapFR _ (MovAR l a r) = MovAR l a r +mapFR f (MovqXA l xr a) = MovqXA l (f xr) a +mapFR f (MovqAX l a xr) = MovqAX l a (f xr) +mapFR _ (Fld l a) = Fld l a +mapFR _ (FldS l s) = FldS l s +mapFR _ (Fldl2e l) = Fldl2e l +mapFR _ (Fldln2 l) = Fldln2 l +mapFR _ (Fld1 l) = Fld1 l +mapFR _ (Fyl2x l) = Fyl2x l +mapFR _ (Fstp l a) = Fstp l a +mapFR _ (F2xm1 l) = F2xm1 l +mapFR _ (Fmulp l) = Fmulp l +mapFR _ (Fprem l) = Fprem l +mapFR _ (Faddp l) = Faddp l +mapFR _ (Fscale l) = Fscale l +mapFR _ (Fninit l) = Fninit l +mapFR _ (Fxch l s) = Fxch l s +mapFR _ (Je x l) = Je x l +mapFR _ (Jge x l) = Jge x l +mapFR _ (Jne x l) = Jne x l +mapFR _ (Jl x l) = Jl x l +mapFR _ (Jle x l) = Jle x l +mapFR _ (CmpRI l r i) = CmpRI l r i +mapFR _ (Ret l) = Ret l +mapFR f (Subsd l xr0 xr1) = Subsd l (f xr0) (f xr1) +mapFR f (Divsd l xr0 xr1) = Divsd l (f xr0) (f xr1) +mapFR f (Vmulsd l xr0 xr1 xr2) = Vmulsd l (f xr0) (f xr1) (f xr2) +mapFR _ (Push l r) = Push l r +mapFR _ (Pop l r) = Pop l r +mapFR _ (IDiv l r) = IDiv l r +mapFR _ (Call l f) = Call l f +mapFR _ (Sal l r i) = Sal l r i +mapFR _ (Sar l r i) = Sar l r i +mapFR f (Maxsd l xr0 xr1) = Maxsd l (f xr0) (f xr1) +mapFR f (Vmaxsd l xr0 xr1 xr2) = Vmaxsd l (f xr0) (f xr1) (f xr2) +mapFR f (VmaxsdA l xr0 xr1 a) = VmaxsdA l (f xr0) (f xr1) a +mapFR f (Minsd l xr0 xr1) = Minsd l (f xr0) (f xr1) +mapFR f (Vminsd l xr0 xr1 xr2) = Vminsd l (f xr0) (f xr1) (f xr2) +mapFR _ (Not l r) = Not l r +mapFR f (Cvtsi2sd l xr r) = Cvtsi2sd l (f xr) r +mapFR f (Vfmadd231sd l xr0 xr1 xr2) = Vfmadd231sd l (f xr0) (f xr1) (f xr2) +mapFR f (Vfmnadd231sd l xr0 xr1 xr2) = Vfmnadd231sd l (f xr0) (f xr1) (f xr2) +mapFR f (Vfmadd213sd l xr0 xr1 xr2) = Vfmadd213sd l (f xr0) (f xr1) (f xr2) +mapFR f (Vfmsub213sd l xr0 xr1 xr2) = Vfmsub213sd l (f xr0) (f xr1) (f xr2) +mapFR f (Vfmsub231sd l xr0 xr1 xr2) = Vfmsub231sd l (f xr0) (f xr1) (f xr2) +mapFR f (Vfmsub132sd l xr0 xr1 xr2) = Vfmsub132sd l (f xr0) (f xr1) (f xr2) +mapFR f (Vfmadd231sdA l xr0 xr1 a) = Vfmadd231sdA l (f xr0) (f xr1) a +mapFR f (Sqrtsd l xr0 xr1) = Sqrtsd l (f xr0) (f xr1) +mapFR _ (And l r0 r1) = And l r0 r1 +mapFR _ (Cmovnle l r0 r1) = Cmovnle l r0 r1 +mapFR _ (Cmovnl l r0 r1) = Cmovnl l r0 r1 +mapFR _ (Cmovne l r0 r1) = Cmovne l r0 r1 +mapFR _ (Cmove l r0 r1) = Cmove l r0 r1 +mapFR _ (Cmovl l r0 r1) = Cmovl l r0 r1 +mapFR _ (Cmovle l r0 r1) = Cmovle l r0 r1 +mapFR _ (Rdrand l r) = Rdrand l r +mapFR _ (TestI l r i) = TestI l r i +mapFR _ (Test l r0 r1) = Test l r0 r1 +mapFR f (Vcmppd l xr0 xr1 xr2 p) = Vcmppd l (f xr0) (f xr1) (f xr2) p +mapFR f (MovqRX l r xr) = MovqRX l r (f xr) +mapFR _ (Fsin l) = Fsin l +mapFR _ (Fcos l) = Fcos l +mapFR _ (XorRR l r0 r1) = XorRR l r0 r1 +mapFR _ (C a l) = C a l +mapFR _ (RetL a l) = RetL a l +mapFR _ (Neg a r) = Neg a r diff --git a/src/Asm/X86/B.hs b/src/Asm/X86/B.hs new file mode 100644 --- /dev/null +++ b/src/Asm/X86/B.hs @@ -0,0 +1,13 @@ +module Asm.X86.B ( bb ) where + +import Asm.BB +import Asm.X86 +import Data.List.Split (keepDelimsL, keepDelimsR, split, whenElt) + +bb :: [X86 reg freg a] -> [BB X86 reg freg 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 + mkBB x = BB x () + emptyBB (BB [] _) = True + emptyBB _ = False diff --git a/src/Asm/X86/Byte.hs b/src/Asm/X86/Byte.hs new file mode 100644 --- /dev/null +++ b/src/Asm/X86/Byte.hs @@ -0,0 +1,988 @@ +-- https://defuse.ca/online-x86-assembler.htm +-- https://disasm.pro/ +-- +-- https://wiki.osdev.org/X86-64_Instruction_Encoding + +{-# LANGUAGE TupleSections #-} + +module Asm.X86.Byte ( allFp, assemble, assembleCtx, dbgFp ) where + +import Asm.M +import Asm.X86 +import Data.Bifunctor (second) +import Data.Bits (Bits, rotateR, shiftL, (.&.), (.|.)) +import qualified Data.ByteString as BS +import Data.Functor (($>)) +import Data.Int (Int32, Int64, Int8) +import qualified Data.IntMap as IM +import qualified Data.Map.Strict as M +import Data.Word +import Foreign.Ptr (FunPtr, IntPtr (..), Ptr, ptrToIntPtr) +import Foreign.Storable (Storable, sizeOf) +import Hs.FFI +import Sys.DL + +pI :: Ptr a -> Int +pI = (\(IntPtr i) -> i) . ptrToIntPtr + +prepAddrs :: [X86 reg freg 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 ctx (ds, isns) = do + let (sz, lbls) = mkIx 0 isns + p <- if hasMa isns then allocNear (fst4 ctx) (fromIntegral sz) else allocExec (fromIntegral sz) + arrs <- aArr ds + let b = BS.pack.concat$asm 0 (pI p, arrs, Just ctx, lbls) isns + 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 (ds, instrs) = do + let (sz, lbls) = mkIx 0 instrs + (fn, p) <- do + res <- prepAddrs instrs + case res of + Just (m, _, _, _) -> (res,) <$> allocNear m (fromIntegral sz) + _ -> (res,) <$> allocExec (fromIntegral sz) + arrs <- aArr ds + let is = asm 0 (pI p, arrs, fn, lbls) instrs; b = BS.pack.concat$is; bs = BS.pack<$>is + mP = snd<$>IM.lookupMin arrs + (bs,,mP)<$>finish b p + +assemble :: (IM.IntMap [Word64], [X86 X86Reg FX86Reg 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 + +data VEXM = F | F38 | F3A + +data PP = S6 | F3 | F2 + +rrNoPre :: RMB reg + => [Word8] + -> reg -- ^ r/m + -> reg -- ^ reg + -> [Word8] +rrNoPre opc r0 r1 = + let (_, b0) = modRM r0 + (_, b1) = modRM r1 + modRMB = (0x3 `shiftL` 6) .|. (b1 `shiftL` 3) .|. b0 + in opc++[modRMB] + +mkRR opc = mkAR opc 3 + +mkAR :: (RMB reg0, RMB reg1) + => [Word8] + -> Word8 -- ^ mod + -> reg0 -- ^ r/m + -> reg1 -- ^ reg + -> [Word8] +mkAR opc m r0 r1 = + let (e0, b0) = modRM r0 + (e1, b1) = modRM r1 + prefix = 0x48 .|. (e1 `shiftL` 2) .|. e0 + modRMB = (m `shiftL` 6) .|. (b1 `shiftL` 3) .|. b0 + in prefix:opc++[modRMB] + +-- movapd xmm9, xmm5 -> 66 44 0f 28 cd +-- movapd xmm1, xmm5 -> 66 0f 28 cd +-- +-- addsd xmm8,xmm10 -> f2 45 0f 58 c2 +extSse :: Word8 -> Word8 -> FX86Reg -> FX86Reg -> [Word8] +extSse pre opc r0 r1 = + let (e0, b0) = modRM r0 + (e1, b1) = modRM r1 + b = 0x40 .|. (e1 `shiftL` 2) .|. e0 + modRMB = (0x3 `shiftL` 6) .|. (b1 `shiftL` 3) .|. b0 + in [pre,b,0xf,opc,modRMB] + +vexV4 :: FX86Reg -> Word8 +vexV4 XMM0 = 0xf +vexV4 XMM1 = 0xe +vexV4 XMM2 = 0xd +vexV4 XMM3 = 0xc +vexV4 XMM4 = 0xb +vexV4 XMM5 = 0xa +vexV4 XMM6 = 0x9 +vexV4 XMM7 = 0x8 +vexV4 XMM8 = 0x7 +vexV4 XMM9 = 0x6 +vexV4 XMM10 = 0x5 +vexV4 XMM11 = 0x4 +vexV4 XMM12 = 0x3 +vexV4 XMM13 = 0x2 +vexV4 XMM14 = 0x1 +vexV4 XMM15 = 0x0 + +bitC :: Word8 -> Word8 +bitC 0x0 = 0x1 +bitC 0x1 = 0x0 + +bitsm :: VEXM -> Word8 +bitsm F = 0x1 +bitsm F38 = 0x2 +bitsm F3A = 0x3 + +ppbits :: PP -> Word8 +ppbits S6 = 0x1 +ppbits F3 = 0x2 +ppbits F2 = 0x3 + +mkVex :: Word8 -> PP -> FX86Reg -> FX86Reg -> FX86Reg -> [Word8] +mkVex opc pp r0 r1 r2 = + [0xc5,b,opc,modRMB] + where b = (bitC e0 `shiftL` 7) .|. (vexV4 r1 `shiftL` 3) .|. ppbits pp + (e0, b0) = modRM r0 + (_, b2) = modRM r2 + modRMB = (0x3 `shiftL` 6) .|. b0 `shiftL` 3 .|. b2 + +mkVex3 :: Word8 -> PP -> VEXM -> FX86Reg -> FX86Reg -> FX86Reg -> [Word8] +mkVex3 opc pp mm r0 r1 r2 = + [0xc4,by0,by1,opc,modRMB] + where by0 = (bitC e0 `shiftL` 7) .|. (0x1 `shiftL` 6) .|. (bitC e2 `shiftL` 5) .|. bitsm mm + by1 = 1 `shiftL` 7 .|. (vexV4 r1 `shiftL` 3) .|. ppbits pp + (e0, b0) = modRM r0 + (e2, b2) = modRM r2 + modRMB = (0x3 `shiftL` 6) .|. b0 `shiftL` 3 .|. b2 + +mkVexA :: Word8 -> PP -> VEXM -> FX86Reg -> FX86Reg -> Addr X86Reg -> [Word8] +mkVexA opc pp mm xr0 xr1 (RSD b s i d)= + [0xc4,by0,by1,opc,modRMB,sib]++le d + where by0 = (bitC e0 `shiftL` 7) .|. (bitC ei `shiftL` 6) .|. (bitC eb `shiftL` 5) .|. bitsm mm + by1 = 1 `shiftL` 7 .|. vexV4 xr1 `shiftL` 3 .|. ppbits pp + (e0, b0) = modRM xr0 + (eb, bb) = modRM b + (ei, bi) = modRM i + modRMB = 0x1 `shiftL` 6 .|. b0 `shiftL` 3 .|. 0x4 + sib = encS s `shiftL` 6 .|. bi `shiftL` 3 .|. bb +mkVexA opc pp mm xr0 xr1 (RC b@Rsp i) = + [0xc4,by0,by1,opc,modRMB,sib]++le i + where by0 = bitC e0 `shiftL` 7 .|. bitC eb `shiftL` 6 .|. bitC eb `shiftL` 5 .|. bitsm mm + by1 = 1 `shiftL` 7 .|. vexV4 xr1 `shiftL` 3 .|. ppbits pp + (e0,b0) = modRM xr0 + (eb,bb) = modRM b + 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 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 + | otherwise = mkIx (ix+2) asms +mkIx ix (Label _ l:asms) = second (M.insert l ix) $ mkIx ix asms +mkIx ix (MovRR{}:asms) = mkIx (ix+3) asms +mkIx ix (Movapd _ r0 r1:asms) | fits r0 && fits r1 = mkIx (ix+4) asms + | otherwise = mkIx (ix+5) asms +mkIx ix (IAddRR{}:asms) = mkIx (ix+3) asms +mkIx ix (And{}:asms) = mkIx (ix+3) asms +mkIx ix (ISubRR{}:asms) = mkIx (ix+3) asms +mkIx ix (Addsd _ r0 r1:asms) | fits r0 && fits r1 = mkIx (ix+4) asms + | otherwise = mkIx (ix+5) asms +mkIx ix (Mulsd _ r0 r1:asms) | fits r0 && fits r1 = mkIx (ix+4) asms + | otherwise = mkIx (ix+5) asms +mkIx ix (Divsd _ r0 r1:asms) | fits r0 && fits r1 = mkIx (ix+4) asms + | otherwise = mkIx (ix+5) asms +mkIx ix (Vsubsd _ _ _ r:asms) | fits r = mkIx (ix+4) asms + | otherwise = mkIx (ix+5) asms +mkIx ix (Vaddsd _ _ _ r:asms) | fits r = mkIx (ix+4) asms + | otherwise = mkIx (ix+5) asms +mkIx ix (Vdivsd _ _ _ r:asms) | fits r = mkIx (ix+4) asms + | otherwise = mkIx (ix+5) asms +mkIx ix (Vmulsd _ _ _ r:asms) | fits r = mkIx (ix+4) asms + | otherwise = mkIx (ix+5) asms +mkIx ix (Vmaxsd _ _ _ r:asms) | fits r = mkIx (ix+4) asms + | otherwise = mkIx (ix+5) asms +mkIx ix (VaddsdA{}:asms) = mkIx (ix+7) asms +mkIx ix (VmaxsdA{}:asms) = mkIx (ix+7) asms +mkIx ix (Vcmppd _ _ _ r _ :asms) | fits r = mkIx (ix+5) asms + | otherwise = mkIx (ix+6) asms +mkIx ix (Vfmadd231sd{}:asms) = mkIx (ix+5) asms +mkIx ix (Vfmnadd231sd{}:asms) = mkIx (ix+5) asms +mkIx ix (Vfmadd213sd{}:asms) = mkIx (ix+5) asms +mkIx ix (Vfmsub213sd{}:asms) = mkIx (ix+5) asms +mkIx ix (Vfmsub231sd{}:asms) = mkIx (ix+5) asms +mkIx ix (Vfmsub132sd{}:asms) = mkIx (ix+5) asms +mkIx ix (Vfmadd231sdA{}:asms) = mkIx (ix+7) asms +mkIx ix (CmpRR{}:asms) = mkIx (ix+3) asms +mkIx ix (IMulRR{}:asms) = mkIx (ix+4) asms +mkIx ix (IMulRA{}:asms) = mkIx (ix+6) asms +mkIx ix (XorRR{}:asms) = mkIx (ix+3) asms +mkIx ix (MovqXR{}:asms) = mkIx (ix+5) asms +mkIx ix (MovqRX{}:asms) = mkIx (ix+5) asms +mkIx ix (TestI{}:asms) = mkIx (ix+7) asms +mkIx ix ((CmpRI _ _ i):asms) | Just{} <- mi64i8 (fromIntegral i) = mkIx (ix+4) asms + | otherwise = mkIx (ix+7) asms +mkIx ix ((IAddRI _ _ i):asms) | Just{} <- mi64i8 i = mkIx (ix+4) asms +mkIx ix ((IAddRI _ _ i):asms) | Just{} <- mi64i32 i = mkIx (ix+7) asms +mkIx ix ((ISubRI _ _ i):asms) | Just{} <- mi64i8 i = mkIx (ix+4) asms + | Just{} <- mi64i32 i = mkIx (ix+7) asms +mkIx ix (MovRI _ r i:asms) | Just{} <- mi64i32 i, i >= 0 && fits r = mkIx (ix+5) asms +mkIx ix (MovRI{}:asms) = mkIx (ix+10) asms +mkIx ix (MovRL{}:asms) = mkIx (ix+10) asms +mkIx ix (Roundsd _ r0 r1 _:asms) | fits r0 && fits r1 = mkIx (ix+6) asms +mkIx ix (Roundsd{}:asms) = mkIx (ix+7) asms +mkIx ix (Cvttsd2si{}:asms) = mkIx (ix+5) asms +mkIx ix (Cvtsi2sd{}:asms) = mkIx (ix+5) asms +mkIx ix (Ret{}:asms) = mkIx (ix+1) asms +mkIx ix (RetL{}:asms) = mkIx (ix+1) asms +mkIx ix (Je{}:asms) = mkIx (ix+6) asms +mkIx ix (Jne{}:asms) = mkIx (ix+6) asms +mkIx ix (Jg{}:asms) = mkIx (ix+6) asms +mkIx ix (Jge{}:asms) = mkIx (ix+6) asms +mkIx ix (Jl{}:asms) = mkIx (ix+6) asms +mkIx ix (Jle{}:asms) = mkIx (ix+6) asms +mkIx ix (J{}:asms) = mkIx (ix+5) asms +mkIx ix (C{}:asms) = mkIx (ix+5) asms +mkIx ix (MovqAX _ (R Rsp) r:asms) | fits r = mkIx (ix+5) asms +mkIx ix (MovqAX _ (R rb) r:asms) | fits rb && fits r = mkIx (ix+4) asms + | otherwise = mkIx (ix+5) asms +mkIx ix (MovqAX _ (RC Rsp _) r1:asms) | fits r1 = mkIx (ix+6) asms +mkIx ix (MovqAX _ (RC R12 _) _:asms) = mkIx (ix+7) asms +mkIx ix (MovqAX _ (RC rb _) r:asms) | fits rb && fits r = mkIx (ix+5) asms + | otherwise = mkIx (ix+6) asms +mkIx ix (MovqAX _ (RSD b _ i _) r:asms) | fits r && fits b && fits i = mkIx (ix+6) asms +mkIx ix (MovqAX _ RSD{} _:asms) = mkIx (ix+7) asms +mkIx ix (MovqXA _ _ (R R13):asms) = mkIx (ix+6) asms +mkIx ix (MovqXA _ r0 (R Rsp):asms) | fits r0 = mkIx (ix+5) asms + | otherwise = mkIx (ix+6) asms +mkIx ix (MovqXA _ r0 (R r1):asms) | fits r0 && fits r1 = mkIx (ix+4) asms + | otherwise = mkIx (ix+5) asms +mkIx ix (MovqXA _ _ (RS R13 _ _):asms) = mkIx (ix+7) asms +mkIx ix (MovqXA _ _ RSD{}:asms) = mkIx (ix+7) asms +mkIx ix (MovqXA _ _ RS{}:asms) = mkIx (ix+6) asms +mkIx ix (MovqXA _ r0 (RC Rsp _):asms) | fits r0 = mkIx (ix+6) asms + | otherwise = mkIx (ix+7) asms +mkIx ix (MovqXA _ xr (RC r _):asms) | fits xr && fits r = mkIx (ix+5) asms +mkIx ix (MovqXA _ _ (RC R12 _):asms) = mkIx (ix+7) asms +mkIx ix (MovqXA _ _ RC{}:asms) = mkIx (ix+6) asms +mkIx ix (Fldl2e{}:asms) = mkIx (ix+2) asms +mkIx ix (Fldln2{}:asms) = mkIx (ix+2) asms +mkIx ix (Fld1{}:asms) = mkIx (ix+2) asms +mkIx ix (Fsin{}:asms) = mkIx (ix+2) asms +mkIx ix (Fcos{}:asms) = mkIx (ix+2) asms +mkIx ix (FldS{}:asms) = mkIx (ix+2) asms +mkIx ix (Fld _ (RC Rsp _):asms) = mkIx (ix+4) asms +mkIx ix (Fyl2x{}:asms) = mkIx (ix+2) asms +mkIx ix (Fmulp{}:asms) = mkIx (ix+2) asms +mkIx ix (F2xm1{}:asms) = mkIx (ix+2) asms +mkIx ix (Fprem{}:asms) = mkIx (ix+2) asms +mkIx ix (Faddp{}:asms) = mkIx (ix+2) asms +mkIx ix (Fscale{}:asms) = mkIx (ix+2) asms +mkIx ix (Fxch{}:asms) = mkIx (ix+2) asms +mkIx ix (Fstp _ (RC Rsp _):asms) = mkIx (ix+4) asms +mkIx ix (Sal{}:asms) = mkIx (ix+4) asms +mkIx ix (Sar{}:asms) = mkIx (ix+4) asms +mkIx ix (Call{}:asms) = mkIx (ix+5) asms +mkIx ix (MovAI32 _ (R Rsp) _:asms) = mkIx (ix+8) asms +mkIx ix (MovAI32 _ (R Rbp) _:asms) = mkIx (ix+8) asms +mkIx ix (MovAI32 _ (R R13) _:asms) = mkIx (ix+8) asms +mkIx ix (MovAI32 _ (R R12) _:asms) = mkIx (ix+8) asms +mkIx ix (MovAI32 _ R{} _:asms) = mkIx (ix+7) asms +mkIx ix (MovAI32 _ RC{} _:asms) = mkIx (ix+8) asms +mkIx ix (MovAR _ (RC Rsp _) _:asms) = mkIx (ix+5) asms +mkIx ix (MovAR _ (RC R12 _) _:asms) = mkIx (ix+5) asms +mkIx ix (MovAR _ RC{} _:asms) = mkIx (ix+4) asms +mkIx ix (MovAR _ (RC32 Rsp _) _:asms) = mkIx (ix+8) asms +mkIx ix (MovAR _ RC32{} _:asms) = mkIx (ix+7) asms +mkIx ix (MovAR _ RSD{} _:asms) = mkIx (ix+5) asms +mkIx ix (MovAR _ RS{} _:asms) = mkIx (ix+4) asms +mkIx ix (MovAR _ (R Rsp) _:asms) = mkIx (ix+4) asms +mkIx ix (MovAR _ (R Rbp) _:asms) = mkIx (ix+4) asms +mkIx ix (MovAR _ (R R13) _:asms) = mkIx (ix+4) asms +mkIx ix (MovAR _ R{} _:asms) = mkIx (ix+3) asms +mkIx ix (MovRA _ _ (RS Rbp _ _):asms) = mkIx (ix+5) asms +mkIx ix (MovRA _ _ (RS R13 _ _):asms) = mkIx (ix+5) asms +mkIx ix (MovRA _ _ RS{}:asms) = mkIx (ix+4) asms +mkIx ix (MovRA _ _ RSD{}:asms) = mkIx (ix+5) asms +mkIx ix (MovRA _ _ (R Rsp):asms) = mkIx (ix+4) asms +mkIx ix (MovRA _ _ (R Rbp):asms) = mkIx (ix+4) asms +mkIx ix (MovRA _ _ (R R13):asms) = mkIx (ix+4) asms +mkIx ix (MovRA _ _ R{}:asms) = mkIx (ix+3) asms +mkIx ix (MovRA _ _ (RC Rsp _):asms) = mkIx (ix+5) asms +mkIx ix (MovRA _ _ (RC R12 _):asms) = mkIx (ix+5) asms +mkIx ix (MovRA _ _ RC{}:asms) = mkIx (ix+4) asms +mkIx ix (MovRA _ _ (RC32 Rsp _):asms) = mkIx (ix+8) asms +mkIx ix (MovRA _ _ RC32{}:asms) = mkIx (ix+7) asms +mkIx ix (Sqrtsd _ r0 r1:asms) | fits r0 && fits r1 = mkIx (ix+4) asms + | otherwise = mkIx (ix+5) asms +mkIx ix (Not{}:asms) = mkIx (ix+3) asms +mkIx ix (Rdrand{}:asms) = mkIx (ix+4) asms +mkIx ix (Cmovnle{}:asms) = mkIx (ix+4) asms +mkIx ix (Cmovnl{}:asms) = mkIx (ix+4) asms +mkIx ix (Cmovne{}:asms) = mkIx (ix+4) asms +mkIx ix (Cmove{}:asms) = mkIx (ix+4) asms +mkIx ix (Cmovl{}:asms) = mkIx (ix+4) asms +mkIx ix (Cmovle{}:asms) = mkIx (ix+4) asms +mkIx ix (Fninit{}:asms) = mkIx (ix+2) asms +mkIx ix (IDiv{}:asms) = mkIx (ix+3) asms +mkIx ix (Neg{}:asms) = mkIx (ix+3) asms +mkIx ix [] = (ix, M.empty) +mkIx _ (instr:_) = error (show instr) + +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 _ _ [] = [] +asm ix st (Push _ r:asms) | fits r = + let (_, b0) = modRM r + isn = 0x50 .|. b0 + in [isn]:asm (ix+1) st asms + | otherwise = + let (_, b0) = modRM r + instr = [0x41, 0x50 .|. b0] + in instr:asm (ix+2) st asms +asm ix st (Pop _ r:asms) | (0, b0) <- modRM r= + let isn = 0x58 .|. b0 + in [isn]:asm (ix+1) st asms + | otherwise = + let (_, b0) = modRM r + instr = [0x41, 0x58 .|. b0] + in instr:asm (ix+2) st asms +asm ix st (Label{}:asms) = + asm ix st asms +asm ix st (MovRR _ r0 r1:asms) = + mkRR [0x89] r0 r1:asm (ix+3) st asms +asm ix st (MovRA _ r0 (RC r1@Rsp i8):asms) = + let (e0, b0) = modRM r0 + (0, b1) = modRM r1 + pref = 0x48 .|. e0 `shiftL` 2 + modB = 0x1 `shiftL` 6 .|. b0 `shiftL` 3 .|. 4 + sib = b1 `shiftL` 3 .|. b1 + opc=0x8b; instr = pref:opc:modB:sib:le i8 + in instr:asm (ix+5) st asms +asm ix st (MovRA _ r0 (RC r1@R12 i8):asms) = + let (e0, b0) = modRM r0 + (e1, b1) = modRM r1 + pref = 0x48 .|. e0 `shiftL` 2 .|. e1 + modB = 0x1 `shiftL` 6 .|. b0 `shiftL` 3 .|. 4 + sib = b1 `shiftL` 3 .|. b1 + opc=0x8b; instr = pref:opc:modB:sib:le i8 + in instr:asm (ix+5) st asms +asm ix st (MovRA _ r0 (RC32 r1@Rsp i32):asms) = + let (e0, b0) = modRM r0 + (0, b1) = modRM r1 + pref = 0x48 .|. e0 `shiftL` 2 + modB = 0x2 `shiftL` 6 .|. b0 `shiftL` 3 .|. 4 + sib = b1 `shiftL` 3 .|. b1 + opc=0x8b; instr = pref:opc:modB:sib:le i32 + in instr:asm (ix+8) st asms +asm ix st (MovRA _ r0 (RC r1 i8):asms) = + let (e0, b0) = modRM r0 + (e1, b1) = modRM r1 + pref = 0x48 .|. (e0 `shiftL` 2) .|. e1 + modB = 0x1 `shiftL` 6 .|. (b0 `shiftL` 3) .|. b1 + opc=0x8b; instr = pref:opc:modB:le i8 + in instr:asm (ix+4) st asms +asm ix st (MovRA _ r0 (RC32 r1 i32):asms) = + let (e0, b0) = modRM r0 + (e1, b1) = modRM r1 + pref = 0x48 .|. (e0 `shiftL` 2) .|. e1 + modB = 0x2 `shiftL` 6 .|. (b0 `shiftL` 3) .|. b1 + opc=0x8b; instr = pref:opc:modB:le i32 + in instr:asm (ix+7) st asms +asm ix st (MovqXA _ r0 (RC r1@Rsp i8):asms) | fits r0 = + let (_, b0) = modRM r0 + (_, b1) = modRM r1 + modB = 0x1 `shiftL` 6 .|. b0 `shiftL` 3 .|. 0x4 + sib = b1 `shiftL` 3 .|. b1 + instr = 0xf3:0xf:0x7e:modB:sib:le i8 + in instr:asm (ix+6) st asms +-- https://stackoverflow.com/questions/52522544/rbp-not-allowed-as-sib-base +asm ix st (MovqXA l r0 (R R13):asms) = asm ix st (MovqXA l r0 (RC R13 0):asms) +asm ix st (MovqXA _ r0 (R r1@Rsp):asms) | (0, b0) <- modRM r0 = + let (0, b1) = modRM r1 + modB = b0 `shiftL` 3 .|. 4 + sib = b1 `shiftL` 3 .|. b1 + isn = [0xf3,0x0f,0x7e,modB,sib] + in isn:asm (ix+5) st asms +asm ix st (MovqXA _ r0 (R r1):asms) | (0, b0) <- modRM r0, (0, b1) <- modRM r1 = + let modB = b0 `shiftL` 3 .|. b1 + instr = [0xf3, 0x0f, 0x7e, modB] + in instr:asm (ix+4) st asms +asm ix st (MovqXA _ r0 (RC r1 i8):asms) | (0, b0) <- modRM r0, (0, b1) <- modRM r1 = + let modB = 0x1 `shiftL` 6 .|. b0 `shiftL` 3 .|. b1 + instr = 0xf3:0x0f:0x7e:modB:le i8 + in instr:asm (ix+5) st asms +asm ix st (MovqXA _ r (RC rb@R12 i8):asms) = + let (e, b) = modRM r + (eb, bb) = modRM rb + modB = 0x1 `shiftL` 6 .|. b `shiftL` 3 .|. 0x4 + sib = 0x4 `shiftL` 3 .|. bb + pre = 0x48 .|. e `shiftL` 2 .|. eb + isn = 0x66:pre:0xf:0x6e:modB:sib:le i8 + in isn:asm (ix+7) st asms +asm ix st (MovqXA _ r (RC rb@Rsp i8):asms) = + let (e, b) = modRM r + (eb, bb) = modRM rb + modB = 0x1 `shiftL` 6 .|. b `shiftL` 3 .|. 0x4 + sib = 0x4 `shiftL` 3 .|. bb + pre = 0x48 .|. e `shiftL` 2 .|. eb + isn = 0x66:pre:0xf:0x6e:modB:sib:le i8 + in isn:asm (ix+7) st asms +asm ix st (MovqXA _ r0 (RC r1 i8):asms) = + let (e0, b0) = modRM r0 + (e1, b1) = modRM r1 + modB = 0x1 `shiftL` 6 .|. b0 `shiftL` 3 .|. b1 + pre = 0x48 .|. e0 `shiftL` 2 .|. e1 + instr = 0x66:pre:0xf:0x6e:modB:le i8 + in instr:asm (ix+6) st asms +asm ix st (MovqXA _ r0 (R r1@Rsp):asms) = + let (e0, b0) = modRM r0 + (0, b1) = modRM r1 + modB = b0 `shiftL` 3 .|. 4 + pre = 0x48 .|. e0 `shiftL` 2 + sib = b1 `shiftL` 3 .|. b1 + instr = [0x66, pre, 0xf, 0x6e, modB, sib] + in instr:asm (ix+6) st asms +asm ix st (MovqXA _ r0 (R r1):asms) = + let (e0, b0) = modRM r0 + (e1, b1) = modRM r1 + modB = b0 `shiftL` 3 .|. b1 + pre = 0x48 .|. e0 `shiftL` 2 .|. e1 + instr = [0x66, pre, 0xf, 0x6e, modB] + in instr:asm (ix+5) st asms +-- https://stackoverflow.com/questions/52522544/rbp-not-allowed-as-sib-base +asm ix st (MovqAX _ (RC r0@Rsp i8) r1:asms) | (0, b1) <- modRM r1 = + let (0, b0) = modRM r0 + modB = 0x1 `shiftL` 6 .|. b1 `shiftL` 3 .|. 0x4 + sib = b0 `shiftL` 3 .|. b0 + instr = 0x66:0x0f:0xd6:modB:sib:le i8 + in instr:asm (ix+6) st asms +asm ix st (MovqAX _ (R rb@Rsp) r:asms) | (0, b) <- modRM r = + let (0, bb) = modRM rb + modB = b `shiftL` 3 .|. 0x4 + sib = bb `shiftL` 3 .|. bb + isn = [0x66,0x0f,0xd6,modB,sib] + in isn:asm (ix+5) st asms +asm ix st (MovqAX _ (R rb) r:asms) | (0, bb) <- modRM rb, (0, b) <- modRM r = + let modB = b `shiftL` 3 .|. bb + isn = [0x66,0x0f,0xd6,modB] + in isn:asm (ix+4) st asms +asm ix st (MovqAX _ (R rb) r:asms) = + let (eb, bb) = modRM rb; (e, b) = modRM r + pre = 0x48 .|. e `shiftL` 3 .|. eb + modB = b `shiftL` 3 .|. bb + isn = [0x66,pre,0x0f,0xd6,modB] + in isn:asm (ix+5) st asms +asm ix st (MovqAX _ (RC rb i8) r:asms) | (0, bb) <- modRM rb, (0, b) <- modRM r = + let modB = 0x1 `shiftL` 6 .|. b `shiftL` 3 .|. bb + isn = 0x66:0x0f:0xd6:modB:le i8 + in isn:asm (ix+5) st asms +asm ix st (MovqAX _ (RC rb@R12 i8) r:asms) = + let (eb, bb) = modRM rb + (e, b) = modRM r + modB = 0x1 `shiftL` 6 .|. b `shiftL` 3 .|. 0x4 + pre = 0x48 .|. e `shiftL` 2 .|. eb + sib = 0x4 `shiftL` 3 .|. bb + isn = 0x66:pre:0x0f:0xd6:modB:sib:le i8 + in isn:asm (ix+7) st asms +asm ix st (MovqAX _ (RC rb i8) r:asms) = + let (eb, bb) = modRM rb + (e, b) = modRM r + modB = 0x1 `shiftL` 6 .|. b `shiftL` 3 .|. bb + pre = 0x48 .|. e `shiftL` 2 .|. eb + isn = 0x66:pre:0x0f:0xd6:modB:le i8 + in isn:asm (ix+6) st asms +asm ix st (MovqAX _ (RSD rb s ri d) r:asms) | (0, b) <- modRM r, (0, bi) <- modRM ri, (0, bb) <- modRM rb = + let modB = 0x1 `shiftL` 6 .|. b `shiftL` 3 .|. 0x4 + sib = encS s `shiftL` 6 .|. bi `shiftL` 3 .|. bb + instr = 0x66:0x0f:0xd6:modB:sib:le d + in instr:asm (ix+6) st asms +asm ix st (MovqAX _ (RSD rb s ri d) r:asms) = + let (e, b) = modRM r; (eb, bb) = modRM rb; (ei, bi) = modRM ri + modB = 0x1 `shiftL` 6 .|. b `shiftL` 3 .|. 0x4 + rex = 0x48 .|. e `shiftL` 2 .|. ei `shiftL` 1 .|. eb + sib = encS s `shiftL` 6 .|. bi `shiftL` 3 .|. bb + instr = 0x66:rex:0x0f:0x7e:modB:sib:le d + in instr:asm (ix+7) st asms +asm ix st (MovqXA l r (RS R13 s ri):asms) = asm ix st (MovqXA l r (RSD R13 s ri 0):asms) +asm ix st (MovqXA _ r (RS rb s ri):asms) = + let (e, b) = modRM r; (eb, bb) = modRM rb; (ei, bi) = modRM ri + modB = b `shiftL` 3 .|. 4 + rex = 0x48 .|. e `shiftL` 2 .|. ei `shiftL` 1 .|. eb + sib = encS s `shiftL` 6 .|. bi `shiftL` 3 .|. bb + instr = [0x66,rex,0x0f,0x6e,modB,sib] + in instr:asm (ix+6) st asms +asm ix st (MovqXA _ r (RSD rb s ri d):asms) = + let (e, b) = modRM r; (eb, bb) = modRM rb; (ei, bi) = modRM ri + modB = 1 `shiftL` 6 .|. b `shiftL` 3 .|. 4 + rex = 0x48 .|. e `shiftL` 2 .|. ei `shiftL` 1 .|. eb + sib = encS s `shiftL` 6 .|. bi `shiftL` 3 .|. bb + instr = 0x66:rex:0x0f:0x6e:modB:sib:le d + in instr:asm (ix+7) st asms +asm ix st (Movapd _ r0 r1:asms) | fits r0 && fits r1 = + rrNoPre [0x66,0x0f,0x28] r1 r0:asm (ix+4) st asms + | otherwise = + extSse 0x66 0x28 r1 r0:asm (ix+5) st asms +asm ix st (IAddRR _ r0 r1:asms) = + mkRR [0x01] r0 r1:asm (ix+3) st asms +asm ix st (And _ r0 r1:asms) = + mkRR [0x21] r0 r1:asm (ix+3) st asms +asm ix st (ISubRR _ r0 r1:asms) = + mkRR [0x29] r0 r1:asm (ix+3) st asms +asm ix st (IDiv _ r:asms) = + let (e, b) = modRM r + modB = 3 `shiftL` 6 .|. 7 `shiftL` 3 .|. b + pre = 0x48 .|. e + isn = [pre,0xf7,modB] + in isn:asm (ix+3) st asms +asm ix st (Addsd _ r0 r1:asms) | fits r0 && fits r1 = + rrNoPre [0xf2,0x0f,0x58] r1 r0:asm (ix+4) st asms + | otherwise = + extSse 0xf2 0x58 r1 r0:asm (ix+5) st asms +asm ix st (Mulsd _ r0 r1:asms) | fits r0 && fits r1 = + rrNoPre [0xf2,0x0f,0x59] r1 r0:asm (ix+4) st asms + | otherwise = + extSse 0xf2 0x59 r1 r0:asm (ix+5) st asms +asm ix st (Divsd _ r0 r1:asms) | fits r0 && fits r1 = + rrNoPre [0xf2,0x0f,0x5e] r1 r0:asm (ix+4) st asms + | otherwise = + extSse 0xf2 0x5e r1 r0:asm (ix+5) st asms +asm ix st (Vsubsd _ r0 r1 r2:asms) | fits r2 = + mkVex 0x5c F2 r0 r1 r2:asm (ix+4) st asms + | otherwise = + mkVex3 0x5c F2 F r0 r1 r2:asm (ix+5) st asms +asm ix st (Vaddsd _ r0 r1 r2:asms) | fits r2 = + mkVex 0x58 F2 r0 r1 r2:asm (ix+4) st asms + | otherwise = + mkVex3 0x58 F2 F r0 r1 r2:asm (ix+5) st asms +asm ix st (Vdivsd _ r0 r1 r2:asms) | fits r2 = + mkVex 0x5e F2 r0 r1 r2:asm (ix+4) st asms + | otherwise = + mkVex3 0x5e F2 F r0 r1 r2:asm (ix+5) st asms +asm ix st (Vmulsd _ r0 r1 r2:asms) | fits r2 = + mkVex 0x59 F2 r0 r1 r2:asm (ix+4) st asms + | otherwise = + mkVex3 0x59 F2 F r0 r1 r2:asm (ix+5) st asms +asm ix st (Vmaxsd _ r0 r1 r2:asms) | fits r2 = + mkVex 0x5f F2 r0 r1 r2:asm (ix+4) st asms + | otherwise = + mkVex3 0x5f F2 F r0 r1 r2:asm (ix+5) st asms +asm ix st (VaddsdA _ r0 r1 a:asms) = + mkVexA 0x58 F2 F r0 r1 a:asm (ix+7) st asms +asm ix st (VmaxsdA _ r0 r1 a:asms) = + mkVexA 0x5f F2 F r0 r1 a:asm (ix+7) st asms +asm ix st (Vcmppd _ r0 r1 r2 p:asms) | fits r2 = + (mkVex 0xc2 S6 r0 r1 r2 ++ le (imm8 p)):asm (ix+5) st asms + | otherwise = + (mkVex3 0xc2 S6 F r0 r1 r2 ++ le (imm8 p)):asm (ix+6) st asms +asm ix st (Vfmadd231sd _ r0 r1 r2:asms) = + mkVex3 0xb9 S6 F38 r0 r1 r2:asm (ix+5) st asms +asm ix st (Vfmnadd231sd _ r0 r1 r2:asms) = + mkVex3 0xbd S6 F38 r0 r1 r2:asm (ix+5) st asms +asm ix st (Vfmadd213sd _ r0 r1 r2:asms) = + mkVex3 0xa9 S6 F38 r0 r1 r2:asm (ix+5) st asms +asm ix st (Vfmsub132sd _ r0 r1 r2:asms) = + mkVex3 0x9b S6 F38 r0 r1 r2:asm (ix+5) st asms +asm ix st (Vfmsub213sd _ r0 r1 r2:asms) = + mkVex3 0xab S6 F38 r0 r1 r2:asm (ix+5) st asms +asm ix st (Vfmsub231sd _ r0 r1 r2:asms) = + mkVex3 0xbb S6 F38 r0 r1 r2:asm (ix+5) st asms +asm ix st (Vfmadd231sdA _ r0 r1 a:asms) = + mkVexA 0xb9 S6 F38 r0 r1 a:asm (ix+7) st asms +asm ix st (Roundsd _ r0 r1 i:asms) | fits r0 && fits r1 = + (rrNoPre [0x66,0x0f,0x3a,0x0b] r1 r0++le (roundMode i)):asm (ix+6) st asms +asm ix st (Roundsd _ r0 r1 i:asms) = + (0x66:mkAR [0xf,0x3a,0xb] 0 r1 r0++le (roundMode i)):asm (ix+7) st asms +asm ix st (Cvttsd2si _ r0 r1:asms) = + (0xf2:mkRR [0x0f,0x2c] r1 r0):asm (ix+5) st asms +asm ix st (Cvtsi2sd _ fr r:asms) = + (0xf2:mkRR [0x0f,0x2a] r fr):asm (ix+5) st asms +asm ix st (Sqrtsd _ r0 r1:asms) | fits r0 && fits r1 = + rrNoPre [0xf2,0x0f,0x51] r1 r0:asm (ix+4) st asms + | otherwise = + extSse 0xf2 0x51 r1 r0:asm (ix+5) st asms +asm ix st (CmpRR _ r0 r1:asms) = + mkRR [0x39] r0 r1:asm (ix+3) st asms +asm ix st (MovqXR _ fr r:asms) = + (0x66:mkRR [0x0f,0x6e] r fr):asm (ix+5) st asms +asm ix st (MovqRX _ r fr:asms) = + (0x66:mkRR [0x0f,0x7e] r fr):asm (ix+5) st asms +asm ix st (IMulRR _ r0 r1:asms) = + -- flip r0,r1 as instr. uses them differently from sub, etc. + mkRR [0x0f, 0xaf] r1 r0:asm (ix+4) st asms +asm ix st (IMulRA _ r (RSD rb s ri d):asms) = + let (e, b) = modRM r + (eb, bb) = modRM rb + (ei, bi) = modRM ri + pre = 0x48 .|. e `shiftL` 2 .|. ei `shiftL` 1 .|. eb + modB = 0x1 `shiftL` 6 .|. b `shiftL` 3 .|. 0x4 + sib = encS s `shiftL` 6 .|. bi `shiftL` 3 .|. bb + in (pre:0x0f:0xaf:modB:sib:le d):asm (ix+6) st asms +asm ix st (XorRR _ r0 r1:asms) = + mkRR [0x31] r0 r1:asm (ix+3) st asms +asm ix st (TestI _ r i:asms) = + let (e, b) = modRM r + prefix = 0x48 .|. e + modB = 0x3 `shiftL` 6 .|. b + in (prefix:0xf7:modB:le i):asm (ix+7) st asms +asm ix st (CmpRI _ r i:asms) | Just i8 <- mi64i8 (fromIntegral i) = + let (e, b) = modRM r + prefix = 0x48 .|. e + modRMB = (0x3 `shiftL` 6) .|. (0o7 `shiftL` 3) .|. b + in (prefix:0x83:modRMB:le i8):asm (ix+4) st asms +asm ix st (CmpRI _ r i32:asms) = + let (e, b) = modRM r + prefix = 0x48 .|. e + modRMB = (0x3 `shiftL` 6) .|. (0o7 `shiftL` 3) .|. b + in (prefix:0x81:modRMB:le i32):asm (ix+7) st asms +asm ix st (IAddRI _ r i:asms) | Just i8 <- mi64i8 i = + let (e, b) = modRM r + prefix = 0x48 .|. e + modRMB = (0x3 `shiftL` 6) .|. b + in (prefix:0x83:modRMB:le i8):asm (ix+4) st asms +asm ix st (IAddRI _ r i:asms) | Just i32 <- mi64i32 i = + let (e, b) = modRM r + prefix = 0x48 .|. e + modRMB = (0x3 `shiftL` 6) .|. b + in (prefix:0x81:modRMB:le i32):asm (ix+7) st asms +asm ix st (ISubRI _ r i:asms) | Just i8 <- mi64i8 i = + let (e, b) = modRM r + prefix = 0x48 .|. e + modRMB = (0x3 `shiftL` 6) .|. (0x5 `shiftL` 3) .|. b + in (prefix:0x83:modRMB:le i8):asm (ix+4) st asms +asm ix st (ISubRI _ r i:asms) | Just i32 <- mi64i32 i = + let (e, b) = modRM r + prefix = 0x48 .|. e + modRMB = (0x3 `shiftL` 6) .|. (0x5 `shiftL` 3) .|. b + in (prefix:0x81:modRMB:le i32):asm (ix+7) st asms + | otherwise = error "Not implemented yet: handling 64-bit immediates" +-- TODO: r32<-i32 like nasm does (note r32<-i32 (zero-extended) vs. +-- sign-extended +-- https://stackoverflow.com/questions/40315803/difference-between-movq-and-movabsq-in-x86-64 +asm ix st (MovRI _ r i:asms) | Just i32 <- mi64i32 i, i >= 0 && fits r = + let (_, b) = modRM r + opc = 0xb8 .|. b + in (opc:cd i32):asm (ix+5) st asms + -- TODO: 0xc7 for case i<0 +asm ix st (MovRI _ r i:asms) = + let (e, b) = modRM r + pre = (0x48 .|. e:) . (0xB8 .|. b:) + in pre (le i):asm (ix+10) st asms +asm ix st (MovRL x r l:asms) = + let p=arr l st + in asm ix st (MovRI x r (fromIntegral$pI p):asms) +asm ix st (Ret{}:asms) = + [0xc3]:asm (ix+1) st asms +asm ix st (RetL{}:asms) = + [0xc3]:asm (ix+1) st asms +asm ix st (Je _ l:asms) = + let lIx = get l st + instr = let offs = lIx-ix-6 in 0x0f:0x84:cd (fromIntegral offs :: Int32) + in instr:asm (ix+6) st asms +asm ix st (Jne _ l:asms) = + let lIx = get l st + instr = let offs = lIx-ix-6 in 0x0f:0x85:cd (fromIntegral offs :: Int32) + in instr:asm (ix+6) st asms +asm ix st (Jg _ l:asms) = + let lIx = get l st + instr = let offs = lIx-ix-6 in 0x0f:0x8f:cd (fromIntegral offs :: Int32) + in instr:asm (ix+6) st asms +asm ix st (Jge _ l:asms) = + let lIx = get l st + instr = let offs = lIx-ix-6 in 0x0f:0x8d:cd (fromIntegral offs :: Int32) + in instr:asm (ix+6) st asms +asm ix st (Jl _ l:asms) = + let lIx = get l st + instr = let offs = lIx-ix-6 in 0x0f:0x8c:cd (fromIntegral offs :: Int32) + in instr:asm (ix+6) st asms +asm ix st (Jle _ l:asms) = + let lIx = get l st + instr = let offs = lIx-ix-6 in 0x0f:0x8e:cd (fromIntegral offs :: Int32) + in instr:asm (ix+6) st asms +asm ix st (J _ l:asms) = + let lIx = get l st + instr = let offs = lIx-ix-5 in 0xe9:cd (fromIntegral offs :: Int32) + in instr:asm (ix+5) st asms +asm ix st (C _ l:asms) = + let lIx = get l st + instr = let offs = lIx-ix-5 in 0xe8:cd (fromIntegral offs :: Int32) + in instr:asm (ix+5) st asms +asm ix st (Fmulp{}:asms) = + [0xde,0xc9]:asm (ix+2) st asms +asm ix st (F2xm1{}:asms) = + [0xd9,0xf0]:asm (ix+2) st asms +asm ix st (Fldl2e{}:asms) = + [0xd9,0xea]:asm (ix+2) st asms +asm ix st (Fldln2{}:asms) = + [0xd9,0xed]:asm (ix+2) st asms +asm ix st (Fld1{}:asms) = + [0xd9,0xe8]:asm (ix+2) st asms +asm ix st (Fsin{}:asms) = + [0xd9,0xfe]:asm (ix+2) st asms +asm ix st (Fcos{}:asms) = + [0xd9,0xff]:asm (ix+2) st asms +asm ix st (FldS _ (ST i):asms) = + let isn = [0xd9, 0xc0+fromIntegral i] in isn:asm (ix+2) st asms +asm ix st (Fprem{}:asms) = + [0xd9,0xf8]:asm (ix+2) st asms +asm ix st (Faddp{}:asms) = + [0xde,0xc1]:asm (ix+2) st asms +asm ix st (Fscale{}:asms) = + [0xd9,0xfd]:asm (ix+2) st asms +asm ix st (Fninit{}:asms) = + [0xdb,0xe3]:asm (ix+2) st asms +asm ix st (Fxch _ (ST i):asms) = + let isn = [0xd9, 0xc9+fromIntegral i] in isn:asm (ix+2) st asms +asm ix st (Fyl2x{}:asms) = + [0xd9,0xf1]:asm (ix+2) st asms +asm ix st (Fld _ (RC r@Rsp i8):asms) = + let (_, b) = modRM r + modB = 0x1 `shiftL` 6 .|. 0x4 + sib = b `shiftL` 3 .|. b + instr = 0xdd:modB:sib:le i8 + in instr:asm (ix+4) st asms +asm ix st (Fstp _ (RC r@Rsp i8):asms) = + let (_, b) = modRM r + modB = 0x1 `shiftL` 6 .|. 0x3 `shiftL` 3 .|. 0x4 + sib = b `shiftL` 3 .|. b + instr = 0xdd:modB:sib:le i8 + in instr:asm (ix+4) st asms +asm ix st (Sal _ r i:asms) = + let (e, b) = modRM r + modRMB = (0x3 `shiftL` 6) .|. (0x4 `shiftL` 3) .|. b + pre = 0x48 .|. e + instr = pre:0xc1:modRMB:le i + in instr:asm (ix+4) st asms +asm ix st (Sar _ r i:asms) = + let (e, b) = modRM r + modRMB = (0x3 `shiftL` 6) .|. (0x7 `shiftL` 3) .|. b + pre = 0x48 .|. e + instr = pre:0xc1:modRMB:le i + in instr:asm (ix+4) st asms +asm ix st (MovAI32 l (R R13) i32:asms) = asm ix st (MovAI32 l (RC R13 0) i32:asms) +asm ix st (MovAI32 l (R Rbp) i32:asms) = asm ix st (MovAI32 l (RC Rbp 0) i32:asms) +asm ix st (MovAI32 _ (R Rsp) i32:asms) = + let (0, b) = modRM Rsp + modB = 0x4 + sib = b `shiftL` 3 .|. b + instr = 0x48:0xc7:modB:sib:le i32 + in instr:asm (ix+8) st asms +asm ix st (MovAI32 _ (R R12) i32:asms) = + let (e, b) = modRM R12 + modB = 0x4 + sib = 0x4 `shiftL` 3 .|. b + pre = 0x48 .|. e + isn = pre:0xc7:modB:sib:le i32 + in isn:asm (ix+8) st asms +asm ix st (MovAI32 _ (R r) i32:asms) = + let (e, b) = modRM r + modRMB = b + pre = 0x48 .|. e + instr = pre:0xc7:modRMB:le i32 + in instr:asm (ix+7) st asms +asm ix st (MovAI32 _ (RC r i8) i32:asms) = + let (e, b) = modRM r + modB = 0x1 `shiftL` 6 .|. b + pre = 0x48 .|. e + isn = pre:0xc7:modB:le i8 ++ le i32 + in isn:asm (ix+8) st asms +asm ix st (MovAR _ (RC Rsp i8) r:asms) = + let (e, b) = modRM r + (0, bi) = modRM Rsp + pre = 0x48 .|. e `shiftL` 2 + modB = 0x1 `shiftL` 6 .|. b `shiftL` 3 .|. 0x4 + sib = bi `shiftL` 3 .|. bi + instr = pre:0x89:modB:sib:le i8 + in instr:asm (ix+5) st asms +asm ix st (MovAR _ (RC32 Rsp i32) r:asms) = + let (e, b) = modRM r + (0, bi) = modRM Rsp + pre = 0x48 .|. e `shiftL` 2 + modB = 0x2 `shiftL` 6 .|. b `shiftL` 3 .|. 0x4 + sib = bi `shiftL` 3 .|. bi + instr = pre:0x89:modB:sib:le i32 + in instr:asm (ix+8) st asms +asm ix st (MovAR _ (RC R12 i8) r:asms) = + let (e, b) = modRM r + (ei, bi) = modRM R12 + pre = 0x48 .|. e `shiftL` 2 .|. ei + modB = 0x1 `shiftL` 6 .|. b `shiftL` 3 .|. 0x4 + sib = bi `shiftL` 3 .|. bi + instr = pre:0x89:modB:sib:le i8 + in instr:asm (ix+5) st asms +asm ix st (MovAR _ (RC ar i8) r:asms) = + (mkAR [0x89] 1 ar r++le i8):asm (ix+4) st asms +asm ix st (MovAR _ (RC32 ar i32) r:asms) = + (mkAR [0x89] 2 ar r++le i32):asm (ix+7) st asms +asm ix st (MovRA l r (RS b@Rbp s i):asms) = asm ix st (MovRA l r (RSD b s i 0):asms) +asm ix st (MovRA l r (RS b@R13 s i):asms) = asm ix st (MovRA l r (RSD b s i 0):asms) +asm ix st (MovRA _ r (RS b s i):asms) = + let (e0, b0) = modRM r + (eb, bb) = modRM b + (ei, bi) = modRM i + pre = 0x48 .|. e0 `shiftL` 2 .|. ei `shiftL` 1 .|. eb + modB = b0 `shiftL` 3 .|. 4 + sib = encS s `shiftL` 6 .|. bi `shiftL` 3 .|. bb + instr = [pre,0x8b,modB,sib] + in instr:asm (ix+4) st asms +asm ix st (MovAR _ (RSD b s i i8) r:asms) = + let (eb, bb) = modRM b + (ei, bi) = modRM i + (e0, b0) = modRM r + pre = 0x48 .|. e0 `shiftL` 2 .|. ei `shiftL` 1 .|. eb + modRMB = 1 `shiftL` 6 .|. b0 `shiftL` 3 .|. 4 + sib = encS s `shiftL` 6 .|. bi `shiftL` 3 .|. bb + instr = pre:0x89:modRMB:sib:le i8 + in instr:asm (ix+5) st asms +asm ix st (MovRA _ r (RSD b s i i8):asms) = + let (eb, bb) = modRM b + (ei, bi) = modRM i + (e0, b0) = modRM r + pre = 0x48 .|. e0 `shiftL` 2 .|. ei `shiftL` 1 .|. eb + modRMB = 1 `shiftL` 6 .|. b0 `shiftL` 3 .|. 4 + sib = encS s `shiftL` 6 .|. bi `shiftL` 3 .|. bb + instr = pre:0x8b:modRMB:sib:le i8 + in instr:asm (ix+5) st asms +asm ix st (MovAR l (R Rbp) r:asms) = asm ix st (MovAR l (RC Rbp 0) r:asms) +asm ix st (MovAR l (R R13) r:asms) = asm ix st (MovAR l (RC R13 0) r:asms) +asm ix st (MovAR _ (R ar@Rsp) r:asms) = + let (0, bi) = modRM ar + (e0, b0) = modRM r + pre = 0x48 .|. e0 `shiftL` 2 + modRMB = b0 `shiftL` 3 .|. 4; sib = bi `shiftL` 3 .|. bi + isn = [pre,0x89,modRMB,sib] + in isn:asm (ix+4) st asms +asm ix st (MovRA _ r (R ar@Rsp):asms) = + let (0, bi) = modRM ar + (e0, b0) = modRM r + pre = 0x48 .|. e0 `shiftL` 2 + modRMB = b0 `shiftL` 3 .|. 4; sib = bi `shiftL` 3 .|. bi + isn = [pre,0x8b,modRMB,sib] + in isn:asm (ix+4) st asms +asm ix st (MovAR _ (R ar) r:asms) = + mkAR [0x89] 0 ar r:asm (ix+3) st asms +asm ix st (MovRA l r (R Rbp):asms) = asm ix st (MovRA l r (RC Rbp 0):asms) +asm ix st (MovRA l r (R R13):asms) = asm ix st (MovRA l r (RC R13 0):asms) +asm ix st (MovRA _ r (R ar):asms) = + mkAR [0x8b] 0 ar r:asm (ix+3) st asms +asm ix st (Cmovne _ r0 r1:asms) = + mkRR [0xf,0x45] r1 r0:asm (ix+4) st asms +asm ix st (Cmovnle _ r0 r1:asms) = + mkRR [0xf,0x4f] r1 r0:asm (ix+4) st asms +asm ix st (Cmovnl _ r0 r1:asms) = + mkRR [0xf,0x4d] r1 r0:asm (ix+4) st asms +asm ix st (Cmovle _ r0 r1:asms) = + mkRR [0xf,0x4e] r1 r0:asm (ix+4) st asms +asm ix st (Cmovl _ r0 r1:asms) = + mkRR [0xf,0x4c] r1 r0:asm (ix+4) st asms +asm ix st (Cmove _ r0 r1:asms) = + mkRR [0xf,0x44] r1 r0:asm (ix+4) st asms +asm ix st (MovAR _ (RS rb s ri) r:asms) = + let (eb, bb) = modRM rb + (ei, bi) = modRM ri + (e, b) = modRM r + modRMB = b `shiftL` 3 .|. 4 + sib = encS s `shiftL` 6 .|. bi `shiftL` 3 .|. bb + pre = 0x48 .|. e `shiftL` 2 .|. ei `shiftL` 1 .|. eb + in [pre,0x89,modRMB,sib]:asm (ix+4) st asms +asm ix st (Not _ r:asms) = + let (e, b) = modRM r + pre = 0x48 .|. e + modB = 3 `shiftL` 6 .|. 2 `shiftL` 3 .|. b + in [pre,0xf7,modB]:asm (ix+3) st asms +asm ix st (Neg _ r:asms) = + let (e, b) = modRM r + pre = 0x48 .|. e + modB = 3 `shiftL` 6 .|. 3 `shiftL` 3 .|. b + in [pre,0xf7,modB]:asm(ix+3) st asms +asm ix st (Rdrand _ r:asms) = + let (e, b) = modRM r + pre = 0x48 .|. e + modB = 3 `shiftL` 6 .|. 6 `shiftL` 3 .|. b + in [pre,0xf,0xc7,modB]:asm(ix+4) st asms +asm ix st@(self, _, Just (m, _, _, _), _) (Call _ Malloc:asms) | Just i32 <- mi32 (m-(self+ix+5)) = + let instr = 0xe8:le i32 + in instr:asm (ix+5) st asms +asm ix st@(self, _, Just (_, f, _, _), _) (Call _ Free:asms) | Just i32 <- mi32 (f-(self+ix+5)) = + let instr = 0xe8:le i32 + in instr:asm (ix+5) st asms +asm ix st@(self, _, Just (_, _, d, _), _) (Call _ DR:asms) | Just i32 <- mi32 (d-(self+ix+5)) = + let isn=0xe8:le i32 + in isn:asm (ix+5) st asms +asm _ (_, _, Nothing, _) (Call{}:_) = error "Internal error? no dynlibs" +asm _ _ (instr:_) = error (show instr) + +encS :: Scale -> Word8 +encS One = 0 +encS Two = 1 +encS Four = 2 +encS Eight = 3 + +get :: Label -> (Int, IM.IntMap (Ptr Word64), Maybe CCtx, M.Map Label Int) -> Int +get l = + M.findWithDefault (error "Internal error: label not found") l . fth where fth (_,_,_,z) = z + +arr :: Int -> (Int, IM.IntMap (Ptr Word64), Maybe CCtx, M.Map Label Int) -> Ptr Word64 +arr n = IM.findWithDefault (error "Internal error: array not found during assembler stage") n . snd4 where snd4 (_,y,_,_) = y + +mi64i8 :: Int64 -> Maybe Int8 +mi64i8 i | i > fromIntegral (maxBound :: Int8) || i < fromIntegral (minBound :: Int8) = Nothing + | otherwise = Just $ fromIntegral i + +mi32 :: Int -> Maybe Int32 +mi32 i | i > fromIntegral (maxBound :: Int32) || i < fromIntegral (minBound :: Int32) = Nothing + | otherwise = Just $ fromIntegral i + +mi64i32 :: Int64 -> Maybe Int32 +mi64i32 i | i > fromIntegral (maxBound :: Int32) || i < fromIntegral (minBound :: Int32) = Nothing + | otherwise = Just $ fromIntegral i + +class RMB a where + -- extra is 1 bit, ModR/M is 3 bits; I store them as bytes for ease of + -- manipulation + modRM :: a -> (Word8, Word8) + +instance RMB X86Reg where + modRM Rax = (0, 0o0) + modRM Rcx = (0, 0o1) + modRM Rdx = (0, 0o2) + modRM Rbx = (0, 0o3) + modRM Rsp = (0, 0o4) + modRM Rbp = (0, 0o5) + modRM Rsi = (0, 0o6) + modRM Rdi = (0, 0o7) + modRM R8 = (1, 0o0) + modRM R9 = (1, 0o1) + modRM R10 = (1, 0o2) + modRM R11 = (1, 0o3) + modRM R12 = (1, 0o4) + modRM R13 = (1, 0o5) + modRM R14 = (1, 0o6) + modRM R15 = (1, 0o7) + +instance RMB FX86Reg where + modRM XMM0 = (0, 0o0) + modRM XMM1 = (0, 0o1) + modRM XMM2 = (0, 0o2) + modRM XMM3 = (0, 0o3) + modRM XMM4 = (0, 0o4) + modRM XMM5 = (0, 0o5) + modRM XMM6 = (0, 0o6) + modRM XMM7 = (0, 0o7) + modRM XMM8 = (1, 0o0) + modRM XMM9 = (1, 0o1) + modRM XMM10 = (1, 0o2) + modRM XMM11 = (1, 0o3) + modRM XMM12 = (1, 0o4) + modRM XMM13 = (1, 0o5) + modRM XMM14 = (1, 0o6) + modRM XMM15 = (1, 0o7) + +cd :: (Integral a) => a -> [Word8] +cd x = le (fromIntegral x :: Word32) + +-- little endian +le :: (Storable a, Integral a, Bits a) => a -> [Word8] +le x = fromIntegral <$> zipWith (\m e -> (x .&. m) `rotateR` e) masks ee + where ee = [0,8..(8*(sizeOf x-1))] + masks = iterate (*0x100) 0xff + +fst4 :: (a, b, c, d) -> a +fst4 (x, _, _, _) = x diff --git a/src/Asm/X86/CF.hs b/src/Asm/X86/CF.hs new file mode 100644 --- /dev/null +++ b/src/Asm/X86/CF.hs @@ -0,0 +1,446 @@ +-- | From the [Kempe compiler](http://vmchale.com/original/compiler.pdf) with +-- improvements. +module Asm.X86.CF ( mkControlFlow + , expand, udd + , uses, defs + , defsF + ) where + +import Asm.BB +import Asm.CF +import Asm.X86 as X86 +import CF +-- seems to pretty clearly be faster +import Class.E as E +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 isns = runFreshM (broadcasts isns *> addControlFlow isns) + +expand :: (E reg, E freg) => BB X86 reg freg () Liveness -> [X86 reg freg 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) + ao=ins s + aif=usesF a <> (aof IS.\\ defsF a) + aof=fins s + in a $> Liveness ai ao aif aof + lS = let ao=out li + aof=fout li + in asm $> Liveness (uses asm `IS.union` (ao `IS.difference` defs asm)) ao (usesF asm `IS.union` (aof `IS.difference` defsF asm)) aof + (iasms, asm) = (init asms, last asms) +expand _ = [] + +{-# 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 [] = pure [] +addControlFlow (BB asms _:bbs) = do + { i <- case asms of + (Label _ l:_) -> lookupLabel l + _ -> getFresh + ; (f, bbs') <- next bbs + ; acc <- case last asms of + J _ lϵ -> do {l_i <- lookupLabel lϵ; pure [l_i]} + Je _ lϵ -> do {l_i <- lookupLabel lϵ; pure (f [l_i])} + Jle _ lϵ -> do {l_i <- lookupLabel lϵ; pure (f [l_i])} + Jl _ lϵ -> do {l_i <- lookupLabel lϵ; pure (f [l_i])} + Jg _ lϵ -> do {l_i <- lookupLabel lϵ; pure (f [l_i])} + Jge _ lϵ -> do {l_i <- lookupLabel lϵ; pure (f [l_i])} + Jne _ lϵ -> do {l_i <- lookupLabel lϵ; pure (f [l_i])} + C _ lϵ -> do {l_i <- lookupLabel lϵ; pure [l_i]} + RetL _ lϵ -> lC lϵ + _ -> pure (f []) + ; pure (BB asms (ControlAnn i acc (ubb asms)) : bbs') + } + +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 = 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 = foldr (\p n -> usesF p `IS.union` (n IS.\\ defsF p)) IS.empty +dBBF = foldMap defsF + +uA :: E reg => Addr reg -> IS.IntSet +uA (R r) = singleton r +uA (RC32 r _) = singleton r +uA (RC r _) = singleton r +uA (RS b _ i) = fromList [b,i] +uA (RSD b _ i _) = fromList [b,i] + +usesF :: E freg => X86 reg freg ann -> IS.IntSet +usesF (Movapd _ _ r) = singleton r +usesF (Vmulsd _ _ r0 r1) = fromList [r0, r1] +usesF (Vaddsd _ _ r0 r1) = fromList [r0, r1] +usesF (Vsubsd _ _ r0 r1) = fromList [r0, r1] +usesF (Vdivsd _ _ r0 r1) = fromList [r0, r1] +usesF (VaddsdA _ _ r _) = singleton r +usesF (Mulsd _ r0 r1) = fromList [r0, r1] +usesF (Divsd _ r0 r1) = fromList [r0, r1] +usesF (Addsd _ r0 r1) = fromList [r0, r1] +usesF (Subsd _ r0 r1) = fromList [r0, r1] +usesF (Vfmadd231sd _ r0 r1 r2) = fromList [r0, r1, r2] +usesF (Vfmnadd231sd _ r0 r1 r2) = fromList [r0, r1, r2] +usesF (Vfmadd231sdA _ r0 r1 _) = fromList [r0, r1] +usesF (Sqrtsd _ _ r) = singleton r +usesF (Vmaxsd _ _ r0 r1) = fromList [r0, r1] +usesF (Vminsd _ _ r0 r1) = fromList [r0, r1] +usesF (VmaxsdA _ _ r _) = singleton r +usesF (Maxsd _ r0 r1) = fromList [r0, r1] +usesF (Minsd _ r0 r1) = fromList [r0, r1] +usesF (Roundsd _ _ r _) = singleton r +usesF (Cvttsd2si _ _ r) = singleton r +usesF (MovqAX _ _ x) = singleton x +usesF MovqXR{} = IS.empty +usesF IAddRR{} = IS.empty +usesF IAddRI{} = IS.empty +usesF ISubRR{} = IS.empty +usesF MovRI{} = IS.empty +usesF MovRR{} = IS.empty +usesF MovRL{} = IS.empty +usesF CmpRR{} = IS.empty +usesF CmpRI{} = IS.empty +usesF Cvtsi2sd{} = IS.empty +usesF MovRA{} = IS.empty +usesF MovAR{} = IS.empty +usesF Fldln2{} = IS.empty +usesF ISubRI{} = IS.empty +usesF IMulRR{} = IS.empty +usesF IMulRA{} = IS.empty +usesF Sal{} = IS.empty +usesF Sar{} = IS.empty +usesF Fscale{} = IS.empty +usesF Call{} = IS.empty +usesF Cmovnle{} = IS.empty +usesF Cmovnl{} = IS.empty +usesF Cmovne{} = IS.empty +usesF Cmove{} = IS.empty +usesF Cmovle{} = IS.empty +usesF Cmovl{} = IS.empty +usesF Fstp{} = IS.empty +usesF MovqXA{} = IS.empty +usesF Fyl2x{} = IS.empty +usesF Fld{} = IS.empty +usesF MovAI32{} = IS.empty +usesF Faddp{} = IS.empty +usesF F2xm1{} = IS.empty +usesF Fprem{} = IS.empty +usesF Fmulp{} = IS.empty +usesF FldS{} = IS.empty +usesF Fld1{} = IS.empty +usesF Fldl2e{} = IS.empty +usesF Fninit{} = IS.empty +usesF TestI{} = IS.empty +usesF (Vcmppd _ _ r0 r1 _) = fromList [r0, r1] +usesF (MovqRX _ _ xr) = singleton xr +usesF Fsin{} = IS.empty +usesF Fcos{} = IS.empty +usesF XorRR{} = IS.empty +usesF Fxch{} = IS.empty +usesF IDiv{} = IS.empty +usesF Test{} = IS.empty +usesF Push{} = IS.empty +usesF Pop{} = IS.empty +usesF Rdrand{} = IS.empty +usesF Neg{} = IS.empty +usesF J{} = IS.empty +usesF Je{} = IS.empty +usesF Label{} = IS.empty +usesF Jne{} = IS.empty +usesF Jge{} = IS.empty +usesF Jg{} = IS.empty +usesF Jl{} = IS.empty +usesF Jle{} = IS.empty +usesF C{} = IS.empty +usesF RetL{} = IS.empty +usesF Ret{} = fromList [FRet0, FRet1] + +uses :: E reg => X86 reg freg ann -> IS.IntSet +uses (MovRR _ _ r) = singleton r +uses MovRL{} = IS.empty +uses (And _ r0 r1) = fromList [r0, r1] +uses (IAddRR _ r0 r1) = fromList [r0, r1] +uses (IAddRI _ r _) = singleton r +uses (ISubRR _ r0 r1) = fromList [r0, r1] +uses (ISubRI _ r _) = singleton r +uses (IMulRR _ r0 r1) = fromList [r0, r1] +uses (IMulRA _ r a) = IS.insert (E.toInt r) $ uA a +uses (CmpRR _ r0 r1) = fromList [r0, r1] +uses MovRI{} = IS.empty +uses (CmpRI _ r _) = singleton r +uses (MovqXR _ _ r) = singleton r +uses (Cvtsi2sd _ _ r) = singleton r +uses (MovqXA _ _ a) = uA a +uses (MovqAX _ a _) = uA a +uses Fldl2e{} = IS.empty +uses Fldln2{} = IS.empty +uses (Fld _ a) = uA a +uses Fyl2x{} = IS.empty +uses F2xm1{} = IS.empty +uses Fmulp{} = IS.empty +uses (Fstp _ a) = uA a +uses (MovRA _ _ a) = uA a +uses (IDiv _ r) = IS.insert (E.toInt r) $ fromList [Quot, Rem] +uses (MovAR _ a r) = uA a <> singleton r +uses (Sal _ r _) = singleton r +uses (Sar _ r _) = singleton r +uses (Call _ Malloc) = fromList [CArg0] +uses (Call _ Free) = fromList [CArg0] +uses (Call _ DR) = IS.empty +uses (MovAI32 _ a _) = uA a +uses Fld1{} = IS.empty +uses FldS{} = IS.empty +uses Fprem{} = IS.empty +uses Faddp{} = IS.empty +uses Fsin{} = IS.empty +uses Fcos{} = IS.empty +uses Fscale{} = IS.empty +uses Fxch{} = IS.empty +uses (Not _ r) = singleton r +uses (Cmovnle _ _ r) = singleton r +uses (Cmovnl _ _ r) = singleton r +uses (Cmovne _ _ r) = singleton r +uses (Cmove _ _ r) = singleton r +uses (Cmovle _ _ r) = singleton r +uses (Cmovl _ _ r) = singleton r +uses Vmulsd{} = IS.empty +uses Vaddsd{} = IS.empty +uses (VaddsdA _ _ _ a) = uA a +uses Vdivsd{} = IS.empty +uses Vsubsd{} = IS.empty +uses Vmaxsd{} = IS.empty +uses Vminsd{} = IS.empty +uses (VmaxsdA _ _ _ a) = uA a +uses Addsd{} = IS.empty +uses Subsd{} = IS.empty +uses Roundsd{} = IS.empty +uses Mulsd{} = IS.empty +uses Divsd{} = IS.empty +uses Movapd{} = IS.empty +uses Vfmadd231sd{} = IS.empty +uses Vfmnadd231sd{} = IS.empty +uses (Vfmadd231sdA _ _ _ a) = uA a +uses Cvttsd2si{} = IS.empty +uses Sqrtsd{} = IS.empty +uses Rdrand{} = IS.empty +uses Fninit{} = IS.empty +uses (TestI _ r _) = singleton r +uses Vcmppd{} = IS.empty +uses MovqRX{} = IS.empty +uses (XorRR _ r0 r1) = fromList [r0, r1] +uses (Test _ r0 r1) = fromList [r0, r1] +uses (Push _ r) = singleton r +uses Pop{} = IS.empty +uses (Neg _ r) = singleton r +uses J{} = IS.empty +uses Je{} = IS.empty +uses Label{} = IS.empty +uses Jne{} = IS.empty +uses Jge{} = IS.empty +uses Jg{} = IS.empty +uses Jl{} = IS.empty +uses Jle{} = IS.empty +uses C{} = IS.empty +uses RetL{} = IS.empty +uses Ret{} = singleton CRet + +defsF :: E freg => X86 reg freg ann -> IS.IntSet +defsF (Movapd _ r _) = singleton r +defsF (Vmulsd _ r _ _) = singleton r +defsF (Vaddsd _ r _ _) = singleton r +defsF (VaddsdA _ r _ _) = singleton r +defsF (Vsubsd _ r _ _) = singleton r +defsF (Vdivsd _ r _ _) = singleton r +defsF (MovqXR _ r _) = singleton r +defsF (Addsd _ r _) = singleton r +defsF (Subsd _ r _) = singleton r +defsF (Divsd _ r _) = singleton r +defsF (Mulsd _ r _) = singleton r +defsF (MovqXA _ r _) = singleton r +defsF MovqAX{} = IS.empty +defsF (Sqrtsd _ r _) = singleton r +defsF (Vmaxsd _ r _ _) = singleton r +defsF (VmaxsdA _ r _ _) = singleton r +defsF (Vminsd _ r _ _) = singleton r +defsF (Minsd _ r _) = singleton r +defsF (Maxsd _ r _) = singleton r +defsF (Vfmadd231sd _ r _ _) = singleton r +defsF (Vfmnadd231sd _ r _ _) = singleton r +defsF (Vfmadd231sdA _ r _ _) = singleton r +defsF (Roundsd _ r _ _) = singleton r +defsF (Cvtsi2sd _ r _) = singleton r +defsF IAddRR{} = IS.empty +defsF IAddRI{} = IS.empty +defsF ISubRR{} = IS.empty +defsF ISubRI{} = IS.empty +defsF IMulRR{} = IS.empty +defsF IMulRA{} = IS.empty +defsF MovRR{} = IS.empty +defsF MovRL{} = IS.empty +defsF MovRA{} = IS.empty +defsF MovAR{} = IS.empty +defsF MovAI32{} = IS.empty +defsF MovRI{} = IS.empty +defsF Fld{} = IS.empty +defsF FldS{} = IS.empty +defsF Fldl2e{} = IS.empty +defsF Fldln2{} = IS.empty +defsF Fld1{} = IS.empty +defsF Fsin{} = IS.empty +defsF Fcos{} = IS.empty +defsF Fyl2x{} = IS.empty +defsF Fstp{} = IS.empty +defsF F2xm1{} = IS.empty +defsF Fmulp{} = IS.empty +defsF Fprem{} = IS.empty +defsF Faddp{} = IS.empty +defsF Fscale{} = IS.empty +defsF Fxch{} = IS.empty +defsF CmpRR{} = IS.empty +defsF CmpRI{} = IS.empty +defsF Sal{} = IS.empty +defsF Sar{} = IS.empty +defsF Cmovnle{} = IS.empty +defsF Cmovnl{} = IS.empty +defsF Cmovne{} = IS.empty +defsF Cmove{} = IS.empty +defsF Cmovle{} = IS.empty +defsF Cmovl{} = IS.empty +defsF (Call _ DR) = IS.singleton (X86.fToInt FRet0) +defsF Call{} = IS.empty +defsF Cvttsd2si{} = IS.empty +defsF Fninit{} = IS.empty +defsF TestI{} = IS.empty +defsF (Vcmppd _ r _ _ _) = singleton r +defsF MovqRX{} = IS.empty +defsF XorRR{} = IS.empty +defsF IDiv{} = IS.empty +defsF Test{} = IS.empty +defsF Pop{} = IS.empty +defsF Push{} = IS.empty +defsF Rdrand{} = IS.empty +defsF Neg{} = IS.empty +defsF J{} = IS.empty +defsF Je{} = IS.empty +defsF Label{} = IS.empty +defsF Jne{} = IS.empty +defsF Jge{} = IS.empty +defsF Jg{} = IS.empty +defsF Jl{} = IS.empty +defsF Jle{} = IS.empty +defsF C{} = IS.empty +defsF RetL{} = IS.empty +defsF Ret{} = IS.empty + +defs :: (E reg) => X86 reg freg ann -> IS.IntSet +defs (MovRR _ r _) = singleton r +defs (MovRL _ r _) = singleton r +defs MovqXR{} = IS.empty +defs MovqXA{} = IS.empty +defs MovqAX{} = IS.empty +defs (IAddRR _ r _) = singleton r +defs (And _ r _) = singleton r +defs (IAddRI _ r _) = singleton r +defs (ISubRR _ r _) = singleton r +defs (ISubRI _ r _) = singleton r +defs (IMulRR _ r _) = singleton r +defs (IMulRA _ r _) = singleton r +defs CmpRR{} = IS.empty +defs (MovRI _ r _) = singleton r +defs (Cvttsd2si _ r _) = singleton r +defs CmpRI{} = IS.empty +defs Fldl2e{} = IS.empty +defs Fldln2{} = IS.empty +defs Fyl2x{} = IS.empty +defs Fstp{} = IS.empty +defs Fsin{} = IS.empty +defs Fcos{} = IS.empty +defs Fld{} = IS.empty +defs F2xm1{} = IS.empty +defs Fmulp{} = IS.empty +defs (MovRA _ r _) = singleton r +defs IDiv{} = fromList [Quot, Rem] +defs MovAR{} = IS.empty +defs (Sal _ r _) = singleton r +defs (Sar _ r _) = singleton r +defs (Call _ Malloc) = IS.singleton (X86.toInt CRet) +defs (Call _ Free) = IS.empty +defs (Call _ DR) = IS.empty +defs MovAI32{} = IS.empty +defs Fld1{} = IS.empty +defs FldS{} = IS.empty +defs Fprem{} = IS.empty +defs Faddp{} = IS.empty +defs Fscale{} = IS.empty +defs Fxch{} = IS.empty +defs (Not _ r) = singleton r +defs (Cmovnle _ r _) = singleton r +defs (Cmovnl _ r _) = singleton r +defs (Cmovne _ r _) = singleton r +defs (Cmove _ r _) = singleton r +defs (Cmovl _ r _) = singleton r +defs (Cmovle _ r _) = singleton r +defs Vmulsd{} = IS.empty +defs Vdivsd{} = IS.empty +defs Vaddsd{} = IS.empty +defs Vsubsd{} = IS.empty +defs Vmaxsd{} = IS.empty +defs Vminsd{} = IS.empty +defs VmaxsdA{} = IS.empty +defs VaddsdA{} = IS.empty +defs Addsd{} = IS.empty +defs Subsd{} = IS.empty +defs Mulsd{} = IS.empty +defs Divsd{} = IS.empty +defs Movapd{} = IS.empty +defs Cvtsi2sd{} = IS.empty +defs Vfmadd231sd{} = IS.empty +defs Vfmadd231sdA{} = IS.empty +defs Vfmnadd231sd{} = IS.empty +defs Roundsd{} = IS.empty +defs Sqrtsd{} = IS.empty +defs (Rdrand _ r) = singleton r +defs Fninit{} = IS.empty +defs TestI{} = IS.empty +defs Vcmppd{} = IS.empty +defs (MovqRX _ r _) = singleton r +defs (XorRR _ r _) = singleton r +defs Test{} = IS.empty +defs Push{} = IS.empty +defs (Pop _ r) = singleton r +defs (Neg _ r) = singleton r +defs J{} = IS.empty +defs Je{} = IS.empty +defs Label{} = IS.empty +defs Jne{} = IS.empty +defs Jge{} = IS.empty +defs Jg{} = IS.empty +defs Jl{} = IS.empty +defs Jle{} = IS.empty +defs C{} = IS.empty +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 asms = do + nextAsms <- addControlFlow asms + case nextAsms of + [] -> pure (id, []) + (asm:_) -> pure ((node (caBB asm) :), nextAsms) + +-- | Construct map assigning labels to their node name. +broadcasts :: [BB X86 reg freg a ()] -> FreshM () +broadcasts [] = pure () +broadcasts ((BB asms@(asm:_) _):bbs@((BB (Label _ retL:_) _):_)) | C _ l <- last asms = do + { i <- fm retL; b3 i l + ; case asm of {Label _ lϵ -> void $ fm lϵ; _ -> pure ()} + ; broadcasts bbs + } +broadcasts ((BB (Label _ l:_) _):bbs) = fm l *> broadcasts bbs +broadcasts (_:bbs) = broadcasts bbs diff --git a/src/Asm/X86/Frame.hs b/src/Asm/X86/Frame.hs new file mode 100644 --- /dev/null +++ b/src/Asm/X86/Frame.hs @@ -0,0 +1,66 @@ +module Asm.X86.Frame ( frameC ) where + +import Asm.X86 +import CF +import Data.Copointed +import Data.Functor (void) +import qualified Data.IntSet as IS +import Data.Maybe (mapMaybe) + +frameC :: [X86 X86Reg FX86Reg Live] -> [X86 X86Reg FX86Reg ()] +frameC = concat . go IS.empty IS.empty + where go _ _ [] = [] + go s fs (isn:isns) = + let i = copoint isn + s' = s `IS.union` new i `IS.difference` done i + fs' = fs `IS.union` fnew i `IS.difference` fdone i + in case isn of + Call _ cf -> + let + cs = handleRax cf $ mapMaybe fromInt $ IS.toList s + xms = mx cf $ mapMaybe fInt $ IS.toList fs + scratch = odd(length cs+length xms) + save = (if scratch then (++[ISubRI () Rsp 8]) else id)$fmap (Push ()) cs + restore = (if scratch then (IAddRI () Rsp 8:) else id)$fmap (Pop ()) (reverse cs) + savex = concatMap puxmm xms + restorex = concatMap poxmm (reverse xms) + in (save ++ savex ++ void isn : restorex ++ restore) : go s' fs' isns + _ -> [void isn] : go s' fs' isns + handleRax Malloc = filter (/=Rax) + handleRax Free = id + handleRax DR = id + puxmm xr = [ISubRI () Rsp 8, MovqAX () (R Rsp) xr] + poxmm xr = [MovqXA () xr (R Rsp), IAddRI () Rsp 8] + mx Free = const [] + mx Malloc = id + mx DR = filter (/=XMM0) + +fromInt :: Int -> Maybe X86Reg +fromInt 1 = Just Rsi +fromInt 2 = Just Rdx +fromInt 3 = Just Rcx +fromInt 4 = Just R8 +fromInt 5 = Just R9 +fromInt 6 = Just Rax +fromInt (-1) = Just R10 +fromInt (-2) = Just R11 +fromInt _ = Nothing + +fInt :: Int -> Maybe FX86Reg +fInt 8 = Just XMM0 +fInt 9 = Just XMM1 +fInt 10 = Just XMM2 +fInt 11 = Just XMM3 +fInt 12 = Just XMM4 +fInt 13 = Just XMM5 +fInt 14 = Just XMM6 +fInt 15 = Just XMM7 +fInt (-5) = Just XMM8 +fInt (-6) = Just XMM9 +fInt (-7) = Just XMM10 +fInt (-8) = Just XMM11 +fInt (-9) = Just XMM12 +fInt (-10) = Just XMM13 +fInt (-11) = Just XMM14 +fInt (-12) = Just XMM15 +fInt _ = Nothing diff --git a/src/Asm/X86/Opt.hs b/src/Asm/X86/Opt.hs new file mode 100644 --- /dev/null +++ b/src/Asm/X86/Opt.hs @@ -0,0 +1,43 @@ +module Asm.X86.Opt ( optX86 ) where + +import Asm.L +import Asm.X86 hiding (toInt) +import Asm.X86.CF +import CF +import Class.E +import Data.Functor (void) +import qualified Data.IntSet as IS + +{-# SCC optAddr #-} +optAddr :: Addr reg -> Addr reg +optAddr (RC r 0) = R r +optAddr (RSD b s i 0) = RS b s i +optAddr a = a + +occ :: E reg => reg -> Addr reg -> Bool +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 = opt.mkLive + +opt :: (E reg, E freg, Eq reg, Eq freg) => [X86 reg freg Liveness] -> [X86 reg freg ()] +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 +opt (MovqXA _ xrϵ a:Vmaxsd l xr0 xr1 xr2:asms) | xr2 == xrϵ && (toInt xr2 `IS.notMember` fout l) = VmaxsdA () xr0 xr1 (optAddr a):opt asms +opt (MovqXA _ xrϵ a:Vaddsd l xr0 xr1 xr2:asms) | xr2 == xrϵ && (toInt xr2 `IS.notMember` fout l) = VaddsdA () xr0 xr1 (optAddr a):opt asms +opt (MovqXA _ xr0 a:Vaddsd _ xr1 xr2 xr3:asms) | xr0 == xr1 && xr0 == xr3 = VaddsdA () xr1 xr2 (optAddr a):opt asms +opt (MovqXA _ xr0 a:asm:Vaddsd _ xr1 xr2 xr3:asms) | xr0 == xr2 && (toInt xr0 `IS.notMember` defsF asm) = void asm:VaddsdA () xr1 xr3 (optAddr a):opt asms +opt ((MovqAX _ a r):asms) = MovqAX () (optAddr a) r:opt asms +opt ((MovqXA _ r a):asms) = MovqXA () r (optAddr a):opt asms +opt (isn@(MovRA _ r0 a0):MovAR _ a1 r1:asms) | r0 == r1 && not (occ r0 a0) && optAddr a0 == optAddr a1 = opt (isn:asms) +opt (isn@(MovRA _ r0 a0):MovRA _ r1 a1:asms) | r0 == r1 && not (occ r0 a0) && optAddr a0 == optAddr a1 = opt (isn:asms) +opt (isn@(MovAR _ a0 r0):MovRA _ r1 a1:asms) | optAddr a0 == optAddr a1 = opt (isn:MovRR undefined r1 r0:asms) +opt ((MovAR _ a r):asms) = MovAR () (optAddr a) r:opt asms +opt ((MovRA _ r a):asms) = MovRA () r (optAddr a):opt asms +opt ((MovRR _ r0 r1):asms) | r0 == r1 = opt asms +opt ((Movapd _ r0 r1):asms) | r0 == r1 = opt asms +opt (isn@(Movapd _ r0 r1):(Movapd _ r0' r1'):asms) | r0 == r1' && r1 == r0' = opt (isn:asms) +-- opt (Vmulsd _ xr0 xr1 xr2:Vaddsd _ xr0' xr1' xr2':asms) | xr0 == xr2 && xr0 == xr0' && xr0' == xr2' = Vfmadd213sd () xr0 xr1 xr1':opt asms +opt (asm:asms) = void asm : opt asms diff --git a/src/Asm/X86/P.hs b/src/Asm/X86/P.hs new file mode 100644 --- /dev/null +++ b/src/Asm/X86/P.hs @@ -0,0 +1,54 @@ +module Asm.X86.P ( gallocFrame, gallocOn ) where + +import Asm.Ar.P +import Asm.G +import Asm.LI +import Asm.X86 +import Asm.X86.Frame +import Asm.X86.Sp +import Data.Int (Int64) +import qualified Data.IntMap as IM +import qualified Data.Set as S + +-- TODO: don't bother re-analyzing if no Calls +gallocFrame :: Int -- ^ int supply for spilling + -> [X86 AbsReg FAbsReg ()] -> [X86 X86Reg FX86Reg ()] +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') + 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 clob asms = pre++asms++post++[Ret()] where + pre = save$Push () <$> clobs + post = restore$Pop () <$> reverse clobs + clobs = S.toList (clob `S.intersection` S.fromList (Rbp:[R12 .. Rbx])) + scratch=even(length clobs) && hasMa asms; save=if scratch then (++[ISubRI () Rsp 8]) else id; restore=if scratch then (IAddRI () Rsp 8:) else id + -- TODO: https://eli.thegreenplace.net/2011/09/06/stack-frame-layout-on-x86-64/ + -- 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 u = go u 16 pres True + where go uϵ offs pres' i isns = rmaps + where rmaps = case (regsM, fregsM) of + (Right regs, Right fregs) -> let saa = saI$8*fromIntegral offs; saaP = if i then init else (++[IAddRI () SP saa]).init.(ISubRI () SP saa:).(ISubRI () BP saa:) in (regs, fregs, saaP isns) + (Left s, Right fregs) -> + let (uϵ', offs', isns') = spill uϵ offs s isns + in go uϵ' offs' (IM.insert (-16) Rbp pres') False isns' + regsM = alloc aIsns ((if i then (++[Rbp]) else id) [Rcx .. Rax]) (IM.keysSet pres') pres' + fregsM = allocF aFIsns [XMM1 .. XMM15] (IM.keysSet preFs) preFs + (aIsns, aFIsns) = bundle isns + +saI :: Int64 -> Int64 +saI i | i`rem`16 == 0 = i | otherwise = i+8 + +pres :: IM.IntMap X86Reg +pres = IM.fromList [(0, Rdi), (1, Rsi), (2, Rdx), (3, Rcx), (4, R8), (5, R9), (6, Rax), (7, Rsp)] + +preFs :: IM.IntMap FX86Reg +preFs = IM.fromList [(8, XMM0), (9, XMM1), (10, XMM2), (11, XMM3), (12, XMM4), (13, XMM5), (14, XMM6), (15, XMM7)] diff --git a/src/Asm/X86/Sp.hs b/src/Asm/X86/Sp.hs new file mode 100644 --- /dev/null +++ b/src/Asm/X86/Sp.hs @@ -0,0 +1,63 @@ +module Asm.X86.Sp ( spill ) where + +import Asm.X86 +import Asm.X86.CF +import Control.Monad.Extra (concatMapM) +import Control.Monad.State.Strict (State, runState, state) +import Data.Functor (void) +import Data.Int (Int32, Int8) +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS +import Data.Maybe (catMaybes) + +type SpM = State Int + +next :: SpM Int +next = state (\i -> (i, i+1)) + +spill :: Int -- ^ Unique state + -> Int + -> IS.IntSet + -> [X86 AbsReg FAbsReg a] + -> (Int, Int, [X86 AbsReg FAbsReg ()]) +spill u offs m isns = + let (o', ᴍ) = spillM offs m isns + (nisns, u') = runState ᴍ u + in (u', o', nisns) + +spillM :: Int -- ^ Offset (from already spilled) + -> IS.IntSet + -> [X86 AbsReg FAbsReg a] + -> (Int, SpM [X86 AbsReg FAbsReg ()]) -- ^ 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 ] + newRs <- traverse (\_ -> IReg <$> next) is + let f = thread (zipWith (\i rϵ r -> if toInt r == i then rϵ else r) is newRs) + ma i = ao (at i); as = ma <$> is + isn' = mapR f isn + pure $ + catMaybes (zipWith (\r a -> if toInt r `IS.member` uses isn' then Just (MovRA () r a) else Nothing) newRs as) + ++ void isn' + : catMaybes (zipWith (\a r -> if toInt r `IS.member` defs isn' then Just (MovAR () a r) else Nothing) as newRs) + + ass :: IS.IntSet -> IM.IntMap Int + ass = IM.fromList . (\k -> zip k [offs,offs+8..]) . IS.toList + + assgn = ass m + at k = IM.findWithDefault (error "Internal error.") k assgn + + foffs = offs + 8*IS.size m + + thread = foldr (.) id + +ao o | Just i8 <- mi8 o = RC BP i8 + | Just i32 <- mi32 o = RC32 BP i32 + +mi8 :: Int -> Maybe Int8 +mi8 i | i <= fromIntegral (maxBound :: Int8) && i >= fromIntegral (minBound :: Int8) = Just $ fromIntegral i + | otherwise = Nothing + +mi32 :: Int -> Maybe Int32 +mi32 i | i <= fromIntegral (maxBound :: Int32) && i >= fromIntegral (minBound :: Int32) = Just $ fromIntegral i + | otherwise = Nothing diff --git a/src/Asm/X86/Trans.hs b/src/Asm/X86/Trans.hs new file mode 100644 --- /dev/null +++ b/src/Asm/X86/Trans.hs @@ -0,0 +1,451 @@ +module Asm.X86.Trans ( irToX86 ) where + +import Asm.M +import Asm.X86 +import Control.Monad.State.Strict (runState) +import Data.Bifunctor (second) +import Data.ByteString.Internal (accursedUnutterablePerformIO) +import Data.Int (Int32, Int64, Int8) +import Data.Tuple (swap) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr (castPtr) +import Foreign.Storable (peek, poke) +import qualified IR +import qualified Op + +plF :: IR.FExp -> WM ([X86 AbsReg FAbsReg ()] -> [X86 AbsReg FAbsReg ()], 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.Reg t) = pure (id, absReg t) +plI e = do {i <- nextI; pl <- evalE e (IR.ITemp i); pure ((pl++), IReg i)} + +absReg :: IR.Temp -> AbsReg +absReg (IR.ITemp i) = IReg i +absReg (IR.ATemp i) = IReg i +absReg IR.C0 = CArg0 +absReg IR.C1 = CArg1 +absReg IR.C2 = CArg2 +absReg IR.C3 = CArg3 +absReg IR.C4 = CArg4 +absReg IR.C5 = CArg5 +absReg IR.CRet = CRet + +fabsReg :: IR.FTemp -> FAbsReg +fabsReg (IR.FTemp i) = FReg i +fabsReg IR.F0 = FArg0 +fabsReg IR.F1 = FArg1 +fabsReg IR.F2 = FArg2 +fabsReg IR.F3 = FArg3 +fabsReg IR.F4 = FArg4 +fabsReg IR.F5 = FArg5 +fabsReg IR.FRet = FRet0 +fabsReg IR.FRet1 = FRet1 + +irToX86 :: IR.WSt -> [IR.Stmt] -> (Int, [X86 AbsReg FAbsReg ()]) +irToX86 st = swap . second IR.wtemps . flip runState st . foldMapA ir + +nextR :: WM AbsReg +nextR = IReg <$> nextI; nextF = FReg <$> nextI + +mi8 :: Int64 -> Maybe Int8 +mi8 i | i <= fromIntegral (maxBound :: Int8) && i >= fromIntegral (minBound :: Int8) = Just $ fromIntegral i + | otherwise = Nothing + +mi32 :: Int64 -> Maybe Int32 +mi32 i | i <= fromIntegral (maxBound :: Int32) && i >= fromIntegral (minBound :: Int32) = Just $ fromIntegral i + | otherwise = Nothing + +fI64 :: Double -> Int64 +fI64 x = accursedUnutterablePerformIO $ alloca $ \bytes -> poke (castPtr bytes) x *> peek bytes + +opPred :: Op.FRel -> Pred +opPred Op.FGeq = Nltus +opPred Op.FGt = Nleus +opPred Op.FEq = Eqoq +opPred Op.FNeq = Nequq +opPred Op.FLeq = Leos +opPred Op.FLt = Ltos + +nopPred :: Op.FRel -> Pred +nopPred Op.FGeq = Ltos +nopPred Op.FGt = Leos +nopPred Op.FEq = Nequq +nopPred Op.FNeq = Eqoq +nopPred Op.FLt = Nltus +nopPred Op.FLeq = Nleus + +ir :: IR.Stmt -> WM [X86 AbsReg FAbsReg ()] +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))] +ir (IR.MX t (IR.FAt (IR.AP m (Just (IR.IB Op.IAsl (IR.Reg i) (IR.ConstI 3))) _))) = pure [MovqXA () (fabsReg t) (RS (absReg m) Eight (absReg i))] +ir (IR.MX t (IR.FAt (IR.AP m (Just (IR.ConstI i)) _))) | Just i8 <- mi8 i = pure [MovqXA () (fabsReg t) (RC (absReg m) i8)] +ir (IR.L l) = pure [Label () l] +ir (IR.MT t e) = evalE e t +ir (IR.MJ (IR.IRel Op.ILeq (IR.Reg r0) (IR.Reg r1)) l) = pure [CmpRR () (absReg r0) (absReg r1), Jle () l] +ir (IR.MJ (IR.IRel Op.ILeq (IR.Reg r0) (IR.ConstI i)) l) | Just i32 <- mi32 i = pure [CmpRI () (absReg r0) i32, Jle () l] +ir (IR.MJ (IR.IRel Op.INeq (IR.Reg r0) (IR.ConstI 0)) l) = pure [TestI () (absReg r0) maxBound, Jne () l] +ir (IR.MJ (IR.IRel Op.INeq (IR.Reg r0) (IR.Reg r1)) l) = pure [Test () (absReg r0) (absReg r1), Jne () l] +ir (IR.MJ (IR.IRel Op.IEq (IR.Reg r0) (IR.Reg r1)) l) = pure [Test () (absReg r0) (absReg r1), Je () l] +ir (IR.MJ (IR.IRel Op.IEq (IR.Reg r0) (IR.ConstI i)) l) | Just i32 <- mi32 i = pure [CmpRI () (absReg r0) i32, Je () l] +ir (IR.MJ (IR.IRel Op.IGeq (IR.Reg r0) (IR.ConstI i)) l) | Just i32 <- mi32 i = pure [CmpRI () (absReg r0) i32, Jge () l] +ir (IR.MJ (IR.IRel Op.IGt (IR.Reg r0) (IR.Reg r1)) l) = pure [CmpRR () (absReg r0) (absReg r1), Jg () l] +ir (IR.MJ (IR.IRel Op.IGeq (IR.Reg r0) e1) l) = do + i1 <- nextI; plE1 <- evalE e1 (IR.ITemp i1) + pure $ plE1 ++ [CmpRR () (absReg r0) (IReg i1), Jge () l] +ir (IR.MJ (IR.IRel Op.IGt (IR.Reg r0) (IR.ConstI i)) l) | Just i32 <- mi32 i = pure [CmpRI () (absReg r0) i32, Jg () l] +ir (IR.MJ (IR.IRel Op.ILt (IR.Reg r0) (IR.Reg r1)) l) = pure [CmpRR () (absReg r0) (absReg r1), Jl () l] +ir (IR.MJ (IR.IRel Op.ILt (IR.Reg r0) (IR.ConstI i)) l) | Just i32 <- mi32 i = pure [CmpRI () (absReg r0) i32, Jl () l] +ir (IR.MJ (IR.IRel Op.ILt (IR.Reg r0) e1) l) = do + i1 <- nextI; plE1 <- evalE e1 (IR.ITemp i1) + pure $ plE1 ++ [CmpRR () (absReg r0) (IReg i1), Jl () l] +ir (IR.MJ (IR.FRel fop (IR.FReg r0) e1) l) = do + (plE1,i1) <- plF e1 + f <- nextF; r <- nextR + pure $ plE1 [Vcmppd () f (fabsReg r0) i1 (opPred fop), MovqRX () r f, TestI () r maxBound, Jne () l] +ir (IR.MJ (IR.Is p) l) = pure [TestI () (absReg p) 1, Jne () l] +ir (IR.MJ (IR.IU Op.IOdd e) l) = do + i <- nextI; plE <- evalE e (IR.ITemp i) + pure $ plE ++ [TestI () (IReg i) 1, Jne () l] +ir (IR.MJ (IR.IU Op.IEven e) l) = do + i <- nextI; plE <- evalE e (IR.ITemp i) + pure $ plE ++ [TestI () (IReg i) 1, Je () l] +ir (IR.J l) = pure [J () l] +-- see https://www.agner.org/optimize/optimizing_assembly.pdf, p. 125 +ir (IR.MX t e) = feval e t +ir IR.RA{} = pure[] +ir (IR.Ma _ t e) = do + plE <- evalE e IR.C0 + pure $ plE ++ [Call () Malloc, MovRR () (absReg t) CRet] +ir (IR.Free t) = + pure [MovRR () CArg0 (absReg t), Call () Free] +ir (IR.Wr (IR.AP m Nothing _) (IR.ConstI i)) | Just i32 <- mi32 i = pure [MovAI32 () (R$absReg m) i32] +ir (IR.Wr (IR.AP m Nothing _) (IR.Reg r)) = pure [MovAR () (R$absReg m) (absReg r)] +ir (IR.Wr (IR.AP m (Just (IR.ConstI i)) _) (IR.Reg r)) | Just i8 <- mi8 i = pure [MovAR () (RC (absReg m) i8) (absReg r)] +ir (IR.Wr (IR.AP m (Just (IR.ConstI i)) _) e) | Just i8 <- mi8 i = do + iT <- nextI + plE <- evalE e (IR.ITemp iT) + pure $ plE ++ [MovAR () (RC (absReg m) i8) (IReg iT)] +ir (IR.Wr (IR.AP m (Just (IR.Reg ix)) _) (IR.Reg r)) = pure [MovAR () (RS (absReg m) One (absReg ix)) (absReg r)] +ir (IR.Wr (IR.AP m (Just (IR.IB Op.IAsl (IR.Reg i) (IR.ConstI 3))) _) (IR.Reg r)) = pure [MovAR () (RS (absReg m) Eight (absReg i)) (absReg r)] +ir (IR.Wr (IR.AP m (Just (IR.IB Op.IPlus (IR.IB Op.IAsl (IR.Reg i) (IR.ConstI 3)) (IR.ConstI j))) _) (IR.Reg r)) | Just i8 <- mi8 j = pure [MovAR () (RSD (absReg m) Eight (absReg i) i8) (absReg r)] +ir (IR.Wr (IR.AP m Nothing _) e) = do + eR <- nextI + plE <- evalE e (IR.ITemp eR) + pure $ plE ++ [MovAR () (R (absReg m)) (IReg eR)] +ir (IR.Wr (IR.AP m (Just ei) _) e) = do + eR <- nextI; eiR <- nextI + plE <- evalE e (IR.ITemp eR); plE' <- evalE ei (IR.ITemp eiR) + pure $ plE ++ plE' ++ [MovAR () (RS (absReg m) One (IReg eiR)) (IReg eR)] +ir (IR.WrF (IR.AP m (Just (IR.IB Op.IPlus (IR.IB Op.IAsl ei (IR.ConstI 3)) (IR.ConstI d))) _) (IR.FReg fr)) | Just d8 <- mi8 d = do + i <- nextI; plEI <- evalE ei (IR.ITemp i) + pure $ plEI ++ [MovqAX () (RSD (absReg m) Eight (IReg i) d8) (fabsReg fr)] +ir (IR.WrF (IR.AP m (Just (IR.ConstI i)) _) (IR.FReg r)) | Just d8 <- mi8 i = pure [MovqAX () (RC (absReg m) d8) (fabsReg r)] +ir (IR.WrF (IR.AP m (Just ei) _) (IR.FReg r)) = do + let m' = absReg m + eR <- nextI + plE <- evalE ei (IR.ITemp eR) + pure $ plE ++ [IAddRR () (IReg eR) m', MovqAX () (R (IReg eR)) (fabsReg r)] +ir (IR.WrF (IR.AP m Nothing _) (IR.FReg r)) = + pure [MovqAX () (R (absReg m)) (fabsReg r)] +ir (IR.WrF (IR.AP m Nothing _) (IR.ConstF x)) = do + iR <- nextR + pure [MovRI () iR (fI64 x), MovAR () (R (absReg m)) iR] +ir (IR.Cset t p) = foldMapA ir [IR.MT t 0, IR.Cmov p t 1] +ir (IR.Fcmov (IR.IU Op.IOdd (IR.Reg r0)) t e) = do + plE <- feval e t; l <- nextL + pure $ [TestI () (absReg r0) 1, Je () l] ++ plE ++ [Label () l] +ir (IR.Cmov (IR.IU Op.IEven (IR.Reg r)) rD e) = do + i <- nextI; plE <- evalE e (IR.ITemp i) + pure $ plE ++ [TestI () (absReg r) 1, Cmove () (absReg rD) (IReg i)] +ir (IR.Cmov (IR.IU Op.IOdd (IR.Reg r)) rD e) = do + i <- nextI; plE <- evalE e (IR.ITemp i) + pure $ plE ++ [TestI () (absReg r) 1, Cmovne () (absReg rD) (IReg i)] +ir (IR.Fcmov (IR.IRel Op.IEq (IR.Reg r0) (IR.Reg r1)) t e) = do + plE <- feval e t; l <- nextL + pure $ [CmpRR () (absReg r0) (absReg r1), Jne () l] ++ plE ++ [Label () l] +ir (IR.Cmov (IR.IRel Op.IGt (IR.Reg r0) (IR.Reg r1)) rD eS) = do + iS <- nextI; plES <- evalE eS (IR.ITemp iS) + pure $ plES ++ [CmpRR () (absReg r0) (absReg r1), Cmovnle () (absReg rD) (IReg iS)] +ir (IR.Cmov (IR.IRel Op.IGeq (IR.Reg r0) (IR.Reg r1)) rD eS) = do + iS <- nextI; plES <- evalE eS (IR.ITemp iS) + pure $ plES ++ [CmpRR () (absReg r0) (absReg r1), Cmovnl () (absReg rD) (IReg iS)] +ir (IR.Cmov (IR.IRel Op.INeq (IR.Reg r0) (IR.Reg r1)) rD eS) = do + iS <- nextI; plES <- evalE eS (IR.ITemp iS) + pure $ plES ++ [CmpRR () (absReg r0) (absReg r1), Cmovne () (absReg rD) (IReg iS)] +ir (IR.Cmov (IR.IRel Op.IEq (IR.Reg r0) (IR.Reg r1)) rD eS) = do + iS <- nextI; plES <- evalE eS (IR.ITemp iS) + pure $ plES ++ [CmpRR () (absReg r0) (absReg r1), Cmove () (absReg rD) (IReg iS)] +ir (IR.Cmov (IR.IRel Op.ILeq (IR.Reg r0) (IR.Reg r1)) rD eS) = do + iS <- nextI; plES <- evalE eS (IR.ITemp iS) + pure $ plES ++ [CmpRR () (absReg r0) (absReg r1), Cmovle () (absReg rD) (IReg iS)] +ir (IR.Cmov (IR.IRel Op.ILt (IR.Reg r0) (IR.Reg r1)) rD eS) = do + iS <- nextI; plES <- evalE eS (IR.ITemp iS) + pure $ plES ++ [CmpRR () (absReg r0) (absReg r1), Cmovl () (absReg rD) (IReg iS)] +ir (IR.Cmov (IR.FRel fop (IR.FReg xr0) (IR.FReg xr1)) rD e) = do + i1 <- nextI; plE <- evalE e (IR.ITemp i1) + f <- nextF; r <- nextR + pure $ plE ++ [Vcmppd () f (fabsReg xr0) (fabsReg xr1) (opPred fop), MovqRX () r f, TestI () r maxBound, Cmovne () (absReg rD) (IReg i1)] +ir (IR.Fcmov (IR.FRel fop (IR.FReg xr0) (IR.FReg xr1)) t e) = do + plE <- feval e t; l <- nextL + f <- nextF; r <- nextR + pure $ [Vcmppd () f (fabsReg xr0) (fabsReg xr1) (nopPred fop), MovqRX () r f, TestI () r maxBound, Jne () l] ++ plE ++ [Label () l] +ir (IR.Fcmov (IR.IRel Op.IEq (IR.Reg r0) (IR.ConstI n)) t e) | Just i32 <- mi32 n = do + plE <- feval e t; l <- nextL + pure $ [CmpRI () (absReg r0) i32, Jne () l] ++ plE ++ [Label () l] +ir (IR.Cpy (IR.AP tD (Just (IR.ConstI sD)) _) (IR.AP tS (Just eI) _) (IR.ConstI n)) | Just n32 <- mi32 n, Just sd8 <- mi8 sD = do + iT <- nextI + plE <- evalE (IR.IB Op.IPlus (IR.Reg tS) eI) (IR.ITemp iT) + i <- nextR; t <- nextR + l <- nextL; eL <- nextL + pure $ plE ++ [MovRI () i 0, CmpRI () i (n32-1), Jg () eL, Label () l, MovRA () t (RS (IReg iT) Eight i), MovAR () (RSD (absReg tD) Eight i sd8) t, IAddRI () i 1, CmpRI () i (n32-1), Jle () l, Label () eL] +ir (IR.Cpy (IR.AP tD (Just (IR.ConstI sD)) _) (IR.AP tS (Just (IR.ConstI sI)) _) (IR.ConstI n)) | Just sd8 <- mi8 sD, Just si8 <- mi8 sI = do + i <- nextR; t <- nextR + l <- nextL; eL <- nextL + pure [MovRI () i (n-1), CmpRI () i 0, Jl () eL, Label () l, MovRA () t (RSD (absReg tS) Eight i si8), MovAR () (RSD (absReg tD) Eight i sd8) t, ISubRI () i 1, CmpRI () i 0, Jge () l, Label () eL] +ir (IR.Cpy (IR.AP tD (Just (IR.ConstI sD)) _) (IR.AP tS (Just (IR.ConstI sI)) _) e) | Just sd8 <- mi8 sD, Just si8 <- mi8 sI = do + ii <- nextI; t <- nextR + plE <- evalE e (IR.ITemp ii) + let i = IReg ii + l <- nextL; endL <- nextL + pure $ plE ++ [ISubRI () i 1, Label () l, CmpRI () i 0, Jl () endL, MovRA () t (RSD (absReg tS) Eight i si8), MovAR () (RSD (absReg tD) Eight i sd8) t, ISubRI () i 1, J () l, Label () endL] +ir (IR.Cpy (IR.AP tD Nothing _ ) (IR.AP tS Nothing _) (IR.ConstI n)) | n <= 4 = do + t <- nextR + pure $ concat [ [ MovRA () t (RC (absReg tS) (i*8)), MovAR () (RC (absReg tD) (i*8)) t ] | i <- [0..(fromIntegral n-1)] ] +ir (IR.Cpy (IR.AP tD (Just e) _) (IR.AP tS Nothing _) (IR.ConstI n)) | n <= 4 = do + iR <- nextI; plE <- evalE e (IR.ITemp iR) + t <- nextR + pure $ plE ++ IAddRR () (IReg iR) (absReg tD):concat [ [MovRA () t (RC (absReg tS) (i*8)), MovAR () (RC (IReg iR) (i*8)) t ] | i <- [0..(fromIntegral n-1)] ] +ir (IR.Cpy (IR.AP tD Nothing _) (IR.AP tS (Just e) _) (IR.ConstI n)) | n <= 4 = do + iR <- nextI; plE <- evalE e (IR.ITemp iR) + t <- nextR + pure $ plE ++ IAddRR () (IReg iR) (absReg tS):concat [ [MovRA () t (RC (IReg iR) (i*8)), MovAR () (RC (absReg tD) (i*8)) t ] | i <- [0..(fromIntegral n-1)] ] +ir (IR.Cpy (IR.AP tD (Just (IR.IB Op.IPlus (IR.IB Op.IAsl eid (IR.ConstI 3)) (IR.ConstI sS))) _) (IR.AP tS (Just (IR.IB Op.IPlus (IR.IB Op.IAsl eis (IR.ConstI 3)) (IR.ConstI dS))) _) n) | Just ds8 <- mi8 dS, Just sS8 <- mi8 sS = do + (plD,diR) <- plI eid; (plS,siR) <- plI eis + (plN,nR) <- plI n + t <- nextR; i <- nextR + l <- nextL; eL <- nextL + pure $ plN $ plD $ plS $ [IAddRR () diR (absReg tD), IAddRR () siR (absReg tS), MovRI () i 0, CmpRR () i nR, Jge () eL, Label () l, MovRA () t (RSD siR Eight i ds8), MovAR () (RSD diR Eight i sS8) t, IAddRI () i 1, CmpRR () i nR, Jl () l, Label () eL] +ir (IR.Cpy (IR.AP tD (Just (IR.IB Op.IAsl eid (IR.ConstI 3))) _) (IR.AP tS (Just (IR.IB Op.IAsl eis (IR.ConstI 3))) _) (IR.ConstI n)) | n <= 4 = do + (plD,diR) <- plI eid; (plS,siR) <- plI eis + t <- nextR + pure $ plD $ plS $ concat [ [ MovRA () t (RSD (absReg tS) Eight siR (i*8)), MovAR () (RSD (absReg tD) Eight diR (i*8)) t ] | i <- [0..(fromIntegral n-1)] ] +ir (IR.Cpy (IR.AP tD (Just ed) _) (IR.AP tS (Just es) _) (IR.ConstI n)) | n <= 4 = do + dR <- nextI; sR <- nextI + plD <- evalE ed (IR.ITemp dR); plS <- evalE es (IR.ITemp sR) + t <- nextR + pure $ plD ++ plS ++ IAddRR () (IReg dR) (absReg tD):IAddRR () (IReg sR) (absReg tS):concat [ [MovRA () t (RC (IReg sR) (i*8)), MovAR () (RC (IReg dR) (i*8)) t ] | i <- [0..(fromIntegral n-1)] ] +ir (IR.Cpy (IR.AP tD (Just (IR.IB Op.IPlus ed (IR.ConstI sS))) _) (IR.AP tS (Just (IR.ConstI dS)) _) k) | Just dS8 <- mi8 dS, Just sS8 <- mi8 sS = do + dR <- nextI; kR <- nextI + plK <- evalE k (IR.ITemp kR); plD <- evalE ed (IR.ITemp dR) + i <- nextR; t <- nextR + l <- nextL; eL <- nextL + pure $ plD ++ plK ++ IAddRR () (IReg dR) (absReg tD):[MovRI () i 0, CmpRR () i (IReg kR), Jge () eL, Label () l, MovRA () t (RSD (absReg tS) Eight i dS8), MovAR () (RSD (IReg dR) Eight i sS8) t, IAddRI () i 1, CmpRR () i (IReg kR), Jl () l, Label () eL] +ir (IR.Cpy (IR.AP tD (Just ed) _) (IR.AP tS (Just (IR.ConstI dS)) _) k) | Just dS8 <- mi8 dS = do + dR <- nextI; kR <- nextI + plK <- evalE k (IR.ITemp kR); plD <- evalE ed (IR.ITemp dR) + i <- nextR; t <- nextR + l <- nextL; eL <- nextL + pure $ plD ++ plK ++ IAddRR () (IReg dR) (absReg tD):[MovRI () i 0, CmpRR () i (IReg kR), Jge () eL, Label () l, MovRA () t (RSD (absReg tS) Eight i dS8), MovAR () (RS (IReg dR) Eight i) t, IAddRI () i 1, CmpRR () i (IReg kR), Jl () l, Label () eL] +ir (IR.Cpy (IR.AP tD (Just e) _) (IR.AP tS Nothing _) (IR.ConstI n)) | Just n32 <- mi32 n = do + iR <- nextI; plE <- evalE e (IR.ITemp iR) + i <- nextR; t <- nextR + l <- nextL; eL <- nextL + pure $ plE ++ [IAddRR () (IReg iR) (absReg tD), MovRI () i 0, CmpRI () i (n32-1), Jg () eL, Label () l, MovRA () t (RS (absReg tS) Eight i), MovAR () (RS (IReg iR) Eight i) t, IAddRI () i 1, CmpRI () i (n32-1), Jle () l, Label () eL] +ir (IR.Cpy (IR.AP tD Nothing _) (IR.AP tS (Just e) _) (IR.ConstI n)) | Just n32 <- mi32 n = do + iR <- nextI; plE <- evalE e (IR.ITemp iR) + i <- nextR; t <- nextR + l <- nextL; eL <- nextL + pure $ plE ++ [IAddRR () (IReg iR) (absReg tS), MovRI () i 0, CmpRI () i (n32-1), Jg () eL, Label () l, MovRA () t (RS (IReg iR) Eight i), MovAR () (RS (absReg tD) Eight i) t, IAddRI () i 1, CmpRI () i (n32-1), Jle () l, Label () eL] +ir (IR.Cpy (IR.AP tD (Just e) _) (IR.AP tS (Just (IR.ConstI d)) _) (IR.ConstI n)) | Just n32 <- mi32 n, Just d8 <- mi8 d = do + iR <- nextI; plE <- evalE e (IR.ITemp iR) + i <- nextR; t <- nextR + l <- nextL; eL <- nextL + pure $ plE ++ [IAddRR () (IReg iR) (absReg tD), MovRI () i 0, CmpRI () i (n32-1), Jg () eL, Label () l, MovRA () t (RSD (absReg tS) Eight i d8), MovAR () (RS (IReg iR) Eight i) t, IAddRI () i 1, CmpRI () i (n32-1), Jle () l, Label () eL] +ir (IR.Cpy (IR.AP tD Nothing _) (IR.AP tS (Just e) _) ne) = do + iR <- nextI; plE <- evalE e (IR.ITemp iR) + (plN,nR) <- plI ne + i <- nextR; t <- nextR + l <- nextL; eL <- nextL + pure $ plE ++ plN [IAddRR () (IReg iR) (absReg tS), MovRI () i 0, CmpRR () i nR, Jge () eL, Label () l, MovRA () t (RS (IReg iR) Eight i), MovAR () (RS (absReg tD) Eight i) t, IAddRI () i 1, CmpRR () i nR, Jl () l, Label () eL] +ir (IR.Cpy (IR.AP tD (Just e) _) (IR.AP tS Nothing _) ne) = do + iR <- nextI; plE <- evalE e (IR.ITemp iR) + (plN,nR) <- plI ne + i <- nextR; t <- nextR + l <- nextL; eL <- nextL + pure $ plE ++ plN [IAddRR () (IReg iR) (absReg tD), MovRI () i 0, CmpRR () i nR, Jge () eL, Label () l, MovRA () t (RS (IReg iR) Eight i), MovAR () (RS (absReg tS) Eight i) t, IAddRI () i 1, CmpRR () i nR, Jl () l, Label () eL] +ir (IR.Cpy (IR.AP tD Nothing _) (IR.AP tS Nothing _) ne) = do + (plN,nR) <- plI ne + i <- nextR; t <- nextR + l <- nextL; eL <- nextL + pure $ plN [MovRI () i 0, CmpRR () i nR, Jge () eL, Label () l, MovRA () t (RS (absReg tS) Eight i), MovAR () (RS (absReg tD) Eight i) t, IAddRI () i 1, CmpRR () i nR, Jl () l, Label () eL] +ir (IR.Cpy (IR.AP tD (Just (IR.ConstI n)) _) (IR.AP tS (Just e) _) ne) | Just n8 <- mi8 n = do + iR <- nextI; plE <- evalE e (IR.ITemp iR) + (plN,nR) <- plI ne + i <- nextR; t <- nextR + l <- nextL; eL <- nextL + pure $ plE ++ plN [IAddRR () (IReg iR) (absReg tS), MovRI () i 0, CmpRR () i nR, Jge () eL, Label () l, MovRA () t (RS (IReg iR) Eight i), MovAR () (RSD (absReg tD) Eight i n8) t, IAddRI () i 1, CmpRR () i nR, Jl () l, Label () eL] +-- https://www.cs.uaf.edu/2015/fall/cs301/lecture/09_23_allocation.html +ir (IR.Sa t (IR.ConstI i)) = pure [ISubRI () SP (saI$i+8), MovRR () (absReg t) SP] +ir (IR.Pop (IR.ConstI i)) = pure [IAddRI () SP (saI$i+8)] +ir (IR.Sa t e) = do + iR <- nextI; plE <- evalE e (IR.ITemp iR) + l <- nextL + pure $ plE ++ [TestI () (IReg iR) 0x8, Je () l, IAddRI () (IReg iR) 8, Label () l, ISubRR () SP (IReg iR), MovRR () (absReg t) SP] +ir (IR.Pop e) = do + iR <- nextI; plE <- evalE e (IR.ITemp iR) + l <- nextL + pure $ plE ++ [TestI () (IReg iR) 0x8, Je () l, IAddRI () (IReg iR) 8, Label () l, IAddRR () SP (IReg iR)] +ir (IR.FRnd t) = + pure [Call () DR, Movapd () (fabsReg t) FRet0] +ir (IR.IRnd t) = pure [Rdrand () (absReg t)] +ir (IR.R l) = pure [RetL () l] +ir (IR.C l) = pure [C () l] +ir s = error (show s) + +saI i | i`rem`16 == 0 = fromIntegral i | otherwise = fromIntegral i+8 + +mSse Op.FMinus = Just Vsubsd +mSse Op.FPlus = Just Vaddsd +mSse Op.FDiv = Just Vdivsd +mSse Op.FMax = Just Vmaxsd +mSse Op.FMin = Just Vminsd +mSse Op.FTimes = Just Vmulsd +mSse Op.FExp = Nothing + +feval :: IR.FExp -> IR.FTemp -> WM [X86 AbsReg FAbsReg ()] -- 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)] +feval (IR.FB Op.FPlus (IR.FReg r0) (IR.FReg r1)) t | t == r0 = pure [Addsd () (fabsReg t) (fabsReg r1)] +feval (IR.FConv (IR.Reg r)) t = pure [Cvtsi2sd () (fabsReg t) (absReg r)] +feval (IR.FReg r) t = pure [Movapd () (fabsReg t) (fabsReg r)] +feval (IR.FB Op.FPlus (IR.FReg r0) (IR.FB Op.FTimes (IR.FReg r1) (IR.FReg r2))) t = + pure [Movapd () (fabsReg t) (fabsReg r0), Vfmadd231sd () (fabsReg t) (fabsReg r1) (fabsReg r2)] +feval (IR.FB Op.FPlus (IR.FReg r0) (IR.FB Op.FTimes e (IR.FAt (IR.AP b (Just (IR.IB Op.IPlus (IR.IB Op.IAsl eI (IR.ConstI 3)) (IR.ConstI s))) _)))) t | Just i8 <- mi8 s = do + (plE,i) <- plF e; (plEI,iI) <- plI eI + pure $ plE $ plEI [Movapd () (fabsReg t) (fabsReg r0), Vfmadd231sdA () (fabsReg t) i (RSD (absReg b) Eight iI i8)] +feval (IR.FB Op.FPlus (IR.FReg r0) (IR.FB Op.FTimes e0 e1)) t = do + (plE0,i0) <- plF e0; (plE1,i1) <- plF e1 + pure $ plE0 $ plE1 [Movapd () (fabsReg t) (fabsReg r0), Vfmadd231sd () (fabsReg t) i0 i1] +feval (IR.FB Op.FMinus (IR.FReg r0) (IR.FB Op.FTimes (IR.FReg r1) (IR.FReg r2))) t = + pure [Movapd () (fabsReg t) (fabsReg r0), Vfmnadd231sd () (fabsReg t) (fabsReg r1) (fabsReg r2)] +feval (IR.FB fop e0 e1) t | Just isn <- mSse fop = do + (plR0,i0) <- plF e0; (plR1,i1) <- plF e1 + pure $ plR0 $ plR1 [isn () (fabsReg t) i0 i1] +feval (IR.ConstF x) t = do + iR <- nextR + pure [MovRI () iR (fI64 x), MovqXR () (fabsReg t) iR] +feval (IR.FU Op.FAbs e) t = do + plE <- feval e t + l <- nextL + let nextIR=[IR.MJ (IR.FRel Op.FGeq (IR.FReg t) 0) l, IR.MX t (negate (IR.FReg t)), IR.L l] + nextX86 <- foldMapA ir nextIR + pure $ plE ++ nextX86 +feval (IR.FU Op.FLog (IR.FReg r0)) t = + let sa = RC SP (-8) in + pure [Fldln2 (), MovqAX () sa (fabsReg r0), Fld () sa, Fyl2x (), Fstp () sa, MovqXA () (fabsReg t) sa] +feval (IR.FU Op.FSin (IR.FReg r)) t = + let sa = RC SP (-8) in + pure [MovqAX () sa (fabsReg r), Fld () sa, Fsin (), Fstp () sa, MovqXA () (fabsReg t) sa] +feval (IR.FU Op.FCos (IR.FReg r)) t = + let sa = RC SP (-8) in + pure [MovqAX () sa (fabsReg r), Fld () sa, Fcos (), Fstp () sa, MovqXA () (fabsReg t) sa] +feval (IR.FB Op.FExp (IR.ConstF 2.718281828459045) e) t = do + (plE,i) <- plF e + let sa = RC SP (-8) + -- https://www.madwizard.org/programming/snippets?id=36 + pure $ plE [MovqAX () sa i, Fninit (), Fld () sa, Fldl2e (), Fmulp (), Fld1 (), FldS () (ST 1), Fprem (), F2xm1 (), Faddp (), Fscale (), Fstp () sa, MovqXA () (fabsReg t) sa] +feval (IR.FB Op.FExp e0 e1) t = do + (plE0,i0) <- plF e0 + (plE1,i1) <- plF e1 + let sa0 = RC SP (-8) + sa1 = RC SP (-16) + -- https://www.madwizard.org/programming/snippets?id=36 + pure $ plE0 $ plE1 [MovqAX () sa0 i0, MovqAX () sa1 i1, Fld () sa1, Fld () sa0, Fyl2x (), Fld1 (), FldS () (ST 1), Fprem (), F2xm1 (), Faddp (), Fscale (), Fstp () sa0, MovqXA () (fabsReg t) sa0] +feval (IR.FU Op.FSqrt (IR.FReg r)) t = + pure [Sqrtsd () (fabsReg t) (fabsReg r)] +feval (IR.FAt (IR.AP m (Just (IR.IB Op.IPlus (IR.IB Op.IAsl (IR.Reg i) (IR.ConstI 3)) (IR.ConstI d))) _)) rD | Just i8 <- mi8 d = pure [MovqXA () (fabsReg rD) (RSD (absReg m) Eight (absReg i) i8)] +feval (IR.FAt (IR.AP m (Just (IR.IB Op.IPlus (IR.IB Op.IAsl e (IR.ConstI 3)) (IR.ConstI d))) _)) rD | Just i8 <- mi8 d = do + i <- nextI; plE <- evalE e (IR.ITemp i) + pure $ plE ++ [MovqXA () (fabsReg rD) (RSD (absReg m) Eight (IReg i) i8)] +feval (IR.FAt (IR.AP m (Just (IR.IB Op.IAsl e (IR.ConstI 3))) _)) rD = do + i <- nextI; plE <- evalE e (IR.ITemp i) + 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.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] +evalE (IR.IB Op.IPlus (IR.IB Op.ITimes (IR.Reg r0) (IR.Reg r1)) (IR.Reg r2)) rD = let rD' = absReg rD in pure [MovRR () rD' (absReg r0), IMulRR () rD' (absReg r1), IAddRR () rD' (absReg r2)] +evalE (IR.IB Op.ITimes (IR.Reg r0) (IR.Reg r1)) rD | r1 /= rD = let rD' = absReg rD in pure [MovRR () rD' (absReg r0), IMulRR () rD' (absReg r1)] + | otherwise = pure [IMulRR () (absReg rD) (absReg r0)] +evalE (IR.IB Op.IAsl e (IR.ConstI i)) rD | Just i8 <- mi8 i = do + let rD' = absReg rD + eR <- nextI; plE <- evalE e (IR.ITemp eR) + pure $ plE ++ [MovRR () rD' (IReg eR), Sal () rD' i8] +evalE (IR.IB Op.IAsr e (IR.ConstI i)) rD | Just i8 <- mi8 i = do + let rD' = absReg rD + eR <- nextI; plE <- evalE e (IR.ITemp eR) + pure $ plE ++ [MovRR () rD' (IReg eR), Sar () rD' i8] +evalE (IR.IB Op.IMinus (IR.ConstI 0) e) rD = do + let rD' = absReg rD + plE <- evalE e rD + pure $ plE ++ [Neg () rD'] +evalE (IR.IB Op.IMinus e (IR.ConstI i)) rD = do + let rD' = absReg rD + eR <- nextI + plE <- evalE e (IR.ITemp eR) + pure $ plE ++ [MovRR () rD' (IReg eR), ISubRI () rD' i] +evalE (IR.IB Op.IMinus e e') rD = do + let rD' = absReg rD + (plE,eR) <- plI e; (plE',e'R) <- plI e' + pure $ plE $ plE' [MovRR () rD' eR, ISubRR () rD' e'R] +evalE (IR.IB Op.IPlus e (IR.ConstI i)) rD = do + let rD' = absReg rD + (plE,eR) <- plI e + pure $ plE [MovRR () rD' eR, IAddRI () rD' i] +evalE (IR.IB Op.IPlus e e') rD = do + let rD' = absReg rD + (plE,eR) <- plI e; (plE',e'R) <- plI e' + pure $ plE $ plE' [MovRR () rD' eR, IAddRR () rD' e'R] +evalE (IR.IB Op.ITimes e (IR.EAt (IR.AP m (Just (IR.IB Op.IPlus (IR.IB Op.IAsl (IR.Reg i) (IR.ConstI 3)) (IR.ConstI d))) _))) rD | Just d8 <- mi8 d = do + let rD'=absReg rD + eR <- nextI; plE <- evalE e (IR.ITemp eR) + pure $ plE ++ [MovRR () rD' (IReg eR), IMulRA () rD' (RSD (absReg m) Eight (absReg i) d8)] +evalE (IR.IB Op.ITimes e0 e1) rD = do + let rD' = absReg rD + e0R <- nextI; plE0 <- evalE e0 (IR.ITemp e0R) + e1R <- nextI; plE1 <- evalE e1 (IR.ITemp e1R) + pure $ plE0 ++ plE1 ++ [MovRR () rD' (IReg e0R), IMulRR () rD' (IReg e1R)] +evalE (IR.IB Op.IDiv e0 e1) rD = do + let rD' = absReg rD + e0R <- nextI; e1R <- nextI + plE0 <- evalE e0 (IR.ITemp e0R) + plE1 <- evalE e1 (IR.ITemp e1R) + pure $ plE0 ++ plE1 ++ [XorRR () Rem Rem, MovRR () Quot (IReg e0R), IDiv () (IReg e1R), MovRR () rD' Quot] +evalE (IR.IB Op.IRem e0 e1) rD = do + let rD' = absReg rD + e0R <- nextI; e1R <- nextI + plE0 <- evalE e0 (IR.ITemp e0R); plE1 <- evalE e1 (IR.ITemp e1R) + pure $ plE0 ++ plE1 ++ [XorRR () Rem Rem, MovRR () Quot (IReg e0R), IDiv () (IReg e1R), MovRR () rD' Rem] +evalE (IR.IRFloor (IR.FReg r)) t = let r' = fabsReg r in pure [Roundsd () r' r' RDown, Cvttsd2si () (absReg t) r'] +evalE (IR.EAt (IR.AP m (Just (IR.ConstI i)) _)) rD | Just i8 <- mi8 i = pure [MovRA () (absReg rD) (RC (absReg m) i8)] +evalE (IR.EAt (IR.AP m (Just (IR.Reg i)) _)) rD = pure [MovRA () (absReg rD) (RS (absReg m) One (absReg i))] +evalE (IR.EAt (IR.AP m (Just (IR.IB Op.IAsl (IR.Reg i) (IR.ConstI 3))) _)) rD = pure [MovRA () (absReg rD) (RS (absReg m) Eight (absReg i))] +evalE (IR.IB (Op.BI Op.AndB) (IR.Reg r0) (IR.Reg r1)) rD = let rD' = absReg rD in pure [MovRR () rD' (absReg r0), And () rD' (absReg r1)] +evalE (IR.EAt (IR.AP m (Just (IR.IB Op.IPlus (IR.IB Op.IAsl (IR.Reg i) (IR.ConstI 3)) (IR.ConstI d))) _)) rD | Just i8 <- mi8 d = pure [MovRA () (absReg rD) (RSD (absReg m) Eight (absReg i) i8)] +evalE (IR.EAt (IR.AP m (Just (IR.IB Op.IPlus (IR.IB Op.IAsl e (IR.ConstI 3)) (IR.ConstI d))) _)) rD | Just i8 <- mi8 d = do + i <- nextI; plE <- evalE e (IR.ITemp i) + pure $ plE ++ [MovRA () (absReg rD) (RSD (absReg m) Eight (IReg i) i8)] +evalE (IR.EAt (IR.AP m Nothing _)) rD = + let rD'=absReg rD in pure [MovRA () rD' (R$absReg m)] +evalE (IR.EAt (IR.AP m (Just e) _)) rD = do + let rD'=absReg rD;m'=absReg m + r <- nextR; eR <- nextI; plE <- evalE e (IR.ITemp eR) + pure $ plE ++ [MovRR () r m', IAddRR () r (IReg eR), MovRA () rD' (R r)] +evalE (IR.LA i) rD = pure [MovRL () (absReg rD) i] +evalE e _ = error (show e) diff --git a/src/Bits.hs b/src/Bits.hs new file mode 100644 --- /dev/null +++ b/src/Bits.hs @@ -0,0 +1,7 @@ +module Bits ( cLog ) where + +import Data.Bits (FiniteBits, countTrailingZeros, popCount) +import Data.Int (Int64) + +cLog :: FiniteBits a => a -> Maybe Int64 +cLog n | popCount n == 1 = Just (fromIntegral$countTrailingZeros n) | otherwise = Nothing diff --git a/src/C.hs b/src/C.hs new file mode 100644 --- /dev/null +++ b/src/C.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} + +-- first IR with for loops and array accesses, inspired by C +module C ( Temp (..), FTemp (..), BTemp (..) + , ArrAcc (..) + , CE (..), CFE (..) + , PE (..) + , CS (..) + , (=:) + , Label, AsmData + , LSt (..) + , prettyCS + , pL + ) where + +import CF.AL +import Data.Copointed +import Data.Int (Int64) +import qualified Data.IntMap as IM +import Data.Word (Word64) +import Op +import Prettyprinter (Doc, Pretty (..), brackets, comma, dot, hardline, indent, lbrace, parens, rbrace, tupled, (<+>)) +import Prettyprinter.Ext + +type Label=Word; type AsmData = IM.IntMap [Word64] + +data Temp = ITemp !Int | ATemp !Int + | C0 | C1 | C2 | C3 | C4 | C5 | CRet deriving Eq + +data BTemp = BTemp !Int | CBRet deriving Eq + +data FTemp = FTemp !Int + | F0 | F1 | F2 | F3 | F4 | F5 | FRet0 | FRet1 deriving Eq + +instance Pretty BTemp where pretty (BTemp i) = "P" <> pretty i; pretty CBRet = "PRet" + +instance Pretty Temp where + pretty (ITemp i) = "T" <> pretty i + pretty (ATemp i) = "AT" <> pretty i + pretty C0 = "CArg0" + pretty C1 = "CArg1" + pretty C2 = "CArg2" + pretty C3 = "CArg3" + pretty C4 = "CArg4" + pretty C5 = "CArg5" + pretty CRet = "CRet" + +instance Pretty FTemp where + pretty (FTemp i) = "X" <> pretty i + pretty F0 = "FArg0" + pretty F1 = "FArg1" + pretty F2 = "FArg2" + pretty F3 = "FArg3" + pretty F4 = "FArg4" + pretty F5 = "FArg5" + pretty FRet0 = "FRet0" + pretty FRet1 = "FRet1" + +data ArrAcc = AElem Temp CE CE (Maybe AL) Int64 -- pointer, rank, elem., label for tracking liveness, elem. size (bytes) + -- TODO: more robust way to handle rank (often statically known) + | ARnk Temp (Maybe AL) + | ADim Temp CE (Maybe AL) -- pointer, #, label + | At Temp [CE] [CE] (Maybe AL) Int64 -- pointer to data, strides, indices, label, elem. size (bytes) + | Raw Temp CE (Maybe AL) Int64 -- pointer to data, offset, label, element size + | TupM Temp (Maybe AL) + +instance Pretty ArrAcc where + pretty (AElem t _ e _ _) = pretty t <> brackets (pretty e) + pretty (ADim t e _) = pretty t <> dot <> "dim" <> brackets (pretty e) + pretty (ARnk t _) = "rnk" <> parens (pretty t) + pretty (At t s ix _ _) = pretty t <> foldMap (brackets.pretty) ix <+> foldMap (parens.pretty) s + pretty (Raw t o _ _) = pretty t <> "@" <> pretty o + pretty (TupM t _) = "tup@" <> pretty t + +instance Show ArrAcc where show=show.pretty + +bPrec AndB=3; bPrec OrB=2; bPrec XorB=6 + +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 + | LA !Int -- assembler data + | DP Temp CE -- pointer, rank + +instance Pretty CE where pretty=ps 0 + +instance PS CE where + ps _ (Tmp t) = pretty t + ps _ (ConstI i) = pretty i + ps d (Bin op e0 e1) | Just d' <- mPrec op = parensp (d>d') (ps (d'+1) e0 <> pretty op <> ps (d'+1) e1) + | otherwise = parens (pretty op <+> ps 11 e0 <+> ps 11 e1) + ps _ (EAt a) = pretty a + ps _ (LA n) = "A_" <> pretty n + ps _ (DP t _) = "DATA" <> parens (pretty t) + ps _ (CFloor x) = "⌊" <> pretty x + +instance Show CE where show=show.pretty + +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 + +instance Num CFE where + (+) = FBin FPlus; (*) = FBin FTimes; (-) = FBin FMinus; fromInteger=ConstF . fromInteger + +instance Fractional CFE where + (/) = FBin FDiv; fromRational=ConstF . fromRational + +instance Pretty CFE where pretty=ps 0 + +data PE = IRel IRel CE CE + | FRel FRel CFE CFE + | Boo BBin PE PE + | BConst Bool + | IUn IUn CE + | Is BTemp + | PAt ArrAcc + | BU BUn PE + +instance Pretty PE where + pretty (IRel rel e0 e1) = pretty e0 <+> pretty rel <+> pretty e1 + pretty (FRel rel e0 e1) = pretty e0 <+> pretty rel <+> pretty e1 + pretty (IUn p e) = pretty p <+> pretty e + pretty (Is t) = "is?" <+> pretty t + pretty (PAt a) = "b@" <> pretty a + pretty (BConst True) = "true" + pretty (BConst False) = "false" + pretty (Boo op e0 e1) = pretty e0 <+> pretty op <+> pretty e1 + pretty (BU op e) = pretty op <> pretty e + +instance PS CFE 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) + | otherwise = parens (pretty op <+> ps 11 x0 <+> ps 11 x1) + ps _ (FTmp t) = pretty t + ps _ (ConstF x) = pretty x + ps d (IE e) = parensp (d>10) ("itof" <+> ps 11 e) + +instance Show CFE where show=show.pretty + +infix 9 =: + +(=:) = MT () + +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] } + | MT { lann :: a, tDest :: Temp, tSrc :: CE } + | MX { lann :: a, ftDest :: FTemp, ftSrc :: CFE } + | MB { lann :: a, bDest :: BTemp, pSrc :: PE } + | Wr { lann :: a, addr :: ArrAcc, wrE :: CE } + | WrF { lann :: a, addr :: ArrAcc, wrF :: CFE } + | WrP { lann :: a, addr :: ArrAcc , wrB :: PE } + | Ma { lann :: a, label :: AL, temp :: Temp, rank :: CE, nElem :: CE, elemSz :: !Int64 } + | Free Temp + | MaΠ { lann :: a, label :: AL, temp :: Temp, aBytes :: CE } + | RA { lann :: a, label :: !AL } -- return array no-op (takes label) + | CpyE { lann :: a, aDest, aSrc :: ArrAcc, nElem :: CE, elemSz :: !Int64 } -- copy elems + | CpyD { lann :: a, aDest, aSrc :: ArrAcc, nDims :: CE } -- copy dims + | Ifn't { lann :: a, scond :: PE, branch :: [CS a] } + | If { lann :: a, scond :: PE, iBranch, eBranch :: [CS a] } + | 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 } + -- TODO: Fcneg? + | Cset { lann :: a, scond :: PE, bdest :: BTemp } + | SZ { lann :: a, szDest :: Temp, arr :: Temp, rank :: CE, mLabel :: Maybe AL } + | PlProd { lann :: a, nDest :: Temp, pdims :: [CE] } + | Rnd { lann :: a, rndDest :: Temp } + | FRnd { lann :: a, frndDest :: FTemp } + | Def { lann :: a, fLabel :: Label, body :: [CS a] } + | G { lann :: a, gt :: Label, retLabel :: Label } + deriving Functor + -- TODO: PlDims cause we have diml + +instance Copointed CS where copoint=lann + +instance Pretty (CS a) where + pretty = pL (const"") + +pL f (MT l t (Bin IPlus (Tmp t') e)) | t==t' = pretty t <+> "+=" <+> pretty e <> f l +pL f (MT l t e) = pretty t <+> "=" <+> pretty e <> f l +pL f (MX l t (FBin FPlus (FTmp t') e)) | t==t' = pretty t <+> "+=" <+> pretty e <> f l +pL f (MX l t e) = pretty t <+> "=" <+> pretty e <> f l +pL f (MB l t e) = pretty t <+> "=" <+> pretty e <> f l +pL f (Wr l a e) = pretty a <+> "=" <+> pretty e <> f l +pL f (WrF l a e) = pretty a <+> "=" <+> pretty e <> f l +pL f (WrP l a e) = pretty a <+> "=" <+> pretty e <> f l +pL _ (Free t) = "free" <+> pretty t +pL f (Ma l _ t rnk e sz) = pretty t <+> "=" <+> "malloc" <> parens ("rnk=" <> pretty rnk <> comma <+> pretty e <> "*" <> pretty sz) <> f l +pL f (MaΠ l _ t sz) = pretty t <+> "=" <+> "malloc" <> parens (pretty sz) <> f l +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 (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 +pL f (CpyE l a a' e n) = "cpy" <+> pretty a <> comma <+> pretty a' <+> parens (pretty e<>"*"<>pretty n) <> f l +pL f (CpyD l a a' e) = "cpydims" <+> pretty a <+> pretty a' <+> pretty e <> f l +pL f (Sa l t e) = pretty t <+> "=" <+> "salloc" <> parens (pretty e) <> f l +pL f (Pop l e) = "pop" <+> pretty e <> f l +pL f (Cmov l p t e) = "if" <+> parens (pretty p) <+> lbrace <#> indent 4 (pretty t <+> "=" <+> pretty e) <#> rbrace <> f l +pL f (Fcmov l p t e) = "if" <+> parens (pretty p) <+> lbrace <#> indent 4 (pretty t <+> "=" <+> pretty e) <#> rbrace <> f l +pL f (Cset l p t) = pretty t <+> "=" <+> pretty p <> f l +pL f (SZ l td t _ _) = pretty td <+> "=" <+> "SIZE" <> parens (pretty t) <> f l +pL f (PlProd l t ts) = pretty t <+> "=" <+> "PRODUCT" <> tupled (pretty<$>ts) <> f l +pL f (Rnd l t) = pretty t <+> "=" <+> "(rnd)" <> f l +pL f (FRnd l x) = pretty x <+> "=" <+> "(frnd)" <> f l +pL f (Def la l cs) = hardline <> pS l <> ":" <#> indent 4 (pCS f cs) <> f la +pL f (G la l _) = "GOTO" <+> pS l <> f la + +pS :: Label -> Doc ann +pS l = "fun_" <> pretty l + +instance Show (CS a) where show=show.pretty + +prettyCS :: (AsmData, [CS a]) -> Doc ann +prettyCS (ds,ss) = pCS (const"") ss + +pCS :: (a -> Doc ann) -> [CS a] -> Doc ann +pCS f=prettyLines.fmap (pL f) + +data LSt = LSt { clabel :: !Label, ctemps :: !Int } diff --git a/src/C/Alloc.hs b/src/C/Alloc.hs new file mode 100644 --- /dev/null +++ b/src/C/Alloc.hs @@ -0,0 +1,39 @@ +module C.Alloc ( live, frees ) where + +import C +import C.CF +import CF +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.Maybe (mapMaybe) +import LR + +frees :: IM.IntMap Temp -> [CS ()] -> [CS Liveness] +frees a = iF a.live + +live :: [CS ()] -> [CS Liveness] +live = fmap (fmap liveness) . (\(is,isns,lm) -> reconstruct is lm isns) . cfC + +iF :: IM.IntMap Temp -> [CS Liveness] -> [CS Liveness] +iF a = gg where + gg (RA{}:cs) = gg cs + gg [s@(For l _ _ _ _ cs)] = s { body = gg cs }:fs0 l + gg [s@(While l _ _ _ cs)] = s { body = gg cs }:fs0 l + gg [s@(For1 l _ _ _ _ cs)] = s { body = gg cs }:fs0 l + gg [s@(If l _ b0 b1)] = s { iBranch = gg b0, eBranch = gg b1 }:fs0 l + gg [s@(Ifn't l _ b)] = s { branch = gg b }:fs0 l + gg [s@(Def _ _ cs)] = [s { body = gg cs }] + gg (s@(For l _ _ _ _ cs):ss@(s0:_)) = s { body = gg cs }:fs l s0++gg ss + gg (s@(While l _ _ _ cs):ss@(s0:_)) = s { body = gg cs }:fs l s0++gg ss + gg (s@(For1 l _ _ _ _ cs):ss@(s0:_)) = s { body = gg cs }:fs l s0++gg ss + gg (s@(If l _ b0 b1):ss@(s0:_)) = s { iBranch = gg b0, eBranch = gg b1 }:fs l s0++gg ss + gg (s@(Ifn't l _ b):ss@(s0:_)) = s { branch = gg b }:fs l s0++gg ss + gg (s@(Def l _ cs):ss@(s0:_)) = s { body = gg cs }:fs l s0++gg ss + gg [s] = s:fs0 (lann s) + gg (s:ss@(s0:_)) = s:fs (lann s) s0++gg ss + gg [] = [] + + fs0 l = [ Free t | t <- ts0 l ] + ts0 l = mapMaybe (`IM.lookup` a) (IS.toList (ins l `IS.difference` out l)) + fs l0 s1 = [ Free t | t <- ts l0 s1 ] + ts l0 s1 = mapMaybe (`IM.lookup` a) (IS.toList (ins l0 `IS.difference` ins (lann s1))) diff --git a/src/C/CF.hs b/src/C/CF.hs new file mode 100644 --- /dev/null +++ b/src/C/CF.hs @@ -0,0 +1,252 @@ +module C.CF ( cfC ) where + +import C +import CF +import CF.AL +-- seems to pretty clearly be faster +import Control.Monad.State.Strict (State, evalState, gets, modify, state) +import Data.Bifunctor (first) +import Data.Functor (($>)) +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.List (uncons) +import qualified Data.Map as M +import Data.Tuple.Extra (second3, snd3, thd3, third3) + +type N=Int + +-- map of labels by node +type FreshM = State (N, M.Map Label N, M.Map Label [N]) + +runFreshM :: FreshM a -> a +runFreshM = flip evalState (0, mempty, mempty) + +cfC :: [CS ()] -> ([N], [CS ControlAnn], IM.IntMap (ControlAnn, Liveness)) +cfC cs = let cfs = mkControlFlow cs in (inspectOrder cfs, cfs, initLiveness cfs) + +mkControlFlow :: [CS ()] -> [CS ControlAnn] +mkControlFlow instrs = runFreshM (brs instrs *> addCF instrs) + +getFresh :: FreshM N +getFresh = state (\(i,m0,m1) -> (i,(i+1,m0,m1))) + +fm :: Label -> FreshM N +fm l = do {i <- getFresh; br i l $> i} + +ll :: Label -> FreshM N +ll l = gets (M.findWithDefault (error "Internal error in control-flow graph: node label not in map.") l . snd3) + +lC :: Label -> FreshM [N] +lC l = gets (M.findWithDefault (error "Internal error in CF graph: node label not in map.") l . thd3) + +br :: N -> Label -> FreshM () +br i l = modify (second3 (M.insert l i)) + +b3 :: N -> Label -> FreshM () +b3 i l = modify (third3 (M.alter (\k -> Just$case k of {Nothing -> [i]; Just is -> i:is}) l)) + +mC :: ([N] -> [N]) -> ControlAnn -> ControlAnn +mC f (ControlAnn l ds udϵ) = ControlAnn l (f ds) udϵ + +unsnoc :: [a] -> ([a], a) +unsnoc [x] = ([], x) +unsnoc (x:xs) = first (x:) $ unsnoc xs +unsnoc _ = error "Internal error: unsnoc called on empty list." + +emptyL :: Liveness +emptyL = Liveness IS.empty IS.empty IS.empty IS.empty + +initLiveness :: [CS ControlAnn] -> IM.IntMap (ControlAnn, Liveness) +initLiveness = IM.fromList . go where + go [] = [] + 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 (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 + go (c:cs) = let x=lann c in (node x, (x, emptyL)):go cs + +inspectOrder :: [CS ControlAnn] -> [N] +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 (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 +inspectOrder (c:cs) = node (lann c):inspectOrder cs +inspectOrder [] = [] + +tieBranch :: ([N] -> [N]) -> [CS ()] -> FreshM ([N] -> [N], [CS ControlAnn]) +tieBranch f ss = do + preSs <- addCF ss + pure $ case uncons preSs of + Just (i1, _) -> + let hi=node (lann i1) + (ss',l) = unsnoc preSs + l' = fmap (mC f) l + ss'' = ss'++[l'] + in ((hi:), ss'') + Nothing -> (id, preSs) + +tieBody :: N -> ([N] -> [N]) -> [CS ()] -> FreshM ([N] -> [N], [CS ControlAnn]) +tieBody h f ss = do + preSs <- addCF ss + case uncons preSs of + Just (i1, _) -> + let hi=node (lann i1) + (ss',l) = unsnoc preSs + l'=fmap (mC ((h:).f)) l + ss''=ss'++[l'] + in pure ((hi:), ss'') + Nothing -> pure (id, []) + +-- | Pair 'CS with a unique node name and a list of all possible +-- destinations. +addCF :: [CS ()] -> FreshM [CS ControlAnn] +addCF [] = pure [] +addCF ((Def _ l ss):stmts) = do + i <- ll l + nextStmts <- addCF stmts + preSs <- addCF ss + case uncons preSs of + Nothing -> undefined + Just (h, _) -> + let hi=node (lann h) + (ss',lϵ) = unsnoc preSs + in do + l_is <- lC l + let l'= fmap (mC (const l_is)) lϵ + ss''=ss'++[l'] + pure (Def (ControlAnn i [hi] (UD IS.empty IS.empty IS.empty IS.empty)) l ss'':nextStmts) +addCF (G _ l r:stmts) = do + i <- ll r + nextStmts <- addCF stmts + l_i <- ll l + pure (G (ControlAnn i [l_i] (UD IS.empty IS.empty IS.empty IS.empty)) l r:nextStmts) +addCF ((For _ t el c eu ss):stmts) = do + i <- getFresh + (f, stmts') <- next stmts + (h, ss') <- tieBody i f ss + pure $ For (ControlAnn i (f (h [])) udϵ) t el c eu ss':stmts' + where + udϵ = UD (uE el<>uE eu) IS.empty IS.empty IS.empty +addCF ((For1 _ t el c eu ss):stmts) = do + i <- getFresh + (f, stmts') <- next stmts + (h, ss') <- tieBody i f ss + pure $ For1 (ControlAnn i (f (h [])) udϵ) t el c eu ss':stmts' + where + udϵ = UD (uE el<>uE eu) IS.empty IS.empty IS.empty +addCF ((While _ t c ed ss):stmts) = do + i <- getFresh + (f, stmts') <- next stmts + (h, ss') <- tieBody i f ss + pure $ While (ControlAnn i (f (h [])) udϵ) t c ed ss':stmts' + where + udϵ = UD (uE ed) IS.empty IS.empty IS.empty +addCF (If _ p b0 b1:stmts) = do + i <- getFresh + (f, stmts') <- next stmts + (h0, b0') <- tieBranch f b0 + (h1, b1') <- tieBranch f b1 + pure $ If (ControlAnn i (f (h0 (h1 []))) udϵ) p b0' b1':stmts' + where + udϵ = UD (uB p) IS.empty IS.empty IS.empty +addCF (Ifn't _ p b:stmts) = do + i <- getFresh + (f, stmts') <- next stmts + (h, b') <- tieBranch f b + pure $ Ifn't (ControlAnn i (f (h [])) udϵ) p b':stmts' + where + udϵ = UD (uB p) IS.empty IS.empty IS.empty +addCF (stmt:stmts) = do + i <- getFresh + (f, stmts') <- next stmts + pure ((stmt $> ControlAnn i (f []) (UD (uses stmt) IS.empty (defs stmt) IS.empty)):stmts') + +uE :: CE -> IS.IntSet +uE ConstI{} = IS.empty +uE LA{} = IS.empty +uE (EAt a) = uA a +uE Tmp{} = IS.empty +uE (Bin _ e0 e1) = uE e0<>uE e1 +uE (CFloor e0) = uF e0 +uE (DP _ e) = uE e + +uF :: CFE -> IS.IntSet +uF ConstF{} = IS.empty +uF FTmp{} = IS.empty +uF (FAt a) = uA a +uF (FUn _ e) = uF e +uF (FBin _ e0 e1) = uF e0<>uF e1 +uF (IE e) = uE e + +m'insert (Just l) a = sinsert l a +m'insert Nothing a = a + +uA (ARnk _ (Just l)) = singleton l +uA (ARnk _ Nothing) = IS.empty +uA (ADim _ d l) = m'insert l $ uE d +uA (TupM _ (Just l)) = singleton l +uA (TupM _ Nothing) = IS.empty +uA (AElem _ r ei l _) = m'insert l (uE r<>uE ei) +uA (Raw _ e l _) = m'insert l (uE e) +uA (At _ ss ixs l _) = m'insert l (foldMap uE ss<>foldMap uE ixs) + +uses :: CS a -> IS.IntSet +uses (Ma _ _ _ r n _) = uE r<>uE n +uses (MaΠ _ _ _ n) = uE n +uses (MX _ _ e) = uF e +uses (Wr _ a e) = uA a <> uE e +uses (RA _ l) = singleton l +uses (Cmov _ e0 _ e1) = uB e0<>uE e1 +uses (Fcmov _ e0 _ e1) = uB e0<>uF e1 +uses (WrF _ a e) = uA a <> uF e +uses (Cset _ e _) = uB e +uses (MT _ _ e) = uE e +uses (MB _ _ e) = uB e +uses (WrP _ a e) = uA a<>uB e +uses Rnd{} = IS.empty +uses FRnd{} = IS.empty +uses (PlProd _ _ es) = foldMap uE es +uses (SZ _ _ _ e (Just l)) = sinsert l (uE e) +uses (SZ _ _ _ e Nothing) = uE e +uses (Pop _ e) = uE e +uses (Sa _ _ e) = uE e +uses (CpyD _ d s n) = uA d<>uA s<>uE n +uses (CpyE _ d s n _) = uA d<>uA s<>uE n + +uB :: PE -> IS.IntSet +uB (PAt a) = uA a +uB BConst{} = IS.empty +uB (IRel _ e0 e1) = uE e0<>uE e1 +uB (FRel _ e0 e1) = uF e0<>uF e1 +uB (Boo _ e0 e1) = uB e0<>uB e1 +uB (IUn _ e) = uE e +uB Is{} = IS.empty +uB (BU _ e) = uB e + +defs :: CS a -> IS.IntSet +defs (Ma _ a _ _ _ _) = singleton a +defs (MaΠ _ a _ _) = singleton a +defs _ = IS.empty + +next :: [CS ()] -> FreshM ([N] -> [N], [CS ControlAnn]) +next stmts = do + nextStmts <- addCF stmts + case nextStmts of + [] -> pure (id, []) + (stmt:_) -> pure ((node (lann stmt) :), nextStmts) + +-- | Construct map assigning labels to their node name. +brs :: [CS ()] -> FreshM () +brs [] = pure () +brs (G _ l retL:stmts) = do {i <- fm retL; b3 i l; brs stmts} +brs (Def _ f b:stmts) = fm f *> brs b *> brs stmts +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 (If _ _ ss ss':stmts) = brs ss *> brs ss' *> brs stmts +brs (Ifn't _ _ ss:stmts) = brs ss *> brs stmts +brs (_:asms) = brs asms diff --git a/src/C/Trans.hs b/src/C/Trans.hs new file mode 100644 --- /dev/null +++ b/src/C/Trans.hs @@ -0,0 +1,1466 @@ +{-# LANGUAGE TupleSections #-} + +module C.Trans ( writeC ) where + +import A +import Bits +import C +import CF.AL (AL (..)) +import qualified CF.AL as AL +import Control.Composition (thread) +import Control.Monad (zipWithM) +import Control.Monad.State.Strict (State, gets, modify, runState, state) +import Data.Bifunctor (first, second) +import Data.Functor (($>)) +import Data.Int (Int64) +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.List (scanl') +import Data.Maybe (catMaybes, isJust) +import Data.Word (Word64) +import GHC.Float (castDoubleToWord64) +import Nm +import Nm.IntMap +import Op + +data CSt = CSt { tempU :: !Int + , arrU :: !AL + , assemblerSt :: !Int + , label :: !Label + , vars :: IM.IntMap Temp -- track vars so that (Var x) can be replaced at the site + , pvars :: IM.IntMap BTemp + , dvars :: IM.IntMap FTemp + , avars :: IM.IntMap (Maybe AL, Temp) + , fvars :: IM.IntMap (Label, [Arg], Either FTemp Temp) + , _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)) + +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))) + +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)) + +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)) + +nBT :: CM BTemp +nBT = BTemp<$>nextI + +newITemp :: CM Temp +newITemp = ITemp <$> nextI + +newFTemp :: CM FTemp +newFTemp = FTemp <$> 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 + +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 + +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 + +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 + +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 + +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 + +getT :: IM.IntMap b -> Nm a -> b +getT st n = findWithDefault (error ("Internal error: variable " ++ show n ++ " not assigned to a temp.")) n st + +type CM = State CSt + +infix 9 += +(+=) t i = t =: (Tmp t+i) + +fop op e0 = EApp F (EApp (F ~> F) (Builtin (F ~> F ~> F) op) e0) +eMinus = fop Minus +eDiv = fop Div + +isF, isI, isB, isIF :: T a -> Bool +isF F = True; isF _ = False +isI I = True; isI _ = False +isB B = True; isB _ = False +isArr Arr{}=True; isArr _=False +isIF I=True; isIF F=True; isIF _=False +isR B=True; isR t=isIF t +nind I=True; nind F=True; nind P{}=True; nind B{}=True; nind _=False +isΠR (P ts)=all isR ts; isΠR _=False +isΠ P{}=True; isΠ _=False + +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 + +if1 :: T a -> Maybe (T a) +if1 (Arr (_ `Cons` Nil) I) = Just I; if1 (Arr (_ `Cons` Nil) F) = Just F; if1 _ = Nothing + +if1p :: T a -> Bool +if1p t | Just{} <- if1 t = True | otherwise = False + +mAA :: T a -> Maybe ((T a, Int64), (T a, Int64)) +mAA (Arrow t0 t1) = (,) <$> tRnk t0 <*> tRnk t1 +mAA _ = Nothing + +f1 :: T a -> Bool +f1 (Arr (_ `Cons` Nil) F) = True; f1 _ = False + +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 :: 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 F=Just 8; rSz I=Just 8; rSz B=Just 1; rSz _=Nothing + +szT = scanl' (\off ty -> off+bT ty::Int64) 0 + +staRnk :: Integral b => Sh a -> Maybe b +staRnk Nil = Just 0 +staRnk (_ `Cons` sh) = (1+) <$> staRnk sh +staRnk _ = Nothing + +eRnk :: Sh a -> (Temp, Maybe AL) -> CE +eRnk sh (xR, lX) | Just i <- staRnk sh = ConstI i + | otherwise = EAt (ARnk xR lX) + +tRnk :: T a -> Maybe (T a, Int64) +tRnk (Arr sh t) = (t,) <$> staRnk sh +tRnk _ = Nothing + +staIx :: Sh a -> Maybe [Int64] +staIx Nil=Just[]; staIx (Ix _ i `Cons` s) = (fromIntegral i:)<$>staIx s; staIx _=Nothing + +tIx :: T a -> Maybe (T a, [Int64]) +tIx (Arr sh t) = (t,)<$>staIx sh; tIx _=Nothing + +nz, ni1 :: I a -> Bool +nz (Ix _ i) | i > 0 = True +nz (StaPlus _ i0 i1) = nz i0 || nz i1 -- no negative dims +nz (StaMul _ i0 i1) = nz i0 && nz i1 +nz _ = False + +nzSh :: Sh a -> Bool +nzSh (i `Cons` Nil) = nz i +nzSh (i `Cons` sh) = nz i && nzSh sh +nzSh _ = False + +ni1 (Ix _ i) | i > 1 = True +ni1 (StaPlus _ i0 i1) = ni1 i0 || ni1 i1 +ni1 (StaMul _ i0 i1) = (nz i0&&ni1 i1) || (nz i1&&ni1 i0) +ni1 _ = False + +ne, n1 :: T a -> Bool +ne (Arr (i `Cons` _) _) = nz i; ne _=False +n1 (Arr (i `Cons` _) _) = ni1 i; n1 _=False + +nee :: T a -> Bool +nee (Arr sh _) = nzSh sh; nee _=False + +for t = if ne t then For1 () else For (); for1 t = if n1 t then For1 () else For () +fors t = if nee t then For1 () else For () + +staR :: Sh a -> [Int64] +staR Nil = []; staR (Ix _ i `Cons` s) = fromIntegral i:staR s + +tRnd :: T a -> (T a, [Int64]) +tRnd (Arr sh t) = (t, staR sh) + +mIFs :: [E a] -> Maybe [Word64] +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) + +writeCM :: E (T ()) -> CM [CS ()] +writeCM eϵ = do + cs <- traverse (\_ -> newITemp) [(0::Int)..5]; fs <- traverse (\_ -> newFTemp) [(0::Int)..5] + (zipWith (\xr xr' -> MX () xr' (FTmp xr)) [F0,F1,F2,F3,F4,F5] fs ++) . (zipWith (\r r' -> r' =: Tmp r) [C0,C1,C2,C3,C4,C5] cs ++) <$> go eϵ fs cs where + go (Lam _ x@(Nm _ _ F) e) (fr:frs) rs = do + modify (addD x fr) + go e frs rs + go (Lam _ (Nm _ _ F) _) [] _ = error "Not enough floating-point registers!" + go (Lam _ x@(Nm _ _ I) e) frs (r:rs) = do + modify (addVar x r) + go e frs rs + go (Lam _ x@(Nm _ _ Arr{}) e) frs (r:rs) = do + modify (addAVar x (Nothing, r)) + go e frs rs + go Lam{} _ [] = error "Not enough registers!" + go e _ _ | isF (eAnn e) = do {f <- newFTemp ; (++[MX () FRet0 (FTmp f)]) <$> feval e f} -- avoid clash with xmm0 (arg + ret) + | isI (eAnn e) = do {t <- newITemp; (++[CRet =: Tmp t]) <$> eval e t} -- avoid clash when calling functions + | isB (eAnn e) = do {t <- nBT; (++[MB () CBRet (Is t)]) <$> peval e t} + | isArr (eAnn e) = do {i <- newITemp; (l,r) <- aeval e i; pure$r++[CRet =: Tmp i]++case l of {Just m -> [RA () m]; Nothing -> []}} + | P [F,F] <- eAnn e = do {t <- newITemp; (_,_,_,p) <- πe e t; pure$Sa () t 16:p++[MX () FRet0 (FAt (Raw t 0 Nothing 8)), MX () FRet1 (FAt (Raw t 1 Nothing 8)), Pop () 16]} + | ty@P{} <- eAnn e, b64 <- bT ty, (n,0) <- b64 `quotRem` 8 = let b=ConstI b64 in do {t <- newITemp; a <- nextArr CRet; (_,_,ls,pl) <- πe e t; pure (Sa () t b:pl++MaΠ () a CRet b:CpyE () (TupM CRet (Just a)) (TupM t Nothing) (ConstI n) 8:Pop () b:RA () a:(RA ()<$>ls))} + +rtemp :: T a -> CM RT +rtemp F=FT<$>newFTemp; rtemp I=IT<$>newITemp; rtemp B=PT<$>nBT + +writeF :: E (T ()) + -> [Arg] + -> RT + -> CM (Maybe AL, [CS ()]) +writeF (Lam _ x e) (AA r l:rs) ret = do + modify (addAVar x (l,r)) + writeF e rs ret +writeF (Lam _ x e) (IPA r:rs) ret = do + modify (addVar x r) + writeF e rs ret +writeF (Lam _ x e) (FA fr:rs) ret = do + modify (addD x fr) + writeF e rs ret +writeF (Lam _ x e) (BA r:rs) ret = do + modify (addB x r) + writeF e rs ret +writeF e [] (IT r) | isArr (eAnn e) = aeval e r +writeF e [] (IT r) | isI (eAnn e) = (Nothing,)<$>eval e r +writeF e [] (IT r) | isΠR (eAnn e) = (\ ~(_,_,_,ss) -> (Nothing, ss))<$>πe e r +writeF e [] (FT r) = (Nothing,)<$>feval e r +writeF e [] (PT r) = (Nothing,)<$>peval e r + +m'p :: Maybe (CS (), CS ()) -> [CS ()] -> [CS ()] +m'p Nothing = id +m'p (Just (a,pop)) = (++[pop]).(a:) + +sas :: [Maybe (CS (), CS ())] -> [CS ()] -> [CS ()] +sas = thread.fmap m'p + +aS :: E (T ()) -> [(T (), Int64 -> ArrAcc)] -> T () -> (Int64 -> ArrAcc) -> CM ([CS ()], [Maybe (CS (), CS ())]) +aS f as rT rAt = do + (args, rArgs, pinchArgs) <- unzip3 <$> traverse (\(t,r) -> arg t (r$bT t)) as + (r, wR, pinch) <- rW rT (rAt$bT rT) + ss <- writeRF f args r + pure (rArgs++ss++[wR], pinch:pinchArgs) + +arg :: T () -> ArrAcc -> CM (RT, CS (), Maybe (CS (), CS ())) +arg ty at | isR ty = do + t <- rtemp ty + pure (t, mt at t, Nothing) +arg ty at | isΠ ty = do + slop <- newITemp + let sz=bT ty; slopE=ConstI sz + pure (IT slop, CpyE () (TupM slop Nothing) at 1 sz, Just (Sa () slop slopE, Pop () slopE)) + +rW :: T () -> ArrAcc -> CM (RT, CS (), Maybe (CS (), CS ())) +rW ty at | isR ty = do + t <- rtemp ty + pure (t, wt at t, Nothing) +rW ty at | isΠ ty = do + slopO <- newITemp + let sz=bT ty; slopE=ConstI sz + pure (IT slopO, CpyE () at (TupM slopO Nothing) 1 sz, Just (Sa () slopO slopE, Pop () slopE)) + +writeRF :: E (T ()) -> [RT] -> RT -> CM [CS ()] +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 + +mt :: ArrAcc -> RT -> CS () +mt p (IT t) = t =: EAt p +mt p (FT t) = MX () t (FAt p) +mt p (PT t) = MB () t (PAt p) + +wt :: ArrAcc -> RT -> CS () +wt p (IT t) = Wr () p (Tmp t) +wt p (FT t) = WrF () p (FTmp t) +wt p (PT t) = WrP () p (Is t) + +ra (FT f)=FA f; ra (IT r)=IPA r; ra (PT r)=BA r + +eeval :: E (T ()) -> RT -> CM [CS ()] +eeval e (IT t) = eval e t +eeval e (FT t) = feval e t +eeval e (PT t) = peval e t + +data RI a b = Cell a | Index b deriving Show + +part :: [RI a b] -> ([a], [b]) +part [] = ([], []) +part (Cell i:is) = first (i:) $ part is +part (Index i:is) = second (i:) $ part is + +diml :: (Temp, Maybe AL) -> [CE] -> [CS ()] +diml (t,l) ds = zipWith (\d i -> Wr () (ADim t (ConstI i) l) d) ds [0..] + +vSz :: Temp -> CE -> Int64 -> CM (AL, [CS ()]) +vSz t n sz = do {a <- nextArr t; pure (a, [Ma () a t 1 n sz, Wr () (ADim t 0 (Just a)) n])} + +v8 :: Temp -> CE -> CM (AL, [CS ()]) +v8 t n = vSz t n 8 + +plDim :: Int64 -> (Temp, Maybe AL) -> CM ([Temp], [CS ()]) +plDim rnk (a,l) = + unzip <$> traverse (\at -> do {dt <- newITemp; pure (dt, dt =: EAt at)}) [ ADim a (ConstI i) l | i <- [0..rnk-1] ] + +offByDim :: [Temp] -> CM ([Temp], [CS ()]) +offByDim dims = do + sts <- traverse (\_ -> newITemp) (undefined:dims) + let ss=zipWith3 (\s1 s0 d -> s1 =: (Tmp s0*Tmp d)) (tail sts) sts dims + pure (reverse sts, head sts =: 1:ss) + -- drop 1 for strides + +data Cell a b = Fixed -- set by the larger procedure + | Bound b -- to be iterated over + +forAll is bs = thread (zipWith g is bs) where + g t b@(ConstI i) | i > 0 = (:[]) . For1 () t 0 ILt b + 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 + (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]) + 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 ([], [], [], []) + +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 +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 + l <- neL + x <- newFTemp; y <- newFTemp + (_, ss) <- writeF e' [FA x] (FT y) + modify (addF n (l, [FA x], Left y)) + pure [C.Def () l ss] + +aeval :: E (T ()) -> Temp -> CM (Maybe AL, [CS ()]) +aeval (LLet _ b e) t = do + ss <- llet b + second (ss ++) <$> aeval e t +aeval (Var _ x) t = do + st <- gets avars + let (i, r) = {-# SCC "getA" #-} getT st x + pure (i, [t =: Tmp r]) +aeval (EApp ty (EApp _ (Builtin _ A.R) e0) e1) t | (F, ixs) <- tRnd ty = do + a <- nextArr t + (plE0,e0e) <- plD e0; (plE1,e1e) <- plD e1 + xR <- newFTemp; scaleR <- newFTemp; k <- newITemp + let rnk=fromIntegral(length ixs); n=product ixs + plRnd = [FRnd () xR, MX () xR (FTmp scaleR*FTmp xR+e0e), WrF () (AElem t rnk (Tmp k) (Just a) 8) (FTmp xR)] + loop=fors ty k 0 ILt (ConstI n) plRnd + pure (Just a, plE0 $ plE1 (Ma () a t rnk (ConstI n) 8:diml (t, Just a) (ConstI<$>ixs)++MX () scaleR (e1e-e0e):[loop])) +aeval (EApp ty (EApp _ (Builtin _ A.R) e0) e1) t | (I, ixs) <- tRnd ty = do + a <- nextArr t + scaleR <- newITemp; iR <- newITemp; k <- newITemp + (plE0,e0e) <- plC e0; (plE1,e1e) <- plC e1 + let rnk=fromIntegral$length ixs; n=product ixs + plRnd = [Rnd () iR, iR =: (Bin IRem (Tmp iR) (Tmp scaleR) + e0e), Wr () (AElem t rnk (Tmp k) (Just a) 8) (Tmp iR)] + loop=fors ty k 0 ILt (ConstI n) plRnd + pure (Just a, plE0$plE1$Ma () a t rnk (ConstI n) 8:diml (t, Just a) (ConstI<$>ixs)++scaleR=:(e1e-e0e+1):[loop]) +aeval (Builtin ty Eye) t | (I, ixs@[i,_]) <- tRnd ty = do + a <- nextArr t + td <- newITemp; k <- newITemp + let rnk=fromIntegral$length ixs; n=product ixs + loop = fors ty k 0 ILt (ConstI i) [Wr () (At td [ConstI i, 1] [Tmp k, Tmp k] (Just a) 8) (ConstI 1)] + pure (Just a, Ma () a t rnk (ConstI n) 8:diml (t, Just a) (ConstI<$>ixs)++[td=:DP t rnk, loop]) +aeval (EApp _ (Builtin _ AddDim) x) t | F <- eAnn x = do + xR <- newFTemp + plX <- feval x xR + (a,aV) <- v8 t 1 + pure (Just a, plX++aV++[WrF () (AElem t 1 0 (Just a) 8) (FTmp xR)]) +aeval (EApp _ (Builtin _ AddDim) x) t | I <- eAnn x = do + xR <- newITemp + plX <- eval x xR + (a,aV) <- v8 t 1 + pure (Just a, plX++aV++[Wr () (AElem t 1 0 (Just a) 8) (Tmp xR)]) +aeval (EApp _ (Builtin _ AddDim) x) t | P{} <- eAnn x = do + xR <- newITemp + (szs, mS, _, plX) <- πe x xR + let sz=last szs + (a,aV) <- vSz t 1 sz + pure (Just a, m'sa xR mS++plX++aV++[CpyE () (AElem t 1 0 (Just a) sz) (TupM xR Nothing) 1 sz]++m'pop mS) +aeval (EApp _ (Builtin _ AddDim) xs) t | (Arr sh ty) <- eAnn xs, nind ty = do + (plX, (lX, xR)) <- plA xs + let sz=bT ty + xRnk <- newITemp; szR <- newITemp; rnk <- newITemp + a <- nextArr t + 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]) +aeval (EApp _ (Builtin _ Flat) xs) t | (Arr sh ty) <- eAnn xs, nind ty = do + (plX, (lX, xR)) <- plA xs + let sz=bT ty + xRnk <- newITemp; szR <- newITemp + (a,aV) <- vSz t (Tmp szR) sz + pure (Just a, plX$xRnk=:eRnk sh (xR,lX):SZ () szR xR (Tmp xRnk) lX:aV++[CpyE () (AElem t 1 0 (Just a) sz) (AElem xR (Tmp xRnk) 0 lX sz) (Tmp szR) sz]) +aeval (EApp _ (EApp _ (Builtin _ Map) op) e) t | (Arrow tD tC) <- eAnn op, nind tD && nind tC = do + (plE, (l, xR)) <- plA e + iR <- newITemp; szR <- newITemp + let sz=bT tC + (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=:EAt (ADim xR 0 l):aV + ++sas pinches [loop]) +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 + a <- nextArr t + slopP <- newITemp; szR <- newITemp; slopSz <- newITemp + xd <- newITemp; i <- newITemp; k <- newITemp + (plX, (lX, xR)) <- plA xs + (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) + 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 + ++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 + (For () 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 + a <- nextArr t + x <- rtemp tD; 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) + (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] + pure (Just a, + plX$ + mt (AElem xR (ConstI xRnk) 0 lX 8) x + :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 + :[For () k 0 ILt (Tmp szX) step]) +aeval (EApp _ (EApp _ (Builtin _ Map) f) xs) t | Just (_, xRnk) <- tRnk (eAnn xs), Just ((ta0, rnk0), (ta1, rnk1)) <- mAA (eAnn f), Just sz0 <- bSz ta0, Just sz1 <- bSz ta1 = do + a <- nextArr t + slopP <- newITemp; y <- newITemp; y0 <- newITemp + szR <- newITemp; slopSz <- newITemp; szY <- newITemp + i <- newITemp; j <- newITemp; k <- newITemp; kL <- newITemp; xd <- newITemp; td <- newITemp + (plX, (lX, xR)) <- plA xs + (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)]] + 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 + ++xd=:DP xR (ConstI xRnk) + :CpyE () (AElem slopP (ConstI rnk0) 0 Nothing sz0) (Raw xd 0 lX sz0) (Tmp slopSz) sz0 + :ss0 + ++PlProd () szR (xDims++yDims) + :Ma () a t (ConstI oRnk) (Tmp szR) sz1 + :CpyD () (ADim t 0 (Just a)) (ADim xR 0 lX) dimsFromIn + :CpyD () (ADim t dimsFromIn (Just a)) (ADim y0 0 lY0) (ConstI rnk1) + :td=:DP t (ConstI oRnk) + :PlProd () szY yDims + :PlProd () kL xDims:i =: 0:j =: 0 + :For () 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, nind tX && nind tY = do + a <- nextArr t + rnkR <- newITemp; szR <- newITemp + i <- newITemp; xRd <- newITemp; tD <- newITemp + let szY=bT tY + (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, nind tX && nind tY && nind tC = do + a <- nextArr t + rnkR <- newITemp; szR <- newITemp + xRd <- newITemp; yRd <- newITemp; tD <- newITemp + (plX, (lX, xR)) <- plA xs; (plY, (lY, yR)) <- plA ys + let szC=bT tC + 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]) +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 + , nind tX && isIF yT && isIF tC = 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 + 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 + xSz=bT tX + (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] + (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) + ++[tϵ=:0 | tϵ <- complts] + ++mt (AElem xR (ConstI xRnk) 0 lX undefined) x + :sss + ++yRd =: DP yR (ConstI yRnk):slopPd =: DP slopP (ConstI slopRnk) + :place + ++ss + ++doss + ++PlProd () zSz (Tmp<$>dots) + :PlProd () oSz (Tmp<$>(zSz:oDims)) + :Ma () a t (ConstI oRnk) (Tmp oSz) 8 + :diml (t, Just a) (Tmp<$>(oDims++dots)) + ++ix=:0:it=:0:m'p pinch loop + ++[Pop () (Tmp slopE)]) +aeval (EApp _ (EApp _ (Builtin _ (Rank [(cr, Just ixs)])) f) xs) t | Just (tA, rnk) <- tRnk (eAnn xs) + , (Arrow _ tC) <- eAnn f + , nind tC && isIF 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 + di <- newITemp + (dts, dss) <- plDim rnk (xR, lX) + (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 + oRnk=rnk-fromIntegral cr; slopRnk=fromIntegral cr::Int64 + ySz=bT tC + (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 + 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) + ++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 + , (Arrow _ tCod) <- eAnn f + , Just (_, opRnk) <- tRnk tCod + , isIF tA = 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) + (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=xRnk+opRnk-slopRnk + (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 + 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] + (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) + ++[tϵ=:0 | tϵ <- complts] + ++sss + ++xRd=:DP xR (ConstI xRnk):slopPd=:DP slopP (ConstI slopRnk) + :place + ++ss + ++doss + ++PlProd () ySz (Tmp<$>dots) + :PlProd () oSz (Tmp<$>(ySz:oDims)) + :Ma () a t (ConstI oRnk) (Tmp oSz) 8 + :diml (t, Just a) (Tmp<$>(oDims++dots)) + ++it=:0:loop + ++[Pop () (Tmp slopE)] + ) +aeval (EApp _ (EApp _ (Builtin _ CatE) x) y) t | Just (ty, 1) <- tRnk (eAnn x) = do + xnR <- newITemp; ynR <- newITemp; tn <- newITemp + (a,aV) <- v8 t (Tmp tn) + let tyN=bT ty + (plX, (lX, xR)) <- plA x; (plY, (lY, yR)) <- plA y + pure (Just a, plX $ plY $ xnR =: EAt (ADim xR 0 lX):ynR =: EAt (ADim yR 0 lY):tn =: (Tmp xnR+Tmp ynR):aV++CpyE () (AElem t 1 0 (Just a) tyN) (AElem xR 1 0 lX tyN) (Tmp xnR) tyN:[CpyE () (AElem t 1 (Tmp xnR) (Just a) tyN) (AElem yR 1 0 lY tyN) (Tmp ynR) tyN]) +aeval (EApp ty (EApp _ (EApp _ (Builtin _ IRange) start) end) (ILit _ 1)) t = do + n <- newITemp; startR <- newITemp; endR <- newITemp + (a,aV) <- v8 t (Tmp n) + i <- newITemp + pStart <- eval start startR; pEnd <- eval end endR + let pN=n =: ((Tmp endR - Tmp startR)+1) + loop=for ty i 0 ILt (Tmp n) [Wr () (AElem t 1 (Tmp i) (Just a) 8) (Tmp startR), startR+=1] + pure (Just a, pStart++pEnd++pN:aV++[loop]) +aeval (EApp ty (EApp _ (EApp _ (Builtin _ IRange) start) end) incr) t = do + n <- newITemp; startR <- newITemp; endR <- newITemp; incrR <- newITemp + (a,aV) <- v8 t (Tmp n) + i <- newITemp + pStart <- eval start startR; pEnd <- eval end endR; pIncr <- eval incr incrR + 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) start) end) steps) t = do + i <- newITemp + startR <- newFTemp; incrR <- newFTemp; n <- newITemp + (a,aV) <- v8 t (Tmp n) + putStart <- feval start startR; putN <- eval steps n + putIncr <- feval ((end `eMinus` start) `eDiv` (EApp F (Builtin (Arrow I F) ItoF) steps `eMinus` FLit F 1)) incrR + let loop=for ty i 0 ILt (Tmp n) [WrF () (AElem t 1 (Tmp i) (Just a) 8) (FTmp startR), MX () startR (FTmp startR+FTmp incrR)] + pure (Just a, putStart++putIncr++putN++aV++[loop]) +aeval (EApp res (EApp _ (Builtin _ Cyc) xs) n) t | if1p res = do + i <- newITemp; nR <- newITemp; nO <- newITemp; szR <- newITemp + (a,aV) <- v8 t (Tmp nO) + (plX, (lX, xR)) <- plA xs + plN <- eval n nR + ix <- newITemp + let loop=for res i 0 ILt (Tmp nR) [CpyE () (AElem t 1 (Tmp ix) (Just a) 8) (AElem xR 1 0 lX 8) (Tmp szR) 8, ix+=Tmp szR] + pure (Just a, plX $ plN ++ szR =: EAt (ADim xR 0 lX):nO =: (Tmp szR*Tmp nR):aV++ix =: 0:[loop]) +aeval (EApp _ (EApp _ (Builtin _ VMul) a) x) t | Just (F, [m,n]) <- tIx$eAnn a, Just s <- cLog n = do + i <- newITemp; j <- newITemp; mR <- newITemp; nR <- newITemp; z <- newFTemp + (aL,aV) <- v8 t (Tmp mR) + (plAA, (lA, aR)) <- plA a; (plX, (lX, xR)) <- plA x + let loop = For () i 0 ILt (Tmp mR) + [ MX () z 0, + for (eAnn x) j 0 ILt (Tmp nR) + [ MX () z (FTmp z+FAt (AElem aR 2 (Bin IAsl (Tmp i) (ConstI s)+Tmp j) lA 8)*FAt (AElem xR 1 (Tmp j) lX 8)) ] + , WrF () (AElem t 1 (Tmp i) (Just aL) 8) (FTmp z) + ] + pure (Just aL, + plAA$ + plX$ + mR=:ConstI m + :aV + ++nR=:ConstI n + :[loop]) +aeval (EApp _ (EApp _ (Builtin _ VMul) (EApp _ (Builtin _ T) a)) x) t | f1 (eAnn x) = do + 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 + let loop = For () i 0 ILt (Tmp m) + [ MX () z 0, + for (eAnn x) 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) + ] + pure (Just aL, + plAA$ + plX$ + m=:EAt (ADim aR 1 lA) + :aV + ++n=:EAt (ADim xR 0 lX) + :[loop]) +aeval (EApp _ (EApp _ (Builtin _ VMul) a) x) t | f1 (eAnn x) = do + 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 + let loop = For () i 0 ILt (Tmp m) + [ MX () z 0, + for (eAnn x) 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) + ] + pure (Just aL, + plAA$ + plX$ + m=:EAt (ADim aR 0 lA) + :aV + ++n=:EAt (ADim xR 0 lX) + :[loop]) +aeval (EApp _ (EApp _ (Builtin _ Mul) (EApp _ (Builtin _ T) a)) b) t | Just (F, _) <- tRnk (eAnn a) = do + aL <- nextArr t + i <- newITemp; j <- newITemp; k <- newITemp; m <- newITemp; n <- newITemp; o <- newITemp; z <- newFTemp + (plAA, (lA, aR)) <- plA a + (plB, (lB, bR)) <- plA b + let loop=For () i 0 ILt (Tmp m) + [For () j 0 ILt (Tmp o) + [ MX () z 0, For () 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)] + ] + pure (Just aL, + plAA$ + plB$ + m=:EAt (ADim aR 1 lA):o=:EAt (ADim bR 1 lB) + :Ma () aL t 2 (Tmp m*Tmp o) 8:diml (t, Just aL) [Tmp m, Tmp o] + ++n=:EAt (ADim aR 0 lA) + :[loop]) +aeval (EApp _ (EApp _ (Builtin _ Mul) a) b) t | Just (F, _) <- tRnk (eAnn a) = do + aL <- nextArr t + i <- newITemp; j <- newITemp; k <- newITemp; m <- newITemp; n <- newITemp; o <- newITemp; z <- newFTemp + (plAA, (lA, aR)) <- plA a + (plB, (lB, bR)) <- plA b + let loop=For () i 0 ILt (Tmp m) + [For () j 0 ILt (Tmp o) + [ MX () z 0, For () 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)] + ] + pure (Just aL, + plAA$ + plB$ + m=:EAt (ADim aR 0 lA):o=:EAt (ADim bR 1 lB) + :Ma () aL t 2 (Tmp m*Tmp o) 8:diml (t, Just aL) [Tmp m, Tmp o] + ++n=:EAt (ADim bR 0 lB) + :[loop]) +aeval (EApp _ (EApp _ (Builtin _ ConsE) x) xs) t | tX <- eAnn x, isIF tX = do + xR <- rtemp tX + nR <- newITemp; nϵR <- newITemp + (a,aV) <- v8 t (Tmp nR) + plX <- eeval x xR + (plXs, (l, xsR)) <- plA xs + pure (Just a, plXs$plX++nϵR =: EAt (ADim xsR 0 l):nR =: (Tmp nϵR+1):aV++wt (AElem t 1 0 (Just a) 8) xR:[CpyE () (AElem t 1 1 (Just a) 8) (AElem xsR 1 0 l 8) (Tmp nϵR) 8]) +aeval (EApp _ (EApp _ (Builtin _ ConsE) x) xs) t | tX <- eAnn x, isΠ tX, sz <- bT tX = do + xR <- newITemp + nR <- newITemp; nϵR <- newITemp + (_, mSz, _, plX) <- πe x xR + (plXs, (lX, xsR)) <- plA xs + (a,aV) <- vSz t (Tmp nR) sz + pure (Just a, plXs$m'sa xR mSz++plX++nϵR =: EAt (ADim xsR 0 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 _ Snoc) x) xs) t | tX <- eAnn x, isIF tX = do + xR <- rtemp tX + nR <- newITemp; nϵR <- newITemp + (a,aV) <- v8 t (Tmp nR) + plX <- eeval x xR + (plXs, (l, xsR)) <- plA xs + pure (Just a, plXs$plX++nϵR =: EAt (ADim xsR 0 l):nR =: (Tmp nϵR+1):aV++wt (AElem t 1 (Tmp nϵR) (Just a) 8) xR:[CpyE () (AElem t 1 0 (Just a) 8) (AElem xsR 1 0 l 8) (Tmp nϵR) 8]) +aeval (EApp _ (EApp _ (Builtin _ Snoc) x) xs) t | tX <- eAnn x, isΠ tX, sz <- bT tX = do + xR <- newITemp + nR <- newITemp; nϵR <- newITemp + (_, mSz, _, plX) <- πe x xR + (plXs, (lX, xsR)) <- plA xs + (a,aV) <- vSz t (Tmp nR) sz + pure (Just a, plXs$m'sa xR mSz++plX++nϵR =: EAt (ADim xsR 0 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 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 + i <- newITemp + putN <- eval n nR; putX <- eeval x xR + let loop=for ty i 0 ILt (Tmp nR) [wt (AElem t 1 (Tmp i) (Just a) xSz) xR] + pure (Just a, putN++aV++putX++[loop]) +aeval (EApp ty (EApp _ (Builtin _ Re) n) x) t | tX <- eAnn x, isΠ tX, sz <- bT tX = do + xR <- newITemp; nR <- newITemp; k <- newITemp + plN <- eval n nR + (a,aV) <- vSz t (Tmp nR) sz + (_, mSz, _, plX) <- πe x xR + let loop = for ty k 0 ILt (Tmp nR) [CpyE () (AElem t 1 (Tmp k) (Just a) sz) (TupM xR Nothing) 1 sz] + pure (Just a, m'sa xR mSz++plX++plN++aV++loop:m'pop mSz) +aeval (EApp ty (EApp _ (Builtin _ Re) n) x) t | (Arr sh tO) <- eAnn x, sz <- bT tO = do + a <- nextArr t + nR <- newITemp; k <- newITemp + (plX, (lX, xR)) <- plA x + plN <- eval n nR + xRnk <- newITemp; oRnk <- 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] + 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) + :[loop]) +aeval (EApp oTy (Builtin _ Init) x) t | if1p oTy = do + nR <- newITemp + (a,aV) <- v8 t (Tmp nR) + (plX, (lX, xR)) <- plA x + pure (Just a, plX$nR =: (EAt (ADim xR 0 lX)-1):aV++[CpyE () (AElem t 1 0 (Just a) 8) (AElem xR 1 0 lX 8) (Tmp nR) 8]) +aeval (EApp oTy (Builtin _ Tail) x) t | if1p oTy = do + nR <- newITemp + (a,aV) <- v8 t (Tmp nR) + (plX, (lX, xR)) <- plA x + pure (Just a, plX$nR =: (EAt (ADim xR 0 lX)-1):aV++[CpyE () (AElem t 1 0 (Just a) 8) (AElem xR 1 1 lX 8) (Tmp nR) 8]) +aeval (EApp ty (EApp _ (EApp _ (Builtin _ Zip) op) xs) ys) t | (Arrow tX (Arrow tY tC)) <- eAnn op, nind tX && nind tY && nind tC = do + nR <- newITemp; i <- newITemp + let zSz=bT tC + (a,aV) <- vSz t (Tmp nR) zSz + (plEX, (lX, aPX)) <- plA xs; (plEY, (lY, aPY)) <- plA ys + (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 =: EAt (ADim aPX 0 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 + plS <- eeval seed acc + (a,aV) <- v8 t (Tmp n) + (plE, (l, aP)) <- plA e + 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 + loop=for (eAnn e) i 0 ILt (Tmp n) loopBody + pure (Just a, plE$plS++n =: (EAt (ADim aP 0 l)+1):aV++[loop]) +aeval (EApp _ (EApp _ (Builtin _ Scan) op) xs) t | (Arrow tAcc (Arrow tX _)) <- eAnn op, isIF tAcc && isIF tX = do + acc <- rtemp tAcc; x <- rtemp tX + i <- newITemp; n <- newITemp + (a,aV) <- v8 t (Tmp n) + (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 + loop=for1 (eAnn xs) i 1 ILeq (Tmp n) loopBody + pure (Just a, plE$n =: EAt (ADim aP 0 l):aV++mt (AElem aP 1 0 l 8) acc:[loop]) +aeval (EApp oTy (EApp _ (Builtin _ (DI n)) op) xs) t | Just ot <- if1 oTy, if1p (eAnn xs) = do + slopP <- newITemp + szR <- newITemp; sz'R <- newITemp; i <- newITemp + fR <- rtemp ot + (a,aV) <- v8 t (Tmp sz'R) + (_, ss) <- writeF op [AA slopP Nothing] fR + let szSlop=fromIntegral$16+8*n + (plX, (lX, aP)) <- plA xs + let sz'=Tmp szR-fromIntegral(n-1) + let loopBody=CpyE () (AElem slopP 1 0 Nothing 8) (AElem aP 1 (Tmp i) lX 8) (fromIntegral n) 8:ss++[wt (AElem t 1 (Tmp i) (Just a) 8) fR] + loop=for oTy i 0 ILt (Tmp sz'R) loopBody + pure (Just a, plX$szR =: EAt (ADim aP 0 lX):sz'R =: sz':aV++Sa () slopP szSlop:Wr () (ARnk slopP Nothing) 1:Wr () (ADim slopP 0 Nothing) (fromIntegral n):loop:[Pop () szSlop]) +aeval (EApp _ (EApp _ (Builtin _ Rot) n) xs) t | if1p (eAnn xs) = do + nR <- newITemp; c <- newITemp; szR <- newITemp + plN <- eval n nR + (plX, (lX, xsR)) <- plA xs + (a, aV) <- v8 t (Tmp szR) + pure (Just a, plX$plN++szR =: EAt (ADim xsR 0 lX):aV++Ifn't () (IRel IGeq (Tmp nR) 0) [nR+=Tmp szR]:c =: (Tmp szR-Tmp nR):[CpyE () (AElem t 1 0 (Just a) 8) (AElem xsR 1 (Tmp nR) lX 8) (Tmp c) 8, CpyE () (AElem t 1 (Tmp c) (Just a) 8) (AElem xsR 1 0 lX 8) (Tmp nR) 8]) +aeval (Id _ (AShLit ns es)) t | Just ws <- mIFs es = do + let rnk=fromIntegral$length ns + n <- nextAA + modify (addAA n (rnk:fmap fromIntegral ns++ws)) + pure (Nothing, [t =: LA n]) +aeval (EApp _ (Builtin _ T) x) t | Just (ty, ixes) <- tIx (eAnn x), rnk <- fromIntegral$length ixes, any (isJust.cLog) ixes = do + a <- nextArr t + let sze=bT ty; rnkE=ConstI rnk + xd <- newITemp; td <- newITemp + (plX, (lX, xR)) <- plA x + (dts, plDs) <- plDim rnk (xR, lX) + let n:sstrides = reverse $ scanl' (*) 1 (reverse ixes); _:dstrides=reverse $ scanl' (*) 1 ixes + is <- traverse (\_ -> newITemp) [1..rnk] + let loop=thread (zipWith (\i tt -> (:[]) . For () i 0 ILt (Tmp tt)) is dts) [CpyE () (At td (ConstI<$>dstrides) (Tmp<$>reverse is) (Just a) sze) (At xd (ConstI<$>sstrides) (Tmp<$>is) lX sze) 1 sze] + pure (Just a, plX$plDs++Ma () a t (ConstI rnk) (ConstI n) sze:diml (t, Just a) (Tmp<$>reverse dts)++xd=:DP xR rnkE:td=:DP t rnkE:loop) +aeval (EApp _ (Builtin _ T) x) t | Just (ty, rnk) <- tRnk (eAnn x) = do + a <- nextArr t + let sze=bT ty; dO=ConstI$8+8*rnk + xd <- newITemp; td <- newITemp + (plX, (l, xR)) <- plA x + (dts, plDs) <- plDim rnk (xR, l) + (sts, plSs) <- offByDim (reverse dts) + (std, plSd) <- offByDim dts + let n:sstrides = sts; (_:dstrides) = std + is <- traverse (\_ -> newITemp) [1..rnk] + let loop=thread (zipWith (\i tt -> (:[]) . For () i 0 ILt (Tmp tt)) is dts) [CpyE () (At td (Tmp<$>dstrides) (Tmp<$>reverse is) (Just a) sze) (At xd (Tmp<$>sstrides) (Tmp<$>is) l sze) 1 sze] + pure (Just a, plX$plDs++plSs++Ma () a t (ConstI rnk) (Tmp n) sze:diml (t, Just a) (Tmp<$>reverse dts)++init plSd++xd =: (Tmp xR+dO):td =: (Tmp t+dO):loop) +aeval (EApp _ (EApp _ (EApp _ (Builtin _ Outer) op) xs) ys) t | (Arrow tX (Arrow tY tC)) <- eAnn op, nind tX && nind tY && nind tC = do + a <- nextArr t + szX <- newITemp; szY <- newITemp; i <- newITemp; j <- newITemp; k <- newITemp + let zSz=bT tC + (plX, (lX, xR)) <- plA xs; (plY, (lY, yR)) <- plA ys + (step, pinches) <- aS op [(tX ,AElem xR 1 (Tmp i) lX), (tY, AElem yR 1 (Tmp j) lY)] tC (AElem t 2 (Tmp k) (Just a)) + let loop=for (eAnn xs) i 0 ILt (Tmp szX) [for (eAnn ys) j 0 ILt (Tmp szY) (step++[k+=1])] + pure (Just a, plX$plY$szX =: EAt (ADim xR 0 lX):szY =: EAt (ADim yR 0 lY):Ma () a t 2 (Tmp szX*Tmp szY) zSz:diml (t, Just a) [Tmp szX, Tmp szY]++k=:0:sas pinches [loop]) +aeval (EApp _ (EApp _ (EApp _ (Builtin _ Outer) op) xs) ys) t | (Arrow tX (Arrow tY tC)) <- eAnn op, Arr sh tEC <- tC, nind tX && nind tY && nind tEC = do + a <- nextArr t + szX <- newITemp; szY <- newITemp; szZ <- newITemp; i <- newITemp; j <- newITemp; k <- newITemp + rnkZ <- newITemp; rnkO <- newITemp + let szXT=bT tX; szYT=bT tY; szZT=bT tEC + z <- newITemp; z0 <- newITemp + (plX, (lX, xR)) <- plA xs; (plY, (lY, yR)) <- plA ys + (x, wX, pinchX) <- arg tX (AElem xR 1 (Tmp i) lX szXT) + (y, wY, pinchY) <- arg tY (AElem yR 1 (Tmp j) lY szYT) + (lZ0, ss0) <- writeF op [ra x, ra y] (IT z0) + (lZ, ss) <- writeF op [ra x, ra y] (IT z) + let step=[wX, wY]++ss++[CpyE () (AElem t (Tmp rnkO) (Tmp k*Tmp szZ) (Just a) szZT) (AElem z (Tmp rnkZ) 0 lZ szZT) (Tmp szZ) szZT, k+=1] + loop=for (eAnn xs) i 0 ILt (Tmp szX) [for (eAnn ys) j 0 ILt (Tmp szY) step] + pure (Just a, + plX$ + plY$ + i=:0:j=:0: + sas [pinchX, pinchY] ( + wX:wY:ss0 + ++rnkZ=:eRnk sh (z0,lZ0) + :rnkO=:(Tmp rnkZ+2) + :SZ () szZ z0 (Tmp rnkZ) lZ0 + :szX=:EAt (ADim xR 0 lX) + :szY=:EAt (ADim yR 0 lY) + :Ma () a t (Tmp rnkO) (Tmp szX*Tmp szY*Tmp szZ) szZT + :diml (t, Just a) [Tmp szX, Tmp szY] + ++[CpyD () (ADim t 2 (Just a)) (ADim z0 0 lZ0) (Tmp rnkZ), k=:0, loop] + )) +aeval (EApp ty (EApp _ (Builtin _ Succ) op) xs) t | Arrow tX (Arrow _ tZ) <- eAnn op, nind tX && nind tZ = do + szR <- newITemp; sz'R <- newITemp + let zSz=bT tZ + (a,aV) <- vSz t (Tmp sz'R) zSz + (plX, (lX, xR)) <- plA xs + i <- newITemp + (step, pinches) <- aS op [(tX, AElem xR 1 (Tmp i+1) lX), (tX, AElem xR 1 (Tmp i) lX)] tZ (AElem t 1 (Tmp i) (Just a)) + let loop=for ty i 0 ILt (Tmp sz'R) step + pure (Just a, plX$szR =: EAt (ADim xR 0 lX):sz'R =: (Tmp szR-1):aV++sas pinches [loop]) +aeval (EApp oTy (Builtin _ RevE) e) t | Just ty <- if1 oTy = do + n <- newITemp; i <- newITemp; o <- rtemp ty + (a,aV) <- v8 t (Tmp n) + (plE, (lE, eR)) <- plA e + let loop=for oTy i 0 ILt (Tmp n) [mt (AElem eR 1 (Tmp n-Tmp i-1) lE 8) o, wt (AElem t 1 (Tmp i) (Just a) 8) o] + pure (Just a, plE$n =: EAt (ADim eR 0 lE):aV++[loop]) +aeval (EApp oTy (EApp _ (EApp _ (Builtin _ Gen) seed) op) n) t | Just ty <- if1 oTy = do + nR <- newITemp; plN <- eval n nR; i <- newITemp + acc <- rtemp ty + plS <- eeval seed acc + (a,aV) <- v8 t (Tmp nR) + ss <- writeRF op [acc] acc + let loop=for oTy i 0 ILt (Tmp nR) (wt (AElem t 1 (Tmp i) (Just a) 8) 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 + 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) +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 + a <- nextArr t + xRd <- newITemp; szR <- newITemp; slopP <- newITemp + (plX, (lX, xR)) <- plA x + (dts, plDs) <- plDim xRnk (xR, lX) + (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 + rnk=ConstI oRnk + z <- rtemp tC; k <- newITemp; o <- rtemp tX + (_, ss) <- writeF f [AA slopP Nothing] z + (sts, plS) <- offByDim (reverse dts) + let _:strides = sts; sss=init plS + extrWindow = j=:0:forAll iw (ConstI . fromIntegral<$>is) + [mt (At xRd (Tmp<$>strides) (zipWith (\jϵ iϵ -> Tmp jϵ+Tmp iϵ) iw io) lX xSz) o, wt (AElem slopP (ConstI$fromIntegral slopRnk) (Tmp j) Nothing oSz) o, j+=1] + step = extrWindow++ss++[wt (AElem t rnk (Tmp k) (Just a) oSz) z, k+=1] + loop=forAll io (Tmp<$>tdims) step + pure (Just a, + plX$ + plDs + ++dims + ++sss + ++PlProd () szR (Tmp<$>tdims):Ma () a t rnk (Tmp szR) oSz:diml (t, Just a) (Tmp<$>tdims) + ++Sa () slopP slopE:Wr () (ARnk slopP Nothing) (ConstI$fromIntegral slopRnk):diml (slopP, Nothing) slopDims + ++xRd=:DP xR (ConstI xRnk):k=:0:loop + ++[Pop () slopE]) +aeval e _ = error (show e) + +plC :: E (T ()) -> CM ([CS ()] -> [CS ()], CE) +plC (ILit _ i) = pure (id, ConstI$fromIntegral i) +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) +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)} + +plP :: E (T ()) -> CM ([CS ()] -> [CS ()], PE) +plP (BLit _ b) = pure (id, BConst b) +plP (Var B x) = do {st <- gets pvars; pure (id, Is$getT st x)} +plP e = do {t <- nBT; pl <- peval e t; pure ((pl++), Is t)} + +plEV :: E (T ()) -> CM ([CS ()] -> [CS ()], Temp) +plEV (Var I x) = do + st <- gets vars + pure (id, getT st x) +plEV e = do + t <- newITemp + pl <- eval e t + pure ((pl++), t) + +plF :: E (T ()) -> CM ([CS ()] -> [CS ()], FTemp) +plF (Var F x) = do + st <- gets dvars + pure (id, getT st x) +plF e = do + t <- newFTemp + pl <- feval e t + pure ((pl++), t) + +plA :: E (T ()) -> CM ([CS ()] -> [CS ()], (Maybe AL, Temp)) +plA (Var _ x) = do {st <- gets avars; pure (id, getT st x)} +plA e = do {t <- newITemp; (lX,plX) <- aeval e t; pure ((plX++), (lX, t))} + +peval :: E (T ()) -> BTemp -> CM [CS ()] +peval (BLit _ b) t = pure [MB () t (BConst b)] +peval (EApp _ (Builtin _ Odd) e0) t = do + (pl,eR) <- plEV e0 + pure $ pl [Cset () (IUn IOdd (Tmp eR)) t] +peval (EApp _ (Builtin _ Even) e0) t = do + (pl,eR) <- plEV e0 + pure $ pl [Cset () (IUn IEven (Tmp eR)) t] +peval (EApp _ (EApp _ (Builtin (Arrow I _) op) e0) e1) t | Just iop <- rel op = do + (plE0,e0e) <- plC e0; (plE1, e1e) <- plC e1 + pure $ plE0 $ plE1 [Cset () (IRel iop e0e e1e) t] +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 _ 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)] +peval (EApp _ (Builtin _ N) e0) t = do + (pl,e0R) <- plP e0 + 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 + (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 =: EAt (ADim aP 0 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 + (plE, (l, aP)) <- plA e + plAcc <- peval seed acc + ss <- writeRF op [PT acc, x] (PT acc) + let loopBody=mt (AElem aP 1 (Tmp i) l szY) x:ss + loop=for (eAnn e) i 0 ILt (Tmp szR) loopBody + pure $ plE $ plAcc++szR=:EAt (ADim aP 0 l):[loop] + +eval :: E (T ()) -> Temp -> CM [CS ()] +eval (LLet _ b e) t = do + ss <- llet b + (ss++) <$> eval e t +eval (ILit _ n) t = pure [t =: fromInteger n] +eval (Var _ x) t = do + st <- gets vars + pure [t =: Tmp (getT st x)] +eval (EApp _ (EApp _ (Builtin _ A.R) e0) e1) t = do + (plE0,e0e) <- plC e0; (plE1,e1e) <- plC e1 + pure $ plE0 $ plE1 [Rnd () t, t =: (Bin IRem (Tmp t) (e1e-e0e+1) + e0e)] +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 + (plE, (l, eR)) <- plA e + plAcc <- eval seed acc + 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 =: EAt (ADim eR 0 l):[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] +eval (EApp _ (EApp _ (Builtin _ Max) e0) e1) t = do + (pl0,t0) <- plEV e0 + -- in case t==t1 + t1 <- newITemp + pl1 <- eval e1 t1 + pure $ pl0 $ pl1 ++ [t =: Tmp t0, Cmov () (IRel IGt (Tmp t1) (Tmp t0)) t (Tmp t1)] +eval (EApp _ (EApp _ (Builtin _ Min) e0) e1) t = do + (pl0,t0) <- plEV e0 + -- in case t==t1 + t1 <- newITemp + pl1 <- eval e1 t1 + pure $ pl0 $ pl1 ++ [t =: Tmp t0, Cmov () (IRel ILt (Tmp t1) (Tmp t0)) t (Tmp t1)] +eval (EApp _ (EApp _ (Builtin _ A1) e) i) t = do + (plE, (lE, eR)) <- plA e + (plI,iE) <- plC i + pure $ plE $ plI [t =: EAt (AElem eR 1 iE lE 8)] +eval (EApp _ (Builtin _ Head) xs) t = do + (plX, (l, a)) <- plA xs + pure $ plX [t =: EAt (AElem a 1 0 l 8)] +eval (EApp _ (Builtin _ Last) xs) t = do + (plX, (l, a)) <- plA xs + pure $ plX [t =: EAt (AElem a 1 (EAt (ADim a 0 l)-1) l 8)] +eval (EApp _ (Builtin _ Size) xs) t | Just (_, 1) <- tRnk (eAnn xs) = do + (plE, (l, xsR)) <- plA xs + pure $ plE [t =: EAt (ADim xsR 0 l)] +eval (EApp _ (Builtin _ Dim) xs) t | Arr (Ix _ i `Cons` _) _ <- eAnn xs = do + pure [t=:ConstI (fromIntegral i)] +eval (EApp _ (Builtin _ Dim) xs) t = do + (plE, (l, xsR)) <- plA xs + pure $ plE [t =: EAt (ADim xsR 0 l)] +eval (EApp _ (Builtin _ Size) xs) t | Arr sh _ <- eAnn xs = do + (plE, (l, xsR)) <- plA xs + rnkR <- newITemp + pure $ plE [rnkR =: eRnk sh (xsR,l), SZ () t xsR (Tmp rnkR) l] +eval (EApp _ (Builtin _ Floor) x) t = do + xR <- newFTemp + plX <- feval x xR + pure $ plX ++ [t =: CFloor (FTmp xR)] +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 +eval (EApp _ (EApp _ (Builtin _ IOf) p) xs) t | (Arrow tD _) <- eAnn p, nind tD = do + pR <- nBT + szR <- newITemp; i <- newITemp; done <- newITemp + (plX, (lX, xsR)) <- plA xs + let szX=bT tD + (x, wX, pinch) <- arg tD (AElem xsR 1 (Tmp i) lX szX) + ss <- writeRF p [x] (PT pR) + let loop=While () done INeq 1 (wX:ss++[If () (Is pR) [t=:Tmp i, done=:1] [], i+=1, Cmov () (IRel IGeq (Tmp i) (Tmp szR)) done 1]) + pure $ plX $ szR=:EAt (ADim xsR 0 lX):t=:(-1):done=:0:i=:0:m'p pinch [loop] +eval (EApp _ (EApp _ (EApp _ (Builtin _ Iter) f) n) x) t = do + (plN,nR) <- plC n + plX <- eval x t + ss <- writeRF f [IT t] (IT t) + i <- newITemp + let loop=For () i 0 ILt nR ss + pure $ plX++plN [loop] +eval (Cond _ p e0 e1) t = snd <$> cond p e0 e1 (IT t) +eval (Id _ (FoldOfZip zop op [p])) acc | Just tP <- if1 (eAnn p) = do + x <- rtemp tP + szR <- newITemp + i <- newITemp + (plPP, (lP, pR)) <- plA p + ss <- writeRF op [IT acc, x] (IT acc) + let step = mt (AElem pR 1 (Tmp i) lP 8) x:ss + loop = for1 (eAnn p) i 1 ILt (Tmp szR) step + sseed <- writeRF zop [x] (IT acc) + pure $ plPP$szR =: EAt (ADim pR 0 lP):mt (AElem pR 1 0 lP 8) x:sseed++[loop] +eval (Id _ (FoldOfZip zop op [p, q])) acc | Just tP <- if1 (eAnn p), Just tQ <- if1 (eAnn q) = do + x <- rtemp tP; y <- rtemp tQ + szR <- newITemp + i <- newITemp + (plPP, (lP, pR)) <- plA p; (plQ, (lQ, qR)) <- plA q + ss <- writeRF op [IT acc, x, y] (IT acc) + let step = mt (AElem pR 1 (Tmp i) lP 8) x:mt (AElem qR 1 (Tmp i) lQ 8) y:ss + loop = for1 (eAnn p) i 1 ILt (Tmp szR) step + seed <- writeRF zop [x,y] (IT acc) + pure $ plPP$plQ$szR =: EAt (ADim pR 0 lP):mt (AElem pR 1 0 lP 8) x:mt (AElem qR 1 0 lQ 8) y:seed++[loop] +eval e _ = error (show e) + +frel :: Builtin -> Maybe FRel +frel Gte=Just FGeq; frel Lte=Just FLeq; frel Eq=Just FEq; frel Neq=Just FNeq; frel Lt=Just FLt; frel Gt=Just FGt; frel _=Nothing + +mFop :: Builtin -> Maybe FBin +mFop Plus=Just FPlus; mFop Times=Just FTimes; mFop Minus=Just FMinus; mFop Div=Just FDiv; mFop Exp=Just FExp; mFop Max=Just FMax; mFop Min=Just FMin; mFop _=Nothing + +mB :: Builtin -> Maybe BBin +mB And=Just AndB;mB Or=Just OrB;mB Xor=Just XorB; mB _=Nothing + +mOp :: Builtin -> Maybe IBin +mOp Plus=Just IPlus;mOp Times=Just ITimes;mOp Minus=Just IMinus; mOp Mod=Just IRem; mOp Sl=Just IAsl;mOp Sr=Just IAsr;mOp a=BI<$>mB a + +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 (FLit _ d) = Just (pure $ ConstF d) +mFEval (Var _ x) = Just $ do + st <- gets dvars + pure (FTmp (getT st x)) +mFEval _ = Nothing + +cond :: E (T ()) -> E (T ()) -> E (T ()) -> RT -> CM (Maybe AL, [CS ()]) +cond (EApp _ (EApp _ (Builtin (Arrow F _) op) c0) c1) e e1 (FT t) | Just cmp <- frel op, Just cfe <- mFEval e1 = do + c0R <- newFTemp; c1R <- newFTemp + plC0 <- feval c0 c0R; plC1 <- feval c1 c1R + eR <- newFTemp; fe <- cfe + plE <- feval e eR + pure (Nothing, plC0 ++ plC1 ++ [MX () t fe] ++ plE ++ [Fcmov () (FRel cmp (FTmp c0R) (FTmp c1R)) t (FTmp eR)]) +cond (EApp _ (EApp _ (Builtin (Arrow F _) o) c0) c1) e0 e1 t | Just f <- frel o, isIF (eAnn e0) = do + c0R <- newFTemp; c1R <- newFTemp + plC0 <- feval c0 c0R; plC1 <- feval c1 c1R + plE0 <- eeval e0 t; plE1 <- eeval e1 t + pure (Nothing, plC0 ++ plC1 ++ [If () (FRel f (FTmp c0R) (FTmp c1R)) plE0 plE1]) +cond (EApp _ (EApp _ (Builtin (Arrow I _) op) c0) c1) e e1 (FT t) | Just cmp <- rel op, Just cfe <- mFEval e1 = do + c0R <- newITemp + plC0 <- eval c0 c0R + (plC1,c1e) <- plC c1 + eR <- newFTemp; fe <- cfe + plE <- feval e eR + pure (Nothing, plC0 ++ plC1 ([MX () t fe] ++ plE ++ [Fcmov () (IRel cmp (Tmp c0R) c1e) t (FTmp eR)])) +cond (EApp _ (EApp _ (Builtin (Arrow I _) op) c0) c1) e0 e1 t | Just cmp <- rel op, isIF (eAnn e0) = do + c0R <- newITemp; c1R <- newITemp + plC0 <- eval c0 c0R; plC1 <- eval c1 c1R + plE0 <- eeval e0 t; plE1 <- eeval e1 t + pure (Nothing, plC0 ++ plC1 ++ [If () (IRel cmp (Tmp c0R) (Tmp c1R)) plE0 plE1]) +cond p e0 e1 t | isIF (eAnn e0) = do + pR <- nBT + plPP <- peval p pR; plE0 <- eeval e0 t; plE1 <- eeval e1 t + pure (Nothing, plPP ++ [If () (Is pR) plE0 plE1]) + +feval :: E (T ()) -> FTemp -> CM [CS ()] +feval (LLet _ b e) t = do + ss <- llet b + (ss++) <$> feval e t +feval (ILit _ x) t = pure [MX () t (ConstF $ fromIntegral x)] -- if it overflows you deserve it +feval (FLit _ x) t = pure [MX () t (ConstF x)] +feval (Var _ x) t = do + st <- gets dvars + pure [MX () t (FTmp $ getT st x)] +feval (EApp _ (EApp _ (Builtin _ A.R) (FLit _ 0)) (FLit _ 1)) t = pure [FRnd () t] +feval (EApp _ (EApp _ (Builtin _ A.R) (FLit _ 0)) e1) t = do + (plE1,e1e) <- plD e1 + pure $ plE1 [FRnd () t, MX () t (FTmp t*e1e)] +feval (EApp _ (EApp _ (Builtin _ A.R) e0) e1) t = do + (plE0,e0e) <- plD e0; (plE1, e1e) <- plD e1 + pure $ plE0 $ plE1 [FRnd () t, MX () t ((e1e-e0e)*FTmp t+e0e)] +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 _ 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))] +feval (EApp _ (EApp _ (Builtin _ IntExp) (FLit _ (-1))) n) t = do + (plR,nR) <- plEV n + pure $ plR [MX () t 1, Fcmov () (IUn IOdd (Tmp nR)) t (ConstF (-1))] +feval (EApp _ (EApp _ (Builtin _ IntExp) x) n) t = do + xR <- newFTemp; nR <- newITemp + plX <- feval x xR; plN <- eval n nR + pure $ plX ++ plN ++ [MX () t 1, While () nR IGt 0 [Ifn't () (IUn IEven (Tmp nR)) [MX () t (FTmp t*FTmp xR)], nR =: Bin IAsr (Tmp nR) 1, MX () xR (FTmp xR*FTmp xR)]] +feval (EApp _ (Builtin _ f) e) t | Just ff <- mFun f = do + (plE,eC) <- plD e + pure $ plE [MX () t (FUn ff eC)] +feval (EApp _ (Builtin _ Neg) x) t = do + (plE,f) <- plD x + pure $ plE [MX () t (negate f)] +feval (EApp _ (Builtin _ ItoF) e) t = do + (pl,iE) <- plC e + pure $ pl [MX () t (IE iE)] +feval (Cond _ p e0 e1) t = snd <$> cond p e0 e1 (FT t) +feval (EApp _ (Builtin _ Head) xs) t = do + (plX, (l, a)) <- plA xs + pure $ plX [MX () t (FAt (AElem a 1 0 l 8))] +feval (EApp _ (EApp _ (Builtin _ A1) e) i) t = do + (plE, (lE, eR)) <- plA e; (plI, iR) <- plC i + pure $ plE $ plI [MX () t (FAt (AElem eR 1 iR lE 8))] +feval (EApp _ (Builtin _ Last) xs) t = do + (plX, (l, a)) <- plA xs + pure $ plX [MX () t (FAt (AElem a 1 (EAt (ADim a 0 l)-1) l 8))] +feval (Id _ (FoldOfZip zop op [p])) acc | Just tP <- if1 (eAnn p) = do + x <- rtemp tP + szR <- newITemp + i <- newITemp + (plPP, (lP, pR)) <- plA p + ss <- writeRF op [FT acc, x] (FT acc) + let step = mt (AElem pR 1 (Tmp i) lP 8) x:ss + loop = for1 (eAnn p) i 1 ILt (Tmp szR) step + sseed <- writeRF zop [x] (FT acc) + pure $ plPP$szR =: EAt (ADim pR 0 lP):mt (AElem pR 1 0 lP 8) x:sseed++[loop] +feval (Id _ (FoldOfZip zop op [EApp _ (EApp _ (EApp _ (Builtin _ FRange) (FLit _ start)) (FLit _ end)) (ILit _ steps), ys])) acc | Just tQ <- if1 (eAnn ys) = do + x <- newFTemp; y <- rtemp tQ + incrR <- newFTemp; i <- newITemp + plY <- eeval (EApp tQ (Builtin undefined Head) ys) y + (plYs, (lY, yR)) <- plA ys + plIncr <- feval (FLit F$(end-start)/realToFrac (steps-1)) incrR + seed <- writeRF zop [FT x, y] (FT acc) + ss <- writeRF op [FT acc, FT x, y] (FT acc) + pure $ plYs $ plY ++ MX () x (ConstF start):seed ++ plIncr ++ [for1 (eAnn ys) i 1 ILt (ConstI$fromIntegral steps) (mt (AElem yR 1 (Tmp i) lY 8) y:MX () x (FTmp x+FTmp incrR):ss)] +feval (Id _ (FoldOfZip zop op [EApp _ (EApp _ (EApp _ (Builtin _ FRange) start) end) steps, ys])) acc | Just tQ <- if1 (eAnn ys) = do + x <- newFTemp; y <- rtemp tQ + incrR <- newFTemp; n <- newITemp; i <- newITemp + plX <- feval start x; plY <- eeval (EApp tQ (Builtin undefined Head) ys) y + (plYs, (lY, yR)) <- plA ys + plN <- eval steps n + plIncr <- feval ((end `eMinus` start) `eDiv` (EApp F (Builtin (Arrow I F) ItoF) steps `eMinus` FLit F 1)) incrR + seed <- writeRF zop [FT x, y] (FT acc) + ss <- writeRF op [FT acc, FT x, y] (FT acc) + pure $ plYs $ plY ++ plX ++ seed ++ plIncr ++ plN ++ [for1 (eAnn ys) i 1 ILt (Tmp n) (mt (AElem yR 1 (Tmp i) lY 8) y:MX () x (FTmp x+FTmp incrR):ss)] +feval (Id _ (FoldOfZip zop op [EApp _ (EApp _ (EApp _ (Builtin _ IRange) start) _) incr, ys])) acc | Just tQ <- if1 (eAnn ys) = do + x <- newITemp; y <- rtemp tQ + szR <- newITemp; i <- newITemp + plX <- eval start x; plY <- eeval (EApp tQ (Builtin undefined Head) ys) y + (plYs, (lY, yR)) <- plA ys + (plI,iE) <- plC incr + seed <- writeRF zop [IT x, y] (FT acc) + ss <- writeRF op [FT acc, IT x, y] (FT acc) + pure $ plYs $ plY ++ plX ++ seed ++ plI (szR =: EAt (ADim yR 0 lY):[for1 (eAnn ys) i 1 ILt (Tmp szR) (mt (AElem yR 1 (Tmp i) lY 8) y:x+=iE:ss)]) +feval (Id _ (FoldOfZip zop op [p, q])) acc | Just tP <- if1 (eAnn p), Just tQ <- if1 (eAnn q) = do + x <- rtemp tP; y <- rtemp tQ + szR <- newITemp + i <- newITemp + (plPP, (lP, pR)) <- plA p; (plQ, (lQ, qR)) <- plA q + ss <- writeRF op [FT acc, x, y] (FT acc) + let step = mt (AElem pR 1 (Tmp i) lP 8) x:mt (AElem qR 1 (Tmp i) lQ 8) y:ss + loop = for1 tP i 1 ILt (Tmp szR) step + seed <- writeRF zop [x,y] (FT acc) + pure $ plPP$plQ$szR =: EAt (ADim pR 0 lP):mt (AElem pR 1 0 lP 8) x:mt (AElem qR 1 0 lQ 8) y:seed++[loop] +feval (EApp _ (EApp _ (Builtin _ Fold) op) e) acc | (Arrow tX _) <- eAnn op, isF tX = do + x <- newFTemp + szR <- newITemp + i <- newITemp + (plE, (l, aP)) <- plA e + ss <- writeRF op [FT acc, FT x] (FT acc) + let loopBody=MX () x (FAt (AElem aP 1 (Tmp i) l 8)):ss + loop=for1 (eAnn e) i 1 ILt (Tmp szR) loopBody + pure $ plE$szR =: EAt (ADim aP 0 l):MX () acc (FAt (AElem aP 1 0 l 8)):[loop] +feval (EApp _ (EApp _ (EApp _ (Builtin _ Foldl) op) seed) e) acc | (Arrow _ (Arrow tX _)) <- eAnn op, isIF tX = do + x <- rtemp tX + i <- newITemp + (plE, (l, eR)) <- plA e + plAcc <- feval seed acc + ss <- writeRF op [x, FT acc] (FT acc) + 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 =: (EAt (ADim eR 0 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 + 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] +feval (EApp _ (EApp _ (EApp _ (Builtin _ FoldS) op) seed) (EApp _ (EApp _ (EApp _ (Builtin _ IRange) start) end) incr)) acc = do + i <- newITemp + endR <- newITemp + (plI,iE) <- plC incr + plStart <- eval start i; plAcc <- feval seed acc; plEnd <- eval end endR + ss <- writeRF op [FT acc, IT i] (FT acc) + pure $ plStart ++ plAcc ++ plEnd ++ plI [While () i ILeq (Tmp endR) (ss++[i+=iE])] +feval (EApp _ (EApp _ (EApp _ (Builtin _ FoldS) op) seed) (EApp ty (EApp _ (EApp _ (Builtin _ FRange) start) end) nSteps)) acc = do + i <- newITemp; startR <- newFTemp; incrR <- newFTemp; xR <- newFTemp; endI <- newITemp + plStart <- feval start startR + plAcc <- feval seed acc + plEnd <- eval nSteps endI + 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 + szR <- newITemp + i <- newITemp + (plE, (l, eR)) <- plA e + plAcc <- feval seed acc + ss <- writeRF op [FT acc, x] (FT 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 =: EAt (ADim eR 0 l):[loop] +feval (EApp _ (EApp _ (EApp _ (Builtin _ Iter) f) n) x) t = do + (plN,nR) <- plC n + plX <- feval x t + ss <- writeRF f [FT t] (FT t) + i <- newITemp + let loop=For () i 0 ILt nR ss + pure $ plX ++ plN [loop] +feval (EApp _ (Builtin _ (TAt i)) e) t = do + 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 + st <- gets fvars + let (l, [FA a], Left r) = getT st f + plX <- feval x a + retL <- neL + pure $ plX ++ [G () l retL, MX () t (FTmp r)] +feval (Id _ (FoldGen seed g f n)) t = do + x <- newFTemp; acc <- newFTemp + nR <- newITemp; k <- newITemp + (plSeed,seedR) <- plF seed + plN <- eval n nR + uss <- writeRF g [FT x] (FT x) + fss <- writeRF f [FT acc, FT x] (FT acc) + pure $ plSeed $ plN++[MX () acc (FTmp seedR), MX () x (FTmp seedR), For () k 0 ILt (Tmp nR) (fss++uss), MX () t (FTmp acc)] +feval e _ = error (show e) + +m'pop :: Maybe CE -> [CS ()] +m'pop = maybe [] ((:[]).Pop ()) + +m'sa :: Temp -> Maybe CE -> [CS ()] +m'sa t = maybe [] ((:[]).Sa () t) + +πe :: E (T ()) -> Temp -> CM ([Int64], Maybe CE, [AL], [CS ()]) -- element offsets, size to be popped off the stack, array labels kept live +πe (EApp (P tys) (Builtin _ Head) xs) t | offs <- szT tys, sz <- last offs, szE <- ConstI sz = do + xR <- newITemp + (lX, plX) <- aeval xs xR + pure (offs, Just szE, [], plX++[CpyE () (TupM t Nothing) (AElem xR 1 0 lX sz) 1 sz]) +πe (EApp (P tys) (Builtin _ Last) xs) t | offs <- szT tys, sz <- last offs, szE <- ConstI sz = do + xR <- newITemp + (lX, plX) <- aeval xs xR + pure (offs, Just szE, [], plX++[CpyE () (TupM t Nothing) (AElem xR 1 (EAt (ADim xR 0 lX)-1) lX sz) 1 sz]) +πe (Tup (P tys) es) t | offs <- szT tys, sz <- last offs, szE <- ConstI sz = do + (ls, ss) <- unzip <$> + zipWithM (\e off -> + case eAnn e of + F -> do {(plX, f) <- plD e; pure (Nothing, plX [WrF () (Raw t (ConstI off) Nothing 1) f])} + I -> do {(plX, i) <- plC e; pure (Nothing, plX [Wr () (Raw t (ConstI off) Nothing 1) i])} + B -> do {(plX, r) <- plP e; pure (Nothing, plX [WrP () (Raw t (ConstI off) Nothing 1) r])} + Arr{} -> do {(pl, (l, r)) <- plA e; pure (l, pl [Wr () (Raw t (ConstI off) Nothing 1) (Tmp r)])}) es offs + pure (offs, Just szE, catMaybes ls, concat ss) +πe (EApp (P tys) (EApp _ (Builtin _ A1) e) i) t | offs <- szT tys, sz <- last offs, szE <- ConstI sz = do + xR <- newITemp; iR <- newITemp + (lX, plX) <- aeval e xR; plI <- eval i iR + pure (offs, Just szE, mempty, plX ++ plI ++ [CpyE () (TupM t Nothing) (AElem xR 1 (Tmp iR) lX sz) 1 sz]) +πe (Var (P tys) x) t = do + st <- gets vars + pure (szT tys, Nothing, undefined, [t =: Tmp (getT st x)]) +πe (LLet _ b e) t = do + ss <- llet b + fourth (ss++) <$> πe e t +πe (EApp _ (EApp _ (EApp _ (Builtin _ Iter) f) n) x) t = do + pre <- newITemp + ttemp <- newITemp + (plN,nR) <- plC n + (offs, mSz, _, plX) <- πe x pre + let sz=last offs; szE=ConstI sz + (_, ss) <- writeF f [IPA pre] (IT t) + i <- newITemp + let loop=For () i 0 ILt nR (ss++[CpyE () (TupM ttemp Nothing) (TupM t Nothing) 1 sz, CpyE () (TupM pre Nothing) (TupM ttemp Nothing) 1 sz]) + pure (offs, Just szE, [], m'sa pre mSz++plX++plN [Sa () ttemp szE, loop, Pop () szE]++m'pop mSz) +πe e _ = error (show e) + +fourth f ~(x,y,z,w) = (x,y,z,f w) + +qmap f g h k ~(x,y,z,w) = (f x, g y, h z, k w) diff --git a/src/CF.hs b/src/CF.hs new file mode 100644 --- /dev/null +++ b/src/CF.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module CF ( ControlAnn (..) + , UD (..) + , Liveness (..) + , NLiveness (..) + , Live (..) + ) where + +import qualified Data.IntSet as IS +import Prettyprinter (Pretty (pretty), braces, punctuate, (<+>)) + +data Liveness = Liveness { ins, out, fins, fout :: !IS.IntSet } deriving Eq + +data NLiveness = NLiveness { nx :: Int, liveness :: !Liveness } + +data Live = Live { new, done, fnew, fdone :: !IS.IntSet } + +instance Pretty Liveness where + pretty (Liveness is os fis fos) = pretty (Live is os fis fos) + +instance Pretty Live where + pretty (Live is os fis fos) = braces (pp (is<>fis) <+> ";" <+> pp (os<>fos)) + where pp = mconcat . punctuate "," . fmap pretty . IS.toList + +-- | Control-flow annotations +data ControlAnn = ControlAnn { node :: !Int + , conn :: [Int] + , ud :: !UD + } + +data UD = UD { usesNode, usesFNode, defsNode, defsFNode :: !IS.IntSet } diff --git a/src/CF/AL.hs b/src/CF/AL.hs new file mode 100644 --- /dev/null +++ b/src/CF/AL.hs @@ -0,0 +1,9 @@ +module CF.AL (AL (..), insert, singleton, sinsert) where + +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS + +newtype AL=AL Int + +insert (AL i) = IM.insert i; sinsert (AL i) = IS.insert i +singleton (AL i) = IS.singleton i diff --git a/src/CGen.hs b/src/CGen.hs new file mode 100644 --- /dev/null +++ b/src/CGen.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} + +module CGen (CType(..), TTE(..), tCTy, pCty) where + +import A +import Control.Exception (Exception) +import Data.Bifunctor (first) +import qualified Data.Text as T +import Prettyprinter (Doc, Pretty (..), braces, parens, tupled, (<+>)) +import Prettyprinter.Ext + +data CType = CR | CI | CB | Af | Ai | Ab + +instance Pretty CType where + pretty CR="F"; pretty CI="J"; pretty CB="B"; pretty Af="Af"; pretty Ai="Ai"; pretty Ab="Ab" + +data CF = CF !T.Text [CType] CType + +instance Pretty CF where + pretty (CF n ins out) = + 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 + (foldMap d args + <> pretty out <+> "res" <> "=" <> ax out (pretty n<>tupled (l.snd<$>args))<>";" + <> foldMap f args + <> "R res;") + where px CR="F"; px CI="J"; px CB="B"; px _="U" + ax Af=("poke_af"<>).parens;ax Ai=("poke_ai"<>).parens;ax Ab=error "not implemented.";ax _=id + d (t,var) = px t <+> l var <> "=" <> ax t (pretty var) <> ";" + f (Af,var) = "free" <> parens (l var) <> ";" + f (Ai,var) = "free" <> parens (l var) <> ";" + f (Ab,var) = "free" <> parens (l var) <> ";" + f _ = mempty + l var = "_" <> pretty var + +-- type translation error +data TTE = HO | Poly | FArg | ArrFn deriving Show + +instance Pretty TTE where + pretty HO = "Higher order"; pretty Poly = "Too polymorphic"; pretty FArg = "Function as argument"; pretty ArrFn = "Arrays of functions are not supported." + +pCty :: T.Text -> T a -> Either TTE (Doc ann) +pCty nm t = ("#include" <#>) . pretty <$> nmtCTy nm t + +nmtCTy :: T.Text -> T a -> Either TTE CF +nmtCTy nm t = do{(ins,out) <- irTy (rLi t); CF nm<$>traverse cTy ins<*>cTy out} + +tCTy :: T a -> Either TTE ([CType], CType) +tCTy t = do{(ins,out) <- irTy (rLi t); (,)<$>traverse cTy ins<*>cTy out} + +cTy :: T a -> Either TTE CType +cTy F = pure CR +cTy I = pure CI +cTy B = pure CB +cTy (Arr _ F) = pure Af +cTy (Arr _ I) = pure Ai +cTy (Arr _ B) = pure Ab +cTy (Arrow Arrow{} _) = Left FArg +cTy (Arr _ Arrow{}) = Left ArrFn + +instance Exception TTE where + +irTy :: T a -> Either TTE ([T a], T a) +irTy F = pure ([], F) +irTy I = pure ([], I) +irTy B = pure ([], B) +irTy t@Arr{} = pure ([], t) +irTy (Arrow Arrow{} _) = Left HO +irTy (Arrow t0 t1) = first (t0:) <$> irTy t1 +irTy TVar{} = Left Poly +irTy Ρ{} = Left Poly diff --git a/src/Class/E.hs b/src/Class/E.hs new file mode 100644 --- /dev/null +++ b/src/Class/E.hs @@ -0,0 +1,123 @@ +module Class.E ( E (..) ) where + +import qualified Asm.Aarch64 as AArch64 +import qualified Asm.X86 as X86 + +class E a where + toInt :: a -> Int + +instance E X86.X86Reg where + toInt X86.Rdi = 0 + toInt X86.Rsi = 1 + toInt X86.Rdx = 2 + toInt X86.Rcx = 3 + toInt X86.R8 = 4 + toInt X86.R9 = 5 + toInt X86.Rax = 6 + toInt X86.Rsp = 7 + toInt X86.R10 = -1 + toInt X86.R11 = -2 + toInt X86.R12 = -3 + toInt X86.R13 = -4 + toInt X86.R14 = -13 + toInt X86.R15 = -14 + toInt X86.Rbx = -15 + toInt X86.Rbp = -16 + +instance E X86.FX86Reg where + toInt X86.XMM0 = 8 + toInt X86.XMM1 = 9 + toInt X86.XMM2 = 10 + toInt X86.XMM3 = 11 + toInt X86.XMM4 = 12 + toInt X86.XMM5 = 13 + toInt X86.XMM6 = 14 + toInt X86.XMM7 = 15 + toInt X86.XMM8 = -5 + toInt X86.XMM9 = -6 + toInt X86.XMM10 = -7 + toInt X86.XMM11 = -8 + toInt X86.XMM12 = -9 + toInt X86.XMM13 = -10 + toInt X86.XMM14 = -11 + toInt X86.XMM15 = -12 + +instance E X86.AbsReg where + toInt = X86.toInt + +instance E X86.FAbsReg where + toInt = X86.fToInt + +instance E AArch64.AReg where + toInt AArch64.X0 = 0 + toInt AArch64.X1 = 1 + toInt AArch64.X2 = 2 + toInt AArch64.X3 = 3 + toInt AArch64.X4 = 4 + toInt AArch64.X5 = 5 + toInt AArch64.X6 = 6 + toInt AArch64.X7 = 7 + toInt AArch64.X8 = -1 + toInt AArch64.X9 = -2 + toInt AArch64.X10 = -3 + toInt AArch64.X11 = -4 + toInt AArch64.X12 = -5 + toInt AArch64.X13 = -6 + toInt AArch64.X14 = -7 + toInt AArch64.X15 = -8 + toInt AArch64.X16 = -9 + toInt AArch64.X17 = -10 + toInt AArch64.X18 = -11 + toInt AArch64.X19 = -12 + toInt AArch64.X20 = -13 + toInt AArch64.X21 = -14 + toInt AArch64.X22 = -15 + toInt AArch64.X23 = -16 + toInt AArch64.X24 = -17 + toInt AArch64.X25 = -18 + toInt AArch64.X26 = -19 + toInt AArch64.X27 = -20 + toInt AArch64.X28 = -21 + toInt AArch64.X29 = 18 + toInt AArch64.X30 = 8 + toInt AArch64.SP = 9 + +instance E AArch64.FAReg where + toInt AArch64.D0 = 10 + toInt AArch64.D1 = 11 + toInt AArch64.D2 = 12 + toInt AArch64.D3 = 13 + toInt AArch64.D4 = 14 + toInt AArch64.D5 = 15 + toInt AArch64.D6 = 16 + toInt AArch64.D7 = 17 + toInt AArch64.D8 = -23 + toInt AArch64.D9 = -24 + toInt AArch64.D10 = -25 + toInt AArch64.D11 = -26 + toInt AArch64.D12 = -27 + toInt AArch64.D13 = -28 + toInt AArch64.D14 = -29 + toInt AArch64.D15 = -30 + toInt AArch64.D16 = -31 + toInt AArch64.D17 = -32 + toInt AArch64.D18 = -33 + toInt AArch64.D19 = -34 + toInt AArch64.D20 = -35 + toInt AArch64.D21 = -36 + toInt AArch64.D22 = -37 + toInt AArch64.D23 = -38 + toInt AArch64.D24 = -39 + toInt AArch64.D25 = -40 + toInt AArch64.D26 = -41 + toInt AArch64.D27 = -42 + toInt AArch64.D28 = -43 + toInt AArch64.D29 = -44 + toInt AArch64.D30 = -45 + toInt AArch64.D31 = -46 + +instance E AArch64.AbsReg where + toInt = AArch64.toInt + +instance E AArch64.FAbsReg where + toInt = AArch64.fToInt diff --git a/src/Data/Copointed.hs b/src/Data/Copointed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Copointed.hs @@ -0,0 +1,8 @@ +module Data.Copointed ( Copointed (..) + ) where + +class Functor p => Copointed p where + copoint :: p a -> a + +instance Copointed ((,) a) where + copoint (_, y) = y diff --git a/src/Dbg.hs b/src/Dbg.hs new file mode 100644 --- /dev/null +++ b/src/Dbg.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Dbg ( dumpAAbs + , dumpAarch64 + , dumpAAss + , dumpX86G + , dumpX86Abs + , dumpX86Liveness + , dumpC + , dumpCI + , dumpIR + , dumpDomTree + , dumpLoop + , dumpX86Intervals + , dumpALiveness + , dumpAIntervals + , dumpX86Ass + , printParsed + , printTypes + , topt + , nasm + , pBIO, dtxt, dAtxt + , edAtxt, eDtxt + , module P + ) where + +import A +import qualified Asm.Aarch64 as Aarch64 +import qualified Asm.Aarch64.Byte as Aarch64 +import qualified Asm.Aarch64.P as Aarch64 +import Asm.Aarch64.T +import Asm.L +import Asm.LI +import Asm.M +import qualified Asm.X86 as X86 +import Asm.X86.Byte +import Asm.X86.P +import Asm.X86.Trans +import C +import C.Alloc +import qualified C.Trans as C +import CF +import Control.Exception (throw, throwIO) +import Control.Monad ((<=<)) +import Data.Bifunctor (second) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Tree (drawTree) +import Data.Tuple (swap) +import Data.Tuple.Extra (fst3) +import Data.Word (Word64) +import IR +import IR.Hoist +import L +import Numeric (showHex) +import P +import Prettyprinter (Doc, Pretty (..), comma, concatWith, punctuate, space, (<+>)) +import Prettyprinter.Ext +import Ty + +pBIO :: BSL.ByteString -> IO () +pBIO = either throwIO TIO.putStr <=< dtxt + +comm :: Either a (IO b) -> IO (Either a b) +comm (Left err) = pure(Left err) +comm (Right x) = Right <$> x + +wIdM :: Functor m => ((c, a) -> m b) -> (c, a) -> m (a, b) +wIdM f (d, x) = (x,)<$>f (d, x) + +dtxt :: BSL.ByteString -> IO (Either (Err AlexPosn) T.Text) +dtxt = asmTxt x86G + +eDtxt :: Int -> E a -> IO (Either (Err a) T.Text) +eDtxt k = asmTxt (ex86G k) + +asmTxt f = fmap (fmap (T.unlines.fmap present.uncurry zipS)) . comm . fmap (wIdM dbgFp) . f + where zipS [] [] = [] + zipS (x@X86.Label{}:xs) ys = (x,BS.empty):zipS xs ys + zipS (x:xs) (y:ys) = (x,y):zipS xs ys + +edAtxt :: Int -> E a -> IO (Either (Err a) T.Text) +edAtxt k = aAsmTxt (eAarch64 k) + +dAtxt :: BSL.ByteString -> IO (Either (Err AlexPosn) T.Text) +dAtxt = aAsmTxt aarch64 + +aAsmTxt f = fmap (fmap (T.unlines.fmap present.uncurry zipS)) . comm . fmap (wIdM Aarch64.dbgFp) . f + where zipS [] [] = [] + zipS (x@Aarch64.C{}:xs) (y0:y1:y2:y3:y4:ys) = (x,y0):(x,y1):(x,y2):(x,y3):(x,y4):zipS xs ys + zipS (x@Aarch64.MovRCf{}:xs) (y0:y1:y2:y3:ys) = (x,y0):(x,y1):(x,y2):(x,y3):zipS xs ys + zipS (x@Aarch64.LdrRL{}:xs) (y0:y1:y2:y3:ys) = (x,y0):(x,y1):(x,y2):(x,y3):zipS xs ys + zipS (x@Aarch64.Label{}:xs) ys = (x,BS.empty):zipS xs ys + zipS (x:xs) (y:ys) = (x,y):zipS xs ys + +rightPad :: Int -> T.Text -> T.Text +rightPad n str = T.take n (str <> T.replicate n " ") + +present :: Pretty a => (a, BS.ByteString) -> T.Text +present (x, b) = rightPad 45 (ptxt x) <> he b + where he = T.unwords.fmap (pad.T.pack.($"").showHex).BS.unpack + pad s | T.length s == 1 = T.cons '0' s | otherwise = s + +nasm :: T.Text -> BSL.ByteString -> Doc ann +nasm f = (\(d,i) -> "section .data\n\n" <> nasmD (IM.toList d) <#> i) . second ((prolegomena <#>).pAsm) . either throw id . x86G + where prolegomena = "section .text\n\nextern malloc\n\nextern free\n\nglobal " <> pretty f <#> pretty f <> ":" + +nasmD :: [(Int, [Word64])] -> Doc ann +nasmD = prettyLines . fmap nasmArr + where nasmArr (i, ds) = "arr_" <> pretty i <+> "dq" <+> concatWith (<>) (punctuate comma (fmap hexn ds)) + hexn = pretty.($"").(("0x"++).).showHex + +dumpX86Ass :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +dumpX86Ass = fmap ((\(regs, fregs, _) -> pR regs <#> pR fregs).uncurry gallocOn.(\(x,_,st) -> irToX86 st x)) . ir + where pR :: Pretty b => IM.IntMap b -> Doc ann; pR = prettyDumpBinds . IM.mapKeys (subtract 16) + +dumpAAss :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +dumpAAss = fmap ((\(regs, fregs, _) -> pR regs <#> pR fregs).uncurry Aarch64.gallocOn.(\(x,_,st) -> irToAarch64 st x)) . ir + where pR :: Pretty b => IM.IntMap b -> Doc ann; pR = prettyDumpBinds . IM.mapKeys (subtract 19) + +dumpX86G :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +dumpX86G = fmap prettyAsm . x86G + +dumpAarch64 :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +dumpAarch64 = fmap prettyAsm . aarch64 + +dumpX86Abs :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +dumpX86Abs = fmap (prettyAsm.(\(x,aa,st) -> (aa,snd (irToX86 st x)))) . ir + +dumpAAbs :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +dumpAAbs = fmap (prettyAsm.(\(x,aa,st) -> (aa,snd (irToAarch64 st x)))) . ir + +dumpC :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +dumpC = fmap (prettyCS.swap).cmm + +dumpCI :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +dumpCI = fmap (prettyCI.live.f.C.writeC).opt where f (cs,_,_,_) = cs + +prettyCI :: [CS Liveness] -> Doc ann +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) + +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) + +dumpIR :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +dumpIR = fmap (prettyIR.π).ir where π (a,b,_)=(b,a) + +dumpX86Intervals :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +dumpX86Intervals = fmap X86.prettyDebugX86 . x86Iv + +dumpAIntervals :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +dumpAIntervals = fmap Aarch64.prettyDebug . aarch64Iv + +dumpX86Liveness :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +dumpX86Liveness = fmap (X86.prettyDebugX86 . mkLive . (\(x,_,st) -> snd (irToX86 st x))) . ir + +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 = fmap (mkIntervals . (\(x,_,st) -> snd (irToX86 st x))) . ir + +aarch64Iv :: BSL.ByteString -> Either (Err AlexPosn) [Aarch64.AArch64 Aarch64.AbsReg Aarch64.FAbsReg Live] +aarch64Iv = fmap (mkIntervals . (\(x,_,st) -> snd (irToAarch64 st x))) . ir + +printParsed :: BSL.ByteString -> Doc ann +printParsed = pretty . fst . either throw id . parseRename + +-- throws exception +printTypes :: BSL.ByteString -> Doc ann +printTypes bsl = + case parseRename bsl of + Left err -> throw err + Right (ast, m) -> either throw (prettyTyped.fst3) $ tyClosed m ast + +topt :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +topt = fmap prettyTyped . opt diff --git a/src/Hs/A.hs b/src/Hs/A.hs new file mode 100644 --- /dev/null +++ b/src/Hs/A.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Hs.A ( Apple (..), U + , AB (..), AI, AF + , P2 (..), P3 (..), P4 (..) + , hs2, hs3, hs4 + ) where + +import Control.Monad (forM, zipWithM_) +import Data.Int (Int64) +import Data.List.Split (chunksOf) +import Data.Word (Word8) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (Storable (..)) +import Prettyprinter (Doc, Pretty (..), align, brackets, concatWith, hardline, space, (<+>)) +import Prettyprinter.Ext + +type AI = Apple Int64; type AF = Apple Double +type U a = Ptr (Apple a) + +data AB = F | T deriving Eq + +instance Pretty AB where pretty T="#t"; pretty F="#f" + +instance Show AB where show=show.pretty + +data Apple a = AA !Int64 [Int64] [a] deriving (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) +data P4 a b c d = P4 a b c d; hs4 (P4 a b c d) = (a,b,c,d) + +instance Storable AB where + sizeOf _ = 1 + peek p = (\b -> case b of 1 -> T; 0 -> F) <$> peek (castPtr p :: Ptr Word8) + poke p F = poke (castPtr p :: Ptr Word8) 0 + poke p T = poke (castPtr p :: Ptr Word8) 1 + +instance (Storable a, Storable b) => Storable (P2 a b) where + sizeOf _ = sizeOf(undefined::a)+sizeOf(undefined::b) + peek p = P2 <$> peek (castPtr p) <*> peek (p `plusPtr` sizeOf(undefined::a)) + +instance (Storable a, Storable b, Storable c) => Storable (P3 a b c) where + sizeOf _ = sizeOf (undefined::a)+sizeOf (undefined::b)+sizeOf (undefined::c) + peek p = P3 <$> peek (castPtr p) <*> peek (p `plusPtr` sizeOf (undefined::a)) <*> peek (p `plusPtr` (sizeOf (undefined::a)+sizeOf (undefined::b))) + +instance (Storable a, Storable b, Storable c, Storable d) => Storable (P4 a b c d) where + sizeOf _ = sizeOf(undefined::a)+sizeOf(undefined::b)+sizeOf(undefined::c)+sizeOf(undefined::d) + peek p = P4 <$> peek (castPtr p) <*> peek (p `plusPtr` sizeOf(undefined::a)) <*> peek (p `plusPtr` (sizeOf(undefined::a)+sizeOf(undefined::b))) <*> peek (p `plusPtr` (sizeOf(undefined::a)+sizeOf(undefined::b)+sizeOf(undefined::c))) + +pE :: Pretty a => [Int64] -> [a] -> Doc ann +pE [_, n] xs = align (brackets (space <> concatWith (\x y -> x <> hardline <> ", " <> y) (pretty<$>chunksOf (fromIntegral n) xs) <> space)) +pE _ xs = pretty xs + +instance Pretty a => Pretty (Apple a) where + pretty (AA _ dims xs) = "Arr" <+> tupledBy "×" (pretty <$> dims) <+> pE dims xs + +instance (Pretty a, Pretty b) => Pretty (P2 a b) where + pretty (P2 x y) = tupledBy "*" [pretty x, pretty y] + +instance (Pretty a, Pretty b, Pretty c) => Pretty (P3 a b c) where + pretty (P3 x y z) = tupledBy "*" [pretty x, pretty y, pretty z] + +instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (P4 a b c d) where + pretty (P4 x y z w) = tupledBy "*" [pretty x, pretty y, pretty z, pretty w] + +instance Storable a => Storable (Apple a) where + sizeOf (AA rnk dims _) = 8+8*fromIntegral rnk+(sizeOf (undefined::a)*fromIntegral (product dims)) + poke p (AA rnk dims xs) = do + poke (castPtr p) rnk + zipWithM_ (\i o -> poke (p `plusPtr` (8+8*o)) i) dims [0..] + let datOffs = 8+8*fromIntegral rnk + zipWithM_ (\x o -> poke (p `plusPtr` (datOffs+sizeOf (undefined::a)*o)) x) xs [0..] + peek p = do + rnk <- peek (castPtr p) + dims <- forM [1..fromIntegral rnk] $ \o -> peek $ p `plusPtr` (8*o) + let datOffs = 8+8*fromIntegral rnk + xs <- forM [1..fromIntegral (product dims)] $ \o -> peek $ p `plusPtr` (datOffs+sizeOf (undefined::a)*(o-1)) + pure $ AA rnk dims xs diff --git a/src/Hs/FFI.hsc b/src/Hs/FFI.hsc new file mode 100644 --- /dev/null +++ b/src/Hs/FFI.hsc @@ -0,0 +1,51 @@ +-- https://eli.thegreenplace.net/2013/11/05/how-to-jit-an-introduction +module Hs.FFI ( bsFp + , allocNear + , allocExec + , finish + , freeFunPtr + ) where + +import Data.Bits ((.|.)) +import Data.Functor (void) +import Control.Monad (when) +import Foreign.C.Types (CInt (..), CSize (..), CChar) +import Foreign.Ptr (FunPtr, IntPtr (..), castFunPtrToPtr, castPtrToFunPtr, Ptr, intPtrToPtr, nullPtr) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS +import System.Posix.Types (COff (..)) + +#include + +allocNear :: Int -> CSize -> IO (Ptr a) +allocNear i sz = + mmap (intPtrToPtr (IntPtr$i+6*1024*104)) sz #{const PROT_WRITE} (#{const MAP_PRIVATE} .|. #{const MAP_ANONYMOUS}) (-1) 0 + -- libc.so is 2.1MB, libm is 918kB + +allocExec :: CSize -> IO (Ptr a) +allocExec sz = + mmap nullPtr sz #{const PROT_WRITE} (#{const MAP_PRIVATE} .|. #{const MAP_ANONYMOUS}) (-1) 0 + +finish :: BS.ByteString -> Ptr CChar -> IO (FunPtr a) +finish bs fAt = BS.unsafeUseAsCStringLen bs $ \(b, sz) -> do + let sz' = fromIntegral sz + _ <- memcpy fAt b sz' + r <- mprotect fAt sz' #{const PROT_EXEC} + when (r == -1) $ error "call to mprotect failed." + pure (castPtrToFunPtr fAt) + +bsFp :: BS.ByteString -> IO (FunPtr a, CSize) +bsFp bs = BS.unsafeUseAsCStringLen bs $ \(bytes, sz) -> do + let sz' = fromIntegral sz + fAt <- {-# SCC "mmap" #-} allocExec sz' + _ <- {-# SCC "memcpy" #-} memcpy fAt bytes sz' + _ <- {-# SCC "mprotect" #-} mprotect fAt sz' #{const PROT_EXEC} + pure (castPtrToFunPtr fAt, sz') + +freeFunPtr :: Int -> FunPtr a -> IO () +freeFunPtr sz fp = void $ munmap (castFunPtrToPtr fp) (fromIntegral sz) + +foreign import ccall mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a) +foreign import ccall mprotect :: Ptr a -> CSize -> CInt -> IO CInt +foreign import ccall memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) +foreign import ccall munmap :: Ptr a -> CSize -> IO CInt diff --git a/src/I.hs b/src/I.hs new file mode 100644 --- /dev/null +++ b/src/I.hs @@ -0,0 +1,122 @@ +module I ( inline + , β + ) where + +import A +import Control.Monad.State.Strict (State, gets, modify, runState) +import Data.Bifunctor (second) +import qualified Data.IntMap as IM +import Nm +import Nm.IntMap +import R +import Ty +import U + +data ISt a = ISt { renames :: !Rs + , binds :: IM.IntMap (E a) + } + +instance HasRs (ISt a) where + rename f s = fmap (\x -> s { renames = x }) (f (renames s)) + +type M a = State (ISt a) + +bind :: Nm a -> E a -> ISt a -> ISt a +bind n e (ISt r bs) = ISt r (insert n e bs) + +runI i = second (max_.renames) . flip runState (ISt (Rs i mempty) mempty) + +inline :: Int -> E (T ()) -> (E (T ()), Int) +inline i = runI i.iM + +β :: Int -> E (T ()) -> (E (T ()), Int) +β i = runI i.bM + +hRi :: Idiom -> Bool +hRi (AShLit _ es) = any hR es + +hR :: E a -> Bool +hR (EApp _ (EApp _ (Builtin _ R) _) _) = True +hR Builtin{} = False +hR FLit{} = False +hR ILit{} = False +hR BLit{} = False +hR (ALit _ es) = any hR es +hR (Tup _ es) = any hR es +hR (Cond _ p e e') = hR p||hR e||hR e' +hR (EApp _ e e') = hR e||hR e' +hR (Lam _ _ e) = hR e +hR (Let _ (_, e') e) = hR e'||hR e +hR (Def _ (_, e') e) = hR e'||hR e +hR (LLet _ (_, e') e) = hR e'||hR e +hR Var{} = False +hR (Id _ i) = hRi i + +-- assumes globally renamed already +-- | Inlining is easy because we don't have recursion +iM :: E (T ()) -> M (T ()) (E (T ())) +iM e@Builtin{} = pure e +iM e@FLit{} = pure e +iM e@ILit{} = pure e +iM e@BLit{} = pure e +iM (ALit l es) = ALit l <$> traverse iM es +iM (Tup l es) = Tup l <$> traverse iM es +iM (Cond l p e0 e1) = Cond l <$> iM p <*> iM e0 <*> iM e1 +iM (EApp l e0 e1) = EApp l <$> iM e0 <*> iM e1 +iM (Lam l n e) = Lam l n <$> iM e +iM (LLet l (n, e') e) = do + e'I <- iM e' + eI <- iM e + pure $ LLet l (n, e'I) eI +iM (Let l (n, e') e) | not(hR e')= do + eI <- iM e' + modify (bind n eI) *> iM e + | otherwise = iM(LLet l (n,e') e) +iM (Def _ (n, e') e) = do + eI <- iM e' + modify (bind n eI) *> iM e +iM e@(Var t (Nm _ (U i) _)) = do + st <- gets binds + case IM.lookup i st of + Just e' -> do {er <- rE e'; pure $ fmap (rwArr.aT (match (eAnn er) t)) er} + Nothing -> pure e + +-- beta reduction +bM :: E (T ()) -> M (T ()) (E (T ())) +bM e@Builtin{} = pure e +bM e@FLit{} = pure e +bM e@ILit{} = pure e +bM e@BLit{} = pure e +bM (ALit l es) = ALit l <$> traverse bM es +bM (Tup l es) = Tup l <$> traverse bM es +bM (Cond l p e0 e1) = Cond l <$> bM p <*> bM e0 <*> bM e1 +bM (EApp l (Lam _ n e') e) | not(hR e) = do + eI <- bM e + modify (bind n eI) *> bM e' + | otherwise = do + eI <- bM e + LLet l (n, eI) <$> bM e' +bM (EApp l e0 e1) = do + e0' <- bM e0 + e1' <- bM e1 + case e0' of + Lam{} -> bM (EApp l e0' e1') + _ -> pure $ EApp l e0' e1' +bM (Lam l n e) = Lam l n <$> bM e +bM e@(Var _ (Nm _ (U i) _)) = do + st <- gets binds + case IM.lookup i st of + -- TODO: track if looked up once before (avoid spurious clones?) + Just e' -> rE e' -- rE vs. match ... t? + Nothing -> pure e +bM (LLet l (n, e') e) = do + e'B <- bM e' + eB <- bM e + pure $ LLet l (n, e'B) eB +bM (Id l idm) = Id l <$> bid idm + +bid :: Idiom -> M (T ()) Idiom +bid (FoldSOfZip seed op es) = FoldSOfZip <$> bM seed <*> bM op <*> traverse bM es +bid (FoldOfZip zop op es) = FoldOfZip <$> bM zop <*> bM op <*> traverse bM es +bid (AShLit ds es) = AShLit ds <$> traverse bM es +bid (FoldGen seed f g n) = FoldGen <$> bM seed <*> bM f <*> bM g <*> bM n diff --git a/src/IR.hs b/src/IR.hs new file mode 100644 --- /dev/null +++ b/src/IR.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE OverloadedStrings #-} + +module IR ( Exp (..), FExp (..) + , Stmt (..) + , Temp (..), FTemp (..) + , Label, AsmData + , AE (..) + , WSt (..) + , prettyIR + ) where + +import CF.AL +import Data.Int (Int64) +import qualified Data.IntMap as IM +import Data.Word (Word64) +import Op +import Prettyprinter (Doc, Pretty (..), hardline, parens, (<+>)) +import Prettyprinter.Ext + +-- see https://my.eng.utah.edu/~cs4400/sse-fp.pdf +type Label = Word; type AsmData = IM.IntMap [Word64] + +data WSt = WSt { wlabel :: !Label, wtemps :: !Int } + +prettyLabel :: Label -> Doc ann +prettyLabel l = "apple_" <> pretty l + +data FTemp = FTemp !Int + | F0 | F1 | F2 | F3 | F4 | F5 + | FRet | FRet1 + deriving (Eq, Ord) + +data Temp = ITemp !Int + | ATemp !Int + | C0 | C1 | C2 | C3 | C4 | C5 + | CRet + deriving Eq + +instance Pretty Temp where + pretty (ITemp i) = "r_" <> pretty i + pretty (ATemp i) = "a_" <> pretty i + pretty C0 = "r_arg0" + pretty C1 = "r_arg1" + pretty C2 = "r_arg2" + pretty C3 = "r_arg3" + pretty C4 = "r_arg4" + pretty C5 = "r_arg5" + pretty CRet = "r_ret" + +instance Pretty FTemp where + pretty (FTemp i) = "f_" <> pretty i + pretty F0 = "f_arg0" + pretty F1 = "f_arg1" + pretty F2 = "f_arg2" + pretty F3 = "f_arg3" + pretty F4 = "f_arg4" + pretty F5 = "f_arg5" + pretty FRet = "f_ret" + pretty FRet1 = "f_ret1" + +instance Show Temp where show=show.pretty + +data Stmt = L Label + | MJ Exp Label + | J Label + | MT Temp Exp | MX FTemp FExp -- move targeting xmm0 &c. + | Ma AL Temp Exp -- label, register, size + | Free Temp | RA !AL -- "return array" no-op + | Wr AE Exp | WrF AE FExp | WrB AE Exp + | Cmov Exp Temp Exp | Fcmov Exp FTemp FExp + | Cset Temp Exp + | Sa Temp Exp -- register, size + | Pop Exp -- pop salloc + | Cpy AE AE Exp + | C Label | R Label + | IRnd Temp | FRnd FTemp + +instance Pretty Stmt where + pretty (L l) = hardline <> prettyLabel l <> ":" + pretty (MT t e) = parens ("movtemp" <+> pretty t <+> pretty e) + pretty (MX t e) = parens ("movf" <+> pretty t <+> pretty e) + pretty (MJ e l) = parens ("mjump" <+> pretty e <+> prettyLabel l) + 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 (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) + pretty (Fcmov p t e) = parens ("fcmov" <+> pretty p <+> pretty t <+> pretty e) + pretty RA{} = parens "return-array" + pretty (Sa t e) = parens ("salloc" <+> pretty t <+> ":" <+> pretty e) + pretty (Pop e) = parens ("spop" <+> pretty e) + pretty (Cpy p p' e) = parens ("cpy" <+> pretty p <> "," <+> pretty p' <+> pretty e) + pretty (C l) = parens ("call" <+> prettyLabel l) + pretty R{} = parens "ret" <> hardline + pretty (IRnd t) = parens (pretty t <+> "<- rnd") + pretty (FRnd t) = parens (pretty t <+> "<- xrnd") + pretty (Cset t e) = parens ("cset" <+> pretty t <+> "<-" <+> pretty e) + +instance Show Stmt where show = show . pretty + +data AE = AP Temp (Maybe Exp) (Maybe AL) -- offset, label for tracking liveness + +instance Pretty AE where + pretty (AP t Nothing _) = parens ("ptr" <+> pretty t) + pretty (AP t (Just e) _) = parens ("ptr" <+> pretty t <> "+" <> pretty e) + +data FExp = ConstF Double + | FB FBin FExp FExp + | FConv Exp + | FReg FTemp + | FU FUn FExp + | FAt AE + +instance Num Exp where + (+) = IB IPlus; (*) = IB ITimes; (-) = IB IMinus; fromInteger = ConstI . fromInteger + +instance Num FExp where + (+) = FB FPlus; (*) = FB FTimes; (-) = FB FMinus; fromInteger = ConstF . fromInteger + +instance Fractional FExp where + (/) = FB FDiv; fromRational = ConstF . fromRational + +data Exp = ConstI Int64 + | Reg Temp + | IB IBin Exp Exp + | FRel FRel FExp FExp + | IRel IRel Exp Exp | Is Temp + | IU IUn Exp + | BU BUn Exp + | IRFloor FExp + | EAt AE | BAt AE + | LA !Int -- assembler data + +instance Pretty FExp where + pretty (ConstF x) = parens ("double" <+> pretty x) + pretty (FConv e) = parens ("itof" <+> pretty e) + pretty (FReg t) = parens ("freg" <+> pretty t) + pretty (FB op e e') = parens (pretty op <+> pretty e <+> pretty e') + pretty (FU op e) = parens (pretty op <+> pretty e) + pretty (FAt p) = "f@" <> pretty p + +instance Show FExp where show=show.pretty + +instance Pretty Exp where + pretty (ConstI i) = parens ("int" <+> pretty i) + pretty (Reg t) = parens ("reg" <+> pretty t) + pretty (IRel op e e') = parens (pretty op <+> pretty e <+> pretty e') + pretty (IB op e e') = parens (pretty op <+> pretty e <+> pretty e') + pretty (IU op e) = parens (pretty op <+> pretty e) + pretty (BU op e) = pretty op <> pretty e + pretty (IRFloor e) = parens ("floor" <+> pretty e) + pretty (EAt p) = "@" <> pretty p + pretty (BAt p) = "b@" <> pretty p + pretty (FRel op e e') = parens (pretty op <+> pretty e <+> pretty e') + pretty (Is e) = parens ("is?" <+> pretty e) + pretty (LA n) = "arr_" <> pretty n + +instance Show Exp where show = show.pretty + +prettyIR :: (AsmData, [Stmt]) -> Doc ann +prettyIR (ds,ss) = pAD ds <#> prettyLines (pretty<$>ss) diff --git a/src/IR/C.hs b/src/IR/C.hs new file mode 100644 --- /dev/null +++ b/src/IR/C.hs @@ -0,0 +1,157 @@ +module IR.C ( ctemp, cToIR ) where + +import Bits +import C +import Control.Monad (foldM) +import Control.Monad.State.Strict (State, runState, state) +import IR +import Op + +type IRM = State WSt + +nextI :: IRM C.Temp +nextI = C.ITemp <$> state (\(WSt ls t) -> (t, WSt ls (t+1))) + +nextL :: IRM IR.Label +nextL = state (\(WSt l ts) -> (l, WSt (l+1) ts)) + +cbtemp :: C.BTemp -> IR.Temp +cbtemp (C.BTemp i) = IR.ITemp i; cbtemp C.CBRet = IR.CRet + +ctemp :: C.Temp -> IR.Temp +ctemp (C.ATemp i) = IR.ATemp i; ctemp (C.ITemp i) = IR.ITemp i +ctemp C.C0 = IR.C0; ctemp C.C1 = IR.C1; ctemp C.C2 = IR.C2 +ctemp C.C3 = IR.C3; ctemp C.C4 = IR.C4; ctemp C.C5 = IR.C5 +ctemp C.CRet = IR.CRet + +fx :: C.FTemp -> IR.FTemp +fx (C.FTemp i) = IR.FTemp i +fx FRet0 = FRet; fx C.FRet1 = IR.FRet1 +fx C.F0 = IR.F0; fx C.F1 = IR.F1; fx C.F2 = IR.F2 +fx C.F3 = IR.F3; fx C.F4 = IR.F4; fx C.F5 = IR.F5 + +cToIR :: LSt -> [CS a] -> ([Stmt], WSt) +cToIR (LSt ls ts) cs = runState (foldMapM cToIRM cs) (WSt ls ts) + +tick reg = IR.MT reg (Reg reg+1) + +nr IGeq=ILt; nr IGt=ILeq; nr ILt=IGeq; nr ILeq=IGt; nr IEq=INeq; nr INeq=IEq + +cToIRM :: CS a -> IRM [Stmt] +cToIRM (G _ l retL) = pure [IR.C l, IR.L retL] +-- FIXME: put this at the end so it doesn't have to be skipped +cToIRM (Def _ l cs) = do + endL <- nextL + irs <- foldMapM cToIRM cs + pure (J endL:L l:irs++[IR.R l, L endL]) +cToIRM (C.PlProd _ t (e:es)) = let t' = ctemp t in pure (IR.MT t' (irE e):[IR.MT t' (IR.Reg t'*irE eϵ) | eϵ <- es]) +cToIRM (C.MT _ t e) = pure [IR.MT (ctemp t) (irE e)] +cToIRM (C.MX _ t e) = pure [IR.MX (fx t) (irX e)] +cToIRM (C.MB _ t e) = pure [IR.MT (cbtemp t) (irp e)] +cToIRM (Rnd _ t) = pure [IR.IRnd (ctemp t)] +cToIRM (C.FRnd _ t) = pure [IR.FRnd (fx t)] +cToIRM (C.Ma _ l t (C.ConstI rnkI) n sz) | Just s <- cLog sz = let t'=ctemp t in pure [IR.Ma l t' (IR.IB IAsl (irE n) (IR.ConstI s)+IR.ConstI (8+8*rnkI)), IR.Wr (AP t' Nothing (Just l)) (IR.ConstI rnkI)] +-- TODO: allocate rnk `shiftL` 3 for dims +cToIRM (C.Ma _ l t rnk n sz) | Just s <- cLog sz = let t'=ctemp t in pure [IR.Ma l t' (IR.IB IAsl (irE rnk+irE n) (IR.ConstI s)+8), IR.Wr (AP t' Nothing (Just l)) (irE rnk)] +-- TODO: allocate rnk `shiftL` 3 for dims +cToIRM (C.Ma _ l t rnk n sz) = let t'=ctemp t in pure [IR.Ma l t' ((irE rnk+irE n)*IR.ConstI sz+8), IR.Wr (AP t' Nothing (Just l)) (irE rnk)] +cToIRM (C.MaΠ _ l t sz) = pure [IR.Ma l (ctemp t) (irE sz)] +cToIRM (C.Free t) = pure [IR.Free (ctemp t)] +cToIRM (C.Wr _ a e) = pure [IR.Wr (irAt a) (irE e)] +cToIRM (C.WrF _ a x) = pure [IR.WrF (irAt a) (irX x)] +cToIRM (C.WrP _ a b) = pure [IR.WrB (irAt a) (irp b)] +cToIRM (For _ t el rel eu s) = do + l <- nextL; eL <- nextL + irs <- foldMapM cToIRM s + pure $ IR.MT t' (irE el):MJ (IR.IRel (nr rel) (Reg t') (irE eu)) eL:L l:irs++[tick t', MJ (IR.IRel rel (Reg t') (irE eu)) l, L eL] + where + t'=ctemp t +cToIRM (For1 _ t el rel eu s) = do + l <- nextL + irs <- foldMapM cToIRM s + pure $ IR.MT t' (irE el):L l:irs++[tick t', MJ (IR.IRel rel (Reg t') (irE eu)) l] + where + t'=ctemp t +cToIRM (While _ t rel eb s) = do + l <- nextL; eL <- nextL + 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 (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)] +cToIRM (CpyE _ a0 a1 e sz) | (s,0) <- sz `quotRem` 8 = pure [Cpy (irAt a0) (irAt a1) (irE e*IR.ConstI s)] +cToIRM (C.Sa _ t e) = pure [IR.Sa (ctemp t) (irE e)] +cToIRM (C.Pop _ e) = pure [IR.Pop (irE e)] +cToIRM (Ifn't _ p s) = do + l <- nextL + s' <- foldMapM cToIRM s + pure $ MJ (irp p) l:s'++[L l] +cToIRM (If _ p s0 s1) = do + l <- nextL; l' <- nextL + s0' <- foldMapM cToIRM s0; s1' <- foldMapM cToIRM s1 + pure $ MJ (irp p) l:s1'++J l':L l:s0'++[L l'] +cToIRM (C.Cmov _ p t e) = pure [IR.Cmov (irp p) (ctemp t) (irE e)] +cToIRM (C.Fcmov _ p t e) = pure [IR.Fcmov (irp p) (fx t) (irX e)] +cToIRM (C.Cset _ p t) = pure [IR.Cset (cbtemp t) (irp p)] +cToIRM (SZ _ td t rnk l) = do + i <- nextI + foldMapM cToIRM + [td =: C.EAt (ADim t 0 l), For () i 1 ILt rnk [td =: (Tmp td*C.EAt (ADim t (Tmp i) l))]] + +irAt :: ArrAcc -> AE +irAt (ARnk t l) = AP (ctemp t) Nothing l +irAt (ADim t (C.ConstI n) l) = AP (ctemp t) (Just$IR.ConstI (8+8*n)) l +irAt (ADim t e l) = AP (ctemp t) (Just$IR.IB IAsl (irE e) 3+8) l +irAt (AElem t (C.ConstI 1) (C.ConstI 0) l _) = AP (ctemp t) (Just 16) l +irAt (AElem t (C.ConstI rnkI) (Bin IPlus e (C.ConstI n)) l 8) = AP (ctemp t) (Just$IR.IB IAsl (irE e) 3+IR.ConstI (8+8*(rnkI+n))) l +irAt (AElem t (C.ConstI rnkI) (Bin IMinus e (C.ConstI n)) l 8) = AP (ctemp t) (Just$IR.IB IAsl (irE e) 3+IR.ConstI (8+8*(rnkI-n))) l +irAt (AElem t (C.ConstI rnkI) e l sz) | Just s <- cLog sz = AP (ctemp t) (Just$IR.IB IAsl (irE e) (IR.ConstI s)+IR.ConstI (8+8*rnkI)) l + | otherwise = AP (ctemp t) (Just$(irE e*IR.ConstI sz)+IR.ConstI (8+8*rnkI)) l +irAt (AElem t rnk e l 8) = AP (ctemp t) (Just$IR.IB IAsl (irE rnk+irE e) 3+8) l +irAt (AElem t rnk e l sz) | Just s <- cLog sz = AP (ctemp t) (Just$IR.IB IAsl (irE rnk) 3+IR.IB IAsl (irE e) (IR.ConstI s)+8) l + | otherwise = AP (ctemp t) (Just$IR.IB IAsl (irE rnk) 3+(irE e*IR.ConstI sz)+8) l +irAt (TupM t l) = AP (ctemp t) Nothing l +irAt (Raw t (C.ConstI 0) l _) = AP (ctemp t) Nothing l +irAt (Raw t (C.ConstI i) l sz) = AP (ctemp t) (Just (IR.ConstI$i*sz)) l +irAt (Raw t o l 1) = AP (ctemp t) (Just$irE o) l +irAt (Raw t o l sz) | Just n <- cLog sz = AP (ctemp t) (Just$IR.IB IAsl (irE o) (IR.ConstI n)) l + | otherwise = AP (ctemp t) (Just$irE o*IR.ConstI sz) l +irAt (At dt s ix l sz) | Just sϵ <- cLog sz = + let offs=foldl1 (IB IPlus) $ zipWith (\d i -> sm (irE i) (irE d)) s ix + in AP (ctemp dt) (Just$IR.IB IAsl offs (IR.ConstI sϵ)) l + where + sm i (IR.ConstI 1) = i + sm i (IR.ConstI d) | Just sϵ <- cLog d = IR.IB IAsl i (IR.ConstI sϵ) + sm d i = i*d + +irE :: CE -> Exp +irE (Tmp t) = Reg (ctemp t) +irE (C.EAt a) = IR.EAt (irAt a) +irE (C.ConstI i) = IR.ConstI i +irE (Bin op e0 e1) = IB op (irE e0) (irE e1) +irE (C.LA i) = IR.LA i +irE (DP t (C.ConstI rnk)) = Reg (ctemp t)+IR.ConstI (8*(1+rnk)) +irE (DP t e) = Reg (ctemp t)+IB IAsl (irE e) 3+8 +irE (CFloor e) = IRFloor (irX e) + +irp :: PE -> Exp +irp (C.IRel rel e0 e1) = IR.IRel rel (irE e0) (irE e1) +irp (C.FRel rel x0 x1) = IR.FRel rel (irX x0) (irX x1) +irp (C.IUn p e) = IR.IU p (irE e) +irp (C.BU op e) = IR.BU op (irp e) +irp (C.Is t) = IR.Is (cbtemp t) +irp (C.PAt a) = IR.BAt (irAt a) +irp (C.BConst True) = IR.ConstI 1 +irp (C.BConst False) = IR.ConstI 0 +irp (C.Boo op e0 e1) = IB (BI op) (irp e0) (irp e1) + +irX :: CFE -> FExp +irX (C.ConstF x) = IR.ConstF x +irX (FTmp t) = FReg (fx t) +irX (C.FAt a) = IR.FAt (irAt a) +irX (FBin op x0 x1) = FB op (irX x0) (irX x1) +irX (IE e) = FConv (irE e) +irX (FUn f e) = FU f (irX e) + +foldMapM f = foldM (\x y -> (x `mappend`) <$> f y) mempty diff --git a/src/IR/CF.hs b/src/IR/CF.hs new file mode 100644 --- /dev/null +++ b/src/IR/CF.hs @@ -0,0 +1,222 @@ +module IR.CF ( rToInt, fToInt + , mkControlFlow + ) where + +import CF +-- seems to pretty clearly be faster +import Control.Monad.State.Strict (State, gets, modify, runState, state) +import Data.Bifunctor (second) +import Data.Functor (($>)) +import qualified Data.IntSet as IS +import qualified Data.Map as M +import Data.Tuple.Extra (fst3, second3, snd3, thd3, third3) +import IR + +type N=Int + +-- map of labels by node +type FreshM = State (Int, M.Map Label N, M.Map Label [N]) + +runFreshM :: FreshM a -> (a, Int) +runFreshM = second fst3.flip runState (0, mempty, mempty) + +mkControlFlow :: [Stmt] -> ([(Stmt, ControlAnn)], Int) +mkControlFlow instrs = runFreshM (brs instrs *> addCF instrs) + +getFresh :: FreshM N +getFresh = state (\(i,m0,m1) -> (i,(i+1,m0,m1))) + +fm :: Label -> FreshM N +fm l = do {i <- getFresh; br i l $> i} + +ll :: Label -> FreshM N +ll l = gets (M.findWithDefault (error "Internal error in control-flow graph: node label not in map.") l . snd3) + +lC :: Label -> FreshM [N] +lC l = gets (M.findWithDefault (error "Internal error in CF graph: node label not in map.") l . thd3) + +br :: N -> Label -> FreshM () +br i l = modify (second3 (M.insert l i)) + +b3 :: N -> Label -> FreshM () +b3 i l = modify (third3 (M.alter (\k -> Just$case k of {Nothing -> [i]; Just is -> i:is}) l)) + +-- | Pair 'Stmt's with a unique node name and a list of all possible +-- destinations. +addCF :: [Stmt] -> FreshM [(Stmt, ControlAnn)] +addCF [] = pure [] +addCF ((L l):stmts) = do + { i <- ll l + ; (f, stmts') <- next stmts + ; pure ((L l, ControlAnn i (f []) (UD IS.empty IS.empty IS.empty IS.empty)):stmts') + } +addCF (J l:stmts) = do + { i <- getFresh + ; ns <- addCF stmts + ; l_i <- ll l + ; pure ((J l, ControlAnn i [l_i] (UD IS.empty IS.empty IS.empty IS.empty)):ns) + } +addCF (C l:stmts) = do + { i <- getFresh + ; ns <- addCF stmts + ; l_i <- ll l + ; pure ((C l, ControlAnn i [l_i] (UD IS.empty IS.empty IS.empty IS.empty)):ns) + } +addCF (R l:stmts) = do + { i <- getFresh + ; ns <- addCF stmts + ; l_is <- lC l + ; pure ((R l, ControlAnn i l_is (UD IS.empty IS.empty IS.empty IS.empty)):ns) + } +addCF (MJ e l:stmts) = do + { i <- getFresh + ; (f, stmts') <- next stmts + ; l_i <- ll l + ; pure ((MJ e l, ControlAnn i (f [l_i]) (UD (uE e) IS.empty IS.empty IS.empty)):stmts') + } +addCF (stmt:stmts) = do + { i <- getFresh + ; (f, stmts') <- next stmts + ; pure ((stmt, ControlAnn i (f []) (UD (uses stmt) (usesF stmt) (defs stmt) (defsF stmt))):stmts') + } + +rToInt :: Temp -> Int +rToInt (ITemp i) = i; rToInt (ATemp i) = i +rToInt C0 = -1; rToInt C1 = -2; rToInt C2 = -3; rToInt C3 = -4 +rToInt C4 = -5; rToInt C5 = -6; rToInt CRet = -7 + +fToInt :: FTemp -> Int +fToInt (FTemp i) = i +fToInt F0 = -8; fToInt F1 = -9; fToInt F2 = -10; fToInt F3 = -11 +fToInt F4 = -12; fToInt F5 = -13; fToInt FRet = -14; fToInt FRet1 = -15 + +singleton :: Temp -> IS.IntSet +singleton = IS.singleton . rToInt + +fsingleton :: FTemp -> IS.IntSet +fsingleton = IS.singleton . fToInt + +uE :: Exp -> IS.IntSet +uE (Reg r) = singleton r +uE ConstI{} = IS.empty +uE (IB _ e0 e1) = uE e0 <> uE e1 +uE (IRel _ e0 e1) = uE e0 <> uE e1 +uE (Is t) = singleton t +uE (IU _ e) = uE e +uE (BU _ e) = uE e +uE LA{} = IS.empty +uE (IRFloor x) = uFR x +uE (EAt a) = uA a +uE (BAt a) = uA a +uE (FRel _ x0 x1) = uFR x0<>uFR x1 + +uFF :: Exp -> IS.IntSet +uFF (IRFloor e) = uF e +uFF ConstI{} = IS.empty +uFF Reg{} = IS.empty +uFF (IB _ e0 e1) = uFF e0<>uFF e1 +uFF (IRel _ e0 e1) = uFF e0<>uFF e1 +uFF (FRel _ e0 e1) = uF e0<>uF e1 +uFF (IU _ e) = uFF e +uFF (BU _ e) = uFF e +uFF LA{} = IS.empty +uFF Is{} = IS.empty +uFF (EAt e) = uAF e +uFF (BAt e) = uAF e + +uF :: FExp -> IS.IntSet +uF ConstF{} = IS.empty +uF (FB _ e0 e1) = uF e0 <> uF e1 +uF (FConv e) = uFF e +uF (FReg t) = fsingleton t +uF (FU _ e) = uF e +uF (FAt a) = uAF a + +uAF :: AE -> IS.IntSet +uAF (AP _ (Just e) _) = uFF e +uAF _ = IS.empty + +uA :: AE -> IS.IntSet +uA (AP t Nothing _) = singleton t +uA (AP t (Just e) _) = IS.insert (rToInt t) (uE e) + +uFR :: FExp -> IS.IntSet +uFR (FAt a) = uA a +uFR (FConv e) = uE e +uFR (FB _ e0 e1) = uFR e0<>uFR e1 +uFR FReg{} = IS.empty +uFR (FU _ e) = uFR e +uFR ConstF{} = IS.empty + +uses, defs :: Stmt -> IS.IntSet +uses IRnd{} = IS.empty +uses FRnd{} = IS.empty +uses L{} = IS.empty +uses J{} = IS.empty +uses (MJ e _) = uE e +uses (MT _ e) = uE e +uses (MX _ e) = uFR e +uses (Ma _ _ e) = uE e +uses (Free t) = singleton t +uses RA{} = IS.empty +uses (Wr a e) = uA a<>uE e +uses (WrF a e) = uA a<>uFR e +uses (WrB a e) = uA a<>uE e +uses (Sa _ e) = uE e +uses (Pop e) = uE e +uses (Cmov e0 _ e1) = uE e0<>uE e1 +uses (Fcmov e _ x) = uE e<>uFR x +uses R{} = IS.empty +uses C{} = IS.empty +uses (Cset _ e) = uE e +uses (Cpy a0 a1 e) = uA a0<>uA a1<>uE e + +defs (MT t _) = singleton t +defs (IRnd t) = singleton t +defs (Ma _ t _) = singleton t +defs (Cmov _ t _) = singleton t +defs (Sa t _) = singleton t +defs (Cset t _) = singleton t +defs _ = IS.empty + +usesF, defsF :: Stmt -> IS.IntSet +usesF IRnd{} = IS.empty +usesF FRnd{} = IS.empty +usesF (MX _ e) = uF e +usesF L{} = IS.empty +usesF J{} = IS.empty +usesF MJ{} = IS.empty +usesF (MT _ e) = uFF e +usesF (Ma _ _ e) = uFF e +usesF Free{} = IS.empty +usesF RA{} = IS.empty +usesF (Cmov e _ e') = uFF e<>uFF e' +usesF (Fcmov e _ x) = uFF e<>uF x +usesF (Wr a e) = uAF a<>uFF e +usesF (WrF a x) = uAF a<>uF x +usesF (WrB a e) = uAF a<>uFF e +usesF (Cset _ e) = uFF e +usesF (Sa _ e) = uFF e +usesF (Pop e) = uFF e +usesF C{} = IS.empty +usesF R{} = IS.empty +usesF (Cpy a0 a1 e) = uAF a0<>uAF a1<>uFF e + +defsF (MX t _) = fsingleton t +defsF (Fcmov _ x _) = fsingleton x +defsF (FRnd t) = fsingleton t +defsF _ = IS.empty + +next :: [Stmt] -> FreshM ([N] -> [N], [(Stmt, ControlAnn)]) +next stmts = do + nextStmts <- addCF stmts + case nextStmts of + [] -> pure (id, []) + (stmt:_) -> pure ((node (snd stmt) :), nextStmts) + +-- | Construct map assigning labels to their node name. +brs :: [Stmt] -> FreshM () +brs [] = pure () +brs ((C l):(L retL):stmts) = do {i <- fm retL; b3 i l; brs stmts} +brs ((L l):stmts) = fm l *> brs stmts +brs (_:asms) = brs asms diff --git a/src/IR/Hoist.hs b/src/IR/Hoist.hs new file mode 100644 --- /dev/null +++ b/src/IR/Hoist.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE TupleSections #-} + +module IR.Hoist ( loop, hoist, pall ) where + +import CF +import Control.Composition (thread) +import Control.Monad.State.Strict (gets, modify, runState) +import qualified Data.Array as A +import Data.Bifunctor (bimap, first, second) +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 qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, fromJust, fromMaybe) +import Data.Tuple.Extra (first3, snd3) +import IR +import IR.CF +import LR + +type N=Int + +mapFA :: (FTemp -> FTemp) -> AE -> AE +mapFA f (AP t (Just e) l) = AP t (Just$mapFE f e) l +mapFA _ a = a + +mapFE :: (FTemp -> FTemp) -> Exp -> Exp +mapFE f (IRFloor x) = IRFloor (mapFF f x) +mapFE f (EAt a) = EAt (mapFA f a) +mapFE f (BAt a) = BAt (mapFA f a) +mapFE _ e@ConstI{} = e +mapFE _ e@Reg{} = e +mapFE _ e@Is{} = e +mapFE f (FRel rel x0 x1) = FRel rel (mapFF f x0) (mapFF f x1) +mapFE f (IB op e0 e1) = IB op (mapFE f e0) (mapFE f e1) +mapFE f (IU op e) = IU op (mapFE f e) +mapFE f (BU op e) = BU op (mapFE f e) +mapFE f (IRel rel e0 e1) = IRel rel (mapFE f e0) (mapFE f e1) +mapFE _ e@LA{} = e + +mapFF :: (FTemp -> FTemp) -> FExp -> FExp +mapFF _ x@ConstF{} = x +mapFF f (FAt a) = FAt (mapFA f a) +mapFF f (FB op e0 e1) = FB op (mapFF f e0) (mapFF f e1) +mapFF f (FU op e) = FU op (mapFF f e) +mapFF f (FReg r) = FReg (f r) +mapFF f (FConv e) = FConv (mapFE f e) + +mapF :: (FTemp -> FTemp) -> Stmt -> Stmt +mapF f (MX t e) = MX (f t) (mapFF f e) +mapF _ s@L{} = s +mapF _ s@C{} = s +mapF _ s@R{} = s +mapF _ s@IRnd{} = s +mapF f (FRnd t) = FRnd (f t) +mapF _ s@J{} = s +mapF _ s@Free{} = s +mapF _ s@RA{} = s +mapF f (MT t e) = MT t (mapFE f e) +mapF f (Wr a e) = Wr (mapFA f a) (mapFE f e) +mapF f (WrF a x) = WrF (mapFA f a) (mapFF f x) +mapF f (WrB a e) = WrB (mapFA f a) (mapFE f e) +mapF f (Fcmov e t x) = Fcmov (mapFE f e) (f t) (mapFF f x) +mapF f (MJ e l) = MJ (mapFE f e) l +mapF f (Ma l t e) = Ma l t (mapFE f e) +mapF f (Sa t e) = Sa t (mapFE f e) +mapF f (Pop e) = Pop (mapFE f e) +mapF f (Cpy a0 a1 e) = Cpy (mapFA f a0) (mapFA f a1) (mapFE f e) +mapF f (Cmov p t e) = Cmov (mapFE f p) t (mapFE f e) +mapF f (Cset t p) = Cset t (mapFE f p) + +type Loop = (N, IS.IntSet) + +-- TODO: array? +lm :: [(Stmt, NLiveness)] -> IM.IntMap NLiveness +lm = IM.fromList.fmap (\(_,n) -> (nx n, n)) + +hl :: (Loop, A.Array Int (Stmt, ControlAnn), IM.IntMap NLiveness) -> [(N, N, (FTemp, Double))] +hl ((n,ns), info, linfo) = go ss + where + lH=liveness (gN n linfo) + fliveInH=fins lH + go ((MX x (ConstF i), a):ssϵ) | fToInt x `IS.notMember` fliveInH && notFDef x (node a) = (n, node a, (x,i)):go ssϵ + go (_:ssϵ) = go ssϵ + go [] = [] + otherDefFs nL = defsFNode.ud.snd.(info A.!)<$>IS.toList(IS.delete nL ns) + notFDef r nL = not $ any (fToInt r `IS.member`) (otherDefFs nL) + ss = (info A.!)<$>IS.toList ns + gN = IM.findWithDefault (error "internal error: node not in map.") + +pall :: [Stmt] -> [Stmt] +pall ss = + let ss' = fmap (second node) cf + (s, ss'') = go ss' + in {-# SCC "applySubst" #-} applySubst s ss'' + where + go ((_,n):ssϵ) | n `IS.member` dels = go ssϵ + go ((s,n):ssϵ) | Just cs <- IM.lookup n is = let (css, (_, subst)) = {-# SCC "consolidate" #-} consolidate cs in bimap (subst<>) ((css++[s])++) (go ssϵ) + go ((s,_):ssϵ) = second (s:)$go ssϵ + go [] = (M.empty, []) + (cf, is, dels) = indels ss + applySubst s = fmap (mapF (\t -> fromMaybe t (M.lookup t s))) + consolidate = first catMaybes . flip runState (M.empty, M.empty) . traverse (\(t,x) -> do + seen <- gets fst + case M.lookup x seen of + Nothing -> modify (first (M.insert x t)) $> Just (MX t (ConstF x)) + Just r -> modify (second (M.insert t r)) $> Nothing) + +indels :: [Stmt] -> ([(Stmt, ControlAnn)], IM.IntMap [(FTemp, Double)], IS.IntSet) +indels ss = (c, is IM.empty, ds) + where + (c,h) = hs ss + ds = IS.fromList (snd3<$>h) + go n s = IM.alter (\d -> case d of {Nothing -> Just [s]; Just ssϵ -> Just$s:ssϵ}) n + is = thread ((\(n,_,s) -> go n s)<$>h) + +hs :: [Stmt] -> ([(Stmt, ControlAnn)], [(N, N, (FTemp, Double))]) +hs ss = let (ls, cf, dm) = loop ss + mm = lm (reconstructFlat cf) + in (cf, concatMap (\l -> hl (l,dm,mm)) (ols ls)) + +loop :: [Stmt] -> ([Loop], [(Stmt, ControlAnn)], A.Array Int (Stmt, ControlAnn)) +loop = first3 (fmap mkL).(\(w,x,y,z) -> (et w (fmap fst z) [] x,y,z)).hoist + where + mkL (n, ns) = (n, IS.fromList ns) + +hoist :: [Stmt] -> (Graph, Tree N, [(Stmt, ControlAnn)], A.Array Int (Stmt, ControlAnn)) +hoist ss = (\ssϵ -> (\(x,y,z,_) -> (x,y,fst ssϵ,z))$mkG ssϵ) (mkControlFlow ss) + +{-# SCC ols #-} +ols :: [Loop] -> [Loop] +ols ls = filter (\(_,ns) -> not $ any (\(_,ns') -> ns `IS.isSubsetOf` 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 + +{-# SCC expandLoop #-} +expandLoop :: Tree N -> (N,N) -> (N,[N]) +-- wir müssen wissen, wir werden wissen +expandLoop t se = fromJust (go [] se 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ϵ} + +tLoops :: Graph -> A.Array Int Stmt -> [N] -> Tree N -> [(N, N)] +tLoops 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 + where + isMJ nϵ = p (ss A.! nϵ) + p MJ{}=True; p _=False + +hasEdge :: Graph -> Node -> Node -> Bool +hasEdge g n0 n1 = case IM.lookup n0 g of {Nothing -> False; Just ns -> n1 `IS.member` ns} + +mkG :: ([(Stmt, ControlAnn)], Int) -> (Graph, Tree N, A.Array Int (Stmt, ControlAnn), IM.IntMap (Stmt, ControlAnn)) +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 diff --git a/src/IR/Opt.hs b/src/IR/Opt.hs new file mode 100644 --- /dev/null +++ b/src/IR/Opt.hs @@ -0,0 +1,93 @@ +module IR.Opt ( optIR ) where + +import Bits +import Data.Bits (shiftL) +import IR +import Op + +optIR :: [Stmt] -> [Stmt] +optIR = fmap opt + +optE :: Exp -> Exp +optE (IB ITimes e0 e1) = + case (optE e0, optE e1) of + (ConstI 0, _) -> ConstI 0 + (_, ConstI 0) -> ConstI 0 + (ConstI 1, e1') -> e1' + (e0', ConstI 1) -> e0' + (ConstI i0, ConstI i1) -> ConstI$i0*i1 + (e0', ConstI i) | Just s <- cLog i -> IB IAsl e0' (ConstI s) + (ConstI i, e1') | Just s <- cLog i -> IB IAsl e1' (ConstI s) + (e0', e1') -> IB ITimes e0' e1' +optE (IB IPlus e0 e1) = + case (optE e0, optE e1) of + (ConstI 0, e1') -> e1' + (e0', ConstI 0) -> e0' + (ConstI i0, ConstI i1) -> ConstI$i0+i1 + (e0', e1') -> IB IPlus e0' e1' +optE (IB IMinus e0 e1) = + case (optE e0, optE e1) of + (e0', ConstI 0) -> e0' + (e0', e1') -> IB IMinus e0' e1' +optE (IB IAsl e0 e1) = + case (optE e0, optE e1) of + (ConstI i0, ConstI i1) -> ConstI$i0 `shiftL` fromIntegral i1 + (e0', ConstI 0) -> e0' + (e0',e1') -> IB IAsl e0' e1' +optE (IB op e e') = IB op (optE e) (optE e') +optE (IRel rel e e') = IRel rel (optE e) (optE e') +optE (FRel rel fe fe') = FRel rel (optF fe) (optF fe') +optE (IU u e) = IU u (optE e) +optE (IRFloor fe) = IRFloor (optF fe) +optE (EAt p) = EAt (optP p) +optE (BAt p) = BAt (optP p) +optE e = e + +optF :: FExp -> FExp +optF (FAt p) = FAt (optP p) +optF (FConv e) = + case optE e of + ConstI i -> ConstF$fromIntegral i + e' -> FConv e' +optF (FU FLog e) = + case optF e of + ConstF d -> ConstF$log d + e' -> FU FLog e' +optF (FB FMinus e0 e1) = + case (optF e0, optF e1) of + (e0', ConstF 0) -> e0' + (e0', e1') -> FB FMinus e0' e1' +optF (FB FPlus e0 e1) = + case (optF e0, optF e1) of + (ConstF 0, e1') -> e1' + (e0', ConstF 0) -> e0' + (ConstF x0, ConstF x1) -> ConstF$x0+x1 + (e0',e1') -> FB FPlus e0' e1' +optF (FB FTimes e0 e1) = + case (optF e0, optF e1) of + (ConstF 1, e1') -> e1' + (e0', ConstF 1) -> e0' + (ConstF x0, ConstF x1) -> ConstF$x0*x1 + (e0',e1') -> FB FTimes e0' e1' +optF (FB FDiv e0 e1) = + case (optF e0, optF e1) of + (e0', ConstF 1) -> e0' + (ConstF x0, ConstF x1) -> ConstF$x0/x1 + (e0', ConstF x) -> FB FTimes e0' (ConstF$1/x) + (e0',e1') -> FB FDiv e0' e1' +optF fe = fe + +optP :: AE -> AE +optP (AP t me l) = AP t (fmap optE me) l + +opt :: Stmt -> Stmt +opt (Cpy s d n) = Cpy (optP s) (optP d) (optE n) +opt (MT r e) = MT r (optE e) +opt (Ma l t e) = Ma l t (optE e) +opt (Wr p e) = Wr (optP p) (optE e) +opt (WrF p e) = WrF (optP p) (optF e) +opt (WrB p e) = WrB (optP p) (optE e) +opt (MX xr e) = MX xr (optF e) +opt (Cmov e t e') = Cmov (optE e) t (optE e') +opt (MJ e l) = MJ (optE e) l +opt s = s diff --git a/src/L.x b/src/L.x new file mode 100644 --- /dev/null +++ b/src/L.x @@ -0,0 +1,509 @@ +{ + {-# LANGUAGE DeriveGeneric #-} + {-# LANGUAGE DeriveAnyClass #-} + {-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE StandaloneDeriving #-} + module L ( alexMonadScan + , alexInitUserState + , runAlex + , runAlexSt + , withAlexSt + , freshName + , newIdent + , AlexPosn (..) + , Alex (..) + , Token (..) + , Sym (..) + , Builtin (..) + , Var (..) + , AlexUserState + ) where + +import Control.Arrow ((&&&)) +import Control.DeepSeq (NFData) +import Data.Bifunctor (first) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as ASCII +import Data.Functor (($>)) +import qualified Data.IntMap as IM +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import GHC.Generics (Generic) +import Prettyprinter (Pretty (pretty), (<+>), colon, squotes) +import Nm +import U + +} + +%wrapper "monadUserState-bytestring" + +$digit = [0-9] +$hexit = [0-9a-f] + +$latin = [a-zA-Z] + +$subscript = [ₐ-ₜ] +$digitsubscript = [₀-₉] + +$greek = [α-ωΑ-Ω] + +$mathgreek = [𝛢-𝛺𝛼-𝜛] +$mathlatin = [𝐴-𝑍𝑎-𝑧] + +$letter = [$latin $greek] +$sub = [$subscript $digitsubscript] + +@follow_char = [$letter $digit \_] + +-- TODO: M₂,₂ without the space +@name = ($letter#[Λλ] @follow_char* $sub* | $mathgreek $sub* | $mathlatin $sub* | ∫ | 𝛻 | ∇) [′″‴⁗]? + +@exp = e\-?$digit+ +@float = $digit+\.$digit+@exp? + +tokens :- + + <0> "[" { mkSym LSqBracket `andBegin` dfn } -- FIXME: this doesn't allow nested + <0> `$white*"{" { mkSym LRank `andBegin` braces } + + { + x { mkRes VarX } + y { mkRes VarY } + `$white*"{" { mkSym LRank `andBegin` dbraces } + } + + { + "[" { mkSym LSqBracket } + "]" { mkSym RSqBracket } + ∘ { mkSym Compose } + o { mkSym Compose } + } + + "}" { mkSym RBrace `andBegin` 0 } + "}" { mkSym RBrace `andBegin` dfn } + + <0,dfn,braces,dbraces> { + $white+ ; + + "--".* ; + + "," { mkSym Comma } + + $digit+ { tok (\p s -> alex $ TokInt p (read $ ASCII.unpack s)) } + } + + <0,dfn> { + "{" { mkSym LBrace } + "}" { mkSym RBrace } + + -- symbols/operators + "%" { mkSym Percent } + "*" { mkSym Times } + "**" { mkSym Pow } + "+" { mkSym Plus } + "-" { mkSym Minus } + "^" { mkSym Caret } + + "/" { mkSym Fold } + "/ₒ" { mkSym FoldS } + "/o" { mkSym FoldS } + "/l" { mkSym Foldl } + "/*" { mkSym FoldA } + ' { mkSym Quot } + ` { mkSym Zip } + + "(" { mkSym LParen } + ")" { mkSym RParen } + λ { mkSym Lam } + \\ { mkSym Lam } + "\`" { mkSym DIS } + "\~" { mkSym Succ } + "." { mkSym Dot } + ";" { mkSym Semicolon } + : { mkSym Colon } + "←" { mkSym Bind } + "<-" { mkSym Bind } + _ { mkSym Underscore } + "?" { mkSym QuestionMark } + ",." { mkSym CondSplit } + ⸎ { mkSym Cor } + × { mkSym IxTimes } + ⟨ { mkSym ArrL } + ⟩ { mkSym ArrR } + "_." { mkSym SymLog } + ⟜ { mkSym LBind } + ⇐ { mkSym PolyBind } + → { mkSym Arrow } + "->" { mkSym Arrow } + "->"$digit+ { tok (\p s -> alex $ TokSym p (Access (read $ ASCII.unpack $ BSL.drop 2 s))) } + :: { mkSym Sig } + ":~" { mkSym TSig } + ⋉ { mkSym MaxS } + ">." { mkSym MaxS } + ⋊ { mkSym MinS } + "<." { mkSym MinS } + ⨳ { mkSym Conv } + "{." { mkSym Head } + "{.?" { mkSym HeadM } + "}." { mkSym Last } + "}.?" { mkSym LastM } + "{:" { mkSym Tail } + "}:" { mkSym Init } + ⊲ { mkSym Cons } + "<|" { mkSym Cons } + ⊳ { mkSym Snoc } + "|>" { mkSym Snoc } + "^:" { mkSym Do } + ⊗ { mkSym Tensor } + "|:" { mkSym Transp } + ⍉ { mkSym Transp } + ≥ { mkSym Geq } + ">=" { mkSym Geq } + ">" { mkSym Gt } + = { mkSym Eq } + ≠ { mkSym Neq } + "!=" { mkSym Neq } + "<" { mkSym Lt } + "<=" { mkSym Leq } + ≤ { mkSym Leq } + "~" { mkSym Tilde } + ⧺ { mkSym PlusPlus } + "++" { mkSym PlusPlus } + ">>" { mkSym Sr } + "<<" { mkSym Sl } + ⊖ { mkSym Rotate } + ⊙ { mkSym Cyc } + ˙ { mkSym A1 } + "|" { mkSym Mod } + "@." { mkSym AtDot } + ℘ { mkSym Weier } + § { mkSym Para } + 👁️ { mkSym Eye } + "eye." { mkSym Eye } + ♭ { mkSym B } + ♮ { mkSym Sharp } + ⊻ { mkSym Xor } + ∧ { mkSym And } + ∨ { mkSym Or } + ¬ { mkSym Not } + + "]" { mkSym RSqBracket `andBegin` 0 } + + frange { mkBuiltin BuiltinFRange } + 𝒻 { mkBuiltin BuiltinFRange } + irange { mkBuiltin BuiltinIota } + ⍳ { mkBuiltin BuiltinIota } + ⌊ { mkBuiltin BuiltinFloor } + "|." { mkBuiltin BuiltinFloor } + ℯ { mkBuiltin BuiltinE } + "e:" { mkBuiltin BuiltinE } + itof { mkBuiltin BuiltinI } + ℝ { mkBuiltin BuiltinI } + 𝓕 { mkBuiltin BuiltinF } + 𝓉 { mkBuiltin BuiltinT } + "#t" { mkBuiltin BuiltinTrue } + "#f" { mkBuiltin BuiltinFalse } + √ { mkBuiltin BuiltinSqrt } + 𝜋 { mkBuiltin BuiltinPi } + "gen." { mkBuiltin BuiltinGen } + "cyc." { mkBuiltin BuiltinCyc } + "re:" { mkBuiltin BuiltinRep } + "di." { mkBuiltin BuiltinD } + Λ { mkBuiltin BuiltinScan } + Λₒ { mkBuiltin BuiltinScanS } + "/\" { mkBuiltin BuiltinScan } + "/\o" { mkBuiltin BuiltinScanS } + "`Cons`" { mkBuiltin BuiltinCons } + Nil { mkBuiltin BuiltinNil } + "%." { mkBuiltin BuiltinMMul } + "%:" { mkBuiltin BuiltinVMul } + Arr { mkBuiltin BuiltinArr } + Vec { mkBuiltin BuiltinVec } + M { mkBuiltin BuiltinM } + float { mkBuiltin BuiltinFloat } + int { mkBuiltin BuiltinInt } + 𝔯 { mkBuiltin BuiltinR } + "rand." { mkBuiltin BuiltinR } + "sin." { mkBuiltin BuiltinSin } + "cos." { mkBuiltin BuiltinCos } + "tan." { mkBuiltin BuiltinTan } + "odd." { mkBuiltin BuiltinOdd } + "even." { mkBuiltin BuiltinEven } + "abs." { mkBuiltin BuiltinAbs } + + _$digit+ { tok (\p s -> alex $ TokInt p (negate $ read $ ASCII.unpack $ BSL.tail s)) } + "0x"$hexit+ { tok (\p s -> alex $ TokInt p (hexP $ BSL.drop 2 s)) } + _"0x"$hexit+ { tok (\p s -> alex $ TokInt p (negate $ hexP $ BSL.drop 3 s)) } + $digitsubscript+ { tok (\p s -> alex $ TokIx p (parseSubscript $ mkText s)) } + + @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)) } + + @name { tok (\p s -> TokName p <$> newIdentAlex p (mkText s)) } + + } + +{ + +alex :: a -> Alex a +alex = pure + +tok f (p,_,s,_) len = f p (BSL.take len s) + +constructor c t = tok (\p _ -> alex $ c p t) + +mkRes = constructor TokResVar + +mkSym = constructor TokSym + +mkBuiltin = constructor TokB + +mkText :: BSL.ByteString -> T.Text +mkText = decodeUtf8 . BSL.toStrict + +parseSubscript :: T.Text -> Int +parseSubscript = T.foldl' (\seed c -> 10 * seed + f c) 0 + where f = (subtract 8320).fromEnum + +hexP :: BSL.ByteString -> Integer +hexP = ASCII.foldl' (\seed x -> 10 * seed + f x) 0 + where f '0' = 0; f '1' = 1; f '2' = 2; f '3' = 3; + f '4' = 4; f '5' = 5; f '6' = 6; f '7' = 7; + f '8' = 8; f '9' = 9; f 'a' = 10; f 'b' = 11 + f 'c' = 12; f 'd' = 13; f 'e'= 14; f 'f'=15 + f c = error (c:" is not a valid hexit!") + +instance Pretty AlexPosn where + pretty (AlexPn _ line col) = pretty line <> colon <> pretty col + +deriving instance Generic AlexPosn + +deriving instance NFData AlexPosn + +type AlexUserState = (Int, M.Map T.Text Int, IM.IntMap (Nm AlexPosn)) + +alexInitUserState :: AlexUserState +alexInitUserState = (0, mempty, mempty) + +gets_alex :: (AlexState -> a) -> Alex a +gets_alex f = Alex (Right . (id &&& f)) + +get_pos :: Alex AlexPosn +get_pos = gets_alex alex_pos + +alexEOF = EOF <$> get_pos + +data Sym = Plus | Minus | Fold | Foldl | Percent | Times | Semicolon | Bind | Pow + | LSqBracket | RSqBracket | LBrace | RBrace | IxTimes | LParen | RParen | Lam + | Dot | Caret | Quot | Zip | Comma | Underscore | QuestionMark | Colon + | CondSplit | Cor | ArrL | ArrR | SymLog | LBind | PolyBind | LRank | Compose + | Arrow | Sig | MaxS | MinS | DIS | Succ | Conv | Access { iat :: !Int } + | TSig | Cons | Snoc | Do | Tensor | Transp | PlusPlus | Rotate + | Last | LastM | Head | HeadM | Tail | Init + | Geq | Gt | Eq | Neq | Leq | Lt + | FoldA | FoldS | Tilde | Cyc | A1 | Mod + | AtDot | Eye | Para | Weier | B | Sharp + | And | Or | Xor | Not | Sr | Sl + deriving (Generic, NFData) + +instance Pretty Sym where + pretty Plus = "+" + pretty Minus = "-" + pretty Percent = "%" + pretty Fold = "/" + pretty FoldS = "/ₒ" + pretty Foldl = "/l" + pretty FoldA = "/*" + pretty Pow = "**" + pretty Times = "*" + pretty Semicolon = ";" + pretty Colon = ":" + pretty Bind = "←" + pretty LSqBracket = "[" + pretty RSqBracket = "]" + pretty LBrace = "{" + pretty RBrace = "}" + pretty LParen = "(" + pretty RParen = ")" + pretty Lam = "λ" + pretty Dot = "." + pretty Caret = "^" + pretty Quot = "'" + pretty Zip = "`" + pretty Comma = "," + pretty Underscore = "_" + pretty QuestionMark = "?" + pretty CondSplit = ",." + pretty Cor = "⸎" + pretty ArrL = "⟨" + pretty ArrR = "⟩" + pretty SymLog = "_." + pretty LBind = "⟜" + pretty PolyBind = "⇐" + pretty LRank = "`{" + pretty Compose = "∘" + pretty Arrow = "→" + pretty Sig = "::" + pretty TSig = ":~" + pretty MaxS = "⋉" + pretty MinS = "⋊" + pretty DIS = "\\`" + pretty Succ = "\\~" + pretty Conv = "⨳" + pretty (Access i) = "->" <> pretty i + pretty Last = "}." + pretty LastM = "}.?" + pretty Head = "{." + pretty HeadM = "{.?" + pretty Cons = "⊲" + pretty Snoc = "⊳" + pretty Do = "^:" + pretty Tensor = "⊗" + pretty Transp = ":|" + pretty Geq = "≥" + pretty Gt = ">" + pretty Eq = "=" + pretty Leq = "≤" + pretty Neq = "≠" + pretty Lt = "<" + pretty Tilde = "~" + pretty PlusPlus = "⧺" + pretty Tail = "{:" + pretty Init = "}:" + pretty Rotate = "⊖" + pretty Cyc = "⊙" + pretty A1 = "˙" + pretty Mod = "|" + pretty AtDot = "@." + pretty Eye = "👁️" + pretty B = "♭" + pretty Sharp = "♮" + pretty Xor = "⊻" + pretty And = "∧" + pretty Or = "∨" + pretty Not = "¬" + pretty Weier = "℘" + pretty Para = "§" + pretty IxTimes = "×" + pretty Sr = ">>" + pretty Sl = "<<" + +-- | Reserved/special variables +data Var = VarX | VarY deriving (Generic, NFData) + +instance Pretty Var where + pretty VarX = "x" + pretty VarY = "y" + +data Builtin = BuiltinFRange | BuiltinIota | BuiltinFloor | BuiltinE | BuiltinI + | BuiltinF | BuiltinTrue | BuiltinFalse | BuiltinSqrt | BuiltinPi + | BuiltinGen | BuiltinRep | BuiltinScan | BuiltinCons | BuiltinNil + | BuiltinMMul | BuiltinArr | BuiltinInt | BuiltinFloat | BuiltinT + | BuiltinR | BuiltinSin | BuiltinCos | BuiltinScanS | BuiltinTan + | BuiltinVMul | BuiltinCyc | BuiltinOdd | BuiltinEven | BuiltinAbs + | BuiltinD | BuiltinVec | BuiltinM + deriving (Generic, NFData) + +instance Pretty Builtin where + pretty BuiltinFRange = "frange" + pretty BuiltinIota = "⍳" + pretty BuiltinFloor = "⌊" + pretty BuiltinE = "ℯ" + pretty BuiltinI = "ℝ" + pretty BuiltinF = "𝓕" + pretty BuiltinTrue = "#t" + pretty BuiltinFalse = "#f" + pretty BuiltinSqrt = "√" + pretty BuiltinPi = "𝜋" + pretty BuiltinGen = "gen." + pretty BuiltinRep = "re:" + pretty BuiltinScan = "Λ" + pretty BuiltinScanS = "Λₒ" + pretty BuiltinCons = "`Cons`" + pretty BuiltinNil = "Nil" + pretty BuiltinMMul = "%." + pretty BuiltinVMul = "%:" + pretty BuiltinArr = "Arr" + pretty BuiltinVec = "Vec" + pretty BuiltinM = "M" + pretty BuiltinInt = "int" + pretty BuiltinFloat = "float" + pretty BuiltinT = "𝓉" + pretty BuiltinR = "𝔯" + pretty BuiltinSin = "sin." + pretty BuiltinCos = "cos." + pretty BuiltinTan = "tan." + pretty BuiltinCyc = "cyc." + pretty BuiltinOdd = "odd." + pretty BuiltinEven = "even." + 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) + +instance Pretty (Token a) where + pretty EOF{} = "(eof)" + pretty (TokSym _ s) = "symbol" <+> squotes (pretty s) + pretty (TokName _ n) = "identifier" <+> squotes (pretty n) + pretty (TokB _ b) = "builtin" <+> squotes (pretty b) + pretty (TokInt _ i) = pretty i + pretty (TokResVar _ v) = "reserved variable" <+> squotes (pretty v) + pretty (TokFloat _ f) = pretty f + pretty (TokIx _ i) = pretty (pSubscript i) + +pSubscript :: Int -> T.Text +pSubscript i = + case i `quotRem` 10 of + (0, d) -> pChar d + (b, d) -> pSubscript b <> pChar d + where + pChar iϵ = T.singleton (toEnum (iϵ+8320)) + +freshName :: T.Text -> Alex (Nm AlexPosn) +freshName t = do + pos <- get_pos + (i, ns, us) <- alexGetUserState + let (j, n) = freshIdent pos t i + alexSetUserState (j, ns, us) $> (n$>pos) + +newIdentAlex :: AlexPosn -> T.Text -> Alex (Nm AlexPosn) +newIdentAlex pos t = do + st <- alexGetUserState + let (st', n) = newIdent pos t st + alexSetUserState st' $> (n $> pos) + +freshIdent :: AlexPosn -> T.Text -> Int -> (Int, Nm AlexPosn) +freshIdent pos t max' = + let i=max'+1; nm=Nm t (U i) pos + in (i, nm) + +newIdent :: AlexPosn -> T.Text -> AlexUserState -> (AlexUserState, Nm AlexPosn) +newIdent pos t pre@(max', ns, us) = + case M.lookup t ns of + 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 + (AlexState { alex_bpos = 0 + , alex_pos = alexStartPos + , alex_inp = inp + , alex_chr = '\n' + , alex_ust = ust + , alex_scd = 0 + }) + +} diff --git a/src/LI.hs b/src/LI.hs new file mode 100644 --- /dev/null +++ b/src/LI.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} + +-- live intervals +module LI ( intervals ) where + +import CF +import Control.Monad.State.Strict (execState, get, put) +import Data.Copointed +import Data.Foldable (traverse_) +import qualified Data.IntMap.Lazy as IM +import qualified Data.IntSet as IS + +collate :: IM.IntMap Int -> IM.IntMap IS.IntSet +collate = IM.unionsWith IS.union . fmap g . IM.toList where g (r, n) = IM.singleton n (IS.singleton r) + +fpF is = snd $ execState (traverse_ g is) (IS.empty, IM.empty) where + g x = do + (previouslySeen, upd) <- get + let ann = copoint x + potentiallyNew = let lx = liveness ann in fins lx <> fout lx + newS = potentiallyNew IS.\\ previouslySeen + nAt = IM.fromList (fmap (,nx ann) (IS.toList newS)) + put (previouslySeen `IS.union` newS, nAt `IM.union` upd) + +-- forward pass (first mentioned, indexed by register) +fpF, pF :: Copointed p => [p NLiveness] -> IM.IntMap Int +pF is = snd $ execState (traverse_ g is) (IS.empty, IM.empty) where + g x = do + (previouslySeen, upd) <- get + let ann = copoint x + potentiallyNew = let lx = liveness ann in ins lx <> out lx + newS = potentiallyNew IS.\\ previouslySeen + nAt = IM.fromList (fmap (,nx ann) (IS.toList newS)) + put (previouslySeen `IS.union` newS, nAt `IM.union` upd) + +-- backward pass (last mentioned, ...) +pB, fpB :: Copointed p => [p NLiveness] -> IM.IntMap Int +pB = pF.reverse +fpB = fpF.reverse + +intervals :: (Copointed p) => [p NLiveness] -> [p Live] +intervals asms = fmap (fmap lookupL) asms + where lookupL x = let n = nx x in Live (lI n findFirst) (lI n findLast) (lI n findFirstF) (lI n findLastF) + lI = IM.findWithDefault IS.empty + findFirst = collate (pF asms) + findLast = collate (pB asms) + findFirstF = collate (fpF asms) + findLastF = collate (fpB asms) diff --git a/src/LR.hs b/src/LR.hs new file mode 100644 --- /dev/null +++ b/src/LR.hs @@ -0,0 +1,67 @@ +-- Based on Appel +-- +-- live ranges +module LR ( reconstruct + , reconstructFlat + ) where + +import CF hiding (done, liveness) +import Data.Copointed +-- this seems to be faster +import qualified Data.IntMap.Lazy as IM +import qualified Data.IntSet as IS + +emptyLiveness :: Liveness +emptyLiveness = Liveness IS.empty IS.empty IS.empty IS.empty + +initLiveness :: Copointed p => [p ControlAnn] -> LivenessMap +initLiveness = IM.fromList . fmap (\asm -> let x = copoint asm in (node x, (x, emptyLiveness))) + +type LivenessMap = IM.IntMap (ControlAnn, Liveness) + +succNode :: ControlAnn -- ^ 'ControlAnn' associated w/ node @n@ + -> LivenessMap + -> [Liveness] -- ^ 'Liveness' associated with 'succNode' @n@ +succNode x ns = + let conns = conn x + in fmap (snd . flip lookupNode ns) conns + +lookupNode :: Int -> LivenessMap -> (ControlAnn, Liveness) +lookupNode = IM.findWithDefault (error "Internal error: failed to look up instruction") + +done :: LivenessMap -> LivenessMap -> Bool +done n0 n1 = {-# SCC "done" #-} and $ zipWith (\(_, l) (_, l') -> l == l') (IM.elems n0) (IM.elems n1) -- n0, n1 have same length + +-- order in which to inspect nodes during liveness analysis +inspectOrder :: Copointed p => [p ControlAnn] -> [Int] +inspectOrder = fmap (node . copoint) -- don't need to reverse because thread goes in opposite order + +reconstructFlat isns = let is=inspectOrder isns in reconstruct is (mkLiveness is isns) isns + +reconstruct :: (Copointed p) => [Int] -> LivenessMap -> [p ControlAnn] -> [p NLiveness] +reconstruct is li asms = {-# SCC "reconstructL" #-} fmap (fmap lookupL) asms + where l = liveness is li + lookupL x = let ni = node x in NLiveness ni (snd $ lookupNode ni l) + +{-# SCC mkLiveness #-} +mkLiveness :: Copointed p => [Int] -> [p ControlAnn] -> LivenessMap +mkLiveness is asms = liveness is (initLiveness asms) + +liveness :: [Int] -> LivenessMap -> LivenessMap +liveness is nSt = + if done nSt nSt' + then nSt + else liveness is nSt' + where nSt' = {-# SCC "iterNodes" #-} iterNodes is nSt + +iterNodes :: [Int] -> LivenessMap -> LivenessMap +iterNodes is = thread (fmap stepNode is) + where thread = foldr (.) id + +stepNode :: Int -> LivenessMap -> LivenessMap +stepNode n ns = {-# SCC "stepNode" #-} IM.insert n (c, Liveness ins' out' fins' fout') ns + where (c, l) = lookupNode n ns; u = ud c + ins' = usesNode u <> (out l IS.\\ defsNode u) + fins' = usesFNode u <> (fout l IS.\\ defsFNode u) + out' = IS.unions (fmap ins (succNode c ns)) + fout' = IS.unions (fmap fins (succNode c ns)) diff --git a/src/Nm.hs b/src/Nm.hs new file mode 100644 --- /dev/null +++ b/src/Nm.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveFunctor #-} + +module Nm ( Nm (..) + , TyNm + ) where + +import Control.DeepSeq (NFData (..)) +import qualified Data.Text as T +import Prettyprinter (Pretty (..)) +import U + +type TyNm a = Nm a + +data Nm a = Nm { name :: T.Text + , unique :: !U + , loc :: a + } deriving (Functor) + +instance Eq (Nm a) where + (==) (Nm _ u _) (Nm _ u' _) = u == u' + +instance Ord (Nm a) where + compare (Nm _ u _) (Nm _ u' _) = compare u u' + +instance Pretty (Nm a) where + pretty (Nm n _ _) = pretty n + -- pretty (Nm n (U i) _) = pretty n <> pretty i + +instance Show (Nm a) where + show = show . pretty + +instance NFData a => NFData (Nm a) where + rnf (Nm _ u x) = rnf x `seq` u `seq` () diff --git a/src/Nm/IntMap.hs b/src/Nm/IntMap.hs new file mode 100644 --- /dev/null +++ b/src/Nm/IntMap.hs @@ -0,0 +1,12 @@ +module Nm.IntMap ( insert + , findWithDefault + ) where + +import qualified Data.IntMap as IM +import Nm +import U + +insert :: Nm a -> b -> IM.IntMap b -> IM.IntMap b +insert (Nm _ (U i) _) = IM.insert i + +findWithDefault x (Nm _ (U i) _) = IM.findWithDefault x i diff --git a/src/Op.hs b/src/Op.hs new file mode 100644 --- /dev/null +++ b/src/Op.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Op ( FUn (..) + , FBin (..) + , IUn (..) + , BUn (..) + , IBin (..) + , BBin (..) + , IRel (..) + , FRel (..) + ) where + +import Prettyprinter (Pretty (..)) + +data FUn = FSqrt | FLog | FSin | FCos | FAbs + +data IUn = IEven | IOdd + +data BUn = BNeg + +data FBin = FPlus | FMinus | FTimes | FDiv | FMax | FMin | FExp + +data BBin = AndB | OrB | XorB + +data IBin = IPlus | IMinus | ITimes | IAsr | IMax | IMin | IDiv | IAsl | IRem | BI !BBin + +data IRel = IEq | INeq | IGt | ILt | ILeq | IGeq +data FRel = FEq | FNeq | FGt | FLt | FLeq | FGeq + +instance Pretty IRel where + pretty IEq = "="; pretty INeq = "!="; pretty IGt = ">" + pretty ILt = "<"; pretty ILeq = "≤"; pretty IGeq = "≥" + +instance Pretty FRel where + pretty FEq = "="; pretty FNeq = "!="; pretty FGt = ">" + pretty FLt = "<"; pretty FLeq = "≤"; pretty FGeq = "≥" + +instance Pretty BUn where + pretty BNeg = "¬" + +instance Pretty BBin where + pretty AndB = "∧"; pretty XorB = "⊻"; pretty OrB = "∨" + +instance Pretty IBin where + pretty IPlus = "+" + pretty IMinus = "-" + pretty ITimes = "*" + pretty IDiv = "div" + pretty IAsl = "asl"; pretty IAsr = "asr" + pretty IMax = "max"; pretty IMin = "min" + pretty IRem = "rem" + pretty (BI p) = pretty p + +instance Pretty FBin where + pretty FPlus = "+"; + pretty FMinus = "-" + pretty FTimes = "*" + pretty FDiv = "%" + pretty FExp = "^" + pretty FMax = "max" + pretty FMin = "min" + +instance Pretty FUn where + pretty FSqrt = "sqrt" + pretty FLog = "log" + pretty FSin = "sin"; pretty FCos = "cos" + pretty FAbs = "abs" + +instance Pretty IUn where + pretty IEven = "even"; pretty IOdd = "odd" diff --git a/src/P.hs b/src/P.hs new file mode 100644 --- /dev/null +++ b/src/P.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- pipeline +module P ( Err (..) + , CCtx + , tyParse + , tyParseCtx + , tyExpr + , tyOf + , tyC + , getTy + , parseInline + , parseRename + , rwP + , opt + , ir + , cmm + , eDumpC + , eDumpIR + , aarch64 + , as, x86G + , eDumpX86, eDumpAarch64 + , ex86G, eAarch64 + , bytes + , funP, aFunP + , eFunP, eAFunP + , ctxFunP, actxFunP + ) where + +import A +import A.Eta +import A.Opt +import Asm.Aarch64 +import qualified Asm.Aarch64.Byte as Aarch64 +import qualified Asm.Aarch64.Opt as Aarch64 +import qualified Asm.Aarch64.P as Aarch64 +import Asm.Aarch64.T +import Asm.M +import Asm.X86 +import Asm.X86.Byte +import Asm.X86.Opt +import qualified Asm.X86.P as X86 +import Asm.X86.Trans +import C +import C.Alloc +import C.Trans as C +import CF (Liveness) +import Control.DeepSeq (NFData) +import Control.Exception (Exception, throw, throwIO) +import Control.Monad ((<=<)) +import Control.Monad.State.Strict (evalState, state) +import Data.Bifunctor (first, second) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as T +import Data.Tuple.Extra (first3) +import Data.Typeable (Typeable) +import Data.Word (Word64) +import Foreign.Ptr (FunPtr, Ptr) +import GHC.Generics (Generic) +import I +import IR +import IR.C +import IR.Hoist +import IR.Opt +import L +import Nm +import Parser +import Parser.Rw +import Prettyprinter (Doc, Pretty (..)) +import Prettyprinter.Ext +import R.Dfn +import R.R +import Sys.DL +import Ty +import Ty.M + +data Err a = PErr (ParseE a) | TyErr (TyE a) | RErr RE deriving (Generic) + +instance Pretty a => Show (Err a) where + show = show . pretty + +instance (Pretty a, Typeable a) => Exception (Err a) where + +instance NFData a => NFData (Err a) where + +instance Pretty a => Pretty (Err a) where + pretty (PErr err) = pretty err + pretty (TyErr err) = pretty err + pretty (RErr err) = pretty err + +rwP st = fmap (uncurry renameECtx.second rewrite) . parseWithMaxCtx st + +parseRenameCtx :: AlexUserState -> BSL.ByteString -> Either (ParseE AlexPosn) (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 = parseRenameCtx alexInitUserState + +tyC :: Int -> E a -> Either (Err a) (E (T ()), [(Nm a, C)], Int) +tyC u = (\(e,cs,uϵ) -> (,cs,uϵ)<$>checkM e) <=< first TyErr . tyClosed u + +tyExpr :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann) +tyExpr = fmap prettyC.tyOf + +tyOf :: BSL.ByteString -> Either (Err AlexPosn) (T (), [(Nm AlexPosn, C)]) +tyOf = fmap (first eAnn) . annTy + +getTy :: BSL.ByteString -> Either (Err AlexPosn) (T (), [(Nm AlexPosn, C)]) +getTy = fmap (first eAnn) . checkCtx <=< annTy + +annTy :: BSL.ByteString -> Either (Err AlexPosn) (E (T ()), [(Nm AlexPosn, C)]) +annTy = fmap discard . tyConstrCtx alexInitUserState where discard (x, y, _) = (x, y) + +eFunP :: (Pretty a, Typeable a) => Int -> CCtx -> E a -> IO (Int, FunPtr b, Maybe (Ptr Word64)) +eFunP = eFunPG assembleCtx ex86G + +eAFunP :: (Pretty a, Typeable a) => Int -> (CCtx, MCtx) -> E a -> IO (Int, FunPtr b, Maybe (Ptr Word64)) +eAFunP = eFunPG Aarch64.assembleCtx eAarch64 + +eFunPG jit asm m ctx = fmap (first3 BS.length) . (jit ctx <=< either throwIO pure . asm m) + +ctxFunP :: CCtx -> BSL.ByteString -> IO (Int, FunPtr a, Maybe (Ptr Word64)) +ctxFunP = ctxFunPG assembleCtx x86G + +actxFunP :: (CCtx, MCtx) -> BSL.ByteString -> IO (Int, FunPtr a, Maybe (Ptr Word64)) +actxFunP = ctxFunPG Aarch64.assembleCtx aarch64 + +ctxFunPG jit asm ctx = fmap (first3 BS.length) . (jit ctx <=< either throwIO pure . asm) + +funP :: BSL.ByteString -> IO (FunPtr a, Maybe (Ptr Word64)) +funP = fmap π.allFp <=< either throwIO pure . x86G + +π :: (a, b, c) -> (b, c) +π (_,y,z) = (y,z) + +aFunP :: BSL.ByteString -> IO (FunPtr a, Maybe (Ptr Word64)) +aFunP = fmap π.Aarch64.allFp <=< either throwIO pure . aarch64 + +bytes :: BSL.ByteString -> Either (Err AlexPosn) BS.ByteString +bytes = fmap assemble . x86G + +as :: T.Text -> BSL.ByteString -> Doc ann +as f = prolegomena.either throw (second aso).aarch64 + where prolegomena (d,i) = ".p2align 2\n\n.data\n\n" <> pAD d <#> ".text\n\n.global " <> pSym f <#> pSym f <> ":" <#> pAsm i + +-- TODO: Call internal +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 = 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 = walloc (uncurry X86.gallocFrame) + +eAarch64 :: Int -> E a -> Either (Err a) (IR.AsmData, [AArch64 AReg FAReg ()]) +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 i = wallocE i (uncurry X86.gallocFrame) + +eDumpX86 :: Int -> E a -> Either (Err a) (Doc ann) +eDumpX86 i = fmap prettyAsm . ex86G i + +eDumpAarch64 :: Int -> E a -> Either (Err a) (Doc ann) +eDumpAarch64 i = fmap prettyAsm . eAarch64 i + +walloc f = fmap (second (optX86.optX86.f) . (\(x,aa,st) -> (aa,irToX86 st x))) . ir +wallocE i f = fmap (second (optX86.optX86.f) . (\(x,aa,st) -> (aa,irToX86 st x))) . eir i + +cmm :: BSL.ByteString -> Either (Err AlexPosn) ([CS Liveness], C.AsmData) +cmm = fmap (f.C.writeC).opt where f (cs,_,aa,t)=(frees t cs,aa) + +ec :: Int -> E a -> Either (Err a) ([CS Liveness], LSt, C.AsmData) +ec i = fmap ((\(cs,u,aa,t) -> (frees t cs,u,aa)) . C.writeC) . optE i + +ir :: BSL.ByteString -> Either (Err AlexPosn) ([Stmt], IR.AsmData, WSt) +ir = fmap (f.C.writeC).opt where f (cs,u,aa,t) = let (s,u')=cToIR u (frees t cs) in (pall (optIR s),aa,u') + +eir :: Int -> E a -> Either (Err a) ([Stmt], IR.AsmData, WSt) +eir i = fmap (f.C.writeC).optE i where f (cs,u,aa,t) = let (s,u')=cToIR u (frees t cs) in (pall (optIR s),aa,u') + +eDumpC :: Int -> E a -> Either (Err a) (Doc ann) +eDumpC i = fmap (prettyCS.𝜋).ec i where 𝜋 (a,_,c)=(c,a) + +eDumpIR :: Int -> E a -> Either (Err a) (Doc ann) +eDumpIR i = fmap (prettyIR.𝜋) . eir i where 𝜋 (a,b,_)=(b,a) + +optE :: Int -> E a -> Either (Err a) (E (T ())) +optE i e = + uncurry go <$> eInline i e where + go eϵ = evalState (β'=< runM k (optA eϵ)) + +opt :: BSL.ByteString -> Either (Err AlexPosn) (E (T ())) +opt bsl = + uncurry go <$> parseInline bsl where + go e = evalState (β'=< runM k (optA e)) + +eInline :: Int -> E a -> Either (Err a) (E (T ()), Int) +eInline m e = (\(eϵ, i) -> inline i eϵ) <$> (checkCtx =<< liftErr (fmap sel (tyClosed m e))) where sel ~(x, _, z) = (x, z); liftErr = first TyErr + +checkM :: E (T ()) -> Either (Err a) (E (T ())) +checkM e = maybe (Right e) (Left . RErr) $ check e + +checkCtx :: (E (T ()), b) -> Either (Err a) (E (T ()), b) +checkCtx (e, u) = (,u)<$>checkM e + +parseInline :: BSL.ByteString -> Either (Err AlexPosn) (E (T ()), Int) +parseInline bsl = + (\(e, i) -> inline i e) <$> (checkCtx =<< tyParse bsl) + +tyConstrCtx :: AlexUserState -> BSL.ByteString -> Either (Err AlexPosn) (E (T ()), [(Nm AlexPosn, C)], Int) +tyConstrCtx st bsl = + case parseRenameCtx st bsl of + Left err -> Left $ PErr err + Right (ast, m) -> first TyErr $ tyClosed m ast + +tyParseCtx :: AlexUserState -> BSL.ByteString -> Either (Err AlexPosn) (E (T ()), Int) +tyParseCtx st = fmap sel . tyConstrCtx st where sel ~(x, _, z) = (x, z) + +tyParse :: BSL.ByteString -> Either (Err AlexPosn) (E (T ()), Int) +tyParse = tyParseCtx alexInitUserState diff --git a/src/Parser.y b/src/Parser.y new file mode 100644 --- /dev/null +++ b/src/Parser.y @@ -0,0 +1,363 @@ +{ + {-# LANGUAGE DeriveGeneric #-} + {-# LANGUAGE OverloadedStrings #-} + module Parser ( parseWithMaxCtx + , ParseE (..) + ) where + +import Control.Exception (Exception) +import Control.Monad.Except (ExceptT, runExceptT, throwError) +import Control.Monad.Trans.Class (lift) +import Control.DeepSeq (NFData) +import Data.Bifunctor (first) +import qualified Data.ByteString.Lazy as BSL +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) +import A +import L +import Prettyprinter (Pretty (pretty), (<+>)) + +} + +%name parseE E +%name parseBind B +%tokentype { Token AlexPosn } +%error { parseError } +%monad { Parse } { (>>=) } { pure } +%lexer { lift alexMonadScan >>= } { EOF _ } + +%token + + lbrace { TokSym $$ LBrace } + rbrace { TokSym $$ RBrace } + lsqbracket { TokSym $$ LSqBracket } + rsqbracket { TokSym $$ RSqBracket } + lparen { TokSym $$ LParen } + rparen { TokSym $$ RParen } + dot { TokSym $$ Dot } + bind { TokSym $$ Bind } + lbind { TokSym $$ LBind } + polybind { TokSym $$ PolyBind } + semicolon { TokSym $$ Semicolon } + comma { TokSym $$ Comma } + underscore { TokSym $$ Underscore } + question { TokSym $$ QuestionMark } + condSplit { TokSym $$ CondSplit } + coronis { TokSym $$ Cor } + larr { TokSym $$ ArrL } + rarr { TokSym $$ ArrR } + colon { TokSym $$ Colon } + lrank { TokSym $$ LRank } + compose { TokSym $$ Compose } + sig { TokSym $$ Sig } + tsig { TokSym $$ TSig } + arrow { TokSym $$ L.Arrow } + di { TokSym $$ DIS } + succ { TokSym $$ L.Succ } + conv { TokSym $$ L.Conv } + last { TokSym $$ L.Last } + lastM { TokSym $$ L.LastM } + head { TokSym $$ L.Head } + headM { TokSym $$ L.HeadM } + tail { TokSym $$ L.Tail } + init { TokSym $$ L.Init } + do { TokSym $$ Do } + tensor { TokSym $$ Tensor } + geq { TokSym $$ Geq } + gt { TokSym $$ L.Gt } + leq { TokSym $$ Leq } + lt { TokSym $$ L.Lt } + eq { TokSym $$ L.Eq } + neq { TokSym $$ L.Neq } + and { TokSym $$ L.And } + or { TokSym $$ L.Or } + xor { TokSym $$ L.Xor } + not { TokSym $$ Not } + tilde { TokSym $$ Tilde } + pp { TokSym $$ PlusPlus } + rot { TokSym $$ Rotate } + sr { TokSym $$ L.Sr } + sl { TokSym $$ L.Sl } + + plus { TokSym $$ L.Plus } + minus { TokSym $$ L.Minus } + times { TokSym $$ L.Times } + percent { TokSym $$ Percent } + caret { TokSym $$ Caret } + max { TokSym $$ MaxS } + min { TokSym $$ MinS } + pow { TokSym $$ Pow } + at { $$@(TokSym _ Access{}) } + consS { TokSym $$ L.Cons } + snoc { TokSym $$ L.Snoc } + trans { TokSym $$ Transp } + bcyc { TokSym $$ L.Cyc } + iat { TokSym $$ L.A1 } + mod { TokSym $$ L.Mod } + atDot { TokSym $$ AtDot } + weier { TokSym $$ Weier } + para { TokSym $$ Para } + eye { TokSym $$ L.Eye } + + folds { TokSym $$ L.FoldS } + fold { TokSym $$ L.Fold } + foldl { TokSym $$ L.Foldl } + foldA { TokSym $$ L.FoldA } + quot { TokSym $$ Quot } + zip { TokSym $$ L.Zip } + flat { TokSym $$ L.B } + addd { TokSym $$ Sharp } + + lam { TokSym $$ L.Lam } + + name { TokName _ $$ } + + intLit { $$@(TokInt _ _) } + floatLit { $$@(TokFloat _ _) } + six { $$@(TokIx _ _) } + + x { TokResVar $$ VarX } + y { TokResVar $$ VarY } + + frange { TokB $$ BuiltinFRange } + iota { TokB $$ BuiltinIota } + floor { TokB $$ BuiltinFloor } + e { TokB $$ BuiltinE } + i { TokB $$ BuiltinI } + f { TokB $$ BuiltinF } + t { TokB $$ BuiltinT } + tt { TokB $$ BuiltinTrue } + ff { TokB $$ BuiltinFalse } + sqrt { TokB $$ BuiltinSqrt } + pi { TokB $$ BuiltinPi } + gen { TokB $$ BuiltinGen } + log { TokSym $$ SymLog } + re { TokB $$ BuiltinRep } + diag { TokB $$ BuiltinD } + nil { TokB $$ BuiltinNil } + cons { TokB $$ BuiltinCons } + arr { TokB $$ BuiltinArr } + ixTimes { TokSym $$ IxTimes } + vec { TokB $$ BuiltinVec } + matrix { TokB $$ BuiltinM } + int { TokB $$ BuiltinInt } + float { TokB $$ BuiltinFloat } + scanS { TokB $$ BuiltinScanS } + scan { TokB $$ BuiltinScan } + mul { TokB $$ BuiltinMMul } + vmul { TokB $$ BuiltinVMul } + r { TokB $$ BuiltinR } + sin { TokB $$ BuiltinSin } + cos { TokB $$ BuiltinCos } + tan { TokB $$ BuiltinTan } + cyc { TokB $$ BuiltinCyc } + even { TokB $$ BuiltinEven } + odd { TokB $$ BuiltinOdd } + abs { TokB $$ BuiltinAbs } + +%left paren +%nonassoc leq geq gt lt neq eq + +%% + +many(p) + : many(p) p { $2 : $1 } + | { [] } + +sepBy(p,q) + : sepBy(p,q) q p { $3 : $1 } + | p { [$1] } + +tupled(p,q) + : tupled(p,q) q p { $3 : $1 } + | p q p { $3 : [$1] } + +braces(p) + : lbrace p rbrace { $2 } + +brackets(p) + : lsqbracket p rsqbracket { $2 } + +parens(p) + : lparen p rparen { $2 } + +flipSeq(p,q) + : p q { $1 } + +I :: { I AlexPosn } + : intLit { Ix (loc $1) (fromInteger $ int $1) } + | name { IVar (Nm.loc $1) $1 } + | I plus I { StaPlus $2 $1 $3 } + +Sh :: { Sh AlexPosn } + : nil { Nil } + | I cons Sh { A.Cons $1 $3 } + | name { SVar $1 } + | parens(Sh) { $1 } + | parens(sepBy(I, ixTimes)) { foldl (flip A.Cons) Nil $1 } + +T :: { T AlexPosn } + : arr Sh T { Arr $2 $3 } + | vec I T { Arr ($2 `A.Cons` Nil) $3 } + | matrix six comma six T { Arr ((Ix (loc $2) (six $2)) `A.Cons` (Ix (loc $4) (six $4)) `A.Cons` Nil) $5 } + | matrix T {% do {i <- lift $ freshName "i"; j <- lift $ freshName "j"; pure $ Arr (IVar $1 i `A.Cons` IVar $1 j `A.Cons` Nil) $2 } } + | int { I } + | float { F } + | parens(T) { $1 } + | T arrow T { A.Arrow $1 $3 } + +R :: { (Int, Maybe [Int]) } + : intLit compose lsqbracket sepBy(intLit,comma) rsqbracket { (fromInteger $ int $1, Just (reverse (fmap (fromInteger.int) $4))) } + | intLit { (fromInteger $ int $1, Nothing) } + +-- binary operator +BBin :: { E AlexPosn } + : plus { Builtin $1 A.Plus } | minus { Builtin $1 A.Minus } + | times { Builtin $1 A.Times } | percent { Builtin $1 Div } + | caret { Builtin $1 IntExp } + | max { Builtin $1 Max } | min { Builtin $1 Min } + | scan { Builtin $1 Scan } + | quot { Builtin $1 Map } + | di intLit { Builtin $1 (DI (fromInteger $ int $2)) } + | conv braces(sepBy(intLit,comma)) { Builtin $1 (A.Conv (reverse (fmap (fromInteger.int) $2))) } + -- FIXME: not necessarily binary operator!! + | lrank sepBy(R,comma) rbrace { Builtin $1 (Rank (reverse $2)) } + | succ { Builtin $1 A.Succ } + | pow { Builtin $1 Exp } + | consS { Builtin $1 ConsE } + | snoc { Builtin $1 A.Snoc } + | mul { Builtin $1 Mul } + | vmul { Builtin $1 VMul } + | geq { Builtin $1 Gte } | gt { Builtin $1 A.Gt } + | leq { Builtin $1 Lte } | lt { Builtin $1 A.Lt } + | eq { Builtin $1 A.Eq } | neq { Builtin $1 A.Neq } + | pp { Builtin $1 CatE } + | rot { Builtin $1 Rot } + | fold { Builtin $1 A.Fold } + | bcyc { Builtin $1 A.Cyc } + | iat { Builtin $1 A.A1 } + | mod { Builtin $1 A.Mod } + | atDot { Builtin $1 IOf } + | and { Builtin $1 A.And } | or { Builtin $1 A.Or } + | xor { Builtin $1 A.Xor } + | weier { Builtin $1 Ices } + | para { Builtin $1 Filt } + | sr { Builtin $1 A.Sr } | sl { Builtin $1 A.Sl } + +B :: { (Bnd, (Nm AlexPosn, E AlexPosn)) } + : name bind E { (L, ($1, $3)) } + | name lbind E { (LL, ($1, $3)) } + | name polybind E { (D, ($1, $3)) } + +E :: { E AlexPosn } + : name { Var (Nm.loc $1) $1 } + | intLit { ILit (loc $1) (int $1) } + | floatLit { FLit (loc $1) (float $1) } + | pi { FLit $1 pi } + | tt { BLit $1 True } + | ff { BLit $1 False } + | 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)) } } + | E BBin E { EApp (eAnn $1) (EApp (eAnn $3) $2 $1) $3 } + | parens(E) { Parens (eAnn $1) $1 } + | larr sepBy(E,comma) rarr { ALit $1 (reverse $2) } + | lparen tupled(E,comma) rparen { Tup $1 (reverse $2) } + | lam name dot E { A.Lam $1 $2 $4 } + | lbrace many(flipSeq(B,semicolon)) E rbrace { mkLet $1 (reverse $2) $3 } + | coronis many(flipSeq(B,semicolon)) E { mkLet $1 (reverse $2) $3 } + | lsqbracket E rsqbracket { Dfn $1 $2 } + | frange { Builtin $1 FRange } | iota { Builtin $1 IRange } + | floor { Builtin $1 Floor } | sqrt { Builtin $1 Sqrt } | log { Builtin $1 Log } + | underscore { Builtin $1 Neg } + | gen { Builtin $1 Gen } + | colon { Builtin $1 Size } + | i { Builtin $1 ItoF } + | t { Builtin $1 Dim } + | E folds E E { EApp (eAnn $1) (EApp (eAnn $1) (EApp $2 (Builtin $2 A.FoldS) $1) $3) $4 } + | E foldl E E { EApp (eAnn $1) (EApp (eAnn $1) (EApp $2 (Builtin $2 A.Foldl) $1) $3) $4 } + | E foldA E E { EApp (eAnn $1) (EApp (eAnn $1) (EApp $2 (Builtin $2 A.FoldA) $1) $3) $4 } + | E scanS E E { EApp (eAnn $1) (EApp (eAnn $1) (EApp $2 (Builtin $2 ScanS) $1) $3) $4 } + | E zip E E { EApp (eAnn $1) (EApp (eAnn $1) (EApp $2 (Builtin $2 A.Zip) $1) $3) $4 } + | E do E E { EApp (eAnn $1) (EApp $2 (EApp $2 (Builtin $2 Iter) $1) $3) $4 } + | E E { EApp (eAnn $1) $1 $2 } + | x { ResVar $1 X } | y { ResVar $1 Y } + | f { Builtin $1 Fib } + | last { Builtin $1 A.Last } | lastM { Builtin $1 A.LastM } + | head { Builtin $1 A.Head } | headM { Builtin $1 A.HeadM } + | tail { Builtin $1 A.Tail } + | init { Builtin $1 A.Init } + | re { Builtin $1 Re } + | diag { Builtin $1 Di } + | question E condSplit E condSplit E { Cond $1 $2 $4 $6 } + | E sig T { Ann $2 $1 $3 } + | E tsig parens(Sh) {% do{a <- lift$freshName "a"; pure$Ann $2 $1 (Arr $3 (TVar a))} } + | e { EApp $1 (Builtin $1 Exp) (FLit $1 (exp 1)) } + | E at { EApp (eAnn $1) (Builtin (loc $2) (TAt (iat $ sym $2))) $1 } + | parens(at) { Builtin (loc $1) (TAt (iat $ sym $1)) } + | E E tensor E { EApp (eAnn $1) (EApp (eAnn $4) (EApp (eAnn $2) (Builtin $3 Outer) $2) $1) $4 } + | trans { Builtin $1 T } + | r { Builtin $1 R } + | sin { Builtin $1 Sin } + | cos { Builtin $1 Cos } + | tan { Builtin $1 Tan } + | cyc { Builtin $1 A.Cyc } + | tilde { Builtin $1 RevE } + | odd { Builtin $1 Odd } + | even { Builtin $1 Even } + | abs { Builtin $1 Abs } + | flat { Builtin $1 Flat } + | addd { Builtin $1 AddDim } + | not { Builtin $1 N } + | eye { Builtin $1 A.Eye } + +{ + +parseError :: Token AlexPosn -> Parse a +parseError = throwError . Unexpected + +data Bnd = L | LL | D + +mkLet :: a -> [(Bnd, (Nm a, E a))] -> E a -> E a +mkLet _ [] e = e +mkLet l ((L, b):bs) e = Let l b (mkLet l bs e) +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) + +instance Pretty a => Pretty (ParseE a) where + pretty (Unexpected tok) = pretty (loc tok) <+> "Unexpected" <+> pretty tok + pretty (LexErr str) = pretty (T.pack str) + +instance Pretty a => Show (ParseE a) where + show = show . pretty + +instance (Pretty a, Typeable a) => Exception (ParseE a) + +instance NFData a => NFData (ParseE a) where + +type Parse = ExceptT (ParseE AlexPosn) Alex + +parseAll :: AlexUserState -> BSL.ByteString -> Either (ParseE AlexPosn) (AlexUserState, E AlexPosn) +parseAll = runParseSt parseE + +parseWithMaxCtx :: AlexUserState -> BSL.ByteString -> Either (ParseE AlexPosn) (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 parser u bs = liftErr $ withAlexSt bs u (runExceptT parser) + +liftErr :: Either String (b, Either (ParseE a) c) -> Either (ParseE a) (b, c) +liftErr (Left err) = Left (LexErr err) +liftErr (Right (_, Left err)) = Left err +liftErr (Right (i, Right x)) = Right (i, x) + +} diff --git a/src/Parser/Rw.hs b/src/Parser/Rw.hs new file mode 100644 --- /dev/null +++ b/src/Parser/Rw.hs @@ -0,0 +1,99 @@ +module Parser.Rw ( rewrite + ) where + +import A + +rewrite = rw + +isBinOp :: Builtin -> Bool +isBinOp FRange = False +isBinOp IRange = False +isBinOp T = False +isBinOp Zip = False +isBinOp Rank{} = False +isBinOp Fib = False +isBinOp Log = False +isBinOp Size = False +isBinOp Sqrt = False +isBinOp Scan{} = False +isBinOp ItoF = False +isBinOp Last = False +isBinOp LastM = False +isBinOp Head = False +isBinOp HeadM = False +isBinOp Gen = False +isBinOp TAt{} = False +isBinOp Outer = False +isBinOp R = False +isBinOp Tail = False +isBinOp Init = False +isBinOp Even = False +isBinOp Odd = False +isBinOp Abs = False +isBinOp Eye = False +isBinOp Flat = False +isBinOp AddDim = False +isBinOp RevE = False +isBinOp _ = True + +fi :: Builtin -> Int +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 Plus = 6; fi Minus = 6 +fi And = 3; fi Or = 2; fi Xor = 6 +fi Map{} = 5 +fi ConsE = 4; fi Snoc = 4 +fi Eq = 4; fi Neq = 4; fi Gt = 4 +fi Lt = 4; fi Lte = 4; fi Gte = 4 +fi CatE = 5; fi Sr=8; fi Sl=8 + +lassoc :: Builtin -> Bool +lassoc IntExp = False +lassoc Exp = False +lassoc Div = True +lassoc Mod = True +lassoc Times = True +lassoc Mul = True +lassoc Plus = True +lassoc Minus = True +lassoc ConsE = False +lassoc Map{} = False +lassoc CatE = False +lassoc Sr = True +lassoc Sl = True +lassoc Xor = True +lassoc Eq = False; lassoc Neq = False +lassoc Gte = False; lassoc Lte = False +lassoc Gt = False; lassoc Lt = False + +shuntl :: Builtin -> Builtin -> Bool +shuntl op0 op1 = fi op0 > fi op1 || lassoc op0 && lassoc op1 && fi op0 == fi op1 + +rw :: E a -> E a +rw (EApp l0 (EApp l1 e0@(Builtin _ op0) e1) e2) | isBinOp op0 = + case rw e2 of + (EApp l2 (EApp l3 e3@(Builtin _ op1) e4) e5) | isBinOp op1 && shuntl op0 op1 -> EApp l0 (EApp l1 e3 (rw (EApp l2 (EApp l3 e0 e1) e4))) e5 + e2' -> EApp l0 (EApp l1 e0 (rw e1)) e2' +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 + (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 +rw (Let l (n, e') e) = Let l (n, rw e') (rw e) +rw (Def l (n, e') e) = Def l (n, rw e') (rw e) +rw (LLet l (n, e') e) = LLet l (n, rw e') (rw e) +rw (Tup l es) = Tup l (rw<$>es) +rw (ALit l es) = ALit l (rw<$>es) +rw (Lam l n e) = Lam l n (rw e) +rw (Dfn l e) = Dfn l (rw e) +rw (Parens l e) = Parens l (rw e) +rw (Ann l e t) = Ann l (rw e) (rt t) +rw (Cond l p e e') = Cond l (rw p) (rw e) (rw e') +rw e = e + +rt :: T a -> T a +rt (Arr sh (Arrow t t')) = Arrow (Arr sh (rt t)) (rt t') +rt t = t diff --git a/src/Prettyprinter/Ext.hs b/src/Prettyprinter/Ext.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Ext.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Prettyprinter.Ext ( (<#>) + , PS (..) + , parensp + , prettyLines + , tupledBy + , ptxt + , aText + , prettyDumpBinds + , pAD + ) where + +import Data.Bits (Bits (..)) +import qualified Data.IntMap as IM +import qualified Data.Text as T +import Data.Word (Word64) +import Numeric (showHex) +import Prettyprinter (Doc, LayoutOptions (..), PageWidth (AvailablePerLine), Pretty (..), SimpleDocStream, concatWith, encloseSep, flatAlt, group, hardline, + layoutSmart, parens, vsep, (<+>)) +import Prettyprinter.Render.Text (renderStrict) + +infixr 6 <#> +(<#>) :: Doc a -> Doc a -> Doc a +(<#>) x y = x <> hardline <> y + +class PS a where + ps :: Int -> a -> Doc ann + +parensp True=parens; parensp False=id + +prettyLines :: [Doc ann] -> Doc ann +prettyLines = concatWith (<#>) + +tupledBy :: Doc ann -> [Doc ann] -> Doc ann +tupledBy sep = group . encloseSep (flatAlt "( " "(") (flatAlt " )" ")") sep + +appleLO :: LayoutOptions +appleLO = LayoutOptions (AvailablePerLine 180 1.0) + +smartA :: Doc a -> SimpleDocStream a +smartA = layoutSmart appleLO + +aText :: Doc a -> T.Text +aText = renderStrict.smartA + +ptxt :: Pretty a => a -> T.Text +ptxt = aText.pretty + +prettyBind :: (Pretty c, Pretty b) => (c, b) -> Doc a +prettyBind (i, j) = pretty i <+> "→" <+> pretty j + +prettyDumpBinds :: Pretty b => IM.IntMap b -> Doc a +prettyDumpBinds b = vsep (prettyBind <$> IM.toList b) + +hex2 :: Integral a => a -> Doc ann +hex2 i | i < 16 = pretty ((($"").(('0':).).showHex) i) + | otherwise = pretty ((($"").showHex) i) + +-- FIXME: this is certainly wrong for arm/endianness +pAD ds = prettyLines ((\(n,dd) -> "arr_" <> pretty n <> ":" <+> ".8byte" <+> concatWith (\x y -> x <> "," <> y) (fmap p64 dd)) <$> IM.toList ds) + +p64 :: Word64 -> Doc ann +p64 w = "0x"<>hex2 w3<>hex2 w2<>hex2 w1<>hex2 w0 + where w0=w .&. 0xffff; w1=(w .&. 0xffff0000) `rotateR` 16; w2=(w .&. 0xFFFF00000000) `rotateR` 32; w3=(w .&. 0xFFFF000000000000) `rotateR` 48 diff --git a/src/R.hs b/src/R.hs new file mode 100644 --- /dev/null +++ b/src/R.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE RankNTypes #-} + +module R ( Rs (..), HasRs (..) + , maxLens + , rG, rE + ) where + +import A +import Control.Monad.State.Strict (StateT, runState) +import Data.Bifunctor (second) +import Data.Functor (($>)) +import qualified Data.IntMap as IM +import Lens.Micro (Lens') +import Lens.Micro.Mtl (modifying, use, (.=)) +import Nm +import Ty.Clone +import U + +data Rs = Rs { max_ :: Int, bound :: IM.IntMap Int } + +class HasRs a where + rename :: Lens' a Rs + +instance HasRs Rs where rename = id + +maxLens :: Lens' Rs Int +maxLens f s = fmap (\x -> s { max_ = x }) (f (max_ s)) + +boundLens :: Lens' Rs (IM.IntMap Int) +boundLens f s = fmap (\x -> s { bound = x }) (f (bound s)) + +-- Make sure you don't have cycles in the renames map! +replaceUnique :: (Monad m, HasRs s) => U -> StateT s m U +replaceUnique u@(U i) = do + rSt <- use (rename.boundLens) + case IM.lookup i rSt of + Nothing -> pure u + Just j -> replaceUnique (U j) + +replaceVar :: (Monad m, HasRs s) => Nm a -> StateT s m (Nm a) +replaceVar (Nm n u l) = do + u' <- replaceUnique u + pure $ Nm n u' l + +doLocal :: (HasRs s, Monad m) => StateT s m a -> StateT s m a +doLocal act = do + preB <- use (rename.boundLens) + act <* ((rename.boundLens) .= preB) + +freshen :: (HasRs s, Monad m) => Nm a -> StateT s m (Nm a) +freshen (Nm t (U i) l) = do + m <- use (rename.maxLens) + let nU=m+1 + rename.maxLens .= nU + modifying (rename.boundLens) (IM.insert i nU) $> Nm t (U nU) l + +-- globally unique +rG :: Int -> E a -> (E a, Int) +rG i = second max_ . flip runState (Rs i IM.empty) . rE + +{-# INLINABLE liftR #-} +liftR :: (HasRs s, Monad m) => T a -> StateT s m (T a) +liftR t = do + i <- use (rename.maxLens) + let (u,t',_) = cloneT i t + (rename.maxLens .= u) $> t' + +{-# INLINABLE rE #-} +rE :: (HasRs s, Monad m) => E a -> StateT s m (E a) +rE (Lam l n e) = doLocal $ do + n' <- freshen n + Lam l n' <$> rE e +rE (Let l (n, eϵ) e) = do + eϵ' <- rE eϵ + n' <- freshen n + Let l (n', eϵ') <$> rE e +rE (Def l (n, eϵ) e) = do + eϵ' <- rE eϵ + n' <- freshen n + Def l (n', eϵ') <$> rE e +rE (LLet l (n, eϵ) e) = do + eϵ' <- rE eϵ + n' <- freshen n + LLet l (n', eϵ') <$> rE e +rE e@Builtin{} = pure e +rE e@FLit{} = pure e +rE e@ILit{} = pure e +rE e@BLit{} = pure e +rE (ALit l es) = ALit l <$> traverse rE es +rE (Tup l es) = Tup l <$> traverse rE es +rE (EApp l e e') = EApp l <$> rE e <*> rE e' +rE (Cond l e e' e'') = Cond l <$> rE e <*> rE e' <*> rE e'' +rE (Var l n) = Var l <$> replaceVar n +rE (Ann l e t) = Ann l <$> rE e <*> liftR t +rE (Id l (AShLit is es)) = Id l . AShLit is <$> traverse rE es diff --git a/src/R/Dfn.hs b/src/R/Dfn.hs new file mode 100644 --- /dev/null +++ b/src/R/Dfn.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} + +module R.Dfn ( dedfn ) where + +import A +import Control.Monad.State.Strict (get, modify) +import qualified Data.Text as T +import Nm +import R.M +import U + +dummyName :: T.Text -> RM (a -> Nm a) +dummyName n = do + st <- get + Nm n (U$st+1) <$ modify (+1) + +dedfn :: Int -> E a -> (E a, Int) +dedfn i = runR i . dedfnM + +-- bottom-up +dedfnM :: E a -> RM (E a) +dedfnM e@ILit{} = pure e +dedfnM e@FLit{} = pure e +dedfnM e@BLit{} = pure e +dedfnM e@Var{} = pure e +dedfnM e@Builtin{} = pure e +dedfnM e@ResVar{} = pure e +dedfnM (Ann l e t) = Ann l <$> dedfnM e <*> pure t +dedfnM (ALit l es) = ALit l <$> traverse dedfnM es +dedfnM (Tup l es) = Tup l <$> traverse dedfnM es +dedfnM (EApp l e e') = EApp l <$> dedfnM e <*> dedfnM e' +dedfnM (Cond l e e' e'') = Cond l <$> dedfnM e <*> dedfnM e' <*> dedfnM e'' +dedfnM (Lam l n e) = Lam l n <$> dedfnM e +dedfnM (Let l (n, e) eBody) = do + e' <- dedfnM e + Let l (n, e') <$> dedfnM eBody +dedfnM (Def l (n, e) eBody) = do + e' <- dedfnM e + Def l (n, e') <$> dedfnM eBody +dedfnM (LLet l (n, e) eBody) = do + e' <- dedfnM e + LLet l (n, e') <$> dedfnM eBody +dedfnM (Dfn l e) = do + e' <- dedfnM e + x <- dummyName "x" -- TODO: do we need uniques? could rename it later + y <- dummyName "y" + let (eDone, hasY) = replaceXY x y e' + pure $ if hasY + then Lam l (x l) (Lam l (y l) eDone) + else Lam l (x l) eDone +dedfnM (Parens _ e) = dedfnM e + +-- this approach is criminally inefficient +replaceXY :: (a -> Nm a) -- ^ x + -> (a -> Nm a) -- ^ y + -> E a -> (E a, Bool) -- True if it has 'y' +replaceXY _ y (ResVar l Y) = (Var l (y l), True) +replaceXY x _ (ResVar l X) = (Var l (x l), False) +replaceXY _ _ e@FLit{} = (e, False) +replaceXY _ _ e@ILit{} = (e, False) +replaceXY _ _ e@BLit{} = (e, False) +replaceXY _ _ e@Var{} = (e, False) +replaceXY _ _ e@Builtin{} = (e, False) +replaceXY x y (Ann l e t) = + let (e', b) = replaceXY x y e + in (Ann l e' t, b) +replaceXY x y (Lam l n e) = + let (e', b) = replaceXY x y e + in (Lam l n e', b) +replaceXY x y (EApp l e e') = + let (eR, b) = replaceXY x y e + (eR', b') = replaceXY x y e' + in (EApp l eR eR', b || b') +replaceXY x y (Cond l p e e') = + let (pR, b0) = replaceXY x y p + (eR, b1) = replaceXY x y e + (eR', b2) = replaceXY x y e' + in (Cond l pR eR eR', b0 || b1 || b2) +replaceXY x y (Let l (n, e) e') = + let (eR, b) = replaceXY x y e + (eR', b') = replaceXY x y e' + in (Let l (n, eR) eR', b || b') +replaceXY x y (LLet l (n, e) e') = + let (eR, b) = replaceXY x y e + (eR', b') = replaceXY x y e' + in (LLet l (n, eR) eR', b || b') +replaceXY x y (Def l (n, e) e') = + let (eR, b) = replaceXY x y e + (eR', b') = replaceXY x y e' + in (Def l (n, eR) eR', b || b') +replaceXY x y (ALit l es) = + let (esR, bs) = unzip (fmap (replaceXY x y) es) + in (ALit l esR, or bs) +replaceXY x y (Tup l es) = + let (esR, bs) = unzip (fmap (replaceXY x y) es) + in (Tup l esR, or bs) diff --git a/src/R/M.hs b/src/R/M.hs new file mode 100644 --- /dev/null +++ b/src/R/M.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module R.M ( RM + , runR + , nextN + , nextU + ) where + +import Control.Monad.State.Strict (State, get, modify, runState) +import Data.Functor (($>)) +import qualified Data.Text as T +import Nm +import U + +type RM = State Int + +nextU :: T.Text -> a -> RM (Nm a) +nextU n l = do {i <- get; modify (+1) $> Nm n (U$i+1) l} + +nextN :: a -> RM (Nm a) +nextN = nextU "x" + +runR :: Int -> RM x -> (x, Int) +runR = flip runState diff --git a/src/R/R.hs b/src/R/R.hs new file mode 100644 --- /dev/null +++ b/src/R/R.hs @@ -0,0 +1,22 @@ +module R.R ( RM + , nextU + , runM + , module R + ) where + +import Control.Monad.State.Strict (State, gets, runState) +import Data.Bifunctor (second) +import Data.Functor (($>)) +import qualified Data.Text as T +import Lens.Micro.Mtl (modifying) +import Nm +import R +import U + +type RM = State Rs + +nextU :: T.Text -> a -> RM (Nm a) +nextU n l = do {i <- gets max_; modifying maxLens (+1) $> Nm n (U$i+1) l } + +runM :: Int -> RM a -> (a, Int) +runM i = second max_ . flip runState (Rs i mempty) diff --git a/src/Sys/DL.chs b/src/Sys/DL.chs new file mode 100644 --- /dev/null +++ b/src/Sys/DL.chs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Sys.DL ( CCtx, MCtx, libc, mem', math' ) where + +import Data.Functor (($>)) +import Foreign.C.Types (CSize) +import Data.Int (Int32) +import Foreign.Ptr (FunPtr, IntPtr (..), Ptr, castFunPtrToPtr, ptrToIntPtr) +import System.Posix.DynamicLinker.ByteString (DL, RTLDFlags (RTLD_LAZY), dlclose, dlopen, dlsym) + +#ifdef linux_HOST_OS +#include +#endif + +type CCtx = (Int, Int, Int, Int); type MCtx = (Int, Int, Int) + +math' :: IO MCtx +math' = do {(e,l,p) <- math; pure (ip e, ip l, ip p)} + +mem' :: IO CCtx +mem' = do {(m,f,xr,r) <- mem; pure (ip m, ip f, ip xr, ip r)} + +ip = (\(IntPtr i) -> i) . ptrToIntPtr . castFunPtrToPtr + +mem :: IO (FunPtr (CSize -> IO (Ptr a)), FunPtr (Ptr a -> IO ()), FunPtr (IO Double), FunPtr (IO Int32)) +mem = do {c <- libc; m <- dlsym c "malloc"; f <- dlsym c "free"; xr <- dlsym c "drand48"; r <- dlsym c "lrand48"; dlclose c$>(m,f,xr,r)} + +math :: IO (FunPtr (Double -> Double), FunPtr (Double -> Double), FunPtr (Double -> Double -> Double)) +math = do {m <- libm; e <- dlsym m "exp"; l <- dlsym m "log"; p <- dlsym m "pow"; dlclose m$>(e,l,p)} + +ll p = dlopen p [RTLD_LAZY] + +libc, libm :: IO DL +#ifdef linux_HOST_OS +libc = ll {# const LIBC_SO #} +libm = ll {# const LIBM_SO #} +#elif darwin_HOST_OS +libc = ll "libc.dylib" +libm = ll "libm.dylib" +#endif diff --git a/src/Ty.hs b/src/Ty.hs new file mode 100644 --- /dev/null +++ b/src/Ty.hs @@ -0,0 +1,944 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ty ( TyE + , tyClosed + , match + -- * Substitutions + , aT, rwArr + ) where + +import A +import Control.DeepSeq (NFData) +import Control.Exception (Exception, throw) +import Control.Monad (zipWithM) +import Control.Monad.Except (liftEither, throwError) +import Control.Monad.State.Strict (StateT (runStateT), gets, modify) +import Data.Bifunctor (first, second) +import Data.Containers.ListUtils (nubOrd) +import Data.Foldable (traverse_) +import Data.Functor (void, ($>)) +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.Maybe (catMaybes) +import qualified Data.Text as T +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Nm +import Nm.IntMap +import Prettyprinter (Doc, Pretty (..), hardline, indent, squotes, (<+>)) +import Prettyprinter.Ext +import Ty.Clone +import U + +data TySt a = TySt { maxU :: !Int + , staEnv :: IM.IntMap (T ()) + , polyEnv :: IM.IntMap (T ()) + , varConstr :: IM.IntMap (C, a) + } + +data Subst a = Subst { tySubst :: IM.IntMap (T a) + , iSubst :: IM.IntMap (I a) -- ^ Index variables + , sSubst :: IM.IntMap (Sh a) -- ^ Shape variables + } deriving (Functor) + +data TyE a = IllScoped a (Nm a) + | UF a (E a) (T a) (T a) + | UI a (I a) (I a) + | USh a (Sh a) (Sh a) + | OT a (T a) (T a) + | OSh a (Sh a) (Sh a) + | OI a (I a) (I a) + | ExistentialArg (T ()) + | MatchFailed (T ()) (T ()) + | MatchShFailed (Sh ()) (Sh ()) + | MatchIFailed a (I a) (I a) + | Doesn'tSatisfy a (T a) C + deriving (Generic) + +instance Semigroup (Subst a) where + (<>) (Subst t i s) (Subst t0 i0 s0) = Subst (t<>t0) (i<>i0) (s<>s0) + +instance Monoid (Subst a) where + mempty = Subst IM.empty IM.empty IM.empty + mappend = (<>) + +instance NFData a => NFData (TyE a) where + +instance Pretty a => Pretty (TyE a) where + pretty (IllScoped l n) = pretty l <> ":" <+> squotes (pretty n) <+> "is not in scope." + pretty (UF l e ty ty') = pretty l <> ":" <+> "could not unify" <+> squotes (pretty ty) <+> "with" <+> squotes (pretty ty') <+> "in expression" <+> squotes (pretty e) + pretty (USh l sh sh') = pretty l <> ":" <+> "could not unify shape" <+> squotes (pretty sh) <+> "with" <+> squotes (pretty sh') + pretty (UI l ix ix') = pretty l <> ":" <+> "could not unify index" <+> squotes (pretty ix) <+> "with" <+> squotes (pretty ix') + pretty (OT l ty ty') = pretty l <> ":" <+> "occurs check failed when unifying" <+> squotes (pretty ty) <+> "and" <+> squotes (pretty ty') + pretty (OI l i j) = pretty l <> ":" <+> "occurs check failed when unifying indices" <+> squotes (pretty i) <+> "and" <+> squotes (pretty j) + pretty (OSh l s0 s1) = pretty l <> ":" <+> "occurs check failed when unifying shapes" <+> squotes (pretty s0) <+> "and" <+> squotes (pretty s1) + pretty (ExistentialArg ty) = "Existential occurs as an argument in" <+> squotes (pretty ty) + pretty (MatchFailed t t') = "Failed to match" <+> squotes (pretty t) <+> "against type" <+> squotes (pretty t') + pretty (MatchShFailed sh sh') = "Failed to match" <+> squotes (pretty sh) <+> "against shape" <+> squotes (pretty sh') + pretty (MatchIFailed l i i') = pretty l <> ":" <+> "failed to match" <+> squotes (pretty i) <+> "against index" <+> squotes (pretty i') + pretty (Doesn'tSatisfy l ty c) = pretty l <+> squotes (pretty ty) <+> "is not a member of class" <+> pretty c + +instance (Pretty a) => Show (TyE a) where + show = show . pretty + +instance (Pretty a, Typeable a) => Exception (TyE a) where + +instance Pretty (Subst a) where + pretty (Subst ty i sh) = + "type:" <#*> prettyDumpBinds ty + <#> "index:" <#*> prettyDumpBinds i + <#> "shape:" <#*> prettyDumpBinds sh + +instance Show (Subst a) where show = show . pretty + +(<#*>) :: Doc a -> Doc a -> Doc a +(<#*>) x y = x <> hardline <> indent 2 y + +type TyM a = StateT (TySt a) (Either (TyE a)) + +mI :: I a -> I a -> Either (TyE a) (Subst a) +mI i0@(Ix l i) i1@(Ix _ j) | i == j = Right mempty + | otherwise = Left $ MatchIFailed l i0 i1 +mI (IVar _ (Nm _ (U i) _)) ix = Right $ Subst IM.empty (IM.singleton i ix) IM.empty +mI ix (IVar _ (Nm _ (U i) _)) = Right $ Subst IM.empty (IM.singleton i ix) IM.empty +mI (IEVar _ n) (IEVar _ n') | n == n' = Right mempty +mI (StaPlus _ i (Ix _ iϵ)) (Ix l j) | j >= iϵ = mI i (Ix l (j-iϵ)) +mI (Ix l iϵ) (StaPlus _ i (Ix _ j)) | iϵ >= j = mI i (Ix l (iϵ-j)) +mI (StaPlus _ i j) (StaPlus _ i' j') = (<>) <$> mI i i' <*> mI j j' -- FIXME: too stringent +mI (StaMul _ i j) (StaMul _ i' j') = (<>) <$> mI i i' <*> mI j j' -- FIXME: too stringent + +mSh :: Sh a -> Sh a -> Either (TyE a) (Subst a) +mSh (SVar (Nm _ (U i) _)) sh = Right $ Subst IM.empty IM.empty (IM.singleton i sh) +mSh Nil Nil = Right mempty +mSh (Cons i sh) (Cons i' sh') = (<>) <$> mI i i' <*> mSh sh sh' +mSh (Cat sh0 sh1) (Cat sh0' sh1') = (<>) <$> mSh sh0 sh0' <*> mSh sh1 sh1' +mSh (Rev sh) (Rev sh') = mSh sh sh' +mSh sh sh' = Left $ MatchShFailed (void sh) (void sh') + +match :: (Typeable a, Pretty a) => T a -> T a -> Subst a +match t t' = either throw id (maM t t') + +maM :: T a -> T a -> Either (TyE a) (Subst a) +maM I I = Right mempty +maM F F = Right mempty +maM B B = Right mempty +maM (TVar n) (TVar n') | n == n' = Right mempty +maM (TVar (Nm _ (U i) _)) t = Right $ Subst (IM.singleton i t) IM.empty IM.empty +maM (Arrow t0 t1) (Arrow t0' t1') = (<>) <$> maM t0 t0' <*> maM t1 t1' -- FIXME: use <\> over <> +maM (Arr sh t) (Arr sh' t') = (<>) <$> mSh sh sh' <*> maM t t' +maM (Arr sh t) t' = (<>) <$> mSh sh Nil <*> maM t t' +maM (P ts) (P ts') = mconcat <$> zipWithM maM ts ts' +maM (Ρ n _) (Ρ n' _) | n == n' = Right mempty +maM (Ρ n rs) t@(Ρ _ rs') | IM.keysSet rs' `IS.isSubsetOf` IM.keysSet rs = mapTySubst (insert n t) . mconcat <$> traverse (uncurry maM) (IM.elems (IM.intersectionWith (,) rs rs')) +maM (Ρ n rs) t@(P ts) | length ts >= fst (IM.findMax rs) = mapTySubst (IM.insert (unU$unique n) t) . mconcat <$> traverse (uncurry maM) [ (ts!!(i-1),tϵ) | (i,tϵ) <- IM.toList rs ] +maM t t' = Left $ MatchFailed (void t) (void t') + +shSubst :: Subst a -> Sh a -> Sh a +shSubst _ Nil = Nil +shSubst s (Cons i sh) = Cons (iSubst s !> i) (shSubst s sh) +shSubst s (Cat sh0 sh1) = Cat (shSubst s sh0) (shSubst s sh1) +shSubst s (Rev sh) = Rev (shSubst s sh) +shSubst s (Π sh) = Π (shSubst s sh) +shSubst s@(Subst ts is ss) sh'@(SVar (Nm _ (U u) _)) = + case IM.lookup u ss of + Just sh''@SVar{} -> shSubst (Subst ts is (IM.delete u ss)) sh'' + Just sh -> shSubst s sh + Nothing -> sh' + +infixr 4 !> +(!>) :: IM.IntMap (I a) -> I a -> I a +(!>) ixes ix'@(IVar _ (Nm _ (U u) _)) = + case IM.lookup u ixes of + Just ix@IVar{} -> IM.delete u ixes !> ix + Just ix -> ixes !>ix + Nothing -> ix' +(!>) ixes (StaPlus l ix ix') = StaPlus l (ixes !> ix) (ixes !> ix') +(!>) ixes (StaMul l ix ix') = StaMul l (ixes !> ix) (ixes !> ix') +(!>) _ ix@Ix{} = ix +(!>) _ ix@IEVar{} = ix + +aT :: Subst a -> T a -> T a +aT s (Arr sh ty) = Arr (shSubst s sh) (aT s ty) +aT s (Arrow t₁ t₂) = Arrow (aT s t₁) (aT s t₂) +aT s@(Subst ts is ss) ty'@(TVar n) = + let u = unU $ unique n in + case IM.lookup u ts of + Just ty@TVar{} -> aT (Subst (IM.delete u ts) is ss) ty + Just ty@Ρ{} -> aT (Subst (IM.delete u ts) is ss) ty + Just ty -> aT s ty + Nothing -> ty' +aT s (P ts) = P (aT s <$> ts) +aT s@(Subst ts is ss) (Ρ n rs) = + let u = unU (unique n) in + case IM.lookup u ts of + Just ty@Ρ{} -> aT (Subst (IM.delete u ts) is ss) ty + Just ty@TVar{} -> aT (Subst (IM.delete u ts) is ss) ty + Just ty -> aT s ty + Nothing -> Ρ n (aT s<$>rs) +aT _ ty = ty + +runTyM :: Int -> TyM a b -> Either (TyE a) (b, Int) +runTyM i = fmap (second maxU) . flip runStateT (TySt i IM.empty IM.empty IM.empty) + +mapMaxU :: (Int -> Int) -> TySt a -> TySt a +mapMaxU f (TySt u l v vcs) = TySt (f u) l v vcs + +setMaxU :: Int -> TySt a -> TySt a +setMaxU i (TySt _ l v vcs) = TySt i l v vcs + +addStaEnv :: Nm a -> T () -> TySt a -> TySt a +addStaEnv n t (TySt u l v vcs) = TySt u (insert n t l) v vcs + +addPolyEnv :: Nm a -> T () -> TySt a -> TySt a +addPolyEnv n t (TySt u l v vcs) = TySt u l (insert n t v) vcs + +addVarConstrI :: Int -> a -> C -> TySt a -> TySt a +addVarConstrI i ann c (TySt u l v vcs) = TySt u l v (IM.insert i (c, ann) vcs) + +addVarConstr :: TyNm a -> a -> C -> TySt a -> TySt a +addVarConstr tn = addVarConstrI (unU$unique tn) + +pushVarConstraint :: TyNm a -> a -> C -> TyM a () +pushVarConstraint tn l c = modify (addVarConstr tn l c) + +freshN :: T.Text -> b -> TyM a (Nm b) +freshN n l = do + modify (mapMaxU (+1)) + st <- gets maxU + pure $ Nm n (U st) l + +ft :: T.Text -> b -> TyM a (T b) +ft n l = TVar <$> freshN n l + +fsh :: T.Text -> TyM a (Sh ()) +fsh n = SVar <$> freshN n () + +ftv :: T.Text -> TyM a (T ()) +ftv n = ft n () + +mapTySubst f (Subst t i sh) = Subst (f t) i sh +mapShSubst f (Subst t i sh) = Subst t i (f sh) + +mguIPrep :: IM.IntMap (I a) -> I a -> I a -> Either (TyE a) (IM.IntMap (I a)) +mguIPrep is i0 i1 = + let i0' = is !> i0 + i1' = is !> i1 + in mguI is (rwI i0') (rwI i1') + +mguI :: IM.IntMap (I a) -> I a -> I a -> Either (TyE a) (IM.IntMap (I a)) +mguI inp i0@(Ix l i) i1@(Ix _ j) | i == j = Right inp + | otherwise = Left$ UI l i0 i1 +mguI inp i0@(IEVar l i) i1@(IEVar _ j) | i == j = Right inp + | otherwise = Left $ UI l i0 i1 +mguI inp (IVar _ i) (IVar _ j) | i == j = Right inp +mguI inp iix@(IVar l (Nm _ (U i) _)) ix | i `IS.member` occI ix = Left $ OI l iix ix + | otherwise = Right $ IM.insert i ix inp +mguI inp ix iix@(IVar l (Nm _ (U i) _)) | i `IS.member` occI ix = Left$ OI l ix iix + | otherwise = Right $ IM.insert i ix inp +mguI inp (StaPlus _ i0 (Ix _ k0)) (StaPlus _ i1 (Ix _ k1)) | k0 == k1 = mguIPrep inp i0 i1 +mguI inp (StaMul _ i0 (Ix _ k0)) (StaMul _ i1 (Ix _ k1)) | k0 == k1 = mguIPrep inp i0 i1 +mguI inp i0@(StaPlus l i (Ix _ k)) i1@(Ix lk j) | j >= k = mguIPrep inp i (Ix lk (j-k)) + | otherwise = Left $ UI l i0 i1 +mguI inp i0@Ix{} i1@(StaPlus _ _ Ix{}) = mguIPrep inp i1 i0 +mguI inp (StaMul _ i0 i1) (StaMul _ j0 j1) = do + -- FIXME: too stringent + s <- mguIPrep inp i0 j0 + mguIPrep s i1 j1 +mguI _ i0@(IEVar l _) i1@Ix{} = Left $ UI l i0 i1 +mguI _ i0@(Ix l _) i1@IEVar{} = Left $ UI l i0 i1 +mguI _ i0@(IEVar l _) i1@StaPlus{} = Left $ UI l i0 i1 +mguI _ i0@(StaPlus l _ _) i1@IEVar{} = Left $ UI l i0 i1 +mguI _ i0 i1 = error (show (i0,i1)) + +mgShPrep :: a -> Subst a -> Sh a -> Sh a -> Either (TyE a) (Subst a) +mgShPrep l s sh0 sh1 = + let sh0' = shSubst s sh0 + sh1' = shSubst s sh1 + in mgSh l s (rwSh sh0') (rwSh sh1') + +mgSh :: a -> Subst a -> Sh a -> Sh a -> Either (TyE a) (Subst a) +mgSh _ inp Nil Nil = Right inp +mgSh l inp (Cons i sh) (Cons i' sh') = do + sI <- mguIPrep (iSubst inp) i i' + mgShPrep l (inp { iSubst = sI }) sh sh' +mgSh _ inp (SVar sh) (SVar sh') | sh == sh' = Right inp +mgSh l inp s@(SVar (Nm _ (U i) _)) sh | i `IS.member` occSh sh = Left$ OSh l s sh + | otherwise = Right$ mapShSubst (IM.insert i sh) inp +mgSh l inp sh s@(SVar (Nm _ (U i) _)) | i `IS.member` occSh sh = Left$ OSh l sh s + | otherwise = Right$ mapShSubst (IM.insert i sh) inp +mgSh l _ sh@Nil sh'@Cons{} = Left $ USh l sh sh' +mgSh l _ sh@Cons{} sh'@Nil{} = Left $ USh l sh' sh +mgSh l inp (Rev sh) (Rev sh') = mgShPrep l inp sh sh' +mgSh l inp (Cat sh0 sh0') (Cat sh1 sh1') = do + s <- mgShPrep l inp sh0 sh1 + mgShPrep l s sh0' sh1' +mgSh l inp (Rev sh) sh' | (is, Nil) <- unroll sh' = do + mgShPrep l inp sh (roll Nil$reverse is) +mgSh l inp sh (Rev sh') | (is, Nil) <- unroll sh' = do + mgShPrep l inp (roll Nil$reverse is) sh + +mguPrep :: (a, E a) -> Subst a -> T a -> T a -> Either (TyE a) (Subst a) +mguPrep l s t0 t1 = + let t0' = aT s t0 + t1' = aT s t1 + in mgu l s ({-# SCC "rwArr" #-} rwArr t0') ({-# SCC "rwArr" #-} rwArr t1') + +occSh :: Sh a -> IS.IntSet +occSh (SVar (Nm _ (U i) _)) = IS.singleton i +occSh (Cat sh0 sh1) = occSh sh0 <> occSh sh1 +occSh (_ `Cons` sh) = occSh sh +occSh Nil{} = IS.empty + +occI :: I a -> IS.IntSet +occI Ix{} = IS.empty +occI (IVar _ (Nm _ (U i) _)) = IS.singleton i +occI (StaPlus _ i j) = occI i <> occI j +occI (StaMul _ i j) = occI i <> occI j +occI IEVar{} = IS.empty + +occ :: T a -> IS.IntSet +occ (TVar (Nm _ (U i) _)) = IS.singleton i +occ (Arrow t t') = occ t <> occ t' +occ (Arr _ a) = occ a -- shouldn't need shape? +occ I = IS.empty +occ F = IS.empty +occ B = IS.empty +occ Li{} = IS.empty +occ (P ts) = foldMap occ ts +occ (Ρ (Nm _ (U i) _) rs) = IS.insert i $ foldMap occ rs + +mgu :: (a, E a) -> Subst a -> T a -> T a -> Either (TyE a) (Subst a) +mgu l s (Arrow t0 t1) (Arrow t0' t1') = do + s0 <- mguPrep l s t0 t0' + mguPrep l s0 t1 t1' +mgu _ s I I = Right s +mgu _ s F F = Right s +mgu _ s B B = Right s +mgu _ s Li{} I = Right s +mgu _ s I Li{} = Right s +mgu _ s (Li i0) (Li i1) = do {iS <- mguIPrep (iSubst s) i0 i1; pure $ Subst mempty iS mempty <> s} +mgu _ s (TVar n) (TVar n') | n == n' = Right s +mgu (l, _) s t'@(TVar (Nm _ (U i) _)) t | i `IS.member` occ t = Left$ OT l t' t + | otherwise = Right $ mapTySubst (IM.insert i t) s +mgu (l, _) s t t'@(TVar (Nm _ (U i) _)) | i `IS.member` occ t = Left$ OT l t' t + | otherwise = Right $ mapTySubst (IM.insert i t) s +mgu (l, e) _ t0@Arrow{} t1 = Left $ UF l e t0 t1 +mgu (l, e) _ t0 t1@Arrow{} = Left $ UF l e t0 t1 +mgu l s (Arr sh t) (Arr sh' t') = do + s0 <- mguPrep l s t t' + mgShPrep (fst l) s0 sh sh' +mgu (l, e) _ F I = Left$ UF l e F I +mgu (l, e) _ I F = Left$ UF l e I F +mgu (l, e) _ F t@Li{} = Left$ UF l e F t +mgu (l, e) _ t@Li{} F = Left$ UF l e t F +mgu l s (Arr (SVar n) t) F = mapShSubst (insert n Nil) <$> mguPrep l s t F +mgu l s (Arr (SVar n) t) I = mapShSubst (insert n Nil) <$> mguPrep l s t I +mgu l s F (Arr (SVar n) t) = mapShSubst (insert n Nil) <$> mguPrep l s F t +mgu l s I (Arr (SVar n) t) = mapShSubst (insert n Nil) <$> mguPrep l s I t +mgu l s (Arr (SVar n) t) t'@P{} = mapShSubst (insert n Nil) <$> mguPrep l s t t' +mgu l s t'@P{} (Arr (SVar n) t) = mapShSubst (insert n Nil) <$> mguPrep l s t' t +mgu l s (P ts) (P ts') | length ts == length ts' = zS (mguPrep l) s ts ts' +-- TODO: rho occurs check +mgu l@(lϵ, e) s t@(Ρ n rs) t'@(P ts) | length ts >= fst (IM.findMax rs) && fst (IM.findMin rs) > 0 = tS (\sϵ (i, tϵ) -> mapTySubst (insert n t') <$> mguPrep l sϵ (ts!!(i-1)) tϵ) s (IM.toList rs) + | otherwise = Left$UF lϵ e t t' +mgu l s t@P{} t'@Ρ{} = mgu l s t' t +mgu l s (Ρ n rs) (Ρ n' rs') = do + rss <- tS (\sϵ (t0,t1) -> mguPrep l sϵ t0 t1) s $ IM.elems $ IM.intersectionWith (,) rs rs' + pure $ mapTySubst (insert n (Ρ n' (rs<>rs'))) rss +mgu (l, e) _ F t@Arr{} = Left $ UF l e F t +mgu (l, e) _ t@Arr{} F = Left $ UF l e t F +mgu (l, e) _ B t@Arr{} = Left $ UF l e B t +mgu (l, e) _ t@Arr{} B = Left $ UF l e t B +mgu (l, e) _ I t@Arr{} = Left $ UF l e I t +mgu (l, e) _ t@Arr{} I = Left $ UF l e t I +mgu (l, e) _ t@Li{} t'@Arr{} = Left $ UF l e t t' +mgu (l, e) _ t@Arr{} t'@Li{} = Left $ UF l e t t' +mgu (l, e) _ F t@P{} = Left $ UF l e F t +mgu (l, e) _ t@P{} F = Left $ UF l e t F +mgu (l, e) _ I t@P{} = Left $ UF l e I t +mgu (l, e) _ t@P{} I = Left $ UF l e t I +mgu (l, e) _ B t@P{} = Left $ UF l e B t +mgu (l, e) _ t@P{} B = Left $ UF l e t B +mgu (l, e) _ t@P{} t'@Arr{} = Left $ UF l e t t' +mgu (l, e) _ t@Arr{} t'@P{} = Left $ UF l e t t' +mgu (l, e) _ I B= Left $ UF l e I B +mgu (l, e) _ B I = Left $ UF l e B I +mgu (l, e) _ t@Li{} B = Left $ UF l e t B +mgu (l, e) _ B t@Li{} = Left $ UF l e B t + +zS _ s [] _ = pure s +zS _ s _ [] = pure s +zS op s (x:xs) (y:ys) = do{next <- op s x y; zS op next xs ys} + +tS :: Monad m => (Subst a -> b -> m (Subst a)) -> Subst a -> [b] -> m (Subst a) +tS _ s [] = pure s +tS f s (t:ts) = do{next <- f s t; tS f next ts} + +vx i = Cons i Nil + +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) + +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) + +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) + +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) + +sel :: [Int] -> Sh a -> Sh a +sel axes sh = roll Nil (fmap snd (filter ((`elem` axes) . fst) (zip [1..] unrolled))) where + (unrolled, _) = unroll sh + +tydrop :: Int -> Sh a -> Sh a +tydrop 0 sh = sh +tydrop _ (_ `Cons` sh) = sh + +del :: [Int] -> Sh a -> Sh a +del axes sh = roll t (fmap snd (filter ((`notElem` axes) . fst) (zip [1..] unrolled))) where + (unrolled, t) = unroll sh + +trim :: Sh a -> Sh a +trim = roll Nil . fst . unroll + +iunroll (Cons i Nil) = Just i +iunroll (Cons i shϵ) = StaMul (ia i) i <$> iunroll shϵ +iunroll _ = Nothing + +unroll (Cons i shϵ) = first (i :) $ unroll shϵ +unroll s = ([], s) + +roll :: Sh a -> [I a] -> Sh a +roll = foldr Cons + +tyB :: a -> Builtin -> TyM a (T (), Subst a) +tyB _ Floor = pure (F ~> I, mempty); tyB _ ItoF = pure (I ~> F, mempty) +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) +tyB _ Iter = do{a <- ftv "a"; let s = Arrow a a in pure (s ~> I ~> s, mempty)} +tyB _ ConsE = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + pure (a ~> Arr (i `Cons` Nil) a ~> Arr (StaPlus () i (Ix()1) `Cons` Nil) a, mempty) +tyB l Snoc = tyB l ConsE +tyB _ A1 = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + sh <- fsh "sh" + pure (Arr (i `Cons` sh) a ~> I ~> Arr sh a, mempty) +tyB _ IOf = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + pure ((a ~> B) ~> Arr (i `Cons` Nil) a ~> I, mempty) +tyB _ Di = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + pure (Arr (i `Cons` i `Cons` Nil) a ~> Arr (i `Cons` Nil) a, mempty) +tyB _ LastM = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + pure (Arr (i `Cons` Nil) a ~> a, mempty) +tyB _ Last = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + pure (Arr (StaPlus () i (Ix()1) `Cons` Nil) a ~> a, mempty) +tyB _ Head = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + pure (Arr (StaPlus () i (Ix()1) `Cons` Nil) a ~> a, mempty) +tyB _ Init = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + pure (Arr (StaPlus () i (Ix()1) `Cons` Nil) a ~> Arr (i `Cons` Nil) a, mempty) +tyB _ Tail = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + pure (Arr (StaPlus () i (Ix()1) `Cons` Nil) a ~> Arr (i `Cons` Nil) a, mempty) +tyB _ Rot = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + pure (I ~> Arr (i `Cons` Nil) a ~> Arr (i `Cons` Nil) a, mempty) +tyB _ Cyc = do + sh <- fsh "sh" + a <- ftv "a" + i <- IVar () <$> freshN "i" () + n <- IEVar () <$> freshN "n" () + pure (Arr (i `Cons` sh) a ~> I ~> Arr (n `Cons` sh) a, mempty) +tyB _ HeadM = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + pure (Arr (i `Cons` Nil) a ~> a, mempty) +tyB _ Re = do + a <- ftv "a" + n <- IEVar () <$> freshN "n" () + pure (I ~> a ~> Arr (n `Cons` Nil) a, mempty) +tyB _ FRange = do + n <- IEVar () <$> freshN "n" () + pure (F ~> F ~> I ~> Arr (n `Cons` Nil) F, mempty) +tyB _ Fib = do + n <- IEVar () <$> freshN "n" () + a <- freshN "a" () + let a' = TVar a + arrTy = Arr (n `Cons` Nil) a' + pure (a' ~> a' ~> (a' ~> a' ~> a') ~> I ~> arrTy, mempty) +tyB _ IRange = do + n <- IEVar () <$> freshN "n" () + 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 +tyB l Gte = tyOrdBinRel l; tyB l Gt = tyOrdBinRel l; tyB l Lt = tyOrdBinRel l +tyB l Lte = tyOrdBinRel l; tyB l Eq = tyOrdBinRel l; tyB l Neq = tyOrdBinRel 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) +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) +tyB l Neg = do + n <- freshN "a" l + let n' = TVar (void n) + pushVarConstraint n 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) +tyB _ Sqrt = pure (F ~> F, mempty) +tyB _ Log = pure (F ~> F, mempty) +tyB _ Div = pure (F ~> F ~> F, mempty) +tyB _ Mod = pure (I ~> I ~> I, mempty) +tyB _ IDiv = pure (I ~> I ~> I, mempty) +tyB _ Outer = do + sh0 <- fsh "sh0"; sh1 <- fsh "sh1" + a <- ftv "a"; b <- ftv "b"; c <- ftv "c" + pure ((a ~> b ~> c) ~> Arr sh0 a ~> Arr sh1 b ~> Arr (Cat sh0 sh1) c, mempty) +tyB _ T = do + sh <- fsh "sh"; a <- ftv "a" + pure (Arr sh a ~> Arr (Rev sh) a, mempty) +tyB _ Flat = do + sh <- fsh "sh"; a <- ftv "a" + pure (Arr sh a ~> Arr (Π sh) a, mempty) +tyB _ AddDim = do + 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 (Arr (vx i') n' ~> Arr (vx j') n' ~> Arr (vx $ StaPlus () i' j') n', mempty) +tyB _ Scan = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + sh <- fsh "sh" + let i1 = StaPlus () i (Ix()1) + arrTy = Arr (Cons i1 sh) a + pure ((a ~> a ~> a) ~> arrTy ~> arrTy, mempty) +tyB _ ScanS = do + a <- ftv "a"; b <- ftv "b" + i <- IVar () <$> freshN "i" () + sh <- fsh "sh" + let opTy = b ~> a ~> b + arrTy = Arr (Cons i sh); rarrTy = Arr (Cons (StaPlus () i (Ix()1)) sh) + -- FIXME: 1+1? + pure (opTy ~> b ~> arrTy a ~> rarrTy b, mempty) +tyB l (DI n) = tyB l (Conv [n]) +tyB _ (Conv ns) = do + sh <- fsh "sh" + is <- zipWithM (\_ t -> IVar () <$> freshN (T.singleton t) ()) ns ['i'..] + a <- ftv "a"; b <- ftv "b" + let nx = Ix () <$> ns + opTy = Arr (foldr Cons sh nx) a ~> b + 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 <- IVar () <$> freshN "i" () + 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) +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' + -- 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 = IVar () i `Cons` Nil + a' = TVar a; b' = TVar b; c' = TVar c + fTy = a' ~> b' ~> c' + gTy = Arr arrSh a' ~> Arr arrSh b' ~> Arr arrSh 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 + vs <- zipWithM (\_ c -> ftv (T.singleton c)) as ['a'..] + codSh <- freshN "sh" () + cod <- ftv "c" + let mArrs = zipWith Arr shs vs + codTy = Arr (SVar 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' = liftEither $ mgShPrep l mempty (sh$>l) (sh'$>l) + s <- zipWithM shUHere shsU (tail shsU++[SVar codSh]) + pure (fTy ~> rTy, mconcat s) +tyB _ Fold = do + ix <- IVar () <$> freshN "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) +tyB _ FoldS = do + ix <- IVar () <$> freshN "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) +tyB _ Foldl = do + ix <- IVar () <$> freshN "i" () + sh <- fsh "sh" + a <- ftv "a" + let sh1 = ix `Cons` sh + pure ((a ~> a ~> a) ~> a ~> Arr sh1 a ~> Arr sh a, mempty) +tyB _ FoldA = do + sh <- fsh "sh" + a <- ftv "a" + pure ((a ~> a ~> a) ~> a ~> Arr sh a ~> a, mempty) +tyB _ Dim = do + iV <- IVar () <$> freshN "i" () + shV <- fsh "sh" + a <- ftv "a" + pure (Arr (iV `Cons` shV) a ~> Li iV, mempty) +tyB _ RevE = do + iV <- IVar () <$> freshN "i" () + shV <- fsh "sh" + a <- ftv "a" + let aTy = Arr (iV `Cons` shV) a + pure (aTy ~> aTy, mempty) +tyB _ Size = do + shV <- fsh "sh" + a <- ftv "a" + pure (Arr shV a ~> I, mempty) +tyB _ Gen = do + a <- ftv "a" + n <- IEVar () <$> freshN "n" () + let arrTy = Arr (n `Cons` Nil) a + pure (a ~> (a ~> a) ~> I ~> arrTy, mempty) +tyB l Mul = do + a <- freshN "a" l + i <- IVar () <$> freshN "i" (); j <- IVar () <$> freshN "j" (); k <- IVar () <$> freshN "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) +tyB l VMul = do + a <- freshN "a" l + i <- IVar () <$> freshN "i" (); j <- IVar () <$> freshN "j" () + pushVarConstraint a l IsNum + let a' = TVar (void a) + pure (Arr (i `Cons` j `Cons` Nil) a' ~> Arr (j `Cons` Nil) a' ~> Arr (i `Cons` Nil) a', mempty) +tyB l Eye = do + a <- freshN "a" l + i <- IVar () <$> freshN "i" () + pushVarConstraint a l IsNum + let a'=TVar (void a) + 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) +tyB _ Ices = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + n <- IEVar () <$> freshN "n" () + pure ((a ~> B) ~> Arr (vx i) a ~> Arr (vx n) I, mempty) +tyB _ Filt = do + a <- ftv "a" + i <- IVar () <$> freshN "i" () + n <- IEVar () <$> freshN "n" () + pure ((a ~> B) ~> Arr (vx i) a ~> Arr (vx n) I, mempty) + +liftCloneTy :: T b -> TyM a (T b, IM.IntMap Int) +liftCloneTy t = do + i<- gets maxU + let (u,t',vs) = cloneT i t + modify (setMaxU u) $> (t',vs) + +cloneWithConstraints :: T b -> TyM a (T b) +cloneWithConstraints t = do + (t', vs) <- liftCloneTy t + traverse_ (\(k,v) -> do + cst <- gets varConstr + case IM.lookup k cst of + Just (c,l) -> modify (addVarConstrI v l c) + Nothing -> pure ()) + (IM.toList vs) + pure t' + +rwI :: I a -> I a +rwI (StaPlus l i0 i1) = + case (rwI i0, rwI i1) of + (Ix lϵ i, Ix _ j) -> Ix lϵ (i+j) + (i0', i1') -> StaPlus l i0' i1' +rwI (StaMul l i0 i1) = + case (rwI i0, rwI i1) of + (Ix lϵ i, Ix _ j) -> Ix lϵ (i*j) + (i0', i1') -> StaMul l i0' i1' +rwI i = i + +rwSh :: Sh a -> Sh a +rwSh s@SVar{} = s +rwSh s@Nil = s +rwSh (i `Cons` s) = rwI i `Cons` rwSh s +rwSh (Cat s0 s1) | (is, Nil) <- unroll (rwSh s0), (js, Nil) <- unroll (rwSh s1) = roll Nil (is++js) + | otherwise = Cat (rwSh s0) (rwSh s1) +rwSh (Rev s) | (is, Nil) <- unroll (rwSh s) = roll Nil (reverse is) + | otherwise = Rev (rwSh s) +rwSh (Π s) | Just i <- iunroll (rwSh s) = rwI i `Cons` Nil + | otherwise = Π (rwSh s) + +rwArr :: T a -> T a +rwArr (Arrow t t') = Arrow (rwArr t) (rwArr t') +rwArr I = I +rwArr B = B +rwArr F = F +rwArr t@Li{} = t +rwArr t@TVar{} = t +rwArr (P ts) = P (rwArr<$>ts) +rwArr (Arr Nil t) = rwArr t +rwArr (Arr ixes arr) | (is, Nil) <- unroll (rwSh ixes), Arr sh t <- rwArr arr = Arr (roll sh is) t +rwArr (Arr sh t) = Arr (rwSh sh) (rwArr t) +rwArr (Ρ n fs) = Ρ n (rwArr<$>fs) + +hasEI :: I a -> Bool +hasEI IEVar{} = True +hasEI (StaPlus _ ix ix') = hasEI ix || hasEI ix' +hasEI (StaMul _ ix ix') = hasEI ix || hasEI ix' +hasEI _ = False + +hasESh :: Sh a -> Bool +hasESh (Cons i sh) = hasEI i || hasESh sh +hasESh _ = False + +hasE :: T a -> Bool +hasE (Arrow t t'@Arrow{}) = hasE t || hasE t' +hasE (Arr sh t) = hasESh sh || hasE t +hasE (P ts) = any hasE ts +hasE _ = False + +chkE :: T () -> Either (TyE a) () +chkE t@Arrow{} = if hasE t then Left (ExistentialArg t) else Right () +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 t (c@IsNum, l) = Left$ Doesn'tSatisfy l t c +checkTy t (c@HasBits, l) = Left$ Doesn'tSatisfy l t c + +substI :: Subst a -> Int -> Maybe (T a) +substI s@(Subst ts is sh) i = + case IM.lookup i ts of + Just ty@TVar{} -> Just $ aT (Subst (IM.delete i ts) is sh) ty + Just ty -> Just $ aT s ty + Nothing -> Nothing + +checkClass :: Subst a -> Int -> (C, a) -> Either (TyE a) (Maybe (Nm a, C)) +checkClass s i c = + case substI s i of + Just ty -> checkTy (rwArr ty) c + Nothing -> pure Nothing + +tyClosed :: Int -> E a -> Either (TyE a) (E (T ()), [(Nm a, C)], Int) +tyClosed u e = do + ((eS, scs), i) <- runTyM u (do { (e', s) <- tyE mempty e; cvs <- gets varConstr; scs <- liftEither $ catMaybes <$> traverse (uncurry$checkClass s) (IM.toList cvs); pure (rwArr.aT (void s)<$>e', scs) }) + let vs = occ (eAnn eS); scs' = filter (\(Nm _ (U iϵ) _, _) -> iϵ `IS.member` vs) scs + chkE (eAnn eS) $> (eS, nubOrd scs', i) + +tyE :: Subst a -> E a -> TyM a (E (T ()), Subst a) +tyE s (EApp _ (Builtin _ Re) (ILit _ n)) = do + a <- ftv "a" + let arrTy = a ~> Arr (vx $ Ix () (fromInteger n)) a + pure (EApp arrTy (Builtin (I ~> arrTy) Re) (ILit I n), s) +tyE s (EApp _ (EApp _ (EApp _ (Builtin _ FRange) e0) e1) (ILit _ n)) = do + (e0',s0) <- tyE s e0; (e1',s1) <- tyE s0 e1 + let tyE0 = eAnn e0'; tyE1 = eAnn e1' + arrTy = Arr (vx (Ix () (fromInteger n))) F + l0 = eAnn e0; l1 = eAnn e1 + s0' <- liftEither $ mguPrep (l0,e0) s1 F (eAnn e0' $> l0); s1' <- liftEither $ mguPrep (l1,e1) s0' F (eAnn e1' $> l1) + pure (EApp arrTy (EApp (I ~> arrTy) (EApp (tyE1 ~> I ~> arrTy) (Builtin (tyE0 ~> tyE1 ~> I ~> arrTy) FRange) e0') e1') (ILit I n), s1') +tyE s (EApp l eϵ@(EApp _ (EApp _ (Builtin _ FRange) e0) e1) n) = do + (nA, sϵ) <- tyE s n + case aT (void sϵ) $ eAnn nA of + iT@(Li ix) -> do + (e0',s0) <- tyE sϵ e0; (e1',s1) <- tyE s0 e1 + let tyE0 = eAnn e0'; tyE1 = eAnn e1' + arrTy = Arr (vx ix) F + l0 = eAnn e0; l1 = eAnn e1 + s0' <- liftEither $ mguPrep (l0,e0) s1 F (eAnn e0' $> l0); s1' <- liftEither $ mguPrep (l1,e1) s0' F (eAnn e1' $> l1) + pure (EApp arrTy (EApp (iT ~> arrTy) (EApp (tyE1 ~> iT ~> arrTy) (Builtin (tyE0 ~> tyE1 ~> iT ~> arrTy) FRange) e0') e1') nA, s1') + _ -> do + a <- ft "a" l; b <- ft "b" l + (eϵ', s0) <- tyE sϵ eϵ + let eϵTy = a ~> b + s1 <- liftEither $ mguPrep (l,eϵ) s0 (eAnn eϵ'$>l) eϵTy + s2 <- liftEither $ mguPrep (l,n) s1 (eAnn nA$>l) a + pure (EApp (void b) eϵ' nA, s2) +tyE s (EApp _ (EApp _ (EApp _ (Builtin _ Gen) x) f) (ILit _ n)) = do + (x',s0) <- tyE s x; (f',s1) <- tyE s0 f + let tyX = eAnn x'; tyF = eAnn f' + arrTy = Arr (vx $ Ix () (fromInteger n)) tyX + lX = eAnn x; lF = eAnn f + s1' <- liftEither $ mguPrep (lF, f) s1 ((tyX $> lX) ~> (tyX $> lX)) (tyF $> lF) + pure (EApp arrTy (EApp (I ~> arrTy) (EApp (tyF ~> I ~> arrTy) (Builtin (tyX ~> tyF ~> I ~> arrTy) Gen) x') f') (ILit I n), s1') +tyE s (EApp l e@(EApp _ (EApp _ (Builtin _ Gen) x) f) n) = do + (nA, sϵ) <- tyE s n + case aT (void sϵ) $ eAnn nA of + iT@(Li ix) -> do + (x',s0) <- tyE sϵ x; (f',s1) <- tyE s0 f + let tyX = eAnn x'; tyF = eAnn f' + arrTy = Arr (vx ix) tyX + lX = eAnn x; lF = eAnn f + s1' <- liftEither $ mguPrep (lF, f) s1 ((tyX $> lX) ~> (tyX $> lX)) (tyF $> lF) + pure (EApp arrTy (EApp (iT ~> arrTy) (EApp (tyF ~> iT ~> arrTy) (Builtin (tyX ~> tyF ~> iT ~> arrTy) Gen) x') f') nA, s1') + _ -> do + a <- ft "a" l; b <- ft "b" l + (e', s0) <- tyE sϵ e + let eT = Arrow a b + s1 <- liftEither $ mguPrep (l,e) s0 (eAnn e'$>l) eT + s2 <- liftEither $ mguPrep (l,n) s1 (eAnn nA$>l) a + pure (EApp (void b) e' nA, s2) +tyE s eC@(EApp lC (EApp _ (Builtin _ Cyc) e) (ILit _ m)) = do + (e0, s0) <- tyE s e + ix <- IVar () <$> freshN "ix" () + a <- ftv "a" + let t=Arr (ix `Cons` Nil) a + arrTy = Arr (StaMul () ix (Ix () (fromIntegral m)) `Cons` Nil) a + lE=eAnn e + s1 <- liftEither $ mguPrep (lC,eC) s0 (eAnn e0$>lE) (t$>lE) + pure (EApp arrTy (EApp (I ~> arrTy) (Builtin (t ~> I ~> arrTy) Cyc) e0) (ILit I m), s1) +tyE s (EApp _ (EApp _ (EApp _ (Builtin _ IRange) (ILit _ b)) (ILit _ e)) (ILit _ si)) = do + let arrTy = Arr (vx (Ix () (fromInteger ((e-b+si) `quot` si)))) I + pure (EApp arrTy (EApp (I ~> arrTy) (EApp (I ~> I ~> arrTy) (Builtin (I ~> I ~> I ~> arrTy) IRange) (ILit I b)) (ILit I e)) (ILit I si), s) +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) +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" + modify (addStaEnv nϵ n) + (e', s') <- tyE s e + let lamTy = n ~> eAnn e' + pure (Lam lamTy (nϵ { loc = n }) e', s') +tyE s (Let _ (n, e') e) = do + (e'Res, s') <- tyE s e' + let e'Ty = eAnn e'Res + modify (addStaEnv n (aT (void s') e'Ty)) + (eRes, s'') <- tyE s' e + pure (Let (eAnn eRes) (n { loc = e'Ty }, e'Res) eRes, s'') +tyE s (Def _ (n, e') e) = do + (e'Res, s') <- tyE s e' + let e'Ty = eAnn e'Res + modify (addPolyEnv n (aT (void s') e'Ty)) + (eRes, s'') <- tyE s' e + pure (Def (eAnn eRes) (n { loc = e'Ty }, e'Res) eRes, s'') +tyE s (LLet _ (n, e') e) = do + (e'Res, s') <- tyE s e' + let e'Ty = eAnn e'Res + modify (addStaEnv n (aT (void s') e'Ty)) + (eRes, s'') <- tyE s' e + pure (LLet (eAnn eRes) (n { loc = e'Ty }, e'Res) eRes, s'') +tyE s e@(ALit l es) = do + a <- ftv "a" + (es', s') <- sSt s es + let eTys = a : fmap eAnn es' + uHere sϵ t t' = mguPrep (l,e) sϵ (t$>l) (t'$>l) + ss' <- liftEither $ zS uHere s' eTys (tail eTys) + pure (ALit (Arr (vx (Ix () $ length es)) a) es', ss') +tyE s (EApp l e0 e1) = do + a <- ft "a" l; b <- ft "b" l + (e0', s0) <- tyE s e0 + (e1', s1) <- tyE s0 e1 + let e0Ty = a ~> b + s2 <- liftEither $ mguPrep (l,e0) s1 (eAnn e0'$>l) e0Ty + s3 <- liftEither $ mguPrep (l,e1) s2 (eAnn e1'$>l) a + pure (EApp (void b) e0' e1', s3) +tyE s (Cond l p e0 e1) = do + (p',sP) <- tyE s p + (e0',s0) <- tyE sP e0 + (e1',s1) <- tyE s0 e1 + sP' <- liftEither $ mguPrep (eAnn p,p) s1 B (eAnn p'$>eAnn p); s0' <- liftEither $ mguPrep (l,e0) sP' (eAnn e0'$>l) (eAnn e1'$>eAnn e1) + pure (Cond (eAnn e0') p' e0' e1', s0') +tyE s (Var l n@(Nm _ (U u) _)) = do + lSt<- gets staEnv + case IM.lookup u lSt of + Just t -> pure (Var t (n $> t), s) + Nothing -> do + vSt<- gets polyEnv + case IM.lookup u vSt of + Just t -> do {t'<- cloneWithConstraints t; pure (Var t' (n$>t'), s)} + Nothing -> throwError $ IllScoped l n +tyE s (Tup _ es) = do + (es', s') <- sSt s es + let eTys = eAnn<$>es' + pure (Tup (P eTys) es', s') +tyE s (Ann l e t) = do + (e', s') <- tyE s e + s'' <- liftEither $ maM (aT s'$fmap ($>l) eAnn e') (aT s' (t$>l)) + pure (e', s'<>s'') + +sSt :: Subst a -> [E a] -> TyM a ([E (T ())], Subst a) +sSt s [] = pure([], s) +sSt s (e:es) = do{(e',s') <- tyE s e; first (e':) <$> sSt s' es} -- TODO: recurse other way idk diff --git a/src/Ty/Clone.hs b/src/Ty/Clone.hs new file mode 100644 --- /dev/null +++ b/src/Ty/Clone.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE RankNTypes #-} + +module Ty.Clone ( cloneT ) where + + +import A +import Control.Monad.State.Strict (State, gets, runState) +import qualified Data.IntMap as IM +import Lens.Micro (Lens') +import Lens.Micro.Mtl (modifying, use) +import Nm +import U + +data TR = TR { maxT :: Int + , boundTV :: IM.IntMap Int + , boundSh :: IM.IntMap Int + , boundIx :: IM.IntMap Int + } + +type CM = State TR + +maxTLens :: Lens' TR Int +maxTLens f s = fmap (\x -> s { maxT = x }) (f (maxT s)) + +boundTVLens :: Lens' TR (IM.IntMap Int) +boundTVLens f s = fmap (\x -> s { boundTV = x }) (f (boundTV s)) + +boundShLens :: Lens' TR (IM.IntMap Int) +boundShLens f s = fmap (\x -> s { boundSh = x }) (f (boundSh s)) + +boundIxLens :: Lens' TR (IM.IntMap Int) +boundIxLens f s = fmap (\x -> s { boundIx = x }) (f (boundIx s)) + +-- for clone +freshen :: Lens' TR (IM.IntMap Int) -- ^ TVars, shape var, etc. + -> Nm a -> CM (Nm a) +freshen lens (Nm n (U i) l) = do + modifying maxTLens (+1) + j <- gets maxT + modifying lens (IM.insert i j) + pure $ Nm n (U j) l + +tryReplaceInT :: Lens' TR (IM.IntMap Int) -> Nm a -> CM (Nm a) +tryReplaceInT lens n@(Nm t (U i) l) = do + st <- use lens + case IM.lookup i st of + Just j -> pure (Nm t (U j) l) + Nothing -> freshen lens n + +cloneT :: Int -> T a + -> (Int, T a, IM.IntMap Int) -- ^ Substition on type variables, returned so constraints can be propagated/copied +cloneT u = (\(t, TR uϵ tvs _ _) -> (uϵ,t,tvs)).flip runState (TR u IM.empty IM.empty IM.empty).cT + where + cloneIx :: I a -> CM (I a) + cloneIx i@Ix{} = pure i + cloneIx (StaPlus l i i') = StaPlus l <$> cloneIx i <*> cloneIx i' + cloneIx (StaMul l i i') = StaMul l <$> cloneIx i <*> cloneIx i' + cloneIx (IVar l n) = IVar l <$> tryReplaceInT boundIxLens n + cloneIx (IEVar l n) = IEVar l <$> tryReplaceInT boundIxLens n + + cloneSh :: Sh a -> CM (Sh a) + cloneSh Nil = pure Nil + cloneSh (Cons i sh) = Cons <$> cloneIx i <*> cloneSh sh + cloneSh (SVar n) = SVar <$> tryReplaceInT boundShLens n + cloneSh (Rev sh) = Rev <$> cloneSh sh + cloneSh (Cat sh0 sh1) = Cat <$> cloneSh sh0 <*> cloneSh sh1 + + cT :: T a -> CM (T a) + cT F = pure F + cT I = pure I + cT B = pure B + cT (Arrow t t') = Arrow <$> cT t <*> cT t' + cT (Arr sh t) = Arr <$> cloneSh sh <*> cT t + cT (TVar n) = TVar <$> tryReplaceInT boundTVLens n + cT (P ts) = P <$> traverse cT ts diff --git a/src/Ty/M.hs b/src/Ty/M.hs new file mode 100644 --- /dev/null +++ b/src/Ty/M.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ty.M ( check, RE (..) ) where + +import A +import Control.Applicative (Alternative (..)) +import Control.DeepSeq (NFData) +import Data.Foldable (asum) +import GHC.Generics (Generic) +import Prettyprinter (Pretty (..), squotes, (<+>)) + +data RE = MR (E (T ())) (T ()) | Unflat (E (T ())) (T ()) | UT (E (T ())) (T ()) | IS (Sh ()) | ES (Sh ()) deriving (Generic) + +instance NFData RE where + +instance Pretty RE where + pretty (MR e t) = "Type" <+> squotes (pretty t) <+> "of expression" <+> squotes (pretty e) <+> "is not sufficiently monomorphic." + pretty (Unflat e t) = "Error in expression" <+> squotes (pretty e) <+> "of type" <+> squotes (pretty t) <> ": arrays of functions are not supported." + pretty (UT e t) = "Type" <+> squotes (pretty t) <+> "of expression" <+> squotes (pretty e) <+> "tuples of arrays of tuples are not supported" + pretty (IS s) = "𝔯 requires statically known dimensions; inferred shape" <+> squotes (pretty s) + pretty (ES s) = "👁️ requires statically known dimensions; inferred shape" <+> squotes (pretty s) + +check = cM + +cM :: E (T ()) -> Maybe RE +cM e | Just t <- mrT (eAnn e) = Just (MR e t) +cM e | Just t <- flT (eAnn e) = Just (Unflat e t) +cM e | Just t <- ata (eAnn e) = Just (UT e t) +cM (Builtin (Arrow _ (Arrow _ (Arr sh _))) R) | dynSh sh = Just (IS sh) +cM (Builtin (Arr sh _) Eye) | dynSh sh = Just (ES sh) +cM (Let _ (_, e) e') = cM e <|> cM e' +cM (LLet _ (_, e) e') = cM e <|> cM e' +cM (Def _ _ e') = cM e' -- FIXME hm +cM (EApp _ e e') = cM e <|> cM e' +cM (ALit _ es) = foldMapAlternative cM es +cM (Lam _ _ e) = cM e +cM (Cond _ p e e') = cM p <|> cM e <|> cM e' +cM (Tup _ es) = foldMapAlternative cM es +cM Builtin{} = Nothing +cM ILit{} = Nothing +cM FLit{} = Nothing +cM BLit{} = Nothing +cM Var{} = Nothing + +mrT :: T a -> Maybe (T a) +mrT t@TVar{} = Just t +mrT (Arr _ t) = mrT t +mrT (Arrow t t') = mrT t <|> mrT t' +mrT (P ts) = foldMapAlternative mrT ts +mrT t@Ρ{} = Just t +mrT _ = Nothing + +flT :: T a -> Maybe (T a) +flT t@(Arr _ tϵ) | ha tϵ = Just t +flT (Arrow t t') = flT t <|> flT t' +flT (P ts) = foldMapAlternative flT ts +flT _ = Nothing + +ha :: T a -> Bool +ha Arrow{} = True +ha (P ts) = any ha ts +ha (Arr _ t) = ha t +ha _ = False + +har :: T a -> Bool +har Arr{} = True; har (P ts) = any har ts; har _ = False + +ata :: T a -> Maybe (T a) +ata t@(Arr _ (P ts)) | any har ts = Just t +ata (Arrow t t') = ata t <|> ata t' +ata (P t) = foldMapAlternative ata t +ata _ = Nothing + +dynI :: I a -> Bool +dynI Ix{} = False +dynI IVar{} = True +dynI IEVar{} = True + +dynSh :: Sh a -> Bool +dynSh SVar{} = True +dynSh Nil = False +dynSh (Cons i sh) = dynI i || dynSh sh + +foldMapAlternative :: (Traversable t, Alternative f) => (a -> f b) -> t a -> f b +foldMapAlternative f xs = asum (f <$> xs) diff --git a/src/U.hs b/src/U.hs new file mode 100644 --- /dev/null +++ b/src/U.hs @@ -0,0 +1,3 @@ +module U ( U (..) ) where + +newtype U = U { unU :: Int } deriving (Eq, Ord) diff --git a/test/Spec.cpphs b/test/Spec.cpphs new file mode 100644 --- /dev/null +++ b/test/Spec.cpphs @@ -0,0 +1,290 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Exception (throw) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Int (Int64) +import Foreign.C.Types (CUChar (..)) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Ptr (FunPtr, Ptr) +import Foreign.Storable (Storable (..)) +import Hs.A +import Hs.FFI +import Math.Hypergeometric (erf, hypergeometric, ncdf) +import Math.SpecialFunction (agm, bessel1, chisqcdf, completeElliptic, gamma, tcdf) +import P +import System.Info (arch) +import Test.Tasty +import Test.Tasty.HUnit + +kl :: Floating a => [a] -> [a] -> a +kl xs ys = sum [ x * log (x/y) | x <- xs, y <- ys ] + +infixl 1 .?= + +(.?=) :: (Show a, Ord a, Floating a) => a -> a -> Assertion +x .?= y = assertBool ("expected " ++ show y ++ ", got " ++ show x) ((x-y)/y<1e-15&&(y-x)/y<1e-15) + +main :: IO () +main = defaultMain $ testGroup "All" $ rTy:tyT:allT: +#ifdef x86_64_HOST_ARCH + [x64T] +#else + [] +#endif + +rTy :: TestTree +rTy = testGroup "Regression tests" + [ tyF "test/data/polymorphic.apple" + , tyF "test/examples/regress.apple" + , tyF "test/examples/convolve.apple" + , tyF "test/examples/offset.apple" + , tyF "test/examples/xor.apple" + ] + +tyT :: TestTree +tyT = testGroup "Type system" [ tyS "((-)\\~)" ] + +allT :: TestTree +allT = testGroup "jit" + [ testCase "exp (series)" $ do { res <- jitExp 20 1 ; res .?= exp 1 } + , testCase "dotprod" $ do { res <- fpAaf "test/examples/dotprod.apple" [1,2,3] [2,4,6] ; res @?= 28 } + , testCase "euclidean" $ do { res <- fpAaf "test/examples/dist.apple" [0,0,0] [3,4,5] ; res @?= sqrt 50 } + , testCase "ncdf" $ do { res <- ncdfJit 2 ; res .?= ncdf 2 } + , testCase "erf" $ do { res <- erfJit 2 ; res .?= erf 2 } + , testCase "primes" $ do { res <- fpIa "test/data/primes.apple" 30; res @?= [T,T,F,T,F,T,F,F,F,T,F,T,F,F,F,T,F,T,F,F,F,T,F,F,F,F,F,T,F] } + , testCase "twoSum" $ do { res <- fpAaf "test/data/twoSum.apple" [1,2,3] [2,4,5] ; res @?= 17 } + , testCase "Floats?" $ do { res <- jitFact 50 ; res @?= 3.0414093201713376e64 } + , testCase "shoelace" $ do { res <- fpAaf "test/examples/shoelace.apple" [0,1,1] [0,0,1] ; res @?= 0.5 } + , testCase "maxscan" $ do { res <- aaFp "bench/apple/scanmax.apple" [4::Int,6,1] ; res @?= [0::Int,4,6,6] } + , testCase "b" $ do { res <- jitB [1,2,3] [2,4,6] ; res @?= 2 } + , testCase "7-day sliding average" $ do { res <- aaFp "test/examples/weekMean.apple" [0..7::Double] ; res @?= [3,4::Double] } + , 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 "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 "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 } + , testCase "mapAa" $ do { (AA 1 [2] res) <- fpAa "test/data/maa.apple" (AA 2 [2,2] [1,2,3,4::Double]); res @?= [3,7::Double] } + , testCase "mapAa" $ do { (AA 2 [3,2] res) <- fpAa "test/data/mfa.apple" (AA 1 [3] [1,2,3::Double]); res @?= [1,1,2,2,3,3::Double] } + , testCase "consSum" $ do { (AA 1 [3] res) <- fpAaa "test/data/consSum.apple" (AA 1 [3] [1,0,0::Double]) (AA 2 [3,2] [2,3,4,5,6,9::Double]); res @?= [6,9,15::Double] } + , testCase "gen." $ do { res <- fpFfa "test/data/gen.apple" 1 (sqrt 2) ; last (hs2 <$> res) @?= (1.1981402347355923 :: Double, 1.1981402347355923 :: Double ) } + , testCase "completeElliptic" $ do { res <- fpFf "math/completeElliptic.apple" 0.8 ; res @?= completeElliptic 0.8 } + , testCase "trainXor" $ do + (AA 2 [2,2] res0, AA 1 [2] res1, AA 1 [2] res2, x) <- fpAaafp4 "test/data/trainXor.apple" (AA 2 [2,2] [0.51426693,0.56885825,0.48725347,0.15041493]) (AA 1 [2] [0.14801747,0.37182892]) (AA 1 [2] [0.79726405,0.67601843]) 0.57823076 + res0 @?= [0.5130108836813994,0.563839153826952,0.48606794571593476,0.1463165649068566] + res1 @?= [1.0692017538688703e-2,0.24098107852780348] + res2 @?= [0.7927996818471371, 0.6633059586618876] + x @?= 0.3988611249884681 + , testCase "elliptic fourier" $ do + (AA 1 [2] coeffs, a, c) <- fpAaip3 "test/examples/ellipticFourier.apple" [0,4,4::Double] [0,0,3::Double] 2 + a @?= 2.5000000000000004 + c @?= 0.9999999999999999 + last coeffs @?= (-0.28876537338066266,-0.02632401569273178,0.10638724282445484,0.342212204005514) + , testCase "ℯ_" $ do { fp <- fpn "[e:(_x)]"; ff fp 1 @?= exp (-1) } + , testCase "ℯ" $ do { res <- jitE 2.5 ; res @?= exp 2.5 } + , 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 @?= [0.0,0.0,0.0,0.0,0.0,0.0,1.0,1.0,1.0,1.0::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 "ramanujan" $ do { res <- fpFf "test/examples/ramanujanFact.apple" 7 ; res ≈ 5040 } + , rfTest + ] + +x64T :: TestTree +x64T = testGroup "x64" + [ testCase "foldl" $ do { res <- fpAf "test/data/cfLeft.apple" (4:replicate 5 8); res ≈ sqrt 17 } + , testCase "hypergeo" $ do { res <- fpAaff "math/hypergeometric.apple" [1] [3/2] 1; res @?= hypergeometric [1] [3/2] 1 } + ] + +(≈) :: (Show a, Ord a, Floating a) => a -> a -> Assertion +x ≈ y = assertBool ("expected " ++ show y ++ ", got " ++ show x) ((x-y)/y<1e-4&&(y-x)/y<1e-4) + +asN :: Storable a => U a -> IO [a] +asN = fmap asV.peek +asV (AA _ _ xs) = xs + +fpAa fp x = wA x $ \pX -> do + f <- fmap aa.fpn =<< BSL.readFile fp + peek (f pX) + +fpAaa fp x y = + wA x $ \pX -> + wA y $ \pY -> do + f <- fmap aaa.fpn =<< BSL.readFile fp + peek (f pX pY) + +aaFp fp xs = + let xA = v1 xs in + wA xA $ \p -> do + f <- fmap aa.fpn =<< BSL.readFile fp + asN (f p) + +tyS :: BSL.ByteString -> TestTree +tyS s = testCase "(expr)" $ + case tyExpr s of + Left err -> assertFailure(show err) + Right{} -> assertBool "passed" True + +tyF :: FilePath -> TestTree +tyF fp = testCase fp $ do + res <- tyExpr <$> BSL.readFile fp + case res of + Left err -> assertFailure (show err) + Right{} -> assertBool "Passes" True + +rfTest :: TestTree +rfTest = testCase "rising factorial" $ do + res <- jitRF 5 15 + res @?= 5068545850368000 + +fpAf :: FilePath -> [Double] -> IO Double +fpAf fp xs = do + f <- bytesE <$> BSL.readFile fp + jitAf f xs + +jitKl = fpAaf "test/examples/kl.apple" +jitB = fpAaf "test/examples/b.apple" + +fpAi :: FilePath -> [Int64] -> IO Int64 +fpAi fp bs = do + f <- fpn =<< BSL.readFile fp + let a=v1 bs + wA a $ \p -> pure $ ai f p + +v1 :: [a] -> Apple a +v1 xs = AA 1 [fromIntegral (length xs)] xs + +fpAaafp4 :: FilePath -> Apple Double -> Apple Double -> Apple Double -> Double -> IO (Apple Double, Apple Double, Apple Double, Double) +fpAaafp4 fp xs ys zs w = do + f <- fpn =<< BSL.readFile fp + wA xs $ \pX -> wA ys $ \pY -> wA zs $ \pZ -> do + (P4 pa0 pa1 pa2 x) <- peek (aaafp4 f pX pY pZ w) + (,,,) <$> peek pa0 <*> peek pa1 <*> peek pa2 <*> pure x + +fpAaip3 :: FilePath -> [Double] -> [Double] -> Int -> IO (Apple (Double, Double, Double, Double), Double, Double) +fpAaip3 fp xs ys n = do + f <- fpn =<< BSL.readFile fp + let a=v1 xs; b=v1 ys + wA a $ \p -> + wA b $ \q -> do + (P3 pa x0 x1) <- peek (aaip3 f p q n) + c <- peek pa + pure (hs4<$>c, x0, x1) + +-- leaks memory +fpn = fmap fst . case arch of {"aarch64" -> aFunP; "x86_64" -> funP} + +fpAaf :: FilePath -> [Double] -> [Double] -> IO Double +fpAaf fp xs ys = do + f <- fpn =<< BSL.readFile fp + jitAaf f xs ys + +fpAaff :: FilePath -> [Double] -> [Double] -> Double -> IO Double +fpAaff fp xs ys z = do {f <- bytesE <$> BSL.readFile fp; jitAaff f xs ys z} + +jitAaff :: BS.ByteString -> [Double] -> [Double] -> Double -> IO Double +jitAaff code xs ys z = + let a=v1 xs; b=v1 ys in + wA a $ \p -> wA b $ \q -> do + (fp,_) <- bsFp code + pure $ aaff fp p q z + +jitAaf :: FunPtr (U Double-> U Double -> Double) -> [Double] -> [Double] -> IO Double +jitAaf fp xs ys = + let a=v1 xs; b=v1 ys in + wA a $ \p -> wA b $ \q -> do + pure $ aaf fp p q + +jitAf :: BS.ByteString -> [Double] -> IO Double +jitAf code xs = + let a = v1 xs in + wA a $ \p -> do + (fp,_) <- bsFp code + pure $ af fp p + +jitE :: Double -> IO Double +jitE x = do + fp <- fpn "[e:x]" + pure $ ff fp x + +jitExp :: Int64 -> Double -> IO Double +jitExp = fpIff "test/examples/exp.apple" + +fpFf :: FilePath -> Double -> IO Double +fpFf fp x = do + f <- fpn =<< BSL.readFile fp + pure $ ff f x + +fpIff :: FilePath -> Int64 -> Double -> IO Double +fpIff fp x y = do + f <- fpn =<< BSL.readFile fp + pure $ iff f x y + +fpIa :: Storable a => FilePath -> Int64 -> IO [a] +fpIa fp n = do + f <- fpn =<< BSL.readFile fp + asN (ia f n) + +fpFfa :: Storable a => FilePath -> Double -> Double -> IO [a] +fpFfa fp x y = do + f <- fpn =<< BSL.readFile fp + asN (ffa f x y) + +fpFff :: FilePath -> Double -> Double -> IO Double +fpFff fp x y = do + f <- fpn =<< BSL.readFile fp + pure $ fff f x y + +fpFfff :: FilePath -> Double -> Double -> Double -> IO Double +fpFfff fp x y z = do + f <- fpn =<< BSL.readFile fp + pure $ ffff f x y z + +gammaJit = fpFf "math/gamma.apple" +ncdfJit = fpFf "math/ncdf.apple" + +erfJit :: Double -> IO Double +erfJit = fpFf "math/erf.apple" + +jitFact :: Double -> IO Double +jitFact = fpFf "test/examples/ffact.apple" + +jitRF :: Int -> Int -> IO Int +jitRF m n = do + fp <- fpn =<< BSL.readFile "test/examples/risingFactorial.apple" + pure $ runRF fp m n + +wA :: Storable a => Apple a -> (U a -> IO b) -> IO b +wA x act = + allocaBytes (sizeOf x) $ \p -> + poke p x *> act p + +bytesE = either throw id . bytes + +foreign import ccall "dynamic" ia :: FunPtr (Int64 -> U a) -> Int64 -> U a +foreign import ccall "dynamic" ai :: FunPtr (U a -> Int64) -> U a -> Int64 +foreign import ccall "dynamic" af :: FunPtr (U a -> Double) -> U a -> Double +foreign import ccall "dynamic" aaf :: FunPtr (U a -> U a -> Double) -> U a -> U a -> Double +foreign import ccall "dynamic" aaff :: FunPtr (U a -> U a -> Double -> Double) -> U a -> U a -> Double -> Double +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" ffff :: FunPtr (Double -> Double -> Double -> Double) -> Double -> Double -> Double -> Double +foreign import ccall "dynamic" ffa :: FunPtr (Double -> Double -> U a) -> Double -> Double -> U a +foreign import ccall "dynamic" iff :: FunPtr (Int64 -> Double -> Double) -> Int64 -> Double -> Double +foreign import ccall "dynamic" runRF :: FunPtr (Int -> Int -> Int) -> (Int -> Int -> Int) +foreign import ccall "dynamic" aa :: FunPtr (U a -> U b) -> U a -> U b +foreign import ccall "dynamic" aaa :: FunPtr (U a -> U b -> U c) -> U a -> U b -> U c +foreign import ccall "dynamic" aaafp4 :: FunPtr (U a -> U b -> U c -> Double -> Ptr (P4 (U d) (U e) (U f) g)) -> U a -> U b -> U c -> Double -> Ptr (P4 (U d) (U e) (U f) g) +foreign import ccall "dynamic" aaip3 :: FunPtr (U a -> U b -> Int -> Ptr (P3 c d e)) -> U a -> U b -> Int -> Ptr (P3 c d e) diff --git a/test/data/T.apple b/test/data/T.apple new file mode 100644 --- /dev/null +++ b/test/data/T.apple @@ -0,0 +1,1 @@ +[|:(x::Arr(i`Cons`j`Cons`Nil)float)] diff --git a/test/data/bha.apple b/test/data/bha.apple new file mode 100644 --- /dev/null +++ b/test/data/bha.apple @@ -0,0 +1,1 @@ +λx.λy. {sum ← [(+)/x]; sum'((<|)`{0,1} x (y::M float))} diff --git a/test/data/cfLeft.apple b/test/data/cfLeft.apple new file mode 100644 --- /dev/null +++ b/test/data/cfLeft.apple @@ -0,0 +1,1 @@ +λas. [x+1%y]/l 0 (as::Vec n float) diff --git a/test/data/coeffN.apple b/test/data/coeffN.apple new file mode 100644 --- /dev/null +++ b/test/data/coeffN.apple @@ -0,0 +1,19 @@ +-- 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ₙ) + } diff --git a/test/data/consSum.apple b/test/data/consSum.apple new file mode 100644 --- /dev/null +++ b/test/data/consSum.apple @@ -0,0 +1,1 @@ +λx.λy. {sum ← [(+)/x]; sum'((<|)`{0,1∘[2]} x (y::M float))} diff --git a/test/data/const.apple b/test/data/const.apple new file mode 100644 --- /dev/null +++ b/test/data/const.apple @@ -0,0 +1,4 @@ +{ + fact ⟜ [(*)/ₒ 1 (𝒻 1 (x-1) (⌊x))]; + fact 6+fact 7 +} diff --git a/test/data/conv.apple b/test/data/conv.apple new file mode 100644 --- /dev/null +++ b/test/data/conv.apple @@ -0,0 +1,2 @@ +-- mean filter +([((+)/* 0 (x::Arr (2`Cons`2`Cons`Nil) float))%ℝ(:x)] ⨳ {2,2}) diff --git a/test/data/dct32.apple b/test/data/dct32.apple new file mode 100644 --- /dev/null +++ b/test/data/dct32.apple @@ -0,0 +1,1 @@ +{ix ← frange 0 31 32; ix [√(1%16)*cos.(x*(y-1)*𝜋%32)]⊗ ix} diff --git a/test/data/gen.apple b/test/data/gen.apple new file mode 100644 --- /dev/null +++ b/test/data/gen.apple @@ -0,0 +1,1 @@ +\x.\y. gen. (x,y) [{a⟜x->1;g⟜x->2;((a+g)%2,√(a*g))}] 6 diff --git a/test/data/hist.apple b/test/data/hist.apple new file mode 100644 --- /dev/null +++ b/test/data/hist.apple @@ -0,0 +1,1 @@ +[cos.(2*𝜋*x)*√(_2*_.y)]`((𝔯 0 1)::Vec 1000 float) (𝔯 0 1) diff --git a/test/data/log.apple b/test/data/log.apple new file mode 100644 --- /dev/null +++ b/test/data/log.apple @@ -0,0 +1,1 @@ +[_.x] diff --git a/test/data/maa.apple b/test/data/maa.apple new file mode 100644 --- /dev/null +++ b/test/data/maa.apple @@ -0,0 +1,1 @@ +λA.[(+)/x]'(A::M float) diff --git a/test/data/map.apple b/test/data/map.apple new file mode 100644 --- /dev/null +++ b/test/data/map.apple @@ -0,0 +1,1 @@ +λX.λv. [(+)`v x]'(X::M float) diff --git a/test/data/mfa.apple b/test/data/mfa.apple new file mode 100644 --- /dev/null +++ b/test/data/mfa.apple @@ -0,0 +1,1 @@ +[(re:2)'(x::Vec n float)] diff --git a/test/data/mul.apple b/test/data/mul.apple new file mode 100644 --- /dev/null +++ b/test/data/mul.apple @@ -0,0 +1,1 @@ +[(x::M float)%.y] diff --git a/test/data/polymorphic.apple b/test/data/polymorphic.apple new file mode 100644 --- /dev/null +++ b/test/data/polymorphic.apple @@ -0,0 +1,5 @@ +⸎ + sum ⇐ [(+)/x]; + sumI ← sum (⍳ 1 1 10); + sumF ← sum (𝒻 1 10 10); + sumI + (⌊sumF) diff --git a/test/data/predictionStep.apple b/test/data/predictionStep.apple new file mode 100644 --- /dev/null +++ b/test/data/predictionStep.apple @@ -0,0 +1,6 @@ +-- ho: 4x2 wo: 2 bo: (scalar) +λho.λwo.λbo. + { sigmoid ← [1%(1+ℯ(_x))] + -- prediction: 4 + ; sigmoid'((+bo)'(ho%:wo)) + } diff --git a/test/data/primes.apple b/test/data/primes.apple new file mode 100644 --- /dev/null +++ b/test/data/primes.apple @@ -0,0 +1,5 @@ +λN. +{ + isPrime ← λn.¬((∨)/ₒ #f ([(n|x)=0]'(⍳ 2 (⌊(√(ℝn))) 1))); + isPrime'(irange 2 N 1) +} diff --git a/test/data/scan.apple b/test/data/scan.apple new file mode 100644 --- /dev/null +++ b/test/data/scan.apple @@ -0,0 +1,1 @@ +[(+) Λ 0 (⍳ 1 x 1)] diff --git a/test/data/sin.apple b/test/data/sin.apple new file mode 100644 --- /dev/null +++ b/test/data/sin.apple @@ -0,0 +1,1 @@ +sin. diff --git a/test/data/softmax.apple b/test/data/softmax.apple new file mode 100644 --- /dev/null +++ b/test/data/softmax.apple @@ -0,0 +1,10 @@ +-- https://towardsdatascience.com/mnist-handwritten-digits-classification-from-scratch-using-python-numpy-b08e401c4dab +-- def softmax(x): +-- exp_element=np.exp(x-x.max()) +-- return exp_element/np.sum(exp_element,axis=0) +λxs. + { 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)) + } diff --git a/test/data/trainXor.apple b/test/data/trainXor.apple new file mode 100644 --- /dev/null +++ b/test/data/trainXor.apple @@ -0,0 +1,23 @@ +-- see: https://towardsdatascience.com/implementing-the-xor-gate-using-backpropagation-in-neural-networks-c1f255b4f20d +-- wh: 2x2 wo: 2 bh: 2 bo: (scalar) +λwh.λwo.λbh.λbo. +{ X ⟜ ⟨⟨0,0⟩,⟨0,1⟩,⟨1,0⟩,⟨1,1⟩⟩; + Y ⟜ ⟨0,1,1,0⟩; + sigmoid ← [1%(1+ℯ(_x))]; + sDdx ← [x*(1-x)]; + sum ⇐ [(+)/x]; + -- ho: 4x2 + -- prediction: 4 + ho ⟜ sigmoid`{0} ([(+)`bh x]'(X%.wh)); + 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Δ); + boa ← bo + sum l1Δ; + (wha,woa,bha,boa) +} +-- train ⟨⟨0.51426693,0.56885825⟩,⟨0.48725347,0.15041493⟩⟩ ⟨0.14801747,0.37182892⟩ ⟨0.79726405,0.67601843⟩ 0.57823076 diff --git a/test/data/twoSum.apple b/test/data/twoSum.apple new file mode 100644 --- /dev/null +++ b/test/data/twoSum.apple @@ -0,0 +1,5 @@ +\xs.\ys. +{ + Σ ← [(+)/ₒ 0.0 x]; + (Σ xs) + (Σ ys) + 0.0 +} diff --git a/test/data/vb.apple b/test/data/vb.apple new file mode 100644 --- /dev/null +++ b/test/data/vb.apple @@ -0,0 +1,1 @@ +[(x::Arr (i`Cons`j`Cons`Nil) float)%:y] diff --git a/test/data/vmul.apple b/test/data/vmul.apple new file mode 100644 --- /dev/null +++ b/test/data/vmul.apple @@ -0,0 +1,6 @@ +λA.λx. +{ + dot ⇐ [(+)/((*)`x y)]; + -- "iterate over second axis" (i.e. columns) + (dot x)`{1∘[2]} (A::Arr (i`Cons`j`Cons`Nil) float) +} diff --git a/test/examples/approxFfact.apple b/test/examples/approxFfact.apple new file mode 100644 --- /dev/null +++ b/test/examples/approxFfact.apple @@ -0,0 +1,1 @@ +\n.(√(2*𝜋))*n**(n+1%2)*(e:(_n)) diff --git a/test/examples/argmax.apple b/test/examples/argmax.apple new file mode 100644 --- /dev/null +++ b/test/examples/argmax.apple @@ -0,0 +1,1 @@ +[{m⟜(⋉)/(x::Vec n float); (=m)@.x}] diff --git a/test/examples/b.apple b/test/examples/b.apple new file mode 100644 --- /dev/null +++ b/test/examples/b.apple @@ -0,0 +1,9 @@ +λxs.λys. +{ + Σ ← [(+)/x]; + n ⟜ ℝ(:xs); + xbar ⟜ (Σ xs)%n; ybar ← (Σ ys)%n; + xy ← Σ ((*)`xs ys); x2 ← Σ ((^2)'xs); + denom ← (x2-(n*(xbar^2))); + (xy-(n*xbar*ybar))%denom +} diff --git a/test/examples/burning.apple b/test/examples/burning.apple new file mode 100644 --- /dev/null +++ b/test/examples/burning.apple @@ -0,0 +1,12 @@ +-- https://paulbourke.net/fractals/burnship/ +{ + seq ← λcx.λcy. { + curry ← λf.λx. f (x->1) (x->2); + next ← λx.λy. { + (x^2-y^2-cx,2*abs.(x*y)-cy) + }; + gen. (cx,cy) (curry next) 256 + }; + N ← λcx.λcy. (>=10)@.([x->1^2+x->2^2]'seq cx cy); + (frange _1 1 100) N⊗ (frange _1 1 100) +} diff --git a/test/examples/coeffs.apple b/test/examples/coeffs.apple new file mode 100644 --- /dev/null +++ b/test/examples/coeffs.apple @@ -0,0 +1,22 @@ +-- 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 + ; coeffs ← λn. + { 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ₙ) + } + ; coeffs'(irange 0 N 1) + } diff --git a/test/examples/continuedFraction.apple b/test/examples/continuedFraction.apple new file mode 100644 --- /dev/null +++ b/test/examples/continuedFraction.apple @@ -0,0 +1,1 @@ +λas. [y+1%x]/ₒ 0 as diff --git a/test/examples/convolve.apple b/test/examples/convolve.apple new file mode 100644 --- /dev/null +++ b/test/examples/convolve.apple @@ -0,0 +1,2 @@ +-- mean filter +([((+)/* 0 (x::Arr (7`Cons`7`Cons`Nil) float))%ℝ(:x)] ⨳ {7,7}) diff --git a/test/examples/dilogarithm.apple b/test/examples/dilogarithm.apple new file mode 100644 --- /dev/null +++ b/test/examples/dilogarithm.apple @@ -0,0 +1,1 @@ +\z.\N. (+)/ 0 ((\k.(z^k)%(itof (k^2)))'1 irange 1 N 1) diff --git a/test/examples/dist.apple b/test/examples/dist.apple new file mode 100644 --- /dev/null +++ b/test/examples/dist.apple @@ -0,0 +1,1 @@ +[√((+)/((^2)'((-)`x y)))] diff --git a/test/examples/dotprod.apple b/test/examples/dotprod.apple new file mode 100644 --- /dev/null +++ b/test/examples/dotprod.apple @@ -0,0 +1,1 @@ +[(+)/ ((*)`((x::Arr (i `Cons` Nil) float)) y)] diff --git a/test/examples/e.apple b/test/examples/e.apple new file mode 100644 --- /dev/null +++ b/test/examples/e.apple @@ -0,0 +1,7 @@ +λN. +{ + sum ← λn.λN.λf. (+)/ 0 (f'1 (irange n N 1)); + fact ← [(*)/ 1 (frange 1 x (⌊x))]; + ix ← λn. 1%(fact (𝑖n)); + sum 0 N ix +} diff --git a/test/examples/ellipticFourier.apple b/test/examples/ellipticFourier.apple new file mode 100644 --- /dev/null +++ b/test/examples/ellipticFourier.apple @@ -0,0 +1,27 @@ +λ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) + ; 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) + ; 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ₙ) + } + ; dtss ⟜ (-)\~((^2)'pts) + ; 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 + ; (coeffs'(irange 1 N 1),A,C) + } diff --git a/test/examples/entropy.apple b/test/examples/entropy.apple new file mode 100644 --- /dev/null +++ b/test/examples/entropy.apple @@ -0,0 +1,1 @@ +\p. (+)/([x*_.x]'p) diff --git a/test/examples/exp.apple b/test/examples/exp.apple new file mode 100644 --- /dev/null +++ b/test/examples/exp.apple @@ -0,0 +1,7 @@ +λN.λx. +{ + fact ← [(*)/ₒ 1 (𝒻 1 x (⌊x))]; + iix ← irange 0 N 1; + mkIx ← λn. (x^n)%(fact (ℝn)); + (+)/ₒ 0 (mkIx'iix) +} diff --git a/test/examples/expSum.apple b/test/examples/expSum.apple new file mode 100644 --- /dev/null +++ b/test/examples/expSum.apple @@ -0,0 +1,7 @@ +λN.λx. +{ + sumi ← λn.λN.λf. (+)/ₒ 0 (f'1 (irange n N 1)); + fact ← [(*)/ₒ 1 (frange 1 x (⌊x))]; + mkIx ← λn. (x^n)%(fact (𝑖n)); + sumi 0 N mkIx +} diff --git a/test/examples/fact.apple b/test/examples/fact.apple new file mode 100644 --- /dev/null +++ b/test/examples/fact.apple @@ -0,0 +1,1 @@ +[(*)/ ⍳ 1 x 1] diff --git a/test/examples/ffact.apple b/test/examples/ffact.apple new file mode 100644 --- /dev/null +++ b/test/examples/ffact.apple @@ -0,0 +1,1 @@ +[(*)/ₒ 1 (frange 1 x (|.x))] diff --git a/test/examples/fib.apple b/test/examples/fib.apple new file mode 100644 --- /dev/null +++ b/test/examples/fib.apple @@ -0,0 +1,1 @@ +\N. 𝓕 1 1 (+) N diff --git a/test/examples/fizzbuzz.apple b/test/examples/fizzbuzz.apple new file mode 100644 --- /dev/null +++ b/test/examples/fizzbuzz.apple @@ -0,0 +1,1 @@ +([?x|3=0,.?x|5=0,.15,.3,.?x|5=0,.5,.0.0]') diff --git a/test/examples/isPrime.apple b/test/examples/isPrime.apple new file mode 100644 --- /dev/null +++ b/test/examples/isPrime.apple @@ -0,0 +1,1 @@ +λn.¬((∨)/ₒ #f ([(n|x)=0]'(⍳ 2 (⌊(√(ℝn))) 1))) diff --git a/test/examples/isbn.apple b/test/examples/isbn.apple new file mode 100644 --- /dev/null +++ b/test/examples/isbn.apple @@ -0,0 +1,1 @@ +[(+)/(*)`(gen. 10 (-1) 10)x] diff --git a/test/examples/isbn10.apple b/test/examples/isbn10.apple new file mode 100644 --- /dev/null +++ b/test/examples/isbn10.apple @@ -0,0 +1,2 @@ +-- https://mlochbaum.github.io/bqncrate/ +[((+)/((*)`(gen. 10 (-1) 10)x))|11] diff --git a/test/examples/kl.apple b/test/examples/kl.apple new file mode 100644 --- /dev/null +++ b/test/examples/kl.apple @@ -0,0 +1,1 @@ +λp.λq. (+)/([x*_.(x%y)]`p q) diff --git a/test/examples/lnSeries.apple b/test/examples/lnSeries.apple new file mode 100644 --- /dev/null +++ b/test/examples/lnSeries.apple @@ -0,0 +1,10 @@ +-- ln(1+x) by x - x^2/2 + x^3/3 - x^4/4 + ... +-- converges -1≤x≤1 +-- +-- not very good. +λN.λx. +{ + iix ← irange 1 N 1; + mkIx ← λn. (_((_ x)^n))%(𝑖n); + (+)/ 0 (mkIx'iix) +} diff --git a/test/examples/log.apple b/test/examples/log.apple new file mode 100644 --- /dev/null +++ b/test/examples/log.apple @@ -0,0 +1,1 @@ +[(_.x)%(_.10)] diff --git a/test/examples/luhn.apple b/test/examples/luhn.apple new file mode 100644 --- /dev/null +++ b/test/examples/luhn.apple @@ -0,0 +1,6 @@ +-- 16-digit for credit card +λxs. + { digitSum ← [?x>10,.x-9,.x] + ; t ← (+)/ [digitSum (x*y)]`(~(}:xs)) (}: (cyc. ⟨2,1::int⟩ 8)) + ; 10-(t|10)=}.xs + } diff --git a/test/examples/mandel.apple b/test/examples/mandel.apple new file mode 100644 --- /dev/null +++ b/test/examples/mandel.apple @@ -0,0 +1,14 @@ +-- counts divergence +{ mseq ← + λz. + { + add ← λz0.λz1. (z0->1+z1->1, z0->2+z1->2); + sq ← λz. { + r ⟜ z->1;i ⟜ z->2; + (r^2-i^2,2*r*i) + }; + abs ← λz. {r ⟜ z->1; i ⟜ z->2; √(r^2+i^2)}; + abs'gen. (0.0,0.0) [add (sq x) z] 64 + }; + [(>4)@.mseq x]`{0} ((frange _2.5 1 700) [(x,y)]⊗ (frange _1 1 400)) +} diff --git a/test/examples/meshgrid.apple b/test/examples/meshgrid.apple new file mode 100644 --- /dev/null +++ b/test/examples/meshgrid.apple @@ -0,0 +1,7 @@ +-- https://numpy.org/doc/stable/reference/generated/numpy.meshgrid.html +\x.\y. + { xn ← :x; yn ← :y + ; xx ← re: yn (x :: Vec i float) + ; yy ← re: xn (y :: Vec i float) + ; (xx,yy) + } diff --git a/test/examples/mul.apple b/test/examples/mul.apple new file mode 100644 --- /dev/null +++ b/test/examples/mul.apple @@ -0,0 +1,1 @@ +\x.\y. |: ((x%:)`{1∘[1]} (y::M float)) diff --git a/test/examples/neuralNetwork.apple b/test/examples/neuralNetwork.apple new file mode 100644 --- /dev/null +++ b/test/examples/neuralNetwork.apple @@ -0,0 +1,10 @@ +{ + softmax ← λx. { + -- TODO: softmax... what's the key for max? + xs ⟜ [ℯ(_x)]'1 x; + avg ← (+)/ 0 xs; + (%avg)'1 xs + }; + sigmoid ← [1+ℯ(_x)]; + sigmoid +} diff --git a/test/examples/offset.apple b/test/examples/offset.apple new file mode 100644 --- /dev/null +++ b/test/examples/offset.apple @@ -0,0 +1,15 @@ +-- A0 and C0 in Kuhl+Giardina +λxs.λys. + { sum ← [(+)/x] + ; tieSelf ← [({.x)⊳x]; Δ ← [(-)\~(tieSelf x)] + ; dxs ⟜ Δ xs; dys ⟜ Δ ys + ; dts ⟜ [√(x^2+y^2)]`dxs dys + ; pxs ← (+)Λ dxs; pys ← (+)Λ dys; pts ⟜ (+)Λ dts + ; dtss ⟜ (-)\~((^2)'(0<|pts)) + ; T ⟜}. pts + ; 𝜉 ← (-)`pxs ((*)`((%)`dxs dts) pts) + ; 𝛿 ← (-)`pys ((*)`((%)`dys dts) pts) + ; A ← ((sum ((*)`((%)`dxs dts) dtss))%2 + (sum ((*)`𝜉 dts)))%T + ; C ← ((sum ((*)`((%)`dys dts) dtss))%2 + (sum ((*)`𝛿 dts)))%T + ; (A,C) + } diff --git a/test/examples/orbit.apple b/test/examples/orbit.apple new file mode 100644 --- /dev/null +++ b/test/examples/orbit.apple @@ -0,0 +1,10 @@ +-- a=2.576 +-- b=4.628 +λa.λb. +{ + g ← λz. + { x ⟜ z->1; y ⟜ z->2 + ; (sin. (x^2-y^2+a), cos. (2*x*y+b)) + }; + (frange _0.455 1 100) [(gen. (x,y) g 200)]⊗ (frange _1 0.515 100) +} diff --git a/test/examples/partition.apple b/test/examples/partition.apple new file mode 100644 --- /dev/null +++ b/test/examples/partition.apple @@ -0,0 +1,1 @@ +([?x>5.0,.1.0,.0.0]') diff --git a/test/examples/perimeter.apple b/test/examples/perimeter.apple new file mode 100644 --- /dev/null +++ b/test/examples/perimeter.apple @@ -0,0 +1,5 @@ +λxs.λys. + { sum ← [(+)/ 0 x] + ; succDiff ← ((-)\~) + ; sum ([√(x^2+y^2)]`(succDiff xs) (succDiff ys)) + } diff --git a/test/examples/poly.apple b/test/examples/poly.apple new file mode 100644 --- /dev/null +++ b/test/examples/poly.apple @@ -0,0 +1,1 @@ +λp.λx. (+)/ ((*)`(~p) (gen. 1 (*x) (𝓉p))) diff --git a/test/examples/ramanujanFact.apple b/test/examples/ramanujanFact.apple new file mode 100644 --- /dev/null +++ b/test/examples/ramanujanFact.apple @@ -0,0 +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)) diff --git a/test/examples/regress.apple b/test/examples/regress.apple new file mode 100644 --- /dev/null +++ b/test/examples/regress.apple @@ -0,0 +1,12 @@ +λxs.λys. +{ + Σ ← [(+)/x]; + n ⟜ ℝ(:xs); + xbar ⟜ (Σ xs) % n; ybar ⟜ (Σ ys) % n; + xy ⟜ Σ ((*)`xs ys); + x2 ⟜ Σ ((^2)'xs); + denom ⟜ (x2-n*(xbar^2)); + a ← ((ybar*x2)-(xbar*xy))%denom; + b ← (xy-(n*xbar*ybar))%denom; + (a,b) +} diff --git a/test/examples/risingFactorial.apple b/test/examples/risingFactorial.apple new file mode 100644 --- /dev/null +++ b/test/examples/risingFactorial.apple @@ -0,0 +1,1 @@ +[(*)/ₒ 1 (⍳ x (x+y-1) 1)] diff --git a/test/examples/shoelace.apple b/test/examples/shoelace.apple new file mode 100644 --- /dev/null +++ b/test/examples/shoelace.apple @@ -0,0 +1,1 @@ +λas.λbs. {sum ⇐ [(+)/x]; 0.5*abs.(sum((*)`as (1⊖bs)) - sum((*)`(1⊖as) bs))} diff --git a/test/examples/stepMnist.apple b/test/examples/stepMnist.apple new file mode 100644 --- /dev/null +++ b/test/examples/stepMnist.apple @@ -0,0 +1,29 @@ +-- x: 600000x784 +-- targets: 600000x10 +λx.λtargets. +λl1.λl2. + { + softmax ← λxs. + { m ⟜ (⋉)/* _1 xs; a ⟜ [e:(x-m)]`{0} xs + ; sum ← [(+)/x] + ; n ⟜ sum`{1} (a::M float) + ; ⍉(([(%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)) + }; + dsigmoid ← ((λx.⸎x⟜ℯ(_x);x%(1+x)^2)`{0}); + -- fw + xl1p ⟜ x%.l1; + xSigmoid ← [1%(1+ℯ(_x))]`{0} xl1p; + xl2p ⟜ xSigmoid%.l2; + out ← softmax xl2p; + -- bw + error ⟜ (*)`{0,0} ({n⟜ℝ(𝓉out); [2*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) + } diff --git a/test/examples/stirling.apple b/test/examples/stirling.apple new file mode 100644 --- /dev/null +++ b/test/examples/stirling.apple @@ -0,0 +1,1 @@ +\n.(√(2*𝜋))*n**(n+1%2)*(e:(_n)) diff --git a/test/examples/sum.apple b/test/examples/sum.apple new file mode 100644 --- /dev/null +++ b/test/examples/sum.apple @@ -0,0 +1,1 @@ +[(+)/ x] diff --git a/test/examples/trainMnist.apple b/test/examples/trainMnist.apple new file mode 100644 --- /dev/null +++ b/test/examples/trainMnist.apple @@ -0,0 +1,35 @@ +λtrainLabels.λtrainImages. +{ + 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; + train ← + λl1.λl2. + { + softmax ← λxs. + { m ⟜ (⋉)/* _1 xs; a ⟜ [e:(x-m)]`{0} xs + ; sum ← [(+)/x] + ; n ⟜ sum`{1} (a::M float) + ; ⍉(([(%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)) + }; + dsigmoid ← ((λx.⸎x⟜ℯ(_x);x%(1+x)^2)`{0}); + -- fw + xl1p ⟜ x%.l1; + xSigmoid ← [1%(1+ℯ(_x))]`{0} xl1p; + xl2p ⟜ xSigmoid%.l2; + out ← softmax xl2p; + -- bw + error ⟜ (*)`{0,0} ({n⟜ℝ(𝓉out); [2*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) + }; + [train (x->1) (x->2)]^:2 (l1init,l2init) +} diff --git a/test/examples/weekMean.apple b/test/examples/weekMean.apple new file mode 100644 --- /dev/null +++ b/test/examples/weekMean.apple @@ -0,0 +1,1 @@ +([((+)/x)%ℝ(:x)]\`7) diff --git a/test/examples/xor.apple b/test/examples/xor.apple new file mode 100644 --- /dev/null +++ b/test/examples/xor.apple @@ -0,0 +1,31 @@ +-- see: https://towardsdatascience.com/implementing-the-xor-gate-using-backpropagation-in-neural-networks-c1f255b4f20d +{ X ⟜ ⟨⟨0,0⟩,⟨0,1⟩,⟨1,0⟩,⟨1,1⟩⟩; + Y ⟜ ⟨0,1,1,0⟩; + sigmoid ← [1%(1+ℯ(_x))]; + sDdx ← [x*(1-x)]; + sum ⇐ [(+)/x]; + forward ← λwh.λwo.λbh.λbo. + -- ho: 4x2 + { ho ← sigmoid`{0} ([(+)`bh x]'(X%.wh)) + -- prediction: 4 + ; prediction ← sigmoid'((+bo)'(ho%:wo)) + ; (ho,prediction) + }; + -- wh: 2x2 wo: 2 bh: 2 bo: (scalar) + train ← λinp. + { wh ← inp->1; wo ← inp->2; bh ← inp->3; bo ← inp->4 + ; o ← forward wh wo bh bo + ; ho ⟜ o->1; prediction ⟜ o->2 + ; l1E ← (-)`prediction Y + ; 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Δ) + ; boa ← bo + sum l1Δ + ; (wha,woa,bha,boa) + }; + wh ← (𝔯_1 1)::Arr (2 × 2) float;wo ← 𝔯_1 1;bh ← 𝔯_1 1;bo ← 𝔯_1 1; + train^:10000 (wh,wo,bh,bo) +} diff --git a/test/harness/a_harness.c b/test/harness/a_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/a_harness.c @@ -0,0 +1,15 @@ +#include +#include +#include + +#include"../../include/apple_p.h" + +extern U a(U); + +int main(int argc, char *argv[]) { + F xs[] = {1,3,2,5}; + U x; + V(4,xs,x); + paf(a(x)); + free(x); +} diff --git a/test/harness/aa_harness.c b/test/harness/aa_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/aa_harness.c @@ -0,0 +1,15 @@ +#include +#include + +#include"../../include/apple_p.h" + +extern U aa(U); + +int main(int argc, char *argv[]) { + F xs[] = {0,1,1,2}; + J dx[] = {2,2}; + Af a = {2,dx,xs}; + U x = poke_af(a); + paf(aa(x)); + free(x); +} diff --git a/test/harness/aaa_harness.c b/test/harness/aaa_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/aaa_harness.c @@ -0,0 +1,19 @@ +#include +#include + +#include"../../include/apple_p.h" + +extern U aaa(U, U); + +int main(int argc, char *argv[]) { + F xs[] = {0,1,1,1}; + F ys[] = {1,1}; + J dx[] = {2,2}; + J dy[] = {2}; + Af a = {2,dx,xs}; + Af b = {1,dy,ys}; + U x = poke_af(a); + U y = poke_af(b); + paf(aaa(x,y)); + free(x);free(y); +} diff --git a/test/harness/aaafa_harness.c b/test/harness/aaafa_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/aaafa_harness.c @@ -0,0 +1,21 @@ +#include +#include + +#include"../../include/apple_p.h" + +extern U aaafa(U,U,U,F); + +int main(int argc, char *argv[]) { + F wh[] = {0.51426693,0.56885825,0.48725347,0.15041493}; + F wo[] = {0.14801747,0.37182892}; + F bh[] = {0.79726405,0.67601843}; + F bo = 0.57823076; + I dwh[] = {2,2}; + I dwo[] = {2};I dbh[] = {2}; + Af a = {2,dwh,wh}; + Af b = {1,dwo,wo}; + Af c = {1,dbh,bh}; + U x = poke_af(a);U y = poke_af(b);U z = poke_af(c); + paf(aaafa(x,y,z,bo)); + free(x);free(y);free(z); +} diff --git a/test/harness/aaf_harness.c b/test/harness/aaf_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/aaf_harness.c @@ -0,0 +1,11 @@ +#include +#include + +int main(int argc, char *argv[]) { + F xs[] = {0,4,4}; + F ys[] = {0,0,3}; + J d[] = {3}; + Af a = {1,d,xs}; + Af b = {1,d,ys}; + printf("%f", aaf_wrapper(a, b)); +} diff --git a/test/harness/aafa_harness.c b/test/harness/aafa_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/aafa_harness.c @@ -0,0 +1,19 @@ +#include +#include + +#include"../../include/apple_p.h" + +extern U aafa(U,U,F); + +int main(int argc, char *argv[]) { + F ho[] = {0.68938893, 0.66284947, 0.78321778, 0.69560025, 0.78776923, 0.77641173, 0.8580009, 0.80143567}; + F wo[] = {0.14801747,0.37182892}; + F bo = 0.57823076; + J dho[] = {4,2}; + J dwo[] = {2}; + Af a = {2,dho,ho}; + Af b = {1,dwo,wo}; + U x = poke_af(a);U y = poke_af(b); + paf(aafa(x,y,bo)); + free(x);free(y); +} diff --git a/test/harness/af_harness.c b/test/harness/af_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/af_harness.c @@ -0,0 +1,14 @@ +#include +#include +#include + +#include"../../include/apple_abi.h" + +extern F af(U); + +int main(int argc, char *argv[]) { + F xs[] = {4,8,8,8,8,8}; + U x; V(6,xs,x); + printf("%f\n", af(x)); + free(x); +} diff --git a/test/harness/ai_harness.c b/test/harness/ai_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/ai_harness.c @@ -0,0 +1,14 @@ +#include +#include +#include + +#include"../../include/apple_abi.h" + +extern J ai(U); + +int main(int argc, char *argv[]) { + F xs[] = {1,2,3,4,5,6,7,8,9,10}; + U x; V(6,xs,x); + printf("%lld\n", ai(x)); + free(x); +} diff --git a/test/harness/bha_harness.c b/test/harness/bha_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/bha_harness.c @@ -0,0 +1,19 @@ +#include +#include + +#include"../../include/apple_p.h" + +extern U bha(U, U); + +int main(int argc, char *argv[]) { + F xs[] = {0.79726405,0.67601843}; + F ys[] = {-0.00461325,-0.0120947,0.00140493,0.00440132,0.00133441,0.00348059,-0.00259046,-0.00849969}; + J dx[] = {2}; + J dy[] = {4,2}; + Af a = {1,dx,xs}; + Af b = {2,dy,ys}; + U x = poke_af(a); + U y = poke_af(b); + paf(bha(x,y)); + free(x);free(y); +} diff --git a/test/harness/conv_harness.c b/test/harness/conv_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/conv_harness.c @@ -0,0 +1,15 @@ +#include +#include + +#include"../../include/apple_p.h" + +extern U conv(U); + +int main(int argc, char *argv[]) { + F xs[] = {9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9}; + J dx[] = {4,4}; + Af a = {2,dx,xs}; + U x = poke_af(a); + paf(conv(x)); + free(x); +} diff --git a/test/harness/ff_harness.c b/test/harness/ff_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/ff_harness.c @@ -0,0 +1,10 @@ +#include +#include + +extern double ff(double); + +#define PI 3.14159265358979 + +int main(int argc, char *argv[]) { + printf("%f\n", ff(3*PI/2)); +} diff --git a/test/harness/fff_harness.c b/test/harness/fff_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/fff_harness.c @@ -0,0 +1,8 @@ +#include +#include + +extern double fff(double, double); + +int main(int argc, char *argv[]) { + printf("%f\n", fff(1.0,12.0)); +} diff --git a/test/harness/hyper_harness.c b/test/harness/hyper_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/hyper_harness.c @@ -0,0 +1,11 @@ +#include +#include + +int main(int argc, char *argv[]) { + F xs[] = {1}; + F ys[] = {1.5}; + J d[] = {1}; + Af a = {1,d,xs}; + Af b = {1,d,ys}; + printf("%f", hyper_wrapper(a, b, 1)); +} diff --git a/test/harness/iff_harness.c b/test/harness/iff_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/iff_harness.c @@ -0,0 +1,8 @@ +#include +#include + +extern double iff(int,double); + +int main(int argc, char *argv[]) { + printf("%f\n", iff(20,1.0)); +} diff --git a/test/harness/orbit_harness.c b/test/harness/orbit_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/orbit_harness.c @@ -0,0 +1,11 @@ +#include +#include + +#include"../../include/apple_p.h" + +extern U orbit(F,F); + +int main(int argc, char *argv[]) { + F a=2.576; F b=4.628; + paf(orbit(a,b)); +} diff --git a/test/harness/u_harness.c b/test/harness/u_harness.c new file mode 100644 --- /dev/null +++ b/test/harness/u_harness.c @@ -0,0 +1,11 @@ +#include +#include +#include + +#include"../../include/apple_p.h" + +extern U u(void); + +int main(int argc, char *argv[]) { + paf(u()); +}